From e4e40e43c6130679c13a738965cb99ac1c63b77b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 22 Oct 2005 10:20:14 +0000 Subject: [PATCH] 0.9.5.83: almost fix COMPUTE-RESTARTS & FIND-RESTART * back out the previous change to COMPUTE-RESTARTS. * make FIND-RESTART check the activity, not applicability, of a restart object passed in as an argument. => now both the Helmut Eller's case and ansi-tests pass. Although: I dispute COMPUTE-RESTARTS.10 and RESTART-BIND.20. See emails to sbcl-devel around Sun, 16 Oct 2005 13:12. The more radical changes outlined there are not part of this yet. --- NEWS | 5 ++--- src/code/target-error.lisp | 34 +++++++++++++++------------------- tests/condition.impure.lisp | 14 +++++++++++++- version.lisp-expr | 2 +- 4 files changed, 31 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 708ab1c..77dd7fb 100644 --- a/NEWS +++ b/NEWS @@ -12,9 +12,8 @@ changes in sbcl-0.9.6 relative to sbcl-0.9.5: on platforms supporting dynamic-extent allocation. * enhancement: saving cores with foreign code loaded is now supported on MIPS/Linux in addition to the previously supported platforms. - * bug fix: COMPUTE-RESTARTS returns all active restarts, including those - with :TEST, when called without a condition. (reported by Helmut Eller for - CMUCL) + * bug fix: FIND-RESTART now tests for activity, not applicability when given + a restart object as identifier. (reported by Helmut Eller for CMUCL) * bug fix: division by zero in sb-sprof when no samples were collected * bug fix: a race when a slow to arrive sigprof signal killed sbcl * bug fix: asdf-install uses CRLF as required by the HTTP spec. diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index f7d43cb..2f6d3fc 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -35,10 +35,9 @@ (defun compute-restarts (&optional condition) #!+sb-doc - "Return a list of all the currently active restarts ordered from most - recently established to less recently established. If CONDITION is - specified, then only restarts associated with CONDITION (or with no - condition) will be returned." + "Return a list of all the currently active restarts ordered from most recently +established to less recently established. If CONDITION is specified, then only +restarts associated with CONDITION (or with no condition) will be returned." (let ((associated ()) (other ())) (dolist (alist *condition-restarts*) @@ -51,9 +50,7 @@ (when (and (or (not condition) (member restart associated) (not (member restart other))) - (or (not condition) - (funcall (restart-test-function restart) - condition))) + (funcall (restart-test-function restart) condition)) (res restart)))) (res)))) @@ -69,19 +66,18 @@ (format stream "~S" restart))))) stream)) -(defun find-restart (name &optional condition) +(defun find-restart (identifier &optional condition) #!+sb-doc - "Return the first restart named NAME. If NAME names a restart, the restart - is returned if it is currently active. If no such restart is found, NIL is - returned. It is an error to supply NIL as a name. If CONDITION is specified - and not NIL, then only restarts associated with that condition (or with no - condition) will be returned." - (let ((restarts (compute-restarts condition))) - (declare (type list restarts)) - (find-if (lambda (x) - (or (eq x name) - (eq (restart-name x) name))) - restarts))) + "Return the first restart identified by IDENTIFIER. If IDENTIFIER is a symbol, +then the innermost applicable restart with that name is returned. If IDENTIFIER +is a restart, it is returned if it is currently active. Otherwise NIL is +returned. If CONDITION is specified and not NIL, then only restarts associated +with that condition (or with no condition) will be returned." + ;; see comment above + (if (typep identifier 'restart) + (and (find-if (lambda (cluster) (find identifier cluster)) *restart-clusters*) + identifier) + (find identifier (compute-restarts condition) :key #'restart-name))) ;;; helper for the various functions which are ANSI-spec'ed to do ;;; something with a restart or signal CONTROL-ERROR if there is none diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 07b41e0..4cb5abe 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -54,7 +54,19 @@ (assert (eq (car (compute-restarts)) (car (compute-restarts c)))))) (picky-restart () :report "Do nothing." - :test (lambda (c) (typep c 'picky-condition)) + :test (lambda (c) + (typep c '(or null picky-condition))) 'ok)) +;;; adapted from Helmut Eller on cmucl-imp +(assert (eq 'it + (restart-case + (handler-case + (error 'picky-condition) + (picky-condition (c) + (invoke-restart (find-restart 'give-it c)))) + (give-it () + :test (lambda (c) (typep c 'picky-condition)) + 'it)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 302dda0..d8e6565 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".) -"0.9.5.82" +"0.9.5.83" -- 1.7.10.4