From e41ce35530a7701cb4be4ab095b8db2e62efe91e Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 6 Apr 2003 09:10:09 +0000
Subject: [PATCH] 	Fix TYPEP/SUBTYPEP problems with unfinalized and 
 forward-referenced classes.

	* pcl/std-class.lisp (class-finalized-p): Method removed.
	(*allow-forward-referenced-classes-in-cpl-p*): New variable.
	(make-preliminary-layout): New function.
	(shared-initialize) <:after std-class>: Call
	make-preliminary-layout.
	(shared-initialize) <:after forward-referenced-class>: New method
	calling make-preliminary-layout.
	(shared-initialize) <:after structure-class>: Set finalized-p slot
	to true.
	(update-slots): Likewise.
	(shared-initialize) <:after condition-class>: Likewise.
	(inform-type-system-about-class): New method for
	forward-referenced classes.
	(class-has-a-forward-referenced-superclass-p): Moved to info.lisp.

	* pcl/cpl.lisp (compute-std-cpl-phase-1): Allow forward-referenced
	classes in the cpl if *allow-forward-referenced-classes-in-cpl-p*
	is true.

	* info.lisp (class-has-a-forward-referenced-superclass-p): Moved
	here from std-class.lisp.

	* pcl/cache.lisp (make-wrapper): Handle forward-referenced
	classes.

	* pcl/braid.lisp (bootstrap-initialize-class): Set the finalized-p
	slot.

	* pcl/defs.lisp (class): Add slot finalized-p.

	* pcl/rt/defclass.lisp (defclass-types.[0-5])
	(defclass-forward-referenced-class.0): New tests.

	Misc fixes.

	* pcl/defclass.lisp (expand-defclass): Remove code papering
	over a potential compiler bug.

	* pcl/macros.lisp (find-class-cell-make-instance-function-keys):
	Removed.
	(setf find-class): Add errorp and environment
	parameters, call (setf kernel::find-class) if new-value is nil.
---
 pcl/braid.lisp       |  5 +--
 pcl/cache.lisp       |  8 +++--
 pcl/cpl.lisp         |  6 ++--
 pcl/defclass.lisp    |  7 ++--
 pcl/defs.lisp        |  5 ++-
 pcl/info.lisp        |  9 +++--
 pcl/macros.lisp      | 21 ++++++-----
 pcl/rt/defclass.lisp | 68 +++++++++++++++++++++++++++++++++--
 pcl/std-class.lisp   | 85 +++++++++++++++++++++++++++++++-------------
 9 files changed, 162 insertions(+), 52 deletions(-)

diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index 72f82d74d..64dad4974 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.33 2003/03/30 18:43:59 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.34 2003/04/06 09:10:09 gerd Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -263,6 +263,7 @@
 	 (set-slot (slot-name value)
 	   (bootstrap-set-slot metaclass-name class slot-name value)))
     (set-slot 'name name)
+    (set-slot 'finalized-p t)
     (set-slot 'source source)
     (set-slot 'type (if (eq class (find-class t))
 			t
@@ -644,7 +645,7 @@
       (if olclass
 	  (assert (eq lclass olclass))
 	  (setf (kernel::find-class name) lclass))
-
+      
       (set-class-translation class name)))
 
   (/show "Boot state BRAID reached")
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index ef544c135..bf70cee18 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.26 2003/03/30 00:48:10 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.27 2003/04/06 09:10:09 gerd Exp $")
 
 ;;;
 ;;; The basics of the PCL wrapper cache mechanism.
@@ -312,7 +312,8 @@
 ;;; lisp:class and pcl::class objects.
 ;;;
 (defun make-wrapper (length class)
-  (cond ((typep class 'std-class)
+  (cond ((or (typep class 'std-class)
+	     (typep class 'forward-referenced-class))
 	 (kernel:initialize-layout-hash
 	  (make-wrapper-internal
 	   :length length
@@ -320,7 +321,8 @@
 	   (let ((owrap (class-wrapper class)))
 	     (cond (owrap
 		    (kernel:layout-class owrap))
-		   ((*subtypep (class-of class) *the-class-standard-class*)
+		   ((or (*subtypep (class-of class) *the-class-standard-class*)
+			(typep class 'forward-referenced-class))
 		    (cond ((and *pcl-class-boot*
 				(eq (slot-value class 'name) *pcl-class-boot*))
 			   (let ((found (kernel::find-class
diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp
index 5c4c00651..e432e77cf 100644
--- a/pcl/cpl.lisp
+++ b/pcl/cpl.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.12 2003/04/06 09:10:09 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -132,7 +132,9 @@
 	       (or (gethash c table)
 		   (setf (gethash c table) (make-cpd))))
 	     (walk (c supers)
-	       (if (forward-referenced-class-p c)
+	       (declare (special *allow-forward-referenced-classes-in-cpl-p*))
+	       (if (and (forward-referenced-class-p c)
+			(not *allow-forward-referenced-classes-in-cpl-p*))
 		   (cpl-forward-referenced-class-error class c)
 		   (let ((cpd (get-cpd c)))
 		     (unless (cpd-class cpd)	;If we have already done this
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index e7d1426f7..eb2802af7 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.25 2003/03/22 16:15:17 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.26 2003/04/06 09:10:09 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -177,10 +177,7 @@
 	      (progn
 		(set-class-info name metaclass info-slots)
 		(when (eq *boot-state* 'complete)
-		  (when (eq metaclass 'standard-class)
-		    ;; a funcallable-standard-class metaclass here causes
-		    ;; a compiler crash in construct.lisp
-		    (inform-type-system-about-std-class name)))
+		  (inform-type-system-about-std-class name))
 		defclass-form)))))))
 
 (defun make-initfunction (initform)
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 22af30499..203a39e00 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -474,7 +474,10 @@
     :initform (cons nil nil))
    (predicate-name
     :initform nil
-    :reader class-predicate-name)))
+    :reader class-predicate-name)
+   (finalized-p
+    :initform nil
+    :reader class-finalized-p)))
 
 ;;;
 ;;; The class PCL-CLASS is an implementation-specific common superclass of
diff --git a/pcl/info.lisp b/pcl/info.lisp
index 8be50ad2f..35fc02f4c 100644
--- a/pcl/info.lisp
+++ b/pcl/info.lisp
@@ -36,7 +36,7 @@
 ;;; GF is actually non-accessor GF.  Clean this up.
 ;;; (setf symbol-value) should be handled like (setf fdefinition)
 
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.2 2003/03/22 16:15:16 gerd Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.3 2003/04/06 09:10:09 gerd Exp $")
 
 (in-package "PCL")
 
@@ -663,6 +663,11 @@
 
 (pushnew 'proclamation-hook c::*proclamation-hooks*)
 
+(defun class-has-a-forward-referenced-superclass-p (class)
+  (or (forward-referenced-class-p class)
+      (some #'class-has-a-forward-referenced-superclass-p
+	    (class-direct-superclasses class))))	 
+      
 ;;;
 ;;; Return true if class CLASS-NAME should be defined at compile time.
 ;;; Called from EXPAND-DEFCLASS.  ENV is the environment in which the
@@ -674,7 +679,7 @@
       (some (lambda (super)
 	      (let ((class (find-class super nil)))
 		(and class
-		     (not (forward-referenced-class-p class))
+		     (not (class-has-a-forward-referenced-superclass-p class))
 		     (some (lambda (c)
 			     (slot-declaration env 'inline c))
 			   (class-precedence-list class)))))
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
index ba3a1f0a0..ccb322006 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.22 2003/03/22 16:15:16 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.23 2003/04/06 09:10:09 gerd Exp $")
 ;;;
 ;;; Macros global variable definitions, and other random support stuff used
 ;;; by the rest of the system.
@@ -151,9 +151,6 @@
 (defmacro find-class-cell-predicate (cell)
   `(cadr ,cell))
 
-(defmacro find-class-cell-make-instance-function-keys (cell)
-  `(cddr ,cell))
-
 (defmacro make-find-class-cell (class-name)
   (declare (ignore class-name))
   '(list* nil #'function-returning-nil nil))
@@ -227,18 +224,20 @@
 			  (find-class-from-cell ',symbol ,class-cell nil))))))
       form))
 
-(defun (setf find-class) (new-value symbol)
-  (if (legal-class-name-p symbol)
-      (let ((cell (find-class-cell symbol)))
+(defun (setf find-class) (new-value name &optional errorp environment)
+  (declare (ignore errorp environment))
+  (if (legal-class-name-p name)
+      (let ((cell (find-class-cell name)))
 	(setf (find-class-cell-class cell) new-value)
-	(when (or (eq *boot-state* 'complete)
-		  (eq *boot-state* 'braid))
+	(when (and (eq *boot-state* 'complete) (null new-value))
+	  (setf (kernel::find-class name) nil))
+	(when (memq *boot-state* '(complete braid))
 	  (when (and new-value (class-wrapper new-value))
 	    (setf (find-class-cell-predicate cell)
 		  (fdefinition (class-predicate-name new-value))))
-	  (update-ctors 'setf-find-class :class new-value :name symbol))
+	  (update-ctors 'setf-find-class :class new-value :name name))
 	new-value)
-      (error "~S is not a legal class name." symbol)))
+      (error "~S is not a legal class name." name)))
 
 (defun (setf find-class-predicate) (new-value symbol)
   (if (legal-class-name-p symbol)
diff --git a/pcl/rt/defclass.lisp b/pcl/rt/defclass.lisp
index 0bbf5beda..aa49bec03 100644
--- a/pcl/rt/defclass.lisp
+++ b/pcl/rt/defclass.lisp
@@ -28,7 +28,7 @@
 ;;; DAMAGE.
 
 #+cmu
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/defclass.lisp,v 1.3 2003/04/03 11:46:20 gerd Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/defclass.lisp,v 1.4 2003/04/06 09:10:09 gerd Exp $")
 
 (in-package "PCL-TEST")
 
@@ -188,4 +188,68 @@
 	  t)
       (values r (null c)))
   t t)
-      
+
+;;;
+;;; TYPEP and SUBTYPEP used to fail with forward-referenced/unfinalized
+;;; classes.
+;;;
+(deftest defclass-types.0
+    (multiple-value-bind (r c)
+	(ignore-errors
+	  (defclass dfr5 (dfr6) ())
+	  (typep t (find-class 'dfr6)))
+      (values r (null c)))
+  nil t)
+
+(deftest defclass-types.2
+    (multiple-value-bind (r c)
+	(ignore-errors
+	  (defclass dfr7 (dfr8) ())
+	  (multiple-value-list
+	   (subtypep (find-class 'dfr7) (find-class 'dfr8))))
+      (values r (null c)))
+  (t t) t)
+
+(deftest defclass-types.3
+    (multiple-value-bind (r c)
+	(ignore-errors
+	  (defclass dfr7 (dfr8) ())
+	  (multiple-value-list
+	   (subtypep (find-class 'dfr8) (find-class 'dfr7))))
+      (values r (null c)))
+  (nil t) t)
+
+(deftest defclass-types.4
+    (multiple-value-bind (r c)
+	(ignore-errors
+	  (defclass dfr9 (dfr10) ())
+	  (defclass dfr11 (dfr9 dfr12) ())
+	  (append
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr9) (find-class 'dfr10)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr11) (find-class 'dfr10)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr11) (find-class 'dfr9)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr11) (find-class 'dfr12)))))
+      (values r (null c)))
+  (t t t t t t t t) t)
+
+(deftest defclass-types.5
+    (multiple-value-bind (r c)
+	(ignore-errors
+	  (defclass dfr13 () ())
+	  (defclass dfr14 (dfr15 dfr13) ())
+	  (defclass dfr16 (dfr14 dfr17) ())
+	  (append
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr16) (find-class 'dfr14)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr16) (find-class 'dfr17)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr16) (find-class 'dfr15)))
+	   (multiple-value-list
+	    (subtypep (find-class 'dfr16) (find-class 'dfr13)))))
+      (values r (null c)))
+  (t t t t t t t t) t)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 212e76519..646589e17 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.49 2003/04/03 11:40:37 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.50 2003/04/06 09:10:09 gerd Exp $")
 
 (in-package :pcl)
 
@@ -153,10 +153,6 @@
 ;;; Various class accessors that are a little more complicated than can be
 ;;; done with automatically generated reader methods.
 ;;;
-(defmethod class-finalized-p ((class pcl-class))
-  (with-slots (wrapper) class
-    (not (null wrapper))))
-
 (defmethod class-prototype ((class std-class))
   (with-slots (prototype) class
     (or prototype (setq prototype (allocate-instance class)))))
@@ -389,16 +385,17 @@
 		      *the-class-standard-class*)
 		     (t
 		      (class-of class)))))  
-    (flet ((fix-super (s)
-	     (cond ((classp s) s)
-		   ((not (legal-class-name-p s))
-		    (simple-program-error
-		     "~@<~S is not a class or a legal class name.~@:>" s))
+    (flet ((fix-super (super)
+	     (cond ((classp super)
+		    super)
+		   ((legal-class-name-p super)
+		    (or (find-class super nil)
+			(make-instance 'forward-referenced-class
+				       :name super)))
 		   (t
-		    (or (find-class s nil)
-			(setf (find-class s)
-			      (make-instance 'forward-referenced-class
-					     :name s)))))))
+		    (simple-program-error
+		     "~@<~S is not a class or a legal class name.~@:>"
+		     super)))))
       ;;
       ;; CLHS: signal PROGRAM-ERROR, if
       ;; (a) there are any duplicate slot names
@@ -490,11 +487,14 @@
   (setq direct-slots
 	(if direct-slots-p
 	    (setf (slot-value class 'direct-slots)
-		  (mapcar (lambda (pl) (make-direct-slotd class pl)) direct-slots))
+		  (mapcar (lambda (pl) (make-direct-slotd class pl))
+			  direct-slots))
 	    (slot-value class 'direct-slots)))
   (if direct-default-initargs-p
-      (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
-      (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
+      (setf (plist-value class 'direct-default-initargs)
+	    direct-default-initargs)
+      (setq direct-default-initargs
+	    (plist-value class 'direct-default-initargs)))
   (setf (plist-value class 'class-slot-cells)
 	(let ((collected ()))
 	  (dolist (dslotd direct-slots (nreverse collected))
@@ -514,7 +514,42 @@
   (add-direct-subclasses class direct-superclasses)
   (make-class-predicate class predicate-name)
   (update-class class nil)
-  (add-slot-accessors class direct-slots))
+  (add-slot-accessors class direct-slots)
+  (make-preliminary-layout class))
+
+(defmethod shared-initialize :after ((class forward-referenced-class)
+				     slot-names &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (make-preliminary-layout class))
+
+;;;
+;;; Give CLASS a preliminary layout, if it doesn't have a layout
+;;; already.  This is done to make CLASS known to the type system
+;;; before the class is finalized, and is a consequence of the class
+;;; schizophrenia we are suffering from.
+;;;
+(defvar *allow-forward-referenced-classes-in-cpl-p* nil)
+
+(defun make-preliminary-layout (class)
+  (flet ((compute-preliminary-cpl (root)
+	   (let ((*allow-forward-referenced-classes-in-cpl-p* t))
+	     (compute-class-precedence-list root))))
+    (unless (class-finalized-p class)
+      (let ((name (class-name class)))
+	(setf (find-class name) class)
+	(inform-type-system-about-class class name)
+	(let ((layout (make-wrapper 0 class))
+	      (kernel-class (kernel::find-class name)))
+	  (setf (kernel:layout-class layout) kernel-class)
+	  (setf (kernel:%class-pcl-class kernel-class) class)
+	  (setf (slot-value class 'wrapper) layout)
+	  (let ((cpl (compute-preliminary-cpl class)))
+	    (setf (kernel:layout-inherits layout)
+		  (kernel:order-layout-inherits
+		   (map 'simple-vector #'class-wrapper
+			(reverse (rest cpl))))))
+	  (kernel:register-layout layout :invalidate t)
+	  (setf (kernel:%class-layout kernel-class) layout))))))
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
   (declare (ignore slot-names name))
@@ -646,6 +681,7 @@
   (let ((lclass (kernel::find-class (class-name class))))
     (setf (kernel:%class-pcl-class lclass) class)
     (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
+  (setf (slot-value class 'finalized-p) t)
   (update-pv-table-cache-info class)
   (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -710,11 +746,6 @@
    class))
 
 
-(defun class-has-a-forward-referenced-superclass-p (class)
-  (or (forward-referenced-class-p class)
-      (some #'class-has-a-forward-referenced-superclass-p
-	    (class-direct-superclasses class))))	 
-      
 ;;;
 ;;; Called by :after shared-initialize whenever a class is initialized or 
 ;;; reinitialized.  The class may or may not be finalized.
@@ -816,6 +847,7 @@
 	      (wrapper-class-slots nwrapper) nwrapper-class-slots
 	      (wrapper-no-of-instance-slots nwrapper) nslots
 	      wrapper nwrapper))
+      (setf (slot-value class 'finalized-p) t)
 
       (unless (eq owrapper nwrapper)
 	(update-inline-access class)
@@ -1160,8 +1192,12 @@
 (defmethod inform-type-system-about-class ((class condition-class) name)
   (set-class-translation class name))
 
-
+(defmethod inform-type-system-about-class ((class forward-referenced-class)
+					   name)
+  (inform-type-system-about-std-class name)
+  (set-class-translation class name))
 
+
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 
@@ -1505,6 +1541,7 @@
     (with-slots (wrapper class-precedence-list prototype predicate-name
 			 (direct-supers direct-superclasses))
 	class
+      (setf (slot-value class 'finalized-p) t)
       (setf (kernel:%class-pcl-class kernel-class) class)
       (setq direct-supers direct-superclasses)
       (setq wrapper (kernel:%class-layout kernel-class))
-- 
GitLab