|
1
21
22 package org.armedbear.lisp;
23
24 import java.util.HashMap  ;
25
26 public class LispClass extends StandardObject
27 {
28 private static final HashMap map = new HashMap ();
29
30 public static void addClass(Symbol symbol, LispClass c)
31 {
32 synchronized (map) {
33 map.put(symbol, c);
34 }
35 }
36
37 public static LispClass findClass(Symbol symbol)
38 {
39 synchronized (map) {
40 return (LispClass) map.get(symbol);
41 }
42 }
43
44 protected Symbol symbol;
45 private Layout layout;
46 private LispObject directSuperclasses = NIL;
47 private LispObject directSubclasses = NIL;
48 private LispObject classPrecedenceList = NIL;
49 private LispObject directMethods = NIL;
50 private LispObject documentation = NIL;
51
52 protected LispClass()
53 {
54 }
55
56 protected LispClass(Symbol symbol)
57 {
58 this.symbol = symbol;
59 this.directSuperclasses = NIL;
60 }
61
62 protected LispClass(Symbol symbol, LispObject directSuperclasses)
63 {
64 this.symbol = symbol;
65 this.directSuperclasses = directSuperclasses;
66 }
67
68 public LispObject getParts() throws ConditionThrowable
69 {
70 LispObject result = NIL;
71 result = result.push(new Cons("NAME", symbol != null ? symbol : NIL));
72 result = result.push(new Cons("LAYOUT", layout != null ? layout : NIL));
73 result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses));
74 result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses));
75 result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList));
76 result = result.push(new Cons("DIRECT-METHODS", directMethods));
77 result = result.push(new Cons("DOCUMENTATION", documentation));
78 return result.nreverse();
79 }
80
81 public final Symbol getSymbol()
82 {
83 return symbol;
84 }
85
86 public final Layout getLayout()
87 {
88 return layout;
89 }
90
91 public final void setLayout(Layout layout)
92 {
93 this.layout = layout;
94 }
95
96 public LispObject getEffectiveSlots()
97 {
98 return NIL;
99 }
100
101 public final LispObject getDirectSuperclasses()
102 {
103 return directSuperclasses;
104 }
105
106 public final void setDirectSuperclasses(LispObject directSuperclasses)
107 {
108 this.directSuperclasses = directSuperclasses;
109 }
110
111 public final void setDirectSuperclass(LispObject superclass)
113 {
114 directSuperclasses = new Cons(superclass);
115 }
116
117 public final LispObject getDirectSubclasses()
118 {
119 return directSubclasses;
120 }
121
122 public final void setDirectSubclasses(LispObject directSubclasses)
123 {
124 this.directSubclasses = directSubclasses;
125 }
126
127 public final LispObject getCPL()
128 {
129 return classPrecedenceList;
130 }
131
132 public final void setCPL(LispObject obj1)
133 {
134 if (obj1 instanceof Cons)
135 classPrecedenceList = obj1;
136 else {
137 Debug.assertTrue(obj1 == this);
138 classPrecedenceList = new Cons(obj1);
139 }
140 }
141
142 public final void setCPL(LispObject obj1, LispObject obj2)
143 {
144 Debug.assertTrue(obj1 == this);
145 classPrecedenceList = list2(obj1, obj2);
146 }
147
148 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3)
149 {
150 Debug.assertTrue(obj1 == this);
151 classPrecedenceList = list3(obj1, obj2, obj3);
152 }
153
154 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
155 LispObject obj4)
156 {
157 Debug.assertTrue(obj1 == this);
158 classPrecedenceList = list4(obj1, obj2, obj3, obj4);
159 }
160
161 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
162 LispObject obj4, LispObject obj5)
163 {
164 Debug.assertTrue(obj1 == this);
165 classPrecedenceList = list5(obj1, obj2, obj3, obj4, obj5);
166 }
167
168 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
169 LispObject obj4, LispObject obj5, LispObject obj6)
170 {
171 Debug.assertTrue(obj1 == this);
172 classPrecedenceList = list6(obj1, obj2, obj3, obj4, obj5, obj6);
173 }
174
175 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
176 LispObject obj4, LispObject obj5, LispObject obj6,
177 LispObject obj7)
178 {
179 Debug.assertTrue(obj1 == this);
180 classPrecedenceList = list7(obj1, obj2, obj3, obj4, obj5, obj6, obj7);
181 }
182
183 public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3,
184 LispObject obj4, LispObject obj5, LispObject obj6,
185 LispObject obj7, LispObject obj8)
186 {
187 Debug.assertTrue(obj1 == this);
188 classPrecedenceList =
189 list8(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8);
190 }
191
192 public String getName()
193 {
194 return symbol.getName();
195 }
196
197 public LispObject typeOf()
198 {
199 return Symbol.CLASS;
200 }
201
202 public LispClass classOf()
203 {
204 return BuiltInClass.CLASS;
205 }
206
207 public LispObject typep(LispObject type) throws ConditionThrowable
208 {
209 if (type == Symbol.CLASS)
210 return T;
211 if (type == BuiltInClass.CLASS)
212 return T;
213 return super.typep(type);
214 }
215
216 private static final Primitive FIND_CLASS =
219 new Primitive("find-class", "symbol &optional errorp environment")
220 {
221 public LispObject execute(LispObject symbol) throws ConditionThrowable
222 {
223 LispObject c = findClass(checkSymbol(symbol));
224 if (c == null) {
225 StringBuffer sb = new StringBuffer ("There is no class named ");
226 sb.append(symbol.writeToString());
227 sb.append('.');
228 return signal(new LispError(sb.toString()));
229 }
230 return c;
231 }
232 public LispObject execute(LispObject symbol, LispObject errorp)
233 throws ConditionThrowable
234 {
235 LispObject c = findClass(checkSymbol(symbol));
236 if (c == null) {
237 if (errorp != NIL) {
238 StringBuffer sb = new StringBuffer ("There is no class named ");
239 sb.append(symbol.writeToString());
240 sb.append('.');
241 return signal(new LispError(sb.toString()));
242 }
243 return NIL;
244 }
245 return c;
246 }
247 public LispObject execute(LispObject symbol, LispObject errorp,
248 LispObject environment)
249 throws ConditionThrowable
250 {
251 return execute(symbol, errorp);
253 }
254 };
255
256 private static final Primitive2 _SET_FIND_CLASS =
258 new Primitive2("%set-find-class", PACKAGE_SYS, false)
259 {
260 public LispObject execute(LispObject first, LispObject second)
261 throws ConditionThrowable
262 {
263 Symbol symbol = checkSymbol(first);
264 if (second instanceof LispClass) {
265 addClass(symbol, (LispClass) second);
266 return second;
267 }
268 if (second == NIL) {
269 map.remove(symbol);
270 return second;
271 }
272 return signal(new TypeError(second, "class"));
273 }
274 };
275
276 private static final Primitive1 _CLASS_NAME =
278 new Primitive1("%class-name", PACKAGE_SYS, false, "class")
279 {
280 public LispObject execute(LispObject arg) throws ConditionThrowable
281 {
282 try {
283 return ((LispClass)arg).symbol;
284 }
285 catch (ClassCastException e) {
286 return signal(new TypeError(arg, "class"));
287 }
288 }
289 };
290
291 private static final Primitive2 _SET_CLASS_NAME =
293 new Primitive2("%set-class-name", PACKAGE_SYS, false)
294 {
295 public LispObject execute(LispObject first, LispObject second)
296 throws ConditionThrowable
297 {
298 try {
299 ((LispClass)first).symbol = checkSymbol(second);
300 return second;
301 }
302 catch (ClassCastException e) {
303 return signal(new TypeError(first, "class"));
304 }
305 }
306 };
307
308 private static final Primitive1 CLASS_LAYOUT =
310 new Primitive1("class-layout", PACKAGE_SYS, false)
311 {
312 public LispObject execute(LispObject arg) throws ConditionThrowable
313 {
314 try {
315 Layout layout = ((LispClass)arg).getLayout();
316 return layout != null ? layout : NIL;
317 }
318 catch (ClassCastException e) {
319 return signal(new TypeError(arg, "class"));
320 }
321 }
322 };
323
324 private static final Primitive2 _SET_CLASS_LAYOUT =
326 new Primitive2("%set-class-layout", PACKAGE_SYS, false)
327 {
328 public LispObject execute(LispObject first, LispObject second)
329 throws ConditionThrowable
330 {
331 try {
332 ((LispClass)first).setLayout((Layout)second);
333 return second;
334 }
335 catch (ClassCastException e) {
336 if (!(first instanceof LispClass))
337 return signal(new TypeError(first, "class"));
338 if (!(second instanceof Layout))
339 return signal(new TypeError(second, "layout"));
340 return NIL;
342 }
343 }
344 };
345
346 private static final Primitive1 CLASS_DIRECT_SUPERCLASSES =
348 new Primitive1("class-direct-superclasses", PACKAGE_SYS, false)
349 {
350 public LispObject execute(LispObject arg) throws ConditionThrowable
351 {
352 if (arg instanceof LispClass)
353 return ((LispClass)arg).getDirectSuperclasses();
354 return signal(new TypeError(arg, "class"));
355 }
356 };
357
358 private static final Primitive2 _SET_CLASS_DIRECT_SUPERCLASSES =
360 new Primitive2("%set-class-direct-superclasses", PACKAGE_SYS, false)
361 {
362 public LispObject execute(LispObject first, LispObject second)
363 throws ConditionThrowable
364 {
365 if (first instanceof LispClass) {
366 ((LispClass)first).setDirectSuperclasses(second);
367 return second;
368 }
369 return signal(new TypeError(first, "class"));
370 }
371 };
372
373 private static final Primitive1 CLASS_DIRECT_SUBCLASSES =
375 new Primitive1("class-direct-subclasses", PACKAGE_SYS, false)
376 {
377 public LispObject execute(LispObject arg) throws ConditionThrowable
378 {
379 if (arg instanceof LispClass)
380 return ((LispClass)arg).getDirectSubclasses();
381 return signal(new TypeError(arg, "class"));
382 }
383 };
384
385 private static final Primitive2 _SET_CLASS_DIRECT_SUBCLASSES =
387 new Primitive2("%set-class-direct-subclasses", PACKAGE_SYS, false)
388 {
389 public LispObject execute(LispObject first, LispObject second)
390 throws ConditionThrowable
391 {
392 if (first instanceof LispClass) {
393 ((LispClass)first).setDirectSubclasses(second);
394 return second;
395 }
396 return signal(new TypeError(first, "class"));
397 }
398 };
399
400 private static final Primitive1 CLASS_PRECEDENCE_LIST =
402 new Primitive1("class-precedence-list", PACKAGE_SYS, false)
403 {
404 public LispObject execute(LispObject arg) throws ConditionThrowable
405 {
406 if (arg instanceof LispClass)
407 return ((LispClass)arg).getCPL();
408 return signal(new TypeError(arg, "class"));
409 }
410 };
411
412 private static final Primitive1 _SET_CLASS_PRECEDENCE_LIST =
414 new Primitive1("%set-class-precedence-list", PACKAGE_SYS, false)
415 {
416 public LispObject execute(LispObject first, LispObject second)
417 throws ConditionThrowable
418 {
419 if (first instanceof LispClass) {
420 ((LispClass)first).classPrecedenceList = second;
421 return second;
422 }
423 return signal(new TypeError(first, "class"));
424 }
425 };
426
427 private static final Primitive1 CLASS_DIRECT_METHODS =
429 new Primitive1("class-direct-methods", PACKAGE_SYS, false)
430 {
431 public LispObject execute(LispObject arg)
432 throws ConditionThrowable
433 {
434 if (arg instanceof LispClass)
435 return ((LispClass)arg).directMethods;
436 return signal(new TypeError(arg, "class"));
437 }
438 };
439
440 private static final Primitive2 _SET_CLASS_DIRECT_METHODS =
442 new Primitive2("%set-class-direct-methods", PACKAGE_SYS, false)
443 {
444 public LispObject execute(LispObject first, LispObject second)
445 throws ConditionThrowable
446 {
447 if (first instanceof LispClass) {
448 ((LispClass)first).directMethods = second;
449 return second;
450 }
451 return signal(new TypeError(first, "class"));
452 }
453 };
454
455 private static final Primitive1 CLASS_DOCUMENTATION =
457 new Primitive1("class-documentation", PACKAGE_SYS, false)
458 {
459 public LispObject execute(LispObject arg)
460 throws ConditionThrowable
461 {
462 if (arg instanceof LispClass)
463 return ((LispClass)arg).documentation;
464 return signal(new TypeError(arg, "class"));
465 }
466 };
467
468 private static final Primitive2 _SET_CLASS_DOCUMENTATION =
470 new Primitive2("%set-class-documentation", PACKAGE_SYS, false)
471 {
472 public LispObject execute(LispObject first, LispObject second)
473 throws ConditionThrowable
474 {
475 if (first instanceof LispClass) {
476 ((LispClass)first).documentation = second;
477 return second;
478 }
479 return signal(new TypeError(first, "class"));
480 }
481 };
482
483 private static final Primitive1 CLASSP =
485 new Primitive1("classp", PACKAGE_EXT, true)
486 {
487 public LispObject execute(LispObject arg)
488 {
489 return arg instanceof LispClass ? T : NIL;
490 }
491 };
492 }
493 |
Popular Tags |
Java API By Example, From Geeks To Geeks.