Skip to content
Snippets Groups Projects
Commit 5731998a authored by gerd's avatar gerd
Browse files

Fix for COMPUTE-RESTARTS.9 from Paul Dietz' test suite.

	* src/code/error.lisp (%find-restarts): New function.
	(munge-restart-case-expression): Use it instead of find-restart
	which returns only one restart object for restarts with equal
	names.
parent f650ebff
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.69 2003/04/16 19:41:05 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.70 2003/04/17 12:55:57 gerd Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -218,6 +218,22 @@ ...@@ -218,6 +218,22 @@
(eval-when (compile load eval) (eval-when (compile load eval)
;;;
;;; Return a list of restarts with names NAMES, taking duplicate
;;; names into account.
;;;
(defun %find-restarts (names)
(let ((all (compute-restarts)))
(collect ((restarts))
(dolist (name names (restarts))
(let ((restart (find-if (lambda (x)
(or (eq x name)
(eq (restart-name x) name)))
all)))
(restarts restart)
(setq all (delete restart all)))))))
;;; Wrap the restart-case expression in a with-condition-restarts if ;;; Wrap the restart-case expression in a with-condition-restarts if
;;; appropriate. Gross, but it's what the book seems to say... ;;; appropriate. Gross, but it's what the book seems to say...
;;; ;;;
...@@ -235,14 +251,11 @@ ...@@ -235,14 +251,11 @@
(signal 'simple-condition) (signal 'simple-condition)
(t 'simple-error)) (t 'simple-error))
',name))) ',name)))
`(with-condition-restarts `(with-condition-restarts ,n-cond
,n-cond (%find-restarts ',(mapcar (lambda (x) (nth 0 x)) data))
(list ,@(mapcar #'(lambda (da) ,(if (eq name 'cerror)
`(find-restart ',(nth 0 da))) `(cerror ,(second expression) ,n-cond)
data)) `(,name ,n-cond))))
,(if (eq name 'cerror)
`(cerror ,(second expression) ,n-cond)
`(,name ,n-cond))))
expression)) expression))
expression))) expression)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment