From ce3d6da896e35c9e202db443c5cfc9fedcf65ebe Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Mon, 21 Apr 2003 04:37:20 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/code/target-error.lisp | 12 ++++---- tests/condition.pure.lisp | 69 ++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 77 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index 77caae8..ee4c576 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4