1.0.32.12: Fix slot-value on specialized parameters in SVUC methods

[sbcl.git] / src / code / target-error.lisp

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index d5025a5..035d44a 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,12 +19,13 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
 ;;; 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)
 (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))
                        (muffle-warning warning)))))))
 
 (defvar *handler-clusters* (initial-handler-clusters))

@@ -41,6 +42,8 @@
         (prin1 (restart-name restart) stream))
       (restart-report restart stream)))
 
         (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
 (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))
           (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
       (res))))
 
 #!+sb-doc

@@ -164,6 +176,15 @@ with that condition (or with no condition) will be returned."
         :interactive read-evaluated-form
         value))))
 
         :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
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure