X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=4bc4f1ea0444c5701d09f9048baa8fc905246d60;hb=d25e3478acccec70402ff32554669a982be8e281;hp=8ad72f6631d62e9c812c12a3c44af89f0f59d54d;hpb=9283908642216e9a3cc217f8e3eab186c8876593;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 8ad72f6..4bc4f1e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1585,7 +1585,7 @@
       (eq gf #'(setf slot-value-using-class))
       (eq gf #'slot-boundp-using-class)))
 
-(let (po-cache)
+(let (initial-print-object-cache)
   (defmethod compute-discriminating-function ((gf standard-generic-function))
     (let ((dfun-state (slot-value gf 'dfun-state)))
       (when (special-case-for-compute-discriminating-function-p gf)
@@ -1623,11 +1623,11 @@
               (cond ((/= nkeys 1)
                      ;; KLUDGE: someone has defined a method
                      ;; specialized on the second argument: punt.
-                     (setf po-cache nil)
+                     (setf initial-print-object-cache nil)
                      (make-initial-dfun gf))
-                    (po-cache
+                    (initial-print-object-cache
                      (multiple-value-bind (dfun cache info)
-                         (make-caching-dfun gf po-cache)
+                         (make-caching-dfun gf (copy-cache initial-print-object-cache))
                        (set-dfun gf dfun cache info)))
                     ;; the relevant PRINT-OBJECT methods get defined
                     ;; late, by delayed DEF!METHOD.  We mustn't cache
@@ -1639,27 +1639,20 @@
                     (t (multiple-value-bind (dfun cache info)
                            (make-final-dfun-internal
                             gf
-                            (list (list (find-class 'sb-kernel::control-stack-exhausted))
-                                  (list (find-class 'sb-kernel::heap-exhausted-error))
-                                  (list (find-class 'restart))))
-                         (setq po-cache cache)
-                         (set-dfun gf dfun cache info))))))
+                            (mapcar (lambda (x) (list (find-class x)))
+                                    '(sb-kernel::control-stack-exhausted
+                                      sb-kernel::binding-stack-exhausted
+                                      sb-kernel::alien-stack-exhausted
+                                      sb-kernel::heap-exhausted-error
+                                      restart)))
+                         (setq initial-print-object-cache cache)
+                         (set-dfun gf dfun (copy-cache cache) info))))))
            ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
             (make-final-dfun gf))
            (t
             (make-initial-dfun gf))))
         (function dfun-state)
         (cons (car dfun-state))))))
-
-(defmethod update-gf-dfun ((class std-class) gf)
-  (let ((*new-class* class)
-        (arg-info (gf-arg-info gf)))
-    (cond
-      ((special-case-for-compute-discriminating-function-p gf))
-      ((gf-precompute-dfun-and-emf-p arg-info)
-       (multiple-value-bind (dfun cache info)
-           (make-final-dfun-internal gf)
-         (update-dfun gf dfun cache info))))))
 
 (defmethod (setf class-name) (new-value class)
   (let ((classoid (wrapper-classoid (class-wrapper class))))