X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=3acc5db71b5d32d3ace15e3adcc618295abb0891;hb=603af6830a9c242adcec3fe3549e74e04cbe3228;hp=d5d906bdcd3ac39498d82b383d4b596e7bfb18a7;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d5d906b..3acc5db 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -72,19 +72,14 @@ (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) - (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd)) + (class (slot-value slotd '%class))) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type (reader 'slot-value-using-class) (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) - (initialize-internal-slot-gfs name))) + (compute-slot-accessor-info slotd type gf))))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -103,7 +98,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) + (class (slot-value slotd '%class)) (old-slotd (find-slot-definition class name)) (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) @@ -123,7 +118,7 @@ (defmethod class-prototype :before (class) (unless (class-finalized-p class) - (error "~S not yet finalized, cannot allocate a prototype." class))) + (error "~@<~S is not finalized.~:@>" class))) ;;; KLUDGE: For some reason factoring the common body into a function ;;; breaks PCL bootstrapping, so just generate it with a macrolet for @@ -281,24 +276,23 @@ slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) + (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl)))) (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) + (setf (slot-value specl '%type) `(eql ,(specializer-object specl))) (setf (info :type :translator specl) (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names) + readers writers slot-names source-location) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) + :definition-source source-location other))) res))) @@ -316,6 +310,7 @@ (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) + #+nil (set-class-type-translation (class-prototype meta) name) (setf class (apply #'make-instance meta :name name initargs)) (without-package-locks @@ -334,17 +329,13 @@ (set-class-type-translation class name) class)) -(defmethod class-predicate-name ((class t)) - 'constantly-nil) - (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) (error "~S is not a class or a legal class name." s)) (t (or (find-class s nil) - (make-instance 'forward-referenced-class - :name s))))) + (ensure-class s :metaclass 'forward-referenced-class))))) (defun ensure-class-values (class initargs) (let (metaclass metaclassp reversed-plist) @@ -368,12 +359,10 @@ (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p)) (cond (direct-superclasses-p (setq direct-superclasses (or direct-superclasses @@ -382,10 +371,10 @@ *the-class-standard-object*)))) (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." + (error "~@" superclass class (class-of superclass) (class-of class) 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) @@ -420,15 +409,7 @@ (push (cons name value) collect)) (push old collect))))) (nreverse collect))) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) (add-direct-subclasses class direct-superclasses) - (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -469,37 +450,27 @@ (without-package-locks (unless (class-finalized-p class) (let ((name (class-name class))) - (setf (find-class name) class) ;; KLUDGE: This is fairly horrible. We need to make a ;; full-fledged CLASSOID here, not just tell the compiler that ;; some class is forthcoming, because there are legitimate ;; questions one can ask of the type system, implemented in ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (when (and (eq *boot-state* 'complete) - (null (find-classoid name nil))) - (setf (find-classoid name) - (make-standard-classoid :name name))) - (set-class-type-translation class name) - (let ((layout (make-wrapper 0 class)) - (classoid (find-classoid name))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) + (let ((layout (make-wrapper 0 class))) (setf (slot-value class 'wrapper) layout) (let ((cpl (compute-preliminary-cpl class))) (setf (layout-inherits layout) (order-layout-inherits (map 'simple-vector #'class-wrapper (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout) - (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) + (register-layout layout :invalidate t)))) + (mapc #'make-preliminary-layout (class-direct-subclasses class))))) (defmethod shared-initialize :before ((class class) slot-names &key name) (declare (ignore slot-names name)) ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) - (setf (slot-value class 'type) `(class ,class)) + (setf (slot-value class '%type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) @@ -515,13 +486,27 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(defmethod reinitialize-instance :after ((class condition-class) &key) + (let* ((name (class-name class)) + (classoid (find-classoid name)) + (slots (condition-classoid-slots classoid))) + ;; to balance the REMOVE-SLOT-ACCESSORS call in + ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). + (dolist (slot slots) + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + ;; FIXME: see comment in SHARED-INITIALIZE :AFTER + ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 + (sb-kernel::install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (sb-kernel::install-condition-slot-writer writer name slot-name)))))) + (defmethod shared-initialize :after ((class condition-class) slot-names &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) - (with-slots (wrapper class-precedence-list cpl-available-p - prototype predicate-name - (direct-supers direct-superclasses)) + (with-slots (wrapper %class-precedence-list cpl-available-p + prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) (mapcar (lambda (pl) (make-direct-slotd class pl)) @@ -530,17 +515,23 @@ (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) - (setq class-precedence-list (compute-class-precedence-list class)) + (setq %class-precedence-list (compute-class-precedence-list class)) (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) - (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name) (setf (slot-value class 'slots) (compute-slots class)))) ;; Comment from Gerd's PCL, 2003-05-15: ;; ;; We don't ADD-SLOT-ACCESSORS here because we don't want to ;; override condition accessors with generic functions. We do this ;; differently. + ;; + ;; ??? What does the above comment mean and why is it a good idea? + ;; CMUCL (which still as of 2005-11-18 uses this code and has this + ;; comment) loses slot information in its condition classes: + ;; DIRECT-SLOTS is always NIL. We have the right information, so we + ;; remove slot accessors but never put them back. I've added a + ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what + ;; was meant to happen? -- CSR, 2005-11-18 (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) @@ -584,7 +575,7 @@ (compute-effective-slot-definition class (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) @@ -654,12 +645,10 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) + ((class structure-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) + direct-default-initargs) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) @@ -693,7 +682,7 @@ (unless (structure-type-p name) (eval defstruct-form)) (mapc (lambda (dslotd reader-name writer-name) (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) + (writer (when (fboundp writer-name) (gdefinition writer-name)))) (setf (slot-value dslotd 'internal-reader-function) reader) @@ -705,7 +694,7 @@ (setf (slot-value class 'defstruct-constructor) (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) + (setf (slot-value class '%class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'cpl-available-p) t) (setf (slot-value class 'slots) (compute-slots class)) @@ -714,14 +703,6 @@ (setf (slot-value class 'wrapper) (classoid-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) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) (defmethod direct-slot-definition-class ((class structure-class) &rest initargs) @@ -793,34 +774,41 @@ ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) - ;; Comment from Gerd Moellmann: - ;; - ;; Note that we can't simply delay the finalization when CLASS has - ;; no forward referenced superclasses because that causes bootstrap - ;; problems. (without-package-locks - (when (and (not finalizep) - (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) - (finalize-inheritance class) - (return-from update-class)) - (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) - (setf (find-class (class-name class)) class) + (when (or finalizep (class-finalized-p class)) (update-cpl class (compute-class-precedence-list class)) ;; This invocation of UPDATE-SLOTS, in practice, finalizes the - ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE - ;; is called at finalization, so that MOP programmers can hook - ;; into the system as described in "Class Finalization Protocol" - ;; (section 5.5.2 of AMOP). + ;; class. (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) + +(define-condition cpl-protocol-violation (reference-condition error) + ((class :initarg :class :reader cpl-protocol-violation-class) + (cpl :initarg :cpl :reader cpl-protocol-violation-cpl)) + (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol"))) + (:report + (lambda (c s) + (format s "~@" + (class-name (class-of (cpl-protocol-violation-class c))) + (cpl-protocol-violation-class c) + (eq (class-of (cpl-protocol-violation-class c)) + *the-class-funcallable-standard-class*) + (find-class 'function) + (cpl-protocol-violation-cpl c))))) (defun update-cpl (class cpl) + (when (eq (class-of class) *the-class-standard-class*) + (when (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) + (when (eq (class-of class) *the-class-funcallable-standard-class*) + (unless (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) (dolist (c cpl t) @@ -830,11 +818,11 @@ ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t) (force-cache-flushes class)) (progn - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) (update-class-can-precede-p cpl)) @@ -901,11 +889,12 @@ (defun compute-class-slots (eslotds) (let (collect) - (dolist (eslotd eslotds) - (push (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-class eslotd))) - collect)) - (nreverse collect))) + (dolist (eslotd eslotds (nreverse collect)) + (let ((cell (assoc (slot-definition-name eslotd) + (class-slot-cells + (slot-definition-allocation-class eslotd))))) + (aver cell) + (push cell collect))))) (defun update-gfs-of-class (class) (when (and (class-finalized-p class) @@ -952,7 +941,7 @@ ;;; the slots predictably, but maybe it would be good to compute some ;;; kind of optimal slot layout by looking at locations of slots in ;;; superclasses? -(defmethod compute-slots ((class std-class)) +(defun std-compute-slots (class) ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once ;; for each different slot name we find in our superclasses. Each ;; call receives the class and a list of the dslotds with that name. @@ -972,11 +961,12 @@ (nreverse name-dslotds-alist)))) (defmethod compute-slots ((class standard-class)) - (call-next-method)) + (std-compute-slots class)) +(defmethod compute-slots ((class funcallable-standard-class)) + (std-compute-slots class)) -(defmethod compute-slots :around ((class standard-class)) - (let ((eslotds (call-next-method)) - (location -1)) +(defun std-compute-slots-around (class eslotds) + (let ((location -1)) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) (case (slot-definition-allocation eslotd) @@ -995,9 +985,9 @@ ;; do if we find that said user has added a slot ;; with the same name as another slot... (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) + (let ((c (cons name +slot-unbound+))) + (push c (class-slot-cells from-class)) + c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) ;; We may have inherited an initfunction @@ -1010,53 +1000,12 @@ (setf (slot-definition-class eslotd) class)) (initialize-internal-slot-functions eslotd)))) -(defmethod compute-slots ((class funcallable-standard-class)) - (call-next-method)) - +(defmethod compute-slots :around ((class standard-class)) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots :around ((class funcallable-standard-class)) - (labels ((instance-slot-names (slotds) - (let (collect) - (dolist (slotd slotds (nreverse collect)) - (when (eq (slot-definition-allocation slotd) :instance) - (push (slot-definition-name slotd) collect))))) - ;; This sorts slots so that slots of classes later in the CPL - ;; come before slots of other classes. This is crucial for - ;; funcallable instances because it ensures that the slots of - ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of - ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn - ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as - ;; a funcallable instance. - (compute-layout (eslotds) - (let ((first ()) - (names (instance-slot-names eslotds))) - (dolist (class - (reverse (class-precedence-list class)) - (nreverse (nconc names first))) - (dolist (ss (class-slots class)) - (let ((name (slot-definition-name ss))) - (when (member name names) - (push name first) - (setq names (delete name names))))))))) - (let ((all-slotds (call-next-method)) - (instance-slots ()) - (class-slots ())) - (dolist (slotd all-slotds) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slots)) - (:class (push slotd class-slots)))) - (let ((layout (compute-layout instance-slots))) - (dolist (slotd instance-slots) - (setf (slot-definition-location slotd) - (position (slot-definition-name slotd) layout)) - (initialize-internal-slot-functions slotd))) - (dolist (slotd class-slots) - (let ((name (slot-definition-name slotd)) - (from-class (slot-definition-allocation-class slotd))) - (setf (slot-definition-location slotd) - (assoc name (class-slot-cells from-class))) - (aver (consp (slot-definition-location slotd))) - (initialize-internal-slot-functions slotd))) - all-slotds))) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots ((class structure-class)) (mapcan (lambda (superclass) @@ -1066,7 +1015,7 @@ (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) @@ -1096,6 +1045,8 @@ (allocation nil) (allocation-class nil) (type t) + (documentation nil) + (documentationp nil) (namep nil) (initp nil) (allocp nil)) @@ -1110,15 +1061,24 @@ (setq initform (slot-definition-initform slotd) initfunction (slot-definition-initfunction slotd) initp t))) + (unless documentationp + (when (%slot-definition-documentation slotd) + (setq documentation (%slot-definition-documentation slotd) + documentationp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) allocation-class (slot-definition-class slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type t) slotd-type) - ((*subtypep type slotd-type) type) - (t `(and ,type ,slotd-type))))))) + (setq type (cond + ((eq type t) slotd-type) + ;; This pairwise type intersection is perhaps a + ;; little inefficient and inelegant, but it's + ;; unlikely to lie on the critical path. Shout + ;; if I'm wrong. -- CSR, 2005-11-24 + (t (type-specifier + (specifier-type `(and ,type ,slotd-type))))))))) (list :name name :initform initform :initfunction initfunction @@ -1126,7 +1086,8 @@ :allocation allocation :allocation-class allocation-class :type type - :class class))) + :class class + :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) @@ -1218,14 +1179,13 @@ (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) -(defmethod validate-superclass ((class class) (new-super class)) - (or (eq new-super *the-class-t*) - (eq (class-of class) (class-of new-super)))) - -(defmethod validate-superclass ((class standard-class) (new-super std-class)) - (let ((new-super-meta-class (class-of new-super))) - (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of class) new-super-meta-class)))) +(defmethod validate-superclass ((class class) (superclass class)) + (or (eq superclass *the-class-t*) + (eq (class-of class) (class-of superclass)) + (and (eq (class-of superclass) *the-class-standard-class*) + (eq (class-of class) *the-class-funcallable-standard-class*)) + (and (eq (class-of superclass) *the-class-funcallable-standard-class*) + (eq (class-of class) *the-class-standard-class*)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it @@ -1288,15 +1248,19 @@ (let* ((owrapper (class-wrapper class)) (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock + (unless (class-finalized-p class) + (if (class-has-a-forward-referenced-superclass-p class) + (return-from make-instances-obsolete class) + (update-cpl class (compute-class-precedence-list class)))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (with-pcl-lock (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) - class))) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class)) @@ -1369,15 +1333,6 @@ ;; -- --> local add slot ;; -- --> shared -- - ;; Collect class slots from inherited wrappers. Needed for - ;; shared -> local transfers of inherited slots. - (let ((inherited (layout-inherits owrapper))) - (loop for i from (1- (length inherited)) downto 0 - for layout = (aref inherited i) - when (typep layout 'wrapper) - do (dolist (slot (wrapper-class-slots layout)) - (pushnew slot oclass-slots :key #'car)))) - ;; Go through all the old local slots. (let ((opos 0)) (dolist (name olayout) @@ -1449,14 +1404,57 @@ (apply #'update-instance-for-different-class copy instance initargs) instance)) -(defmethod change-class ((instance standard-object) - (new-class standard-class) +(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) + (unless (class-finalized-p new-class) + (finalize-inheritance new-class)) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) + (change-class-internal instance new-class initargs)) + +(defmethod change-class ((instance forward-referenced-class) + (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl + (error 'metaobject-initialization-violation + :format-control + "~@" + :format-arguments + (list 'change-class 'forward-referenced-class 'class) + :references + (list '(:amop :generic-function ensure-class-using-class) + '(:amop :initialization class)))) + (when (eq class (find-class 'class)) + (return nil)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) (new-class funcallable-standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) @@ -1487,15 +1485,24 @@ ;;;; But, there are other parts of the protocol we must follow and those ;;;; definitions appear here. -(defmethod shared-initialize :before - ((class built-in-class) slot-names &rest initargs) - (declare (ignore slot-names initargs)) - (error "attempt to initialize or reinitialize a built in class")) - -(defmethod class-direct-slots ((class built-in-class)) ()) -(defmethod class-slots ((class built-in-class)) ()) -(defmethod class-direct-default-initargs ((class built-in-class)) ()) -(defmethod class-default-initargs ((class built-in-class)) ()) +(macrolet ((def (name args control) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list ',name) + :references (list '(:amop :initialization "Class")))))) + (def initialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.") + (def reinitialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.")) + +(macrolet ((def (name) + `(defmethod ,name ((class built-in-class)) nil))) + (def class-direct-slots) + (def class-slots) + (def class-direct-default-initargs) + (def class-default-initargs)) (defmethod validate-superclass ((c class) (s built-in-class)) (or (eq s *the-class-t*) (eq s *the-class-stream*)