(defvar *standard-slot-locations* (make-hash-table :test 'equal))
(defun compute-standard-slot-locations ()
- (clrhash *standard-slot-locations*)
- (dolist (class-name *standard-classes*)
- (let ((class (find-class class-name)))
- (dolist (slot (class-slots class))
- (setf (gethash (cons class (slot-definition-name slot))
- *standard-slot-locations*)
- (slot-definition-location slot))))))
-
-;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS
-;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS.
-(defun maybe-update-standard-class-locations (class)
+ (let ((new (make-hash-table :test 'equal)))
+ (dolist (class-name *standard-classes*)
+ (let ((class (find-class class-name)))
+ (dolist (slot (class-slots class))
+ (setf (gethash (cons class (slot-definition-name slot)) new)
+ (slot-definition-location slot)))))
+ (setf *standard-slot-locations* new)))
+
+(defun maybe-update-standard-slot-locations (class)
(when (and (eq *boot-state* 'complete)
(memq (class-name class) *standard-classes*))
(compute-standard-slot-locations)))
(let ((subcpl (member (ecase type
(reader (car specializers))
(writer (cadr specializers)))
- cpl)))
- (and subcpl (member found-specializer subcpl))))
+ cpl :test #'eq)))
+ (and subcpl (member found-specializer subcpl :test #'eq))))
(setf found-specializer (ecase type
(reader (car specializers))
(writer (cadr specializers))))
(early-class-precedence-list
accessor-class)
(class-precedence-list
- accessor-class)))
- (if early-p
- (not (eq *the-class-standard-method*
- (early-method-class meth)))
- (accessor-method-p meth))
- (if early-p
- (early-accessor-method-slot-name meth)
- (accessor-method-slot-name meth))))))
+ accessor-class))
+ :test #'eq)
+ (accessor-method-p meth)
+ (accessor-method-slot-name meth)))))
(slotd (and accessor-class
(if early-p
(dolist (slot (early-class-slotds accessor-class) nil)
(writer (cadr specializers))))
(specl-cpl (if early-p
(early-class-precedence-list specl)
- (and (class-finalized-p specl)
- (class-precedence-list specl))))
- (so-p (member *the-class-standard-object* specl-cpl))
+ (when (class-finalized-p specl)
+ (class-precedence-list specl))))
+ (so-p (member *the-class-standard-object* specl-cpl :test #'eq))
(slot-name (if (consp method)
(and (early-method-standard-accessor-p method)
(early-method-standard-accessor-slot-name
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
(null so-p)
- (member *the-class-structure-object* specl-cpl))
+ (member *the-class-structure-object* specl-cpl :test #'eq))
(return-from make-accessor-table nil))
;; Collect all the slot-definitions for SLOT-NAME from SPECL and
;; all of its subclasses. If either SPECL or one of the subclasses
;; is not a standard-class, bail out.
(labels ((aux (class)
- ;; FIND-SLOT-DEFINITION might not be defined yet
- (let ((slotd (find-if (lambda (x)
- (eq (sb-pcl::slot-definition-name x)
- slot-name))
- (sb-pcl::class-slots class))))
+ (let ((slotd (find-slot-definition class slot-name)))
(when slotd
- (unless (or early-p
- (slot-accessor-std-p slotd type))
+ (unless (or early-p (slot-accessor-std-p slotd type))
(return-from make-accessor-table nil))
(push (cons specl slotd) (gethash class table))))
(dolist (subclass (sb-pcl::class-direct-subclasses class))
+ (unless (class-finalized-p subclass)
+ (return-from make-accessor-table nil))
(aux subclass))))
(aux specl))))
(maphash (lambda (class specl+slotd-list)
;;; CMUCL comment: used only in map-all-orders
(defun class-might-precede-p (class1 class2)
(if (not *in-precompute-effective-methods-p*)
- (not (member class1 (cdr (class-precedence-list class2))))
+ (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))
(class-can-precede-p class1 class2)))
(defun compute-precedence (lambda-list nreq argument-precedence-order)
;;; I'm aware of, but they look like they might be useful for
;;; debugging or performance tweaking or something, so I've just
;;; commented them out instead of deleting them. -- WHN 2001-03-28
+#||
(defun list-dfun (gf)
(let* ((sym (type-of (gf-dfun-info gf)))
(a (assq sym *dfun-list*)))