X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=4b423bb0d5400c31116f10a2a8474a286e7877e3;hb=bcbbce86c47a1c530d488c7876a453100fcd933e;hp=fdd8fcabeba9cb3743087fc581e1c10d979a3916;hpb=e9618f8ea11045b8616a49338966eac44d9c92e6;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index fdd8fca..4b423bb 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -57,6 +57,11 @@
 
 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
 
+;;; Bug 50(c,d): numeric types with empty ranges should be NIL
+(assert (type-evidently-= 'nil '(integer (0) (0))))
+(assert (type-evidently-= 'nil '(rational (0) (0))))
+(assert (type-evidently-= 'nil '(float (0.0) (0.0))))
+
 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
@@ -101,13 +106,48 @@
 (assert (not (subtypep 'symbol 'keyword)))
 (assert (subtypep 'ratio 'real))
 (assert (subtypep 'ratio 'number))
+
+;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
+;;; to revisit this, perhaps by implementing a COMPLEMENT type
+;;; (analogous to UNION and INTERSECTION) to take the logic out of the
+;;; HAIRY domain.
+(assert-nil-t (subtypep 'atom 'cons))
+(assert-nil-t (subtypep 'cons 'atom))
+(assert-nil-t (subtypep '(not list) 'cons))
+(assert-nil-t (subtypep '(not float) 'single-float))
+(assert-t-t (subtypep '(not atom) 'cons))
+(assert-t-t (subtypep 'cons '(not atom)))
+;;; FIXME: Another thing to revisit is %INVOKE-TYPE-METHOD.
+;;; Essentially, the problem is that when the two arguments to
+;;; subtypep are of different specifier-type types (e.g. HAIRY and
+;;; UNION), there are two applicable type methods -- in this case
+;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
+;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD.  Both of these exist, but
+;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
+;;; them returns NIL, NIL (indicating uncertainty) it should try the
+;;; other; this is complicated by the presence of other TYPE-METHODS
+;;; (e.g. INTERSECTION and UNION) whose return convention may or may
+;;; not follow the same standard.
+#||
+(assert-nil-t (subtypep '(not cons) 'list))
+(assert-nil-t (subtypep '(not single-float) 'float))
+||#
+;;; If we fix the above FIXME, we should for free have fixed bug 58.
+#||
+(assert-t-t (subtypep '(and zilch integer) 'zilch))
+||#
+;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
+;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
+;;; corresponding to the NIL type-specifier; we were bogusly returning
+;;; NIL, T (indicating surety) for the following:
+(assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
 
-;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow
-;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally
-;;;; be nicer, and Martin Atzmueller ported the patches.
-;;;; They look nice but they're nontrivial enough that it's not obvious
-;;;; from inspection that everything is OK. Let's make sure that things
-;;;; still basically work.
+;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
+;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
+;;;; generally be nicer, and Martin Atzmueller ported the patches.
+;;;; They look nice but they're nontrivial enough that it's not
+;;;; obvious from inspection that everything is OK. Let's make sure
+;;;; that things still basically work.
 
 ;; structure type tests setup
 (defstruct structure-foo1)
@@ -149,6 +189,10 @@
      ;; structure type tests
      (assert (typep (make-structure-foo3) 'structure-foo2))
      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
+     (assert (typep (nth-value 1
+			       (ignore-errors (structure-foo2-x
+					       (make-structure-foo1))))
+		    'type-error))
      (assert (null (ignore-errors
 		     (setf (structure-foo2-x (make-structure-foo1)) 11))))
 
@@ -192,12 +236,17 @@
      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 							 'simple-condition)))
 		 (sb-pcl:find-class 'condition)))
-     (assert (null (set-difference
-		    (sb-pcl:class-direct-subclasses (sb-pcl:find-class
-						     'simple-condition))
-		    (mapcar #'sb-pcl:find-class
-			    '(simple-type-error simple-error
-						sb-int:simple-style-warning)))))
+
+    (let ((subclasses (mapcar #'sb-pcl:find-class
+                              '(simple-type-error
+                                simple-error
+                                simple-warning
+                                sb-int:simple-file-error
+                                sb-int:simple-style-warning))))
+      (assert (null (set-difference
+                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+                                                      'simple-condition))
+                     subclasses))))
 
      ;; precedence lists
      (assert (equal (sb-pcl:class-precedence-list