X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=ef1eea847ce300f0157c2f03d379b3f1536ba82b;hb=d40a76606c86722b0aef8179155f9f2840739b72;hp=6f576f718cef180641f34521f200c3e534ca50a9;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 6f576f7..ef1eea8 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -17,15 +17,27 @@ ;;; a list of lists of restarts (defvar *restart-clusters* '()) -;;; An ALIST (condition . restarts) which records the restarts currently -;;; associated with Condition. +;;; an ALIST (condition . restarts) which records the restarts currently +;;; associated with Condition (defvar *condition-restarts* ()) +(defstruct (restart (:copier nil) (:predicate nil)) + (name (missing-arg) :type symbol :read-only t) + function + report-function + interactive-function + (test-fun (lambda (cond) (declare (ignore cond)) t))) +(def!method print-object ((restart restart) stream) + (if *print-escape* + (print-unreadable-object (restart stream :type t :identity t) + (prin1 (restart-name restart) stream)) + (restart-report restart stream))) + (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 ())) @@ -39,21 +51,10 @@ (when (and (or (not condition) (member restart associated) (not (member restart other))) - (funcall (restart-test-function restart) condition)) + (funcall (restart-test-fun restart) condition)) (res restart)))) (res)))) -(defstruct (restart (:copier nil)) - name - function - report-function - interactive-function - (test-function #'(lambda (cond) (declare (ignore cond)) t))) -(def!method print-object ((restart restart) stream) - (if *print-escape* - (print-unreadable-object (restart stream :type t :identity t)) - (restart-report restart stream))) - #!+sb-doc (setf (fdocumentation 'restart-name 'function) "Return the name of the given restart object.") @@ -61,9 +62,9 @@ (defun restart-report (restart stream) (funcall (or (restart-report-function restart) (let ((name (restart-name restart))) - #'(lambda (stream) - (if name (format stream "~S" name) - (format stream "~S" restart))))) + (lambda (stream) + (if name (format stream "~S" name) + (format stream "~S" restart))))) stream)) (defmacro with-condition-restarts (condition-form restarts-form &body body) @@ -89,32 +90,31 @@ the same restart name, FIND-RESTART will find the first such clause." `(let ((*restart-clusters* (cons (list - ,@(mapcar #'(lambda (binding) - (unless (or (car binding) - (member :report-function - binding - :test #'eq)) - (warn "Unnamed restart does not have a ~ + ,@(mapcar (lambda (binding) + (unless (or (car binding) + (member :report-function + binding + :test #'eq)) + (warn "Unnamed restart does not have a ~ report function: ~S" - binding)) - `(make-restart - :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) + binding)) + `(make-restart :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) *restart-clusters*))) ,@forms)) (defun find-restart (name &optional condition) #!+sb-doc - "Return the first restart named name. If name is a restart, it 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 + "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." - (find-if #'(lambda (x) - (or (eq x name) - (eq (restart-name x) name))) + (find-if (lambda (x) + (or (eq x name) + (eq (restart-name x) name))) (compute-restarts condition))) (defun invoke-restart (restart &rest values) @@ -122,11 +122,13 @@ "Calls the function associated with the given restart, passing any given 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)) (apply (restart-function real-restart) values))) (defun invoke-restart-interactively (restart) @@ -134,11 +136,14 @@ "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))) @@ -201,9 +206,7 @@ :interactive-function result))) (when test - (setq result (list* `#',test - :test-function - result))) + (setq result (list* `#',test :test-fun result))) (nreverse result))) (parse-keyword-pairs (list keys) (do ((l list (cddr l)) @@ -254,25 +257,25 @@ (let ((,temp-var nil)) (tagbody (restart-bind - ,(mapcar #'(lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) + ,(mapcar (lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) data) (return-from ,block-tag ,(munge-restart-case-expression expression data))) - ,@(mapcan #'(lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply #'(lambda ,bvl ,@body) - ,temp-var))))) + ,@(mapcan (lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply (lambda ,bvl ,@body) + ,temp-var))))) data))))))) (defmacro with-simple-restart ((restart-name format-string @@ -283,7 +286,7 @@ body) If restart-name is not invoked, then all values returned by forms are returned. If control is transferred to this restart, it immediately - returns the values nil and t." + returns the values NIL and T." `(restart-case ;; If there's just one body form, then don't use PROGN. This allows ;; RESTART-CASE to "see" calls to ERROR, etc. @@ -310,7 +313,7 @@ (when member-if (error "ill-formed handler binding: ~S" (first member-if)))) `(let ((*handler-clusters* - (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) *handler-clusters*))) (multiple-value-prog1 @@ -321,7 +324,7 @@ ;;;; HANDLER-CASE -(defmacro handler-case (form &rest cases) +(defmacro handler-case (form &rest clauses) "(HANDLER-CASE form { (type ([var]) body) }* ) Execute FORM in a context with handlers established for the condition @@ -350,7 +353,12 @@ ;; 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 - (let ((no-error-clause (assoc ':no-error cases))) + ;; + ;; 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"))) @@ -359,13 +367,18 @@ (block ,normal-return (return-from ,error-return (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((var (gensym)) - (outer-tag (gensym)) - (inner-tag (gensym)) - (tag-var (gensym)) - (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) - cases))) + ;; 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) @@ -375,27 +388,34 @@ (catch ,inner-tag (throw ,outer-tag (handler-bind - ,(mapcar #'(lambda (annotated-case) - `(,(cadr annotated-case) - #'(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (setf ,tag-var - ',(car annotated-case)) - (throw ,inner-tag nil)))) - annotated-cases) + ,(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 (annotated-case) - (let ((body (cdddr annotated-case)) - (varp (caddr annotated-case))) - `(,(car annotated-case) - ,@(if varp - `((let ((,(car varp) ,var)) - ,@body)) - body)))) - annotated-cases))))))) + ,@(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 (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause