0.9.10.2:

[sbcl.git] / src / pcl / dfun.lisp

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 15601a1..7c3ed05 100644 (file)
--- 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
@@ -1224,7 +1224,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; function GF which reads/writes instances of class CLASS.
 ;;; TYPE is one of the symbols READER or WRITER.
 (defun find-standard-class-accessor-method (gf class type)
-  (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+  (let ((cpl (standard-slot-value/class class '%class-precedence-list))
         (found-specializer *the-class-t*)
         (found-method nil))
     (dolist (method (standard-slot-value/gf gf 'methods) found-method)
@@ -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)
@@ -1430,10 +1426,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defun order-specializers (specl1 specl2 index compare-classes-function)
   (let ((type1 (if (eq *boot-state* 'complete)
                    (specializer-type specl1)
-                   (!bootstrap-get-slot 'specializer specl1 'type)))
+                   (!bootstrap-get-slot 'specializer specl1 '%type)))
         (type2 (if (eq *boot-state* 'complete)
                    (specializer-type specl2)
-                   (!bootstrap-get-slot 'specializer specl2 'type))))
+                   (!bootstrap-get-slot 'specializer specl2 '%type))))
     (cond ((eq specl1 specl2)
            nil)
           ((atom type1)
@@ -1645,18 +1641,22 @@ 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)))))
+                    root)))
+    nil))
 \f
 (defvar *effective-method-cache* (make-hash-table :test 'eq))