From: Paul Khuong Date: Mon, 20 May 2013 04:40:33 +0000 (-0400) Subject: Print intermediate evaluation results for some ASSERTed expressions X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f7808fb1c49b729d00580321b3f8457ce4b84cf4;p=sbcl.git 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 --- 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 --- 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 --- 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))) -(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 "~@" + :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 --- 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.")))