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