source: branches/0.17.x/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

Last change on this file was 12255, checked in by ehuelsmann, 16 years ago

Rename ConditionThrowable? to ControlTransfer? and remove

try/catch blocks which don't have anything to do with
non-local transfer of control.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 25.3 KB
Line 
1/*
2 * StandardGenericFunction.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves
5 * $Id: StandardGenericFunction.java 12255 2009-11-06 22:36:32Z ehuelsmann $
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36import java.util.HashMap;
37
38public final class StandardGenericFunction extends StandardObject
39{
40  private LispObject function;
41
42  private int numberOfRequiredArgs;
43
44  private HashMap<CacheEntry,LispObject> cache;
45  private HashMap<LispObject,LispObject> slotCache;
46
47  public StandardGenericFunction()
48  {
49    super(StandardClass.STANDARD_GENERIC_FUNCTION,
50          StandardClass.STANDARD_GENERIC_FUNCTION.getClassLayout().getLength());
51  }
52
53  public StandardGenericFunction(String name, Package pkg, boolean exported,
54                                 Function function, LispObject lambdaList,
55                                 LispObject specializers)
56  {
57    this();
58    Symbol symbol;
59    if (exported)
60      symbol = pkg.internAndExport(name.toUpperCase());
61    else
62      symbol = pkg.intern(name.toUpperCase());
63    symbol.setSymbolFunction(this);
64    this.function = function;
65    slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = symbol;
66    slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] =
67      lambdaList;
68    slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] =
69      lambdaList;
70    numberOfRequiredArgs = lambdaList.length();
71    slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] =
72      NIL;
73    StandardMethod method =
74      new StandardMethod(this, function, lambdaList, specializers);
75    slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] =
76      list(method);
77    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] =
78      StandardClass.STANDARD_METHOD;
79    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] =
80      Symbol.STANDARD;
81    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
82      NIL;
83    slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] =
84      NIL;
85    slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
86  }
87
88  private void finalizeInternal()
89  {
90    cache = null;
91  }
92
93  @Override
94  public LispObject typep(LispObject type)
95  {
96    if (type == Symbol.COMPILED_FUNCTION)
97      {
98        if (function != null)
99          return function.typep(type);
100        else
101          return NIL;
102      }
103    if (type == Symbol.STANDARD_GENERIC_FUNCTION)
104      return T;
105    if (type == StandardClass.STANDARD_GENERIC_FUNCTION)
106      return T;
107    return super.typep(type);
108  }
109
110  public LispObject getGenericFunctionName()
111  {
112    return slots[StandardGenericFunctionClass.SLOT_INDEX_NAME];
113  }
114
115  public void setGenericFunctionName(LispObject name)
116  {
117    slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = name;
118  }
119
120  @Override
121  public LispObject execute()
122  {
123    return function.execute();
124  }
125
126  @Override
127  public LispObject execute(LispObject arg)
128  {
129    return function.execute(arg);
130  }
131
132  @Override
133  public LispObject execute(LispObject first, LispObject second)
134
135  {
136    return function.execute(first, second);
137  }
138
139  @Override
140  public LispObject execute(LispObject first, LispObject second,
141                            LispObject third)
142
143  {
144    return function.execute(first, second, third);
145  }
146
147  @Override
148  public LispObject execute(LispObject first, LispObject second,
149                            LispObject third, LispObject fourth)
150
151  {
152    return function.execute(first, second, third, fourth);
153  }
154
155  @Override
156  public LispObject execute(LispObject first, LispObject second,
157                            LispObject third, LispObject fourth,
158                            LispObject fifth)
159
160  {
161    return function.execute(first, second, third, fourth,
162                            fifth);
163  }
164
165  @Override
166  public LispObject execute(LispObject first, LispObject second,
167                            LispObject third, LispObject fourth,
168                            LispObject fifth, LispObject sixth)
169
170  {
171    return function.execute(first, second, third, fourth,
172                            fifth, sixth);
173  }
174
175  @Override
176  public LispObject execute(LispObject first, LispObject second,
177                            LispObject third, LispObject fourth,
178                            LispObject fifth, LispObject sixth,
179                            LispObject seventh)
180
181  {
182    return function.execute(first, second, third, fourth,
183                            fifth, sixth, seventh);
184  }
185
186  @Override
187  public LispObject execute(LispObject first, LispObject second,
188                            LispObject third, LispObject fourth,
189                            LispObject fifth, LispObject sixth,
190                            LispObject seventh, LispObject eighth)
191
192  {
193    return function.execute(first, second, third, fourth,
194                            fifth, sixth, seventh, eighth);
195  }
196
197  @Override
198  public LispObject execute(LispObject[] args)
199  {
200    return function.execute(args);
201  }
202
203  @Override
204  public String writeToString()
205  {
206    LispObject name = getGenericFunctionName();
207    if (name != null)
208      {
209        FastStringBuffer sb = new FastStringBuffer();
210        sb.append(getLispClass().getSymbol().writeToString());
211        sb.append(' ');
212        sb.append(name.writeToString());
213        return unreadableString(sb.toString());
214      }
215    return super.writeToString();
216  }
217
218  // Profiling.
219  private int callCount;
220  private int hotCount;
221
222  @Override
223  public final int getCallCount()
224  {
225    return callCount;
226  }
227
228  @Override
229  public void setCallCount(int n)
230  {
231    callCount = n;
232  }
233
234  @Override
235  public final void incrementCallCount()
236  {
237    ++callCount;
238  }
239
240    @Override
241    public final int getHotCount()
242    {
243        return hotCount;
244    }
245
246    @Override
247    public void setHotCount(int n)
248    {
249        hotCount = n;
250    }
251
252    @Override
253    public final void incrementHotCount()
254    {
255        ++hotCount;
256    }
257
258    // AMOP (p. 216) specifies the following readers as generic functions:
259  //   generic-function-argument-precedence-order
260  //   generic-function-declarations
261  //   generic-function-lambda-list
262  //   generic-function-method-class
263  //   generic-function-method-combination
264  //   generic-function-methods
265  //   generic-function-name
266
267  // ### %generic-function-name
268  private static final Primitive _GENERIC_FUNCTION_NAME =
269    new Primitive("%generic-function-name", PACKAGE_SYS, true)
270    {
271      @Override
272      public LispObject execute(LispObject arg)
273      {
274          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME];
275      }
276    };
277
278  // ### %set-generic-function-name
279  private static final Primitive _SET_GENERIC_FUNCTION_NAME =
280    new Primitive("%set-generic-function-name", PACKAGE_SYS, true)
281    {
282      @Override
283      public LispObject execute(LispObject first, LispObject second)
284
285      {
286          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second;
287          return second;
288      }
289    };
290
291  // ### %generic-function-lambda-list
292  private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST =
293    new Primitive("%generic-function-lambda-list", PACKAGE_SYS, true)
294    {
295      @Override
296      public LispObject execute(LispObject arg)
297      {
298          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST];
299      }
300    };
301
302  // ### %set-generic-function-lambdaList
303  private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST =
304    new Primitive("%set-generic-function-lambda-list", PACKAGE_SYS, true)
305    {
306      @Override
307      public LispObject execute(LispObject first, LispObject second)
308
309      {
310          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second;
311          return second;
312      }
313    };
314
315  // ### funcallable-instance-function funcallable-instance => function
316  private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION =
317    new Primitive("funcallable-instance-function", PACKAGE_MOP, false,
318                  "funcallable-instance")
319    {
320      @Override
321      public LispObject execute(LispObject arg)
322
323      {
324          return checkStandardGenericFunction(arg).function;
325      }
326    };
327
328  // ### set-funcallable-instance-function funcallable-instance function => unspecified
329  // AMOP p. 230
330  private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION =
331    new Primitive("set-funcallable-instance-function", PACKAGE_MOP, true,
332                  "funcallable-instance function")
333    {
334      @Override
335      public LispObject execute(LispObject first, LispObject second)
336
337      {
338          checkStandardGenericFunction(first).function = second;
339          return second;
340      }
341    };
342
343  // ### gf-required-args
344  private static final Primitive GF_REQUIRED_ARGS =
345    new Primitive("gf-required-args", PACKAGE_SYS, true)
346    {
347      @Override
348      public LispObject execute(LispObject arg)
349      {
350          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS];
351      }
352    };
353
354  // ### %set-gf-required-args
355  private static final Primitive _SET_GF_REQUIRED_ARGS =
356    new Primitive("%set-gf-required-args", PACKAGE_SYS, true)
357    {
358      @Override
359      public LispObject execute(LispObject first, LispObject second)
360
361      {
362        final StandardGenericFunction gf = checkStandardGenericFunction(first);
363        gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second;
364        gf.numberOfRequiredArgs = second.length();
365        return second;
366      }
367    };
368
369  // ### generic-function-initial-methods
370  private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS =
371    new Primitive("generic-function-initial-methods", PACKAGE_SYS, true)
372    {
373      @Override
374      public LispObject execute(LispObject arg)
375      {
376          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS];
377      }
378    };
379
380  // ### set-generic-function-initial-methods
381  private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS =
382    new Primitive("set-generic-function-initial-methods", PACKAGE_SYS, true)
383    {
384      @Override
385      public LispObject execute(LispObject first, LispObject second)
386
387      {
388          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second;
389          return second;
390      }
391    };
392
393  // ### generic-function-methods
394  private static final Primitive GENERIC_FUNCTION_METHODS =
395    new Primitive("generic-function-methods", PACKAGE_SYS, true)
396    {
397      @Override
398      public LispObject execute(LispObject arg)
399      {
400          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS];
401      }
402    };
403
404  // ### set-generic-function-methods
405  private static final Primitive SET_GENERIC_FUNCTION_METHODS =
406    new Primitive("set-generic-function-methods", PACKAGE_SYS, true)
407    {
408      @Override
409      public LispObject execute(LispObject first, LispObject second)
410
411      {
412          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second;
413          return second;
414      }
415    };
416
417  // ### generic-function-method-class
418  private static final Primitive GENERIC_FUNCTION_METHOD_CLASS =
419    new Primitive("generic-function-method-class", PACKAGE_SYS, true)
420    {
421      @Override
422      public LispObject execute(LispObject arg)
423      {
424          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS];
425      }
426    };
427
428  // ### set-generic-function-method-class
429  private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS =
430    new Primitive("set-generic-function-method-class", PACKAGE_SYS, true)
431    {
432      @Override
433      public LispObject execute(LispObject first, LispObject second)
434
435      {
436          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second;
437          return second;
438      }
439    };
440
441  // ### generic-function-method-combination
442  private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION =
443    new Primitive("generic-function-method-combination", PACKAGE_SYS, true)
444    {
445      @Override
446      public LispObject execute(LispObject arg)
447      {
448          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION];
449      }
450    };
451
452  // ### set-generic-function-method-combination
453  private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION =
454    new Primitive("set-generic-function-method-combination", PACKAGE_SYS, true)
455    {
456      @Override
457      public LispObject execute(LispObject first, LispObject second)
458
459      {
460          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] 
461      = second;
462          return second;
463      }
464    };
465
466  // ### generic-function-argument-precedence-order
467  private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER =
468    new Primitive("generic-function-argument-precedence-order", PACKAGE_SYS, true)
469    {
470      @Override
471      public LispObject execute(LispObject arg)
472      {
473          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass
474               .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER];
475      }
476    };
477
478  // ### set-generic-function-argument-precedence-order
479  private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER =
480    new Primitive("set-generic-function-argument-precedence-order", PACKAGE_SYS, true)
481    {
482      @Override
483      public LispObject execute(LispObject first, LispObject second)
484
485      {
486          checkStandardGenericFunction(first)
487      .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second;
488          return second;
489      }
490    };
491
492  // ### generic-function-classes-to-emf-table
493  private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE =
494    new Primitive("generic-function-classes-to-emf-table", PACKAGE_SYS, true)
495    {
496      @Override
497      public LispObject execute(LispObject arg)
498      {
499          return checkStandardGenericFunction(arg)
500      .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE];
501      }
502    };
503
504  // ### set-generic-function-classes-to-emf-table
505  private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE =
506    new Primitive("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true)
507    {
508      @Override
509      public LispObject execute(LispObject first, LispObject second)
510
511      {
512          checkStandardGenericFunction(first)
513      .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second;
514          return second;
515      }
516    };
517
518  // ### generic-function-documentation
519  private static final Primitive GENERIC_FUNCTION_DOCUMENTATION =
520    new Primitive("generic-function-documentation", PACKAGE_SYS, true)
521    {
522      @Override
523      public LispObject execute(LispObject arg)
524      {
525          return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION];
526      }
527    };
528
529  // ### set-generic-function-documentation
530  private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION =
531    new Primitive("set-generic-function-documentation", PACKAGE_SYS, true)
532    {
533      @Override
534      public LispObject execute(LispObject first, LispObject second)
535
536      {
537          checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] 
538      = second;
539          return second;
540      }
541    };
542
543  // ### %finalize-generic-function
544  private static final Primitive _FINALIZE_GENERIC_FUNCTION =
545    new Primitive("%finalize-generic-function", PACKAGE_SYS, true,
546                  "generic-function")
547    {
548      @Override
549      public LispObject execute(LispObject arg)
550      {
551          final StandardGenericFunction gf = checkStandardGenericFunction(arg);
552          gf.finalizeInternal();       
553          return T;
554      }
555    };
556
557  // ### cache-emf
558  private static final Primitive CACHE_EMF =
559    new Primitive("cache-emf", PACKAGE_SYS, true, "generic-function args emf")
560    {
561      @Override
562      public LispObject execute(LispObject first, LispObject second,
563                                LispObject third)
564
565      {
566        final StandardGenericFunction gf = checkStandardGenericFunction(first);
567        LispObject args = second;
568        LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
569        for (int i = gf.numberOfRequiredArgs; i-- > 0;)
570          {
571            array[i] = gf.getArgSpecialization(args.car());
572            args = args.cdr();
573          }
574        CacheEntry specializations = new CacheEntry(array);
575        HashMap<CacheEntry,LispObject> ht = gf.cache;
576        if (ht == null)
577            ht = gf.cache = new HashMap<CacheEntry,LispObject>();
578        ht.put(specializations, third);
579        return third;
580      }
581    };
582
583  // ### get-cached-emf
584  private static final Primitive GET_CACHED_EMF =
585    new Primitive("get-cached-emf", PACKAGE_SYS, true, "generic-function args")
586    {
587      @Override
588      public LispObject execute(LispObject first, LispObject second)
589
590      {
591        final StandardGenericFunction gf = checkStandardGenericFunction(first);
592        LispObject args = second;
593        LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
594        for (int i = gf.numberOfRequiredArgs; i-- > 0;)
595          {
596            array[i] = gf.getArgSpecialization(args.car());
597            args = args.cdr();
598          }
599        CacheEntry specializations = new CacheEntry(array);
600        HashMap<CacheEntry,LispObject> ht = gf.cache;
601        if (ht == null)
602          return NIL;
603        LispObject emf = (LispObject) ht.get(specializations);
604        return emf != null ? emf : NIL;
605      }
606    };
607
608  /**
609   * Returns an object representing generic function
610   * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
611   *
612   * <p>In the simplest case, when this generic function
613   * does not have EQL specialized methos, and therefore
614   * only argument types are relevant for choosing
615   * applicable methods, the value returned is the
616   * class of <tt>arg</tt>
617   *
618   * <p>If the function has EQL specialized methods:
619   *   - if <tt>arg</tt> is EQL to some of the EQL-specializers,
620   *     a special object representing equality to that specializer
621   *     is returned.
622   *   - otherwise class of the <tt>arg</tt> is returned.
623   *
624   * <p>Note that we do not consider argument position, when
625   * calculating arg specialization. In rare cases (when
626   * one argument is eql-specialized to a symbol specifying
627   * class of another argument) this may result in redundant cache
628   * entries caching the same method. But the method cached is anyway
629   * correct for the arguments (because in case of cache miss, correct method
630   * is calculated by other code, which does not rely on getArgSpecialization;
631   * and because EQL is true only for objects of the same type, which guaranties
632   * that if a type-specialized methods was chached by eql-specialization,
633   * all the cache hits into this records will be from args of the conforming
634   * type).
635   *
636   * <p>Consider:
637   * <pre><tt>
638   * (defgeneric f (a b))
639   *
640   * (defmethod f (a (b (eql 'symbol)))
641   *   "T (EQL 'SYMBOL)")
642   *
643   * (defmethod f ((a symbol) (b (eql 'symbol)))
644   *   "SYMBOL (EQL 'SYMBOL)")
645   *
646   * (f 12 'symbol)
647   * => "T (EQL 'SYMBOL)"
648   *
649   * (f 'twelve 'symbol)
650   * => "SYMBOL (EQL 'SYMBOL)"
651   *
652   * (f 'symbol 'symbol)
653   * => "SYMBOL (EQL 'SYMBOL)"
654   *
655   * </tt></pre>
656   *
657   * After the two above calls <tt>cache</tt> will contain tree keys:
658   * <pre>
659   * { class FIXNUM, EqlSpecialization('SYMBOL) }
660   * { class SYMBOL, EqlSpecialization('SYMBOL) }
661   * { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
662   * </pre>
663   */     
664  private LispObject getArgSpecialization(LispObject arg)
665  {
666    for (EqlSpecialization eqlSpecialization : eqlSpecializations)
667      {
668        if (eqlSpecialization.eqlTo.eql(arg))
669          return eqlSpecialization;
670      }
671    return arg.classOf();
672  }
673
674  // ### %get-arg-specialization
675  private static final Primitive _GET_ARG_SPECIALIZATION =
676    new Primitive("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg")
677    {
678      @Override
679      public LispObject execute(LispObject first, LispObject second)
680
681      {
682        final StandardGenericFunction gf = checkStandardGenericFunction(first);
683        return gf.getArgSpecialization(second);
684      }
685    };
686
687  // ### cache-slot-location
688  private static final Primitive CACHE_SLOT_LOCATION =
689    new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location")
690    {
691      @Override
692      public LispObject execute(LispObject first, LispObject second,
693                                LispObject third)
694
695      {
696        final StandardGenericFunction gf = checkStandardGenericFunction(first);
697        LispObject layout = second;
698        LispObject location = third;
699        HashMap<LispObject,LispObject> ht = gf.slotCache;
700        if (ht == null)
701          ht = gf.slotCache = new HashMap<LispObject,LispObject>();
702        ht.put(layout, location);
703        return third;
704      }
705    };
706
707  // ### get-cached-slot-location
708  private static final Primitive GET_CACHED_SLOT_LOCATION =
709    new Primitive("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout")
710    {
711      @Override
712      public LispObject execute(LispObject first, LispObject second)
713
714      {
715        final StandardGenericFunction gf = checkStandardGenericFunction(first);
716        LispObject layout = second;
717        HashMap<LispObject,LispObject> ht = gf.slotCache;
718        if (ht == null)
719          return NIL;
720        LispObject location = (LispObject) ht.get(layout);
721        return location != null ? location : NIL;
722      }
723    };
724
725  private static final StandardGenericFunction GENERIC_FUNCTION_NAME =
726    new StandardGenericFunction("generic-function-name",
727                                PACKAGE_MOP,
728                                true,
729                                _GENERIC_FUNCTION_NAME,
730                                list(Symbol.GENERIC_FUNCTION),
731                                list(StandardClass.STANDARD_GENERIC_FUNCTION));
732
733  private static class CacheEntry
734  {
735    final LispObject[] array;
736
737    CacheEntry(LispObject[] array)
738    {
739      this.array = array;
740    }
741
742    @Override
743    public int hashCode()
744    {
745      int result = 0;
746      for (int i = array.length; i-- > 0;)
747        result ^= array[i].hashCode();
748      return result;
749    }
750
751    @Override
752    public boolean equals(Object object)
753    {
754      if (!(object instanceof CacheEntry))
755        return false;
756      final CacheEntry otherEntry = (CacheEntry) object;
757      if (otherEntry.array.length != array.length)
758        return false;
759      final LispObject[] otherArray = otherEntry.array;
760      for (int i = array.length; i-- > 0;)
761        if (array[i] != otherArray[i])
762          return false;
763      return true;
764    }
765  }
766
767  private EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
768
769    // ### %init-eql-specializations
770    private static final Primitive _INIT_EQL_SPECIALIZATIONS
771      = new Primitive("%init-eql-specializations", PACKAGE_SYS, true, 
772        "generic-function eql-specilizer-objects-list")
773      {
774        @Override
775        public LispObject execute(LispObject first, LispObject second)
776
777        {
778          final StandardGenericFunction gf = checkStandardGenericFunction(first);
779          LispObject eqlSpecializerObjects = second;
780          gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
781          for (int i = 0; i < gf.eqlSpecializations.length; i++) {
782      gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
783      eqlSpecializerObjects = eqlSpecializerObjects.cdr();
784          }
785          return NIL;
786        }
787      };
788
789  private static class EqlSpecialization extends LispObject
790  {
791    public LispObject eqlTo;
792
793    public EqlSpecialization(LispObject eqlTo)
794    {
795        this.eqlTo = eqlTo;
796    }
797  }
798 
799  public static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
800
801  {
802    if (obj instanceof StandardGenericFunction)
803      return (StandardGenericFunction) obj;
804    return (StandardGenericFunction) // Not reached.
805      type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
806  }
807}
Note: See TracBrowser for help on using the repository browser.