0.8.0.62:
[sbcl.git] / tests / type.impure.lisp
index 8b9a67c..294659f 100644 (file)
@@ -1,6 +1,16 @@
-(in-package :cl-user)
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
 
 (load "assertoid.lisp")
+(use-package "ASSERTOID")
 
 (defmacro assert-nil-nil (expr)
   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
 ;;; part I: TYPEP
 (assert (typep #(11) '(simple-array t 1)))
 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
-;;; FIXME: This is broken because of compiler bug 123: the compiler
-;;; optimizes the type test to T, so it never gets a chance to raise a
-;;; runtime error. (It used to work under the IR1 interpreter just
-;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard
-;;; as the byte compiler does.)
-#+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
+(assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
 (assert (not (typep 11 '(simple-array undef-type 1))))
 ;;; part II: SUBTYPEP
+
 (assert (subtypep '(vector some-undef-type) 'vector))
 (assert (not (subtypep '(vector some-undef-type) 'integer)))
 (assert-nil-nil (subtypep 'utype-1 'utype-2))
 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
 
 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
-#| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.7.2.
 (assert (raises-error? (typep 11 'and)))
 (assert (raises-error? (typep 11 'or)))
-|#
+(assert (raises-error? (typep 11 'member)))
+(assert (raises-error? (typep 11 'values)))
+(assert (raises-error? (typep 11 'eql)))
+(assert (raises-error? (typep 11 'satisfies)))
+(assert (raises-error? (typep 11 'not)))
+
 ;;; Of course empty lists of subtypes are still OK.
 (assert (typep 11 '(and)))
 (assert (not (typep 11 '(or))))
 ;;; HAIRY domain.
 (assert-nil-t (subtypep 'atom 'cons))
 (assert-nil-t (subtypep 'cons 'atom))
+;;; These two are desireable but not necessary for ANSI conformance;
+;;; maintenance work on other parts of the system broke them in
+;;; sbcl-0.7.13.11 -- CSR
+#+nil
 (assert-nil-t (subtypep '(not list) 'cons))
+#+nil
 (assert-nil-t (subtypep '(not float) 'single-float))
 (assert-t-t (subtypep '(not atom) 'cons))
 (assert-t-t (subtypep 'cons '(not atom)))
 ;;; uncertainty, to wit:
 (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
                      '(mod 536870911))) ; aka SB-INT:INDEX.
+;;; floating point types can be tricky.
+(assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
+(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
+(assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
+
+(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
+(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
+(assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
+(assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
+(assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
+
+(assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
+(assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
+
+(assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
+(assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
+
+(assert-t-t (subtypep '(float -0.0) '(float 0.0)))
+(assert-t-t (subtypep '(float 0.0) '(float -0.0)))
+(assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
+(assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))
 \f
 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
      (assert (subtypep 'simple-error 'error))
      (assert (not (subtypep 'condition 'simple-condition)))
      (assert (not (subtypep 'error 'simple-error)))
-     (assert (eq (car (sb-kernel:class-direct-superclasses
+     (assert (eq (car (sb-pcl:class-direct-superclasses
                       (find-class 'simple-condition)))
                 (find-class 'condition)))
 
-     (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
-                                                        'simple-condition)))
-                (sb-pcl:find-class 'condition)))
-
-    (let ((subclasses (mapcar #'sb-pcl:find-class
+    (let ((subclasses (mapcar #'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
+                     (sb-pcl:class-direct-subclasses (find-class
                                                       'simple-condition))
                      subclasses))))
 
      ;; precedence lists
      (assert (equal (sb-pcl:class-precedence-list
-                    (sb-pcl:find-class 'simple-condition))
-                   (mapcar #'sb-pcl:find-class '(simple-condition
-                                                 condition
-                                                 sb-kernel:instance
-                                                 t))))
+                    (find-class 'simple-condition))
+                   (mapcar #'find-class '(simple-condition
+                                          condition
+                                          sb-pcl::slot-object
+                                          sb-kernel:instance
+                                          t))))
 
      ;; stream classes
-     (assert (null (sb-kernel:class-direct-superclasses
-                   (find-class 'fundamental-stream))))
-     (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+     (assert (equal (sb-pcl:class-direct-superclasses (find-class
                                                       'fundamental-stream))
-                   (mapcar #'sb-pcl:find-class '(standard-object stream))))
+                   (mapcar #'find-class '(standard-object stream))))
      (assert (null (set-difference
-                   (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+                   (sb-pcl:class-direct-subclasses (find-class
                                                     'fundamental-stream))
-                   (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
-                                                 fundamental-character-stream
-                                                 fundamental-output-stream
-                                                 fundamental-input-stream)))))
-     (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+                   (mapcar #'find-class '(fundamental-binary-stream
+                                          fundamental-character-stream
+                                          fundamental-output-stream
+                                          fundamental-input-stream)))))
+     (assert (equal (sb-pcl:class-precedence-list (find-class
                                                   'fundamental-stream))
-                   (mapcar #'sb-pcl:find-class '(fundamental-stream
-                                                 standard-object
-                                                 sb-pcl::std-object
-                                                 sb-pcl::slot-object
-                                                 stream
-                                                 sb-kernel:instance
-                                                 t))))
-     (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+                   (mapcar #'find-class '(fundamental-stream
+                                          standard-object
+                                          sb-pcl::std-object
+                                          sb-pcl::slot-object
+                                          stream
+                                          sb-kernel:instance
+                                          t))))
+     (assert (equal (sb-pcl:class-precedence-list (find-class
                                                   'fundamental-stream))
-                   (mapcar #'sb-pcl:find-class '(fundamental-stream
-                                                 standard-object
-                                                 sb-pcl::std-object
-                                                 sb-pcl::slot-object stream
-                                                 sb-kernel:instance t))))
+                   (mapcar #'find-class '(fundamental-stream
+                                          standard-object
+                                          sb-pcl::std-object
+                                          sb-pcl::slot-object stream
+                                          sb-kernel:instance t))))
      (assert (subtypep (find-class 'stream) (find-class t)))
      (assert (subtypep (find-class 'fundamental-stream) 'stream))
      (assert (not (subtypep 'stream 'fundamental-stream)))))
 (tests-of-inline-type-tests)
 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 \f
-#|| Pending fix for bug 176, bug 140 has been unfixed
 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 (defclass superclass () ())
+(defclass maybe-subclass () ())
+(assert-nil-t (subtypep 'maybe-subclass 'superclass))
 (defclass maybe-subclass (superclass) ())
 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 (defclass maybe-subclass () ())
 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
-||#
+\f
+;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
+;;; specialized on some as-yet-undefined type which would cause this
+;;; program to fail (bugs #123 and #165). Verify that it doesn't.
+(defun foo (x)
+  (declare (type (vector bar) x))
+  (aref x 1))
+(deftype bar () 'single-float)
+(assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
+            0.0f0))
 \f
 ;;; success
 (quit :unix-status 104)