X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=a65384294c8edea2fc9e2b58151b0ec1d0f69c46;hb=df679ed627975948b1cee190f4d79c397588c43e;hp=34a1d5a1462da9bcc104e8c7ccdb04f4ccdcd871;hpb=015c86a5eaaa3d2490d221ae56ffec36d2007529;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 34a1d5a..a653842 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -86,6 +86,20 @@ (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) +;;; CMUCL (Gerd PCL 2003-04-25) comment: +;;; +;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF +;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/ +;;; writing/testing effective slot SLOTD. +;;; +;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on +;;; GF. Store the effective method in the effective slot definition +;;; object itself; these GFs have special dispatch functions calling +;;; effective methods directly retrieved from effective slot +;;; definition objects, as an optimization. +;;; +;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, +;;; or some such. (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) @@ -485,6 +499,9 @@ (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) + ;; The below initializes shared slots from direct initforms, + ;; but one might inherit initforms from superclasses + ;; (cf. UPDATE-SHARED-SLOT-VALUES). (let (collect) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) @@ -505,6 +522,26 @@ (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)) + ((null slots) (when dupes + (style-warn + ;; FIXME: the indentation request ("~4I") + ;; below appears not to do anything. Finding + ;; out why would be nice. -- CSR, 2003-04-24 + "~@~@:>" + class + dupes))) + (let* ((slot (car slots)) + (oslots (remove (slot-definition-name slot) (cdr slots) + :test-not #'string= :key #'slot-definition-name))) + (when oslots + (pushnew (cons (slot-definition-name slot) + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car)))) (add-slot-accessors class direct-slots) (make-preliminary-layout class)) @@ -710,7 +747,7 @@ (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) -(defmethod direct-slot-definition-class ((class structure-class) initargs) +(defmethod direct-slot-definition-class ((class structure-class) &rest initargs) (declare (ignore initargs)) (find-class 'structure-direct-slot-definition)) @@ -792,13 +829,27 @@ (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) + (update-shared-slot-values class) (update-ctors 'finalize-inheritance :class class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) +(defun update-shared-slot-values (class) + (dolist (slot (class-slots class)) + (when (eq (slot-definition-allocation slot) :class) + (let ((cell (assq (slot-definition-name slot) (class-slot-cells class)))) + (when cell + (let ((initfn (slot-definition-initfunction slot))) + (when initfn + (setf (cdr cell) (funcall initfn))))))))) + (defun update-cpl (class cpl) (if (class-finalized-p class) - (unless (equal (class-precedence-list class) cpl) + (unless (and (equal (class-precedence-list class) cpl) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. @@ -896,29 +947,20 @@ (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) - (let ((cpl (class-precedence-list class)) - (direct (class-direct-default-initargs class))) - (labels ((walk (tail) - (if (null tail) - nil - (let ((c (pop tail))) - (append (if (eq c class) - direct - (class-direct-default-initargs c)) - (walk tail)))))) - (let ((initargs (walk cpl))) - (delete-duplicates initargs :test #'eq :key #'car :from-end t))))) + (let ((initargs (loop for c in (class-precedence-list class) + append (class-direct-default-initargs c)))) + (delete-duplicates initargs :test #'eq :key #'car :from-end t))) ;;;; protocols for constructing direct and effective slot definitions -(defmethod direct-slot-definition-class ((class std-class) initargs) +(defmethod direct-slot-definition-class ((class std-class) &rest initargs) (declare (ignore initargs)) (find-class 'standard-direct-slot-definition)) (defun make-direct-slotd (class initargs) (let ((initargs (list* :class class initargs))) (apply #'make-instance - (direct-slot-definition-class class initargs) + (apply #'direct-slot-definition-class class initargs) initargs))) (defmethod compute-slots ((class std-class)) @@ -1025,14 +1067,14 @@ (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) (declare (ignore name)) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (effective-slot-definition-class class initargs))) + (class (apply #'effective-slot-definition-class class initargs))) (apply #'make-instance class initargs))) -(defmethod effective-slot-definition-class ((class std-class) initargs) +(defmethod effective-slot-definition-class ((class std-class) &rest initargs) (declare (ignore initargs)) (find-class 'standard-effective-slot-definition)) -(defmethod effective-slot-definition-class ((class structure-class) initargs) +(defmethod effective-slot-definition-class ((class structure-class) &rest initargs) (declare (ignore initargs)) (find-class 'structure-effective-slot-definition))