0.9.9.27:

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

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 2d8acb7..251a5fa 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
@@ -968,25 +968,25 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun accessor-miss (gf new object dfun-info)
   (let ((wrapper (wrapper-of object))
-       (previous-miss (assq gf *accessor-miss-history*)))
+        (previous-miss (assq gf *accessor-miss-history*)))
     (when (eq wrapper (cdr previous-miss))
       (error "~@<Vicious metacircle:  The computation of a ~
               dfun of ~s for argument ~s uses the dfun being ~
               computed.~@:>"
-            gf object))
+             gf object))
     (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
-          (ostate (type-of dfun-info))
-          (otype (dfun-info-accessor-type dfun-info))
-          oindex ow0 ow1 cache
-          (args (ecase otype
-                  ((reader boundp) (list object))
-                  (writer (list new object)))))
+           (ostate (type-of dfun-info))
+           (otype (dfun-info-accessor-type dfun-info))
+           oindex ow0 ow1 cache
+           (args (ecase otype
+                   ((reader boundp) (list object))
+                   (writer (list new object)))))
       (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-       ;; The following lexical functions change the state of the
-       ;; dfun to that which is their name.  They accept arguments
-       ;; which are the parameters of the new state, and get other
-       ;; information from the lexical variables bound above.
-       (flet ((two-class (index w0 w1)
+        ;; The following lexical functions change the state of the
+        ;; dfun to that which is their name.  They accept arguments
+        ;; which are the parameters of the new state, and get other
+        ;; information from the lexical variables bound above.
+        (flet ((two-class (index w0 w1)
                (when (zerop (random 2)) (psetf w0 w1 w1 w0))
                (dfun-update gf
                             #'make-two-class-accessor-dfun
@@ -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)
@@ -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))