X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=37002f97e223139d2eb92c7bd5c31413860fcf14;hb=d25e3478acccec70402ff32554669a982be8e281;hp=5532c12f1f9d653285195be9e00c4591e5062bfd;hpb=ef43bf713ac67d3acf4727a5111567e70675df44;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 5532c12..37002f9 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -187,17 +187,15 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (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)))
@@ -1195,8 +1193,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                    (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))))
@@ -1235,14 +1233,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                            (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)
@@ -1282,7 +1276,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                             (early-class-precedence-list specl)
                             (when (class-finalized-p specl)
                               (class-precedence-list specl))))
-             (so-p (member *the-class-standard-object* specl-cpl))
+             (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
@@ -1290,7 +1284,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                             (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
@@ -1471,7 +1465,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; 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)
@@ -1789,6 +1783,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; 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*)))