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

Last change on this file was 15761, checked in by Mark Evenson, 5 months ago

Differentiate STORAGE-CONDITION causes

A STORAGE-CONDITION may be signalled because of various causes which
we differentiate by unique messages as debugging them can be rather
mysterious.

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