;;;; various class accessors that are a little more complicated than can be
;;;; done with automatically generated reader methods
-(defmethod class-prototype ((class std-class))
- (with-slots (prototype) class
- (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-prototype ((class structure-class))
- (with-slots (prototype wrapper defstruct-constructor) class
- (or prototype
- (setq prototype
- (if defstruct-constructor
- (allocate-instance class)
- (allocate-standard-instance wrapper))))))
+(defmethod class-prototype :before (class)
+ (unless (class-finalized-p class)
+ (error "~S not yet finalized, cannot allocate a prototype." class)))
+
+;;; KLUDGE: For some reason factoring the common body into a function
+;;; breaks PCL bootstrapping, so just generate it with a macrolet for
+;;; all.
+(macrolet ((def (class)
+ `(defmethod class-prototype ((class ,class))
+ (with-slots (prototype) class
+ (or prototype
+ (setf prototype (allocate-instance class)))))))
+ (def std-class)
+ (def condition-class)
+ (def structure-class))
(defmethod class-direct-default-initargs ((class slot-class))
(plist-value class 'direct-default-initargs))
(defmethod class-slot-cells ((class std-class))
(plist-value class 'class-slot-cells))
+(defmethod (setf class-slot-cells) (new-value (class std-class))
+ (setf (plist-value class 'class-slot-cells) new-value))
\f
;;;; class accessors that are even a little bit more complicated than those
;;;; above. These have a protocol for updating them, we must implement that
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
-\f
-(defun real-load-defclass (name metaclass-name supers slots other)
- (let ((res (apply #'ensure-class name :metaclass metaclass-name
- :direct-superclasses supers
- :direct-slots slots
- :definition-source `((defclass ,name)
- ,*load-pathname*)
- other)))
- res))
+ (setf (slot-value specl 'type)
+ `(eql ,(specializer-object specl)))
+ (setf (info :type :translator specl)
+ (constantly (make-member-type :members (list (specializer-object specl))))))
+
+(defun real-load-defclass (name metaclass-name supers slots other
+ readers writers slot-names)
+ (with-single-package-locked-error (:symbol name "defining ~S as a class")
+ (%compiler-defclass name readers writers slot-names)
+ (let ((res (apply #'ensure-class name :metaclass metaclass-name
+ :direct-superclasses supers
+ :direct-slots slots
+ :definition-source `((defclass ,name)
+ ,*load-pathname*)
+ other)))
+ res)))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
(set-class-type-translation (class-prototype meta) name)
- (setf class (apply #'make-instance meta :name name initargs)
- (find-class name) class)
+ (setf class (apply #'make-instance meta :name name initargs))
+ (without-package-locks
+ (setf (find-class name) class))
(set-class-type-translation class name)
class))
(unless (eq (class-of class) meta)
(apply #'change-class class meta initargs))
(apply #'reinitialize-instance class initargs)
- (setf (find-class name) class)
+ (without-package-locks
+ (setf (find-class name) class))
(set-class-type-translation class name)
class))
(make-instance 'forward-referenced-class
:name s)))))
-(defun ensure-class-values (class args)
- (let* ((initargs (copy-list args))
- (unsupplied (list 1))
- (supplied-meta (getf initargs :metaclass unsupplied))
- (supplied-supers (getf initargs :direct-superclasses unsupplied))
- (supplied-slots (getf initargs :direct-slots unsupplied))
- (meta
- (cond ((neq supplied-meta unsupplied)
- (find-class supplied-meta))
- ((or (null class)
- (forward-referenced-class-p class))
- *the-class-standard-class*)
- (t
- (class-of class)))))
- ;; KLUDGE: It seemed to me initially that there ought to be a way
- ;; of collecting all the erroneous problems in one go, rather than
- ;; this way of solving the problem of signalling the errors that
- ;; we are required to, which stops at the first bogus input.
- ;; However, after playing around a little, I couldn't find that
- ;; way, so I've left it as is, but if someone does come up with a
- ;; better way... -- CSR, 2002-09-08
- (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
- ((endp direct-slots) nil)
- (destructuring-bind (slot &rest more) direct-slots
- (let ((slot-name (getf slot :name)))
- (when (some (lambda (s) (eq slot-name (getf s :name))) more)
- ;; FIXME: It's quite possible that we ought to define an
- ;; SB-INT:PROGRAM-ERROR function to signal these and other
- ;; errors throughout the codebase that are required to be
- ;; of type PROGRAM-ERROR.
- (error 'simple-program-error
- :format-control "~@<There is more than one direct slot ~
- with name ~S.~:>"
- :format-arguments (list slot-name)))
- (do ((stuff slot (cddr stuff)))
- ((endp stuff) nil)
- (destructuring-bind (option value &rest more) stuff
- (cond
- ((and (member option '(:allocation :type
- :initform :documentation))
- (not (eq unsupplied
- (getf more option unsupplied))))
- (error 'simple-program-error
- :format-control "~@<Duplicate slot option ~S for ~
- slot named ~S.~:>"
- :format-arguments (list option slot-name)))
- ((and (eq option :readers)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot reader names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))
- ((and (eq option :initargs)
- (notevery #'symbolp value))
- (error 'simple-program-error
- :format-control "~@<Slot initarg names for slot ~
- named ~S must be symbols.~:>"
- :format-arguments (list slot-name)))))))))
- (loop for (initarg . more) on (getf initargs :direct-default-initargs)
- for name = (car initarg)
- when (some (lambda (a) (eq (car a) name)) more)
- do (error 'simple-program-error
- :format-control "~@<Duplicate initialization argument ~
- name ~S in :DEFAULT-INITARGS.~:>"
- :format-arguments (list name class)))
- (let ((metaclass 0)
- (default-initargs 0))
- (do ((args initargs (cddr args)))
- ((endp args) nil)
- (case (car args)
- (:metaclass
- (when (> (incf metaclass) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :METACLASS ~
- option specified.~:>")))
- (:direct-default-initargs
- (when (> (incf default-initargs) 1)
- (error 'simple-program-error
- :format-control "~@<More than one :DEFAULT-INITARGS ~
- option specified.~:>"))))))
- (remf initargs :metaclass)
- (loop (unless (remf initargs :direct-superclasses) (return)))
- (loop (unless (remf initargs :direct-slots) (return)))
- (values
- meta
- (nconc
- (when (neq supplied-supers unsupplied)
- (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
- (when (neq supplied-slots unsupplied)
- (list :direct-slots supplied-slots))
- initargs))))
+(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)))))
+ (values (cond (metaclassp
+ (find-class metaclass))
+ ((or (null class) (forward-referenced-class-p class))
+ *the-class-standard-class*)
+ (t
+ (class-of class)))
+ (nreverse reversed-plist))))
+
\f
(defmethod shared-initialize :after
((class std-class)
(direct-slots nil direct-slots-p)
(direct-default-initargs nil direct-default-initargs-p)
(predicate-name nil predicate-name-p))
- (declare (ignore slot-names))
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
(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)
+ (let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+ (collect '()))
(dolist (dslotd direct-slots)
(when (eq :class (slot-definition-allocation dslotd))
- (let ((initfunction (slot-definition-initfunction dslotd)))
- (push (cons (slot-definition-name dslotd)
- (if initfunction
- (funcall initfunction)
- +slot-unbound+))
- collect))))
+ ;; see CLHS 4.3.6
+ (let* ((name (slot-definition-name dslotd))
+ (old (assoc name old-class-slot-cells)))
+ (if (or (not old)
+ (eq t slot-names)
+ (member name slot-names))
+ (let* ((initfunction (slot-definition-initfunction dslotd))
+ (value (if initfunction
+ (funcall initfunction)
+ +slot-unbound+)))
+ (push (cons name value) collect))
+ (push old collect)))))
(nreverse collect)))
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
dupes)))
(let* ((slot (car slots))
(oslots (remove (slot-definition-name slot) (cdr slots)
- :test-not #'string= :key #'slot-definition-name)))
+ :test #'string/= :key #'slot-definition-name)))
(when oslots
(pushnew (cons (slot-definition-name slot)
(mapcar #'slot-definition-name oslots))
(flet ((compute-preliminary-cpl (root)
(let ((*allow-forward-referenced-classes-in-cpl-p* t))
(compute-class-precedence-list root))))
- (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)))
- (setf (layout-classoid layout) classoid)
- (setf (classoid-pcl-class classoid) 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)
- (setf (classoid-layout classoid) layout)
- (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
+ (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)))
+ (setf (layout-classoid layout) classoid)
+ (setf (classoid-pcl-class classoid) 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)
+ (setf (classoid-layout classoid) layout)
+ (mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
(defmethod shared-initialize :before ((class class) slot-names &key name)
(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)
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
- (with-slots (wrapper class-precedence-list prototype predicate-name
+ (with-slots (wrapper class-precedence-list cpl-available-p
+ prototype predicate-name
(direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
(setq class-precedence-list (compute-class-precedence-list class))
- (setq prototype (make-condition (class-name 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)
(error "Structure slots must have :INSTANCE allocation.")))
(defun make-structure-class-defstruct-form (name direct-slots include)
- (let* ((conc-name (intern (format nil "~S structure class " name)))
- (constructor (intern (format nil "~Aconstructor" conc-name)))
+ (let* ((conc-name (format-symbol *package* "~S structure class " name))
+ (constructor (format-symbol *package* "~Aconstructor" conc-name))
(defstruct `(defstruct (,name
,@(when include
`((:include ,(class-name include))))
instance))))
(defmethod shared-initialize :after
- ((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))
+ ((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))
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(mapcar (lambda (pl)
(when defstruct-p
(let* ((slot-name (getf pl :name))
- (acc-name
- (format nil
- "~S structure class ~A"
- name slot-name))
- (accessor (intern acc-name)))
+ (accessor
+ (format-symbol *package*
+ "~S structure class ~A"
+ name slot-name)))
(setq pl (list* :defstruct-accessor-symbol
accessor pl))))
(make-direct-slotd class pl))
(make-defstruct-allocation-function class)))
(add-direct-subclasses class direct-superclasses)
(setf (slot-value class 'class-precedence-list)
- (compute-class-precedence-list class))
+ (compute-class-precedence-list class))
+ (setf (slot-value class 'cpl-available-p) t)
(setf (slot-value class 'slots) (compute-slots class))
(let ((lclass (find-classoid (class-name class))))
(setf (classoid-pcl-class lclass) class)
(defun fix-slot-accessors (class dslotds add/remove)
(flet ((fix (gfspec name r/w)
- (let ((gf (ensure-generic-function gfspec)))
- (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 (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)))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd)))
- (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
- (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
+ (dolist (r (slot-definition-readers dslotd))
+ (fix r slot-name 'r))
+ (dolist (w (slot-definition-writers dslotd))
+ (fix w slot-name 'w))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(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))))
-\f
(defmethod finalize-inheritance ((class std-class))
(update-class class t))
;; Note that we can't simply delay the finalization when CLASS has
;; no forward referenced superclasses because that causes bootstrap
;; problems.
- (when (and (not finalizep)
- (not (class-finalized-p class))
+ (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)))
- (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)
- (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).
- (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)))))))))
+ (setf (find-class (class-name class)) 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).
+ (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)))))
(defun update-cpl (class cpl)
(if (class-finalized-p class)
;; 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))
- (setf (slot-value class 'class-precedence-list) cpl))
+ (progn
+ (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class 'cpl-available-p) t)))
(update-class-can-precede-p cpl))
(defun update-class-can-precede-p (cpl)
(update-gf-dfun class gf))
gf-table)))))
-(defun update-inits (class inits)
+(defun update-initargs (class inits)
(setf (plist-value class 'default-initargs) inits))
\f
(defmethod compute-default-initargs ((class slot-class))
(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)))
(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))
(location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
- (ecase (slot-definition-allocation eslotd)
+ (case (slot-definition-allocation eslotd)
(:instance
(incf location))
(:class
(let* ((name (slot-definition-name eslotd))
- (from-class (slot-definition-allocation-class eslotd))
- (cell (assq name (class-slot-cells from-class))))
+ (from-class
+ (or
+ (slot-definition-allocation-class eslotd)
+ ;; we get here if the user adds an extra slot
+ ;; himself...
+ (setf (slot-definition-allocation-class eslotd)
+ class)))
+ ;; which raises the question of what we should
+ ;; 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))))))
(aver (consp cell))
- cell))))
+ (if (eq +slot-unbound+ (cdr cell))
+ ;; We may have inherited an initfunction
+ (let ((initfun (slot-definition-initfunction eslotd)))
+ (if initfun
+ (rplacd cell (funcall initfun))
+ cell))
+ cell)))))
+ (unless (slot-definition-class eslotd)
+ (setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
(defmethod compute-slots ((class funcallable-standard-class))
(instance-slots ())
(class-slots ()))
(dolist (slotd all-slotds)
- (ecase (slot-definition-allocation slotd)
+ (case (slot-definition-allocation slotd)
(:instance (push slotd instance-slots))
(:class (push slotd class-slots))))
(let ((layout (compute-layout instance-slots)))
(with-pcl-lock
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
- (invalidate-wrapper owrapper :flush 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))
class)))
(defmethod make-instances-obsolete ((class symbol))
- (make-instances-obsolete (find-class class)))
+ (make-instances-obsolete (find-class class))
+ ;; ANSI wants the class name when called with a symbol.
+ class)
;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
;;; see an obsolete instance. The times when it is called are:
(added ())
(discarded ())
(plist ()))
- ;; local --> local transfer
- ;; local --> shared discard
- ;; local --> -- discard
- ;; shared --> local transfer
- ;; shared --> shared discard
- ;; shared --> -- discard
- ;; -- --> local add
+
+ ;; local --> local transfer value
+ ;; local --> shared discard value, discard slot
+ ;; local --> -- discard slot
+ ;; shared --> local transfer value
+ ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
+ ;; shared --> -- discard value
+ ;; -- --> 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)
(let ((name (car oclass-slot-and-val))
(val (cdr oclass-slot-and-val)))
(let ((npos (posq name nlayout)))
- (if npos
- (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
- (progn (push name discarded)
- (unless (eq val +slot-unbound+)
- (setf (getf plist name) val)))))))
+ (when npos
+ (setf (clos-slots-ref nslots npos) val)))))
;; Go through all the new local slots to compute the added slots.
(dolist (nlocal nlayout)
(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*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
projects / sbcl.git / blobdiff