Changeset 12576


Ignore:
Timestamp:
03/28/10 20:13:14 (12 years ago)
Author:
ehuelsmann
Message:

Re #38: Merge the METACLASS branch to trunk.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
17 edited

Legend:

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

    r12557 r12576  
    686686        autoload(Symbol.SET_SCHAR, "StringFunctions");
    687687
    688         autoload(Symbol.SET_CLASS_SLOTS, "SlotClass");
     688        autoload(Symbol._SET_CLASS_SLOTS, "SlotClass");
    689689        autoload(Symbol._CLASS_SLOTS, "SlotClass");
    690690
  • trunk/abcl/src/org/armedbear/lisp/Condition.java

    r12512 r12576  
    142142  public LispObject typeOf()
    143143  {
    144     LispClass c = getLispClass();
    145     if (c != null)
    146       return c.getName();
     144    LispObject c = getLispClass();
     145    if (c instanceof LispClass)
     146        return ((LispClass)c).getName();
     147    else if (c != null)
     148      return Symbol.CLASS_NAME.execute(c);
    147149    return Symbol.CONDITION;
    148150  }
     
    151153  public LispObject classOf()
    152154  {
    153     LispClass c = getLispClass();
     155    LispObject c = getLispClass();
    154156    if (c != null)
    155157      return c;
  • trunk/abcl/src/org/armedbear/lisp/Layout.java

    r12513 r12576  
    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      }
  • trunk/abcl/src/org/armedbear/lisp/Lisp.java

    r12524 r12576  
    16541654  }
    16551655 
    1656   public final static LispClass checkClass(LispObject obj)
    1657 
    1658    {
    1659           if (obj instanceof LispClass)         
    1660                   return (LispClass) obj;                         
    1661           return (LispClass)// Not reached.                   
    1662                 type_error(obj, Symbol.CLASS);
    1663    }   
    1664 
    16651656  public final static Layout checkLayout(LispObject obj)
    16661657
  • trunk/abcl/src/org/armedbear/lisp/LispClass.java

    r12481 r12576  
    4949  }
    5050
     51  public static LispObject addClass(Symbol symbol, LispObject c)
     52  {
     53    synchronized (map)
     54      {
     55        map.put(symbol, c);
     56      }
     57    return c;
     58  }
     59
    5160  public static void removeClass(Symbol symbol)
    5261  {
     
    6978  {
    7079    final Symbol symbol = checkSymbol(name);
    71     final LispClass c;
    72     synchronized (map)
    73       {
    74         c = (LispClass) map.get(symbol);
     80    final LispObject c;
     81    synchronized (map)
     82      {
     83        c = map.get(symbol);
    7584      }
    7685    if (c != null)
     
    180189  }
    181190
    182   public void setClassLayout(Layout layout)
    183   {
    184     classLayout = layout;
     191  public void setClassLayout(LispObject layout)
     192  {
     193    classLayout = layout == NIL ? null : (Layout)layout;
    185194  }
    186195
     
    202211  }
    203212
    204   public final boolean isFinalized()
     213  public boolean isFinalized()
    205214  {
    206215    return finalized;
    207216  }
    208217
    209   public final void setFinalized(boolean b)
     218  public void setFinalized(boolean b)
    210219  {
    211220    finalized = b;
     
    292301  public boolean subclassp(LispObject obj)
    293302  {
    294     LispObject cpl = getCPL();
     303    return false;
     304  }
     305
     306  public static boolean subclassp(LispObject cls, LispObject obj)
     307  {
     308    LispObject cpl;
     309
     310    if (cls instanceof LispClass)
     311      cpl = ((LispClass)cls).getCPL();
     312    else
     313      cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls);
     314
    295315    while (cpl != NIL)
    296316      {
     
    299319        cpl = ((Cons)cpl).cdr;
    300320      }
     321
     322    if (cls instanceof LispClass)
     323      // additional checks (currently because of JavaClass)
     324      return ((LispClass)cls).subclassp(obj);
     325
    301326    return false;
    302327  }
     
    341366            return second;
    342367          }
    343         final LispClass c = checkClass(second);
    344         addClass(name, c);
     368        addClass(name, second);
    345369        return second;
    346370      }
     
    355379
    356380      {
    357         final LispClass c = checkClass(first);
    358         return c.subclassp(second) ? T : NIL;
     381        return LispClass.subclassp(first, second) ? T : NIL;
    359382      }
    360383    };
  • trunk/abcl/src/org/armedbear/lisp/LispObject.java

    r12541 r12576  
    678678  }
    679679
     680  public LispObject getSymbolSetfFunction()
     681  {
     682    return type_error(this, Symbol.SYMBOL);
     683  }
     684
     685  public LispObject getSymbolSetfFunctionOrDie()
     686  {
     687    return type_error(this, Symbol.SYMBOL);
     688  }
     689
    680690  public String writeToString()
    681691  {
  • trunk/abcl/src/org/armedbear/lisp/Primitives.java

    r12516 r12576  
    53175317        @Override
    53185318        public LispObject execute(LispObject arg) {
    5319             return checkClass(arg).getName();
     5319            if (arg instanceof LispClass)
     5320                return ((LispClass)arg).getName();
     5321
     5322            return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
    53205323        }
    53215324    };
     
    53325335
    53335336        {
    5334             checkClass(first).setName(checkSymbol(second));
    5335             return second;
     5337            if (second instanceof LispClass)
     5338                ((LispClass)second).setName(checkSymbol(first));
     5339            else
     5340                ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
     5341                                                           checkSymbol(first));
     5342            return first;
    53365343        }
    53375344    };
    53385345
    53395346    // ### 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");
    5344         }
    5345 
    5346         @Override
    5347         public LispObject execute(LispObject arg) {
    5348             Layout layout = checkClass(arg).getClassLayout();
     5347    private static final Primitive CLASS_LAYOUT = new pf__class_layout();
     5348    private static final class pf__class_layout extends Primitive {
     5349        pf__class_layout() {
     5350            super("%class-layout", PACKAGE_SYS, true, "class");
     5351        }
     5352
     5353        @Override
     5354        public LispObject execute(LispObject arg) {
     5355            Layout layout;
     5356            if (arg instanceof LispClass)
     5357              layout = ((LispClass)arg).getClassLayout();
     5358            else
     5359              layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
     5360
    53495361            return layout != null ? layout : NIL;
    53505362        }
     
    53625374
    53635375        {
    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);
    5377         }
    5378 
    5379         @Override
    5380         public LispObject execute(LispObject arg) {
    5381             return checkClass(arg).getDirectSuperclasses();
     5376            if (first == NIL || first instanceof Layout) {
     5377                if (second instanceof LispClass)
     5378                  ((LispClass)second).setClassLayout(first);
     5379                else
     5380                  ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
     5381                return first;
     5382            }
     5383            return type_error(first, Symbol.LAYOUT);
     5384        }
     5385    };
     5386
     5387    // ### %class-direct-superclasses
     5388    private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
     5389    private static final class pf__class_direct_superclasses extends Primitive {
     5390        pf__class_direct_superclasses() {
     5391            super("%class-direct-superclasses", PACKAGE_SYS, true);
     5392        }
     5393
     5394        @Override
     5395        public LispObject execute(LispObject arg) {
     5396            if (arg instanceof LispClass)
     5397              return ((LispClass)arg).getDirectSuperclasses();
     5398            else
     5399              return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
    53825400        }
    53835401    };
     
    53925410        @Override
    53935411        public LispObject execute(LispObject first, LispObject second)
    5394 
    5395         {
    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);
    5406         }
    5407 
    5408         @Override
    5409         public LispObject execute(LispObject arg) {
    5410             return checkClass(arg).getDirectSubclasses();
     5412        {
     5413            if (second instanceof LispClass)
     5414              ((LispClass)second).setDirectSuperclasses(first);
     5415            else
     5416              ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
     5417            return first;
     5418        }
     5419    };
     5420
     5421    // ### %class-direct-subclasses
     5422    private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
     5423    private static final class pf__class_direct_subclasses extends Primitive {
     5424        pf__class_direct_subclasses() {
     5425            super("%class-direct-subclasses", PACKAGE_SYS, true);
     5426        }
     5427
     5428        @Override
     5429        public LispObject execute(LispObject arg) {
     5430            if (arg instanceof LispClass)
     5431                return ((LispClass)arg).getDirectSubclasses();
     5432            else
     5433                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
    54115434        }
    54125435    };
     
    54225445        @Override
    54235446        public LispObject execute(LispObject first, LispObject second)
    5424 
    5425         {
    5426             checkClass(first).setDirectSubclasses(second);
    5427             return second;
     5447        {
     5448            if (second instanceof LispClass)
     5449                ((LispClass)second).setDirectSubclasses(first);
     5450            else
     5451                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
     5452            return first;
    54285453        }
    54295454    };
     
    54385463        @Override
    54395464        public LispObject execute(LispObject arg) {
    5440             return checkClass(arg).getCPL();
    5441         }
    5442     };
    5443 
    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);
     5465            if (arg instanceof LispClass)
     5466                return ((LispClass)arg).getCPL();
     5467            else
     5468                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
     5469        }
     5470    };
     5471
     5472    // ### %set-class-precedence-list
     5473    private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
     5474    private static final class pf__set_class_precedence_list extends Primitive {
     5475        pf__set_class_precedence_list() {
     5476            super("%set-class-precedence-list", PACKAGE_SYS, true);
     5477        }
     5478
     5479        @Override
     5480        public LispObject execute(LispObject first, LispObject second)
     5481        {
     5482            if (second instanceof LispClass)
     5483                ((LispClass)second).setCPL(first);
     5484            else
     5485                ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
     5486            return first;
     5487        }
     5488    };
     5489
     5490    // ### %class-direct-methods
     5491    private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
     5492    private static final class pf__class_direct_methods extends Primitive {
     5493        pf__class_direct_methods() {
     5494            super("%class-direct-methods", PACKAGE_SYS, true);
    54655495        }
    54665496
    54675497        @Override
    54685498        public LispObject execute(LispObject arg)
    5469 
    5470         {
    5471             return checkClass(arg).getDirectMethods();
     5499        {
     5500            if (arg instanceof LispClass)
     5501                return ((LispClass)arg).getDirectMethods();
     5502            else
     5503                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
    54725504        }
    54735505    };
     
    54825514        @Override
    54835515        public LispObject execute(LispObject first, LispObject second)
    5484 
    5485         {
    5486             checkClass(first).setDirectMethods(second);
    5487             return second;
     5516        {
     5517            if (second instanceof LispClass)
     5518                ((LispClass)second).setDirectMethods(first);
     5519            else
     5520                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
     5521            return first;
    54885522        }
    54895523    };
     
    55015535
    55025536        {
    5503             return checkClass(arg).getDocumentation();
     5537            if (arg instanceof LispClass)
     5538                return ((LispClass)arg).getDocumentation();
     5539            else
     5540                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
    55045541        }
    55055542    };
     
    55155552        @Override
    55165553        public LispObject execute(LispObject first, LispObject second)
    5517 
    5518         {
    5519             checkClass(first).setDocumentation(second);
     5554        {
     5555            if (first instanceof LispClass)
     5556                ((LispClass)first).setDocumentation(second);
     5557            else
     5558                ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
    55205559            return second;
    55215560        }
    55225561    };
    55235562
    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);
    5529         }
    5530 
    5531         @Override
    5532         public LispObject execute(LispObject arg) {
    5533             return checkClass(arg).isFinalized() ? T : NIL;
     5563    // ### %class-finalized-p
     5564    private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
     5565    private static final class pf__class_finalized_p extends Primitive {
     5566        pf__class_finalized_p() {
     5567            super("%class-finalized-p", PACKAGE_SYS, true);
     5568        }
     5569
     5570        @Override
     5571        public LispObject execute(LispObject arg) {
     5572            if (arg instanceof LispClass)
     5573                return ((LispClass)arg).isFinalized() ? T : NIL;
     5574            else
     5575                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
    55345576        }
    55355577    };
     
    55445586        @Override
    55455587        public LispObject execute(LispObject first, LispObject second)
    5546 
    5547         {
    5548             checkClass(first).setFinalized(second != NIL);
    5549             return second;
     5588        {
     5589            if (second instanceof LispClass)
     5590                ((LispClass)second).setFinalized(first != NIL);
     5591            else
     5592                ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
     5593            return first;
    55505594        }
    55515595    };
     
    55605604        @Override
    55615605        public LispObject execute(LispObject arg) {
    5562             return arg instanceof LispClass ? T : NIL;
     5606            return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
    55635607        }
    55645608    };
  • trunk/abcl/src/org/armedbear/lisp/SlotClass.java

    r12513 r12576  
    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);
    308         }
    309     };
    310 
    311     // ### compute-class-default-initargs
    312     private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS =
    313         new Primitive("compute-class-default-initargs", PACKAGE_SYS, true)
    314     {
    315         @Override
    316         public LispObject execute(LispObject arg)
    317 
    318         {
    319             final SlotClass c;
    320             if (arg instanceof SlotClass) {
    321                 c = (SlotClass) arg;
    322             }
    323             else {
    324                 return type_error(arg, Symbol.STANDARD_CLASS);
    325             }
    326             return c.computeDefaultInitargs();
    327         }
    328     };
     303            if (second instanceof SlotClass) {
     304                ((SlotClass)second).setDefaultInitargs(first);
     305                return first;
     306            }
     307            return type_error(second, Symbol.STANDARD_CLASS);
     308        }
     309    };
     310
    329311}
  • trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

    r12521 r12576  
    7070    slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
    7171  }
    72  
     72
     73  public SlotDefinition(LispObject name, LispObject readers,
     74                        Function initFunction)
     75  {
     76    this();
     77    Debug.assertTrue(name instanceof Symbol);
     78    slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name;
     79    slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = initFunction;
     80    slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = NIL;
     81    slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] =
     82      new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName()));
     83    slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers;
     84    slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
     85  }
     86
    7387  public static SlotDefinition checkSlotDefinition(LispObject obj) {
    7488          if (obj instanceof SlotDefinition) return (SlotDefinition)obj;
     
    148162
    149163  // ### set-slot-definition-initfunction
    150   private static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
     164  static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
    151165    new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true,
    152166                  "slot-definition initfunction")
     
    174188
    175189  // ### set-slot-definition-initform
    176   private static final Primitive SET_SLOT_DEFINITION_INITFORM =
     190  static final Primitive SET_SLOT_DEFINITION_INITFORM =
    177191    new Primitive("set-slot-definition-initform", PACKAGE_SYS, true,
    178192                  "slot-definition initform")
  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r12481 r12576  
    3939{
    4040
    41   private static Symbol symName = PACKAGE_MOP.intern("NAME");
    42   private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
    43   private static Symbol symDirectSuperclasses
     41  public static Symbol symName = PACKAGE_MOP.intern("NAME");
     42  public static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
     43  public static Symbol symDirectSuperclasses
    4444    = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
    45   private static Symbol symDirectSubclasses
     45  public static Symbol symDirectSubclasses
    4646    = PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
    47   private static Symbol symClassPrecedenceList
    48     = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
    49   private static Symbol symDirectMethods
     47  public static Symbol symPrecedenceList
     48    = PACKAGE_MOP.intern("PRECEDENCE-LIST");
     49  public static Symbol symDirectMethods
    5050    = PACKAGE_MOP.intern("DIRECT-METHODS");
    51   private static Symbol symDocumentation
     51  public static Symbol symDocumentation
    5252    = PACKAGE_MOP.intern("DOCUMENTATION");
    53   private static Symbol symDirectSlots
     53  public static Symbol symDirectSlots
    5454    = PACKAGE_MOP.intern("DIRECT-SLOTS");
    55   private static Symbol symSlots
     55  public static Symbol symSlots
    5656    = PACKAGE_MOP.intern("SLOTS");
    57   private static Symbol symDirectDefaultInitargs
     57  public static Symbol symDirectDefaultInitargs
    5858    = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
    59   private static Symbol symDefaultInitargs
     59  public static Symbol symDefaultInitargs
    6060    = PACKAGE_MOP.intern("DEFAULT-INITARGS");
     61  public static Symbol symFinalizedP
     62    = PACKAGE_MOP.intern("FINALIZED-P");
    6163
    6264  static Layout layoutStandardClass =
     
    6668                      symDirectSuperclasses,
    6769                      symDirectSubclasses,
    68                       symClassPrecedenceList,
     70                      symPrecedenceList,
    6971                      symDirectMethods,
    7072                      symDocumentation,
     
    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);
     
    148155
    149156  @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);
     166  }
     167
     168  @Override
    150169  public LispObject getDirectSubclasses()
    151170  {
     
    162181  public LispObject getCPL()
    163182  {
    164     return getInstanceSlotValue(symClassPrecedenceList);
     183    return getInstanceSlotValue(symPrecedenceList);
    165184  }
    166185
     
    170189    LispObject obj1 = cpl[0];
    171190    if (obj1.listp() && cpl.length == 1)
    172       setInstanceSlotValue(symClassPrecedenceList, obj1);
     191      setInstanceSlotValue(symPrecedenceList, obj1);
    173192    else
    174193      {
     
    177196        for (int i = cpl.length; i-- > 0;)
    178197            l = new Cons(cpl[i], l);
    179         setInstanceSlotValue(symClassPrecedenceList, l);
     198        setInstanceSlotValue(symPrecedenceList, l);
    180199      }
    181200  }
     
    253272  }
    254273
    255 
     274  @Override
     275  public LispObject typeOf()
     276  {
     277    return Symbol.STANDARD_CLASS;
     278  }
    256279
    257280  @Override
     
    298321  }
    299322
     323  private static final LispObject standardClassSlotDefinitions()
     324  {
     325      // (CONSTANTLY NIL)
     326    Function initFunction = new Function() {
     327      @Override
     328      public LispObject execute()
     329      {
     330         return NIL;
     331      }
     332    };
     333
     334    return
     335        list(helperMakeSlotDefinition("NAME", initFunction),
     336             helperMakeSlotDefinition("LAYOUT", initFunction),
     337             helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction),
     338             helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction),
     339             helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction),
     340             helperMakeSlotDefinition("DIRECT-METHODS", initFunction),
     341             helperMakeSlotDefinition("DIRECT-SLOTS", initFunction),
     342             helperMakeSlotDefinition("SLOTS", initFunction),
     343             helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction),
     344             helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction),
     345             helperMakeSlotDefinition("FINALIZED-P", initFunction));
     346  }
     347
     348
     349
     350  private static final SlotDefinition helperMakeSlotDefinition(String name,
     351                                                               Function init)
     352  {
     353    return
     354        new SlotDefinition(PACKAGE_MOP.intern(name),   // name
     355             list(PACKAGE_MOP.intern("CLASS-" + name)), // readers
     356             init);
     357  }
     358
    300359  private static final StandardClass addStandardClass(Symbol name,
    301360                                                      LispObject directSuperclasses)
     
    322381
    323382    STANDARD_CLASS.setClassLayout(layoutStandardClass);
    324     STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions());
     383    STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
    325384  }
    326385
     
    617676
    618677    // Condition classes.
     678    STANDARD_CLASS.finalizeClass();
    619679    ARITHMETIC_ERROR.finalizeClass();
    620680    CELL_ERROR.finalizeClass();
  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r12513 r12576  
    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());
  • trunk/abcl/src/org/armedbear/lisp/StandardMethod.java

    r12481 r12576  
    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());
  • trunk/abcl/src/org/armedbear/lisp/StandardObject.java

    r12513 r12576  
    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      {
    119147        // TYPE-OF.9
    120         final LispObject c2 = LispClass.findClass(checkSymbol(name));
     148        final LispObject c2 = LispClass.findClass(name, false);
    121149        if (c2 == c1)
    122150          return name;
     
    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;
  • trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java

    r12290 r12576  
    4848          return new StandardClass();
    4949        if (arg instanceof StandardClass)
    50                 return ((StandardClass)arg).allocateInstance();
     50            return ((StandardClass)arg).allocateInstance();
     51        if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
     52            Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg);
     53            return new StandardObject(layout);
     54        }
    5155        return type_error(arg, Symbol.STANDARD_CLASS);
    5256      }
  • trunk/abcl/src/org/armedbear/lisp/Symbol.java

    r12515 r12576  
    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);
     
    29222929
    29232930  // MOP.
     2931  public static final Symbol CLASS_LAYOUT =
     2932    PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT");
     2933  public static final Symbol CLASS_PRECEDENCE_LIST =
     2934    PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST");
    29242935  public static final Symbol STANDARD_READER_METHOD =
    29252936    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");
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12516 r12576  
    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)
     
    254289;;; finalize-inheritance
    255290
     291(defun std-compute-class-default-initargs (class)
     292  (mapcan #'(lambda (c)
     293              (copy-list
     294               (class-direct-default-initargs c)))
     295          (class-precedence-list class)))
     296
    256297(defun std-finalize-inheritance (class)
    257   (set-class-precedence-list
    258    class
     298  (setf (class-precedence-list class)
    259299   (funcall (if (eq (class-of class) (find-class 'standard-class))
    260300                #'std-compute-class-precedence-list
    261301                #'compute-class-precedence-list)
    262302            class))
    263   (dolist (class (%class-precedence-list class))
     303  (dolist (class (class-precedence-list class))
    264304    (when (typep class 'forward-referenced-class)
    265305      (return-from std-finalize-inheritance)))
    266   (set-class-slots class
     306  (setf (class-slots class)
    267307                   (funcall (if (eq (class-of class) (find-class 'standard-class))
    268308                                #'std-compute-slots
    269                                 #'compute-slots)
    270                             class))
     309                     #'compute-slots) class))
    271310  (let ((old-layout (class-layout class))
    272311        (length 0)
    273312        (instance-slots '())
    274313        (shared-slots '()))
    275     (dolist (slot (%class-slots class))
     314    (dolist (slot (class-slots class))
    276315      (case (%slot-definition-allocation slot)
    277316        (:instance
     
    293332               (old-location (layout-slot-location old-layout slot-name)))
    294333          (unless old-location
    295             (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name))
     334            (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
    296335                   (initfunction (%slot-definition-initfunction slot-definition)))
    297336              (when initfunction
     
    299338    (setf (class-layout class)
    300339          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
    301   (setf (class-default-initargs class) (compute-class-default-initargs class))
     340  (setf (class-default-initargs class)
     341        (std-compute-class-default-initargs class))
    302342  (setf (class-finalized-p class) t))
    303343
     
    393433(defun std-compute-slots (class)
    394434  (let* ((all-slots (mapappend #'class-direct-slots
    395                                (%class-precedence-list class)))
     435                               (class-precedence-list class)))
    396436         (all-names (remove-duplicates
    397437                     (mapcar #'%slot-definition-name all-slots))))
     
    432472
    433473(defun find-slot-definition (class slot-name)
    434   (dolist (slot (%class-slots class) nil)
     474  (dolist (slot (class-slots class) nil)
    435475    (when (eq slot-name (%slot-definition-name slot))
    436476      (return slot))))
     
    482522
    483523(defun std-slot-exists-p (instance slot-name)
    484   (not (null (find slot-name (%class-slots (class-of instance))
     524  (not (null (find slot-name (class-slots (class-of instance))
    485525                   :key #'%slot-definition-name))))
    486526
     
    500540  (declare (ignore metaclass))
    501541  (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) ())
     542    (%set-class-name name class)
     543    (%set-class-layout nil class)
     544    (%set-class-direct-subclasses ()  class)
     545    (%set-class-direct-methods ()  class)
    505546    (%set-class-documentation class documentation)
    506547    (std-after-initialization-for-classes class
     
    538579  (getf canonical-slot :name))
    539580
    540 (defun ensure-class (name &rest all-keys &allow-other-keys)
     581(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
    541582  ;; Check for duplicate slots.
     583  (remf all-keys :metaclass)
    542584  (let ((slots (getf all-keys :direct-slots)))
    543585    (dolist (s1 slots)
     
    564606        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
    565607  (let ((old-class (find-class name nil)))
    566     (cond ((and old-class (eq name (%class-name old-class)))
     608    (cond ((and old-class (eq name (class-name old-class)))
    567609           (cond ((typep old-class 'built-in-class)
    568610                  (error "The symbol ~S names a built-in class." name))
     
    583625                  old-class)))
    584626          (t
    585            (let ((class (apply #'make-instance-standard-class
    586                                (find-class 'standard-class)
     627           (let ((class (apply (if metaclass
     628                                   #'make-instance
     629                                   #'make-instance-standard-class)
     630                               (or metaclass
     631                                   (find-class 'standard-class))
    587632                               :name name all-keys)))
    588633             (%set-find-class name class)
     
    832877          gf)
    833878        (progn
    834           (when (fboundp function-name)
     879          (when (and (null *clos-booting*)
     880                     (fboundp function-name))
    835881            (error 'program-error
    836882                   :format-control "~A already names an ordinary function, macro, or special operator."
     
    17811827                   )))
    17821828
    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))
     1829(defmacro redefine-class-forwarder (name slot &optional alternative-name)
     1830  (let* (($name (if (consp name) (cadr name) name))
     1831         (%name (intern (concatenate 'string
     1832                                     "%"
     1833                                     (if (consp name)
     1834                                         (symbol-name 'set-) "")
     1835                                     (symbol-name $name))
     1836                        (find-package "SYS"))))
     1837    (unless alternative-name
     1838      (setf alternative-name name))
     1839    (if (consp name)
     1840        `(progn ;; setter
     1841           (defgeneric ,alternative-name (new-value class))
     1842           (defmethod ,alternative-name (new-value (class built-in-class))
     1843             (,%name new-value class))
     1844           (defmethod ,alternative-name (new-value (class forward-referenced-class))
     1845             (,%name new-value class))
     1846           (defmethod ,alternative-name (new-value (class structure-class))
     1847             (,%name new-value class))
     1848           (defmethod ,alternative-name (new-value (class standard-class))
     1849             (setf (slot-value class ',slot) new-value))
     1850           ,@(unless (eq name alternative-name)
     1851                     `((setf (get ',$name 'SETF-FUNCTION)
     1852                             (symbol-function ',alternative-name))))
     1853           )
     1854        `(progn ;; getter
     1855           (defgeneric ,alternative-name (class))
     1856           (defmethod ,alternative-name ((class built-in-class))
     1857             (,%name class))
     1858           (defmethod ,alternative-name ((class forward-referenced-class))
     1859             (,%name class))
     1860           (defmethod ,alternative-name ((class structure-class))
     1861             (,%name class))
     1862           (defmethod ,alternative-name ((class standard-class))
     1863             (slot-value class ',slot))
     1864           ,@(unless (eq name alternative-name)
     1865                     `((setf (symbol-function ',$name)
     1866                             (symbol-function ',alternative-name))))
     1867           ) )))
     1868
     1869(redefine-class-forwarder class-name name)
     1870(redefine-class-forwarder (setf class-name) name)
     1871(redefine-class-forwarder class-slots slots)
     1872(redefine-class-forwarder (setf class-slots) slots)
     1873(redefine-class-forwarder class-direct-slots direct-slots)
     1874(redefine-class-forwarder (setf class-direct-slots) direct-slots)
     1875(redefine-class-forwarder class-layout layout)
     1876(redefine-class-forwarder (setf class-layout) layout)
     1877(redefine-class-forwarder class-direct-superclasses direct-superclasses)
     1878(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
     1879(redefine-class-forwarder class-direct-subclasses direct-subclasses)
     1880(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
     1881(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
     1882(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
     1883(redefine-class-forwarder class-precedence-list precedence-list)
     1884(redefine-class-forwarder (setf class-precedence-list) precedence-list)
     1885(redefine-class-forwarder class-finalized-p finalized-p)
     1886(redefine-class-forwarder (setf class-finalized-p) finalized-p)
     1887(redefine-class-forwarder class-default-initargs default-initargs)
     1888(redefine-class-forwarder (setf class-default-initargs) default-initargs)
     1889(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
     1890(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
    18031891
    18041892
     
    19512039
    19522040(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
    1953   (dolist (dsd (%class-slots class))
     2041  (dolist (dsd (class-slots class))
    19542042    (when (eq (sys::dsd-name dsd) slot-name)
    19552043      (return-from slot-exists-p-using-class t)))
     
    19872075(defmethod allocate-instance ((class structure-class) &rest initargs)
    19882076  (declare (ignore initargs))
    1989   (%make-structure (%class-name class)
    1990                    (make-list (length (%class-slots class))
     2077  (%make-structure (class-name class)
     2078                   (make-list (length (class-slots class))
    19912079                              :initial-element +slot-unbound+)))
    19922080
     
    20132101     `(,instance ,@initargs)
    20142102         (list instance)))))
    2015     (slots (%class-slots (class-of instance))))
     2103    (slots (class-slots (class-of instance))))
    20162104      (do* ((tail initargs (cddr tail))
    20172105            (initarg (car tail) (car tail)))
     
    20962184       :format-control "Invalid initarg ~S."
    20972185       :format-arguments (list initarg))))
    2098   (dolist (slot (%class-slots (class-of instance)))
     2186  (dolist (slot (class-slots (class-of instance)))
    20992187    (let ((slot-name (%slot-definition-name slot)))
    21002188      (multiple-value-bind (init-key init-value foundp)
     
    21212209(defmethod change-class ((old-instance standard-object) (new-class standard-class)
    21222210                         &rest initargs)
    2123   (let ((old-slots (%class-slots (class-of old-instance)))
    2124         (new-slots (%class-slots new-class))
     2211  (let ((old-slots (class-slots (class-of old-instance)))
     2212        (new-slots (class-slots new-class))
    21252213        (new-instance (allocate-instance new-class)))
    21262214    ;; "The values of local slots specified by both the class CTO and the class
     
    21542242                       (slot-exists-p old slot-name))
    21552243                    (mapcar #'%slot-definition-name
    2156                             (%class-slots (class-of new))))))
     2244                            (class-slots (class-of new))))))
    21572245    (check-initargs new added-slots initargs)
    21582246    (apply #'shared-initialize new added-slots initargs)))
     
    23412429(defmethod make-load-form ((class class) &optional environment)
    23422430  (declare (ignore environment))
    2343   (let ((name (%class-name class)))
     2431  (let ((name (class-name class)))
    23442432    (unless (and name (eq (find-class name nil) class))
    23452433      (error 'simple-type-error
     
    23562444    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
    23572445
     2446(fmakunbound 'no-applicable-method)
    23582447(defgeneric no-applicable-method (generic-function &rest args))
    23592448
     
    23942483(defgeneric function-keywords (method))
    23952484
     2485(setf *clos-booting* nil)
     2486
    23962487(defgeneric class-prototype (class))
    23972488
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12516 r12576  
    34033403                    (CHAR=              p2-test-char=)
    34043404                    (CHARACTERP         p2-test-characterp)
    3405                     (CLASSP             p2-test-classp)
    34063405                    (CONSP              p2-test-consp)
    34073406                    (CONSTANTP          p2-test-constantp)
     
    35433542(defun p2-test-special-variable-p (form)
    35443543  (p2-test-predicate form "isSpecialVariable"))
    3545 
    3546 (defun p2-test-classp (form)
    3547   (p2-test-instanceof-predicate form +lisp-class-class+))
    35483544
    35493545(defun p2-test-symbolp (form)
     
    48274823(defun p2-characterp (form target representation)
    48284824  (p2-instanceof-predicate form target representation +lisp-character-class+))
    4829 
    4830 (defun p2-classp (form target representation)
    4831   (p2-instanceof-predicate form target representation +lisp-class-class+))
    48324825
    48334826(defun p2-consp (form target representation)
     
    88758868  (install-p2-handler 'char=               'p2-char=)
    88768869  (install-p2-handler 'characterp          'p2-characterp)
    8877   (install-p2-handler 'classp              'p2-classp)
    88788870  (install-p2-handler 'coerce-to-function  'p2-coerce-to-function)
    88798871  (install-p2-handler 'cons                'p2-cons)
Note: See TracChangeset for help on using the changeset viewer.