From: Nikodemus S. <de...@us...> - 2008-07-30 13:53:16
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15043/src/code Modified Files: target-error.lisp Log Message: 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. Index: target-error.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-error.lisp,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- target-error.lisp 3 Jul 2008 21:31:58 -0000 1.19 +++ target-error.lisp 30 Jul 2008 13:53:12 -0000 1.20 @@ -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 @@ (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 |