X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=26b12ce601e5733d8334097feec077d7659ee404;hb=8bc3c6490d56d4cfcdc72fd14b0d11764cf9f54d;hp=ef9d8b076ed6a23f403af8d1d189e2474515d065;hpb=75f37cd646778cc8d4bed86d79309b7161bd41dc;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index ef9d8b0..26b12ce 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -618,7 +618,7 @@
 (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))
 
 
@@ -1069,6 +1069,21 @@
     (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*))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1820,18 +1835,27 @@
 (setf *mystery* :mystery)
 (assert (eq :ok (test-mystery (make-thing :slot :mystery))))
 
-;;; 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*))))
+;;; 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