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

/*
 * StandardObject.java
 *
 * Copyright (C) 2003-2006 Peter Graves
 * $Id: StandardObject.java 15741 2023-11-11 11:51:41Z mevenson $
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 *
 * As a special exception, the copyright holders of this library give you
 * permission to link this library with independent modules to produce an
 * executable, regardless of the license terms of these independent
 * modules, and to copy and distribute the resulting executable under
 * terms of your choice, provided that you also meet, for each linked
 * independent module, the terms and conditions of the license of that
 * module.  An independent module is a module which is not derived from
 * or based on this library.  If you modify this library, you may extend
 * this exception to your version of the library, but you are not
 * obligated to do so.  If you do not wish to do so, delete this
 * exception statement from your version.
 */

package org.armedbear.lisp;

import static org.armedbear.lisp.Lisp.*;

public class StandardObject extends LispObject
{
  protected Layout layout;
  protected LispObject[] slots;

  protected StandardObject()
  {
    layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL);
  }


  protected StandardObject(Layout layout)
  {
    this(layout, layout.getLength());
  }

  protected StandardObject(Layout layout, int length)
  {
    this.layout = layout;
    slots = new LispObject[length];
    for (int i = slots.length; i-- > 0;)
      slots[i] = UNBOUND_VALUE;
  }


  protected StandardObject(LispClass cls, int length)
  {
    layout = cls == null ? null : cls.getClassLayout();
    slots = new LispObject[length];
    for (int i = slots.length; i-- > 0;)
      slots[i] = UNBOUND_VALUE;
  }

  protected StandardObject(LispClass cls)
  {
    layout = cls == null ? null : cls.getClassLayout();
    slots = new LispObject[layout == null ? 0 : layout.getLength()];
    for (int i = slots.length; i-- > 0;)
      slots[i] = UNBOUND_VALUE;
  }

  @Override
  public LispObject getParts()
  {
    LispObject parts = NIL;
    if (layout != null)
      {
        if (layout.isInvalid())
          {
            // Update instance.
            layout = updateLayout();
          }
      }
    parts = parts.push(new Cons("LAYOUT", layout));
    if (layout != null)
      {
        LispObject[] slotNames = layout.getSlotNames();
        if (slotNames != null)
          {
            for (int i = 0; i < slotNames.length; i++)
              {
                parts = parts.push(new Cons(slotNames[i], slots[i]));
              }
          }
      }
    return parts.nreverse();
  }

  public final LispObject getLispClass()
  {
    return layout.getLispClass();
  }

  private LispObject helperGetClassName()
  {
    final LispObject c1 = layout.getLispClass();
    if (c1 instanceof LispClass)
        return ((LispClass)c1).getName();
    else
        return LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);
  }

  private LispObject helperGetCPL()
  {
    final LispObject c1 = layout.getLispClass();
    if (c1 instanceof LispClass)
        return ((LispClass)c1).getCPL();
    else
        return LispThread.currentThread().execute(Symbol.CLASS_PRECEDENCE_LIST, c1);
  }

  @Override
  public LispObject typeOf()
  {
    // "For objects of metaclass STRUCTURE-CLASS or STANDARD-CLASS, and for
    // conditions, TYPE-OF returns the proper name of the class returned by
    // CLASS-OF if it has a proper name, and otherwise returns the class
    // itself."
    final LispObject c1 = layout.getLispClass();
    LispObject name;
    if (c1 instanceof LispClass)
        name = ((LispClass)c1).getName();
    else
        name = LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);

    // The proper name of a class is "a symbol that names the class whose
    // name is that symbol".
    if (name != NIL && name != UNBOUND_VALUE)
      {
        // TYPE-OF.9
        final LispObject c2 = LispClass.findClass(name, false);
        if (c2 == c1)
          return name;
      }
    return c1;
  }

  @Override
  public LispObject classOf()
  {
    return layout.getLispClass();
  }

  @Override
  public LispObject typep(LispObject type)
  {
    if (type == Symbol.STANDARD_OBJECT)
      return T;
    if (type == StandardClass.STANDARD_OBJECT)
      return T;
    LispObject cls = layout != null ? layout.getLispClass() : null;
    if (cls != null)
      {
        if (type == cls)
          return T;
        if (type == helperGetClassName())
          return T;
        LispObject cpl = helperGetCPL();
        while (cpl != NIL)
          {
            if (type == cpl.car())
              return T;

            LispObject otherName;
            LispObject otherClass = cpl.car();
            if (otherClass instanceof LispClass) {
              if (type == ((LispClass)otherClass).getName())
                return T;
            }
            else
            if (type == LispThread
                .currentThread().execute(Symbol.CLASS_NAME, otherClass))
                return T;

            cpl = cpl.cdr();
          }
      }
    return super.typep(type);
  }

  @Override
  public String printObject()
  {
    final LispThread thread = LispThread.currentThread();
    int maxLevel = Integer.MAX_VALUE;
    LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread);
    if (printLevel instanceof Fixnum)
      maxLevel = ((Fixnum)printLevel).value;
    LispObject currentPrintLevel =
      _CURRENT_PRINT_LEVEL_.symbolValue(thread);
    int currentLevel = Fixnum.getValue(currentPrintLevel);
    if (currentLevel >= maxLevel)
      return "#";
    return unreadableString(typeOf().printObject());
  }

  synchronized Layout updateLayout()
  {
    if (!layout.isInvalid()) return layout;
    Layout oldLayout = layout;
    LispObject cls = oldLayout.getLispClass();
    Layout newLayout;

    if (cls instanceof LispClass)
        newLayout = ((LispClass)cls).getClassLayout();
    else
        newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls);

    Debug.assertTrue(!newLayout.isInvalid());
    StandardObject newInstance = new StandardObject(newLayout);
    Debug.assertTrue(newInstance.layout == newLayout);
    LispObject added = NIL;
    LispObject discarded = NIL;
    LispObject plist = NIL;
    // Old local slots.
    LispObject[] oldSlotNames = oldLayout.getSlotNames();
    for (int i = 0; i < oldSlotNames.length; i++)
      {
        LispObject slotName = oldSlotNames[i];
        int j = newLayout.getSlotIndex(slotName);
        if (j >= 0)
          newInstance.slots[j] = slots[i];
        else
          {
            discarded = discarded.push(slotName);
            if (slots[i] != UNBOUND_VALUE)
              {
                plist = plist.push(slots[i]);
                plist = plist.push(slotName);
              }
          }
      }
    // Old shared slots.
    LispObject rest = oldLayout.getSharedSlots(); // A list.
    if (rest != null)
      {
        while (rest != NIL)
          {
            LispObject location = rest.car();
            LispObject slotName = location.car();
            int i = newLayout.getSlotIndex(slotName);
            if (i >= 0)
              newInstance.slots[i] = location.cdr();
            rest = rest.cdr();
          }
      }
    // Go through all the new local slots to compute the added slots.
    LispObject[] newSlotNames = newLayout.getSlotNames();
    for (int i = 0; i < newSlotNames.length; i++)
      {
        LispObject slotName = newSlotNames[i];
        int j = oldLayout.getSlotIndex(slotName);
        if (j >= 0)
          continue;
        LispObject location = oldLayout.getSharedSlotLocation(slotName);
        if (location != null)
          continue;
        // Not found.
        added = added.push(slotName);
      }
    // Swap slots.
    LispObject[] tempSlots = slots;
    slots = newInstance.slots;
    newInstance.slots = tempSlots;
    // Swap layouts.
    Layout tempLayout = layout;
    layout = newInstance.layout;
    newInstance.layout = tempLayout;
    Debug.assertTrue(!layout.isInvalid());
    // Call UPDATE-INSTANCE-FOR-REDEFINED-CLASS.
    Symbol.UPDATE_INSTANCE_FOR_REDEFINED_CLASS.execute(this, added,
                                                       discarded, plist);
    return newLayout;
  }

  // Only handles instance slots (not shared slots).
  public LispObject getInstanceSlotValue(LispObject slotName)

  {
    Debug.assertTrue(layout != null);
    if (layout.isInvalid())
      {
        // Update instance.
        layout = updateLayout();
      }
    Debug.assertTrue(layout != null);
    int index = layout.getSlotIndex(slotName);
    if (index < 0) {
      // Not found.
      final LispThread thread = LispThread.currentThread();
      // If the operation is slot-value, only the primary value [of
      // slot-missing] will be used by the caller, and all other values
      // will be ignored.
      LispObject value = thread.execute(Symbol.SLOT_MISSING,
                                        this.getLispClass(), this,
                                        slotName, Symbol.SLOT_VALUE);
      thread._values = null;
      return value;
    }
    return slots[index];
  }

  // Only handles instance slots (not shared slots).
  public void setInstanceSlotValue(LispObject slotName, LispObject newValue)

  {
    Debug.assertTrue(layout != null);
    if (layout.isInvalid())
      {
        // Update instance.
        layout = updateLayout();
      }
    Debug.assertTrue(layout != null);
    int index = layout.getSlotIndex(slotName);
    if (index < 0) {
      // Not found.
      final LispThread thread = LispThread.currentThread();
      // If the operation is setf or slot-makunbound, any values
      // [returned by slot-missing] will be ignored by the caller.
      thread.execute(Symbol.SLOT_MISSING, this.getLispClass(), this,
                     slotName, Symbol.SETF, newValue);
      thread._values = null;
    }
    slots[index] = newValue;
  }

  final public static StandardObject checkStandardObject(LispObject first)
  {
    if (first instanceof StandardObject)
      return (StandardObject) first;
    return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT);
  }

  private static final Primitive SWAP_SLOTS
    = new pf_swap_slots();
  @DocString(name="swap-slots",
             args="instance-1 instance-2",
             returns="nil")
  private static final class pf_swap_slots extends Primitive
  {
    pf_swap_slots()
    {
      super("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2");
    }
    @Override
    public LispObject execute(LispObject first, LispObject second)
    {
      final StandardObject obj1 = checkStandardObject(first);
      final StandardObject obj2 = checkStandardObject(second);
      LispObject[] temp = obj1.slots;
      obj1.slots = obj2.slots;
      obj2.slots = temp;
      return NIL;
    }
  };

  private static final Primitive STD_INSTANCE_LAYOUT
    = new pf_std_instance_layout();
  @DocString(name="std-instance-layout")
  private static final class pf_std_instance_layout extends Primitive
  {
    pf_std_instance_layout()
    {
      super("std-instance-layout", PACKAGE_SYS, true);
    }
    @Override
    public LispObject execute(LispObject arg)
    {
      final StandardObject instance = checkStandardObject(arg);
      Layout layout = instance.layout;
      if (layout.isInvalid())
        {
          // Update instance.
          layout = instance.updateLayout();
        }
      return layout;
    }
  };

  private static final Primitive _SET_STD_INSTANCE_LAYOUT
    = new pf__set_std_instance_layout();
  @DocString(name="%set-std-instance-layout")
  private static final class pf__set_std_instance_layout extends Primitive
  {
    pf__set_std_instance_layout()
    {
      super("%set-std-instance-layout", PACKAGE_SYS, true);
    }
    @Override
    public LispObject execute(LispObject first, LispObject second)
    {
      checkStandardObject(first).layout = checkLayout(second);
      return second;
    }
  };

  private static final Primitive STD_INSTANCE_CLASS
    = new pf_std_instance_class();
  @DocString(name="std-instance-class")
  private static final class pf_std_instance_class extends Primitive
  {
    pf_std_instance_class()
    {
      super("std-instance-class", PACKAGE_SYS, true);
    }
    @Override
    public LispObject execute(LispObject arg)
    {
      return checkStandardObject(arg).layout.getLispClass();
    }
  };

  private static final Primitive STANDARD_INSTANCE_ACCESS
    = new pf_standard_instance_access();
  @DocString(name="standard-instance-access",
             args="instance location",
             returns="value")
  private static final class pf_standard_instance_access extends Primitive
  {
    pf_standard_instance_access()
    {
      super("standard-instance-access", PACKAGE_SYS, true,
            "instance location");
    }
    @Override
    public LispObject execute(LispObject first, LispObject second)
    {
      final StandardObject instance = checkStandardObject(first);
      if (instance.layout.isInvalid()) {
        // Update instance.
        instance.updateLayout();
      }
      final int index;
      if (second instanceof Fixnum) {
        index = ((Fixnum)second).value;
      } else {
        return type_error(second, Symbol.INTEGER);
      }

      LispObject value;
      try {
        value = instance.slots[index];
      } catch (ArrayIndexOutOfBoundsException e) {
        if (instance.slots.length > 0)
          return type_error(second,
                            list(Symbol.INTEGER, Fixnum.ZERO,
                                 Fixnum.getInstance(instance.slots.length - 1)));
        else
          return program_error("The object " + instance.princToString()
                               + " has no slots.");

      }
      // We let UNBOUND_VALUE escape here, since invoking
      // standard-instance-access on an unbound slot has undefined
      // consequences (AMOP pg. 239), and we use this behavior to
      // implement slot-boundp-using-class.
      return value;
    }
  };

  private static final Primitive _SET_STANDARD_INSTANCE_ACCESS
    = new pf__set_standard_instance_access();
  @DocString(name="%set-standard-instance-access",
             args="instance location new-value",
             returns="new-value")
  private static final class pf__set_standard_instance_access extends Primitive
  {
    pf__set_standard_instance_access()
    {
      super("%set-standard-instance-access", PACKAGE_SYS, true);
    }
    @Override
    public LispObject execute(LispObject first, LispObject second,
                              LispObject third)
    {
      final StandardObject instance = checkStandardObject(first);
      if (instance.layout.isInvalid()) {
        // Update instance.
        instance.updateLayout();
      }
      final int index;
      if (second instanceof Fixnum) {
        index = ((Fixnum)second).value;
      } else {
        return type_error(second, Symbol.INTEGER);
      }
      try {
        instance.slots[index] = third;
      } catch (ArrayIndexOutOfBoundsException e) {
        if (instance.slots.length > 0)
          return type_error(second,
                            list(Symbol.INTEGER, Fixnum.ZERO,
                                 Fixnum.getInstance(instance.slots.length - 1)));
        else
          return program_error("The object " + instance.princToString()
                               + " has no slots.");
      }
      return third;
    }
  };

  private static final Primitive STD_SLOT_BOUNDP
    = new pf_std_slot_boundp();
  @DocString(name="std-slot-boundp")
  private static final class pf_std_slot_boundp extends Primitive
  {
    pf_std_slot_boundp()
    {
      super(Symbol.STD_SLOT_BOUNDP, "instance slot-name");
    }
    @Override
    public LispObject execute(LispObject first, LispObject second)
    {
      final StandardObject instance = checkStandardObject(first);
      Layout layout = instance.layout;
      if (layout.isInvalid())
        {
          // Update instance.
          layout = instance.updateLayout();
        }
      final LispObject index = layout.slotTable.get(second);
      if (index != null)
        {
          // Found instance slot.
          return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL;
        }
      // Check for shared slot.
      final LispObject location = layout.getSharedSlotLocation(second);
      if (location != null)
        return location.cdr() != UNBOUND_VALUE ? T : NIL;
      // Not found.
      final LispThread thread = LispThread.currentThread();
      LispObject value =
        thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(),
                       instance, second, Symbol.SLOT_BOUNDP);
      // "If SLOT-MISSING is invoked and returns a value, a boolean
      // equivalent to its primary value is returned by SLOT-BOUNDP."
      thread._values = null;
      return value != NIL ? T : NIL;
    }
  };

  @Override
  public LispObject SLOT_VALUE(LispObject slotName)
  {
    if (layout.isInvalid())
      {
        // Update instance.
        layout = updateLayout();
      }
    LispObject value;
    final LispObject index = layout.slotTable.get(slotName);
    if (index != null)
      {
        // Found instance slot.
        value = slots[((Fixnum)index).value];
      }
    else
      {
        // Check for shared slot.
        LispObject location = layout.getSharedSlotLocation(slotName);
        if (location == null)
          return Symbol.SLOT_MISSING.execute(getLispClass(), this, slotName,
                                             Symbol.SLOT_VALUE);
        value = location.cdr();
      }
    if (value == UNBOUND_VALUE)
      {
        value = Symbol.SLOT_UNBOUND.execute(getLispClass(), this, slotName);
        LispThread.currentThread()._values = null;
      }
    return value;
  }

  private static final Primitive STD_SLOT_VALUE
    = new pf_std_slot_value();
  @DocString(name="std-slot-value")
  private static final class pf_std_slot_value extends Primitive
  {
    pf_std_slot_value()
    {
      super(Symbol.STD_SLOT_VALUE, "instance slot-name");
    }
    @Override
    public LispObject execute(LispObject first, LispObject second)
    {
      return first.SLOT_VALUE(second);
    }
  };

  @Override
  public void setSlotValue(LispObject slotName, LispObject newValue)
  {
    if (layout.isInvalid())
      {
        // Update instance.
        layout = updateLayout();
      }
    final LispObject index = layout.slotTable.get(slotName);
    if (index != null)
      {
        // Found instance slot.
        slots[((Fixnum)index).value] = newValue;
        return;
      }
    // Check for shared slot.
    LispObject location = layout.getSharedSlotLocation(slotName);
    if (location != null)
      {
        location.setCdr(newValue);
        return;
      }
    LispObject[] args = new LispObject[5];
    args[0] = getLispClass();
    args[1] = this;
    args[2] = slotName;
    args[3] = Symbol.SETF;
    args[4] = newValue;
    Symbol.SLOT_MISSING.execute(args);
  }

  private static final Primitive SET_STD_SLOT_VALUE
    = new pf_set_std_slot_value();
  @DocString(name="set-std-slot-value")
  private static final class pf_set_std_slot_value extends Primitive
  {
    pf_set_std_slot_value()
    {
      super(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value");
    }
    @Override
    public LispObject execute(LispObject first, LispObject second,
                              LispObject third)
    {
      first.setSlotValue(second, third);
      return third;
    }
  };

  private static final Primitive _STD_ALLOCATE_INSTANCE
    = new pf__std_allocate_instance();
  @DocString(name="%std-allocate-instance",
             args="class",
             returns="instance")
  private static final class pf__std_allocate_instance extends Primitive
  {
    pf__std_allocate_instance()
    {
      super("%std-allocate-instance", PACKAGE_SYS, true, "class");
    }
    @Override
    public LispObject execute(LispObject arg)
    {
      if (arg == StandardClass.FUNCALLABLE_STANDARD_CLASS) {
        return new FuncallableStandardClass();
      } else if (arg == StandardClass.STANDARD_CLASS) {
        return new StandardClass();
      } else if (arg instanceof StandardClass) {
        StandardClass cls = (StandardClass)arg;
        Layout layout = cls.getClassLayout();
        if (layout == null) {
          program_error("No layout for class " + cls.princToString() + ".");
        }
        return new StandardObject(cls, layout.getLength());
      } else if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
        LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
        if (! (l instanceof Layout)) {
          program_error("Invalid standard class layout for class "
                        + arg.princToString() + ".");
        }
        return new StandardObject((Layout)l);
      } else {
        return type_error(arg, Symbol.STANDARD_CLASS);
      }
    }
  };
}