001: /*
002: * LispClass.java
003: *
004: * Copyright (C) 2003 Peter Graves
005: * $Id: LispClass.java,v 1.6 2003/11/15 11:03:33 beedlem 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 LispObject directSuperclasses;
043: private LispObject directSubclasses;
044: private LispObject classPrecedenceList = NIL;
045: private LispObject directMethods = NIL;
046:
047: protected LispClass() {
048: }
049:
050: protected LispClass(Symbol symbol) {
051: this .symbol = symbol;
052: this .directSuperclasses = NIL;
053: }
054:
055: protected LispClass(Symbol symbol, LispObject directSuperclasses) {
056: this .symbol = symbol;
057: this .directSuperclasses = directSuperclasses;
058: }
059:
060: public final Symbol getSymbol() {
061: return symbol;
062: }
063:
064: public final LispObject getDirectSuperclasses() {
065: return directSuperclasses;
066: }
067:
068: public final void setDirectSuperclasses(
069: LispObject directSuperclasses) {
070: this .directSuperclasses = directSuperclasses;
071: }
072:
073: // When there's only one direct superclass...
074: public final void setDirectSuperclass(LispObject super class) {
075: directSuperclasses = new Cons(super class);
076: }
077:
078: public final LispObject getDirectSubclasses() {
079: return directSubclasses;
080: }
081:
082: public final void setDirectSubclasses(LispObject directSubclasses) {
083: this .directSubclasses = directSubclasses;
084: }
085:
086: public final LispObject getCPL() {
087: return classPrecedenceList;
088: }
089:
090: public final void setCPL(LispObject obj1) {
091: Debug.assertTrue(obj1 == this );
092: classPrecedenceList = new Cons(obj1);
093: }
094:
095: public final void setCPL(LispObject obj1, LispObject obj2) {
096: Debug.assertTrue(obj1 == this );
097: classPrecedenceList = list2(obj1, obj2);
098: }
099:
100: public final void setCPL(LispObject obj1, LispObject obj2,
101: LispObject obj3) {
102: Debug.assertTrue(obj1 == this );
103: classPrecedenceList = list3(obj1, obj2, obj3);
104: }
105:
106: public final void setCPL(LispObject obj1, LispObject obj2,
107: LispObject obj3, LispObject obj4) {
108: Debug.assertTrue(obj1 == this );
109: classPrecedenceList = list4(obj1, obj2, obj3, obj4);
110: }
111:
112: public final void setCPL(LispObject obj1, LispObject obj2,
113: LispObject obj3, LispObject obj4, LispObject obj5) {
114: Debug.assertTrue(obj1 == this );
115: classPrecedenceList = list5(obj1, obj2, obj3, obj4, obj5);
116: }
117:
118: public final void setCPL(LispObject obj1, LispObject obj2,
119: LispObject obj3, LispObject obj4, LispObject obj5,
120: LispObject obj6) {
121: Debug.assertTrue(obj1 == this );
122: classPrecedenceList = list6(obj1, obj2, obj3, obj4, obj5, obj6);
123: }
124:
125: public final void setCPL(LispObject obj1, LispObject obj2,
126: LispObject obj3, LispObject obj4, LispObject obj5,
127: LispObject obj6, LispObject obj7) {
128: Debug.assertTrue(obj1 == this );
129: classPrecedenceList = list7(obj1, obj2, obj3, obj4, obj5, obj6,
130: obj7);
131: }
132:
133: public String getName() {
134: return symbol.getName();
135: }
136:
137: public LispObject typeOf() {
138: return Symbol.CLASS;
139: }
140:
141: public LispClass classOf() {
142: return BuiltInClass.CLASS;
143: }
144:
145: public LispObject typep(LispObject type) throws ConditionThrowable {
146: if (type == Symbol.CLASS)
147: return T;
148: if (type == BuiltInClass.CLASS)
149: return T;
150: return super .typep(type);
151: }
152:
153: // ### find-class
154: // find-class symbol &optional errorp environment => class
155: private static final Primitive FIND_CLASS = new Primitive(
156: "find-class") {
157: public LispObject execute(LispObject symbol)
158: throws ConditionThrowable {
159: LispObject c = findClass(checkSymbol(symbol));
160: if (c == null) {
161: StringBuffer sb = new StringBuffer(
162: "there is no class named ");
163: sb.append(symbol);
164: throw new ConditionThrowable(new LispError(sb
165: .toString()));
166: }
167: return c;
168: }
169:
170: public LispObject execute(LispObject symbol, LispObject errorp)
171: throws ConditionThrowable {
172: LispObject c = findClass(checkSymbol(symbol));
173: if (c == null) {
174: if (errorp != NIL) {
175: StringBuffer sb = new StringBuffer(
176: "there is no class named ");
177: sb.append(symbol);
178: throw new ConditionThrowable(new LispError(sb
179: .toString()));
180: }
181: return NIL;
182: }
183: return c;
184: }
185:
186: public LispObject execute(LispObject symbol, LispObject errorp,
187: LispObject environment) throws ConditionThrowable {
188: // FIXME Ignore environment.
189: return execute(symbol, errorp);
190: }
191: };
192:
193: // ### %set-find-class
194: private static final Primitive2 _SET_FIND_CLASS = new Primitive2(
195: "%set-find-class", PACKAGE_SYS, false) {
196: public LispObject execute(LispObject first, LispObject second)
197: throws ConditionThrowable {
198: Symbol symbol = checkSymbol(first);
199: if (second instanceof LispClass) {
200: addClass(symbol, (LispClass) second);
201: return second;
202: }
203: if (second == NIL) {
204: map.remove(symbol);
205: return second;
206: }
207: throw new ConditionThrowable(new TypeError(second, "class"));
208: }
209: };
210:
211: // ### class-name
212: private static final Primitive1 CLASS_NAME = new Primitive1(
213: "class-name") {
214: public LispObject execute(LispObject arg)
215: throws ConditionThrowable {
216: try {
217: return ((LispClass) arg).symbol;
218: } catch (ClassCastException e) {
219: throw new ConditionThrowable(
220: new TypeError(arg, "class"));
221: }
222: }
223: };
224:
225: // ### %set-class-name
226: private static final Primitive2 _SET_CLASS_NAME = new Primitive2(
227: "%set-class-name", PACKAGE_SYS, false) {
228: public LispObject execute(LispObject first, LispObject second)
229: throws ConditionThrowable {
230: try {
231: ((LispClass) first).symbol = checkSymbol(second);
232: return second;
233: } catch (ClassCastException e) {
234: throw new ConditionThrowable(new TypeError(first,
235: "class"));
236: }
237: }
238: };
239:
240: // ### class-direct-superclasses
241: private static final Primitive1 CLASS_DIRECT_SUPERCLASSES = new Primitive1(
242: "class-direct-superclasses", PACKAGE_SYS, false) {
243: public LispObject execute(LispObject arg)
244: throws ConditionThrowable {
245: if (arg instanceof LispClass)
246: return ((LispClass) arg).getDirectSuperclasses();
247: throw new ConditionThrowable(new TypeError(arg, "class"));
248: }
249: };
250:
251: // ### %set-class-direct-superclasses
252: private static final Primitive2 _SET_CLASS_DIRECT_SUPERCLASSES = new Primitive2(
253: "%set-class-direct-superclasses", PACKAGE_SYS, false) {
254: public LispObject execute(LispObject first, LispObject second)
255: throws ConditionThrowable {
256: if (first instanceof LispClass) {
257: ((LispClass) first).setDirectSuperclasses(second);
258: return second;
259: }
260: throw new ConditionThrowable(new TypeError(first, "class"));
261: }
262: };
263:
264: // ### class-direct-subclasses
265: private static final Primitive1 CLASS_DIRECT_SUBCLASSES = new Primitive1(
266: "class-direct-subclasses", PACKAGE_SYS, false) {
267: public LispObject execute(LispObject arg)
268: throws ConditionThrowable {
269: if (arg instanceof LispClass)
270: return ((LispClass) arg).getDirectSubclasses();
271: throw new ConditionThrowable(new TypeError(arg, "class"));
272: }
273: };
274:
275: // ### %set-class-direct-subclasses
276: private static final Primitive2 _SET_CLASS_DIRECT_SUBCLASSES = new Primitive2(
277: "%set-class-direct-subclasses", PACKAGE_SYS, false) {
278: public LispObject execute(LispObject first, LispObject second)
279: throws ConditionThrowable {
280: if (first instanceof LispClass) {
281: ((LispClass) first).setDirectSubclasses(second);
282: return second;
283: }
284: throw new ConditionThrowable(new TypeError(first, "class"));
285: }
286: };
287:
288: // ### class-precedence-list
289: private static final Primitive1 CLASS_PRECEDENCE_LIST = new Primitive1(
290: "class-precedence-list", PACKAGE_SYS, false) {
291: public LispObject execute(LispObject arg)
292: throws ConditionThrowable {
293: if (arg instanceof LispClass)
294: return ((LispClass) arg).getCPL();
295: throw new ConditionThrowable(new TypeError(arg, "class"));
296: }
297: };
298:
299: // ### %set-class-precedence-list
300: private static final Primitive1 _SET_CLASS_PRECEDENCE_LIST = new Primitive1(
301: "%set-class-precedence-list", PACKAGE_SYS, false) {
302: public LispObject execute(LispObject first, LispObject second)
303: throws ConditionThrowable {
304: if (first instanceof LispClass) {
305: ((LispClass) first).classPrecedenceList = second;
306: return second;
307: }
308: throw new ConditionThrowable(new TypeError(first, "class"));
309: }
310: };
311:
312: // ### class-direct-methods
313: private static final Primitive1 CLASS_DIRECT_METHODS = new Primitive1(
314: "class-direct-methods", PACKAGE_SYS, false) {
315: public LispObject execute(LispObject arg)
316: throws ConditionThrowable {
317: if (arg instanceof LispClass)
318: return ((LispClass) arg).directMethods;
319: throw new ConditionThrowable(new TypeError(arg, "class"));
320: }
321: };
322:
323: // ### %set-class-direct-methods
324: private static final Primitive2 _SET_CLASS_DIRECT_METHODS = new Primitive2(
325: "%set-class-direct-methods", PACKAGE_SYS, false) {
326: public LispObject execute(LispObject first, LispObject second)
327: throws ConditionThrowable {
328: if (first instanceof LispClass) {
329: ((LispClass) first).directMethods = second;
330: return second;
331: }
332: throw new ConditionThrowable(new TypeError(first, "class"));
333: }
334: };
335:
336: // ### classp
337: private static final Primitive1 CLASSP = new Primitive1("classp",
338: PACKAGE_EXT, true) {
339: public LispObject execute(LispObject arg) {
340: return arg instanceof LispClass ? T : NIL;
341: }
342: };
343: }
|