X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=a1929f0120aef834198cac2181b19a48cabbc782;hb=31fb28368061079b109c2193abd570111d8bb20a;hp=76643d85573f14c33ad6d094315bb6586fe52c3a;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 76643d8..a1929f0 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -23,10 +23,10 @@ (defstruct (restart (:copier nil) (:predicate nil)) (name (missing-arg) :type symbol :read-only t) - function - report-function - interactive-function - (test-function (lambda (cond) (declare (ignore cond)) t))) + (function (missing-arg) :type function) + (report-function nil :type (or null function)) + (interactive-function nil :type (or null function)) + (test-function (lambda (cond) (declare (ignore cond)) t) :type function)) (def!method print-object ((restart restart) stream) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t) @@ -36,8 +36,8 @@ (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 + 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 ())) @@ -51,7 +51,8 @@ (when (and (or (not condition) (member restart associated) (not (member restart other))) - (funcall (restart-test-function restart) condition)) + (funcall (restart-test-function restart) + condition)) (res restart)))) (res)))) @@ -112,10 +113,20 @@ 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." - (find-if (lambda (x) - (or (eq x name) - (eq (restart-name x) name))) - (compute-restarts condition))) + (let ((restarts (compute-restarts condition))) + (declare (type list restarts)) + (find-if (lambda (x) + (or (eq x name) + (eq (restart-name x) name))) + restarts))) + +(defun find-restart-or-lose (restart-designator) + (let ((real-restart (find-restart restart-designator))) + (unless real-restart + (error 'simple-control-error + :format-control "Restart ~S is not active." + :format-arguments (list restart-designator))) + real-restart)) (defun invoke-restart (restart &rest values) #!+sb-doc @@ -123,33 +134,23 @@ arguments. If the argument restart is not a restart or a currently active non-nil restart name, then a control-error is signalled." (/show "entering INVOKE-RESTART" restart) - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'simple-control-error - :format-control "Restart ~S is not active." - :format-arguments (list restart))) - (/show (restart-name real-restart)) + (let ((real-restart (find-restart-or-lose restart))) (apply (restart-function real-restart) values))) +(defun interactive-restart-arguments (real-restart) + (let ((interactive-function (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) + '()))) + (defun invoke-restart-interactively (restart) #!+sb-doc "Calls the function associated with the given restart, prompting for any necessary arguments. If the argument restart is not a restart or a currently active non-nil restart name, then a control-error is signalled." - (/show "entering INVOKE-RESTART-INTERACTIVELY" restart) - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'simple-control-error - :format-control "Restart ~S is not active." - :format-arguments (list restart))) - (/show (restart-name real-restart)) - (/show0 "falling through to APPLY of RESTART-FUNCTION") - (apply (restart-function real-restart) - (let ((interactive-function - (restart-interactive-function real-restart))) - (if interactive-function - (funcall interactive-function) - '()))))) + (let* ((real-restart (find-restart-or-lose restart)) + (args (interactive-restart-arguments real-restart))) + (apply (restart-function real-restart) args))) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if @@ -206,9 +207,7 @@ :interactive-function result))) (when test - (setq result (list* `#',test - :test-function - result))) + (setq result (list* `#',test :test-function result))) (nreverse result))) (parse-keyword-pairs (list keys) (do ((l list (cddr l)) @@ -326,99 +325,18 @@ ;;;; HANDLER-CASE -(defmacro handler-case (form &rest clauses) +(defmacro handler-case (form &rest cases) "(HANDLER-CASE form { (type ([var]) body) }* ) Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :no-error. If such a clause + types. A peculiar property allows type to be :NO-ERROR. If such a clause occurs, and form returns normally, all its values are passed to this clause as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one var specification." - ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH - ;; operations, which seems like an ugly way to handle lexical - ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch - ;; (included below this form, but #+NIL'ed out) to switch over to - ;; RETURN-FROM, which seems like basically a better idea. - ;; Unfortunately when using his patch, this reasonable code - ;; (DEFUN FOO1I () - ;; (IF (NOT (IGNORE-ERRORS - ;; (MAKE-PATHNAME :HOST "FOO" - ;; :DIRECTORY "!BLA" - ;; :NAME "BAR"))) - ;; (PRINT "OK") - ;; (ERROR "NOTUNLESSNOT"))) - ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK" - ;; instead). I think this may not be a bug in MNA's patch, but - ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM) - ;; but whatever the reason. (I noticed this problem in - ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point. - ;; The problem also occurs at least in sbcl-0.6.12.59 and - ;; sbcl-0.6.13.) -- WHN - ;; - ;; Note also: I think the old nested THROW/CATCH version became - ;; easier to read once I converted it to use DESTRUCTURING-BIND and - ;; mnemonic names, and it would probably be a useful to do that to - ;; the RETURN-FROM version when/if it's adopted. - (let ((no-error-clause (assoc ':no-error clauses))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ;; FIXME: What if there's more than one :NO-ERROR - ;; clause? The code here and above doesn't seem - ;; either to remove both of them or to signal - ;; a good error, so it's probably wrong. - ,@(remove no-error-clause clauses))))))) - (let ((var (gensym "HC-VAR-")) - (outer-tag (gensym "OUTER-HC-TAG-")) - (inner-tag (gensym "INNER-HC-TAG-")) - (tag-var (gensym "HC-TAG-VAR-")) - (tagged-clauses (mapcar (lambda (clause) - (cons (gensym "HC-TAG-") clause)) - clauses))) - `(let ((,outer-tag (cons nil nil)) - (,inner-tag (cons nil nil)) - ,var ,tag-var) - ;; FIXME: should be (DECLARE (IGNORABLE ,VAR)) - ,var ;ignoreable - (catch ,outer-tag - (catch ,inner-tag - (throw ,outer-tag - (handler-bind - ,(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore body)) - `(,typespec - (lambda (temp) - ,(if args - `(setq ,var temp) - '(declare (ignore temp))) - (setf ,tag-var ',tag) - (/show "THROWing INNER-TAG from HANDLER-BIND closure for" ',typespec) - (throw ,inner-tag nil))))) - tagged-clauses) - ,form))) - (case ,tag-var - ,@(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore typespec)) - `(,tag - ,@(if args - (destructuring-bind (arg) args - `((let ((,arg ,var)) - ,@body))) - body)))) - tagged-clauses))))))) - #+nil ; MNA's patched version -- see FIXME above + ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND + ;; and names for the subexpressions would make it easier to + ;; understand the code below. (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (make-symbol "normal-return"))