From cdb3a46f120caf982c9e8c87f1643b18bb775689 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 13 Apr 2003 13:44:54 +0000
Subject: [PATCH] 	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.
---
 code/error.lisp | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index 328076ab8..a7cacdf3d 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (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 @@
 		(slot (find-slot (condition-class-cpl class) name)))
 	    (unless slot
 	      (error "Slot ~S of ~S missing." name condition))
-	    (dolist (initarg (condition-slot-initargs slot))
-	      (let ((val (getf actual-initargs initarg *empty-slot*)))
-		(unless (eq val *empty-slot*)
-		  (return-from condition-reader-function
-			       (setf (getf (condition-assigned-slots condition)
-					   name)
-				     val)))))
+	    ;;
+	    ;; Loop over actual initargs because the order of
+	    ;; actual initargs determines how slots are initialized.
+	    (loop with slot-initargs = (condition-slot-initargs slot)
+		  for (initarg init-value) on actual-initargs by #'cddr
+		  if (member initarg slot-initargs) do
+		    (return-from condition-reader-function
+		      (setf (getf (condition-assigned-slots condition)
+				  name)
+			    init-value)))
 	    (setf (getf (condition-assigned-slots condition) name)
 		  (find-slot-default class slot)))
 	  val))))
@@ -604,7 +607,7 @@
 ;;;
 (defun compute-effective-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))
 	(let ((found (find (condition-slot-name sslot) (res)
 			   :test #'eq)))
-- 
GitLab