X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=553e17d3294fc47ed0cf2832e43b7601d81659c3;hb=fb03344c5e8388e0b16512f1cb662d8cf5d13972;hp=9952a16d9d35c26b523746d4d80311bf913d1a3a;hpb=1831934a29eb9361472e4f49efbcd5398392a6b0;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 9952a16..553e17d 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) @@ -281,11 +276,11 @@ 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)))))) @@ -315,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 @@ -333,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) @@ -367,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 @@ -419,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)) @@ -468,19 +450,18 @@ (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))) + (let ((classoid (or (let ((layout (slot-value class 'wrapper))) + (when layout (layout-classoid layout))) + #+nil + (find-classoid name nil) + (make-standard-classoid + :name (if (symbolp name) name nil)))) + (layout (make-wrapper 0 class))) (setf (layout-classoid layout) classoid) (setf (classoid-pcl-class classoid) class) (setf (slot-value class 'wrapper) layout) @@ -490,15 +471,15 @@ (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)))))))) + (setf (classoid-layout classoid) layout)))) + (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))) @@ -514,13 +495,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)) @@ -529,17 +524,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) @@ -583,7 +584,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))) @@ -653,12 +654,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) @@ -704,7 +703,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)) @@ -713,14 +712,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) @@ -792,33 +783,17 @@ ;;; 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) @@ -852,11 +827,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)) @@ -923,11 +898,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) @@ -1018,9 +994,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 @@ -1048,7 +1024,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))) @@ -1104,9 +1080,14 @@ 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 @@ -1276,15 +1257,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)) @@ -1357,15 +1342,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) @@ -1439,6 +1415,8 @@ (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 @@ -1473,6 +1451,19 @@ (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)