X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=da143e3828af0c4289d608716c9a8951eafae2b1;hb=fcde5281a74cb29e21550f4f979ad6356f149ab9;hp=7a4e89efee69c049233d096742f791d2b74bf4cd;hpb=67d2b80e478824a46317419f076ab1f6b020f6b1;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 7a4e89e..da143e3 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -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))))
@@ -9,16 +19,21 @@
 (defmacro assert-t-t (expr)
   `(assert (equal '(t t) (multiple-value-list ,expr))))
 
+(defmacro assert-t-t-or-uncertain (expr)
+  `(assert (let ((list (multiple-value-list ,expr)))
+	     (or (equal '(nil nil) list)
+		 (equal '(t t) list)))))
+
 (let ((types '(character
 	       integer fixnum (integer 0 10)
 	       single-float (single-float -1.0 1.0) (single-float 0.1)
 	       (real 4 8) (real -1 7) (real 2 11)
+	       null symbol keyword
 	       (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
-	       ;; FIXME: When bug 91 is fixed, add these to the list:
-	       ;;   (INTEGER -1 1)
-	       ;;   UNSIGNED-BYTE
-	       ;;   (RATIONAL -1 7) (RATIONAL -2 4)
-	       ;;   RATIO
+	       (integer -1 1)
+	       unsigned-byte
+	       (rational -1 7) (rational -2 4)
+	       ratio
 	       )))
   (dolist (i types)
     (format t "type I=~S~%" i)
@@ -75,14 +90,10 @@
 ;;; 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))
@@ -170,6 +181,18 @@
 ;;; 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))
+
+;;; It turns out that, as of sbcl-0.7.2, we require to be able to
+;;; detect this to compile src/compiler/node.lisp (and in particular,
+;;; the definition of the component structure). Since it's a sensible
+;;; thing to want anyway, let's test for it here:
+(assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
+		      '(or some-undefined-type (member :no-ir2-yet :dead))))
+;;; BUG 158 (failure to compile loops with vector references and
+;;; increments of greater than 1) was a symptom of type system
+;;; uncertainty, to wit:
+(assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
+		      '(mod 536870911))) ; aka SB-INT:INDEX.
 
 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
@@ -325,6 +348,25 @@
   #.*tests-of-inline-type-tests*)
 (tests-of-inline-type-tests)
 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
-
+
+;;; 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))
+
+;;; 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))
+
 ;;; success
 (quit :unix-status 104)