X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler-test-util.lisp;h=352db70625909a192a53ca3c4ebb383345ddd47e;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=d83c7b04e9506b2dfe6eb70908c1746961510226;hpb=ac93aa515b197d751dad85d70432ebc87fac420a;p=sbcl.git

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index d83c7b0..352db70 100644
--- 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
@@ -111,19 +112,15 @@
       (ignore-errors (delete-file lisp))
       (ignore-errors (delete-file fasl)))))
 
-(defun file-compile (toplevel-forms &key load)
-  (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
-         (fasl (compile-file-pathname lisp)))
-    (unwind-protect
-         (progn
-           (with-open-file (f lisp :direction :output)
-             (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))