'fundamental-stream))
(mapcar #'find-class '(fundamental-stream
standard-object
- sb-pcl::std-object
sb-pcl::slot-object
stream
t))))
'fundamental-stream))
(mapcar #'find-class '(fundamental-stream
standard-object
- sb-pcl::std-object
sb-pcl::slot-object stream
t))))
(assert (subtypep (find-class 'stream) (find-class t)))
;;; 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)))))
+\f
+;;; 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))))))
+\f
+(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)))
+\f
+;;; 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))
+\f
+;;; 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)))
+\f
+;;; 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)))))
+\f
+;;; 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))))
\f
+(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
projects / sbcl.git / blobdiff