(assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a)))
(assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error))
-(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b)))
+(assert (equal (check-embedded-thes 1 0 3 :b) '(3 :b)))
(assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error))
(assert (eq :two (type-error-datum e)))
(assert (eq 'number (type-error-expected-type e)))
:error))))))
+
+(with-test (:name :compiled-debug-funs-leak)
+ (sb-ext:gc :full t)
+ (let ((usage-before (sb-kernel::dynamic-usage)))
+ (dotimes (x 10000)
+ (let ((f (compile nil '(lambda ()
+ (error "X")))))
+ (handler-case
+ (funcall f)
+ (error () nil))))
+ (sb-ext:gc :full t)
+ (let ((usage-after (sb-kernel::dynamic-usage)))
+ (when (< (+ usage-before 2000000) usage-after)
+ (error "Leak")))))
+
+;;; PROGV compilation and type checking when the declared type
+;;; includes a FUNCTION subtype.
+(declaim (type (or (function (t) (values boolean &optional)) string)
+ *hairy-progv-var*))
+(defvar *hairy-progv-var* #'null)
+(with-test (:name :hairy-progv-type-checking)
+ (assert (eq :error
+ (handler-case
+ (progv '(*hairy-progv-var*) (list (eval 42))
+ *hairy-progv-var*)
+ (type-error () :error))))
+ (assert (equal "GOOD!"
+ (progv '(*hairy-progv-var*) (list (eval "GOOD!"))
+ *hairy-progv-var*))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(setf *mystery* :mystery)
(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
+;;; optimizing make-array
+(defun count-code-callees (f)
+ (let ((code (sb-kernel:fun-code-header f))
+ (n 0))
+ (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+ for c = (sb-kernel:code-header-ref code i)
+ do (when (typep c 'fdefn)
+ (print c)
+ (incf n)))
+ n))
+(assert (zerop (count-code-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '(3) :initial-contents (list x y z)))))))
+(assert (zerop (count-code-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '3 :initial-contents (vector x y z)))))))
+(assert (zerop (count-code-callees
+ (compile nil
+ `(lambda (x y z)
+ (make-array '3 :initial-contents `(,x ,y ,z)))))))
+
;;; success