From fc1338bb79642f1b02636dfd65d73f806e0bf9df Mon Sep 17 00:00:00 2001
From: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Mon, 10 Feb 2014 02:22:49 +0100
Subject: [PATCH] added GENERALIZERS-OF-USING-CLASS

---
 src/specializable.lisp | 55 +++++++++++++++++++++++-------------------
 1 file changed, 30 insertions(+), 25 deletions(-)

diff --git a/src/specializable.lisp b/src/specializable.lisp
index 8d01319..7b8bcb6 100644
--- a/src/specializable.lisp
+++ b/src/specializable.lisp
@@ -11,10 +11,11 @@
            "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
            "SPECIALIZER<"
 
+           "GENERALIZERS-OF-USING-CLASS"
            "GENERALIZER-OF-USING-CLASS"
            "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
            "GENERALIZER-EQUAL-HASH-KEY"
-           
+
            "DEFINE-EXTENDED-SPECIALIZER"))
 
 (in-package "SPECIALIZABLE")
@@ -72,11 +73,11 @@
 ;;; (defun intern-extended-specializer (gf sname)
 ;;;   (destructuring-bind (kind &rest args) sname
 ;;;     (setf (gethash sname (generic-function-extended-specializers gf))
-;;; 	  (apply (or (get kind 'extended-specializer-parser)
-;;; 		     (error "not declared as an extended specializer name: ~A"
-;;; 			    kind))
-;;; 		 gf
-;;; 		 args))))
+;;;       (apply (or (get kind 'extended-specializer-parser)
+;;;                  (error "not declared as an extended specializer name: ~A"
+;;;                         kind))
+;;;              gf
+;;;              args))))
 
 (defun make-extended-specializer (sname)
   (destructuring-bind (kind &rest args) sname
@@ -110,14 +111,6 @@
 
 ;;; from Closette, changed to use some SBCL functions:
 
-;;; FIXME: this is not actually sufficient argument checking
-(defun required-portion (gf args)
-  (let ((number-required
-	 (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
-    (when (< (length args) number-required)
-      (error "Too few arguments to generic function ~S." gf))
-    (subseq args 0 number-required)))
-
 (defgeneric generalizer-equal-hash-key (generic-function generalizer))
 (defmethod generalizer-equal-hash-key
     ((gf specializable-generic-function) (g class))
@@ -142,23 +135,22 @@
   (cond
     ((not (slot-value gf 'cacheingp))
      (lambda (&rest args)
-       (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                   args)))
+       (let ((generalizers (generalizers-of-using-class gf args)))
          (slow-method-lookup-and-call gf args generalizers))))
     ((first-arg-only-special-case gf)
      (lambda (&rest args)
-       (let* ((g (generalizer-of-using-class gf (car args)))
-              (k (generalizer-equal-hash-key gf g))
-              (emfun (gethash k (emf-table gf) nil)))
+       (let* ((generalizer (first (generalizers-of-using-class gf args))) ; TODO defeats purpose of special case
+              (key (generalizer-equal-hash-key gf generalizer))
+              (emfun (gethash key (emf-table gf) nil)))
          (if emfun
              (sb-pcl::invoke-emf emfun args)
              (slow-method-lookup-and-call
-              gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                      (cdr (required-portion gf args)))))))))
+              gf args (list* generalizer
+                             (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                     (rest (required-portion gf args)))))))))
     (t
      (lambda (&rest args)
-       (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                    (required-portion gf args)))
+       (let* ((generalizers (generalizers-of-using-class gf args))
               (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
               (emfun (gethash keys (emf-table gf) nil)))
          (if emfun
@@ -195,6 +187,20 @@
         (sb-pcl::make-effective-method-function gf em))))
 
 ;; new, not in closette
+  ;;; FIXME: this is not actually sufficient argument checking
+(defun required-portion (gf args)
+  (let ((number-required
+          (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
+    (when (< (length args) number-required)
+      (error "Too few arguments to generic function ~S." gf))
+    (subseq args 0 number-required)))
+
+(defgeneric generalizers-of-using-class (generic-function args))
+
+(defmethod generalizers-of-using-class ((generic-function specializable-generic-function) args)
+  (mapcar (lambda (arg) (generalizer-of-using-class generic-function arg))
+          (required-portion generic-function args)))
+
 (defgeneric generalizer-of-using-class (generic-function object))
 (defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
   (class-of object))
@@ -249,8 +255,7 @@
 			      (sb-mop:method-specializers method)
 			      arguments))
 		   (sb-mop:generic-function-methods gf)))
-   (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                               (required-portion gf arguments))))
+   (let ((generalizers (generalizers-of-using-class gf arguments)))
      (lambda (m1 m2)
        (method-more-specific-p gf m1 m2 generalizers)))))
 
-- 
2.30.2