X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=a07cf93ce01126627894663fefe778f28bf89305;hb=43a526583b7015e6b9945d16e31da72fda1325f5;hp=bf80f1b4a111ef8102e72e8b61c07b30dc112222;hpb=29003bacae52b0b32626b30e67d6f82a9f4dbce7;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index bf80f1b..a07cf93 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -24,18 +24,20 @@ (in-package "SB-PCL") (defmethod slot-accessor-function ((slotd effective-slot-definition) type) - (ecase type - (reader (slot-definition-reader-function slotd)) - (writer (slot-definition-writer-function slotd)) - (boundp (slot-definition-boundp-function slotd)))) + (let ((info (slot-definition-info slotd))) + (ecase type + (reader (slot-info-reader info)) + (writer (slot-info-writer info)) + (boundp (slot-info-boundp info))))) (defmethod (setf slot-accessor-function) (function (slotd effective-slot-definition) type) - (ecase type - (reader (setf (slot-definition-reader-function slotd) function)) - (writer (setf (slot-definition-writer-function slotd) function)) - (boundp (setf (slot-definition-boundp-function slotd) function)))) + (let ((info (slot-definition-info slotd))) + (ecase type + (reader (setf (slot-info-reader info) function)) + (writer (setf (slot-info-writer info) function)) + (boundp (setf (slot-info-boundp info) function))))) (defconstant +slotd-reader-function-std-p+ 1) (defconstant +slotd-writer-function-std-p+ 2) @@ -69,8 +71,8 @@ (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) -(defmethod initialize-internal-slot-functions ((slotd - effective-slot-definition)) +(defmethod initialize-internal-slot-functions + ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd '%class))) (dolist (type '(reader writer boundp)) @@ -79,7 +81,34 @@ (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))))) + ;; KLUDGE: this logic is cut'n'pasted from + ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is + ;; only called later, because it does things that can't be + ;; computed this early in class finalization; however, we need + ;; this bit as early as possible. -- CSR, 2009-11-05 + (setf (slot-accessor-std-p slotd type) + (let* ((std-method (standard-svuc-method type)) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types))) + (null (cdr methods)))) + (setf (slot-accessor-function slotd type) + (lambda (&rest args) + (declare (dynamic-extent args)) + ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P + ;; work here (see KLUDGE comment above). + (let ((fun (compute-slot-accessor-info slotd type gf))) + (apply fun args)))))))) + +(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition)) + (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)))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -98,12 +127,9 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd '%class)) - (old-slotd (when (class-finalized-p class) - (find-slot-definition class name))) - (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (class (slot-value slotd '%class))) (multiple-value-bind (function std-p) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (get-accessor-method-function gf type class slotd) (get-optimized-std-accessor-method-function class slotd type)) (setf (slot-accessor-std-p slotd type) std-p) @@ -181,13 +207,13 @@ (defmethod add-direct-method :around ((specializer specializer) method) ;; All the actions done under this lock are done in an order ;; that is safe to unwind at any point. - (sb-thread::with-recursive-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-spinlock (*specializer-lock*) (call-next-method))) (defmethod remove-direct-method :around ((specializer specializer) method) ;; All the actions done under this lock are done in an order ;; that is safe to unwind at any point. - (sb-thread::with-recursive-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-spinlock (*specializer-lock*) (call-next-method))) (defmethod add-direct-method ((specializer class) (method method)) @@ -353,7 +379,7 @@ (without-package-locks (setf (find-class name) class)))) ;; After boot (SETF FIND-CLASS) does this. - (unless (eq *boot-state* 'complete) + (unless (eq **boot-state** 'complete) (%set-class-type-translation class name)) class) @@ -367,7 +393,7 @@ (without-package-locks (setf (find-class name) class)))) ;; After boot (SETF FIND-CLASS) does this. - (unless (eq *boot-state* 'complete) + (unless (eq **boot-state** 'complete) (%set-class-type-translation class name)) class) @@ -395,13 +421,15 @@ (t *the-class-standard-class*)) (nreverse reversed-plist))))) +;;; This is used to call initfunctions of :allocation :class slots. (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)))) + (let ((type (slot-definition-type slotd))) + (unless (or (eq t type) + (typep value type)) + (error 'type-error :expected-type type :datum value)))) value)) (defmethod shared-initialize :after @@ -511,7 +539,7 @@ (defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses) (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses)) (remove-direct-subclass old-super class)) - (remove-slot-accessors class (class-direct-slots class))) + (remove-slot-accessors class (class-direct-slots class))) (defmethod reinitialize-instance :after ((class slot-class) &rest initargs @@ -586,18 +614,19 @@ (defmethod compute-effective-slot-definition ((class condition-class) slot-name dslotds) - (let ((slotd (call-next-method))) - (setf (slot-definition-reader-function slotd) + (let* ((slotd (call-next-method)) + (info (slot-definition-info slotd))) + (setf (slot-info-reader info) (lambda (x) (handler-case (condition-reader-function x slot-name) ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot ;; is unbound; maybe it should be a CELL-ERROR of some ;; sort? (error () (values (slot-unbound class x slot-name)))))) - (setf (slot-definition-writer-function slotd) + (setf (slot-info-writer info) (lambda (v x) (condition-writer-function x v slot-name))) - (setf (slot-definition-boundp-function slotd) + (setf (slot-info-boundp info) (lambda (x) (multiple-value-bind (v c) (ignore-errors (condition-reader-function x slot-name)) @@ -615,7 +644,7 @@ (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod shared-initialize :after @@ -886,6 +915,32 @@ (defun class-can-precede-p (class1 class2) (member class2 (class-can-precede-list class1) :test #'eq)) +;;; This is called from %UPDATE-SLOTS when layout doesn't seem to change. +;;; SLOT-INFO structures from old slotds may have been cached in permutation +;;; vectors, but new slotds have had new ones allocated to them. +;;; +;;; This is non-problematic for standard slotds, because we know the structure +;;; is compatible, but if a slot definition class changes, this can change the +;;; way SLOT-VALUE-USING-CLASS should dispatch. +;;; +;;; So, compare all slotd classes, and return T if all remain the same. +(defun slotd-classes-eq (oslotds nslotds) + (labels ((pop-nslotd (name) + (aver nslotds) + ;; Most of the time the first slot is right, but because the + ;; order of instance and non-instance slots can change without + ;; layout changing we cannot rely on that. + (let ((n (pop nslotds))) + (if (eq name (slot-definition-name n)) + n + (prog1 + (pop-nslotd name) + (push n nslotds)))))) + (loop while oslotds + for o = (pop oslotds) + for n = (pop-nslotd (slot-definition-name o)) + always (eq (class-of o) (class-of n))))) + (defun %update-slots (class eslotds) (let ((instance-slots ()) (class-slots ())) @@ -897,7 +952,9 @@ ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. - (let* ((nlayout (mapcar #'slot-definition-name + (let* ((nlayout (mapcar (lambda (slotd) + (cons (slot-definition-name slotd) + (slot-definition-type slotd))) (sort instance-slots #'< :key #'slot-definition-location))) (nslots (length nlayout)) @@ -911,10 +968,9 @@ (cond ((null owrapper) (make-wrapper nslots class)) ((and (equal nlayout olayout) - (not - (loop for o in owrapper-class-slots - for n in nwrapper-class-slots - do (unless (eq (car o) (car n)) (return t))))) + (equal (mapcar #'car owrapper-class-slots) + (mapcar #'car nwrapper-class-slots)) + (slotd-classes-eq (slot-value class 'slots) eslotds)) owrapper) (t ;; This will initialize the new wrapper to have the @@ -939,7 +995,7 @@ (style-warn "~@~@:>" + for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>" class dupes))) (let* ((slot (car slots)) (oslots (remove (slot-definition-name slot) (cdr slots) @@ -1095,14 +1151,14 @@ (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) - (declare (ignore name)) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (apply #'effective-slot-definition-class class initargs))) - (apply #'make-instance class initargs))) + (class (apply #'effective-slot-definition-class class initargs)) + (slotd (apply #'make-instance class initargs))) + slotd)) (defmethod effective-slot-definition-class ((class std-class) &rest initargs) (declare (ignore initargs)) @@ -1121,7 +1177,6 @@ (allocation nil) (allocation-class nil) (type t) - (type-check-function nil) (documentation nil) (documentationp nil) (namep nil) @@ -1147,16 +1202,6 @@ allocation-class (slot-definition-class slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) - (let ((fun (slot-definition-type-check-function slotd))) - (when fun - (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))) - fun)))) (let ((slotd-type (slot-definition-type slotd))) (setq type (cond ((eq type t) slotd-type) @@ -1173,15 +1218,14 @@ :allocation allocation :allocation-class allocation-class :type type - 'type-check-function type-check-function :class class :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) - (let ((slotd (car direct-slotds))) - (list* :defstruct-accessor-symbol - (slot-definition-defstruct-accessor-symbol slotd) + (let* ((slotd (car direct-slotds)) + (accessor (slot-definition-defstruct-accessor-symbol slotd))) + (list* :defstruct-accessor-symbol accessor :internal-reader-function (slot-definition-internal-reader-function slotd) :internal-writer-function @@ -1418,43 +1462,55 @@ (oclass-slots (wrapper-class-slots owrapper)) (added ()) (discarded ()) - (plist ())) + (plist ()) + (safe (safe-p class))) - ;; local --> local transfer value + ;; local --> local transfer value, check type ;; local --> shared discard value, discard slot ;; local --> -- discard slot - ;; shared --> local transfer value + ;; shared --> local transfer value, check type ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) ;; shared --> -- discard value ;; -- --> local add slot ;; -- --> shared -- - ;; Go through all the old local slots. - (let ((opos 0)) - (dolist (name olayout) - (let ((npos (posq name nlayout))) - (if npos - (setf (clos-slots-ref nslots npos) - (clos-slots-ref oslots opos)) - (progn - (push name discarded) - (unless (eq (clos-slots-ref oslots opos) +slot-unbound+) - (setf (getf plist name) (clos-slots-ref oslots opos)))))) - (incf opos))) - - ;; Go through all the old shared slots. - (dolist (oclass-slot-and-val oclass-slots) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (when npos - (setf (clos-slots-ref nslots npos) val))))) + (flet ((set-value (value npos &optional (otype t)) + (when safe + (let ((ntype (cdr (nth npos nlayout)))) + (unless (equal ntype otype) + (assert (typep value ntype) (value) + "~@" + (car (nth npos nlayout)) class value ntype)))) + (setf (clos-slots-ref nslots npos) value))) + ;; Go through all the old local slots. + (let ((opos 0)) + (dolist (spec olayout) + (destructuring-bind (name . otype) spec + (let ((npos (position name nlayout :key #'car))) + (if npos + (set-value (clos-slots-ref oslots opos) npos otype) + (progn + (push name discarded) + (unless (eq (clos-slots-ref oslots opos) +slot-unbound+) + (setf (getf plist name) (clos-slots-ref oslots opos))))))) + (incf opos))) + + ;; Go through all the old shared slots. + (dolist (oclass-slot-and-val oclass-slots) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (position name nlayout :key #'car))) + (when npos + (set-value val npos)))))) ;; Go through all the new local slots to compute the added slots. - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) + (dolist (spec nlayout) + (let ((name (car spec))) + (unless (or (member name olayout :key #'car) + (assq name oclass-slots)) + (push name added)))) (%swap-wrappers-and-slots instance copy) @@ -1473,25 +1529,37 @@ (new-layout (wrapper-instance-slots-layout new-wrapper)) (old-slots (get-slots instance)) (new-slots (get-slots copy)) - (old-class-slots (wrapper-class-slots old-wrapper))) - - ;; "The values of local slots specified by both the class CTO and - ;; CFROM are retained. If such a local slot was unbound, it - ;; remains unbound." - (let ((new-position 0)) - (dolist (new-slot new-layout) - (let ((old-position (posq new-slot old-layout))) - (when old-position - (setf (clos-slots-ref new-slots new-position) - (clos-slots-ref old-slots old-position)))) - (incf new-position))) - - ;; "The values of slots specified as shared in the class CFROM and - ;; as local in the class CTO are retained." - (dolist (slot-and-val old-class-slots) - (let ((position (posq (car slot-and-val) new-layout))) - (when position - (setf (clos-slots-ref new-slots position) (cdr slot-and-val))))) + (old-class-slots (wrapper-class-slots old-wrapper)) + (safe (safe-p new-class))) + + (flet ((set-value (value pos) + (when safe + (let ((spec (nth pos new-layout))) + (assert (typep value (cdr spec)) (value) + "~@" + (car spec) old-class value + (cdr spec) new-class))) + (setf (clos-slots-ref new-slots pos) value))) + ;; "The values of local slots specified by both the class CTO and + ;; CFROM are retained. If such a local slot was unbound, it + ;; remains unbound." + (let ((new-position 0)) + (dolist (new-slot new-layout) + (let* ((name (car new-slot)) + (old-position (position name old-layout :key #'car))) + (when old-position + (set-value (clos-slots-ref old-slots old-position) + new-position))) + (incf new-position))) + + ;; "The values of slots specified as shared in the class CFROM and + ;; as local in the class CTO are retained." + (dolist (slot-and-val old-class-slots) + (let ((position (position (car slot-and-val) new-layout :key #'car))) + (when position + (set-value (cdr slot-and-val) position))))) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage.