X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=f79f7bfc0dbefe78385db6baca414e1bfba2f074;hb=df679ed627975948b1cee190f4d79c397588c43e;hp=cb48233810ac1bab0d4ef7c144c722dcff9b3fcf;hpb=42c897f39be552e99d73ad23c12e1ede2dd4c512;p=sbcl.git

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index cb48233..f79f7bf 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -120,45 +120,43 @@
                    (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."
   (/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))))
@@ -173,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))))
@@ -185,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)}*)
@@ -270,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))