;;; 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)
(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)))))
+
;;; success