X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=be8c31901e0a5d51a4d7e34d0a9f4efb168f3172;hb=f7808fb1c49b729d00580321b3f8457ce4b84cf4;hp=d5025a507e3ca187b74fa081b1164b2234585827;hpb=74a1797f60e26c7adbc491840f89bbaab08e504d;p=sbcl.git

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index d5025a5..be8c319 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,12 +19,13 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
+(defun muffle-warning-p (warning)
+  (declare (special *muffled-warnings*))
+  (typep warning *muffled-warnings*))
+
 (defun initial-handler-clusters ()
   `(((warning . ,#'(lambda (warning)
-                     (when (typep warning
-                                  (locally
-                                      (declare (special sb!ext:*muffled-warnings*))
-                                    sb!ext:*muffled-warnings*))
+                     (when (muffle-warning-p warning)
                        (muffle-warning warning)))))))
 
 (defvar *handler-clusters* (initial-handler-clusters))
@@ -41,6 +42,8 @@
         (prin1 (restart-name restart) stream))
       (restart-report restart stream)))
 
+(defvar *restart-test-stack* nil)
+
 (defun compute-restarts (&optional condition)
   #!+sb-doc
   "Return a list of all the currently active restarts ordered from most recently
@@ -53,13 +56,22 @@ restarts associated with CONDITION (or with no condition) will be returned."
           (setq associated (cdr alist))
           (setq other (append (cdr alist) other))))
     (collect ((res))
-      (dolist (restart-cluster *restart-clusters*)
-        (dolist (restart restart-cluster)
-          (when (and (or (not condition)
-                         (member restart associated)
-                         (not (member restart other)))
-                     (funcall (restart-test-function restart) condition))
-            (res restart))))
+      (let ((stack *restart-test-stack*))
+        (dolist (restart-cluster *restart-clusters*)
+          (dolist (restart restart-cluster)
+            (when (and (or (not condition)
+                           (memq restart associated)
+                           (not (memq restart other)))
+                       ;; A call to COMPUTE-RESTARTS -- from an error, from
+                       ;; user code, whatever -- inside the test function
+                       ;; would cause infinite recursion here, so we disable
+                       ;; each restart using *restart-test-stack* for the
+                       ;; duraction of the test call.
+                       (not (memq restart stack))
+                       (let ((*restart-test-stack* (cons restart stack)))
+                         (declare (truly-dynamic-extent *restart-test-stack*))
+                         (funcall (restart-test-function restart) condition)))
+             (res restart)))))
       (res))))
 
 #!+sb-doc
@@ -119,33 +131,35 @@ 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 "~@<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
 ;;; and by CHECK-TYPE.
-(defun read-evaluated-form ()
-  (format *query-io* "~&Type a form to be evaluated:~%")
+(defun read-evaluated-form (&optional (prompt-control nil promptp)
+                            &rest prompt-args)
+  (apply #'format *query-io*
+         (if promptp prompt-control "~&Type a form to be evaluated: ")
+         prompt-args)
+  (finish-output *query-io*)
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)
@@ -164,6 +178,15 @@ with that condition (or with no condition) will be returned."
         :interactive read-evaluated-form
         value))))
 
+(defun case-failure (name value keys)
+  (error 'case-failure
+         :name name
+         :datum value
+         :expected-type (if (eq name 'ecase)
+                            `(member ,@keys)
+                            `(or ,@keys))
+         :possibilities keys))
+
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure