1.0.19.4: recursive restart computation

 * A call to COMPUTE-RESTARTS from restart test function caused
   infinite recursion. Fix with a stack.

 * Test-case.

diff --git a/NEWS b/NEWS
index 5735d36..3ffa382 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,9 @@ changes in sbcl-1.0.20 relative to 1.0.19:
     type of a variable or bind a constant is made.
   * bug fix: SET signals an error when an attempt to violate declared
     type of a variable is made.
+  * bug fix: restart computation during the execution of a restart
+    test function no longer causes infinite recursion. (reported by
+    Michael Weber)
 
 changes in sbcl-1.0.19 relative to 1.0.18:
   * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index d5025a5..9bb1506 100644 (file)
--- 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,23 @@ 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*))
+        (declare (optimize sb!c::stack-allocate-dynamic-extent))
+        (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 (dynamic-extent *restart-test-stack*))
+                         (funcall (restart-test-function restart) condition)))
+             (res restart)))))
       (res))))
 
 #!+sb-doc

diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp
index f7ea61a..4722d92 100644 (file)
--- a/tests/condition.impure.lisp
+++ b/tests/condition.impure.lisp
@@ -108,3 +108,16 @@
     ;; whether escaped or not
     (dolist (*print-escape* '(nil t))
       (write c :stream (make-string-output-stream)))))
+
+;;; Reported by Michael Weber: restart computation in :TEST-FUNCTION used to
+;;; cause infinite recursion.
+(defun restart-test-finds-restarts ()
+  (restart-bind
+      ((bar (lambda ()
+              (return-from restart-test-finds-restarts 42))
+         :test-function
+         (lambda (condition)
+           (find-restart 'qux))))
+    (when (find-restart 'bar)
+      (invoke-restart 'bar))))
+(assert (not (restart-test-finds-restarts)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 73bd3c9..2e843e5 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.19.3"
+"1.0.19.4"