diff -U 8 -r C:\usr\unpacked\abcl\abcl-src-0.15.0-original\src/org/armedbear/lisp/StandardGenericFunction.java C:\usr\unpacked\abcl\abcl-src-0.15.0\src/org/armedbear/lisp/StandardGenericFunction.java
--- C:\usr\unpacked\abcl\abcl-src-0.15.0-original\src/org/armedbear/lisp/StandardGenericFunction.java	2009-06-07 14:49:36.000000000 +0300
+++ C:\usr\unpacked\abcl\abcl-src-0.15.0\src/org/armedbear/lisp/StandardGenericFunction.java	2009-07-13 02:43:07.968750000 +0300
@@ -545,24 +545,24 @@
                                 LispObject third)
         throws ConditionThrowable
       {
         final StandardGenericFunction gf = checkStandardGenericFunction(first);
         LispObject args = second;
         LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
         for (int i = gf.numberOfRequiredArgs; i-- > 0;)
           {
-            array[i] = args.car().classOf();
+            array[i] = gf.getArgSpecialization(args.car());
             args = args.cdr();
           }
-        CacheEntry classes = new CacheEntry(array);
+        CacheEntry specializations = new CacheEntry(array);
         HashMap<CacheEntry,LispObject> ht = gf.cache;
         if (ht == null)
             ht = gf.cache = new HashMap<CacheEntry,LispObject>();
-        ht.put(classes, third);
+        ht.put(specializations, third);
         return third;
       }
     };
 
   // ### get-cached-emf
   private static final Primitive GET_CACHED_EMF =
     new Primitive("get-cached-emf", PACKAGE_SYS, true, "generic-function args")
     {
@@ -570,28 +570,107 @@
       public LispObject execute(LispObject first, LispObject second)
         throws ConditionThrowable
       {
         final StandardGenericFunction gf = checkStandardGenericFunction(first);
         LispObject args = second;
         LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
         for (int i = gf.numberOfRequiredArgs; i-- > 0;)
           {
-            array[i] = args.car().classOf();
+            array[i] = gf.getArgSpecialization(args.car());
             args = args.cdr();
           }
-        CacheEntry classes = new CacheEntry(array);
+        CacheEntry specializations = new CacheEntry(array);
         HashMap<CacheEntry,LispObject> ht = gf.cache;
         if (ht == null)
           return NIL;
-        LispObject emf = (LispObject) ht.get(classes);
+        LispObject emf = (LispObject) ht.get(specializations);
         return emf != null ? emf : NIL;
       }
     };
 
+  /**
+   * Returns an object representing generic function 
+   * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
+   *
+   * <p>In the simplest case, when this generic function
+   * does not have EQL specialized methos, and therefore
+   * only argument types are relevant for choosing
+   * applicable methods, the value returned is the 
+   * class of <tt>arg</tt>
+   *
+   * <p>If the function has EQL specialized methods: 
+   *   - if <tt>arg</tt> is EQL to some of the EQL-specializers,
+   *     a special object representing equality to that specializer
+   *     is returned.
+   *   - otherwise class of the <tt>arg</tt> is returned.
+   *
+   * <p>Note that we do not consider argument position, when
+   * calculating arg specialization. In rare cases (when
+   * one argument is eql-specialized to a symbol specifying
+   * class of another argument) this may result in redundant cache
+   * entries caching the same method. But the method cached is anyway
+   * correct for the arguments (because in case of cache miss, correct method
+   * is calculated by other code, which does not rely on getArgSpecialization;
+   * and because EQL is true only for objects of the same type, which guaranties
+   * that if a type-specialized methods was chached by eql-specialization,
+   * all the cache hits into this records will be from args of the conforming 
+   * type).
+   *
+   * <p>Consider:
+   * <pre><tt>
+   * (defgeneric f (a b))
+   *
+   * (defmethod f (a (b (eql 'symbol)))
+   *   "T (EQL 'SYMBOL)")
+   *
+   * (defmethod f ((a symbol) (b (eql 'symbol)))
+   *   "SYMBOL (EQL 'SYMBOL)")
+   *
+   * (f 12 'symbol)
+   * => "T (EQL 'SYMBOL)"
+   *
+   * (f 'twelve 'symbol)
+   * => "SYMBOL (EQL 'SYMBOL)"
+   *
+   * (f 'symbol 'symbol)
+   * => "SYMBOL (EQL 'SYMBOL)"
+   *
+   * </tt></pre>
+   *
+   * After the two above calls <tt>cache</tt> will contain tree keys:
+   * <pre>
+   * { class FIXNUM, EqlSpecialization('SYMBOL) }
+   * { class SYMBOL, EqlSpecialization('SYMBOL) }
+   * { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
+   * </pre>
+   */     
+  private LispObject getArgSpecialization(LispObject arg)
+  {
+    for (EqlSpecialization eqlSpecialization : eqlSpecializations)
+      {
+        if (eqlSpecialization.eqlTo.eql(arg))
+          return eqlSpecialization;
+      }
+    return arg.classOf();
+  }
+
+  // ### %get-arg-specialization
+  private static final Primitive _GET_ARG_SPECIALIZATION =
+    new Primitive("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg")
+    {
+      @Override
+      public LispObject execute(LispObject first, LispObject second)
+        throws ConditionThrowable
+      {
+        final StandardGenericFunction gf = checkStandardGenericFunction(first);
+        return gf.getArgSpecialization(second);
+      }
+    };
+
   // ### cache-slot-location
   private static final Primitive CACHE_SLOT_LOCATION =
     new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location")
     {
       @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)
         throws ConditionThrowable
@@ -661,18 +740,50 @@
         return false;
       final LispObject[] otherArray = otherEntry.array;
       for (int i = array.length; i-- > 0;)
         if (array[i] != otherArray[i])
           return false;
       return true;
     }
   }
+
+  private EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
+
+    // ### %init-eql-specializations
+    private static final Primitive _INIT_EQL_SPECIALIZATIONS =
+      new Primitive("%init-eql-specializations", PACKAGE_SYS, true, "generic-function eql-specilizer-objects-list")
+      {
+        @Override
+        public LispObject execute(LispObject first, LispObject second)
+          throws ConditionThrowable
+        {
+          final StandardGenericFunction gf = checkStandardGenericFunction(first);
+          LispObject eqlSpecializerObjects = second;
+          gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
+          for (int i = 0; i < gf.eqlSpecializations.length; i++)
+          {
+              gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
+              eqlSpecializerObjects = eqlSpecializerObjects.cdr();
+          }
+          return NIL;
+        }
+      };
+
+  private static class EqlSpecialization extends LispObject
+  {
+    public LispObject eqlTo;
+
+    public EqlSpecialization(LispObject eqlTo)
+    {
+        this.eqlTo = eqlTo;
+    }
+  }
   
   public static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
   throws ConditionThrowable
   {
                 if (obj instanceof StandardGenericFunction)
                         return (StandardGenericFunction) obj;
                 return (StandardGenericFunction) // Not reached.
                 type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
-        }
+  }
 }
Only in C:\usr\unpacked\abcl\abcl-src-0.15.0\src/org/armedbear/lisp: StandardGenericFunction.java~
diff -U 8 -r C:\usr\unpacked\abcl\abcl-src-0.15.0-original\src/org/armedbear/lisp/clos.lisp C:\usr\unpacked\abcl\abcl-src-0.15.0\src/org/armedbear/lisp/clos.lisp
--- C:\usr\unpacked\abcl\abcl-src-0.15.0-original\src/org/armedbear/lisp/clos.lisp	2009-06-07 14:49:34.000000000 +0300
+++ C:\usr\unpacked\abcl\abcl-src-0.15.0\src/org/armedbear/lisp/clos.lisp	2009-07-13 02:37:44.109375000 +0300
@@ -852,19 +852,30 @@
   (set-funcallable-instance-function
    gf
    (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
                 #'std-compute-discriminating-function
                 #'compute-discriminating-function)
             gf))
   (apply gf args))
 
+(defun collect-eql-specializer-objects (generic-function)
+  (let ((result nil))
+    (dolist (method (generic-function-methods generic-function))
+      (dolist (specializer (%method-specializers method))
+        (when (typep specializer 'eql-specializer)
+          (pushnew (eql-specializer-object specializer)
+                   result
+                   :test 'eql))))
+    result))
+
 (defun finalize-generic-function (gf)
   (%finalize-generic-function gf)
   (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
+  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
   (set-funcallable-instance-function
    gf
    (make-closure `(lambda (&rest args)
                     (initial-discriminating-function ,gf args))
                  nil))
   ;; FIXME Do we need to warn on redefinition somewhere else?
   (let ((*warn-on-redefinition* nil))
     (setf (fdefinition (%generic-function-name gf)) gf))
@@ -1179,42 +1190,32 @@
                                   (method-qualifiers method))
                            (equal canonical-specializers
                                   (%method-specializers method))))
                    (generic-function-methods gf))))
     (if (and (null method) errorp)
         (error "No such method for ~S." (%generic-function-name gf))
         method)))
 
-(defun methods-contain-eql-specializer-p (methods)
-  (dolist (method methods nil)
-    (when (dolist (spec (%method-specializers method) nil)
-            (when (eql-specializer-p spec) (return t)))
-      (return t))))
-
 (defun fast-callable-p (gf)
   (and (eq (generic-function-method-combination gf) 'standard)
        (null (intersection (%generic-function-lambda-list gf)
                            '(&rest &optional &key &allow-other-keys &aux)))))
 
 (declaim (ftype (function * t) slow-method-lookup-1))
 
 (declaim (ftype (function (t t t) t) slow-reader-lookup))
 (defun slow-reader-lookup (gf layout slot-name)
   (let ((location (layout-slot-location layout slot-name)))
     (cache-slot-location gf layout location)
     location))
 
 (defun std-compute-discriminating-function (gf)
   (let ((code
-         (cond ((methods-contain-eql-specializer-p (generic-function-methods gf))
-                (make-closure `(lambda (&rest args)
-                                 (slow-method-lookup ,gf args))
-                              nil))
-               ((and (= (length (generic-function-methods gf)) 1)
+         (cond ((and (= (length (generic-function-methods gf)) 1)
                      (typep (car (generic-function-methods gf)) 'standard-reader-method))
 ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
                 (make-closure
                  (let* ((method (%car (generic-function-methods gf)))
                         (class (car (%method-specializers method)))
                         (slot-name (reader-method-slot-name method)))
                    `(lambda (arg)
                       (declare (optimize speed))
@@ -1240,47 +1241,54 @@
                                                   '(&rest &optional &key
                                                     &allow-other-keys &aux)))))
                   (make-closure
                    (cond ((= number-required 1)
                           (if exact
                               (cond ((and (eq (generic-function-method-combination gf) 'standard)
                                           (= (length (generic-function-methods gf)) 1))
                                      (let* ((method (%car (generic-function-methods gf)))
-                                            (class (car (%method-specializers method)))
+                                            (specializer (car (%method-specializers method)))
                                             (function (or (%method-fast-function method)
                                                           (%method-function method))))
-                                       `(lambda (arg)
-                                          (declare (optimize speed))
-                                          (unless (simple-typep arg ,class)
-                                            ;; FIXME no applicable method
-                                            (error 'simple-type-error
-                                                   :datum arg
-                                                   :expected-type ,class))
-                                          (funcall ,function arg))))
+                                       (if (eql-specializer-p specializer)
+                                           (let ((specializer-object (eql-specializer-object specializer)))
+                                             `(lambda (arg)
+                                                (declare (optimize speed))
+                                                (if (eql arg ',specializer-object)
+                                                    (funcall ,function arg)
+                                                    (no-applicable-method ,gf (list arg)))))
+                                           `(lambda (arg)
+                                              (declare (optimize speed))
+                                              (unless (simple-typep arg ,specializer)
+                                                ;; FIXME no applicable method
+                                                (error 'simple-type-error
+                                                       :datum arg
+                                                       :expected-type ,specializer))
+                                              (funcall ,function arg)))))
                                     (t
                                      `(lambda (arg)
                                         (declare (optimize speed))
-                                        (let* ((class (class-of arg))
-                                               (emfun (or (gethash1 class ,emf-table)
-                                                          (slow-method-lookup-1 ,gf class))))
+                                        (let* ((specialization (%get-arg-specialization ,gf arg))
+                                               (emfun (or (gethash1 specialization ,emf-table)
+                                                          (slow-method-lookup-1 ,gf arg specialization))))
                                           (if emfun
                                               (funcall emfun (list arg))
                                               (apply #'no-applicable-method ,gf (list arg)))))
                                      ))
                               `(lambda (&rest args)
                                  (declare (optimize speed))
                                  (unless (>= (length args) 1)
                                    (error 'program-error
                                           :format-control "Not enough arguments for generic function ~S."
                                           :format-arguments (list (%generic-function-name ,gf))))
                                  (let ((emfun (get-cached-emf ,gf args)))
                                    (if emfun
                                        (funcall emfun args)
-                                       (slow-method-lookup ,gf args))))))
+                                      (slow-method-lookup ,gf args))))))
                          ((= number-required 2)
                           (if exact
                               `(lambda (arg1 arg2)
                                  (declare (optimize speed))
                                  (let* ((args (list arg1 arg2))
                                         (emfun (get-cached-emf ,gf args)))
                                    (if emfun
                                        (funcall emfun args)
@@ -1363,51 +1371,36 @@
 (defun method-applicable-p-using-classes (method classes)
   (do* ((specializers (%method-specializers method) (cdr specializers))
         (classes classes (cdr classes)))
        ((null specializers) t)
     (let ((specializer (car specializers)))
       (unless (subclassp (car classes) specializer)
         (return nil)))))
 
-(defun %compute-applicable-methods-using-classes (gf required-classes)
-  (let ((methods '()))
-    (dolist (method (generic-function-methods gf))
-      (when (method-applicable-p-using-classes method required-classes)
-        (push method methods)))
-    (if (or (null methods) (null (%cdr methods)))
-        methods
-        (sort methods
-              (if (eq (class-of gf) (find-class 'standard-generic-function))
-                  #'(lambda (m1 m2)
-                     (std-method-more-specific-p m1 m2 required-classes
-                                                 (generic-function-argument-precedence-order gf)))
-                  #'(lambda (m1 m2)
-                     (method-more-specific-p gf m1 m2 required-classes)))))))
-
 (defun slow-method-lookup (gf args)
   (let ((applicable-methods (%compute-applicable-methods gf args)))
     (if applicable-methods
         (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
                                   #'std-compute-effective-method-function
                                   #'compute-effective-method-function)
                               gf applicable-methods)))
           (cache-emf gf args emfun)
           (funcall emfun args))
         (apply #'no-applicable-method gf args))))
 
-(defun slow-method-lookup-1 (gf class)
-  (let ((applicable-methods (%compute-applicable-methods-using-classes gf (list class))))
+(defun slow-method-lookup-1 (gf arg arg-specialization)
+  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
     (if applicable-methods
         (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
                                   #'std-compute-effective-method-function
                                   #'compute-effective-method-function)
                               gf applicable-methods)))
           (when emfun
-            (setf (gethash class (classes-to-emf-table gf)) emfun))
+            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
           emfun))))
 
 (defun sub-specializer-p (c1 c2 c-arg)
   (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
 
 (defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
   (if argument-precedence-order
       (let ((specializers-1 (%method-specializers method1))
