source: branches/streams/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java

Last change on this file was 14503, checked in by rschlatte, 12 years ago

Move initial initialization of generic functions Lisp-side

File size: 7.9 KB
Line 
1/*
2 * FuncallableStandardObject.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves, 2012 Rudolf Schlatte
5 * $Id$
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
34
35// TODO: swap-slots is currently handled by StandardObject, so doesn't
36// exchange the functions.
37package org.armedbear.lisp;
38
39import static org.armedbear.lisp.Lisp.*;
40
41public class FuncallableStandardObject extends StandardObject
42{
43  LispObject function;
44
45  // KLUDGE: this is only needed for generic functions, but doesn't hurt
46  // to have it here.
47  EMFCache cache = new EMFCache();
48
49  protected FuncallableStandardObject()
50  {
51    super();
52  }
53
54
55  protected FuncallableStandardObject(Layout layout)
56  {
57    this(layout, layout.getLength());
58  }
59
60  protected FuncallableStandardObject(Layout layout, int length)
61  {
62    super(layout, length);
63  }
64
65
66  protected FuncallableStandardObject(LispClass cls, int length)
67  {
68    super(cls, length);
69  }
70
71  protected FuncallableStandardObject(LispClass cls)
72  {
73    super(cls);
74  }
75
76  @Override
77  public LispObject typep(LispObject type)
78  {
79    if (type == Symbol.COMPILED_FUNCTION)
80      {
81        if (function != null)
82          return function.typep(type);
83        else
84          return NIL;
85      }
86    if (type == Symbol.FUNCALLABLE_STANDARD_OBJECT)
87      return T;
88    if (type == StandardClass.FUNCALLABLE_STANDARD_OBJECT)
89      return T;
90    return super.typep(type);
91  }
92
93  @Override
94  public LispObject execute()
95  {
96    return function.execute();
97  }
98
99  @Override
100  public LispObject execute(LispObject arg)
101  {
102    return function.execute(arg);
103  }
104
105  @Override
106  public LispObject execute(LispObject first, LispObject second)
107
108  {
109    return function.execute(first, second);
110  }
111
112  @Override
113  public LispObject execute(LispObject first, LispObject second,
114                            LispObject third)
115
116  {
117    return function.execute(first, second, third);
118  }
119
120  @Override
121  public LispObject execute(LispObject first, LispObject second,
122                            LispObject third, LispObject fourth)
123
124  {
125    return function.execute(first, second, third, fourth);
126  }
127
128  @Override
129  public LispObject execute(LispObject first, LispObject second,
130                            LispObject third, LispObject fourth,
131                            LispObject fifth)
132
133  {
134    return function.execute(first, second, third, fourth,
135                            fifth);
136  }
137
138  @Override
139  public LispObject execute(LispObject first, LispObject second,
140                            LispObject third, LispObject fourth,
141                            LispObject fifth, LispObject sixth)
142
143  {
144    return function.execute(first, second, third, fourth,
145                            fifth, sixth);
146  }
147
148  @Override
149  public LispObject execute(LispObject first, LispObject second,
150                            LispObject third, LispObject fourth,
151                            LispObject fifth, LispObject sixth,
152                            LispObject seventh)
153
154  {
155    return function.execute(first, second, third, fourth,
156                            fifth, sixth, seventh);
157  }
158
159  @Override
160  public LispObject execute(LispObject first, LispObject second,
161                            LispObject third, LispObject fourth,
162                            LispObject fifth, LispObject sixth,
163                            LispObject seventh, LispObject eighth)
164
165  {
166    return function.execute(first, second, third, fourth,
167                            fifth, sixth, seventh, eighth);
168  }
169
170  @Override
171  public LispObject execute(LispObject[] args)
172  {
173    return function.execute(args);
174  }
175
176  private static final Primitive _ALLOCATE_FUNCALLABLE_INSTANCE
177    = new pf__allocate_funcallable_instance();
178  @DocString(name="%allocate-funcallable-instance",
179             args="class",
180             returns="instance")
181  private static final class pf__allocate_funcallable_instance extends Primitive
182  {
183    pf__allocate_funcallable_instance()
184    {
185      super("%allocate-funcallable-instance", PACKAGE_SYS, true, "class");
186    }
187    @Override
188    public LispObject execute(LispObject arg)
189    {
190      if (arg.typep(StandardClass.FUNCALLABLE_STANDARD_CLASS) != NIL) {
191        LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
192        if (! (l instanceof Layout)) {
193          return program_error("Invalid standard class layout for: "
194                               + arg.princToString() + ".");
195        }
196        return new FuncallableStandardObject((Layout)l);
197      }
198      return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS);
199    }
200  };
201
202  // AMOP p. 230
203  private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION
204    = new pf_set_funcallable_instance_function();
205  @DocString(name="set-funcallable-instance-function",
206             args="funcallable-instance function",
207             returns="unspecified")
208  private static final class pf_set_funcallable_instance_function extends Primitive
209  {
210    pf_set_funcallable_instance_function()
211    {
212      super("set-funcallable-instance-function", PACKAGE_MOP, true,
213            "funcallable-instance function");
214    }
215    @Override
216    public LispObject execute(LispObject first, LispObject second)
217    {
218      checkFuncallableStandardObject(first).function = second;
219      return second;
220    }
221  };
222
223  private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION
224    = new pf_funcallable_instance_function();
225  @DocString(name="funcallable-instance-function",
226             args="funcallable-instance",
227             returns="function")
228  private static final class pf_funcallable_instance_function extends Primitive
229  {
230    pf_funcallable_instance_function()
231    {
232      super("funcallable-instance-function", PACKAGE_MOP, false,
233            "funcallable-instance");
234    }
235    @Override
236    public LispObject execute(LispObject arg)
237    {
238      return checkFuncallableStandardObject(arg).function;
239    }
240  };
241
242
243  // Profiling.
244  private int callCount;
245  private int hotCount;
246
247  @Override
248  public final int getCallCount()
249  {
250    return callCount;
251  }
252
253  @Override
254  public void setCallCount(int n)
255  {
256    callCount = n;
257  }
258
259  @Override
260  public final void incrementCallCount()
261  {
262    ++callCount;
263  }
264
265  @Override
266  public final int getHotCount()
267  {
268    return hotCount;
269  }
270
271  @Override
272  public void setHotCount(int n)
273  {
274    hotCount = n;
275  }
276
277  @Override
278  public final void incrementHotCount()
279  {
280    ++hotCount;
281  }
282
283  public static final FuncallableStandardObject checkFuncallableStandardObject(LispObject obj)
284  {
285    if (obj instanceof FuncallableStandardObject)
286      return (FuncallableStandardObject) obj;
287    return (FuncallableStandardObject) // Not reached.
288      type_error(obj, Symbol.FUNCALLABLE_STANDARD_OBJECT);
289  }
290
291}
Note: See TracBrowser for help on using the repository browser.