From f4136bbceaf150420789b6e803a5acdbb136a08d Mon Sep 17 00:00:00 2001
From: "Tobias C. Rittweiler" <trittweiler@users.sourceforge.net>
Date: Tue, 6 Apr 2010 11:09:31 +0000
Subject: [PATCH] 1.0.37.41: Improved ASSERT-NO-CONSING reporting in test
 suite.

An hooray to FORMAT:

  (assert-no-consing (sleep 0.0001)) results in

      Expected the form
          (SLEEP 1.e-4)
      NOT to cons, yet running it for 10000 times resulted in the
      allocation of 1290440 bytes (129.044 per run).
---
 tests/compiler-test-util.lisp |   48 +++++++++++++++++++++++++++--------------
 version.lisp-expr             |    2 +-
 2 files changed, 33 insertions(+), 17 deletions(-)

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index 25a6ed4..f05e3fa 100644
--- a/tests/compiler-test-util.lisp
+++ b/tests/compiler-test-util.lisp
@@ -57,22 +57,38 @@
           when (typep c type)
           collect c)))
 
-(defmacro assert-no-consing (form &optional times)
-  `(%assert-no-consing (lambda () ,form) ,times))
-(defun %assert-no-consing (thunk &optional times)
-  (let ((before (sb-ext:get-bytes-consed))
-        (times (or times 10000)))
-    (declare (type (integer 1 *) times))
+(defun collect-consing-stats (thunk times)
+  (declare (type function thunk))
+  (declare (type fixnum times))
+  (let ((before (sb-ext:get-bytes-consed)))
     (dotimes (i times)
       (funcall thunk))
-    (assert (< (- (sb-ext:get-bytes-consed) before) times))))
+    (values before (sb-ext:get-bytes-consed))))
 
-(defmacro assert-consing (form &optional times)
-  `(%assert-consing (lambda () ,form) ,times))
-(defun %assert-consing (thunk &optional times)
-  (let ((before (sb-ext:get-bytes-consed))
-        (times (or times 10000)))
-    (declare (type (integer 1 *) times))
-    (dotimes (i times)
-      (funcall thunk))
-    (assert (not (< (- (sb-ext:get-bytes-consed) before) times)))))
+(defun check-consing (yes/no form thunk times)
+  (multiple-value-bind (before after)
+      (collect-consing-stats thunk times)
+    (let ((consed-bytes (- after before)))
+      (assert (funcall (if yes/no #'not #'identity)
+                       ;; I do not know why we do this comparasion,
+                       ;; the original code did, so I let it
+                       ;; in. Perhaps to prevent losage on GC
+                       ;; fluctuations, or something. --TCR.
+                       (< consed-bytes times))
+              ()
+              "~@<Expected the form ~
+                      ~4I~@:_~A ~0I~@:_~
+                  ~:[NOT to cons~;to cons~], yet running it for ~
+                  ~D times resulted in the allocation of ~
+                  ~D bytes~:[ (~,3F per run)~;~].~@:>"
+              form yes/no times consed-bytes
+              (zerop consed-bytes) (float (/ consed-bytes times))))
+    (values before after)))
+
+(defparameter +times+ 10000)
+
+(defmacro assert-no-consing (form &optional (times '+times+))
+  `(check-consing nil ',form (lambda () ,form) ,times))
+
+(defmacro assert-consing (form &optional (times '+times+))
+  `(check-consing t ',form (lambda () ,form) ,times))
diff --git a/version.lisp-expr b/version.lisp-expr
index abade63..865c279 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.37.40"
+"1.0.37.41"
-- 
1.7.10.4