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.
     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*;
 
 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)))
 
         (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 +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))
           (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
       (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)))))
     ;; 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".)
 ;;; 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"