1.0.21.17: --script commandline argument

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 2f6d3fc..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* ())
 
 ;;; 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)
 
 (defstruct (restart (:copier nil) (:predicate nil))
   (name (missing-arg) :type symbol :read-only t)

@@ -33,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

@@ -45,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