X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fdfun.lisp;h=92e10181a859686f2d181de3d3f2a58f802b2f0b;hb=effa5c5b6a302cbcde162c49a1aaa6d96a030add;hp=15601a106d7a65677484fbd567647fd29c4c7426;hpb=2d10bc4b0d8557a5c553d13a3d520c40b48414db;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 15601a1..92e1018 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -492,7 +492,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (some (lambda (method)
           (let ((fmf (if (listp method)
                          (third method)
-                         (method-fast-function method))))
+                         (safe-method-fast-function method))))
             (method-function-get fmf :slot-name-lists)))
         ;; KLUDGE: As of sbcl-0.6.4, it's very important for
         ;; efficiency to know the type of the sequence argument to
@@ -581,14 +581,14 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            (dolist (method methods t)
              (when (eq *boot-state* 'complete)
                (when (or (some #'eql-specializer-p
-                               (method-specializers method))
-                         (method-qualifiers method))
+                               (safe-method-specializers method))
+                         (safe-method-qualifiers method))
                  (return nil)))
              (let ((value (method-function-get
                            (if early-p
                                (or (third method) (second method))
-                               (or (method-fast-function method)
-                                   (method-function method)))
+                               (or (safe-method-fast-function method)
+                                   (safe-method-function method)))
                            :constant-value default)))
                (when (or (eq value default)
                          (and boolean-values-p
@@ -1369,14 +1369,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (let ((definite-p t) (possibly-applicable-methods nil))
     (dolist (method (if (early-gf-p generic-function)
                         (early-gf-methods generic-function)
-                        (if (eq (class-of generic-function)
-                                *the-class-standard-generic-function*)
-                            ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO
-                            (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*)
-                            (generic-function-methods generic-function))))
+                        (safe-generic-function-methods generic-function)))
       (let ((specls (if (consp method)
                         (early-method-specializers method t)
-                        (method-specializers method)))
+                        (safe-method-specializers method)))
             (types types)
             (possibly-applicable-p t) (applicable-p t))
         (dolist (specl specls)
@@ -1645,15 +1641,18 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                            'specializer-applicable-using-type-p
                            type)))))
 
-(defun map-all-classes (function &optional (root t))
-  (let ((braid-p (or (eq *boot-state* 'braid)
+(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))))
     (labels ((do-class (class)
-               (mapc #'do-class
-                     (if braid-p
-                         (class-direct-subclasses class)
-                         (early-class-direct-subclasses class)))
-               (funcall function class)))
+               (unless (gethash class all-classes)
+                 (setf (gethash class all-classes) t)
+                 (funcall fun class)
+                 (mapc #'do-class
+                       (if braid-p
+                           (class-direct-subclasses class)
+                           (early-class-direct-subclasses class))))))
       (do-class (if (symbolp root)
                     (find-class root)
                     root)))))