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

Last change on this file was 12756, checked in by astalla, 14 years ago

Simple slot-* support for structures.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 18.7 KB
Line 
1/*
2 * StructureObject.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves
5 * $Id: StructureObject.java 12756 2010-06-17 20:14:10Z astalla $
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    protected int getSlotIndex(LispObject slotName) {
157  LispObject effectiveSlots = structureClass.getSlotDefinitions();
158  LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
159  for (int i = 0; i < slots.length; i++) {
160      SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
161      LispObject candidateSlotName = slotDefinition.AREF(1);
162      if(slotName == candidateSlotName) {
163    return i;
164      }
165  }
166  return -1;
167    }
168
169  @Override
170  public LispObject SLOT_VALUE(LispObject slotName)
171  {
172    LispObject value;
173    final int index = getSlotIndex(slotName);
174    if (index >= 0) {
175        value = slots[index];
176    } else {
177  value = UNBOUND_VALUE;
178        value = Symbol.SLOT_UNBOUND.execute(structureClass, this, slotName);
179        LispThread.currentThread()._values = null;
180    }
181    return value;
182  }
183
184  public void setSlotValue(LispObject slotName, LispObject newValue) {
185      final int index = getSlotIndex(slotName);
186      if (index >= 0) {
187    slots[index] = newValue;
188      } else {
189    LispObject[] args = new LispObject[5];
190    args[0] = structureClass;
191    args[1] = this;
192    args[2] = slotName;
193    args[3] = Symbol.SETF;
194    args[4] = newValue;
195    Symbol.SLOT_MISSING.execute(args);
196      }
197  }
198
199  @Override
200  public LispObject getParts()
201  {
202    LispObject result = NIL;
203    result = result.push(new Cons("class", structureClass));
204    LispObject effectiveSlots = structureClass.getSlotDefinitions();
205    LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
206    Debug.assertTrue(effectiveSlotsArray.length == slots.length);
207    for (int i = 0; i < slots.length; i++)
208      {
209        SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
210        LispObject slotName = slotDefinition.AREF(1);
211        result = result.push(new Cons(slotName, slots[i]));
212      }
213    return result.nreverse();
214  }
215
216  @Override
217  public LispObject typep(LispObject type)
218  {
219    if (type instanceof StructureClass)
220      return memq(type, structureClass.getCPL()) ? T : NIL;
221    if (type == structureClass.getName())
222      return T;
223    if (type == Symbol.STRUCTURE_OBJECT)
224      return T;
225    if (type == BuiltInClass.STRUCTURE_OBJECT)
226      return T;
227    if (type instanceof Symbol)
228      {
229        LispClass c = LispClass.findClass((Symbol)type);
230        if (c != null)
231          return memq(c, structureClass.getCPL()) ? T : NIL;
232      }
233    return super.typep(type);
234  }
235
236  @Override
237  public boolean equalp(LispObject obj)
238  {
239    if (this == obj)
240      return true;
241    if (obj instanceof StructureObject)
242      {
243        StructureObject o = (StructureObject) obj;
244        if (structureClass != o.structureClass)
245          return false;
246        for (int i = 0; i < slots.length; i++)
247          {
248            if (!slots[i].equalp(o.slots[i]))
249              return false;
250          }
251        return true;
252      }
253    return false;
254  }
255
256  @Override
257  public LispObject getSlotValue_0()
258  {
259    try
260      {
261        return slots[0];
262      }
263    catch (ArrayIndexOutOfBoundsException e)
264      {
265        return badIndex(0);
266      }
267  }
268
269  @Override
270  public LispObject getSlotValue_1()
271  {
272    try
273      {
274        return slots[1];
275      }
276    catch (ArrayIndexOutOfBoundsException e)
277      {
278        return badIndex(1);
279      }
280  }
281
282  @Override
283  public LispObject getSlotValue_2()
284  {
285    try
286      {
287        return slots[2];
288      }
289    catch (ArrayIndexOutOfBoundsException e)
290      {
291        return badIndex(2);
292      }
293  }
294
295  @Override
296  public LispObject getSlotValue_3()
297  {
298    try
299      {
300        return slots[3];
301      }
302    catch (ArrayIndexOutOfBoundsException e)
303      {
304        return badIndex(3);
305      }
306  }
307
308  @Override
309  public LispObject getSlotValue(int index)
310  {
311    try
312      {
313        return slots[index];
314      }
315    catch (ArrayIndexOutOfBoundsException e)
316      {
317        return badIndex(index);
318      }
319  }
320
321  @Override
322  public int getFixnumSlotValue(int index)
323  {
324    try
325      {
326        return Fixnum.getValue(slots[index]);
327      }
328    catch (ArrayIndexOutOfBoundsException e)
329      {
330        badIndex(index);
331        // Not reached.
332        return 0;
333      }
334  }
335
336  @Override
337  public boolean getSlotValueAsBoolean(int index)
338  {
339    try
340      {
341        return slots[index] != NIL ? true : false;
342      }
343    catch (ArrayIndexOutOfBoundsException e)
344      {
345        badIndex(index);
346        // Not reached.
347        return false;
348      }
349  }
350
351  @Override
352  public void setSlotValue_0(LispObject value)
353
354  {
355    try
356      {
357        slots[0] = value;
358      }
359    catch (ArrayIndexOutOfBoundsException e)
360      {
361        badIndex(0);
362      }
363  }
364
365  @Override
366  public void setSlotValue_1(LispObject value)
367
368  {
369    try
370      {
371        slots[1] = value;
372      }
373    catch (ArrayIndexOutOfBoundsException e)
374      {
375        badIndex(1);
376      }
377  }
378
379  @Override
380  public void setSlotValue_2(LispObject value)
381
382  {
383    try
384      {
385        slots[2] = value;
386      }
387    catch (ArrayIndexOutOfBoundsException e)
388      {
389        badIndex(2);
390      }
391  }
392
393  @Override
394  public void setSlotValue_3(LispObject value)
395
396  {
397    try
398      {
399        slots[3] = value;
400      }
401    catch (ArrayIndexOutOfBoundsException e)
402      {
403        badIndex(3);
404      }
405  }
406
407  @Override
408  public void setSlotValue(int index, LispObject value)
409
410  {
411    try
412      {
413        slots[index] = value;
414      }
415    catch (ArrayIndexOutOfBoundsException e)
416      {
417        badIndex(index);
418      }
419  }
420
421  private LispObject badIndex(int n)
422  {
423    StringBuilder sb = new StringBuilder("Invalid slot index ");
424    sb.append(Fixnum.getInstance(n).writeToString());
425    sb.append(" for ");
426    sb.append(writeToString());
427    return error(new LispError(sb.toString()));
428  }
429
430  @Override
431  public final int psxhash()
432  {
433    return psxhash(4);
434  }
435
436  @Override
437  public final int psxhash(int depth)
438  {
439    int result = mix(structureClass.sxhash(), 7814971);
440    if (depth > 0)
441      {
442        int limit = slots.length;
443        if (limit > 4)
444          limit = 4;
445        for (int i = 0; i < limit; i++)
446          result = mix(slots[i].psxhash(depth - 1), result);
447      }
448    return result & 0x7fffffff;
449  }
450
451  @Override
452  public String writeToString()
453  {
454    try
455      {
456        final LispThread thread = LispThread.currentThread();
457        // FIXME
458        if (typep(Symbol.RESTART) != NIL)
459          {
460            Symbol PRINT_RESTART = PACKAGE_SYS.intern("PRINT-RESTART");
461            LispObject fun = PRINT_RESTART.getSymbolFunction();
462            StringOutputStream stream = new StringOutputStream();
463            thread.execute(fun, this, stream);
464            return stream.getString().getStringValue();
465          }
466        if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL)
467          return unreadableString(structureClass.getName().writeToString());
468        int maxLevel = Integer.MAX_VALUE;
469        LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread);
470        if (printLevel instanceof Fixnum)
471          maxLevel = ((Fixnum)printLevel).value;
472        LispObject currentPrintLevel =
473          _CURRENT_PRINT_LEVEL_.symbolValue(thread);
474        int currentLevel = Fixnum.getValue(currentPrintLevel);
475        if (currentLevel >= maxLevel && slots.length > 0)
476          return "#";
477        StringBuilder sb = new StringBuilder("#S(");
478        sb.append(structureClass.getName().writeToString());
479        if (currentLevel < maxLevel)
480          {
481            LispObject effectiveSlots = structureClass.getSlotDefinitions();
482            LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
483            Debug.assertTrue(effectiveSlotsArray.length == slots.length);
484            final LispObject printLength = Symbol.PRINT_LENGTH.symbolValue(thread);
485            final int limit;
486            if (printLength instanceof Fixnum)
487              limit = Math.min(slots.length, ((Fixnum)printLength).value);
488            else
489              limit = slots.length;
490            final boolean printCircle =
491              (Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL);
492            for (int i = 0; i < limit; i++)
493              {
494                sb.append(' ');
495                SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
496                // FIXME AREF(1)
497                LispObject slotName = slotDefinition.AREF(1);
498                Debug.assertTrue(slotName instanceof Symbol);
499                sb.append(':');
500                sb.append(((Symbol)slotName).name.getStringValue());
501                sb.append(' ');
502                if (printCircle)
503                  {
504                    StringOutputStream stream = new StringOutputStream();
505                    thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(),
506                                   slots[i], stream);
507                    sb.append(stream.getString().getStringValue());
508                  }
509                else
510                  sb.append(slots[i].writeToString());
511              }
512            if (limit < slots.length)
513              sb.append(" ...");
514          }
515        sb.append(')');
516        return sb.toString();
517      }
518    catch (StackOverflowError e)
519      {
520        error(new StorageCondition("Stack overflow."));
521        return null; // Not reached.
522      }
523  }
524
525  // ### structure-object-p object => generalized-boolean
526  private static final Primitive STRUCTURE_OBJECT_P =
527    new Primitive("structure-object-p", PACKAGE_SYS, true, "object")
528    {
529      @Override
530      public LispObject execute(LispObject arg)
531      {
532        return arg instanceof StructureObject ? T : NIL;
533      }
534    };
535
536  // ### structure-length instance => length
537  private static final Primitive STRUCTURE_LENGTH =
538    new Primitive("structure-length", PACKAGE_SYS, true, "instance")
539    {
540      @Override
541      public LispObject execute(LispObject arg)
542      {
543          if (arg instanceof StructureObject)
544            return Fixnum.getInstance(((StructureObject)arg).slots.length);
545        return type_error(arg, Symbol.STRUCTURE_OBJECT);
546      }
547    };
548
549  // ### structure-ref instance index => value
550  private static final Primitive STRUCTURE_REF =
551    new Primitive("structure-ref", PACKAGE_SYS, true)
552    {
553      @Override
554      public LispObject execute(LispObject first, LispObject second)
555
556      {
557    if (first instanceof StructureObject)
558        try
559          {
560            return ((StructureObject)first).slots[Fixnum.getValue(second)];
561          }
562        catch (ArrayIndexOutOfBoundsException e)
563          {
564            // Shouldn't happen.
565            return error(new LispError("Internal error."));
566          }     
567      return type_error(first, Symbol.STRUCTURE_OBJECT);
568      }
569    };
570
571  // ### structure-set instance index new-value => new-value
572  private static final Primitive STRUCTURE_SET =
573    new Primitive("structure-set", PACKAGE_SYS, true)
574    {
575      @Override
576      public LispObject execute(LispObject first, LispObject second,
577                                LispObject third)
578
579      {
580         
581            if (first instanceof StructureObject)
582                try
583                  {
584                    ((StructureObject)first).slots[Fixnum.getValue(second)] = third;
585                    return third;
586                  }
587                catch (ArrayIndexOutOfBoundsException e)
588                  {
589                    // Shouldn't happen.
590                    return error(new LispError("Internal error."));
591                  }     
592              return type_error(first, Symbol.STRUCTURE_OBJECT);
593              }     
594    };
595
596  // ### make-structure
597  private static final Primitive MAKE_STRUCTURE =
598    new Primitive("make-structure", PACKAGE_SYS, true)
599    {
600      @Override
601      public LispObject execute(LispObject first, LispObject second)
602
603      {
604          return new StructureObject(checkSymbol(first), second);
605      }
606      @Override
607      public LispObject execute(LispObject first, LispObject second,
608                                LispObject third)
609
610      {
611          return new StructureObject(checkSymbol(first), second, third);
612      }
613      @Override
614      public LispObject execute(LispObject first, LispObject second,
615                                LispObject third, LispObject fourth)
616
617      {
618          return new StructureObject(checkSymbol(first), second, third, fourth);
619      }
620      @Override
621      public LispObject execute(LispObject first, LispObject second,
622                                LispObject third, LispObject fourth,
623                                LispObject fifth)
624
625      {
626          return new StructureObject(checkSymbol(first), second, third, fourth,
627                  fifth);
628      }
629      @Override
630      public LispObject execute(LispObject first, LispObject second,
631                                LispObject third, LispObject fourth,
632                                LispObject fifth, LispObject sixth)
633
634      {
635          return new StructureObject(checkSymbol(first), second, third, fourth,
636                  fifth, sixth);
637      }
638      @Override
639      public LispObject execute(LispObject first, LispObject second,
640                                LispObject third, LispObject fourth,
641                                LispObject fifth, LispObject sixth,
642                                LispObject seventh)
643
644      {
645          return new StructureObject(checkSymbol(first), second, third, fourth,
646                  fifth, sixth, seventh);
647      }
648    };
649
650  // ### %make-structure name slot-values => object
651  private static final Primitive _MAKE_STRUCTURE =
652    new Primitive("%make-structure", PACKAGE_SYS, true)
653    {
654      @Override
655      public LispObject execute(LispObject first, LispObject second)
656
657      {
658          return new StructureObject(checkSymbol(first), second.copyToArray());
659      }
660    };
661
662  // ### copy-structure structure => copy
663  private static final Primitive COPY_STRUCTURE =
664    new Primitive(Symbol.COPY_STRUCTURE, "structure")
665    {
666      @Override
667      public LispObject execute(LispObject arg)
668      {
669          if (arg instanceof StructureObject)
670            return new StructureObject((StructureObject)arg);
671          return type_error(arg, Symbol.STRUCTURE_OBJECT);
672      }
673    };
674}
Note: See TracBrowser for help on using the repository browser.