Changeset 12527


Ignore:
Timestamp:
03/13/10 19:05:15 (11 years ago)
Author:
ehuelsmann
Message:

Make all class accessor functions generic functions instead

of normal ones, to support METACLASS. Additionally, make
it possible to store general objects in Layout.lispClass.

Because classes may be of a different Java type than

StandardClass?, fall back to the generic functions to access
the required fields from Java.

See #38.

Location:
branches/metaclass/abcl/src/org/armedbear/lisp
Files:
14 edited

Legend:

Unmodified
Added
Removed
  • branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java

    r12451 r12527  
    685685        autoload(Symbol.SET_SCHAR, "StringFunctions");
    686686
    687         autoload(Symbol.SET_CLASS_SLOTS, "SlotClass");
     687        autoload(Symbol._SET_CLASS_SLOTS, "SlotClass");
    688688        autoload(Symbol._CLASS_SLOTS, "SlotClass");
    689689
  • branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java

    r12481 r12527  
    138138  public LispObject typeOf()
    139139  {
    140     LispClass c = getLispClass();
    141     if (c != null)
    142       return c.getName();
     140    LispObject c = getLispClass();
     141    if (c instanceof LispClass)
     142        return ((LispClass)c).getName();
     143    else if (c != null)
     144      return Symbol.CLASS_NAME.execute(c);
    143145    return Symbol.CONDITION;
    144146  }
     
    147149  public LispObject classOf()
    148150  {
    149     LispClass c = getLispClass();
     151    LispObject c = getLispClass();
    150152    if (c != null)
    151153      return c;
  • branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java

    r12481 r12527  
    3838public class Layout extends LispObject
    3939{
    40   private final LispClass lispClass;
     40  private final LispObject lispClass;
    4141  public final EqHashTable slotTable;
    4242
     
    4646  private boolean invalid;
    4747
    48   public Layout(LispClass lispClass, LispObject instanceSlots, LispObject sharedSlots)
     48  public Layout(LispObject lispClass, LispObject instanceSlots, LispObject sharedSlots)
    4949  {
    5050    this.lispClass = lispClass;
     
    6565  }
    6666
    67   public Layout(LispClass lispClass, LispObject[] instanceSlotNames,
     67  public Layout(LispObject lispClass, LispObject[] instanceSlotNames,
    6868                LispObject sharedSlots)
    6969  {
     
    104104  }
    105105
    106   public LispClass getLispClass()
     106  public LispObject getLispClass()
    107107  {
    108108    return lispClass;
     
    160160
    161161      {
    162           return new Layout(checkClass(first), checkList(second),
    163                               checkList(third));
     162          return new Layout(first, checkList(second), checkList(third));
    164163      }
    165164
     
    236235
    237236      {
    238                 final Layout layOutFirst = checkLayout(first);
     237            final Layout layOutFirst = checkLayout(first);
    239238            final LispObject slotNames[] = layOutFirst.slotNames;
    240239            final int limit = slotNames.length;
     
    264263      public LispObject execute(LispObject arg)
    265264      {
    266         final LispClass lispClass = checkClass(arg);
    267         Layout oldLayout = lispClass.getClassLayout();
    268         Layout newLayout = new Layout(oldLayout);
    269         lispClass.setClassLayout(newLayout);
    270         oldLayout.invalidate();
     265        final LispObject lispClass = arg;
     266        LispObject oldLayout;
     267        if (lispClass instanceof LispClass)
     268            oldLayout = ((LispClass)lispClass).getClassLayout();
     269        else
     270            oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass);
     271
     272        Layout newLayout = new Layout((Layout)oldLayout);
     273        if (lispClass instanceof LispClass)
     274          ((LispClass)lispClass).setClassLayout(newLayout);
     275        else
     276          Symbol.CLASS_LAYOUT.getSymbolSetfFunction()
     277              .execute(newLayout, lispClass);
     278        ((Layout)oldLayout).invalidate();
    271279        return arg;
    272280      }
  • branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java

    r12481 r12527  
    180180  }
    181181
    182   public void setClassLayout(Layout layout)
    183   {
    184     classLayout = layout;
     182  public void setClassLayout(LispObject layout)
     183  {
     184    classLayout = layout == NIL ? null : (Layout)layout;
    185185  }
    186186
     
    202202  }
    203203
    204   public final boolean isFinalized()
     204  public boolean isFinalized()
    205205  {
    206206    return finalized;
    207207  }
    208208
    209   public final void setFinalized(boolean b)
     209  public void setFinalized(boolean b)
    210210  {
    211211    finalized = b;
  • branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java

    r12431 r12527  
    669669  }
    670670
     671  public LispObject getSymbolSetfFunction()
     672  {
     673    return type_error(this, Symbol.SYMBOL);
     674  }
     675
     676  public LispObject getSymbolSetfFunctionOrDie()
     677  {
     678    return type_error(this, Symbol.SYMBOL);
     679  }
     680
    671681  public String writeToString()
    672682  {
  • branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java

    r12481 r12527  
    53325332
    53335333        {
    5334             checkClass(first).setName(checkSymbol(second));
    5335             return second;
     5334            checkClass(second).setName(checkSymbol(first));
     5335            return first;
    53365336        }
    53375337    };
    53385338
    53395339    // ### class-layout
    5340     private static final Primitive CLASS_LAYOUT = new pf_class_layout();
    5341     private static final class pf_class_layout extends Primitive {
    5342         pf_class_layout() {
    5343             super("class-layout", PACKAGE_SYS, true, "class");
     5340    private static final Primitive CLASS_LAYOUT = new pf__class_layout();
     5341    private static final class pf__class_layout extends Primitive {
     5342        pf__class_layout() {
     5343            super("%class-layout", PACKAGE_SYS, true, "class");
    53445344        }
    53455345
     
    53625362
    53635363        {
    5364             if (second instanceof Layout) {
    5365                 checkClass(first).setClassLayout((Layout)second);
    5366                 return second;
    5367             }
    5368             return type_error(second, Symbol.LAYOUT);
    5369         }
    5370     };
    5371 
    5372     // ### class-direct-superclasses
    5373     private static final Primitive CLASS_DIRECT_SUPERCLASSES = new pf_class_direct_superclasses();
    5374     private static final class pf_class_direct_superclasses extends Primitive {
    5375         pf_class_direct_superclasses() {
    5376             super("class-direct-superclasses", PACKAGE_SYS, true);
     5364            if (first == NIL || first instanceof Layout) {
     5365                checkClass(second).setClassLayout(first);
     5366                return first;
     5367            }
     5368            return type_error(first, Symbol.LAYOUT);
     5369        }
     5370    };
     5371
     5372    // ### %class-direct-superclasses
     5373    private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
     5374    private static final class pf__class_direct_superclasses extends Primitive {
     5375        pf__class_direct_superclasses() {
     5376            super("%class-direct-superclasses", PACKAGE_SYS, true);
    53775377        }
    53785378
     
    53945394
    53955395        {
    5396             checkClass(first).setDirectSuperclasses(second);
    5397             return second;
    5398         }
    5399     };
    5400 
    5401     // ### class-direct-subclasses
    5402     private static final Primitive CLASS_DIRECT_SUBCLASSES = new pf_class_direct_subclasses();
    5403     private static final class pf_class_direct_subclasses extends Primitive {
    5404         pf_class_direct_subclasses() {
    5405             super("class-direct-subclasses", PACKAGE_SYS, true);
     5396            checkClass(second).setDirectSuperclasses(first);
     5397            return first;
     5398        }
     5399    };
     5400
     5401    // ### %class-direct-subclasses
     5402    private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
     5403    private static final class pf__class_direct_subclasses extends Primitive {
     5404        pf__class_direct_subclasses() {
     5405            super("%class-direct-subclasses", PACKAGE_SYS, true);
    54065406        }
    54075407
     
    54245424
    54255425        {
    5426             checkClass(first).setDirectSubclasses(second);
    5427             return second;
     5426            checkClass(second).setDirectSubclasses(first);
     5427            return first;
    54285428        }
    54295429    };
     
    54425442    };
    54435443
    5444     // ### set-class-precedence-list
    5445     private static final Primitive SET_CLASS_PRECEDENCE_LIST = new pf_set_class_precedence_list();
    5446     private static final class pf_set_class_precedence_list extends Primitive {
    5447         pf_set_class_precedence_list() {
    5448             super("set-class-precedence-list", PACKAGE_SYS, true);
    5449         }
    5450 
    5451         @Override
    5452         public LispObject execute(LispObject first, LispObject second)
    5453 
    5454         {
    5455             checkClass(first).setCPL(second);
    5456             return second;
    5457         }
    5458     };
    5459 
    5460     // ### class-direct-methods
    5461     private static final Primitive CLASS_DIRECT_METHODS = new pf_class_direct_methods();
    5462     private static final class pf_class_direct_methods extends Primitive {
    5463         pf_class_direct_methods() {
    5464             super("class-direct-methods", PACKAGE_SYS, true);
     5444    // ### %set-class-precedence-list
     5445    private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
     5446    private static final class pf__set_class_precedence_list extends Primitive {
     5447        pf__set_class_precedence_list() {
     5448            super("%set-class-precedence-list", PACKAGE_SYS, true);
     5449        }
     5450
     5451        @Override
     5452        public LispObject execute(LispObject first, LispObject second)
     5453
     5454        {
     5455            checkClass(second).setCPL(first);
     5456            return first;
     5457        }
     5458    };
     5459
     5460    // ### %class-direct-methods
     5461    private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
     5462    private static final class pf__class_direct_methods extends Primitive {
     5463        pf__class_direct_methods() {
     5464            super("%class-direct-methods", PACKAGE_SYS, true);
    54655465        }
    54665466
     
    54845484
    54855485        {
    5486             checkClass(first).setDirectMethods(second);
    5487             return second;
     5486            checkClass(second).setDirectMethods(first);
     5487            return first;
    54885488        }
    54895489    };
     
    55225522    };
    55235523
    5524     // ### class-finalized-p
    5525     private static final Primitive CLASS_FINALIZED_P = new pf_class_finalized_p();
    5526     private static final class pf_class_finalized_p extends Primitive {
    5527         pf_class_finalized_p() {
    5528             super("class-finalized-p", PACKAGE_SYS, true);
     5524    // ### %class-finalized-p
     5525    private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
     5526    private static final class pf__class_finalized_p extends Primitive {
     5527        pf__class_finalized_p() {
     5528            super("%class-finalized-p", PACKAGE_SYS, true);
    55295529        }
    55305530
     
    55465546
    55475547        {
    5548             checkClass(first).setFinalized(second != NIL);
    5549             return second;
     5548            checkClass(second).setFinalized(first != NIL);
     5549            return first;
    55505550        }
    55515551    };
  • branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java

    r12481 r12527  
    179179    // ### class-direct-slots
    180180    private static final Primitive CLASS_DIRECT_SLOTS =
    181         new Primitive("class-direct-slots", PACKAGE_SYS, true)
     181        new Primitive("%class-direct-slots", PACKAGE_SYS, true)
    182182    {
    183183        @Override
     
    201201
    202202        {
    203                 if (first instanceof SlotClass) {
    204                   ((SlotClass)first).setDirectSlotDefinitions(second);
    205                 return second;
     203                if (second instanceof SlotClass) {
     204                  ((SlotClass)second).setDirectSlotDefinitions(first);
     205                return first;
    206206            }
    207207                else {
    208                 return type_error(first, Symbol.STANDARD_CLASS);
     208                return type_error(second, Symbol.STANDARD_CLASS);
    209209            }
    210210        }
     
    228228
    229229    // ### set-class-slots
    230     private static final Primitive SET_CLASS_SLOTS =
    231         new Primitive(Symbol.SET_CLASS_SLOTS, "class slot-definitions")
     230    private static final Primitive _SET_CLASS_SLOTS =
     231        new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions")
    232232    {
    233233        @Override
     
    235235
    236236        {
    237             if (first instanceof SlotClass) {
    238               ((SlotClass)first).setSlotDefinitions(second);
    239               return second;
     237            if (second instanceof SlotClass) {
     238              ((SlotClass)second).setSlotDefinitions(first);
     239              return first;
    240240            }
    241241            else {
    242               return type_error(first, Symbol.STANDARD_CLASS);
     242              return type_error(second, Symbol.STANDARD_CLASS);
    243243            }
    244244        }
     
    247247    // ### class-direct-default-initargs
    248248    private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS =
    249         new Primitive("class-direct-default-initargs", PACKAGE_SYS, true)
     249        new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true)
    250250    {
    251251        @Override
     
    269269
    270270        {
    271             if (first instanceof SlotClass) {
    272               ((SlotClass)first).setDirectDefaultInitargs(second);
    273               return second;
    274             }
    275             return type_error(first, Symbol.STANDARD_CLASS);
     271            if (second instanceof SlotClass) {
     272              ((SlotClass)second).setDirectDefaultInitargs(first);
     273              return first;
     274            }
     275            return type_error(second, Symbol.STANDARD_CLASS);
    276276        }
    277277    };
     
    279279    // ### class-default-initargs
    280280    private static final Primitive CLASS_DEFAULT_INITARGS =
    281         new Primitive("class-default-initargs", PACKAGE_SYS, true)
     281        new Primitive("%class-default-initargs", PACKAGE_SYS, true)
    282282    {
    283283        @Override
     
    301301
    302302        {
    303             if (first instanceof SlotClass) {
    304                 ((SlotClass)first).setDefaultInitargs(second);
    305                 return second;
    306             }
    307             return type_error(first, Symbol.STANDARD_CLASS);
     303            if (second instanceof SlotClass) {
     304                ((SlotClass)second).setDefaultInitargs(first);
     305                return first;
     306            }
     307            return type_error(second, Symbol.STANDARD_CLASS);
    308308        }
    309309    };
  • branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java

    r12431 r12527  
    7171  }
    7272 
    73   public static SlotDefinition checkSlotDefination(LispObject obj) {
     73  public static SlotDefinition checkSlotDefinition(LispObject obj) {
    7474          if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
    7575      return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);     
     
    118118      public LispObject execute(LispObject arg)
    119119      {
    120           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
     120          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
    121121      }
    122122    };
     
    131131
    132132      {
    133           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
     133          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
    134134          return second;
    135135      }
     
    143143      public LispObject execute(LispObject arg)
    144144      {
    145           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
     145          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
    146146      }
    147147    };
    148148
    149149  // ### set-slot-definition-initfunction
    150   private static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
     150  static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
    151151    new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true,
    152152                  "slot-definition initfunction")
     
    156156
    157157      {
    158           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
     158          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
    159159          return second;
    160160      }
     
    169169      public LispObject execute(LispObject arg)
    170170      {
    171           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
     171          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
    172172      }
    173173    };
    174174
    175175  // ### set-slot-definition-initform
    176   private static final Primitive SET_SLOT_DEFINITION_INITFORM =
     176  static final Primitive SET_SLOT_DEFINITION_INITFORM =
    177177    new Primitive("set-slot-definition-initform", PACKAGE_SYS, true,
    178178                  "slot-definition initform")
     
    182182
    183183      {
    184           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
     184          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
    185185          return second;
    186186      }
     
    194194      public LispObject execute(LispObject arg)
    195195      {
    196           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
     196          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
    197197      }
    198198    };
     
    207207
    208208      {
    209           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
     209          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
    210210          return second;
    211211      }
     
    220220      public LispObject execute(LispObject arg)
    221221      {
    222           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
     222          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
    223223      }
    224224    };
     
    233233
    234234      {
    235           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
     235          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
    236236          return second;
    237237      }
     
    246246      public LispObject execute(LispObject arg)
    247247      {
    248           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
     248          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
    249249      }
    250250    };
     
    259259
    260260      {
    261           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
     261          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
    262262          return second;
    263263      }
     
    272272      public LispObject execute(LispObject arg)
    273273      {
    274           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
     274          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
    275275      }
    276276    };
     
    285285
    286286      {
    287           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
     287          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
    288288          return second;
    289289      }
     
    298298      public LispObject execute(LispObject arg)
    299299      {
    300           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
     300          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
    301301      }
    302302    };
     
    311311
    312312      {
    313           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
     313          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
    314314          return second;
    315315      }
     
    323323      public LispObject execute(LispObject arg)
    324324      {
    325           return checkSlotDefination(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
     325          return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
    326326      }
    327327    };
     
    335335
    336336      {
    337           checkSlotDefination(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
     337          checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
    338338          return second;
    339339      }
  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java

    r12481 r12527  
    5959  private static Symbol symDefaultInitargs
    6060    = PACKAGE_MOP.intern("DEFAULT-INITARGS");
     61  private static Symbol symFinalizedP
     62    = PACKAGE_MOP.intern("FINALIZED-P");
    6163
    6264  static Layout layoutStandardClass =
     
    7274                      symSlots,
    7375                      symDirectDefaultInitargs,
    74                       symDefaultInitargs),
     76                      symDefaultInitargs,
     77                      symFinalizedP),
    7578                 NIL)
    7679      {
     
    8790      setDirectSuperclasses(NIL);
    8891      setDirectSubclasses(NIL);
     92      setClassLayout(layoutStandardClass);
    8993      setCPL(NIL);
    9094      setDirectMethods(NIL);
     
    9498      setDirectDefaultInitargs(NIL);
    9599      setDefaultInitargs(NIL);
     100      setFinalized(false);
    96101  }
    97102
     
    101106            symbol, directSuperclasses);
    102107      setDirectSubclasses(NIL);
     108      setClassLayout(layoutStandardClass);
    103109      setCPL(NIL);
    104110      setDirectMethods(NIL);
     
    108114      setDirectDefaultInitargs(NIL);
    109115      setDefaultInitargs(NIL);
     116      setFinalized(false);
    110117  }
    111118
     
    130137
    131138  @Override
    132   public void setClassLayout(Layout newLayout)
     139  public void setClassLayout(LispObject newLayout)
    133140  {
    134141    setInstanceSlotValue(symLayout, newLayout);
     
    145152  {
    146153    setInstanceSlotValue(symDirectSuperclasses, directSuperclasses);
     154  }
     155
     156  @Override
     157  public final boolean isFinalized()
     158  {
     159    return getInstanceSlotValue(symFinalizedP) != NIL;
     160  }
     161
     162  @Override
     163  public final void setFinalized(boolean b)
     164  {
     165    setInstanceSlotValue(symFinalizedP, b ? T : NIL);
    147166  }
    148167
     
    323342    STANDARD_CLASS.setClassLayout(layoutStandardClass);
    324343    STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
     344    LispObject slots = STANDARD_CLASS.getDirectSlotDefinitions();
     345    while (slots != NIL) {
     346      SlotDefinition slot = (SlotDefinition)slots.car();
     347      if (slot.getName() == symLayout)
     348          SlotDefinition.SET_SLOT_DEFINITION_INITFUNCTION.execute(slot,
     349                                                                  new Function() {
     350@Override
     351    public LispObject execute() {
     352    return NIL;
     353}
     354                                                                  });
     355      slots = slots.cdr();
     356    }
     357   
    325358  }
    326359
     
    617650
    618651    // Condition classes.
     652    STANDARD_CLASS.finalizeClass();
    619653    ARITHMETIC_ERROR.finalizeClass();
    620654    CELL_ERROR.finalizeClass();
  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r12481 r12527  
    210210      {
    211211        StringBuilder sb = new StringBuilder();
    212         sb.append(getLispClass().getName().writeToString());
     212        LispObject className;
     213        LispObject lispClass = getLispClass();
     214        if (lispClass instanceof LispClass)
     215          className = ((LispClass)lispClass).getName();
     216        else
     217          className = Symbol.CLASS_NAME.execute(lispClass);
     218
     219        sb.append(className.writeToString());
    213220        sb.append(' ');
    214221        sb.append(name.writeToString());
  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java

    r12481 r12527  
    157157          {
    158158            StringBuilder sb = new StringBuilder();
    159             sb.append(getLispClass().getName().writeToString());
     159            LispObject className;
     160            LispObject lispClass = getLispClass();
     161            if (lispClass instanceof LispClass)
     162              className = ((LispClass)lispClass).getName();
     163            else
     164              className = Symbol.CLASS_NAME.execute(lispClass);
     165
     166            sb.append(className.writeToString());
    160167            sb.append(' ');
    161168            sb.append(name.writeToString());
  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java

    r12481 r12527  
    4747
    4848
     49  protected StandardObject(Layout layout)
     50  {
     51    this(layout, layout.getLength());
     52  }
     53
    4954  protected StandardObject(Layout layout, int length)
    5055  {
     
    99104  }
    100105
    101   public final LispClass getLispClass()
     106  public final LispObject getLispClass()
    102107  {
    103108    return layout.getLispClass();
     109  }
     110
     111  private LispObject helperGetClassName()
     112  {
     113    final LispObject c1 = layout.getLispClass();
     114    if (c1 instanceof LispClass)
     115        return ((LispClass)c1).getName();
     116    else
     117        return LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);
     118  }
     119
     120  private LispObject helperGetCPL()
     121  {
     122    final LispObject c1 = layout.getLispClass();
     123    if (c1 instanceof LispClass)
     124        return ((LispClass)c1).getCPL();
     125    else
     126        return LispThread.currentThread().execute(Symbol.CLASS_PRECEDENCE_LIST, c1);
    104127  }
    105128
     
    111134    // CLASS-OF if it has a proper name, and otherwise returns the class
    112135    // itself."
    113     final LispClass c1 = layout.getLispClass();
     136    final LispObject c1 = layout.getLispClass();
     137    LispObject name;
     138    if (c1 instanceof LispClass)
     139        name = ((LispClass)c1).getName();
     140    else
     141        name = LispThread.currentThread().execute(Symbol.CLASS_NAME, c1);
     142
    114143    // The proper name of a class is "a symbol that names the class whose
    115144    // name is that symbol".
    116     final LispObject name = c1.getName();
    117145    if (name != NIL && name != UNBOUND_VALUE)
    118146      {
     
    138166    if (type == StandardClass.STANDARD_OBJECT)
    139167      return T;
    140     LispClass cls = layout != null ? layout.getLispClass() : null;
     168    LispObject cls = layout != null ? layout.getLispClass() : null;
    141169    if (cls != null)
    142170      {
    143171        if (type == cls)
    144172          return T;
    145         if (type == cls.getName())
     173        if (type == helperGetClassName())
    146174          return T;
    147         LispObject cpl = cls.getCPL();
     175        LispObject cpl = helperGetCPL();
    148176        while (cpl != NIL)
    149177          {
    150178            if (type == cpl.car())
    151179              return T;
    152             if (type == ((LispClass)cpl.car()).getName())
    153               return T;
     180
     181            LispObject otherName;
     182            LispObject otherClass = cpl.car();
     183            if (otherClass instanceof LispClass) {
     184              if (type == ((LispClass)otherClass).getName())
     185                return T;
     186            }
     187            else
     188            if (type == LispThread
     189                .currentThread().execute(Symbol.CLASS_NAME, otherClass))
     190                return T;
     191
    154192            cpl = cpl.cdr();
    155193          }
     
    184222    Debug.assertTrue(layout.isInvalid());
    185223    Layout oldLayout = layout;
    186     LispClass cls = oldLayout.getLispClass();
    187     Layout newLayout = cls.getClassLayout();
     224    LispObject cls = oldLayout.getLispClass();
     225    Layout newLayout;
     226
     227    if (cls instanceof LispClass)
     228        newLayout = ((LispClass)cls).getClassLayout();
     229    else
     230        newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls);
     231
    188232    Debug.assertTrue(!newLayout.isInvalid());
    189     StandardObject newInstance = new StandardObject(cls);
     233    StandardObject newInstance = new StandardObject(newLayout);
    190234    Debug.assertTrue(newInstance.layout == newLayout);
    191235    LispObject added = NIL;
  • branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java

    r12431 r12527  
    391391  }
    392392
     393  @Override
     394  public final LispObject getSymbolSetfFunction()
     395  {
     396    return get(this, Symbol.SETF_FUNCTION, NIL);
     397  }
     398
     399
     400  @Override
    393401  public final LispObject getSymbolSetfFunctionOrDie()
    394 
    395402  {
    396403    LispObject obj = get(this, Symbol.SETF_FUNCTION, null);
     
    29142921
    29152922  // MOP.
     2923  public static final Symbol CLASS_LAYOUT =
     2924    PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT");
     2925  public static final Symbol CLASS_PRECEDENCE_LIST =
     2926    PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST");
    29162927  public static final Symbol STANDARD_READER_METHOD =
    29172928    PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
     
    29662977  public static final Symbol OUTPUT_OBJECT =
    29672978    PACKAGE_SYS.addExternalSymbol("OUTPUT-OBJECT");
    2968   public static final Symbol SET_CLASS_SLOTS =
    2969     PACKAGE_SYS.addExternalSymbol("SET-CLASS-SLOTS");
     2979  public static final Symbol _SET_CLASS_SLOTS =
     2980    PACKAGE_SYS.addExternalSymbol("%SET-CLASS-SLOTS");
    29702981  public static final Symbol SETF_FUNCTION =
    29712982    PACKAGE_SYS.addExternalSymbol("SETF-FUNCTION");
  • branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp

    r12481 r12527  
    5454(export '(class-precedence-list class-slots))
    5555
    56 (defun class-slots (class)
    57   (%class-slots class))
     56;; Don't use DEFVAR, because that disallows loading clos.lisp
     57;; after compiling it: the binding won't get assigned to T anymore
     58(defparameter *clos-booting* t)
     59
     60(defmacro define-class->%class-forwarder (name)
     61  (let* (($name (if (consp name) (cadr name) name))
     62         (%name (intern (concatenate 'string
     63                                     "%"
     64                                     (if (consp name)
     65                                         (symbol-name 'set-) "")
     66                                     (symbol-name $name))
     67                        (symbol-package $name))))
     68    `(progn
     69       (declaim (notinline ,name))
     70       (defun ,name (&rest args)
     71         (apply #',%name args)))))
     72
     73(define-class->%class-forwarder class-name)
     74(define-class->%class-forwarder (setf class-name))
     75(define-class->%class-forwarder class-slots)
     76(define-class->%class-forwarder (setf class-slots))
     77(define-class->%class-forwarder class-direct-slots)
     78(define-class->%class-forwarder (setf class-direct-slots))
     79(define-class->%class-forwarder class-layout)
     80(define-class->%class-forwarder (setf class-layout))
     81(define-class->%class-forwarder class-direct-superclasses)
     82(define-class->%class-forwarder (setf class-direct-superclasses))
     83(define-class->%class-forwarder class-direct-subclasses)
     84(define-class->%class-forwarder (setf class-direct-subclasses))
     85(define-class->%class-forwarder class-direct-methods)
     86(define-class->%class-forwarder (setf class-direct-methods))
     87(define-class->%class-forwarder class-precedence-list)
     88(define-class->%class-forwarder (setf class-precedence-list))
     89(define-class->%class-forwarder class-finalized-p)
     90(define-class->%class-forwarder (setf class-finalized-p))
     91(define-class->%class-forwarder class-default-initargs)
     92(define-class->%class-forwarder (setf class-default-initargs))
     93(define-class->%class-forwarder class-direct-default-initargs)
     94(define-class->%class-forwarder (setf class-direct-default-initargs))
     95
     96(defun no-applicable-method (generic-function &rest args)
     97  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
     98         generic-function
     99         args))
     100
     101
    58102
    59103(defmacro push-on-end (value location)
     
    86130            (mapplist fun (cddr x)))))
    87131
    88 (defsetf class-layout %set-class-layout)
    89 (defsetf class-direct-superclasses %set-class-direct-superclasses)
    90 (defsetf class-direct-subclasses %set-class-direct-subclasses)
    91 (defsetf class-direct-methods %set-class-direct-methods)
    92 (defsetf class-direct-slots %set-class-direct-slots)
    93 ;; (defsetf class-slots %set-class-slots)
    94 (defsetf class-direct-default-initargs %set-class-direct-default-initargs)
    95 (defsetf class-default-initargs %set-class-default-initargs)
    96 (defsetf class-finalized-p %set-class-finalized-p)
    97132(defsetf std-instance-layout %set-std-instance-layout)
    98133(defsetf standard-instance-access %set-standard-instance-access)
     
    255290
    256291(defun std-finalize-inheritance (class)
    257   (set-class-precedence-list
    258    class
     292  (setf (class-precedence-list class)
    259293   (funcall (if (eq (class-of class) (find-class 'standard-class))
    260294                #'std-compute-class-precedence-list
    261295                #'compute-class-precedence-list)
    262296            class))
    263   (dolist (class (%class-precedence-list class))
     297  (dolist (class (class-precedence-list class))
    264298    (when (typep class 'forward-referenced-class)
    265299      (return-from std-finalize-inheritance)))
    266   (set-class-slots class
    267                    (funcall (if (eq (class-of class) (find-class 'standard-class))
    268                                 #'std-compute-slots
    269                                 #'compute-slots)
    270                             class))
     300  (setf (class-slots class)
     301        (funcall (if (eq (class-of class) (find-class 'standard-class))
     302                     #'std-compute-slots
     303                     #'compute-slots) class))
    271304  (let ((old-layout (class-layout class))
    272305        (length 0)
    273306        (instance-slots '())
    274307        (shared-slots '()))
    275     (dolist (slot (%class-slots class))
     308    (dolist (slot (class-slots class))
    276309      (case (%slot-definition-allocation slot)
    277310        (:instance
     
    293326               (old-location (layout-slot-location old-layout slot-name)))
    294327          (unless old-location
    295             (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name))
     328            (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
    296329                   (initfunction (%slot-definition-initfunction slot-definition)))
    297330              (when initfunction
     
    393426(defun std-compute-slots (class)
    394427  (let* ((all-slots (mapappend #'class-direct-slots
    395                                (%class-precedence-list class)))
     428                               (class-precedence-list class)))
    396429         (all-names (remove-duplicates
    397430                     (mapcar #'%slot-definition-name all-slots))))
     
    432465
    433466(defun find-slot-definition (class slot-name)
    434   (dolist (slot (%class-slots class) nil)
     467  (dolist (slot (class-slots class) nil)
    435468    (when (eq slot-name (%slot-definition-name slot))
    436469      (return slot))))
     
    482515
    483516(defun std-slot-exists-p (instance slot-name)
    484   (not (null (find slot-name (%class-slots (class-of instance))
     517  (not (null (find slot-name (class-slots (class-of instance))
    485518                   :key #'%slot-definition-name))))
    486519
     
    500533  (declare (ignore metaclass))
    501534  (let ((class (std-allocate-instance (find-class 'standard-class))))
    502     (%set-class-name class name)
    503     (setf (class-direct-subclasses class) ())
    504     (setf (class-direct-methods class) ())
     535    (%set-class-name name class)
     536    (%set-class-layout nil class)
     537    (%set-class-direct-subclasses ()  class)
     538    (%set-class-direct-methods ()  class)
    505539    (%set-class-documentation class documentation)
    506540    (std-after-initialization-for-classes class
     
    538572  (getf canonical-slot :name))
    539573
    540 (defun ensure-class (name &rest all-keys &allow-other-keys)
     574(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
    541575  ;; Check for duplicate slots.
     576  (remf all-keys :metaclass)
    542577  (let ((slots (getf all-keys :direct-slots)))
    543578    (dolist (s1 slots)
     
    564599        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
    565600  (let ((old-class (find-class name nil)))
    566     (cond ((and old-class (eq name (%class-name old-class)))
     601    (cond ((and old-class (eq name (class-name old-class)))
    567602           (cond ((typep old-class 'built-in-class)
    568603                  (error "The symbol ~S names a built-in class." name))
     
    583618                  old-class)))
    584619          (t
    585            (let ((class (apply #'make-instance-standard-class
    586                                (find-class 'standard-class)
     620           (let ((class (apply (if metaclass
     621                                   #'make-instance
     622                                   #'make-instance-standard-class)
     623                               (or metaclass
     624                                   (find-class 'standard-class))
    587625                               :name name all-keys)))
    588626             (%set-find-class name class)
     
    832870          gf)
    833871        (progn
    834           (when (fboundp function-name)
     872          (when (and (null *clos-booting*)
     873                     (fboundp function-name))
    835874            (error 'program-error
    836875                   :format-control "~A already names an ordinary function, macro, or special operator."
     
    17811820                   )))
    17821821
    1783 (fmakunbound 'class-name)
    1784 (fmakunbound '(setf class-name))
    1785 
    1786 (defgeneric class-name (class))
    1787 
    1788 (defmethod class-name ((class class))
    1789   (%class-name class))
    1790 
    1791 (defgeneric (setf class-name) (new-value class))
    1792 
    1793 (defmethod (setf class-name) (new-value (class class))
    1794   (%set-class-name class new-value))
    1795 
    1796 (when (autoloadp 'class-precedence-list)
    1797   (fmakunbound 'class-precedence-list))
    1798 
    1799 (defgeneric class-precedence-list (class))
    1800 
    1801 (defmethod class-precedence-list ((class class))
    1802   (%class-precedence-list class))
     1822(defmacro redefine-class-forwarder (name slot &optional alternative-name)
     1823  (let* (($name (if (consp name) (cadr name) name))
     1824         (%name (intern (concatenate 'string
     1825                                     "%"
     1826                                     (if (consp name)
     1827                                         (symbol-name 'set-) "")
     1828                                     (symbol-name $name))
     1829                        (find-package "SYS"))))
     1830    (unless alternative-name
     1831      (setf alternative-name name))
     1832    (if (consp name)
     1833        `(progn ;; setter
     1834           (defgeneric ,alternative-name (new-value class))
     1835           (defmethod ,alternative-name (new-value (class built-in-class))
     1836             (,%name new-value class))
     1837           (defmethod ,alternative-name (new-value (class forward-referenced-class))
     1838             (,%name new-value class))
     1839           (defmethod ,alternative-name (new-value (class structure-class))
     1840             (,%name new-value class))
     1841           (defmethod ,alternative-name (new-value (class standard-class))
     1842             (setf (slot-value class ',slot) new-value))
     1843           ,@(unless (eq name alternative-name)
     1844                     `((setf (get ',$name 'SETF-FUNCTION)
     1845                             (symbol-function ',alternative-name))))
     1846           )
     1847        `(progn ;; getter
     1848           (defgeneric ,alternative-name (class))
     1849           (defmethod ,alternative-name ((class built-in-class))
     1850             (,%name class))
     1851           (defmethod ,alternative-name ((class forward-referenced-class))
     1852             (,%name class))
     1853           (defmethod ,alternative-name ((class structure-class))
     1854             (,%name class))
     1855           (defmethod ,alternative-name ((class standard-class))
     1856             (slot-value class ',slot))
     1857           ,@(unless (eq name alternative-name)
     1858                     `((setf (symbol-function ',$name)
     1859                             (symbol-function ',alternative-name))))
     1860           ) )))
     1861
     1862(redefine-class-forwarder class-name name)
     1863(redefine-class-forwarder (setf class-name) name)
     1864(redefine-class-forwarder class-slots slots)
     1865(redefine-class-forwarder (setf class-slots) slots)
     1866(redefine-class-forwarder class-direct-slots direct-slots)
     1867(redefine-class-forwarder (setf class-direct-slots) direct-slots)
     1868(redefine-class-forwarder class-layout layout)
     1869(redefine-class-forwarder (setf class-layout) layout)
     1870(redefine-class-forwarder class-direct-superclasses direct-superclasses)
     1871(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
     1872(redefine-class-forwarder class-direct-subclasses direct-subclasses)
     1873(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
     1874(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
     1875(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
     1876(redefine-class-forwarder class-precedence-list class-precedence-list)
     1877(redefine-class-forwarder (setf class-precedence-list) class-precedence-list)
     1878(redefine-class-forwarder class-finalized-p finalized-p)
     1879(redefine-class-forwarder (setf class-finalized-p) finalized-p)
     1880(redefine-class-forwarder class-default-initargs default-initargs)
     1881(redefine-class-forwarder (setf class-default-initargs) default-initargs)
     1882(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
     1883(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
    18031884
    18041885
     
    19512032
    19522033(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
    1953   (dolist (dsd (%class-slots class))
     2034  (dolist (dsd (class-slots class))
    19542035    (when (eq (sys::dsd-name dsd) slot-name)
    19552036      (return-from slot-exists-p-using-class t)))
     
    19702051(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
    19712052  (declare (ignore new-value))
     2053  (mapcar #'print (mapcar #'frame-to-string (sys::backtrace)))
    19722054  (error "The slot ~S is missing from the class ~S." slot-name class))
    19732055
     
    19872069(defmethod allocate-instance ((class structure-class) &rest initargs)
    19882070  (declare (ignore initargs))
    1989   (%make-structure (%class-name class)
    1990                    (make-list (length (%class-slots class))
     2071  (%make-structure (class-name class)
     2072                   (make-list (length (class-slots class))
    19912073                              :initial-element +slot-unbound+)))
    19922074
     
    20132095     `(,instance ,@initargs)
    20142096         (list instance)))))
    2015     (slots (%class-slots (class-of instance))))
     2097    (slots (class-slots (class-of instance))))
    20162098      (do* ((tail initargs (cddr tail))
    20172099            (initarg (car tail) (car tail)))
     
    20962178       :format-control "Invalid initarg ~S."
    20972179       :format-arguments (list initarg))))
    2098   (dolist (slot (%class-slots (class-of instance)))
     2180  (dolist (slot (class-slots (class-of instance)))
    20992181    (let ((slot-name (%slot-definition-name slot)))
    21002182      (multiple-value-bind (init-key init-value foundp)
     
    21212203(defmethod change-class ((old-instance standard-object) (new-class standard-class)
    21222204                         &rest initargs)
    2123   (let ((old-slots (%class-slots (class-of old-instance)))
    2124         (new-slots (%class-slots new-class))
     2205  (let ((old-slots (class-slots (class-of old-instance)))
     2206        (new-slots (class-slots new-class))
    21252207        (new-instance (allocate-instance new-class)))
    21262208    ;; "The values of local slots specified by both the class CTO and the class
     
    21542236                       (slot-exists-p old slot-name))
    21552237                    (mapcar #'%slot-definition-name
    2156                             (%class-slots (class-of new))))))
     2238                            (class-slots (class-of new))))))
    21572239    (check-initargs new added-slots initargs)
    21582240    (apply #'shared-initialize new added-slots initargs)))
     
    23412423(defmethod make-load-form ((class class) &optional environment)
    23422424  (declare (ignore environment))
    2343   (let ((name (%class-name class)))
     2425  (let ((name (class-name class)))
    23442426    (unless (and name (eq (find-class name nil) class))
    23452427      (error 'simple-type-error
     
    23562438    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
    23572439
     2440(fmakunbound 'no-applicable-method)
    23582441(defgeneric no-applicable-method (generic-function &rest args))
    23592442
     
    23942477(defgeneric function-keywords (method))
    23952478
     2479(setf *clos-booting* nil)
    23962480
    23972481(provide 'clos)
Note: See TracChangeset for help on using the changeset viewer.