0.pre8.34

[sbcl.git] / src / code / target-error.lisp

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 4c1ea5c..a1929f0 100644 (file)
--- 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* '())
 
 ;;; 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* ())
 
 (defvar *condition-restarts* ())
 

+(defstruct (restart (:copier nil) (:predicate nil))
+  (name (missing-arg) :type symbol :read-only 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)
+       (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
 (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 ()))
    condition) will be returned."
   (let ((associated ())
        (other ()))

@@ -39,31 +51,21 @@
          (when (and (or (not condition)
                         (member restart associated)
                         (not (member restart other)))
          (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))))
 
            (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)
 #!+sb-doc
 (setf (fdocumentation 'restart-name 'function)

-      "Returns the name of the given restart object.")
+      "Return the name of the given restart object.")

 
 (defun restart-report (restart stream)
   (funcall (or (restart-report-function restart)
               (let ((name (restart-name restart)))
 
 (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)
           stream))
 
 (defmacro with-condition-restarts (condition-form restarts-form &body body)

@@ -89,62 +91,66 @@
    the same restart name, FIND-RESTART will find the first such clause."
   `(let ((*restart-clusters*
          (cons (list
    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"
                                        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
                *restart-clusters*)))
      ,@forms))
 
 (defun find-restart (name &optional condition)
   #!+sb-doc

-  "Returns 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."
    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
   "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."
 
 (defun invoke-restart (restart &rest values)
   #!+sb-doc
   "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."

-  (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 "entering INVOKE-RESTART" restart)
+  (let ((real-restart (find-restart-or-lose restart)))

     (apply (restart-function real-restart) values)))
 
     (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."
 (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."

-  (let ((real-restart (find-restart restart)))
-    (unless real-restart
-      (error 'simple-control-error
-            :format-control "Restart ~S is not active."
-            :format-arguments (list restart)))
-    (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
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if

@@ -201,9 +207,7 @@
                                   :interactive-function
                                   result)))
             (when test
                                   :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))
             (nreverse result)))
         (parse-keyword-pairs (list keys)
           (do ((l list (cddr l))

@@ -254,25 +258,25 @@
         (let ((,temp-var nil))
           (tagbody
            (restart-bind
         (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)))
                         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
                      data)))))))
 
 (defmacro with-simple-restart ((restart-name format-string

@@ -283,7 +287,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
    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.
   `(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 +314,7 @@
     (when member-if
       (error "ill-formed handler binding: ~S" (first member-if))))
   `(let ((*handler-clusters*
     (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
                                bindings))
                *handler-clusters*)))
      (multiple-value-prog1

@@ -325,78 +329,14 @@
   "(HANDLER-CASE form
    { (type ([var]) body) }* )
    Execute FORM in a context with handlers established for the condition
   "(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."
 
    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
-  (let ((no-error-clause (assoc ':no-error cases)))
-    (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)
-                     ,@(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)))
-          `(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 (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)
-                          ,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)))))))
-  #+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"))
   (let ((no-error-clause (assoc ':no-error cases)))
     (if no-error-clause
        (let ((normal-return (make-symbol "normal-return"))