source: branches/0.17.x/abcl/src/org/armedbear/lisp/StructureObject.java

Last change on this file was 12254, checked in by ehuelsmann, 16 years ago

Remove 'throws ConditionThrowable?' method annotations:

it's an unchecked exception now, so no need to declare it thrown.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 17.0 KB
Line 
1/*
2 * StructureObject.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves
5 * $Id: StructureObject.java 12254 2009-11-06 20:07:54Z ehuelsmann $
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
34package org.armedbear.lisp;
35
36public final class StructureObject extends LispObject
37{
38  private final StructureClass structureClass;
39  private final LispObject[] slots;
40
41  public StructureObject(Symbol symbol, LispObject[] slots)
42
43  {
44    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
45    this.slots = slots;
46  }
47
48  public StructureObject(Symbol symbol, LispObject obj0)
49
50  {
51    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
52    LispObject[] slots = new LispObject[1];
53    slots[0] = obj0;
54    this.slots = slots;
55  }
56
57  public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1)
58
59  {
60    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
61    LispObject[] slots = new LispObject[2];
62    slots[0] = obj0;
63    slots[1] = obj1;
64    this.slots = slots;
65  }
66
67  public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1,
68                         LispObject obj2)
69
70  {
71    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
72    LispObject[] slots = new LispObject[3];
73    slots[0] = obj0;
74    slots[1] = obj1;
75    slots[2] = obj2;
76    this.slots = slots;
77  }
78
79  public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1,
80                         LispObject obj2, LispObject obj3)
81
82  {
83    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
84    LispObject[] slots = new LispObject[4];
85    slots[0] = obj0;
86    slots[1] = obj1;
87    slots[2] = obj2;
88    slots[3] = obj3;
89    this.slots = slots;
90  }
91
92  public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1,
93                         LispObject obj2, LispObject obj3, LispObject obj4)
94
95  {
96    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
97    LispObject[] slots = new LispObject[5];
98    slots[0] = obj0;
99    slots[1] = obj1;
100    slots[2] = obj2;
101    slots[3] = obj3;
102    slots[4] = obj4;
103    this.slots = slots;
104  }
105
106  public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1,
107                         LispObject obj2, LispObject obj3, LispObject obj4,
108                         LispObject obj5)
109
110  {
111    structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null.
112    LispObject[] slots = new LispObject[6];
113    slots[0] = obj0;
114    slots[1] = obj1;
115    slots[2] = obj2;
116    slots[3] = obj3;
117    slots[4] = obj4;
118    slots[5] = obj5;
119    this.slots = slots;
120  }
121
122  public StructureObject(StructureObject obj)
123  {
124    this.structureClass = obj.structureClass;
125    slots = new LispObject[obj.slots.length];
126    for (int i = slots.length; i-- > 0;)
127      slots[i] = obj.slots[i];
128  }
129
130  @Override
131  public LispObject typeOf()
132  {
133    return structureClass.getSymbol();
134  }
135
136  @Override
137  public LispObject classOf()
138  {
139    return structureClass;
140  }
141
142  @Override
143  public LispObject getParts()
144  {
145    LispObject result = NIL;
146    result = result.push(new Cons("class", structureClass));
147    LispObject effectiveSlots = structureClass.getSlotDefinitions();
148    LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
149    Debug.assertTrue(effectiveSlotsArray.length == slots.length);
150    for (int i = 0; i < slots.length; i++)
151      {
152        SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
153        LispObject slotName = slotDefinition.AREF(1);
154        result = result.push(new Cons(slotName, slots[i]));
155      }
156    return result.nreverse();
157  }
158
159  @Override
160  public LispObject typep(LispObject type)
161  {
162    if (type instanceof StructureClass)
163      return memq(type, structureClass.getCPL()) ? T : NIL;
164    if (type == structureClass.getSymbol())
165      return T;
166    if (type == Symbol.STRUCTURE_OBJECT)
167      return T;
168    if (type == BuiltInClass.STRUCTURE_OBJECT)
169      return T;
170    if (type instanceof Symbol)
171      {
172        LispClass c = LispClass.findClass((Symbol)type);
173        if (c != null)
174          return memq(c, structureClass.getCPL()) ? T : NIL;
175      }
176    return super.typep(type);
177  }
178
179  @Override
180  public boolean equalp(LispObject obj)
181  {
182    if (this == obj)
183      return true;
184    if (obj instanceof StructureObject)
185      {
186        StructureObject o = (StructureObject) obj;
187        if (structureClass != o.structureClass)
188          return false;
189        for (int i = 0; i < slots.length; i++)
190          {
191            if (!slots[i].equalp(o.slots[i]))
192              return false;
193          }
194        return true;
195      }
196    return false;
197  }
198
199  @Override
200  public LispObject getSlotValue_0()
201  {
202    try
203      {
204        return slots[0];
205      }
206    catch (ArrayIndexOutOfBoundsException e)
207      {
208        return badIndex(0);
209      }
210  }
211
212  @Override
213  public LispObject getSlotValue_1()
214  {
215    try
216      {
217        return slots[1];
218      }
219    catch (ArrayIndexOutOfBoundsException e)
220      {
221        return badIndex(1);
222      }
223  }
224
225  @Override
226  public LispObject getSlotValue_2()
227  {
228    try
229      {
230        return slots[2];
231      }
232    catch (ArrayIndexOutOfBoundsException e)
233      {
234        return badIndex(2);
235      }
236  }
237
238  @Override
239  public LispObject getSlotValue_3()
240  {
241    try
242      {
243        return slots[3];
244      }
245    catch (ArrayIndexOutOfBoundsException e)
246      {
247        return badIndex(3);
248      }
249  }
250
251  @Override
252  public LispObject getSlotValue(int index)
253  {
254    try
255      {
256        return slots[index];
257      }
258    catch (ArrayIndexOutOfBoundsException e)
259      {
260        return badIndex(index);
261      }
262  }
263
264  @Override
265  public int getFixnumSlotValue(int index)
266  {
267    try
268      {
269        return Fixnum.getValue(slots[index]);
270      }
271    catch (ArrayIndexOutOfBoundsException e)
272      {
273        badIndex(index);
274        // Not reached.
275        return 0;
276      }
277  }
278
279  @Override
280  public boolean getSlotValueAsBoolean(int index)
281  {
282    try
283      {
284        return slots[index] != NIL ? true : false;
285      }
286    catch (ArrayIndexOutOfBoundsException e)
287      {
288        badIndex(index);
289        // Not reached.
290        return false;
291      }
292  }
293
294  @Override
295  public void setSlotValue_0(LispObject value)
296
297  {
298    try
299      {
300        slots[0] = value;
301      }
302    catch (ArrayIndexOutOfBoundsException e)
303      {
304        badIndex(0);
305      }
306  }
307
308  @Override
309  public void setSlotValue_1(LispObject value)
310
311  {
312    try
313      {
314        slots[1] = value;
315      }
316    catch (ArrayIndexOutOfBoundsException e)
317      {
318        badIndex(1);
319      }
320  }
321
322  @Override
323  public void setSlotValue_2(LispObject value)
324
325  {
326    try
327      {
328        slots[2] = value;
329      }
330    catch (ArrayIndexOutOfBoundsException e)
331      {
332        badIndex(2);
333      }
334  }
335
336  @Override
337  public void setSlotValue_3(LispObject value)
338
339  {
340    try
341      {
342        slots[3] = value;
343      }
344    catch (ArrayIndexOutOfBoundsException e)
345      {
346        badIndex(3);
347      }
348  }
349
350  @Override
351  public void setSlotValue(int index, LispObject value)
352
353  {
354    try
355      {
356        slots[index] = value;
357      }
358    catch (ArrayIndexOutOfBoundsException e)
359      {
360        badIndex(index);
361      }
362  }
363
364  private LispObject badIndex(int n)
365  {
366    FastStringBuffer sb = new FastStringBuffer("Invalid slot index ");
367    sb.append(Fixnum.getInstance(n).writeToString());
368    sb.append(" for ");
369    sb.append(writeToString());
370    return error(new LispError(sb.toString()));
371  }
372
373  @Override
374  public final int psxhash()
375  {
376    return psxhash(4);
377  }
378
379  @Override
380  public final int psxhash(int depth)
381  {
382    int result = mix(structureClass.sxhash(), 7814971);
383    if (depth > 0)
384      {
385        int limit = slots.length;
386        if (limit > 4)
387          limit = 4;
388        for (int i = 0; i < limit; i++)
389          result = mix(slots[i].psxhash(depth - 1), result);
390      }
391    return result & 0x7fffffff;
392  }
393
394  @Override
395  public String writeToString()
396  {
397    try
398      {
399        final LispThread thread = LispThread.currentThread();
400        // FIXME
401        if (typep(Symbol.RESTART) != NIL)
402          {
403            Symbol PRINT_RESTART = PACKAGE_SYS.intern("PRINT-RESTART");
404            LispObject fun = PRINT_RESTART.getSymbolFunction();
405            StringOutputStream stream = new StringOutputStream();
406            thread.execute(fun, this, stream);
407            return stream.getString().getStringValue();
408          }
409        if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL)
410          return unreadableString(structureClass.getSymbol().writeToString());
411        int maxLevel = Integer.MAX_VALUE;
412        LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread);
413        if (printLevel instanceof Fixnum)
414          maxLevel = ((Fixnum)printLevel).value;
415        LispObject currentPrintLevel =
416          _CURRENT_PRINT_LEVEL_.symbolValue(thread);
417        int currentLevel = Fixnum.getValue(currentPrintLevel);
418        if (currentLevel >= maxLevel && slots.length > 0)
419          return "#";
420        FastStringBuffer sb = new FastStringBuffer("#S(");
421        sb.append(structureClass.getSymbol().writeToString());
422        if (currentLevel < maxLevel)
423          {
424            LispObject effectiveSlots = structureClass.getSlotDefinitions();
425            LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
426            Debug.assertTrue(effectiveSlotsArray.length == slots.length);
427            final LispObject printLength = Symbol.PRINT_LENGTH.symbolValue(thread);
428            final int limit;
429            if (printLength instanceof Fixnum)
430              limit = Math.min(slots.length, ((Fixnum)printLength).value);
431            else
432              limit = slots.length;
433            final boolean printCircle =
434              (Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL);
435            for (int i = 0; i < limit; i++)
436              {
437                sb.append(' ');
438                SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
439                // FIXME AREF(1)
440                LispObject slotName = slotDefinition.AREF(1);
441                Debug.assertTrue(slotName instanceof Symbol);
442                sb.append(':');
443                sb.append(((Symbol)slotName).name.getStringValue());
444                sb.append(' ');
445                if (printCircle)
446                  {
447                    StringOutputStream stream = new StringOutputStream();
448                    thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(),
449                                   slots[i], stream);
450                    sb.append(stream.getString().getStringValue());
451                  }
452                else
453                  sb.append(slots[i].writeToString());
454              }
455            if (limit < slots.length)
456              sb.append(" ...");
457          }
458        sb.append(')');
459        return sb.toString();
460      }
461    catch (StackOverflowError e)
462      {
463        error(new StorageCondition("Stack overflow."));
464        return null; // Not reached.
465      }
466  }
467
468  // ### structure-object-p object => generalized-boolean
469  private static final Primitive STRUCTURE_OBJECT_P =
470    new Primitive("structure-object-p", PACKAGE_SYS, true, "object")
471    {
472      @Override
473      public LispObject execute(LispObject arg)
474      {
475        return arg instanceof StructureObject ? T : NIL;
476      }
477    };
478
479  // ### structure-length instance => length
480  private static final Primitive STRUCTURE_LENGTH =
481    new Primitive("structure-length", PACKAGE_SYS, true, "instance")
482    {
483      @Override
484      public LispObject execute(LispObject arg)
485      {
486          if (arg instanceof StructureObject)
487            return Fixnum.getInstance(((StructureObject)arg).slots.length);
488        return type_error(arg, Symbol.STRUCTURE_OBJECT);
489      }
490    };
491
492  // ### structure-ref instance index => value
493  private static final Primitive STRUCTURE_REF =
494    new Primitive("structure-ref", PACKAGE_SYS, true)
495    {
496      @Override
497      public LispObject execute(LispObject first, LispObject second)
498
499      {
500    if (first instanceof StructureObject)
501        try
502          {
503            return ((StructureObject)first).slots[Fixnum.getValue(second)];
504          }
505        catch (ArrayIndexOutOfBoundsException e)
506          {
507            // Shouldn't happen.
508            return error(new LispError("Internal error."));
509          }     
510      return type_error(first, Symbol.STRUCTURE_OBJECT);
511      }
512    };
513
514  // ### structure-set instance index new-value => new-value
515  private static final Primitive STRUCTURE_SET =
516    new Primitive("structure-set", PACKAGE_SYS, true)
517    {
518      @Override
519      public LispObject execute(LispObject first, LispObject second,
520                                LispObject third)
521
522      {
523         
524            if (first instanceof StructureObject)
525                try
526                  {
527                    ((StructureObject)first).slots[Fixnum.getValue(second)] = third;
528                    return third;
529                  }
530                catch (ArrayIndexOutOfBoundsException e)
531                  {
532                    // Shouldn't happen.
533                    return error(new LispError("Internal error."));
534                  }     
535              return type_error(first, Symbol.STRUCTURE_OBJECT);
536              }     
537    };
538
539  // ### make-structure
540  private static final Primitive MAKE_STRUCTURE =
541    new Primitive("make-structure", PACKAGE_SYS, true)
542    {
543      @Override
544      public LispObject execute(LispObject first, LispObject second)
545
546      {
547          return new StructureObject(checkSymbol(first), second);
548      }
549      @Override
550      public LispObject execute(LispObject first, LispObject second,
551                                LispObject third)
552
553      {
554          return new StructureObject(checkSymbol(first), second, third);
555      }
556      @Override
557      public LispObject execute(LispObject first, LispObject second,
558                                LispObject third, LispObject fourth)
559
560      {
561          return new StructureObject(checkSymbol(first), second, third, fourth);
562      }
563      @Override
564      public LispObject execute(LispObject first, LispObject second,
565                                LispObject third, LispObject fourth,
566                                LispObject fifth)
567
568      {
569          return new StructureObject(checkSymbol(first), second, third, fourth,
570                  fifth);
571      }
572      @Override
573      public LispObject execute(LispObject first, LispObject second,
574                                LispObject third, LispObject fourth,
575                                LispObject fifth, LispObject sixth)
576
577      {
578          return new StructureObject(checkSymbol(first), second, third, fourth,
579                  fifth, sixth);
580      }
581      @Override
582      public LispObject execute(LispObject first, LispObject second,
583                                LispObject third, LispObject fourth,
584                                LispObject fifth, LispObject sixth,
585                                LispObject seventh)
586
587      {
588          return new StructureObject(checkSymbol(first), second, third, fourth,
589                  fifth, sixth, seventh);
590      }
591    };
592
593  // ### %make-structure name slot-values => object
594  private static final Primitive _MAKE_STRUCTURE =
595    new Primitive("%make-structure", PACKAGE_SYS, true)
596    {
597      @Override
598      public LispObject execute(LispObject first, LispObject second)
599
600      {
601          return new StructureObject(checkSymbol(first), second.copyToArray());
602      }
603    };
604
605  // ### copy-structure structure => copy
606  private static final Primitive COPY_STRUCTURE =
607    new Primitive(Symbol.COPY_STRUCTURE, "structure")
608    {
609      @Override
610      public LispObject execute(LispObject arg)
611      {
612          if (arg instanceof StructureObject)
613            return new StructureObject((StructureObject)arg);
614          return type_error(arg, Symbol.STRUCTURE_OBJECT);
615      }
616    };
617}
Note: See TracBrowser for help on using the repository browser.