001: /*
002: * LispClass.java
003: *
004: * Copyright (C) 2003-2004 Peter Graves
005: * $Id: LispClass.java,v 1.47 2004/05/23 17:42:02 piso Exp $
006: *
007: * This program is free software; you can redistribute it and/or
008: * modify it under the terms of the GNU General Public License
009: * as published by the Free Software Foundation; either version 2
010: * of the License, or (at your option) any later version.
011: *
012: * This program is distributed in the hope that it will be useful,
013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
015: * GNU General Public License for more details.
016: *
017: * You should have received a copy of the GNU General Public License
018: * along with this program; if not, write to the Free Software
019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
020: */
021:
022: package org.armedbear.lisp;
023:
024: import java.util.HashMap;
025:
026: public class LispClass extends StandardObject {
027: private static final HashMap map = new HashMap();
028:
029: public static void addClass(Symbol symbol, LispClass c) {
030: synchronized (map) {
031: map.put(symbol, c);
032: }
033: }
034:
035: public static LispClass findClass(Symbol symbol) {
036: synchronized (map) {
037: return (LispClass) map.get(symbol);
038: }
039: }
040:
041: protected Symbol symbol;
042: private Layout layout;
043: private LispObject directSuperclasses = NIL;
044: private LispObject directSubclasses = NIL;
045: private LispObject classPrecedenceList = NIL;
046: private LispObject directMethods = NIL;
047: private LispObject documentation = NIL;
048:
049: protected LispClass() {
050: }
051:
052: protected LispClass(Symbol symbol) {
053: this .symbol = symbol;
054: this .directSuperclasses = NIL;
055: }
056:
057: protected LispClass(Symbol symbol, LispObject directSuperclasses) {
058: this .symbol = symbol;
059: this .directSuperclasses = directSuperclasses;
060: }
061:
062: public LispObject getParts() throws ConditionThrowable {
063: LispObject result = NIL;
064: result = result.push(new Cons("NAME", symbol != null ? symbol
065: : NIL));
066: result = result.push(new Cons("LAYOUT", layout != null ? layout
067: : NIL));
068: result = result.push(new Cons("DIRECT-SUPERCLASSES",
069: directSuperclasses));
070: result = result.push(new Cons("DIRECT-SUBCLASSES",
071: directSubclasses));
072: result = result.push(new Cons("CLASS-PRECEDENCE-LIST",
073: classPrecedenceList));
074: result = result.push(new Cons("DIRECT-METHODS", directMethods));
075: result = result.push(new Cons("DOCUMENTATION", documentation));
076: return result.nreverse();
077: }
078:
079: public final Symbol getSymbol() {
080: return symbol;
081: }
082:
083: public final Layout getLayout() {
084: return layout;
085: }
086:
087: public final void setLayout(Layout layout) {
088: this .layout = layout;
089: }
090:
091: public LispObject getEffectiveSlots() {
092: return NIL;
093: }
094:
095: public final LispObject getDirectSuperclasses() {
096: return directSuperclasses;
097: }
098:
099: public final void setDirectSuperclasses(
100: LispObject directSuperclasses) {
101: this .directSuperclasses = directSuperclasses;
102: }
103:
104: // When there's only one direct superclass...
105: public final void setDirectSuperclass(LispObject super class) {
106: directSuperclasses = new Cons(super class);
107: }
108:
109: public final LispObject getDirectSubclasses() {
110: return directSubclasses;
111: }
112:
113: public final void setDirectSubclasses(LispObject directSubclasses) {
114: this .directSubclasses = directSubclasses;
115: }
116:
117: public final LispObject getCPL() {
118: return classPrecedenceList;
119: }
120:
121: public final void setCPL(LispObject obj1) {
122: if (obj1 instanceof Cons)
123: classPrecedenceList = obj1;
124: else {
125: Debug.assertTrue(obj1 == this );
126: classPrecedenceList = new Cons(obj1);
127: }
128: }
129:
130: public final void setCPL(LispObject obj1, LispObject obj2) {
131: Debug.assertTrue(obj1 == this );
132: classPrecedenceList = list2(obj1, obj2);
133: }
134:
135: public final void setCPL(LispObject obj1, LispObject obj2,
136: LispObject obj3) {
137: Debug.assertTrue(obj1 == this );
138: classPrecedenceList = list3(obj1, obj2, obj3);
139: }
140:
141: public final void setCPL(LispObject obj1, LispObject obj2,
142: LispObject obj3, LispObject obj4) {
143: Debug.assertTrue(obj1 == this );
144: classPrecedenceList = list4(obj1, obj2, obj3, obj4);
145: }
146:
147: public final void setCPL(LispObject obj1, LispObject obj2,
148: LispObject obj3, LispObject obj4, LispObject obj5) {
149: Debug.assertTrue(obj1 == this );
150: classPrecedenceList = list5(obj1, obj2, obj3, obj4, obj5);
151: }
152:
153: public final void setCPL(LispObject obj1, LispObject obj2,
154: LispObject obj3, LispObject obj4, LispObject obj5,
155: LispObject obj6) {
156: Debug.assertTrue(obj1 == this );
157: classPrecedenceList = list6(obj1, obj2, obj3, obj4, obj5, obj6);
158: }
159:
160: public final void setCPL(LispObject obj1, LispObject obj2,
161: LispObject obj3, LispObject obj4, LispObject obj5,
162: LispObject obj6, LispObject obj7) {
163: Debug.assertTrue(obj1 == this );
164: classPrecedenceList = list7(obj1, obj2, obj3, obj4, obj5, obj6,
165: obj7);
166: }
167:
168: public final void setCPL(LispObject obj1, LispObject obj2,
169: LispObject obj3, LispObject obj4, LispObject obj5,
170: LispObject obj6, LispObject obj7, LispObject obj8) {
171: Debug.assertTrue(obj1 == this );
172: classPrecedenceList = list8(obj1, obj2, obj3, obj4, obj5, obj6,
173: obj7, obj8);
174: }
175:
176: public String getName() {
177: return symbol.getName();
178: }
179:
180: public LispObject typeOf() {
181: return Symbol.CLASS;
182: }
183:
184: public LispClass classOf() {
185: return BuiltInClass.CLASS;
186: }
187:
188: public LispObject typep(LispObject type) throws ConditionThrowable {
189: if (type == Symbol.CLASS)
190: return T;
191: if (type == BuiltInClass.CLASS)
192: return T;
193: return super .typep(type);
194: }
195:
196: // ### find-class
197: // find-class symbol &optional errorp environment => class
198: private static final Primitive FIND_CLASS = new Primitive(
199: "find-class", "symbol &optional errorp environment") {
200: public LispObject execute(LispObject symbol)
201: throws ConditionThrowable {
202: LispObject c = findClass(checkSymbol(symbol));
203: if (c == null) {
204: StringBuffer sb = new StringBuffer(
205: "There is no class named ");
206: sb.append(symbol.writeToString());
207: sb.append('.');
208: return signal(new LispError(sb.toString()));
209: }
210: return c;
211: }
212:
213: public LispObject execute(LispObject symbol, LispObject errorp)
214: throws ConditionThrowable {
215: LispObject c = findClass(checkSymbol(symbol));
216: if (c == null) {
217: if (errorp != NIL) {
218: StringBuffer sb = new StringBuffer(
219: "There is no class named ");
220: sb.append(symbol.writeToString());
221: sb.append('.');
222: return signal(new LispError(sb.toString()));
223: }
224: return NIL;
225: }
226: return c;
227: }
228:
229: public LispObject execute(LispObject symbol, LispObject errorp,
230: LispObject environment) throws ConditionThrowable {
231: // FIXME Ignore environment.
232: return execute(symbol, errorp);
233: }
234: };
235:
236: // ### %set-find-class
237: private static final Primitive2 _SET_FIND_CLASS = new Primitive2(
238: "%set-find-class", PACKAGE_SYS, false) {
239: public LispObject execute(LispObject first, LispObject second)
240: throws ConditionThrowable {
241: Symbol symbol = checkSymbol(first);
242: if (second instanceof LispClass) {
243: addClass(symbol, (LispClass) second);
244: return second;
245: }
246: if (second == NIL) {
247: map.remove(symbol);
248: return second;
249: }
250: return signal(new TypeError(second, "class"));
251: }
252: };
253:
254: // ### %class-name
255: private static final Primitive1 _CLASS_NAME = new Primitive1(
256: "%class-name", PACKAGE_SYS, false, "class") {
257: public LispObject execute(LispObject arg)
258: throws ConditionThrowable {
259: try {
260: return ((LispClass) arg).symbol;
261: } catch (ClassCastException e) {
262: return signal(new TypeError(arg, "class"));
263: }
264: }
265: };
266:
267: // ### %set-class-name
268: private static final Primitive2 _SET_CLASS_NAME = new Primitive2(
269: "%set-class-name", PACKAGE_SYS, false) {
270: public LispObject execute(LispObject first, LispObject second)
271: throws ConditionThrowable {
272: try {
273: ((LispClass) first).symbol = checkSymbol(second);
274: return second;
275: } catch (ClassCastException e) {
276: return signal(new TypeError(first, "class"));
277: }
278: }
279: };
280:
281: // ### class-layout
282: private static final Primitive1 CLASS_LAYOUT = new Primitive1(
283: "class-layout", PACKAGE_SYS, false) {
284: public LispObject execute(LispObject arg)
285: throws ConditionThrowable {
286: try {
287: Layout layout = ((LispClass) arg).getLayout();
288: return layout != null ? layout : NIL;
289: } catch (ClassCastException e) {
290: return signal(new TypeError(arg, "class"));
291: }
292: }
293: };
294:
295: // ### %set-class-layout
296: private static final Primitive2 _SET_CLASS_LAYOUT = new Primitive2(
297: "%set-class-layout", PACKAGE_SYS, false) {
298: public LispObject execute(LispObject first, LispObject second)
299: throws ConditionThrowable {
300: try {
301: ((LispClass) first).setLayout((Layout) second);
302: return second;
303: } catch (ClassCastException e) {
304: if (!(first instanceof LispClass))
305: return signal(new TypeError(first, "class"));
306: if (!(second instanceof Layout))
307: return signal(new TypeError(second, "layout"));
308: // Not reached.
309: return NIL;
310: }
311: }
312: };
313:
314: // ### class-direct-superclasses
315: private static final Primitive1 CLASS_DIRECT_SUPERCLASSES = new Primitive1(
316: "class-direct-superclasses", PACKAGE_SYS, false) {
317: public LispObject execute(LispObject arg)
318: throws ConditionThrowable {
319: if (arg instanceof LispClass)
320: return ((LispClass) arg).getDirectSuperclasses();
321: return signal(new TypeError(arg, "class"));
322: }
323: };
324:
325: // ### %set-class-direct-superclasses
326: private static final Primitive2 _SET_CLASS_DIRECT_SUPERCLASSES = new Primitive2(
327: "%set-class-direct-superclasses", PACKAGE_SYS, false) {
328: public LispObject execute(LispObject first, LispObject second)
329: throws ConditionThrowable {
330: if (first instanceof LispClass) {
331: ((LispClass) first).setDirectSuperclasses(second);
332: return second;
333: }
334: return signal(new TypeError(first, "class"));
335: }
336: };
337:
338: // ### class-direct-subclasses
339: private static final Primitive1 CLASS_DIRECT_SUBCLASSES = new Primitive1(
340: "class-direct-subclasses", PACKAGE_SYS, false) {
341: public LispObject execute(LispObject arg)
342: throws ConditionThrowable {
343: if (arg instanceof LispClass)
344: return ((LispClass) arg).getDirectSubclasses();
345: return signal(new TypeError(arg, "class"));
346: }
347: };
348:
349: // ### %set-class-direct-subclasses
350: private static final Primitive2 _SET_CLASS_DIRECT_SUBCLASSES = new Primitive2(
351: "%set-class-direct-subclasses", PACKAGE_SYS, false) {
352: public LispObject execute(LispObject first, LispObject second)
353: throws ConditionThrowable {
354: if (first instanceof LispClass) {
355: ((LispClass) first).setDirectSubclasses(second);
356: return second;
357: }
358: return signal(new TypeError(first, "class"));
359: }
360: };
361:
362: // ### class-precedence-list
363: private static final Primitive1 CLASS_PRECEDENCE_LIST = new Primitive1(
364: "class-precedence-list", PACKAGE_SYS, false) {
365: public LispObject execute(LispObject arg)
366: throws ConditionThrowable {
367: if (arg instanceof LispClass)
368: return ((LispClass) arg).getCPL();
369: return signal(new TypeError(arg, "class"));
370: }
371: };
372:
373: // ### %set-class-precedence-list
374: private static final Primitive1 _SET_CLASS_PRECEDENCE_LIST = new Primitive1(
375: "%set-class-precedence-list", PACKAGE_SYS, false) {
376: public LispObject execute(LispObject first, LispObject second)
377: throws ConditionThrowable {
378: if (first instanceof LispClass) {
379: ((LispClass) first).classPrecedenceList = second;
380: return second;
381: }
382: return signal(new TypeError(first, "class"));
383: }
384: };
385:
386: // ### class-direct-methods
387: private static final Primitive1 CLASS_DIRECT_METHODS = new Primitive1(
388: "class-direct-methods", PACKAGE_SYS, false) {
389: public LispObject execute(LispObject arg)
390: throws ConditionThrowable {
391: if (arg instanceof LispClass)
392: return ((LispClass) arg).directMethods;
393: return signal(new TypeError(arg, "class"));
394: }
395: };
396:
397: // ### %set-class-direct-methods
398: private static final Primitive2 _SET_CLASS_DIRECT_METHODS = new Primitive2(
399: "%set-class-direct-methods", PACKAGE_SYS, false) {
400: public LispObject execute(LispObject first, LispObject second)
401: throws ConditionThrowable {
402: if (first instanceof LispClass) {
403: ((LispClass) first).directMethods = second;
404: return second;
405: }
406: return signal(new TypeError(first, "class"));
407: }
408: };
409:
410: // ### class-documentation
411: private static final Primitive1 CLASS_DOCUMENTATION = new Primitive1(
412: "class-documentation", PACKAGE_SYS, false) {
413: public LispObject execute(LispObject arg)
414: throws ConditionThrowable {
415: if (arg instanceof LispClass)
416: return ((LispClass) arg).documentation;
417: return signal(new TypeError(arg, "class"));
418: }
419: };
420:
421: // ### %set-class-documentation
422: private static final Primitive2 _SET_CLASS_DOCUMENTATION = new Primitive2(
423: "%set-class-documentation", PACKAGE_SYS, false) {
424: public LispObject execute(LispObject first, LispObject second)
425: throws ConditionThrowable {
426: if (first instanceof LispClass) {
427: ((LispClass) first).documentation = second;
428: return second;
429: }
430: return signal(new TypeError(first, "class"));
431: }
432: };
433:
434: // ### classp
435: private static final Primitive1 CLASSP = new Primitive1("classp",
436: PACKAGE_EXT, true) {
437: public LispObject execute(LispObject arg) {
438: return arg instanceof LispClass ? T : NIL;
439: }
440: };
441: }
|