0.7.1.26:

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 4c1ea5c..ef1eea8 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
+  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
 (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,20 @@
          (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-fun 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,32 +90,31 @@
    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)))
+  (find-if (lambda (x)
+            (or (eq x name)
+                (eq (restart-name x) name)))

           (compute-restarts condition)))
 
 (defun invoke-restart (restart &rest values)
           (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."
   "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)))
   (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)
     (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."
   "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)))
   (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)))
     (apply (restart-function real-restart)
           (let ((interactive-function
                  (restart-interactive-function real-restart)))

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

@@ -254,25 +257,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 +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
    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 +313,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

@@ -321,7 +324,7 @@
 \f
 ;;;; HANDLER-CASE
 
 \f
 ;;;; 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
   "(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
   ;; 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")))
     (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)
                (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)
           `(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
                (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
                           ,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
   #+nil ; MNA's patched version -- see FIXME above
   (let ((no-error-clause (assoc ':no-error cases)))
     (if no-error-clause