0.pre8.84:

        Fixes in RESTART-CASE, inspired by Paul Dietz' test suit:
        * MACROEXPAND requires two arguments;
        * DWIM module in RESTART-CASE uses search-by-identity rather
          than search-by-name.

diff --git a/NEWS b/NEWS
index 77caae8..ee4c576 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1682,6 +1682,8 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14
     ** &WHOLE and &REST arguments in macro lambda lists are patterns;
     ** NSET-EXCLUSIVE-OR does not return extra elements when its
        arguments contain duplicated elements;
+    ** RESTART-CASE understands local macros;
+    ** ... and associates exactly its own restarts with a condition;
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index a1929f0..f79f7bf 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -155,8 +155,8 @@
 (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))))
@@ -171,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))))
@@ -183,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)}*)
@@ -268,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))

diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index a36bd71..96cdd0f 100644 (file)
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -20,3 +20,72 @@
 (format t
        "~&printable now: ~A~%"
        (make-condition 'file-error :pathname "foo"))
+
+(assert (eq
+         (block nil
+           (macrolet ((opaque-error (arg) `(error ,arg)))
+             (handler-bind
+                 ((error (lambda (c)
+                           (let ((restarts (remove 'res (compute-restarts c)
+                                                   :key #'restart-name
+                                                   :test-not #'eql)))
+                             (assert (= (length restarts) 2))
+                             (invoke-restart (second restarts))))))
+               (let ((foo1 (make-condition 'error))
+                     (foo2 (make-condition 'error)))
+                 (restart-case
+                     (with-condition-restarts foo1 (list (find-restart 'res))
+                       (restart-case
+                           (opaque-error foo2)
+                         (res () 'int1)
+                         (res () 'int2)))
+                   (res () 'ext))))))
+         'int2))
+
+(assert (eq
+         (block nil
+           (macrolet ((opaque-error (arg) `(error ,arg)))
+             (let ((foo1 (make-condition 'error))
+                   (foo2 (make-condition 'error)))
+               (handler-bind
+                   ((error (lambda (c)
+                             (let ((restarts (remove 'res (compute-restarts foo1)
+                                                     :key #'restart-name
+                                                     :test-not #'eql)))
+                               (assert (= (length restarts) 1))
+                               (invoke-restart (first restarts))))))
+                 (restart-case
+                     (with-condition-restarts foo1 (list (find-restart 'res))
+                       (restart-case
+                           (opaque-error foo2)
+                         (res () 'int1)
+                         (res () 'int2)))
+                   (res () 'ext))))))
+         'ext))
+
+(assert (eq
+         'ext
+         (block nil
+           (let ((visible nil)
+                 (c1 (make-condition 'error))
+                 (c2 (make-condition 'error)))
+             (handler-bind
+                 ((error
+                   (lambda (c)
+                     (declare (ignore c))
+                     (flet ((check-restarts (length)
+                              (assert (= length
+                                         (length (remove 'foo (compute-restarts c1)
+                                                         :key #'restart-name
+                                                         :test-not #'eql))))))
+                       (check-restarts 1)
+                       (setq visible t)
+                       (check-restarts 1)
+                       (invoke-restart (find-restart 'foo c1))))))
+               (restart-case
+                   (restart-case
+                       (error c2)
+                     (foo () 'in1)
+                     (foo () :test (lambda (c) (declare (ignore c)) visible)
+                          'in2))
+                 (foo () 'ext)))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 0e366e3..b34ce86 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.83"
+"0.pre8.84"