X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=13bc885a07cd75927a3ab7e00cefc365952fde1f;hb=fa2c3ba871c9818e5768fd8f6092ddda83a93a1f;hp=4bc4f1ea0444c5701d09f9048baa8fc905246d60;hpb=c47a1dd98bc2d0be7910782c46cf29349ce973c1;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4bc4f1e..13bc885 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)
@@ -554,7 +554,6 @@
                        (warn "~@<Invalid qualifiers for ~S method combination ~
                               in method ~S:~2I~_~S.~@:>"
                              mc-name method qualifiers))))))
-
               (unless skip-dfun-update-p
                 (update-ctors 'add-method
                               :generic-function generic-function
@@ -616,11 +615,11 @@
             ;; 7.6.4 point 5 probably entails that if any method says
             ;; &allow-other-keys then the gf should be construed to
             ;; accept any key.
-            (let ((allowp (or gf.allowp
-                              (find '&allow-other-keys methods
-                                    :test #'find
-                                    :key #'method-lambda-list))))
-              (setf (info :function :type name)
+            (let* ((allowp (or gf.allowp
+                               (find '&allow-other-keys methods
+                                     :test #'find
+                                     :key #'method-lambda-list)))
+                   (ftype
                     (specifier-type
                      `(function
                        (,@(mapcar tfun gf.required)
@@ -644,10 +643,11 @@
                               `(&key))
                           ,@(when allowp
                               `(&allow-other-keys)))
-                       *))
+                       *))))
+              (setf (info :function :type name) ftype
                     (info :function :where-from name) :defined-method
-                    (gf-info-needs-update gf) nil))))))
-    (values)))
+                    (gf-info-needs-update gf) nil)
+              ftype)))))))
 
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -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)
@@ -1570,15 +1541,15 @@
 
 (defun slot-value-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-reader-function slotd) object))
+  (funcall (slot-info-reader (slot-definition-info slotd)) object))
 
 (defun setf-slot-value-using-class-dfun (new-value class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-writer-function slotd) new-value object))
+  (funcall (slot-info-writer (slot-definition-info slotd)) new-value object))
 
 (defun slot-boundp-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-boundp-function slotd) object))
+  (funcall (slot-info-boundp (slot-definition-info slotd)) object))
 
 (defun special-case-for-compute-discriminating-function-p (gf)
   (or (eq gf #'slot-value-using-class)