Print intermediate evaluation results for some ASSERTed expressions

* The reports of errors signaled by ASSERT now print intermediate
  evaluation results under the following conditions:
   1. The ASSERTed expression is known to be a function call.
   2. Arguments in the call are not constants.

* Test the new feature in condition.impure.lisp.

* Original patch from Alexandra Barchunova; closes lp#789497.

diff --git a/NEWS b/NEWS
index dd9b144..105f6e5 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -26,6 +26,8 @@ changes relative to sbcl-1.1.7:
        NFKD) has been included;
     ** querying the character database for code points not defined by Unicode
        gives less wrong answers (lp#1178038, reported by Ken Harris)
+  * enhancement: print intermediate evaluation results for some ASSERTed
+    expressions. (lp#789497)
   * bug fix: type derivation for LOG{AND,IOR,XOR} scales linearly instead
     of quadratically with the size of the input in the worst case.
     (lp#1096444)

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 935fe5b..3bfcbaa 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -24,16 +24,64 @@
 ;;;
 ;;; ASSERT-ERROR isn't defined until a later file because it uses the
 ;;; macro RESTART-CASE, which isn't defined until a later file.
-(defmacro-mundanely assert (test-form &optional places datum &rest arguments)
+(defmacro-mundanely assert (test-form &optional places datum &rest arguments
+                            &environment env)
   #!+sb-doc
-  "Signals an error if the value of test-form is nil. Continuing from this
-   error using the CONTINUE restart will allow the user to alter the value of
-   some locations known to SETF, starting over with test-form. Returns NIL."
-  `(do () (,test-form)
-     (assert-error ',test-form ',places ,datum ,@arguments)
-     ,@(mapcar (lambda (place)
-                 `(setf ,place (assert-prompt ',place ,place)))
-               places)))
+  "Signals an error if the value of TEST-FORM is NIL. Returns NIL.
+
+   Optional DATUM and ARGUMENTS can be used to change the signaled
+   error condition and are interpreted as in (APPLY #'ERROR DATUM
+   ARGUMENTS).
+
+   Continuing from the signaled error using the CONTINUE restart will
+   allow the user to alter the values of the SETFable locations
+   specified in PLACES and then start over with TEST-FORM.
+
+   If TEST-FORM is of the form
+
+     (FUNCTION ARG*)
+
+   where FUNCTION is a function (but not a special operator like
+   CL:OR, CL:AND, etc.) the results of evaluating the ARGs will be
+   included in the error report if the assertion fails."
+  (collect ((bindings) (infos))
+    (let ((new-test
+            (flet ((process-place (place)
+                     (if (sb!xc:constantp place env)
+                         place
+                         (with-unique-names (temp)
+                           (bindings `(,temp ,place))
+                           (infos `(list ',place ,temp))
+                           temp))))
+              (cond
+                ;; TEST-FORM looks like a function call. We do not
+                ;; attempt this if TEST-FORM is the application of a
+                ;; special operator because of argument evaluation
+                ;; order issues.
+                ((and (typep test-form '(cons symbol list))
+                      (eq (info :function :kind (first test-form)) :function))
+                 (let ((name (first test-form))
+                       (args (mapcar #'process-place (rest test-form))))
+                   `(,name ,@args)))
+                ;; For all other cases, just evaluate TEST-FORM and do
+                ;; not report any details if the assertion fails.
+                (t
+                 test-form)))))
+      ;; If TEST-FORM, potentially using values from BINDINGS, does not
+      ;; hold, enter a loop which reports the assertion error,
+      ;; potentially changes PLACES, and retries TEST-FORM.
+      `(tagbody
+        :try
+          (let ,(bindings)
+            (when ,new-test
+              (go :done))
+            (assert-error ',test-form (list ,@(infos))
+                          ',places ,datum ,@arguments))
+          ,@(mapcar (lambda (place)
+                      `(setf ,place (assert-prompt ',place ,place)))
+                    places)
+          (go :try)
+        :done))))
 
 (defun assert-prompt (name value)
   (cond ((y-or-n-p "The old value of ~S is ~S.~

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index e431146..be8c319 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -131,27 +131,25 @@ with that condition (or with no condition) will be returned."
          (args (interactive-restart-arguments real-restart)))
     (apply (restart-function real-restart) args)))
 \f
-(defun assert-error (assertion places datum &rest arguments)
+(defun assert-error (assertion args-and-values places datum &rest arguments)
   (let ((cond (if datum
-                (coerce-to-condition datum
-                                                    arguments
-                                                    'simple-error
-                                                    'error)
-                (make-condition 'simple-error
-                                :format-control "The assertion ~S failed."
-                                :format-arguments (list assertion)))))
+                  (coerce-to-condition
+                   datum arguments 'simple-error 'error)
+                  (make-condition
+                   'simple-error
+                   :format-control "~@<The assertion ~S failed~:[.~:; ~
+                                    with ~:*~{~{~S = ~S~}~^, ~}.~]~:@>"
+                   :format-arguments (list assertion args-and-values)))))
     (restart-case
         (error cond)
       (continue ()
-                :report (lambda (stream)
-                          (format stream "Retry assertion")
-                          (if places
-                              (format stream
-                                      " with new value~P for ~{~S~^, ~}."
-                                      (length places)
-                                      places)
-                              (format stream ".")))
-                nil))))
+        :report (lambda (stream)
+                  (format stream "Retry assertion")
+                  (if places
+                      (format stream " with new value~P for ~{~S~^, ~}."
+                              (length places) places)
+                      (format stream ".")))
+        nil))))
 
 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros

diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp
index 7eab70a..aaa9d54 100644 (file)
--- a/tests/condition.impure.lisp
+++ b/tests/condition.impure.lisp
@@ -194,7 +194,7 @@
            (condition-with-constant-function-initform-foo
             (make-instance 'condition-with-constant-function-initform)))))
 
-;;; bug-
+;;; bug-1164969
 
 (defvar bar-counter 0)
 
@@ -270,3 +270,25 @@
                   (make-condition 'condition-with-class-allocation))))
   (assert (= 5 (condition-with-class-allocation-count
                 (make-condition 'condition-with-class-allocation)))))
+
+;;; bug-789497
+
+(with-test (:name (assert :print-intermediate-results :bug-789497))
+  (macrolet ((test (bindings expression expected-message)
+               `(let ,bindings
+                  (handler-case (assert ,expression)
+                    (simple-error (condition)
+                      (assert (string= (princ-to-string condition)
+                                       ,expected-message)))))))
+    ;; Constant and variables => no special report.
+    (test () nil "The assertion NIL failed.")
+    (test ((a nil)) a "The assertion A failed.")
+    ;; Special operators => no special report.
+    (test ((a nil) (b nil)) (or a b) "The assertion (OR A B) failed.")
+    (test ((a nil) (b t)) (and a b) "The assertion (AND A B) failed.")
+    ;; Functions with constant and non-constant arguments => include
+    ;; non-constant arguments in report.
+    (test ((a t)) (not a) "The assertion (NOT A) failed with A = T.")
+    (test () (not t) "The assertion (NOT T) failed.")
+    (test ((a -1)) (plusp (signum a))
+          "The assertion (PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1.")))