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

Last change on this file was 12513, checked in by ehuelsmann, 15 years ago

Remove 'private' keyword to eliminate the Java requirement

for the compiler to generate synthetic accessors: functions that
don't appear in the source but do appear in the class file.

Patch by: Douglas Miles <dmiles _at_ users.sf.net>

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