source: trunk/abcl/src/org/armedbear/lisp/StructureObject.java @ 12559

Last change on this file since 12559 was 12513, checked in by ehuelsmann, 15 years ago

Remove 'private' keyword to eliminate the Java requirement

for the compiler to generate synthetic accessors: functions that
don't appear in the source but do appear in the class file.

Patch by: Douglas Miles <dmiles _at_ users.sf.net>

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