X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=1e915ca4b5bc40dea3c389feafe274149b393686;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=046006b56ce4022cb196dff2b9a2a21dc5f32218;hpb=0337d730355489f27cb3e1527d45c27fd2243ddf;p=sbcl.git

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 046006b..1e915ca 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -324,7 +324,7 @@ evaluated as a PROGN."
   evaluated before each evaluation of the body Forms. When the Test is true,
   the Exit-Forms are evaluated as a PROGN, with the result being the value
   of the DO. A block named NIL is established around the entire expansion,
-  allowing RETURN to be used as an laternate exit mechanism."
+  allowing RETURN to be used as an alternate exit mechanism."
   (frob-do-body varlist endlist body 'let* 'setq 'do* nil))
 
 ;;; DOTIMES and DOLIST could be defined more concisely using
@@ -405,8 +405,10 @@ evaluated as a PROGN."
 
 ;;; KLUDGE: we PROCLAIM these special here so that we can use restart
 ;;; macros in the compiler before the DEFVARs are compiled.
-(sb!xc:proclaim
- '(special *handler-clusters* *restart-clusters* *condition-restarts*))
+;;;
+;;; For an explanation of these data structures, see DEFVARs in
+;;; target-error.lisp.
+(sb!xc:proclaim '(special *handler-clusters* *restart-clusters*))
 
 (defmacro-mundanely with-condition-restarts
     (condition-form restarts-form &body body)
@@ -415,14 +417,17 @@ evaluated as a PROGN."
    RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
    This allows FIND-RESTART, etc., to recognize restarts that are not related
    to the error currently being debugged. See also RESTART-CASE."
-  (let ((n-cond (gensym)))
-    `(let ((*condition-restarts*
-            (cons (let ((,n-cond ,condition-form))
-                    (cons ,n-cond
-                          (append ,restarts-form
-                                  (cdr (assoc ,n-cond *condition-restarts*)))))
-                  *condition-restarts*)))
-       ,@body)))
+  (once-only ((restarts restarts-form))
+    (with-unique-names (restart)
+      ;; FIXME: check the need for interrupt-safety.
+      `(unwind-protect
+           (progn
+             (dolist (,restart ,restarts)
+               (push ,condition-form
+                     (restart-associated-conditions ,restart)))
+             ,@body)
+         (dolist (,restart ,restarts)
+           (pop (restart-associated-conditions ,restart)))))))
 
 (defmacro-mundanely restart-bind (bindings &body forms)
   #!+sb-doc
@@ -435,13 +440,18 @@ evaluated as a PROGN."
            (unless (>= (length binding) 2)
              (error "ill-formed restart binding: ~S" binding))
            (destructuring-bind (name function
-                                &rest args
-                                &key report-function &allow-other-keys)
+                                &key interactive-function
+                                     test-function
+                                     report-function)
                binding
              (unless (or name report-function)
                (warn "Unnamed restart does not have a report function: ~
                       ~S" binding))
-             `(make-restart :name ',name :function ,function ,@args))))
+             `(make-restart ',name ,function
+                            ,report-function
+                            ,interactive-function
+                            ,@(and test-function
+                                   `(,test-function))))))
     `(let ((*restart-clusters*
              (cons (list ,@(mapcar #'parse-binding bindings))
                    *restart-clusters*)))
@@ -517,7 +527,7 @@ evaluated as a PROGN."
                              (return (values result form))))
                           result)))))
              (parse-clause (clause)
-               (unless (and (listp clause ) (>= (length clause) 2)
+               (unless (and (listp clause) (>= (length clause) 2)
                             (listp (second clause)))
                  (error "ill-formed ~S clause, no lambda-list:~%  ~S"
                         'restart-case clause))
@@ -526,17 +536,33 @@ evaluated as a PROGN."
                      (parse-keywords-and-body body)
                    (list name (sb!xc:gensym "TAG") keywords lambda-list body))))
              (make-binding (clause-data)
-               (destructuring-bind (name tag keywords &rest rest) clause-data
-                 (declare (ignore rest))
-                 `(,name #'(lambda (&rest temp)
-                             (setq ,temp-var temp)
-                             (go ,tag))
-                         ,@keywords)))
+               (destructuring-bind (name tag keywords lambda-list body) clause-data
+                 (declare (ignore body))
+                 `(,name
+                   (lambda ,(cond ((null lambda-list)
+                                   ())
+                                  ((and (null (cdr lambda-list))
+                                        (not (member (car lambda-list)
+                                                     '(&optional &key &aux))))
+                                   '(temp))
+                                  (t
+                                   '(&rest temp)))
+                     ,@(when lambda-list `((setq ,temp-var temp)))
+                     (locally (declare (optimize (safety 0)))
+                       (go ,tag)))
+                   ,@keywords)))
              (make-apply-and-return (clause-data)
                (destructuring-bind (name tag keywords lambda-list body) clause-data
                  (declare (ignore name keywords))
                  `(,tag (return-from ,block-tag
-                          (apply (lambda ,lambda-list ,@body) ,temp-var))))))
+                          ,(cond ((null lambda-list)
+                                  `(progn ,@body))
+                                 ((and (null (cdr lambda-list))
+                                       (not (member (car lambda-list)
+                                                    '(&optional &key &aux))))
+                                  `(funcall (lambda ,lambda-list ,@body) ,temp-var))
+                                 (t
+                                  `(apply (lambda ,lambda-list ,@body) ,temp-var))))))))
       (let ((clauses-data (mapcar #'parse-clause clauses)))
         `(block ,block-tag
            (let ((,temp-var nil))