X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=41b439009d258a0f492023543ea53ea8642dbdfa;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=d60c04c3858ed8e0c23a0f20c856b0f26e238188;hpb=f4e8bca5eaa6e6db42299fe2f3852fb2e07508c7;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d60c04c..41b4390 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -349,15 +349,17 @@ (defun ensure-class-values (class initargs) (let (metaclass metaclassp reversed-plist) (doplist (key val) initargs - (cond ((eq key :metaclass) - (setf metaclass val - metaclassp key)) - (t - (when (eq key :direct-superclasses) - (setf val (mapcar #'fix-super val))) - (setf reversed-plist (list* val key reversed-plist))))) + (cond ((eq key :metaclass) + (setf metaclass val + metaclassp key)) + (t + (when (eq key :direct-superclasses) + (setf val (mapcar #'fix-super val))) + (setf reversed-plist (list* val key reversed-plist))))) (values (cond (metaclassp - (find-class metaclass)) + (if (classp metaclass) + metaclass + (find-class metaclass))) ((or (null class) (forward-referenced-class-p class)) *the-class-standard-class*) (t @@ -501,8 +503,9 @@ (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) -(defmethod reinitialize-instance :before ((class slot-class) &key) - (remove-direct-subclasses class (class-direct-superclasses class)) +(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))) (defmethod reinitialize-instance :after ((class slot-class) @@ -647,15 +650,8 @@ (defun make-defstruct-allocation-function (class) (let ((dd (get-structure-dd (class-name class)))) (lambda () - (let ((instance (%make-instance (dd-length dd))) - (raw-index (dd-raw-index dd))) - (setf (%instance-layout instance) - (sb-kernel::compiler-layout-or-lose (dd-name dd))) - (when raw-index - (setf (%instance-ref instance raw-index) - (make-array (dd-raw-length dd) - :element-type '(unsigned-byte 32)))) - instance)))) + (sb-kernel::%make-instance-with-layout + (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after ((class structure-class) @@ -743,20 +739,26 @@ (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) - (let ((gf (if (fboundp gfspec) - (without-package-locks - (ensure-generic-function gfspec)) - (ensure-generic-function - gfspec :lambda-list (case r/w - (r '(object)) - (w '(new-value object))))))) - (case r/w - (r (if (eq add/remove 'add) - (add-reader-method class gf name) - (remove-reader-method class gf))) - (w (if (eq add/remove 'add) - (add-writer-method class gf name) - (remove-writer-method class gf))))))) + (let ((gf (cond ((eq add/remove 'add) + (if (fboundp gfspec) + (without-package-locks + (ensure-generic-function gfspec)) + (ensure-generic-function + gfspec :lambda-list (case r/w + (r '(object)) + (w '(new-value object)))))) + ((generic-function-p (and (fboundp gfspec) + (fdefinition gfspec))) + (without-package-locks + (ensure-generic-function gfspec)))))) + (when gf + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf)))))))) (dolist (dslotd dslotds) (let ((slot-name (slot-definition-name dslotd))) (dolist (r (slot-definition-readers dslotd)) @@ -769,11 +771,6 @@ (unless (memq class (class-direct-subclasses class)) (add-direct-subclass super class)))) -(defun remove-direct-subclasses (class supers) - (let ((old (class-direct-superclasses class))) - (dolist (o (set-difference old supers)) - (remove-direct-subclass o class)))) - (defmethod finalize-inheritance ((class std-class)) (update-class class t)) @@ -942,18 +939,26 @@ (find-class 'standard-direct-slot-definition)) (defun make-direct-slotd (class initargs) - (let ((initargs (list* :class class initargs))) - (apply #'make-instance - (apply #'direct-slot-definition-class class initargs) - initargs))) - + (apply #'make-instance + (apply #'direct-slot-definition-class class initargs) + :class class + initargs)) + +;;; I (CSR) am not sure, but I believe that the particular order of +;;; slots is quite important: it is ideal to attempt to have a +;;; constant slot location for the same notional slots as much as +;;; possible, so that clever discriminating functions (ONE-INDEX et +;;; al.) have a chance of working. The below at least walks through +;;; 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)) ;; 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. ;; The list is in most-specific-first order. (let ((name-dslotds-alist ())) - (dolist (c (class-precedence-list class)) + (dolist (c (reverse (class-precedence-list class))) (dolist (slot (class-direct-slots c)) (let* ((name (slot-definition-name slot)) (entry (assq name name-dslotds-alist))) @@ -963,8 +968,8 @@ (mapcar (lambda (direct) (compute-effective-slot-definition class (car direct) - (nreverse (cdr direct)))) - name-dslotds-alist))) + (cdr direct))) + (nreverse name-dslotds-alist)))) (defmethod compute-slots ((class standard-class)) (call-next-method)) @@ -1493,8 +1498,12 @@ (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) - (eq s *the-class-stream*))) + (or (eq s *the-class-t*) (eq s *the-class-stream*) + ;; FIXME: bad things happen if someone tries to mix in both + ;; FILE-STREAM and STRING-STREAM (as they have the same + ;; layout-depthoid). Is there any way we can provide a useful + ;; error message? -- CSR, 2005-05-03 + (eq s *the-class-file-stream*) (eq s *the-class-string-stream*))) ;;; Some necessary methods for FORWARD-REFERENCED-CLASS (defmethod class-direct-slots ((class forward-referenced-class)) ())