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

Fix CONDITION-x-SLOTS* ANSI test failures.

	* src-types/code/error.lisp (condition-reader-function): Loop over
	actual initargs first because these determine how slots are
	initialized.
	(compute-effective-slots): Don't duplicate slots of the class
	whose effective slots are computed.
parent 81978758
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.67 2003/03/23 21:23:42 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.68 2003/04/13 13:44:54 gerd Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -506,13 +506,16 @@ ...@@ -506,13 +506,16 @@
(slot (find-slot (condition-class-cpl class) name))) (slot (find-slot (condition-class-cpl class) name)))
(unless slot (unless slot
(error "Slot ~S of ~S missing." name condition)) (error "Slot ~S of ~S missing." name condition))
(dolist (initarg (condition-slot-initargs slot)) ;;
(let ((val (getf actual-initargs initarg *empty-slot*))) ;; Loop over actual initargs because the order of
(unless (eq val *empty-slot*) ;; actual initargs determines how slots are initialized.
(return-from condition-reader-function (loop with slot-initargs = (condition-slot-initargs slot)
(setf (getf (condition-assigned-slots condition) for (initarg init-value) on actual-initargs by #'cddr
name) if (member initarg slot-initargs) do
val))))) (return-from condition-reader-function
(setf (getf (condition-assigned-slots condition)
name)
init-value)))
(setf (getf (condition-assigned-slots condition) name) (setf (getf (condition-assigned-slots condition) name)
(find-slot-default class slot))) (find-slot-default class slot)))
val)))) val))))
...@@ -604,7 +607,7 @@ ...@@ -604,7 +607,7 @@
;;; ;;;
(defun compute-effective-slots (class) (defun compute-effective-slots (class)
(collect ((res (copy-list (condition-class-slots class)))) (collect ((res (copy-list (condition-class-slots class))))
(dolist (sclass (condition-class-cpl class)) (dolist (sclass (cdr (condition-class-cpl class)))
(dolist (sslot (condition-class-slots sclass)) (dolist (sslot (condition-class-slots sclass))
(let ((found (find (condition-slot-name sslot) (res) (let ((found (find (condition-slot-name sslot) (res)
:test #'eq))) :test #'eq)))
......
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