From: Christophe R. <cr...@us...> - 2003-03-31 10:34:29
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv31246/src/code Modified Files: condition.lisp Log Message: 0.pre8.18: Fix a couple of condition system bugs from the test suite ... slot access in the presence of multiple initargs; ... USE-VALUE and friends in the presence of multiple restarts of the same name where some are associated with other conditions. Index: condition.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- condition.lisp 25 Mar 2003 13:40:14 -0000 1.23 +++ condition.lisp 31 Mar 2003 10:34:24 -0000 1.24 @@ -206,7 +206,6 @@ (when (eq (condition-slot-name cslot) name) (return-from condition-reader-function (car (condition-slot-cell cslot))))) - (let ((val (getf (condition-assigned-slots condition) name *empty-condition-slot*))) (if (eq val *empty-condition-slot*) @@ -214,17 +213,15 @@ (slot (find-condition-class-slot class name))) (unless slot (error "missing slot ~S of ~S" name condition)) - (dolist (initarg (condition-slot-initargs slot)) - (let ((val (getf actual-initargs - initarg - *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from condition-reader-function - (setf (getf (condition-assigned-slots condition) - name) - val))))) - (setf (getf (condition-assigned-slots condition) name) - (find-slot-default class slot))) + (do ((initargs actual-initargs (cddr initargs))) + ((endp initargs) + (setf (getf (condition-assigned-slots condition) name) + (find-slot-default class slot))) + (when (member (car initargs) (condition-slot-initargs slot)) + (return-from condition-reader-function + (setf (getf (condition-assigned-slots condition) + name) + (cadr initargs)))))) val)))) ;;;; MAKE-CONDITION @@ -866,8 +863,9 @@ #!+sb-doc ,doc ;; FIXME: Perhaps this shared logic should be pulled out into ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code.. - (when (find-restart ',name condition) - (invoke-restart ',name ,@args))))) + (let ((restart (find-restart ',name condition))) + (when restart + (invoke-restart restart ,@args)))))) (define-nil-returning-restart continue () "Transfer control to a restart named CONTINUE, or return NIL if none exists.") (define-nil-returning-restart store-value (value) |