[armedbear-cvs] r13991 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Wed Jul  4 07:12:57 2012
New Revision: 13991

Log:
Call compute-applicable-methods

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jul  2 09:33:36 2012	(r13990)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Wed Jul  4 07:12:57 2012	(r13991)
@@ -2199,7 +2199,7 @@
           (unless (subclassp (class-of (car args)) specializer)
             (return nil))))))
 
-(defun %compute-applicable-methods (gf args)
+(defun std-compute-applicable-methods (gf args)
   (let ((required-classes (mapcar #'class-of (required-portion gf args)))
         (methods '()))
     (dolist (method (generic-function-methods gf))
@@ -2207,6 +2207,10 @@
         (push method methods)))
     (sort-methods methods gf required-classes)))
 
+(declaim (notinline compute-applicable-methods))
+(defun compute-applicable-methods (gf args)
+  (std-compute-applicable-methods gf args))
+
 ;;; METHOD-APPLICABLE-USING-CLASSES-P
 ;;;
 ;;; If the first return value is T, METHOD is definitely applicable to
@@ -2272,7 +2276,10 @@
       (funcall emfun args)))
 
 (defun slow-method-lookup (gf args)
-  (let ((applicable-methods (%compute-applicable-methods gf args)))
+  (let ((applicable-methods
+          (if (eq (class-of gf) +the-standard-generic-function-class+)
+              (std-compute-applicable-methods gf args)
+              (compute-applicable-methods gf args))))
     (if applicable-methods
         (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
                                    #'std-compute-effective-method
@@ -2303,7 +2310,10 @@
         (apply #'no-applicable-method gf args))))
 
 (defun slow-method-lookup-1 (gf arg arg-specialization)
-  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
+  (let ((applicable-methods
+          (if (eq (class-of gf) +the-standard-generic-function-class+)
+              (std-compute-applicable-methods gf (list arg))
+              (compute-applicable-methods gf (list arg)))))
     (if applicable-methods
         (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
                                   #'std-compute-effective-method
@@ -3150,9 +3160,9 @@
 
 ;;; Applicable methods
 
-(defgeneric compute-applicable-methods (gf args)
+(atomic-defgeneric compute-applicable-methods (gf args)
   (:method ((gf standard-generic-function) args)
-    (%compute-applicable-methods gf args)))
+    (std-compute-applicable-methods gf args)))
 
 (defgeneric compute-applicable-methods-using-classes (gf classes)
   (:method ((gf standard-generic-function) classes)
@@ -3387,12 +3397,14 @@
                                              initargs)
   (let* ((methods
           (nconc
-             (compute-applicable-methods #'shared-initialize
-                                         (list* instance
-                                                shared-initialize-param
-                                                initargs))
+             (std-compute-applicable-methods #'shared-initialize
+                                             (list* instance
+                                                    shared-initialize-param
+                                                    initargs))
              (mapcan #'(lambda (gf)
-                         (compute-applicable-methods gf args))
+                         (if (eq (class-of gf) +the-standard-generic-function-class+)
+                             (std-compute-applicable-methods gf args)
+                             (compute-applicable-methods gf args)))
                      gf-list)))
          (method-keyword-args
           (reduce #'merge-initargs-sets
@@ -3797,7 +3809,7 @@
 
 (defgeneric compute-applicable-methods (gf args))
 (defmethod compute-applicable-methods ((gf standard-generic-function) args)
-  (%compute-applicable-methods gf args))
+  (std-compute-applicable-methods gf args))
 
 ;;; AMOP pg. 207
 (atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment)