001: /*
002: * StructureObject.java
003: *
004: * Copyright (C) 2003 Peter Graves
005: * $Id: StructureObject.java,v 1.6 2003/11/15 11:03:32 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: public final class StructureObject extends LispObject {
025: private final LispClass structureClass;
026: private final LispObject[] slots;
027:
028: public StructureObject(Symbol symbol, LispObject list)
029: throws ConditionThrowable {
030: structureClass = LispClass.findClass(symbol); // Might return null.
031: Debug.assertTrue(structureClass instanceof StructureClass);
032: slots = list.copyToArray();
033: }
034:
035: public StructureObject(StructureObject obj) {
036: this .structureClass = obj.structureClass;
037: slots = new LispObject[obj.slots.length];
038: for (int i = slots.length; i-- > 0;)
039: slots[i] = obj.slots[i];
040: }
041:
042: public LispObject typeOf() {
043: return structureClass.getSymbol();
044: }
045:
046: public LispClass classOf() {
047: return structureClass;
048: }
049:
050: public LispObject typep(LispObject type) throws ConditionThrowable {
051: if (type instanceof StructureClass)
052: return type == structureClass ? T : NIL; // FIXME Could be a superclass.
053: if (type == structureClass.getSymbol())
054: return T;
055: if (type == Symbol.STRUCTURE_OBJECT)
056: return T;
057: if (type == BuiltInClass.STRUCTURE_OBJECT)
058: return T;
059: return super .typep(type);
060: }
061:
062: public String toString() {
063: StringBuffer sb = new StringBuffer("#S(");
064: sb.append(structureClass.getSymbol());
065: // FIXME Use *PRINT-LENGTH*.
066: final int limit = Math.min(slots.length, 10);
067: for (int i = 0; i < limit; i++) {
068: sb.append(' ');
069: sb.append(slots[i]);
070: }
071: if (limit < slots.length)
072: sb.append(" ...");
073: sb.append(')');
074: return sb.toString();
075: }
076:
077: // ### %structure-ref
078: // %structure-ref instance index => value
079: private static final Primitive2 _STRUCTURE_REF = new Primitive2(
080: "%structure-ref", PACKAGE_SYS, false) {
081: public LispObject execute(LispObject first, LispObject second)
082: throws ConditionThrowable {
083: try {
084: return ((StructureObject) first).slots[((Fixnum) second)
085: .getValue()];
086: } catch (ClassCastException e) {
087: throw new ConditionThrowable(new TypeError());
088: } catch (ArrayIndexOutOfBoundsException e) {
089: // Shouldn't happen.
090: throw new ConditionThrowable(new LispError(
091: "internal error"));
092: }
093: }
094: };
095:
096: private static final Primitive1 _STRUCTURE_REF_0 = new Primitive1(
097: "%structure-ref-0", PACKAGE_SYS, false) {
098: public LispObject execute(LispObject arg)
099: throws ConditionThrowable {
100: try {
101: return ((StructureObject) arg).slots[0];
102: } catch (ClassCastException e) {
103: throw new ConditionThrowable(new TypeError());
104: } catch (ArrayIndexOutOfBoundsException e) {
105: // Shouldn't happen.
106: throw new ConditionThrowable(new LispError(
107: "internal error"));
108: }
109: }
110: };
111:
112: private static final Primitive1 _STRUCTURE_REF_1 = new Primitive1(
113: "%structure-ref-1", PACKAGE_SYS, false) {
114: public LispObject execute(LispObject arg)
115: throws ConditionThrowable {
116: try {
117: return ((StructureObject) arg).slots[1];
118: } catch (ClassCastException e) {
119: throw new ConditionThrowable(new TypeError());
120: } catch (ArrayIndexOutOfBoundsException e) {
121: // Shouldn't happen.
122: throw new ConditionThrowable(new LispError(
123: "internal error"));
124: }
125: }
126: };
127:
128: private static final Primitive1 _STRUCTURE_REF_2 = new Primitive1(
129: "%structure-ref-2", PACKAGE_SYS, false) {
130: public LispObject execute(LispObject arg)
131: throws ConditionThrowable {
132: try {
133: return ((StructureObject) arg).slots[2];
134: } catch (ClassCastException e) {
135: throw new ConditionThrowable(new TypeError());
136: } catch (ArrayIndexOutOfBoundsException e) {
137: // Shouldn't happen.
138: throw new ConditionThrowable(new LispError(
139: "internal error"));
140: }
141: }
142: };
143:
144: // ### %structure-set
145: // %structure-set instance index new-value => new-value
146: private static final Primitive3 _STRUCTURE_SET = new Primitive3(
147: "%structure-set", PACKAGE_SYS, false) {
148: public LispObject execute(LispObject first, LispObject second,
149: LispObject third) throws ConditionThrowable {
150: try {
151: ((StructureObject) first).slots[((Fixnum) second)
152: .getValue()] = third;
153: return third;
154: } catch (ClassCastException e) {
155: throw new ConditionThrowable(new TypeError());
156: } catch (ArrayIndexOutOfBoundsException e) {
157: // Shouldn't happen.
158: throw new ConditionThrowable(new LispError(
159: "internal error"));
160: }
161: }
162: };
163:
164: private static final Primitive1 _STRUCTURE_SET_0 = new Primitive1(
165: "%structure-set-0", PACKAGE_SYS, false) {
166: public LispObject execute(LispObject first, LispObject second)
167: throws ConditionThrowable {
168: try {
169: ((StructureObject) first).slots[0] = second;
170: return second;
171: } catch (ClassCastException e) {
172: throw new ConditionThrowable(new TypeError());
173: } catch (ArrayIndexOutOfBoundsException e) {
174: // Shouldn't happen.
175: throw new ConditionThrowable(new LispError(
176: "internal error"));
177: }
178: }
179: };
180:
181: private static final Primitive1 _STRUCTURE_SET_1 = new Primitive1(
182: "%structure-set-1", PACKAGE_SYS, false) {
183: public LispObject execute(LispObject first, LispObject second)
184: throws ConditionThrowable {
185: try {
186: ((StructureObject) first).slots[1] = second;
187: return second;
188: } catch (ClassCastException e) {
189: throw new ConditionThrowable(new TypeError());
190: } catch (ArrayIndexOutOfBoundsException e) {
191: // Shouldn't happen.
192: throw new ConditionThrowable(new LispError(
193: "internal error"));
194: }
195: }
196: };
197:
198: private static final Primitive1 _STRUCTURE_SET_2 = new Primitive1(
199: "%structure-set-2", PACKAGE_SYS, false) {
200: public LispObject execute(LispObject first, LispObject second)
201: throws ConditionThrowable {
202: try {
203: ((StructureObject) first).slots[2] = second;
204: return second;
205: } catch (ClassCastException e) {
206: throw new ConditionThrowable(new TypeError());
207: } catch (ArrayIndexOutOfBoundsException e) {
208: // Shouldn't happen.
209: throw new ConditionThrowable(new LispError(
210: "internal error"));
211: }
212: }
213: };
214:
215: // ### %make-structure
216: // %make-structure name slot-values => object
217: private static final Primitive2 _MAKE_STRUCTURE = new Primitive2(
218: "%make-structure", PACKAGE_SYS, false) {
219: public LispObject execute(LispObject first, LispObject second)
220: throws ConditionThrowable {
221: return new StructureObject(checkSymbol(first),
222: checkList(second));
223: }
224: };
225:
226: // ### copy-structure
227: // copy-structure structure => copy
228: private static final Primitive1 COPY_STRUCTURE = new Primitive1(
229: "copy-structure") {
230: public LispObject execute(LispObject arg)
231: throws ConditionThrowable {
232: try {
233: return new StructureObject((StructureObject) arg);
234: } catch (ClassCastException e) {
235: throw new ConditionThrowable(new TypeError(arg,
236: "STRUCTURE-OBJECT"));
237: }
238: }
239: };
240: }
|