+
;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
(test every)
(test notany)
(test notevery))))
+
+(with-test (:name :propagate-complex-type-tests)
+ (flet ((test (type value)
+ (let ((ftype (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (if (typep x ',type)
+ x
+ ',value))))))
+ (assert (typep ftype `(cons (eql function))))
+ (assert (= 3 (length ftype)))
+ (let* ((return (third ftype))
+ (rtype (second return)))
+ (assert (typep return `(cons (eql values)
+ (cons t
+ (cons (eql &optional)
+ null)))))
+ (assert (and (subtypep rtype type)
+ (subtypep type rtype)))))))
+ (mapc (lambda (params)
+ (apply #'test params))
+ `(((unsigned-byte 17) 0)
+ ((member 1 3 5 7) 5)
+ ((or symbol (eql 42)) t)))))
+
+(with-test (:name :constant-fold-complex-type-tests)
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (if (typep x '(member 1 3))
+ (typep x '(member 1 3 15))
+ t))))
+ `(function (t) (values (member t) &optional))))
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (declare (type (member 1 3) x))
+ (typep x '(member 1 3 15)))))
+ `(function ((or (integer 1 1) (integer 3 3)))
+ (values (member t) &optional)))))
+
+(with-test (:name :quietly-row-major-index-no-dimensions)
+ (assert (handler-case
+ (compile nil `(lambda (x) (array-row-major-index x)))
+ (warning () nil))))