1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / defboot.lisp

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index d636685..3ce3db4 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -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,36 +417,40 @@ 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
-  "Executes forms in a dynamic context where the given restart bindings are
-   in effect. Users probably want to use RESTART-CASE. When clauses contain
-   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 ~
-                                      report function: ~S"
-                                     binding))
-                             `(make-restart :name ',(car binding)
-                                            :function ,(cadr binding)
-                                            ,@(cddr binding)))
-                           bindings))
-                *restart-clusters*)))
-     ,@forms))
+  "(RESTART-BIND ({(case-name function {keyword value}*)}*) forms)
+   Executes forms in a dynamic context where the given bindings are in
+   effect. Users probably want to use RESTART-CASE. A case-name of NIL
+   indicates an anonymous restart. When bindings contain the same
+   restart name, FIND-RESTART will find the first such binding."
+  (flet ((parse-binding (binding)
+           (unless (>= (length binding) 2)
+             (error "ill-formed restart binding: ~S" binding))
+           (destructuring-bind (name function
+                                &rest args
+                                &key report-function &allow-other-keys)
+               binding
+             (unless (or name report-function)
+               (warn "Unnamed restart does not have a report function: ~
+                      ~S" binding))
+             `(make-restart :name ',name :function ,function ,@args))))
+    `(let ((*restart-clusters*
+             (cons (list ,@(mapcar #'parse-binding bindings))
+                   *restart-clusters*)))
+       ,@forms)))
 
 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
 ;;; appropriate. Gross, but it's what the book seems to say...
@@ -529,7 +535,8 @@ evaluated as a PROGN."
                  (declare (ignore rest))
                  `(,name #'(lambda (&rest temp)
                              (setq ,temp-var temp)
-                             (go ,tag))
+                             (locally (declare (optimize (safety 0)))
+                               (go ,tag)))
                          ,@keywords)))
              (make-apply-and-return (clause-data)
                (destructuring-bind (name tag keywords lambda-list body) clause-data