(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)
- (when (and (eq *boot-state* 'complete)
+ (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)))
(generic-function-methods gf)))
(default '(unknown)))
(and (null applyp)
- (or (not (eq *boot-state* 'complete))
+ (or (not (eq **boot-state** 'complete))
;; If COMPUTE-APPLICABLE-METHODS is specialized, we
;; can't use this, of course, because we can't tell
;; which methods will be considered applicable.
;; method has qualifiers, to make sure that emfs are really
;; method functions; see above.
(dolist (method methods t)
- (when (eq *boot-state* 'complete)
+ (when (eq **boot-state** 'complete)
(when (or (some #'eql-specializer-p
(safe-method-specializers method))
(safe-method-qualifiers method))
(return t)))))
(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
- (when (eq *boot-state* 'complete)
+ (when (eq **boot-state** 'complete)
(unless (or caching-p
(gf-requires-emf-keyword-checks gf)
;; DISPATCH-DFUN-COST will error if it encounters a
(initial-dfun gf args))))
(multiple-value-bind (dfun cache info)
(cond
- ((and (eq *boot-state* 'complete)
+ ((and (eq **boot-state** 'complete)
(not (finalize-specializers gf)))
(values initial-dfun nil (initial-dfun-info)))
- ((and (eq *boot-state* 'complete)
+ ((and (eq **boot-state** 'complete)
(compute-applicable-methods-emf-std-p gf))
(let* ((caching-p (use-caching-dfun-p gf))
;; KLUDGE: the only effect of this (when
(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))))
(safe-method-qualifiers meth))
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
- (early-p (not (eq *boot-state* 'complete)))
+ (early-p (not (eq **boot-state** 'complete)))
(slot-name (when accessor-class
(if (consp meth)
(and (early-method-standard-accessor-p meth)
(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)
(generic-function-methods gf)))
(all-index nil)
(no-class-slots-p t)
- (early-p (not (eq *boot-state* 'complete)))
+ (early-p (not (eq **boot-state** 'complete)))
first second (size 0))
(declare (fixnum size))
;; class -> {(specl slotd)}
(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)
precedence
(lambda (class1 class2 index)
(let* ((class (type-class (nth index types)))
- (cpl (if (eq *boot-state* 'complete)
+ (cpl (if (eq **boot-state** 'complete)
(class-precedence-list class)
(early-class-precedence-list class))))
(if (memq class2 (memq class1 cpl))
(stable-sort methods #'sorter)))
(defun order-specializers (specl1 specl2 index compare-classes-function)
- (let ((type1 (if (eq *boot-state* 'complete)
+ (let ((type1 (if (eq **boot-state** 'complete)
(specializer-type specl1)
(!bootstrap-get-slot 'specializer specl1 '%type)))
- (type2 (if (eq *boot-state* 'complete)
+ (type2 (if (eq **boot-state** 'complete)
(specializer-type specl2)
(!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
;;; 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)
argument-precedence-order)))
(defun cpl-or-nil (class)
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(progn
;; KLUDGE: why not use (slot-boundp class
;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
(defun map-all-classes (fun &optional (root t))
(let ((all-classes (make-hash-table :test 'eq))
- (braid-p (or (eq *boot-state* 'braid)
- (eq *boot-state* 'complete))))
+ (braid-p (or (eq **boot-state** 'braid)
+ (eq **boot-state** 'complete))))
(labels ((do-class (class)
(unless (gethash class all-classes)
(setf (gethash class all-classes) t)
wrappers-p all-applicable-p
all-sorted-p function-p)
(if (and all-applicable-p all-sorted-p (not function-p))
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(let* ((combin (generic-function-method-combination gf))
(effective (compute-effective-method gf combin methods)))
(make-effective-method-function1 gf effective method-alist-p
(get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
(defun methods-contain-eql-specializer-p (methods)
- (and (eq *boot-state* 'complete)
+ (and (eq **boot-state** 'complete)
(dolist (method methods nil)
(when (dolist (spec (method-specializers method) nil)
(when (eql-specializer-p spec) (return t)))
;;; 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*)))
projects / sbcl.git / blobdiff