From 650f162090e21b336cb842c8519e4215d7283ff3 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 30 Mar 2003 00:48:10 +0000
Subject: [PATCH] 	Make classes FIND-CLASSable early, for MOP
 programming, 	and for compatibility with other Lisps.

	* pcl/std-class.lisp (update-class): (setf find-class) here.
	(shared-initialize) <:after std-class>: Call update-class
	after setting the class predicate.

	Make ENSURE-CLASS-USING-CLASS AMOP compliant.

	* pcl/std-class.lisp (ensure-class, ensure-class-using-class)
	(ensure-class-using-class): Exchange first and second arg for AMOP
	compliance.

	* pcl/generic-functions.lisp (ensure-non-standard-class):
	Likewise.

	* pcl/braid.lisp (ensure-non-standard-class): Likewise.
---
 pcl/braid.lisp             | 23 ++++++++++++-----------
 pcl/cache.lisp             |  4 ++--
 pcl/generic-functions.lisp |  4 ++--
 pcl/std-class.lisp         | 11 ++++++-----
 4 files changed, 22 insertions(+), 20 deletions(-)

diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index c071710c9..e8287ada5 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.30 2003/03/26 17:15:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.31 2003/03/30 00:48:10 gerd Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -511,11 +511,11 @@
 		  (supers (mapcar #'kernel:%class-name kernel-supers)))
 	     (if slotsp
 		 (ensure-class-using-class
-		  name nil :metaclass metaclass :name name
+		  nil name :metaclass metaclass :name name
 		  :direct-superclasses supers
 		  :direct-slots slots)
 		 (ensure-class-using-class
-		  name nil :metaclass metaclass :name name
+		  nil name :metaclass metaclass :name name
 		  :direct-superclasses supers))))
 	 (slot-initargs-from-structure-slotd (slotd)
 	   `(:name ,(structure-slotd-name slotd)
@@ -579,20 +579,21 @@
 ;;; class in the lisp type system.
 ;;;
 (defun update-lisp-class-layout (class layout)
-  (let ((lclass (kernel:layout-class layout)))
-    (unless (eq (kernel:%class-layout lclass) layout)
-      (setf (kernel:layout-inherits layout)
-	    (kernel:order-layout-inherits
-	     (map 'simple-vector #'class-wrapper
-		  (reverse (rest (class-precedence-list class))))))
+  (let ((kernel-class (kernel:layout-class layout)))
+    (unless (eq (kernel:%class-layout kernel-class) layout)
+      (let ((cpl (class-precedence-list class)))
+	(setf (kernel:layout-inherits layout)
+	      (kernel:order-layout-inherits
+	       (map 'simple-vector #'class-wrapper
+		    (reverse (rest cpl))))))
       (kernel:register-layout layout :invalidate t)
       ;;
       ;; Subclasses of formerly forward-referenced-class may be unknown
       ;; to lisp:find-class and also anonymous. This functionality moved
       ;; here from (setf find-class).
       (let ((name (class-name class)))
-	(setf (kernel::find-class name) lclass
-	      (kernel:%class-name lclass) name)))))
+	(setf (kernel::find-class name) kernel-class
+	      (kernel:%class-name kernel-class) name)))))
 
 (defun common-lisp::sxhash-instance (instance)
   (get-hash instance))
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index 2c6bd8d2b..ef544c135 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.25 2003/03/26 17:15:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.26 2003/03/30 00:48:10 gerd Exp $")
 
 ;;;
 ;;; The basics of the PCL wrapper cache mechanism.
@@ -410,7 +410,7 @@
 	  (:obsolete
 	   (obsolete-instance-trap owrapper (second state) instance))))))
 
-(declaim (inline check-obsolete-instance))
+;(declaim (inline check-obsolete-instance))
 (defun check-obsolete-instance (instance)
   (when (invalid-wrapper-p (kernel:layout-of instance))
     (check-wrapper-validity instance)))
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
index 7fdd4c913..fc0f8c375 100644
--- a/pcl/generic-functions.lisp
+++ b/pcl/generic-functions.lisp
@@ -1,7 +1,7 @@
 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.20 2003/03/26 17:15:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.21 2003/03/30 00:48:10 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -721,7 +721,7 @@
 ;          (structure-class)
 ;          (funcallable-standard-class)
 
-(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys))
+(defgeneric ensure-class-using-class (class name &rest args &key &allow-other-keys))
 ;          (t null)
 ;          (t pcl-class)
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index bb66bfaf4..482dc3db7 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.46 2003/03/28 16:07:42 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.47 2003/03/30 00:48:10 gerd Exp $")
 
 (in-package :pcl)
 
@@ -353,9 +353,9 @@
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 (defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class name (find-class name nil) all))
+  (apply #'ensure-class-using-class (find-class name nil) name all))
 
-(defmethod ensure-class-using-class (name (class null) &rest args &key)
+(defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
     (inform-type-system-about-class (class-prototype meta) name)
@@ -364,7 +364,7 @@
     (inform-type-system-about-class class name)
     class))
 
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
+(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
     (unless (eq (class-of class) meta)
@@ -512,8 +512,8 @@
 			       (setf (slot-value class 'predicate-name)
 				     (make-class-predicate-name (class-name class))))))
   (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
   (make-class-predicate class predicate-name)
+  (update-class class nil)
   (add-slot-accessors class direct-slots))
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
@@ -734,6 +734,7 @@
   (when (or finalizep
 	    (class-finalized-p class)
 	    (not (class-has-a-forward-referenced-superclass-p class)))
+    (setf (find-class (class-name class)) class)
     (update-cpl class (compute-class-precedence-list class))
     (update-slots class (compute-slots class))
     (update-gfs-of-class class)
-- 
GitLab