X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=91a1f696a2d1ccd184231bbd1a6d7b3be41c52b7;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=b2ac327a957282f2dbe57a31dabc8d3ed9ccb1f6;hpb=34664ac9b1d27f0dff2514c388cf10813a9b1108;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index b2ac327..91a1f69 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -354,7 +354,6 @@
                     (mapcar #'find-class '(simple-condition
                                            condition
                                            sb-pcl::slot-object
-                                           sb-kernel:instance
                                            t))))
 
      ;; stream classes
@@ -372,18 +371,15 @@
                                                    'fundamental-stream))
                     (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 #'find-class '(fundamental-stream
                                            standard-object
-                                           sb-pcl::std-object
                                            sb-pcl::slot-object stream
-                                           sb-kernel:instance t))))
+                                           t))))
      (assert (subtypep (find-class 'stream) (find-class t)))
      (assert (subtypep (find-class 'fundamental-stream) 'stream))
      (assert (not (subtypep 'stream 'fundamental-stream)))))
@@ -434,10 +430,334 @@
 ;;; confusing.
 (with-test (:name (:ctor :typep-function))
   (assert (eval '(typep (sb-pcl::ensure-ctor
-                         (list 'sb-pcl::ctor (gensym)) nil nil)
+                         (list 'sb-pcl::ctor (gensym)) nil nil nil)
                         'function))))
 (with-test (:name (:ctor :functionp))
   (assert (functionp (sb-pcl::ensure-ctor
-                      (list 'sb-pcl::ctor (gensym)) nil nil))))
+                      (list 'sb-pcl::ctor (gensym)) nil nil nil))))
+;;; some new (2008-10-03) ways of going wrong...
+(with-test (:name (:ctor-allocate-instance :typep-function))
+  (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor))
+                        'function))))
+(with-test (:name (:ctor-allocate-instance :functionp))
+  (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor)))))
+
+;;; from PFD ansi-tests
+(let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
+                       (integer -234496 215373))
+                 integer))
+      (t2 '(cons (cons (cons integer integer)
+                       (integer -234496 215373))
+                 t)))
+  (assert (null (values (subtypep `(not ,t2) `(not ,t1))))))
+
+(defstruct misc-629a)
+(defclass misc-629b () ())
+(defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
+
+(assert (typep (make-misc-629a) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
+                        nil))
+(let ((misc-629a (make-misc-629a)))
+  (assert-t-t (subtypep `(member ,misc-629a)
+                        `(and (member ,misc-629a) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629a)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
+                      'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
+                          sb-kernel:instance)
+                        nil))
+(let ((misc-629b (make-instance 'misc-629b)))
+  (assert-t-t (subtypep `(member ,misc-629b)
+                        `(and (member ,misc-629b) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629b)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
+                      'sb-kernel:funcallable-instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
+                          sb-kernel:funcallable-instance)
+                        nil))
+(let ((misc-629c (make-instance 'misc-629c)))
+  (assert-t-t (subtypep `(member ,misc-629c)
+                        `(and (member ,misc-629c)
+                          sb-kernel:funcallable-instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629c)
+                          sb-kernel:instance)
+                        nil)))
+
+;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
+;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
+;;; subclass, so SUBTYPEP must be prepared to deal with
+(defclass ansi-tests-defclass1 () ())
+(defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
+(make-instance 'ansi-tests-defclass1)
+(assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
 
+;;; so was this
+(let ((class (eval '(defclass to-be-type-ofed () ()))))
+  (setf (find-class 'to-be-type-ofed) nil)
+  (assert (eq (type-of (make-instance class)) class)))
+
+;;; accuracy of CONS :SIMPLE-TYPE-=
+(deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
+(deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 integer)))
+  (assert ok)
+  (assert win))
+
+;; See FIXME in type method for CONS :SIMPLE-TYPE-=
+#+nil
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 single-float)))
+  (assert (not ok))
+  (assert win))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach2 single-float)))
+  (assert (not ok))
+  (assert (not win)))
+
+;;; precise unions of array types (was bug 306a)
+(defun bug-306-a (x)
+  (declare (optimize speed)
+           (type (or (array cons) (array vector)) x))
+  (elt (aref x 0) 0))
+(assert (= 0 (bug-306-a #((0)))))
+
+;;; FUNCALLABLE-INSTANCE is a subtype of function.
+(assert-t-t (subtypep '(and pathname function) nil))
+(assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
+(assert (not (subtypep '(and stream function) nil)))
+(assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
+(assert (not (subtypep '(and function standard-object) nil)))
+(assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
+
+;;; also, intersections of classes with INSTANCE should not be too
+;;; general
+(assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
+(assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
+
+(assert-t-t
+ (subtypep '(or simple-array simple-string) '(or simple-string simple-array)))
+(assert-t-t
+ (subtypep '(or simple-string simple-array) '(or simple-array simple-string)))
+(assert-t-t
+ (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
+           '(or fixnum vector end-of-file parse-error fixnum simple-string)))
+
+#+sb-eval
+(assert-t-t
+ (subtypep '(and function (not compiled-function)
+             (not sb-eval:interpreted-function))
+           nil))
+
+;;; weakening of union type checks
+(defun weaken-union-1 (x)
+  (declare (optimize speed))
+  (car x))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-1 "askdjhasdkj"))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+(defun weaken-union-2 (x)
+  (declare (optimize speed)
+           (type (or cons fixnum) x))
+  (etypecase x
+    (fixnum x)
+    (cons
+     (setf (car x) 3)
+     x)))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-2 "asdkahsdkhj"))
+  (assert (not res))
+  (assert (typep err 'type-error))
+  (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
+              (equal '(or fixnum cons) (type-error-expected-type err)))))
+
+;;; TYPEXPAND & Co
+
+(deftype a-deftype (arg)
+  `(cons (eql ,arg) *))
+
+(deftype another-deftype (arg)
+  `(a-deftype ,arg))
+
+(deftype list-of-length (length &optional element-type)
+  (assert (not (minusp length)))
+  (if (zerop length)
+      'null
+      `(cons ,element-type (list-of-length ,(1- length) ,element-type))))
+
+(with-test (:name :typexpand-1)
+  (multiple-value-bind (expansion-1 expandedp-1)
+      (sb-ext:typexpand-1 '(another-deftype symbol))
+    (assert expandedp-1)
+    (assert (equal expansion-1 '(a-deftype symbol)))
+    (multiple-value-bind (expansion-2 expandedp-2)
+        (sb-ext:typexpand-1 expansion-1)
+      (assert expandedp-2)
+      (assert (equal expansion-2 '(cons (eql symbol) *)))
+      (multiple-value-bind (expansion-3 expandedp-3)
+          (sb-ext:typexpand-1 expansion-2)
+        (assert (not expandedp-3))
+        (assert (eq expansion-2 expansion-3))))))
+
+(with-test (:name :typexpand.1)
+  (multiple-value-bind (expansion-1 expandedp-1)
+      (sb-ext:typexpand '(another-deftype symbol))
+    (assert expandedp-1)
+    (assert (equal expansion-1 '(cons (eql symbol) *)))
+    (multiple-value-bind (expansion-2 expandedp-2)
+        (sb-ext:typexpand expansion-1)
+      (assert (not expandedp-2))
+      (assert (eq expansion-1 expansion-2)))))
+
+(with-test (:name :typexpand.2)
+  (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum))
+                 '(cons fixnum (list-of-length 2 fixnum)))))
+
+(with-test (:name :typexpand-all)
+  (assert (equal (sb-ext:typexpand-all '(list-of-length 3))
+                 '(cons t (cons t (cons t null)))))
+  (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum))
+                 '(cons fixnum (cons fixnum (cons fixnum null))))))
+
+(defclass a-deftype () ())
+
+(with-test (:name (:typexpand-1 :after-type-redefinition-to-class))
+  (multiple-value-bind (expansion expandedp)
+      (sb-ext:typexpand-1 '#1=(a-deftype symbol))
+    (assert (not expandedp))
+    (assert (eq expansion '#1#))))
+
+
+(with-test (:name :defined-type-name-p)
+  (assert (not (sb-ext:defined-type-name-p '#:foo)))
+  (assert (sb-ext:defined-type-name-p 'a-deftype))
+  (assert (sb-ext:defined-type-name-p 'structure-foo1))
+  (assert (sb-ext:defined-type-name-p 'structure-class-foo1))
+  (assert (sb-ext:defined-type-name-p 'standard-class-foo1))
+  (assert (sb-ext:defined-type-name-p 'condition-foo1))
+  (dolist (prim-type '(t nil fixnum cons atom))
+    (assert (sb-ext:defined-type-name-p prim-type))))
+
+
+(with-test (:name :valid-type-specifier-p)
+  (macrolet ((yes (form) `(assert ,form))
+             (no  (form) `(assert (not ,form))))
+    (no  (sb-ext:valid-type-specifier-p '(cons #(frob) *)))
+    (no  (sb-ext:valid-type-specifier-p 'list-of-length))
+    (no  (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x))))
+    (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum)))
+
+    (yes (sb-ext:valid-type-specifier-p 'structure-foo1))
+    (no  (sb-ext:valid-type-specifier-p '(structure-foo1 x)))
+    (yes (sb-ext:valid-type-specifier-p 'condition-foo1))
+    (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1))
+    (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1))
+
+    (yes (sb-ext:valid-type-specifier-p 'readtable))
+    (no  (sb-ext:valid-type-specifier-p '(readtable)))
+    (no  (sb-ext:valid-type-specifier-p '(readtable x)))
+
+    (yes (sb-ext:valid-type-specifier-p '(values)))
+    (no  (sb-ext:valid-type-specifier-p 'values))
+    (yes (sb-ext:valid-type-specifier-p '(and)))
+    (no  (sb-ext:valid-type-specifier-p 'and))))
+
+(with-test (:name (:valid-type-specifier-p :introspection-test))
+  (flet ((map-functions (fn)
+           (do-all-symbols (s)
+             (when (and (fboundp s)
+                        (not (macro-function s))
+                        (not (special-operator-p s)))
+               (funcall fn s)))))
+    (map-functions
+     #'(lambda (s)
+         (let* ((fun   (sb-kernel:%fun-fun (fdefinition s)))
+                (ftype (sb-kernel:%simple-fun-type fun)))
+           (unless (sb-ext:valid-type-specifier-p ftype)
+             (format *error-output*
+                     "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>"
+                     'sb-ext:valid-type-specifier-p
+                     s
+                     ftype )
+             (error "FAILURE")))))))
+
+(with-test (:name (:bug-309128 1))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 2))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 3))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s))
+         (s2 (gensym))
+         (t2 (sb-kernel:specifier-type s2)))
+    (eval `(deftype ,s2 () ',s))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
+      (assert (and ok sure)))))
+
+(with-test (:name :unknown-type-not=-for-sure)
+  (let* ((type (gensym "FOO"))
+         (spec1 (sb-kernel:specifier-type `(vector ,type)))
+         (spec2 (sb-kernel:specifier-type `(vector single-float))))
+    (eval `(deftype ,type () 'double-float))
+    (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2)
+      (assert (not ok))
+      (assert sure))))
+
+(defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ())
+(defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ())
+(defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ())
+(defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ())
+(with-test (:name (:subtypep :forward-referenced-classes))
+  (flet ((test (c1 c2 b1 b2)
+           (multiple-value-bind (x1 x2) (subtypep c1 c2)
+             (unless (and (eq b1 x1) (eq b2 x2))
+               (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S"
+                      c1 c2 x1 x2 b1 b2)))))
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t)
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil)
+
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t)
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil)
+
+    (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t)
+    (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t)
+    (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil)
+    (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil)
+
+    (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil)
+    (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t)))
+
 ;;; success