Commit 978d0344 authored by pfdietz's avatar pfdietz

Added more subtypep/disjointness tests, for structures, float types, and fixnums.

parent 897dce2e
......@@ -143,25 +143,40 @@ Results: ~A~%" expected-number form n results))))
;;; Assumes the types are nonempty.
(defun check-disjointness (type1 type2)
(remove 'nil
(list
(check-subtypep type1 type2 nil)
(check-subtypep type2 type1 nil)
(check-subtypep type1 `(not ,type2) t)
(check-subtypep type2 `(not ,type1) t)
(check-subtypep `(and ,type1 ,type2) nil t)
(check-subtypep `(and ,type2 ,type1) nil t)
(check-subtypep `(and ,type1 (not ,type2)) type1 t)
(check-subtypep `(and (not ,type2) ,type1) type1 t)
(check-subtypep `(and ,type2 (not ,type1)) type2 t)
(check-subtypep `(and (not ,type1) ,type2) type2 t)
(check-subtypep type1 `(or ,type1 (not ,type2)) t)
(check-subtypep type1 `(or (not ,type2) ,type1) t)
(check-subtypep type2 `(or ,type2 (not ,type1)) t)
(check-subtypep type2 `(or (not ,type1) ,type2) t)
(check-subtypep t `(or (not ,type1) (not ,type2)) t)
(check-subtypep t `(or (not ,type2) (not ,type1)) t)
)))
(append
(check-subtypep type1 type2 nil)
(check-subtypep type2 type1 nil)
(check-subtypep type1 `(not ,type2) t)
(check-subtypep type2 `(not ,type1) t)
(check-subtypep `(and ,type1 ,type2) nil t)
(check-subtypep `(and ,type2 ,type1) nil t)
(check-subtypep `(and ,type1 (not ,type2)) type1 t)
(check-subtypep `(and (not ,type2) ,type1) type1 t)
(check-subtypep `(and ,type2 (not ,type1)) type2 t)
(check-subtypep `(and (not ,type1) ,type2) type2 t)
;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t)
;;; (check-subtypep type1 `(or (not ,type2) ,type1) t)
;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t)
;;; (check-subtypep type2 `(or (not ,type1) ,type2) t)
(check-subtypep t `(or (not ,type1) (not ,type2)) t)
(check-subtypep t `(or (not ,type2) (not ,type1)) t)
))
(defun check-equivalence (type1 type2)
(append
(check-subtypep type1 type2 t)
(check-subtypep type2 type1 t)
(check-subtypep `(not ,type1) `(not ,type2) t)
(check-subtypep `(not ,type2) `(not ,type1) t)
(check-subtypep `(and ,type1 (not ,type2)) nil t)
(check-subtypep `(and ,type2 (not ,type1)) nil t)
(check-subtypep `(and (not ,type2) ,type1) nil t)
(check-subtypep `(and (not ,type1) ,type2) nil t)
(check-subtypep t `(or ,type1 (not ,type2)) t)
(check-subtypep t `(or ,type2 (not ,type1)) t)
(check-subtypep t `(or (not ,type2) ,type1) t)
(check-subtypep t `(or (not ,type1) ,type2) t)))
(defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
(multiple-value-bind
......@@ -172,7 +187,7 @@ Results: ~A~%" expected-number form n results))))
(if (or (and valid sub (not is-sub))
(and valid (not sub) is-sub)
(and (not valid) should-be-valid))
`((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid)
`(((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid))
nil)))
(defun check-type-predicate (P TYPE)
......
......@@ -114,6 +114,113 @@
(values t t))
t t)
(deftest subtypep.fixnum-or-bignum
(check-equivalence '(or fixnum bignum) 'integer)
nil)
(deftest subtypep.integer.1
(subtypep* '(integer 0 10) '(integer 0 20))
t t)
(deftest subtypep.integer.2
(subtypep* '(integer 0 10) '(integer 0 (10)))
nil t)
(deftest subtypep.float.1
(loop for tp in +float-types+
append (check-subtypep tp 'float t t))
nil)
(deftest subtypep.float.2
(if (subtypep 'short-float 'long-float)
(loop for tp in +float-types+
append
(loop for tp2 in +float-types+
append (check-subtypep tp tp2 t t)))
nil)
nil)
(deftest subtypep.float.3
(if (and (not (subtypep 'short-float 'single-float))
(subtypep 'single-float 'long-float))
(append
(check-equivalence 'single-float 'double-float)
(check-equivalence 'single-float 'long-float)
(check-equivalence 'double-float 'long-float)
(check-disjointness 'short-float 'single-float)
(check-disjointness 'short-float 'double-float)
(check-disjointness 'short-float 'long-float))
nil)
nil)
(deftest subtypep.float.4
(if (and (subtypep 'single-float 'short-float)
(subtypep 'double-float 'long-float)
(not (subtypep 'short-float 'double-float)))
(append
(check-equivalence 'short-float 'single-float)
(check-equivalence 'double-float 'long-float)
(loop for tp in '(short-float single-float)
append
(loop for tp2 in '(double-float long-float)
append (check-disjointness tp tp2))))
nil)
nil)
(deftest subtypep.float.5
(if (and (not (subtypep 'single-float 'short-float))
(not (subtypep 'single-float 'double-float))
(subtypep 'double-float 'long-float))
(append
(check-disjointness 'short-float 'single-float)
(check-disjointness 'short-float 'double-float)
(check-disjointness 'short-float 'long-float)
(check-disjointness 'single-float 'double-float)
(check-disjointness 'single-float 'long-float)
(check-equivalence 'double-float 'long-float))
nil)
nil)
(deftest subtypep.float.6
(if (and (subtypep 'single-float 'short-float)
(not (subtypep 'single-float 'double-float))
(not (subtypep 'double-float 'long-float)))
(append
(check-equivalence 'short-float 'single-float)
(check-disjointness 'single-float 'double-float)
(check-disjointness 'single-float 'long-float)
(check-disjointness 'double-float 'long-float))
nil)
nil)
(deftest subtypep.float.7
(if (and (not (subtypep 'single-float 'short-float))
(not (subtypep 'single-float 'double-float))
(not (subtypep 'double-float 'long-float)))
(loop for tp in +float-types+
append
(loop for tp2 in +float-types+
unless (eq tp tp2)
append (check-disjointness tp tp2)))
nil)
nil)
(deftest subtypep.float.8
(subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0))
t t)
(deftest subtypep.float.9
(subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0))
t t)
(deftest subtypep.float.10
(subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0))
t t)
(deftest subtypep.float.11
(subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0))
t t)
;;; SUBTYPEP on CONS types
(defvar *cons-types*
......
......@@ -198,7 +198,23 @@
(deftest user-class-disjointness-2
(check-disjointness 'tac-1a-class 'tac-1b-class)
nil)
nil)
(defstruct tac-2-struct a b c)
(defstruct (tac-2a-struct (:include tac-2-struct)) d e)
(defstruct (tac-2b-struct (:include tac-2-struct)) f g)
(deftest user-struct-disjointness
(loop for l in *disjoint-types-list2*
append
(loop
for type in l
append (check-disjointness type 'tac-2-struct)))
nil)
(deftest user-struct-disjointness-2
(check-disjointness 'tac-2a-struct 'tac-2b-struct)
nil)
(deftest integer-and-ratio-are-disjoint
(classes-are-disjoint 'integer 'ratio)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment