Fix make-array transforms.

[sbcl.git] / tests / compiler-test-util.lisp

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index a21f04f..352db70 100644 (file)
--- a/tests/compiler-test-util.lisp
+++ b/tests/compiler-test-util.lisp
@@ -17,6 +17,7 @@
   (:export #:assert-consing
            #:assert-no-consing
            #:compiler-derived-type
+           #:count-full-calls
            #:find-value-cell-values
            #:find-code-constants
            #:find-named-callees
@@ -25,7 +26,7 @@
 (cl:in-package :ctu)
 
 (unless (fboundp 'compiler-derived-type)
-  (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
+  (defknown compiler-derived-type (t) (values t t) (flushable))
   (deftransform compiler-derived-type ((x) * * :node node)
     (sb-c::delay-ir1-transform node :optimize)
     `(values ',(type-specifier (sb-c::lvar-type x)) t))
@@ -95,16 +96,31 @@
   `(check-consing t ',form (lambda () ,form) ,times))
 
 (defun file-compile (toplevel-forms &key load)
-  (let* ((lisp "compile-impure-tmp.lisp")
+  (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
          (fasl (compile-file-pathname lisp)))
     (unwind-protect
          (progn
            (with-open-file (f lisp :direction :output)
-             (dolist (form toplevel-forms)
-               (prin1 form f)))
+             (if (stringp toplevel-forms)
+                 (write-line toplevel-forms f)
+                 (dolist (form toplevel-forms)
+                   (prin1 form f))))
            (multiple-value-bind (fasl warn fail) (compile-file lisp)
              (when load
                (load fasl))
              (values warn fail)))
       (ignore-errors (delete-file lisp))
       (ignore-errors (delete-file fasl)))))
+
+;; Pretty horrible, but does the job
+(defun count-full-calls (name function)
+  (let ((code (with-output-to-string (s)
+                (disassemble function :stream s)))
+        (n 0))
+    (with-input-from-string (s code)
+      (loop for line = (read-line s nil nil)
+            while line
+            when (and (search name line)
+                      (search "#<FDEFINITION" line))
+            do (incf n)))
+    n))