X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=2d63c9b108d39adc6ba5855c69f598439879a369;hb=1bab7f87e5800ae7d0eed4e301de15125e72bd6f;hp=e6b08db185a47b8e80f81e78ed24dff9dd9ec13b;hpb=f815f89eb5b1a7d5e6fefaf5b19321d8870931f9;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index e6b08db..2d63c9b 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -370,7 +370,7 @@
 
 (defmethod generic-function-argument-precedence-order
     ((gf standard-generic-function))
-  (aver (eq *boot-state* 'complete))
+  (aver (eq **boot-state** 'complete))
   (loop with arg-info = (gf-arg-info gf)
         with lambda-list = (arg-info-lambda-list arg-info)
         for argument-position in (arg-info-precedence arg-info)
@@ -783,7 +783,7 @@
           (let ((emf (get-effective-method-function generic-function
                                                     methods)))
             (invoke-emf emf args))
-          (apply #'no-applicable-method generic-function args)))))
+          (call-no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
   (loop (when (atom x) (return (eq x y)))
@@ -795,7 +795,7 @@
 (defvar *std-cam-methods* nil)
 
 (defun compute-applicable-methods-emf (generic-function)
-  (if (eq *boot-state* 'complete)
+  (if (eq **boot-state** 'complete)
       (let* ((cam (gdefinition 'compute-applicable-methods))
              (cam-methods (compute-applicable-methods-using-types
                            cam (list `(eql ,generic-function) t))))
@@ -1183,35 +1183,6 @@
         (class-eq (cadr type))
         (class (cadr type)))))
 
-(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
-  (let* ((arg-info (gf-arg-info gf))
-         (methods (generic-function-methods gf))
-         (precedence (arg-info-precedence arg-info))
-         (*in-precompute-effective-methods-p* t)
-         (classes-list nil))
-    (generate-discrimination-net-internal
-     gf methods nil
-     (lambda (methods known-types)
-       (when methods
-         (when classes-list-p
-           (push (mapcar #'class-from-type known-types) classes-list))
-         (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
-                                      methods))))
-           (map-all-orders
-            methods precedence
-            (lambda (methods)
-              (get-secondary-dispatch-function1
-               gf methods known-types
-               nil caching-p no-eql-specls-p))))))
-     (lambda (position type true-value false-value)
-       (declare (ignore position type true-value false-value))
-       nil)
-     (lambda (type)
-       (if (and (consp type) (eq (car type) 'eql))
-           `(class-eq ,(class-of (cadr type)))
-           type)))
-    classes-list))
-
 ;;; We know that known-type implies neither new-type nor `(not ,new-type).
 (defun augment-type (new-type known-type)
   (if (or (eq known-type t)
@@ -1585,7 +1556,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 +1594,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,13 +1610,14 @@
                     (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