1.0.22.20: Make a stab at having DEFTYPE types replace structure types.

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index f7d43cb..659ed28 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,7 +19,16 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
-(defvar *handler-clusters* nil)
+(defun muffle-warning-p (warning)
+  (declare (special *muffled-warnings*))
+  (typep warning *muffled-warnings*))
+
+(defun initial-handler-clusters ()
+  `(((warning . ,#'(lambda (warning)
+                     (when (muffle-warning-p warning)
+                       (muffle-warning warning)))))))
+
+(defvar *handler-clusters* (initial-handler-clusters))
 
 (defstruct (restart (:copier nil) (:predicate nil))
   (name (missing-arg) :type symbol :read-only t)
@@ -33,12 +42,13 @@
         (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 established to less recently established. If CONDITION is
-   specified, then only restarts associated with CONDITION (or with no
-   condition) will be returned."
+  "Return a list of all the currently active restarts ordered from most recently
+established to less recently established. If CONDITION is specified, then only
+restarts associated with CONDITION (or with no condition) will be returned."
   (let ((associated ())
         (other ()))
     (dolist (alist *condition-restarts*)
@@ -46,15 +56,22 @@
           (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)))
-                     (or (not condition)
-                         (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
@@ -69,19 +86,18 @@
                        (format stream "~S" restart)))))
            stream))
 
-(defun find-restart (name &optional condition)
+(defun find-restart (identifier &optional condition)
   #!+sb-doc
-  "Return the first restart named NAME. If NAME names a restart, the restart
-   is returned if it is currently active. If no such restart is found, NIL is
-   returned. It is an error to supply NIL as a name. If CONDITION is specified
-   and not NIL, then only restarts associated with that condition (or with no
-   condition) will be returned."
-  (let ((restarts (compute-restarts condition)))
-    (declare (type list restarts))
-    (find-if (lambda (x)
-               (or (eq x name)
-                   (eq (restart-name x) name)))
-             restarts)))
+  "Return the first restart identified by IDENTIFIER. If IDENTIFIER is a symbol,
+then the innermost applicable restart with that name is returned. If IDENTIFIER
+is a restart, it is returned if it is currently active. Otherwise NIL is
+returned. If CONDITION is specified and not NIL, then only restarts associated
+with that condition (or with no condition) will be returned."
+  ;; see comment above
+  (if (typep identifier 'restart)
+      (and (find-if (lambda (cluster) (find identifier cluster)) *restart-clusters*)
+           identifier)
+      (find identifier (compute-restarts condition) :key #'restart-name)))
 
 ;;; helper for the various functions which are ANSI-spec'ed to do
 ;;; something with a restart or signal CONTROL-ERROR if there is none