type gf)
(let* ((name (slot-value slotd 'name))
(class (slot-value slotd '%class))
- (old-slotd (find-slot-definition class name))
+ (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))))
(multiple-value-bind (function std-p)
(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)
- (setf (slot-accessor-function slotd type) function))
- (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
- (push (cons class name) *pv-table-cache-update-info*))))
+ (setf (slot-accessor-function slotd type) function))))
(defmethod slot-definition-allocation ((slotd structure-slot-definition))
:instance)
;;; here, the values are read by an automatically generated reader method.
(defmethod add-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
- (pushnew subclass direct-subclasses)
+ (pushnew subclass direct-subclasses :test #'eq)
subclass))
(defmethod remove-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr cell) ()
- (car cell) (adjoin method (car cell))))
+ (car cell) (adjoin method (car cell) :test #'eq)))
method)
(defmethod remove-direct-method ((specializer class) (method method))
\f
;;; This hash table is used to store the direct methods and direct generic
;;; functions of EQL specializers. Each value in the table is the cons.
-(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
-(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
+;;;
+;;; These tables are shared between threads, so they need to be synchronized.
+(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t))
+(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t))
(defmethod specializer-method-table ((specializer eql-specializer))
*eql-specializer-methods*)
(let* ((object (specializer-object specializer))
(table (specializer-method-table specializer))
(entry (gethash object table)))
- ;; This table is shared between multiple specializers, but
- ;; no worries as (at least for the time being) our hash-tables
- ;; are thread safe.
(unless entry
(setf entry
(setf (gethash object table) (cons nil nil))))
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr entry) ()
- (car entry) (adjoin method (car entry)))
+ (car entry) (adjoin method (car entry) :test #'eq))
method))
(defmethod remove-direct-method ((specializer specializer-with-object)
((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))
+ (direct-default-initargs nil direct-default-initargs-p)
+ definition-source)
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
(old (assoc name old-class-slot-cells)))
(if (or (not old)
(eq t slot-names)
- (member name slot-names))
+ (member name slot-names :test #'eq))
(let* ((initfunction (slot-definition-initfunction dslotd))
(value (if initfunction
(funcall initfunction)
;; required by AMOP, "Reinitialization of Class Metaobjects"
(finalize-inheritance class)
(update-class class nil))
- (add-slot-accessors class direct-slots)
+ (add-slot-accessors class direct-slots definition-source)
(make-preliminary-layout class))
(defmethod shared-initialize :after ((class forward-referenced-class)
(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))))
+ (let ((classoid (find-classoid (slot-value class 'name))))
(with-slots (wrapper %class-precedence-list cpl-available-p
prototype (direct-supers direct-superclasses))
class
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
(let ((slots (compute-slots class)))
- (setf (slot-value class 'slots) slots
- (slot-value class 'slot-vector) (make-slot-vector class slots)))))
+ (setf (slot-value class 'slots) slots)
+ (setf (layout-slot-table wrapper) (make-slot-table class slots)))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
;; 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)
&rest initargs)
(cons nil nil))))
(values defstruct-form constructor reader-names writer-names)))
-(defun make-defstruct-allocation-function (class)
+(defun make-defstruct-allocation-function (name)
;; FIXME: Why don't we go class->layout->info == dd
- (let ((dd (find-defstruct-description (class-name class))))
- (lambda ()
- (sb-kernel::%make-instance-with-layout
- (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
+ (let ((dd (find-defstruct-description name)))
+ (ecase (dd-type dd)
+ (structure
+ (%make-structure-instance-allocator dd nil))
+ (funcallable-structure
+ (%make-funcallable-structure-instance-allocator dd nil)))))
(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)
+ direct-default-initargs
+ definition-source)
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(or direct-superclasses
(setq direct-superclasses
- (and (not (eq (class-name class) 'structure-object))
+ (and (not (eq (slot-value class 'name) 'structure-object))
(list *the-class-structure-object*)))))
(setq direct-superclasses (slot-value class 'direct-superclasses)))
- (let* ((name (class-name class))
+ (let* ((name (slot-value class 'name))
(from-defclass-p (slot-value class 'from-defclass-p))
(defstruct-p (or from-defclass-p (not (structure-type-p name)))))
(if direct-slots-p
(setf (slot-value class 'defstruct-form) defstruct-form)
(setf (slot-value class 'defstruct-constructor) constructor)))
(setf (slot-value class 'defstruct-constructor)
- (make-defstruct-allocation-function class)))
+ ;; KLUDGE: not class; in fixup.lisp, can't access slots
+ ;; outside methods yet.
+ (make-defstruct-allocation-function name)))
(add-direct-subclasses class direct-superclasses)
(setf (slot-value class '%class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
(let ((slots (compute-slots class)))
- (setf (slot-value class 'slots) slots
- (slot-value class 'slot-vector) (make-slot-vector class slots)))
- (let ((lclass (find-classoid (class-name class))))
- (setf (classoid-pcl-class lclass) class)
- (setf (slot-value class 'wrapper) (classoid-layout lclass)))
+ (setf (slot-value class 'slots) slots)
+ (let* ((lclass (find-classoid (slot-value class 'name)))
+ (layout (classoid-layout lclass)))
+ (setf (classoid-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) layout)
+ (setf (layout-slot-table layout) (make-slot-table class slots))))
(setf (slot-value class 'finalized-p) t)
- (update-pv-table-cache-info class)
- (add-slot-accessors class direct-slots)))
+ (add-slot-accessors class direct-slots definition-source)))
(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(defmethod finalize-inheritance ((class structure-class))
nil) ; always finalized
\f
-(defun add-slot-accessors (class dslotds)
- (fix-slot-accessors class dslotds 'add))
+(defun add-slot-accessors (class dslotds &optional source-location)
+ (fix-slot-accessors class dslotds 'add source-location))
(defun remove-slot-accessors (class dslotds)
(fix-slot-accessors class dslotds 'remove))
-(defun fix-slot-accessors (class dslotds add/remove)
+(defun fix-slot-accessors (class dslotds add/remove &optional source-location)
(flet ((fix (gfspec name r/w doc)
(let ((gf (cond ((eq add/remove 'add)
(or (find-generic-function gfspec nil)
(when gf
(case r/w
(r (if (eq add/remove 'add)
- (add-reader-method class gf name doc)
+ (add-reader-method class gf name doc source-location)
(remove-reader-method class gf)))
(w (if (eq add/remove 'add)
- (add-writer-method class gf name doc)
+ (add-writer-method class gf name doc source-location)
(remove-writer-method class gf))))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd))
(when cpl
(let ((first (car cpl)))
(dolist (c (cdr cpl))
- (pushnew c (slot-value first 'can-precede-list))))
+ (pushnew c (slot-value first 'can-precede-list) :test #'eq)))
(update-class-can-precede-p (cdr cpl))))
(defun class-can-precede-p (class1 class2)
- (member class2 (class-can-precede-list class1)))
+ (member class2 (class-can-precede-list class1) :test #'eq))
(defun update-slots (class eslotds)
(let ((instance-slots ())
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'slots) eslotds
- (slot-value class 'slot-vector) (make-slot-vector class eslotds)
+ (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
- (layout-length nwrapper) nslots
+ (wrapper-length nwrapper) nslots
(slot-value class 'wrapper) nwrapper)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
:test #'string= :key #'car))))
(setf (slot-value class 'finalized-p) t)
(unless (eq owrapper nwrapper)
- (update-pv-table-cache-info class)
(maybe-update-standard-class-locations class)))))
(defun compute-class-slots (eslotds)
(defun update-gfs-of-class (class)
(when (and (class-finalized-p class)
(let ((cpl (class-precedence-list class)))
- (or (member *the-class-slot-class* cpl)
+ (or (member *the-class-slot-class* cpl :test #'eq)
(member *the-class-standard-effective-slot-definition*
- cpl))))
+ cpl :test #'eq))))
(let ((gf-table (make-hash-table :test 'eq)))
(labels ((collect-gfs (class)
(dolist (gf (specializer-direct-generic-functions class))
(declare (ignore direct-slot initargs))
(find-class 'standard-reader-method))
-(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method 'standard-reader-method
()
(or slot-documentation "automatically generated reader method")
:slot-name slot-name
:object-class class
- :method-class-function #'reader-method-class)))
+ :method-class-function #'reader-method-class
+ :definition-source source-location)))
(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
(declare (ignore direct-slot initargs))
(find-class 'standard-writer-method))
-(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method 'standard-writer-method
()
(or slot-documentation "automatically generated writer method")
:slot-name slot-name
:object-class class
- :method-class-function #'writer-method-class)))
+ :method-class-function #'writer-method-class
+ :definition-source source-location)))
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method (constantly (find-class 'standard-boundp-method))
class
(list class)
(make-boundp-method-function class slot-name)
(or slot-documentation "automatically generated boundp method")
- slot-name)))
+ :slot-name slot-name
+ :definition-source source-location)))
(defmethod remove-reader-method ((class slot-class) generic-function)
(let ((method (get-method generic-function () (list class) nil)))
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
+ (setf (wrapper-slot-table nwrapper)
+ (wrapper-slot-table owrapper))
(with-pcl-lock
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
+ (setf (wrapper-slot-table nwrapper)
+ (wrapper-slot-table owrapper))
(with-pcl-lock
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(def class-direct-default-initargs)
(def class-default-initargs))
-(defmethod class-slot-vector (class)
- ;; Default method to cause FIND-SLOT-DEFINITION return NIL for all
- ;; non SLOT-CLASS classes.
- #(nil))
-
(defmethod validate-superclass ((c class) (s built-in-class))
(or (eq s *the-class-t*) (eq s *the-class-stream*)
;; FIXME: bad things happen if someone tries to mix in both
t)
\f
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
- (pushnew dependent (plist-value metaobject 'dependents)))
+ (pushnew dependent (plist-value metaobject 'dependents) :test #'eq))
(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
(setf (plist-value metaobject 'dependents)
projects / sbcl.git / blobdiff