From dcc18b4ddb40e9c63229d9bc37e0132f0123e817 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 30 Jul 2008 13:53:11 +0000 Subject: [PATCH] 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. --- NEWS | 3 +++ src/code/target-error.lisp | 26 +++++++++++++++++++------- tests/condition.impure.lisp | 13 +++++++++++++ version.lisp-expr | 2 +- 4 files changed, 36 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index 5735d36..3ffa382 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4