0.8.0.24:

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 747b54f..f79f7bf 100644 (file)
--- 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-fun (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)
@@ -51,7 +51,8 @@
          (when (and (or (not condition)
                         (member restart associated)
                         (not (member restart other)))
-                    (funcall (restart-test-fun 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,39 +134,29 @@
    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
 ;;; appropriate. Gross, but it's what the book seems to say...
-(defun munge-restart-case-expression (expression data)
-  (let ((exp (macroexpand expression)))
+(defun munge-restart-case-expression (expression env)
+  (let ((exp (sb!xc:macroexpand expression env)))
     (if (consp exp)
        (let* ((name (car exp))
               (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
@@ -170,9 +171,7 @@
                                    ',name)))
                `(with-condition-restarts
                     ,n-cond
-                    (list ,@(mapcar (lambda (da)
-                                      `(find-restart ',(nth 0 da)))
-                                    data))
+                    (car *restart-clusters*)
                   ,(if (eq name 'cerror)
                        `(cerror ,(second expression) ,n-cond)
                        `(,name ,n-cond))))
@@ -182,7 +181,7 @@
 
 ;;; FIXME: I did a fair amount of rearrangement of this code in order to
 ;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
-(defmacro restart-case (expression &body clauses)
+(defmacro restart-case (expression &body clauses &environment env)
   #!+sb-doc
   "(RESTART-CASE form
    {(case-name arg-list {keyword value}* body)}*)
@@ -206,7 +205,7 @@
                                   :interactive-function
                                   result)))
             (when test
-              (setq result (list* `#',test :test-fun result)))
+              (setq result (list* `#',test :test-function result)))
             (nreverse result)))
         (parse-keyword-pairs (list keys)
           (do ((l list (cddr l))
@@ -267,7 +266,7 @@
                                     ,@keys)))
                         data)
              (return-from ,block-tag
-                          ,(munge-restart-case-expression expression data)))
+                          ,(munge-restart-case-expression expression env)))
            ,@(mapcan (lambda (datum)
                        (let ((tag  (nth 1 datum))
                              (bvl  (nth 3 datum))