;;; 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)
(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)
(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
(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)))
+ (%make-structure-instance-allocator dd nil)))
(defmethod shared-initialize :after
((class structure-class) slot-names &key
(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)
- (let* ((lclass (find-classoid (class-name class)))
+ (let* ((lclass (find-classoid (slot-value class 'name)))
(layout (classoid-layout lclass)))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) layout)
(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 ())
(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))
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