X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=91a1f696a2d1ccd184231bbd1a6d7b3be41c52b7;hb=db0110475c0db5dc3cb1bb12de0b0c475880899e;hp=73301f03e011a0d475e84b854fd3230c7b58b2a1;hpb=d1e7b48b17180a417c41ed55eb382ebf6d4e7a2a;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 73301f0..91a1f69 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -430,11 +430,17 @@
 ;;; 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)
@@ -558,4 +564,200 @@
              (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