From 18bfa853e120ec8cae16f965fcad4bbb68f6b741 Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Thu, 29 Nov 2001 03:50:35 +0000
Subject: [PATCH] Fixed AMOP conformance bug of ensure-class-using-class
 reported by Hannu Koivisto:  ensure-class-using-class shouldn't default
 unsupplied :direct-superclasses or :direct-slots arguments in its calls to
 make-instance and reinitialize-instance.

Code audit showed that only coerce-to-class relied on the old
behaviour.  This was necessary because the initialization code for
std-class didn't default an unsupplied value for :direct-superclasses
correctly, producing a class with no direct superclasses, contrary to
the AMOP.  Fixed this as well.
---
 pcl/std-class.lisp | 19 +++++++++----------
 1 file changed, 9 insertions(+), 10 deletions(-)

diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 78df6671b..170e0900d 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.27 2001/04/10 22:37:23 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.28 2001/11/29 03:50:35 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -363,7 +363,6 @@
 	 (unsupplied (list 1))
 	 (supplied-meta   (getf initargs :metaclass unsupplied))
 	 (supplied-supers (getf initargs :direct-superclasses unsupplied))
-	 (supplied-slots  (getf initargs :direct-slots unsupplied))
 	 (meta
 	   (cond ((neq supplied-meta unsupplied)
 		  (find-class supplied-meta))
@@ -383,14 +382,13 @@
 					     :name s)))))))      
       (loop (unless (remf initargs :metaclass) (return)))
       (loop (unless (remf initargs :direct-superclasses) (return)))
-      (loop (unless (remf initargs :direct-slots) (return)))
       (values meta
-	      (list* :direct-superclasses
-		     (and (neq supplied-supers unsupplied)
-			  (mapcar #'fix-super supplied-supers))
-		     :direct-slots
-		     (and (neq supplied-slots unsupplied) supplied-slots)
-		     initargs)))))
+	      (nconc
+	       (when (neq supplied-supers unsupplied)
+		 (list 
+		  :direct-superclasses
+		  (mapcar #'fix-super supplied-supers)))
+	       initargs)))))
 
 
 ;;;
@@ -413,7 +411,8 @@
 		 (direct-default-initargs nil direct-default-initargs-p)
 	         (predicate-name nil predicate-name-p))
   (declare (ignore slot-names))
-  (cond (direct-superclasses-p
+  (cond ((or direct-superclasses-p
+	     (null (slot-value class 'direct-superclasses)))
 	 (setq direct-superclasses
 	       (or direct-superclasses
 		   (list (if (funcallable-standard-class-p class)
-- 
GitLab