Changeset 14493


Ignore:
Timestamp:
05/05/13 15:02:32 (10 years ago)
Author:
rschlatte
Message:

downsize StandardGenericFunction?.java

  • move all caching into new class EMFCache.java
  • eliminate or inline all other methods, rely on superclasses' implementations instead.
Location:
trunk/abcl/src/org/armedbear/lisp
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/Autoload.java

    r14490 r14493  
    553553        autoload(PACKAGE_SYS, "%%string=", "StringFunctions");
    554554        autoload(PACKAGE_SYS, "%adjust-array", "adjust_array");
    555         autoload(PACKAGE_SYS, "%clear-emf-cache", "StandardGenericFunction", true);
    556555        autoload(PACKAGE_SYS, "%defpackage", "PackageFunctions");
    557556        autoload(PACKAGE_SYS, "%get-output-stream-bytes", "ByteArrayOutputStream"); //AS 20090325
    … …  
    561560        autoload(PACKAGE_SYS, "%make-byte-array-output-stream", "ByteArrayOutputStream"); //AS 20090325
    562561        autoload(PACKAGE_SYS, "%make-condition", "make_condition", true);
     562        autoload(PACKAGE_SYS, "%make-emf-cache", "EMFCache", true);
    563563        autoload(PACKAGE_SYS, "%make-hash-table", "HashTableFunctions");
    564564        autoload(PACKAGE_SYS, "%make-hash-table", "HashTableFunctions");
    … …  
    571571        autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions");
    572572        autoload(PACKAGE_SYS, "%nstring-upcase", "StringFunctions");
     573        autoload(PACKAGE_SYS, "%reinit-emf-cache", "EMFCache", true);
    573574        autoload(PACKAGE_SYS, "%run-shell-command", "ShellCommand");
    574575        autoload(PACKAGE_SYS, "%server-socket-close", "server_socket_close");
    … …  
    578579        autoload(PACKAGE_SYS, "%set-class-direct-slots", "SlotClass", true);
    579580        autoload(PACKAGE_SYS, "%set-function-info", "function_info");
    580         autoload(PACKAGE_SYS, "%init-eql-specializations", "StandardGenericFunction", true);
    581581        autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives");
    582582        autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector");
    … …  
    610610        autoload(PACKAGE_SYS, "%string>=", "StringFunctions");
    611611        autoload(PACKAGE_SYS, "%time", "Time");
    612         autoload(PACKAGE_SYS, "cache-emf", "StandardGenericFunction", true);
     612        autoload(PACKAGE_SYS, "cache-emf", "EMFCache", true);
    613613        autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true);
    614614        autoload(PACKAGE_SYS, "%class-direct-slots", "SlotClass");
    … …  
    626626        autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true);
    627627        autoload(PACKAGE_SYS, "function-info", "function_info");
    628         autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true);
     628        autoload(PACKAGE_SYS, "get-cached-emf", "EMFCache", true);
    629629        autoload(PACKAGE_SYS, "get-function-info-value", "function_info");
    630630        autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions");

  • trunk/abcl/src/org/armedbear/lisp/EMFCache.java

    r14492 r14493  
    11/*
    2  * StandardGenericFunction.java
    3  *
    4  * Copyright (C) 2003-2006 Peter Graves
    5  * $Id$
     2 * EMFCache.java
     3 *
     4 * Copyright (C) 2003-2006 Peter Graves, 2013 Rudolf Schlatte
    65 *
    76 * This program is free software; you can redistribute it and/or
    … …  
    3837import java.util.concurrent.ConcurrentHashMap;
    3938
    40 public final class StandardGenericFunction extends FuncallableStandardObject
     39public final class EMFCache extends LispObject
    4140{
    42 
    4341  ConcurrentHashMap<CacheEntry,LispObject> cache
    4442    = new ConcurrentHashMap<CacheEntry,LispObject>();;
    45 
    46   public StandardGenericFunction()
    47   {
    48     this(StandardClass.STANDARD_GENERIC_FUNCTION.getClassLayout());
    49   }
    50 
    51   public StandardGenericFunction(Layout layout)
    52   {
    53     super(layout);
    54     setInstanceSlotValue(Symbol.NAME, NIL);
    55     setInstanceSlotValue(Symbol.LAMBDA_LIST, NIL);
    56     setInstanceSlotValue(Symbol.REQUIRED_ARGS, NIL);
    57     setInstanceSlotValue(Symbol.OPTIONAL_ARGS, NIL);
    58     setInstanceSlotValue(Symbol.INITIAL_METHODS, NIL);
    59     setInstanceSlotValue(Symbol.METHODS, NIL);
    60     setInstanceSlotValue(Symbol.METHOD_CLASS, StandardClass.STANDARD_METHOD);
    61     // method combination class set by clos.lisp:shared-initialize :after
    62     setInstanceSlotValue(Symbol._METHOD_COMBINATION, list(Symbol.STANDARD));
    63     setInstanceSlotValue(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL);
    64     setInstanceSlotValue(Symbol.DECLARATIONS, NIL);
    65     setInstanceSlotValue(Symbol._DOCUMENTATION, NIL);
    66   }
     43  EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
    6744
    6845  void clearCache()
    6946  {
    7047    cache = new ConcurrentHashMap<CacheEntry,LispObject>();
    71   }
    72 
    73   public LispObject getName()
    74   {
    75     return getInstanceSlotValue(Symbol.NAME);
    76   }
    77 
    78   public void setName(LispObject name)
    79   {
    80     setInstanceSlotValue(Symbol.NAME, name);
    81   }
    82 
    83 
    84   @Override
    85   public LispObject typep(LispObject type)
    86   {
    87     if (type == Symbol.STANDARD_GENERIC_FUNCTION)
    88       return T;
    89     if (type == StandardClass.STANDARD_GENERIC_FUNCTION)
    90       return T;
    91     return super.typep(type);
    9248  }
    9349
    … …  
    9551  public String printObject()
    9652  {
    97     LispObject name = getName();
    98     if (name != null)
    99       {
    100         StringBuilder sb = new StringBuilder();
    101         LispObject className;
    102         LispObject lispClass = getLispClass();
    103         if (lispClass instanceof LispClass)
    104           className = ((LispClass)lispClass).getName();
    105         else
    106           className = Symbol.CLASS_NAME.execute(lispClass);
    107 
    108         sb.append(className.princToString());
    109         sb.append(' ');
    110         sb.append(name.princToString());
    111         return unreadableString(sb.toString());
     53    return unreadableString("EMF-CACHE");
     54  }
     55
     56  static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
     57  {
     58    if (obj instanceof StandardGenericFunction)
     59      return (StandardGenericFunction) obj;
     60    return (StandardGenericFunction) // Not reached.
     61      type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
     62  }
     63
     64  private static class EqlSpecialization extends LispObject
     65  {
     66    public LispObject eqlTo;
     67
     68    public EqlSpecialization(LispObject eqlTo)
     69    {
     70        this.eqlTo = eqlTo;
     71    }
     72  }
     73
     74  private static class CacheEntry
     75  {
     76    final LispObject[] array;
     77
     78    CacheEntry(LispObject[] array)
     79    {
     80      this.array = array;
     81    }
     82
     83    @Override
     84    public int hashCode()
     85    {
     86      int result = 0;
     87      for (int i = array.length; i-- > 0;)
     88        result ^= array[i].hashCode();
     89      return result;
     90    }
     91
     92    @Override
     93    public boolean equals(Object object)
     94    {
     95      if (!(object instanceof CacheEntry))
     96        return false;
     97      final CacheEntry otherEntry = (CacheEntry) object;
     98      if (otherEntry.array.length != array.length)
     99        return false;
     100      final LispObject[] otherArray = otherEntry.array;
     101      for (int i = array.length; i-- > 0;)
     102        if (array[i] != otherArray[i])
     103          return false;
     104      return true;
     105    }
     106  }
     107
     108  private static final Primitive _MAKE_EMF_CACHE
     109    = new pf__make_emf_cache();
     110  @DocString(name="%make-emf-cache")
     111  private static final class  pf__make_emf_cache extends Primitive
     112  {
     113    pf__make_emf_cache()
     114    {
     115      super("%make-emf-cache", PACKAGE_SYS, true);
     116    }
     117    @Override
     118    public LispObject execute(LispObject arg)
     119    {
     120      return new EMFCache();
     121    }
     122  };
     123
     124  private static final Primitive _REINIT_EMF_CACHE
     125    = new pf__reinit_emf_cache();
     126  @DocString(name="%reinit-emf-cache",
     127             args="generic-function eql-specilizer-objects-list")
     128  private static final class  pf__reinit_emf_cache extends Primitive
     129  {
     130    pf__reinit_emf_cache()
     131    {
     132      super("%reinit-emf-cache", PACKAGE_SYS, true,
     133            "generic-function eql-specializer-objects-list");
     134    }
     135    @Override
     136    public LispObject execute(LispObject generic_function, LispObject eql_specializers)
     137    {
     138      final StandardGenericFunction gf = checkStandardGenericFunction(generic_function);
     139      EMFCache cache = gf.cache;
     140      cache.clearCache();
     141      cache.eqlSpecializations = new EqlSpecialization[eql_specializers.length()];
     142      for (int i = 0; i < cache.eqlSpecializations.length; i++) {
     143        cache.eqlSpecializations[i] = new EqlSpecialization(eql_specializers.car());
     144        eql_specializers = eql_specializers.cdr();
    112145      }
    113     return super.printObject();
    114   }
    115 
    116 
    117   private static final Primitive _CLEAR_EMF_CACHE
    118     = new pf__finalize_generic_function();
    119   @DocString(name="%clear-emf-cache",
    120              args="generic-function")
    121   private static final class  pf__finalize_generic_function extends Primitive
    122   {
    123     pf__finalize_generic_function()
    124     {
    125       super("%clear-emf-cache", PACKAGE_SYS, true,
    126             "generic-function");
    127     }
    128     @Override
    129     public LispObject execute(LispObject arg)
    130     {
    131       final StandardGenericFunction gf = checkStandardGenericFunction(arg);
    132       gf.clearCache();       
    133146      return T;
    134147    }
    135148  };
    136149
    137   private static final Primitive CACHE_EMF 
     150  private static final Primitive CACHE_EMF
    138151    = new pf_cache_emf();
    139152  @DocString(name="cache-emf",
    140153             args="generic-function args emf")
    141   private static final class pf_cache_emf extends Primitive 
     154  private static final class pf_cache_emf extends Primitive
    142155  {
    143156    pf_cache_emf()
    … …  
    150163    {
    151164      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     165      EMFCache cache = gf.cache;
    152166      LispObject args = second;
    153167      int numberOfRequiredArgs
    … …  
    156170      for (int i = numberOfRequiredArgs; i-- > 0;)
    157171        {
    158           array[i] = gf.getArgSpecialization(args.car());
     172          array[i] = cache.getArgSpecialization(args.car());
    159173          args = args.cdr();
    160174        }
    161175      CacheEntry specializations = new CacheEntry(array);
    162       ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
     176      ConcurrentHashMap<CacheEntry,LispObject> ht = cache.cache;
    163177      ht.put(specializations, third);
    164178      return third;
    … …  
    170184  @DocString(name="get-cached-emf",
    171185             args="generic-function args")
    172   private static final class pf_get_cached_emf extends Primitive 
     186  private static final class pf_get_cached_emf extends Primitive
    173187  {
    174188    pf_get_cached_emf() {
    … …  
    179193    {
    180194      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     195      EMFCache cache = gf.cache;
    181196      LispObject args = second;
    182197      int numberOfRequiredArgs
    … …  
    185200      for (int i = numberOfRequiredArgs; i-- > 0;)
    186201        {
    187           array[i] = gf.getArgSpecialization(args.car());
     202          array[i] = cache.getArgSpecialization(args.car());
    188203          args = args.cdr();
    189204        }
    190205      CacheEntry specializations = new CacheEntry(array);
    191       ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
     206      ConcurrentHashMap<CacheEntry,LispObject> ht = cache.cache;
    192207      LispObject emf = (LispObject) ht.get(specializations);
    193208      return emf != null ? emf : NIL;
    … …  
    196211
    197212  /**
    198    * Returns an object representing generic function 
     213   * Returns an object representing generic function
    199214   * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
    200215   *
    … …  
    202217   * does not have EQL specialized methods, and therefore
    203218   * only argument types are relevant for choosing
    204    * applicable methods, the value returned is the 
     219   * applicable methods, the value returned is the
    205220   * class of <tt>arg</tt>
    206221   *
    207    * <p>If the function has EQL specialized methods: 
     222   * <p>If the function has EQL specialized methods:
    208223   *   - if <tt>arg</tt> is EQL to some of the EQL-specializers,
    209224   *     a special object representing equality to that specializer
    … …  
    250265   * { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
    251266   * </pre>
    252    */     
     267   */
    253268  LispObject getArgSpecialization(LispObject arg)
    254269  {
    … …  
    261276  }
    262277
    263   private static class CacheEntry
    264   {
    265     final LispObject[] array;
    266 
    267     CacheEntry(LispObject[] array)
    268     {
    269       this.array = array;
    270     }
    271 
    272     @Override
    273     public int hashCode()
    274     {
    275       int result = 0;
    276       for (int i = array.length; i-- > 0;)
    277         result ^= array[i].hashCode();
    278       return result;
    279     }
    280 
    281     @Override
    282     public boolean equals(Object object)
    283     {
    284       if (!(object instanceof CacheEntry))
    285         return false;
    286       final CacheEntry otherEntry = (CacheEntry) object;
    287       if (otherEntry.array.length != array.length)
    288         return false;
    289       final LispObject[] otherArray = otherEntry.array;
    290       for (int i = array.length; i-- > 0;)
    291         if (array[i] != otherArray[i])
    292           return false;
    293       return true;
    294     }
    295   }
    296 
    297   EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
    298 
    299   private static final Primitive _INIT_EQL_SPECIALIZATIONS 
    300     = new pf__init_eql_specializations();
    301   @DocString(name="%init-eql-specializations",
    302              args="generic-function eql-specilizer-objects-list")
    303   private static final class pf__init_eql_specializations extends Primitive
    304   {
    305     pf__init_eql_specializations()
    306     {
    307       super("%init-eql-specializations", PACKAGE_SYS, true,
    308             "generic-function eql-specilizer-objects-list");
    309     }
    310     @Override
    311     public LispObject execute(LispObject first, LispObject second)
    312     {
    313       final StandardGenericFunction gf = checkStandardGenericFunction(first);
    314       LispObject eqlSpecializerObjects = second;
    315       gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
    316       for (int i = 0; i < gf.eqlSpecializations.length; i++) {
    317         gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
    318         eqlSpecializerObjects = eqlSpecializerObjects.cdr();
    319       }
    320       return NIL;
    321     }
    322   };
    323 
    324   private static class EqlSpecialization extends LispObject
    325   {
    326     public LispObject eqlTo;
    327 
    328     public EqlSpecialization(LispObject eqlTo)
    329     {
    330         this.eqlTo = eqlTo;
    331     }
    332   }
    333  
    334   private static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
    335   {
    336     if (obj instanceof StandardGenericFunction)
    337       return (StandardGenericFunction) obj;
    338     return (StandardGenericFunction) // Not reached.
    339       type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
    340   }
    341278}

  • trunk/abcl/src/org/armedbear/lisp/Primitives.java

    r14484 r14493  
    26612661                value1 = NIL;
    26622662                value2 = T;
    2663                 value3 = ((StandardGenericFunction)arg).getName();
     2663                value3 = ((StandardGenericFunction)arg).getInstanceSlotValue(Symbol.NAME);
    26642664            } else if (arg instanceof FuncallableStandardObject) {
    26652665              return this.execute(((FuncallableStandardObject)arg).function);
    … …  
    42224222            }
    42234223            if (arg instanceof StandardGenericFunction) {
    4224                 return ((StandardGenericFunction)arg).getName();
     4224                return ((StandardGenericFunction)arg).getInstanceSlotValue(Symbol.NAME);
    42254225            }
    42264226            if (arg instanceof FuncallableStandardObject) {
    … …  
    42474247            }
    42484248            if (first instanceof StandardGenericFunction) {
    4249                 ((StandardGenericFunction)first).setName(second);
     4249                ((StandardGenericFunction)first).setInstanceSlotValue(Symbol.NAME, second);
    42504250                return second;
    42514251            }

  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r14491 r14493  
    3636import static org.armedbear.lisp.Lisp.*;
    3737
    38 import java.util.concurrent.ConcurrentHashMap;
    39 
    4038public final class StandardGenericFunction extends FuncallableStandardObject
    4139{
    4240
    43   ConcurrentHashMap<CacheEntry,LispObject> cache
    44     = new ConcurrentHashMap<CacheEntry,LispObject>();;
     41  EMFCache cache = new EMFCache();
    4542
    4643  public StandardGenericFunction()
    … …  
    6663  }
    6764
    68   void clearCache()
    69   {
    70     cache = new ConcurrentHashMap<CacheEntry,LispObject>();
    71   }
    72 
    73   public LispObject getName()
    74   {
    75     return getInstanceSlotValue(Symbol.NAME);
    76   }
    77 
    78   public void setName(LispObject name)
    79   {
    80     setInstanceSlotValue(Symbol.NAME, name);
    81   }
    82 
    83 
    84   @Override
    85   public LispObject typep(LispObject type)
    86   {
    87     if (type == Symbol.STANDARD_GENERIC_FUNCTION)
    88       return T;
    89     if (type == StandardClass.STANDARD_GENERIC_FUNCTION)
    90       return T;
    91     return super.typep(type);
    92   }
    93 
    94   @Override
    95   public String printObject()
    96   {
    97     LispObject name = getName();
    98     if (name != null)
    99       {
    100         StringBuilder sb = new StringBuilder();
    101         LispObject className;
    102         LispObject lispClass = getLispClass();
    103         if (lispClass instanceof LispClass)
    104           className = ((LispClass)lispClass).getName();
    105         else
    106           className = Symbol.CLASS_NAME.execute(lispClass);
    107 
    108         sb.append(className.princToString());
    109         sb.append(' ');
    110         sb.append(name.princToString());
    111         return unreadableString(sb.toString());
    112       }
    113     return super.printObject();
    114   }
    115 
    116 
    117   private static final Primitive _CLEAR_EMF_CACHE
    118     = new pf__finalize_generic_function();
    119   @DocString(name="%clear-emf-cache",
    120              args="generic-function")
    121   private static final class  pf__finalize_generic_function extends Primitive
    122   {
    123     pf__finalize_generic_function()
    124     {
    125       super("%clear-emf-cache", PACKAGE_SYS, true,
    126             "generic-function");
    127     }
    128     @Override
    129     public LispObject execute(LispObject arg)
    130     {
    131       final StandardGenericFunction gf = checkStandardGenericFunction(arg);
    132       gf.clearCache();       
    133       return T;
    134     }
    135   };
    136 
    137   private static final Primitive CACHE_EMF
    138     = new pf_cache_emf();
    139   @DocString(name="cache-emf",
    140              args="generic-function args emf")
    141   private static final class pf_cache_emf extends Primitive
    142   {
    143     pf_cache_emf()
    144     {
    145       super("cache-emf", PACKAGE_SYS, true, "generic-function args emf");
    146     }
    147     @Override
    148     public LispObject execute(LispObject first, LispObject second,
    149                               LispObject third)
    150     {
    151       final StandardGenericFunction gf = checkStandardGenericFunction(first);
    152       LispObject args = second;
    153       int numberOfRequiredArgs
    154         = gf.getInstanceSlotValue(Symbol.REQUIRED_ARGS).length();
    155       LispObject[] array = new LispObject[numberOfRequiredArgs];
    156       for (int i = numberOfRequiredArgs; i-- > 0;)
    157         {
    158           array[i] = gf.getArgSpecialization(args.car());
    159           args = args.cdr();
    160         }
    161       CacheEntry specializations = new CacheEntry(array);
    162       ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
    163       ht.put(specializations, third);
    164       return third;
    165     }
    166   };
    167 
    168   private static final Primitive GET_CACHED_EMF
    169     = new pf_get_cached_emf();
    170   @DocString(name="get-cached-emf",
    171              args="generic-function args")
    172   private static final class pf_get_cached_emf extends Primitive
    173   {
    174     pf_get_cached_emf() {
    175       super("get-cached-emf", PACKAGE_SYS, true, "generic-function args");
    176     }
    177     @Override
    178     public LispObject execute(LispObject first, LispObject second)
    179     {
    180       final StandardGenericFunction gf = checkStandardGenericFunction(first);
    181       LispObject args = second;
    182       int numberOfRequiredArgs
    183         = gf.getInstanceSlotValue(Symbol.REQUIRED_ARGS).length();
    184       LispObject[] array = new LispObject[numberOfRequiredArgs];
    185       for (int i = numberOfRequiredArgs; i-- > 0;)
    186         {
    187           array[i] = gf.getArgSpecialization(args.car());
    188           args = args.cdr();
    189         }
    190       CacheEntry specializations = new CacheEntry(array);
    191       ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
    192       LispObject emf = (LispObject) ht.get(specializations);
    193       return emf != null ? emf : NIL;
    194     }
    195   };
    196 
    197   /**
    198    * Returns an object representing generic function
    199    * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
    200    *
    201    * <p>In the simplest case, when this generic function
    202    * does not have EQL specialized methods, and therefore
    203    * only argument types are relevant for choosing
    204    * applicable methods, the value returned is the
    205    * class of <tt>arg</tt>
    206    *
    207    * <p>If the function has EQL specialized methods:
    208    *   - if <tt>arg</tt> is EQL to some of the EQL-specializers,
    209    *     a special object representing equality to that specializer
    210    *     is returned.
    211    *   - otherwise class of the <tt>arg</tt> is returned.
    212    *
    213    * <p>Note that we do not consider argument position, when
    214    * calculating arg specialization. In rare cases (when one argument
    215    * is eql-specialized to a symbol specifying class of another
    216    * argument) this may result in redundant cache entries caching the
    217    * same method. But the method cached is anyway correct for the
    218    * arguments (because in case of cache miss, correct method is
    219    * calculated by other code, which does not rely on
    220    * getArgSpecialization; and because EQL is true only for objects of
    221    * the same type, which guaranties that if a type-specialized
    222    * methods was chached by eql-specialization, all the cache hits
    223    * into this records will be from args of the conforming type).
    224    *
    225    * <p>Consider:
    226    * <pre><tt>
    227    * (defgeneric f (a b))
    228    *
    229    * (defmethod f (a (b (eql 'symbol)))
    230    *   "T (EQL 'SYMBOL)")
    231    *
    232    * (defmethod f ((a symbol) (b (eql 'symbol)))
    233    *   "SYMBOL (EQL 'SYMBOL)")
    234    *
    235    * (f 12 'symbol)
    236    * => "T (EQL 'SYMBOL)"
    237    *
    238    * (f 'twelve 'symbol)
    239    * => "SYMBOL (EQL 'SYMBOL)"
    240    *
    241    * (f 'symbol 'symbol)
    242    * => "SYMBOL (EQL 'SYMBOL)"
    243    *
    244    * </tt></pre>
    245    *
    246    * After the two above calls <tt>cache</tt> will contain three keys:
    247    * <pre>
    248    * { class FIXNUM, EqlSpecialization('SYMBOL) }
    249    * { class SYMBOL, EqlSpecialization('SYMBOL) }
    250    * { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
    251    * </pre>
    252    */     
    253   LispObject getArgSpecialization(LispObject arg)
    254   {
    255     for (EqlSpecialization eqlSpecialization : eqlSpecializations)
    256       {
    257         if (eqlSpecialization.eqlTo.eql(arg))
    258           return eqlSpecialization;
    259       }
    260     return arg.classOf();
    261   }
    262 
    263   private static class CacheEntry
    264   {
    265     final LispObject[] array;
    266 
    267     CacheEntry(LispObject[] array)
    268     {
    269       this.array = array;
    270     }
    271 
    272     @Override
    273     public int hashCode()
    274     {
    275       int result = 0;
    276       for (int i = array.length; i-- > 0;)
    277         result ^= array[i].hashCode();
    278       return result;
    279     }
    280 
    281     @Override
    282     public boolean equals(Object object)
    283     {
    284       if (!(object instanceof CacheEntry))
    285         return false;
    286       final CacheEntry otherEntry = (CacheEntry) object;
    287       if (otherEntry.array.length != array.length)
    288         return false;
    289       final LispObject[] otherArray = otherEntry.array;
    290       for (int i = array.length; i-- > 0;)
    291         if (array[i] != otherArray[i])
    292           return false;
    293       return true;
    294     }
    295   }
    296 
    297   EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
    298 
    299   private static final Primitive _INIT_EQL_SPECIALIZATIONS 
    300     = new pf__init_eql_specializations();
    301   @DocString(name="%init-eql-specializations",
    302              args="generic-function eql-specilizer-objects-list")
    303   private static final class pf__init_eql_specializations extends Primitive
    304   {
    305     pf__init_eql_specializations()
    306     {
    307       super("%init-eql-specializations", PACKAGE_SYS, true,
    308             "generic-function eql-specilizer-objects-list");
    309     }
    310     @Override
    311     public LispObject execute(LispObject first, LispObject second)
    312     {
    313       final StandardGenericFunction gf = checkStandardGenericFunction(first);
    314       LispObject eqlSpecializerObjects = second;
    315       gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
    316       for (int i = 0; i < gf.eqlSpecializations.length; i++) {
    317         gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
    318         eqlSpecializerObjects = eqlSpecializerObjects.cdr();
    319       }
    320       return NIL;
    321     }
    322   };
    323 
    324   private static class EqlSpecialization extends LispObject
    325   {
    326     public LispObject eqlTo;
    327 
    328     public EqlSpecialization(LispObject eqlTo)
    329     {
    330         this.eqlTo = eqlTo;
    331     }
    332   }
    333  
    334   private static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
    335   {
    336     if (obj instanceof StandardGenericFunction)
    337       return (StandardGenericFunction) obj;
    338     return (StandardGenericFunction) // Not reached.
    339       type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
    340   }
    34165}

  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14492 r14493  
    18201820
    18211821(defun finalize-standard-generic-function (gf)
    1822   (%clear-emf-cache gf)
    1823   (%init-eql-specializations gf (collect-eql-specializer-objects gf))
     1822  (%reinit-emf-cache gf (collect-eql-specializer-objects gf))
    18241823  (set-funcallable-instance-function
    18251824   gf
Note: See TracChangeset for help on using the changeset viewer.