diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 72f82d74d59e1c5eff28d41e5766a075a32f3673..64dad49740215058012e888cf7ad75d7b3225a89 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 ef544c1355c4f07b4da2cc2d26dcfed68be3a913..bf70cee182943f5a8fac4214a9c35ac26bde889e 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 5c4c00651c3dd1f7265f0e991becc48cb27faaea..e432e77cff8a6d71b693657bd9d08459ad06ddb2 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 e7d1426f7d4aa51975fb9158581a9e43ac9c9c45..eb2802af7d49410519071bc51e4fedcfdc209a35 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 22af30499286d59c22c528e9de53f4e3e1db87ca..203a39e00342a749064f304263f45219d34e7ab1 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 8be50ad2f4107748eab6899b4f32a94b04e19425..35fc02f4c65a0afc9b981163ef15ecd53cf6d29c 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 ba3a1f0a043381ee2229883b4a78944546a0eb8f..ccb3220061f949183746005d955b52cf2b7b78c0 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 0bbf5beda16965b44587fea22687bce048420a96..aa49bec035978b6661a04e3d05e69c005e65817e 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 212e76519370afd45a2d0269f9e3176de011bf66..646589e17e6e3b979878ab1c50810169fd69cabc 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))