-(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")
+(use-package "TEST-UTIL")
(defmacro assert-nil-nil (expr)
`(assert (equal '(nil nil) (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)))))
+ (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)
- (integer -1 1)
- unsigned-byte
- (rational -1 7) (rational -2 4)
- ratio
- )))
+ 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)
+ (member #\a #\c #\d #\f) (integer -1 1)
+ unsigned-byte
+ (rational -1 7) (rational -2 4)
+ ratio
+ )))
(dolist (i types)
(format t "type I=~S~%" i)
(dolist (j types)
(assert (subtypep i `(or ,i ,i ,j)))
(assert (subtypep i `(or ,j ,i)))
(dolist (k types)
- (format t " type K=~S~%" k)
- (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
- (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
+ (format t " type K=~S~%" k)
+ (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
+ (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
;;; gotchas that can come up in handling subtypeness as "X is a
;;; subtype of Y if each of the elements of X is a subtype of Y"
(let ((subtypep-values (multiple-value-list
- (subtypep '(single-float -1.0 1.0)
- '(or (real -100.0 0.0)
- (single-float 0.0 100.0))))))
+ (subtypep '(single-float -1.0 1.0)
+ '(or (real -100.0 0.0)
+ (single-float 0.0 100.0))))))
(assert (member subtypep-values
- '(;; The system isn't expected to
- ;; understand the subtype relationship.
- (nil nil)
- ;; But if it does, that'd be neat.
- (t t)
- ;; (And any other return would be wrong.)
- )
- :test #'equal)))
+ '(;; The system isn't expected to
+ ;; understand the subtype relationship.
+ (nil nil)
+ ;; But if it does, that'd be neat.
+ (t t)
+ ;; (And any other return would be wrong.)
+ )
+ :test #'equal)))
(defun type-evidently-= (x y)
(and (subtypep x y)
(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)))
+;;; and while it doesn't specifically disallow illegal compound
+;;; specifiers from the CL package, we don't have any.
+(assert (raises-error? (subtypep 'fixnum '(fixnum 1))))
+(assert (raises-error? (subtypep 'class '(list))))
+(assert (raises-error? (subtypep 'foo '(ratio 1/2 3/2))))
+(assert (raises-error? (subtypep 'character '(character 10))))
+#+nil ; doesn't yet work on PCL-derived internal types
+(assert (raises-error? (subtypep 'lisp '(class))))
+#+nil
+(assert (raises-error? (subtypep 'bar '(method number number))))
+
;;; 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)))
;;; 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))))
+ '(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.
+ '(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 (typep (make-structure-foo3) 'structure-foo2))
(assert (not (typep (make-structure-foo1) 'structure-foo4)))
(assert (typep (nth-value 1
- (ignore-errors (structure-foo2-x
- (make-structure-foo1))))
- 'type-error))
+ (ignore-errors (structure-foo2-x
+ (make-structure-foo1))))
+ 'type-error))
(assert (null (ignore-errors
- (setf (structure-foo2-x (make-structure-foo1)) 11))))
+ (setf (structure-foo2-x (make-structure-foo1)) 11))))
;; structure-class tests
(assert (typep (make-instance 'structure-class-foo3)
- 'structure-class-foo2))
+ 'structure-class-foo2))
(assert (not (typep (make-instance 'structure-class-foo1)
- 'structure-class-foo4)))
+ 'structure-class-foo4)))
(assert (null (ignore-errors
- (setf (slot-value (make-instance 'structure-class-foo1)
- 'x)
- 11))))
+ (setf (slot-value (make-instance 'structure-class-foo1)
+ 'x)
+ 11))))
;; standard-class tests
(assert (typep (make-instance 'standard-class-foo3)
- 'standard-class-foo2))
+ 'standard-class-foo2))
(assert (not (typep (make-instance 'standard-class-foo1)
- 'standard-class-foo4)))
+ 'standard-class-foo4)))
(assert (null (ignore-errors
- (setf (slot-value (make-instance 'standard-class-foo1) 'x)
- 11))))
+ (setf (slot-value (make-instance 'standard-class-foo1) 'x)
+ 11))))
;; condition tests
(assert (typep (make-condition 'condition-foo3)
- 'condition-foo2))
+ 'condition-foo2))
(assert (not (typep (make-condition 'condition-foo1)
- 'condition-foo4)))
+ 'condition-foo4)))
(assert (null (ignore-errors
- (setf (slot-value (make-condition 'condition-foo1) 'x)
- 11))))
+ (setf (slot-value (make-condition 'condition-foo1) 'x)
+ 11))))
(assert (subtypep 'error 't))
(assert (subtypep 'simple-condition 'condition))
(assert (subtypep 'simple-error 'simple-condition))
(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
- (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
- '(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
- 'simple-condition))
- subclasses))))
+ (assert (eq (car (sb-pcl:class-direct-superclasses
+ (find-class 'simple-condition)))
+ (find-class 'condition)))
+
+ #+nil ; doesn't look like a good test
+ (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 (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
+ 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
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(standard-object stream))))
+ (assert (equal (sb-pcl:class-direct-superclasses (find-class
+ 'fundamental-stream))
+ (mapcar #'find-class '(standard-object stream))))
(assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl: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
- '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
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-stream
- standard-object
- sb-pcl::std-object
- sb-pcl::slot-object stream
- sb-kernel:instance t))))
+ (sb-pcl:class-direct-subclasses (find-class
+ 'fundamental-stream))
+ (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 #'find-class '(fundamental-stream
+ standard-object
+ sb-pcl::slot-object
+ stream
+ t))))
+ (assert (equal (sb-pcl:class-precedence-list (find-class
+ 'fundamental-stream))
+ (mapcar #'find-class '(fundamental-stream
+ standard-object
+ sb-pcl::slot-object stream
+ t))))
(assert (subtypep (find-class 'stream) (find-class t)))
(assert (subtypep (find-class 'fundamental-stream) 'stream))
(assert (not (subtypep 'stream 'fundamental-stream)))))
(aref x 1))
(deftype bar () 'single-float)
(assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
- 0.0f0))
+ 0.0f0))
+
+;;; bug 260a
+(assert-t-t
+ (let* ((s (gensym))
+ (t1 (sb-kernel:specifier-type s)))
+ (eval `(defstruct ,s))
+ (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
+
+;;; bug found by PFD's random subtypep tester
+(let ((t1 '(cons rational (cons (not rational) (cons integer t))))
+ (t2 '(not (cons (integer 0 1) (cons single-float long-float)))))
+ (assert-t-t (subtypep t1 t2))
+ (assert-nil-t (subtypep t2 t1))
+ (assert-t-t (subtypep `(not ,t2) `(not ,t1)))
+ (assert-nil-t (subtypep `(not ,t1) `(not ,t2))))
+\f
+;;; not easily visible to user code, but this used to be very
+;;; confusing.
+(with-test (:name (:ctor :typep-function))
+ (assert (eval '(typep (sb-pcl::ensure-ctor
+ (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 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
-(quit :unix-status 104)
projects / sbcl.git / blobdiff