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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index d5025a5..845c647 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -41,6 +41,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 +55,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