X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=84fcda4efb72004f9a86b1441294bb285c0d3709;hb=95f17ca63742f8c164309716b35bc25545a849a6;hp=ef3f7e377e1776274ed33891f16cdea2074413f1;hpb=ccd8e0156b45b6aa88d95bd796e1f49aebebe37d;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ef3f7e3..84fcda4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -150,7 +150,7 @@ ;;; here, the values are read by an automatically generated reader method. (defmethod add-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class - (pushnew subclass direct-subclasses) + (pushnew subclass direct-subclasses :test #'eq) subclass)) (defmethod remove-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class @@ -196,7 +196,7 @@ ;; be in progress, and because if an interrupt catches us we ;; need to have a consistent state. (setf (cdr cell) () - (car cell) (adjoin method (car cell)))) + (car cell) (adjoin method (car cell) :test #'eq))) method) (defmethod remove-direct-method ((specializer class) (method method)) @@ -229,8 +229,10 @@ ;;; This hash table is used to store the direct methods and direct generic ;;; functions of EQL specializers. Each value in the table is the cons. -(defvar *eql-specializer-methods* (make-hash-table :test 'eql)) -(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq)) +;;; +;;; These tables are shared between threads, so they need to be synchronized. +(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t)) +(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t)) (defmethod specializer-method-table ((specializer eql-specializer)) *eql-specializer-methods*) @@ -243,9 +245,6 @@ (let* ((object (specializer-object specializer)) (table (specializer-method-table specializer)) (entry (gethash object table))) - ;; This table is shared between multiple specializers, but - ;; no worries as (at least for the time being) our hash-tables - ;; are thread safe. (unless entry (setf entry (setf (gethash object table) (cons nil nil)))) @@ -253,7 +252,7 @@ ;; be in progress, and because if an interrupt catches us we ;; need to have a consistent state. (setf (cdr entry) () - (car entry) (adjoin method (car entry))) + (car entry) (adjoin method (car entry) :test #'eq)) method)) (defmethod remove-direct-method ((specializer specializer-with-object) @@ -337,33 +336,40 @@ (setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest args) - (apply #'ensure-class-using-class - (let ((class (find-class name nil))) - (when (and class (eq name (class-name class))) - ;; NAME is the proper name of CLASS, so redefine it - class)) - name - args)) + (with-world-lock () + (apply #'ensure-class-using-class + (let ((class (find-class name nil))) + (when (and class (eq name (class-name class))) + ;; NAME is the proper name of CLASS, so redefine it + class)) + name + args))) (defmethod ensure-class-using-class ((class null) name &rest args &key) - (multiple-value-bind (meta initargs) - (frob-ensure-class-args args) - (setf class (apply #'make-instance meta :name name initargs)) - (without-package-locks - (setf (find-class name) class)) - (set-class-type-translation class name) - class)) + (with-world-lock () + (multiple-value-bind (meta initargs) + (frob-ensure-class-args args) + (setf class (apply #'make-instance meta :name name initargs)) + (without-package-locks + (setf (find-class name) class)))) + ;; After boot (SETF FIND-CLASS) does this. + (unless (eq *boot-state* 'complete) + (%set-class-type-translation class name)) + class) (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) - (multiple-value-bind (meta initargs) - (frob-ensure-class-args args) - (unless (eq (class-of class) meta) - (apply #'change-class class meta initargs)) - (apply #'reinitialize-instance class initargs) - (without-package-locks - (setf (find-class name) class)) - (set-class-type-translation class name) - class)) + (with-world-lock () + (multiple-value-bind (meta initargs) + (frob-ensure-class-args args) + (unless (eq (class-of class) meta) + (apply #'change-class class meta initargs)) + (apply #'reinitialize-instance class initargs) + (without-package-locks + (setf (find-class name) class)))) + ;; After boot (SETF FIND-CLASS) does this. + (unless (eq *boot-state* 'complete) + (%set-class-type-translation class name)) + class) (defun frob-ensure-class-args (args) (let (metaclass metaclassp reversed-plist) @@ -388,6 +394,15 @@ (find-class metaclass))) (t *the-class-standard-class*)) (nreverse reversed-plist))))) + +(defun call-initfun (fun slotd safe) + (declare (function fun)) + (let ((value (funcall fun))) + (when safe + (let ((typecheck (slot-definition-type-check-function slotd))) + (when typecheck + (funcall (the function typecheck) value)))) + value)) (defmethod shared-initialize :after ((class std-class) slot-names &key @@ -407,8 +422,8 @@ super-class of the class ~S, ~ but the meta-classes ~S and ~S are incompatible. ~ Define a method for ~S to avoid this error.~@:>" - superclass class (class-of superclass) (class-of class) - 'validate-superclass))) + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) (t (setq direct-superclasses (slot-value class 'direct-superclasses)))) @@ -425,6 +440,7 @@ (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (safe (safe-p class)) (collect '())) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) @@ -433,11 +449,12 @@ (old (assoc name old-class-slot-cells))) (if (or (not old) (eq t slot-names) - (member name slot-names)) + (member name slot-names :test #'eq)) (let* ((initfunction (slot-definition-initfunction dslotd)) - (value (if initfunction - (funcall initfunction) - +slot-unbound+))) + (value + (if initfunction + (call-initfun initfunction dslotd safe) + +slot-unbound+))) (push (cons name value) collect)) (push old collect))))) (nreverse collect))) @@ -462,24 +479,25 @@ (flet ((compute-preliminary-cpl (root) (let ((*allow-forward-referenced-classes-in-cpl-p* t)) (compute-class-precedence-list root)))) - (without-package-locks - (unless (class-finalized-p class) - (let ((name (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. - (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) - (set-class-type-translation class (layout-classoid layout))))) - (mapc #'make-preliminary-layout (class-direct-subclasses class))))) + (with-world-lock () + (without-package-locks + (unless (class-finalized-p class) + (let ((name (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. + (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) + (%set-class-type-translation class (layout-classoid layout))))) + (mapc #'make-preliminary-layout (class-direct-subclasses class)))))) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -520,7 +538,7 @@ (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)))) + (let ((classoid (find-classoid (slot-value class 'name)))) (with-slots (wrapper %class-precedence-list cpl-available-p prototype (direct-supers direct-superclasses)) class @@ -656,12 +674,14 @@ (cons nil nil)))) (values defstruct-form constructor reader-names writer-names))) -(defun make-defstruct-allocation-function (class) +(defun make-defstruct-allocation-function (name) ;; FIXME: Why don't we go class->layout->info == dd - (let ((dd (find-defstruct-description (class-name class)))) - (lambda () - (sb-kernel::%make-instance-with-layout - (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) + (let ((dd (find-defstruct-description name))) + (ecase (dd-type dd) + (structure + (%make-structure-instance-allocator dd nil)) + (funcallable-structure + (%make-funcallable-structure-instance-allocator dd nil))))) (defmethod shared-initialize :after ((class structure-class) slot-names &key @@ -674,10 +694,10 @@ (setf (slot-value class 'direct-superclasses) (or direct-superclasses (setq direct-superclasses - (and (not (eq (class-name class) 'structure-object)) + (and (not (eq (slot-value class 'name) 'structure-object)) (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) - (let* ((name (class-name class)) + (let* ((name (slot-value class 'name)) (from-defclass-p (slot-value class 'from-defclass-p)) (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (if direct-slots-p @@ -712,14 +732,16 @@ (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor))) (setf (slot-value class 'defstruct-constructor) - (make-defstruct-allocation-function class))) + ;; KLUDGE: not class; in fixup.lisp, can't access slots + ;; outside methods yet. + (make-defstruct-allocation-function name))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class '%class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'cpl-available-p) t) (let ((slots (compute-slots class))) (setf (slot-value class 'slots) slots) - (let* ((lclass (find-classoid (class-name class))) + (let* ((lclass (find-classoid (slot-value class 'name))) (layout (classoid-layout lclass))) (setf (classoid-pcl-class lclass) class) (setf (slot-value class 'wrapper) layout) @@ -794,16 +816,17 @@ ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) (without-package-locks - (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. - (update-slots class (compute-slots class)) - (update-gfs-of-class class) - (update-initargs class (compute-default-initargs class)) - (update-ctors 'finalize-inheritance :class class)) - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil)))) + (with-world-lock () + (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. + (%update-slots class (compute-slots class)) + (update-gfs-of-class class) + (setf (plist-value class 'default-initargs) (compute-default-initargs class)) + (update-ctors 'finalize-inheritance :class class)) + (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) @@ -821,7 +844,7 @@ (find-class 'function) (cpl-protocol-violation-cpl c))))) -(defun update-cpl (class cpl) +(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))) @@ -835,11 +858,11 @@ :key #'slot-definition-allocation) (return nil)))) ;; comment from the old CMU CL sources: - ;; Need to have the cpl setup before update-lisp-class-layout + ;; 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 'cpl-available-p) t) - (force-cache-flushes class)) + (%force-cache-flushes class)) (progn (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) @@ -849,13 +872,13 @@ (when cpl (let ((first (car cpl))) (dolist (c (cdr cpl)) - (pushnew c (slot-value first 'can-precede-list)))) + (pushnew c (slot-value first 'can-precede-list) :test #'eq))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) - (member class2 (class-can-precede-list class1))) + (member class2 (class-can-precede-list class1) :test #'eq)) -(defun update-slots (class eslotds) +(defun %update-slots (class eslotds) (let ((instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) @@ -894,7 +917,7 @@ (make-instances-obsolete class) (class-wrapper class))))) - (update-lisp-class-layout class nwrapper) + (%update-lisp-class-layout class nwrapper) (setf (slot-value class 'slots) eslotds (wrapper-slot-table nwrapper) (make-slot-table class eslotds) (wrapper-instance-slots-layout nwrapper) nlayout @@ -921,7 +944,7 @@ :test #'string= :key #'car)))) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) - (maybe-update-standard-class-locations class))))) + (maybe-update-standard-slot-locations class))))) (defun compute-class-slots (eslotds) (let (collect) @@ -932,12 +955,21 @@ (aver cell) (push cell collect))))) +(defun update-gf-dfun (class gf) + (let ((*new-class* class) + (arg-info (gf-arg-info gf))) + (cond + ((special-case-for-compute-discriminating-function-p gf)) + ((gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) + (update-dfun gf dfun cache info)))))) + (defun update-gfs-of-class (class) (when (and (class-finalized-p class) (let ((cpl (class-precedence-list class))) - (or (member *the-class-slot-class* cpl) + (or (member *the-class-slot-class* cpl :test #'eq) (member *the-class-standard-effective-slot-definition* - cpl)))) + cpl :test #'eq)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) (dolist (gf (specializer-direct-generic-functions class)) @@ -948,9 +980,6 @@ (declare (ignore ignore)) (update-gf-dfun class gf)) gf-table))))) - -(defun update-initargs (class inits) - (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) (let ((initargs (loop for c in (class-precedence-list class) @@ -1002,7 +1031,8 @@ (std-compute-slots class)) (defun std-compute-slots-around (class eslotds) - (let ((location -1)) + (let ((location -1) + (safe (safe-p class))) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) (case (slot-definition-allocation eslotd) @@ -1026,10 +1056,12 @@ c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) - ;; We may have inherited an initfunction + ;; We may have inherited an initfunction FIXME: Is this + ;; really right? Is the initialization in + ;; SHARED-INITIALIZE (STD-CLASS) not enough? (let ((initfun (slot-definition-initfunction eslotd))) (if initfun - (rplacd cell (funcall initfun)) + (rplacd cell (call-initfun initfun eslotd safe)) cell)) cell))))) (unless (slot-definition-class eslotd) @@ -1094,13 +1126,13 @@ (setq name (slot-definition-name slotd) namep t)) (unless initp - (when (slot-definition-initfunction slotd) + (awhen (slot-definition-initfunction slotd) (setq initform (slot-definition-initform slotd) - initfunction (slot-definition-initfunction slotd) + initfunction it initp t))) (unless documentationp - (when (%slot-definition-documentation slotd) - (setq documentation (%slot-definition-documentation slotd) + (awhen (%slot-definition-documentation slotd) + (setq documentation it documentationp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) @@ -1112,6 +1144,7 @@ (setf type-check-function (if type-check-function (let ((old-function type-check-function)) + (declare (function old-function fun)) (lambda (value) (funcall old-function value) (funcall fun value))) @@ -1262,7 +1295,7 @@ ;;; :UNINITIALIZED))) ;;; ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29 -(defun force-cache-flushes (class) +(defun %force-cache-flushes (class) (let* ((owrapper (class-wrapper class))) ;; We only need to do something if the wrapper is still valid. If ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and @@ -1283,43 +1316,38 @@ (wrapper-class-slots owrapper)) (setf (wrapper-slot-table nwrapper) (wrapper-slot-table owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - ;; Use :OBSOLETE instead of :FLUSH if any superclass has - ;; been obsoleted. - (if (find-if (lambda (x) - (and (consp x) (eq :obsolete (car x)))) - (layout-inherits owrapper) - :key #'layout-invalid) - (invalidate-wrapper owrapper :obsolete nwrapper) - (invalidate-wrapper owrapper :flush nwrapper))))))) - -(defun flush-cache-trap (owrapper nwrapper instance) - (declare (ignore owrapper)) - (set-wrapper instance nwrapper)) + (%update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + ;; Use :OBSOLETE instead of :FLUSH if any superclass has + ;; been obsoleted. + (if (find-if (lambda (x) + (and (consp x) (eq :obsolete (car x)))) + (layout-inherits owrapper) + :key #'layout-invalid) + (%invalidate-wrapper owrapper :obsolete nwrapper) + (%invalidate-wrapper owrapper :flush nwrapper)))))) ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause ;;; the next access to the instance (as defined in 88-002R) to trap ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. (defmethod make-instances-obsolete ((class std-class)) - (let* ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper (layout-length owrapper) - class))) - (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)) - (setf (wrapper-slot-table nwrapper) - (wrapper-slot-table owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) + (with-world-lock () + (let* ((owrapper (class-wrapper class)) + (nwrapper (make-wrapper (layout-length owrapper) + class))) + (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)) + (setf (wrapper-slot-table nwrapper) + (wrapper-slot-table owrapper)) + (%update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) + (%invalidate-wrapper owrapper :obsolete nwrapper) class))) (defmethod make-instances-obsolete ((class symbol)) @@ -1367,12 +1395,12 @@ "~@" (type-of (obsolete-structure-datum condition)))))) -(defun obsolete-instance-trap (owrapper nwrapper instance) +(defun %obsolete-instance-trap (owrapper nwrapper instance) (if (not (layout-for-std-class-p owrapper)) (if *in-obsolete-instance-trap* *the-wrapper-of-structure-object* - (let ((*in-obsolete-instance-trap* t)) - (error 'obsolete-structure :datum instance))) + (let ((*in-obsolete-instance-trap* t)) + (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) (copy (allocate-instance class)) ;??? allocate-instance ??? (olayout (wrapper-instance-slots-layout owrapper)) @@ -1420,7 +1448,7 @@ (assq nlocal oclass-slots)) (push nlocal added))) - (swap-wrappers-and-slots instance copy) + (%swap-wrappers-and-slots instance copy) (update-instance-for-redefined-class instance added @@ -1428,7 +1456,7 @@ plist) nwrapper))) -(defun change-class-internal (instance new-class initargs) +(defun %change-class (instance new-class initargs) (let* ((old-class (class-of instance)) (copy (allocate-instance new-class)) (new-wrapper (get-wrapper copy)) @@ -1459,63 +1487,67 @@ ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. - (swap-wrappers-and-slots instance copy) + (%swap-wrappers-and-slots instance copy) (apply #'update-instance-for-different-class copy instance initargs) + instance)) (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)) + (with-world-lock () + (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 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)) + (with-world-lock () + (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 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)) + (with-world-lock () + (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 instance new-class initargs))) (defmethod change-class ((instance standard-object) (new-class funcallable-standard-class) @@ -1592,7 +1624,7 @@ t) (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) - (pushnew dependent (plist-value metaobject 'dependents))) + (pushnew dependent (plist-value metaobject 'dependents) :test #'eq)) (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) (setf (plist-value metaobject 'dependents)