From 840832c6ca7fae0af981d721bdbb38e567d575cf Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 31 Mar 2003 10:34:21 +0000 Subject: [PATCH] 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. --- NEWS | 5 +++++ src/code/condition.lisp | 26 ++++++++++++-------------- version.lisp-expr | 2 +- 3 files changed, 18 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 34505a7..93dbf0b 100644 --- a/NEWS +++ b/NEWS @@ -1636,6 +1636,11 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14 * fixed some bugs revealed by Paul Dietz' test suite: ** COPY-ALIST now signals an error if its argument is a dotted list; + ** condition slots are now accessed more correctly in the presence + of multiple initargs for a given slot; + ** the USE-VALUE, CONTINUE and STORE-VALUE functions now correctly + exclude restarts of the same name associated with a different + condition; planned incompatible changes in 0.7.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 07393fa..5feeb73 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -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) diff --git a/version.lisp-expr b/version.lisp-expr index 975ce35..8c2cf77 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.17" +"0.pre8.18" -- 1.7.10.4