Changeset 13541


Ignore:
Timestamp:
08/27/11 23:23:24 (10 years ago)
Author:
Mark Evenson
Message:

Convert docstrings and primitives to standard conventions.

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

Legend:

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

    r12576 r13541  
    177177    }
    178178
    179     // ### class-direct-slots
    180     private static final Primitive CLASS_DIRECT_SLOTS =
    181         new Primitive("%class-direct-slots", PACKAGE_SYS, true)
    182     {
     179    @DocString(name="%class-direct-slots")
     180    private static final Primitive CLASS_DIRECT_SLOTS
     181        = new pf__class_direct_slots();
     182    private static final class pf__class_direct_slots extends Primitive
     183    {
     184        pf__class_direct_slots()
     185        {
     186            super("%class-direct-slots", PACKAGE_SYS, true);
     187        }
    183188        @Override
    184189        public LispObject execute(LispObject arg)
     
    193198    };
    194199
    195     // ### %set-class-direct-slots
    196     private static final Primitive _SET_CLASS_DIRECT_SLOTS =
    197         new Primitive("%set-class-direct-slots", PACKAGE_SYS, true)
    198     {
     200    @DocString(name="%set-class-direct-slots")
     201    private static final Primitive _SET_CLASS_DIRECT_SLOT
     202        = new pf__set_class_direct_slots();
     203    private static final class pf__set_class_direct_slots extends Primitive
     204    {
     205        pf__set_class_direct_slots()
     206        {
     207            super("%set-class-direct-slots", PACKAGE_SYS, true);
     208        }
     209
    199210        @Override
    200211        public LispObject execute(LispObject first, LispObject second)
    201 
    202         {
    203                 if (second instanceof SlotClass) {
     212        {
     213            if (second instanceof SlotClass) {
    204214                  ((SlotClass)second).setDirectSlotDefinitions(first);
    205215                return first;
    206             }
    207                 else {
     216            } else {
    208217                return type_error(second, Symbol.STANDARD_CLASS);
    209218            }
     
    211220    };
    212221
    213     // ### %class-slots
    214     private static final Primitive _CLASS_SLOTS =
    215         new Primitive(Symbol._CLASS_SLOTS, "class")
    216     {
     222    @DocString(name="%class-slots",
     223               args="class")
     224    private static final Primitive _CLASS_SLOTS
     225        = new pf__class_slots();
     226    private static final class pf__class_slots extends Primitive
     227    {
     228        pf__class_slots()
     229        {
     230            super(Symbol._CLASS_SLOTS, "class");
     231        }
     232
    217233        @Override
    218234        public LispObject execute(LispObject arg)
    219 
    220235        {
    221236            if (arg instanceof SlotClass)
     
    227242    };
    228243
    229     // ### set-class-slots
    230     private static final Primitive _SET_CLASS_SLOTS =
    231         new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions")
    232     {
     244    @DocString(name="%set-class-slots",
     245               args="class slot-definitions")
     246    private static final Primitive _SET_CLASS_SLOTS
     247        = new pf__set_class_slots();
     248    private static final class pf__set_class_slots extends Primitive
     249    {
     250        pf__set_class_slots()
     251        {
     252            super(Symbol._SET_CLASS_SLOTS, "class slot-definitions");
     253        }
    233254        @Override
    234255        public LispObject execute(LispObject first, LispObject second)
    235 
    236256        {
    237257            if (second instanceof SlotClass) {
    238258              ((SlotClass)second).setSlotDefinitions(first);
    239259              return first;
    240             }
    241             else {
     260            } else {
    242261              return type_error(second, Symbol.STANDARD_CLASS);
    243262            }
     
    245264    };
    246265
    247     // ### class-direct-default-initargs
    248     private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS =
    249         new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true)
    250     {
     266    @DocString(name="%class-direct-default-initargs")
     267    private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS
     268        = new pf__class_direct_default_initargs();
     269    private static final class pf__class_direct_default_initargs extends Primitive
     270    {
     271        pf__class_direct_default_initargs()
     272        {
     273            super("%class-direct-default-initargs", PACKAGE_SYS, true);
     274        }
    251275        @Override
    252276        public LispObject execute(LispObject arg)
    253 
    254277        {
    255278            if (arg instanceof SlotClass)
     
    261284    };
    262285
    263     // ### %set-class-direct-default-initargs
    264     private static final Primitive _SET_CLASS_DIRECT_DEFAULT_INITARGS =
    265         new Primitive("%set-class-direct-default-initargs", PACKAGE_SYS, true)
    266     {
     286    @DocString(name="%set-class-direct-default-initargs")
     287    private static final Primitive _SET_CLASS_DIRECT_DEFAULT_INITARGS
     288        = new pf__set_class_direct_default_initargs();
     289    private static final class pf__set_class_direct_default_initargs extends Primitive
     290    {
     291        pf__set_class_direct_default_initargs()
     292        {
     293            super("%set-class-direct-default-initargs", PACKAGE_SYS, true);
     294        }
    267295        @Override
    268296        public LispObject execute(LispObject first, LispObject second)
    269 
    270297        {
    271298            if (second instanceof SlotClass) {
    272               ((SlotClass)second).setDirectDefaultInitargs(first);
    273               return first;
     299                ((SlotClass)second).setDirectDefaultInitargs(first);
     300                return first;
    274301            }
    275302            return type_error(second, Symbol.STANDARD_CLASS);
     
    277304    };
    278305
    279     // ### class-default-initargs
    280     private static final Primitive CLASS_DEFAULT_INITARGS =
    281         new Primitive("%class-default-initargs", PACKAGE_SYS, true)
    282     {
     306    @DocString(name="%class-default-initargs")
     307    private static final Primitive CLASS_DEFAULT_INITARGS
     308        = new pf__class_default_initargs();
     309    private static final class pf__class_default_initargs extends Primitive
     310    {
     311        pf__class_default_initargs()
     312        {
     313            super("%class-default-initargs", PACKAGE_SYS, true);
     314        }
    283315        @Override
    284316        public LispObject execute(LispObject arg)
    285 
    286317        {
    287318            if (arg instanceof SlotClass)
     
    293324    };
    294325
    295     // ### %set-class-default-initargs
    296     private static final Primitive _SET_CLASS_DEFAULT_INITARGS =
    297         new Primitive("%set-class-default-initargs", PACKAGE_SYS, true)
    298     {
     326    @DocString(name="%set-class-default-initargs")
     327    private static final Primitive _SET_CLASS_DEFAULT_INITARGS
     328        = new pf__set_class_default_initargs();
     329
     330    private static final class pf__set_class_default_initargs extends Primitive
     331    {
     332        pf__set_class_default_initargs()
     333        {
     334            super("%set-class-default-initargs", PACKAGE_SYS, true);
     335        }
    299336        @Override
    300337        public LispObject execute(LispObject first, LispObject second)
    301 
    302338        {
    303339            if (second instanceof SlotClass) {
     
    308344        }
    309345    };
    310 
    311346}
  • trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

    r13440 r13541  
    130130  }
    131131
    132   // ### make-slot-definition &optional class
    133   private static final Primitive MAKE_SLOT_DEFINITION =
    134     new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class")
    135     {
    136       @Override
    137       public LispObject execute()
    138       {
    139         return new SlotDefinition();
    140       }
    141       @Override
    142       public LispObject execute(LispObject slotDefinitionClass)
    143       {
    144           return new SlotDefinition((StandardClass) slotDefinitionClass);
    145       }
    146     };
    147 
    148   // ### %slot-definition-name
    149   private static final Primitive _SLOT_DEFINITION_NAME =
    150     new Primitive(Symbol._SLOT_DEFINITION_NAME, "slot-definition")
    151     {
    152       @Override
    153       public LispObject execute(LispObject arg)
    154       {
    155           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
    156       }
    157     };
    158 
    159   // ### set-slot-definition-name
    160   private static final Primitive SET_SLOT_DEFINITION_NAME =
    161     new Primitive("set-slot-definition-name", PACKAGE_SYS, true,
    162                   "slot-definition name")
    163     {
    164       @Override
    165       public LispObject execute(LispObject first, LispObject second)
    166 
    167       {
    168           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
    169           return second;
    170       }
    171     };
    172 
    173   // ### %slot-definition-initfunction
    174   private static final Primitive _SLOT_DEFINITION_INITFUNCTION =
    175     new Primitive(Symbol._SLOT_DEFINITION_INITFUNCTION, "slot-definition")
    176     {
    177       @Override
    178       public LispObject execute(LispObject arg)
    179       {
    180           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
    181       }
    182     };
    183 
    184   // ### set-slot-definition-initfunction
    185   static final Primitive SET_SLOT_DEFINITION_INITFUNCTION =
    186     new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true,
    187                   "slot-definition initfunction")
    188     {
    189       @Override
    190       public LispObject execute(LispObject first, LispObject second)
    191 
    192       {
    193           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
    194           return second;
    195       }
    196     };
    197 
    198   // ### %slot-definition-initform
    199   private static final Primitive _SLOT_DEFINITION_INITFORM =
    200     new Primitive("%slot-definition-initform", PACKAGE_SYS, true,
    201                   "slot-definition")
    202     {
    203       @Override
    204       public LispObject execute(LispObject arg)
    205       {
    206           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
    207       }
    208     };
    209 
    210   // ### set-slot-definition-initform
    211   static final Primitive SET_SLOT_DEFINITION_INITFORM =
    212     new Primitive("set-slot-definition-initform", PACKAGE_SYS, true,
    213                   "slot-definition initform")
    214     {
    215       @Override
    216       public LispObject execute(LispObject first, LispObject second)
    217 
    218       {
    219           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
    220           return second;
    221       }
    222     };
    223 
    224   // ### %slot-definition-initargs
    225   private static final Primitive _SLOT_DEFINITION_INITARGS =
    226     new Primitive(Symbol._SLOT_DEFINITION_INITARGS, "slot-definition")
    227     {
    228       @Override
    229       public LispObject execute(LispObject arg)
    230       {
    231           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
    232       }
    233     };
    234 
    235   // ### set-slot-definition-initargs
    236   private static final Primitive SET_SLOT_DEFINITION_INITARGS =
    237     new Primitive("set-slot-definition-initargs", PACKAGE_SYS, true,
    238                   "slot-definition initargs")
    239     {
    240       @Override
    241       public LispObject execute(LispObject first, LispObject second)
    242 
    243       {
    244           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
    245           return second;
    246       }
    247     };
    248 
    249   // ### %slot-definition-readers
    250   private static final Primitive _SLOT_DEFINITION_READERS =
    251     new Primitive("%slot-definition-readers", PACKAGE_SYS, true,
    252                   "slot-definition")
    253     {
    254       @Override
    255       public LispObject execute(LispObject arg)
    256       {
    257           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
    258       }
    259     };
    260 
    261   // ### set-slot-definition-readers
    262   private static final Primitive SET_SLOT_DEFINITION_READERS =
    263     new Primitive("set-slot-definition-readers", PACKAGE_SYS, true,
    264                   "slot-definition readers")
    265     {
    266       @Override
    267       public LispObject execute(LispObject first, LispObject second)
    268 
    269       {
    270           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
    271           return second;
    272       }
    273     };
    274 
    275   // ### %slot-definition-writers
    276   private static final Primitive _SLOT_DEFINITION_WRITERS =
    277     new Primitive("%slot-definition-writers", PACKAGE_SYS, true,
    278                   "slot-definition")
    279     {
    280       @Override
    281       public LispObject execute(LispObject arg)
    282       {
    283           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
    284       }
    285     };
    286 
    287   // ### set-slot-definition-writers
    288   private static final Primitive SET_SLOT_DEFINITION_WRITERS =
    289     new Primitive("set-slot-definition-writers", PACKAGE_SYS, true,
    290                   "slot-definition writers")
    291     {
    292       @Override
    293       public LispObject execute(LispObject first, LispObject second)
    294 
    295       {
    296           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
    297           return second;
    298       }
    299     };
    300 
    301   // ### %slot-definition-allocation
    302   private static final Primitive _SLOT_DEFINITION_ALLOCATION =
    303     new Primitive("%slot-definition-allocation", PACKAGE_SYS, true,
    304                   "slot-definition")
    305     {
    306       @Override
    307       public LispObject execute(LispObject arg)
    308       {
    309           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
    310       }
    311     };
    312 
    313   // ### set-slot-definition-allocation
    314   private static final Primitive SET_SLOT_DEFINITION_ALLOCATION =
    315     new Primitive("set-slot-definition-allocation", PACKAGE_SYS, true,
    316                   "slot-definition allocation")
    317     {
    318       @Override
    319       public LispObject execute(LispObject first, LispObject second)
    320 
    321       {
    322           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
    323           return second;
    324       }
    325     };
    326 
    327   // ### %slot-definition-allocation-class
    328   private static final Primitive _SLOT_DEFINITION_ALLOCATION_CLASS =
    329     new Primitive("%slot-definition-allocation-class", PACKAGE_SYS, true,
    330                   "slot-definition")
    331     {
    332       @Override
    333       public LispObject execute(LispObject arg)
    334       {
    335           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
    336       }
    337     };
    338 
    339   // ### set-slot-definition-allocation-class
    340   private static final Primitive SET_SLOT_DEFINITION_ALLOCATION_CLASS =
    341     new Primitive("set-slot-definition-allocation-class", PACKAGE_SYS, true,
    342                   "slot-definition allocation-class")
    343     {
    344       @Override
    345       public LispObject execute(LispObject first, LispObject second)
    346 
    347       {
    348           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
    349           return second;
    350       }
    351     };
    352 
    353   // ### %slot-definition-location
    354   private static final Primitive _SLOT_DEFINITION_LOCATION =
    355     new Primitive("%slot-definition-location", PACKAGE_SYS, true, "slot-definition")
    356     {
    357       @Override
    358       public LispObject execute(LispObject arg)
    359       {
    360           return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
    361       }
    362     };
    363 
    364   // ### set-slot-definition-location
    365   private static final Primitive SET_SLOT_DEFINITION_LOCATION =
    366     new Primitive("set-slot-definition-location", PACKAGE_SYS, true, "slot-definition location")
    367     {
    368       @Override
    369       public LispObject execute(LispObject first, LispObject second)
    370 
    371       {
    372           checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
    373           return second;
    374       }
    375     };
     132  private static final Primitive MAKE_SLOT_DEFINITION
     133    = new pf_make_slot_definition();
     134  @DocString(name="make-slot-definition",
     135             args="&optional class")
     136  private static final class pf_make_slot_definition extends Primitive
     137  {
     138    pf_make_slot_definition()
     139    {
     140      super("make-slot-definition", PACKAGE_SYS, true, "&optional class");
     141    }
     142    @Override
     143    public LispObject execute()
     144    {
     145      return new SlotDefinition();
     146    }
     147    @Override
     148    public LispObject execute(LispObject slotDefinitionClass)
     149    {
     150      return new SlotDefinition((StandardClass) slotDefinitionClass);
     151    }
     152  };
     153
     154  private static final Primitive _SLOT_DEFINITION_NAME
     155    = new pf__slot_definition_name();
     156  @DocString(name="%slot-definition-name")
     157  private static final class pf__slot_definition_name extends Primitive
     158  {
     159    pf__slot_definition_name()
     160    {
     161      super(Symbol._SLOT_DEFINITION_NAME, "slot-definition");
     162    }
     163    @Override
     164    public LispObject execute(LispObject arg)
     165    {
     166      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];
     167    }
     168  };
     169
     170  private static final Primitive SET_SLOT_DEFINITION_NAME
     171    = new pf_set_slot_definition_name();
     172  @DocString(name="set-slot-definition-name",
     173             args="slot-definition name")
     174  private static final class pf_set_slot_definition_name extends Primitive
     175  {
     176    pf_set_slot_definition_name()
     177    {
     178      super("set-slot-definition-name", PACKAGE_SYS, true,
     179            "slot-definition name");
     180    }
     181    @Override
     182    public LispObject execute(LispObject first, LispObject second)
     183    {
     184      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;
     185      return second;
     186    }
     187  };
     188
     189  private static final Primitive _SLOT_DEFINITION_INITFUNCTION
     190    = new pf__slot_definition_initfunction();
     191  @DocString(name="%slot-definition-initfunction")
     192  private static final class pf__slot_definition_initfunction extends Primitive
     193  {
     194    pf__slot_definition_initfunction()
     195    {
     196      super(Symbol._SLOT_DEFINITION_INITFUNCTION, "slot-definition");
     197    }
     198    @Override
     199    public LispObject execute(LispObject arg)
     200    {
     201      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];
     202    }
     203  };
     204
     205  static final Primitive SET_SLOT_DEFINITION_INITFUNCTION
     206    = new pf_set_slot_definition_initfunction();
     207  @DocString(name="set-slot-definition-initfunction",
     208             args="slot-definition initfunction")
     209  static final class pf_set_slot_definition_initfunction extends Primitive
     210  {
     211    pf_set_slot_definition_initfunction()
     212    {
     213      super("set-slot-definition-initfunction", PACKAGE_SYS, true,
     214            "slot-definition initfunction");
     215    }
     216    @Override
     217    public LispObject execute(LispObject first, LispObject second)
     218    {
     219      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;
     220      return second;
     221    }
     222  };
     223
     224  private static final Primitive _SLOT_DEFINITION_INITFORM
     225    = new pf__slot_definition_initform();
     226  @DocString(name="%slot-definition-initform",
     227             args="slot-definition")
     228  private static final class pf__slot_definition_initform extends Primitive
     229  {
     230    pf__slot_definition_initform()
     231    {
     232      super("%slot-definition-initform", PACKAGE_SYS, true,
     233            "slot-definition");
     234    }
     235    @Override
     236    public LispObject execute(LispObject arg)
     237    {
     238      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];
     239    }
     240  };
     241
     242  static final Primitive SET_SLOT_DEFINITION_INITFORM
     243    = new pf_set_slot_definition_initform();
     244  @DocString(name="set-slot-definition-initform",
     245             args="slot-definition initform")
     246  static final class pf_set_slot_definition_initform extends Primitive
     247  {
     248    pf_set_slot_definition_initform()
     249    {
     250      super("set-slot-definition-initform", PACKAGE_SYS, true,
     251            "slot-definition initform");
     252    }
     253    @Override
     254    public LispObject execute(LispObject first, LispObject second)
     255    {
     256      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;
     257      return second;
     258    }
     259  };
     260
     261  private static final Primitive _SLOT_DEFINITION_INITARGS
     262    = new pf__slot_definition_initargs();
     263  @DocString(name="%slot-definition-initargs")
     264  private static final class pf__slot_definition_initargs extends Primitive
     265  {
     266    pf__slot_definition_initargs()
     267    {
     268      super(Symbol._SLOT_DEFINITION_INITARGS, "slot-definition");
     269    }
     270    @Override
     271    public LispObject execute(LispObject arg)
     272    {
     273      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];
     274    }
     275  };
     276
     277  private static final Primitive SET_SLOT_DEFINITION_INITARGS
     278    = new pf_set_slot_definition_initargs();
     279  @DocString(name="set-slot-definition-initargs",
     280             args="slot-definition initargs")
     281  private static final class pf_set_slot_definition_initargs extends Primitive
     282  {
     283    pf_set_slot_definition_initargs()
     284    {
     285      super("set-slot-definition-initargs", PACKAGE_SYS, true,
     286            "slot-definition initargs");
     287    }
     288    @Override
     289    public LispObject execute(LispObject first, LispObject second)
     290    {
     291      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;
     292      return second;
     293    }
     294  };
     295
     296  private static final Primitive _SLOT_DEFINITION_READERS
     297    = new pf__slot_definition_readers();
     298  @DocString(name="%slot-definition-readers",
     299             args="slot-definition")
     300  private static final class pf__slot_definition_readers extends Primitive {
     301    pf__slot_definition_readers()
     302    {
     303      super("%slot-definition-readers", PACKAGE_SYS, true,
     304            "slot-definition");
     305    }
     306    @Override
     307    public LispObject execute(LispObject arg)
     308    {
     309      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];
     310    }
     311  };
     312
     313  private static final Primitive SET_SLOT_DEFINITION_READERS
     314    = new pf_set_slot_definition_readers();
     315  @DocString(name="set-slot-definition-readers",
     316             args="slot-definition readers")
     317  private static final class pf_set_slot_definition_readers extends Primitive
     318  {
     319    pf_set_slot_definition_readers()
     320    {
     321      super("set-slot-definition-readers", PACKAGE_SYS, true,
     322            "slot-definition readers");
     323    }
     324    @Override
     325    public LispObject execute(LispObject first, LispObject second)
     326    {
     327      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;
     328      return second;
     329    }
     330  };
     331
     332  private static final Primitive _SLOT_DEFINITION_WRITERS
     333    = new pf__slot_definition_writers();
     334  @DocString(name="%slot-definition-writers",
     335             args="slot-definition")
     336  private static final class pf__slot_definition_writers extends Primitive
     337  {
     338    pf__slot_definition_writers()
     339    {
     340      super("%slot-definition-writers", PACKAGE_SYS, true,
     341            "slot-definition");
     342    }
     343    @Override
     344    public LispObject execute(LispObject arg)
     345    {
     346      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];
     347    }
     348  };
     349
     350  private static final Primitive SET_SLOT_DEFINITION_WRITERS
     351    = new pf_set_slot_definition_writers();
     352  @DocString(name="set-slot-definition-writers",
     353             args="slot-definition writers")
     354  private static final class pf_set_slot_definition_writers extends Primitive
     355  {
     356    pf_set_slot_definition_writers()
     357    {
     358      super("set-slot-definition-writers", PACKAGE_SYS, true,
     359            "slot-definition writers");
     360    }
     361    @Override
     362    public LispObject execute(LispObject first, LispObject second)
     363    {
     364      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;
     365      return second;
     366    }
     367  };
     368
     369  private static final Primitive _SLOT_DEFINITION_ALLOCATION
     370    = new pf__slot_definition_allocation();
     371  @DocString(name="%slot-definition-allocation",
     372             args="slot-definition")
     373  private static final class pf__slot_definition_allocation extends Primitive
     374  {
     375    pf__slot_definition_allocation()
     376    {
     377      super("%slot-definition-allocation", PACKAGE_SYS, true,
     378            "slot-definition");
     379    }
     380    @Override
     381    public LispObject execute(LispObject arg)
     382    {
     383      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];
     384    }
     385  };
     386
     387  private static final Primitive SET_SLOT_DEFINITION_ALLOCATION
     388    = new pf_set_slot_definition_allocation();
     389  @DocString(name="set-slot-definition-allocation",
     390             args="slot-definition allocation")
     391  private static final class pf_set_slot_definition_allocation extends Primitive
     392  {
     393    pf_set_slot_definition_allocation()
     394    {
     395      super("set-slot-definition-allocation", PACKAGE_SYS, true,
     396            "slot-definition allocation");
     397    }
     398    @Override
     399    public LispObject execute(LispObject first, LispObject second)
     400    {
     401      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;
     402      return second;
     403    }
     404  };
     405
     406  private static final Primitive _SLOT_DEFINITION_ALLOCATION_CLASS
     407    = new pf__slot_definition_allocation_class();
     408  @DocString(name="%slot-definition-allocation-class",
     409             args="slot-definition")
     410  private static final class pf__slot_definition_allocation_class extends Primitive
     411  {
     412    pf__slot_definition_allocation_class()
     413    {
     414      super("%slot-definition-allocation-class", PACKAGE_SYS, true,
     415            "slot-definition");
     416    }
     417    @Override
     418    public LispObject execute(LispObject arg)
     419    {
     420      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];
     421    }
     422  };
     423
     424  private static final Primitive SET_SLOT_DEFINITION_ALLOCATION_CLASS
     425    = new pf_set_slot_definition_allocation_class();
     426  @DocString(name="set-slot-definition-allocation-class",
     427             args="slot-definition allocation-class")
     428  private static final class pf_set_slot_definition_allocation_class extends Primitive
     429  {
     430    pf_set_slot_definition_allocation_class()
     431    {
     432      super("set-slot-definition-allocation-class", PACKAGE_SYS, true,
     433            "slot-definition allocation-class");
     434    }
     435    @Override
     436    public LispObject execute(LispObject first, LispObject second)
     437    {
     438      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;
     439      return second;
     440    }
     441  };
     442
     443  private static final Primitive _SLOT_DEFINITION_LOCATION
     444    = new pf__slot_definition_location();
     445  @DocString(name="%slot-definition-location")
     446  private static final class pf__slot_definition_location extends Primitive
     447  {
     448    pf__slot_definition_location()
     449    {
     450      super("%slot-definition-location", PACKAGE_SYS, true, "slot-definition");
     451    }
     452    @Override
     453    public LispObject execute(LispObject arg)
     454    {
     455      return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];
     456    }
     457  };
     458
     459  private static final Primitive SET_SLOT_DEFINITION_LOCATION
     460    = new pf_set_slot_definition_location();
     461  @DocString(name="set-slot-definition-location",
     462             args="slot-definition location")
     463  private static final class pf_set_slot_definition_location extends Primitive
     464  {
     465    pf_set_slot_definition_location()
     466    {
     467      super("set-slot-definition-location", PACKAGE_SYS, true,
     468            "slot-definition location");
     469    }
     470    @Override
     471    public LispObject execute(LispObject first, LispObject second)
     472    {
     473      checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;
     474      return second;
     475    }
     476  };
    376477}
  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r13440 r13541  
    247247  }
    248248
    249     @Override
    250     public final int getHotCount()
    251     {
    252         return hotCount;
    253     }
    254 
    255     @Override
    256     public void setHotCount(int n)
    257     {
    258         hotCount = n;
    259     }
    260 
    261     @Override
    262     public final void incrementHotCount()
    263     {
    264         ++hotCount;
    265     }
    266 
    267     // AMOP (p. 216) specifies the following readers as generic functions:
     249  @Override
     250  public final int getHotCount()
     251  {
     252    return hotCount;
     253  }
     254
     255  @Override
     256  public void setHotCount(int n)
     257  {
     258    hotCount = n;
     259  }
     260
     261  @Override
     262  public final void incrementHotCount()
     263  {
     264    ++hotCount;
     265  }
     266
     267  // AMOP (p. 216) specifies the following readers as generic functions:
    268268  //   generic-function-argument-precedence-order
    269269  //   generic-function-declarations
     
    274274  //   generic-function-name
    275275
    276   // ### %generic-function-name
    277   private static final Primitive _GENERIC_FUNCTION_NAME =
    278     new Primitive("%generic-function-name", PACKAGE_SYS, true)
    279     {
    280       @Override
    281       public LispObject execute(LispObject arg)
    282       {
    283           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME];
    284       }
    285     };
    286 
    287   // ### %set-generic-function-name
    288   private static final Primitive _SET_GENERIC_FUNCTION_NAME =
    289     new Primitive("%set-generic-function-name", PACKAGE_SYS, true)
    290     {
    291       @Override
    292       public LispObject execute(LispObject first, LispObject second)
    293 
    294       {
    295           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second;
    296           return second;
    297       }
    298     };
    299 
    300   // ### %generic-function-lambda-list
    301   private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST =
    302     new Primitive("%generic-function-lambda-list", PACKAGE_SYS, true)
    303     {
    304       @Override
    305       public LispObject execute(LispObject arg)
    306       {
    307           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST];
    308       }
    309     };
    310 
    311   // ### %set-generic-function-lambdaList
    312   private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST =
    313     new Primitive("%set-generic-function-lambda-list", PACKAGE_SYS, true)
    314     {
    315       @Override
    316       public LispObject execute(LispObject first, LispObject second)
    317 
    318       {
    319           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second;
    320           return second;
    321       }
    322     };
    323 
    324   // ### funcallable-instance-function funcallable-instance => function
    325   private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION =
    326     new Primitive("funcallable-instance-function", PACKAGE_MOP, false,
    327                   "funcallable-instance")
    328     {
    329       @Override
    330       public LispObject execute(LispObject arg)
    331 
    332       {
    333           return checkStandardGenericFunction(arg).function;
    334       }
    335     };
    336 
    337   // ### set-funcallable-instance-function funcallable-instance function => unspecified
     276  private static final Primitive _GENERIC_FUNCTION_NAME
     277    = new pf__generic_function_name();
     278  @DocString(name="%generic-function-name")
     279  private static final class pf__generic_function_name extends Primitive
     280  {
     281    pf__generic_function_name()
     282    {
     283      super("%generic-function-name", PACKAGE_SYS, true);
     284    }
     285    @Override
     286    public LispObject execute(LispObject arg)
     287    {
     288      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME];
     289    }
     290  };
     291
     292  private static final Primitive _SET_GENERIC_FUNCTION_NAME
     293    = new pf__set_generic_function_name();
     294  @DocString(name="%set-generic-function-name")
     295  private static final class pf__set_generic_function_name extends Primitive
     296  {
     297    pf__set_generic_function_name()
     298    {
     299      super ("%set-generic-function-name", PACKAGE_SYS, true);
     300    }
     301    @Override
     302    public LispObject execute(LispObject first, LispObject second)
     303    {
     304      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second;
     305      return second;
     306    }
     307  };
     308
     309  private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST
     310    = new pf__generic_function_lambda_list();
     311  @DocString(name ="%generic-function-lambda-list")
     312  private static final class pf__generic_function_lambda_list extends Primitive {
     313    pf__generic_function_lambda_list()
     314    {
     315      super("%generic-function-lambda-list", PACKAGE_SYS, true);
     316    }
     317    @Override
     318    public LispObject execute(LispObject arg)
     319    {
     320      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST];
     321    }
     322  };
     323
     324  private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST
     325    = new pf__set_generic_function_lambda_list();
     326  @DocString(name="%set-generic-function-lambdalist")
     327  private static final class pf__set_generic_function_lambda_list extends Primitive
     328  {
     329    pf__set_generic_function_lambda_list()
     330    {
     331      super("%set-generic-function-lambda-list", PACKAGE_SYS, true);
     332    }
     333    @Override
     334    public LispObject execute(LispObject first, LispObject second)
     335    {
     336      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second;
     337      return second;
     338    }
     339  };
     340
     341  private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION
     342    = new pf_funcallable_instance_function();
     343  @DocString(name="funcallable-instance-function",
     344             args="funcallable-instance",
     345             returns="function")
     346  private static final class pf_funcallable_instance_function extends Primitive
     347  {
     348    pf_funcallable_instance_function()
     349    {
     350      super("funcallable-instance-function", PACKAGE_MOP, false,
     351            "funcallable-instance");
     352    }
     353    @Override
     354    public LispObject execute(LispObject arg)
     355    {
     356      return checkStandardGenericFunction(arg).function;
     357    }
     358  };
     359
    338360  // AMOP p. 230
    339   private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION =
    340     new Primitive("set-funcallable-instance-function", PACKAGE_MOP, true,
    341                   "funcallable-instance function")
    342     {
    343       @Override
    344       public LispObject execute(LispObject first, LispObject second)
    345 
    346       {
    347           checkStandardGenericFunction(first).function = second;
    348           return second;
    349       }
    350     };
    351 
    352   // ### gf-required-args
    353   private static final Primitive GF_REQUIRED_ARGS =
    354     new Primitive("gf-required-args", PACKAGE_SYS, true)
    355     {
    356       @Override
    357       public LispObject execute(LispObject arg)
    358       {
    359           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS];
    360       }
    361     };
    362 
    363   // ### %set-gf-required-args
    364   private static final Primitive _SET_GF_REQUIRED_ARGS =
    365     new Primitive("%set-gf-required-args", PACKAGE_SYS, true)
    366     {
    367       @Override
    368       public LispObject execute(LispObject first, LispObject second)
    369 
    370       {
    371         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    372         gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second;
    373         gf.numberOfRequiredArgs = second.length();
    374         return second;
    375       }
    376     };
    377 
    378   // ### generic-function-initial-methods
    379   private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS =
    380     new Primitive("generic-function-initial-methods", PACKAGE_SYS, true)
    381     {
    382       @Override
    383       public LispObject execute(LispObject arg)
    384       {
    385           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS];
    386       }
    387     };
    388 
    389   // ### set-generic-function-initial-methods
    390   private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS =
    391     new Primitive("set-generic-function-initial-methods", PACKAGE_SYS, true)
    392     {
    393       @Override
    394       public LispObject execute(LispObject first, LispObject second)
    395 
    396       {
    397           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second;
    398           return second;
    399       }
    400     };
    401 
    402   // ### generic-function-methods
    403   private static final Primitive GENERIC_FUNCTION_METHODS =
    404     new Primitive("generic-function-methods", PACKAGE_SYS, true)
    405     {
    406       @Override
    407       public LispObject execute(LispObject arg)
    408       {
    409           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS];
    410       }
    411     };
    412 
    413   // ### set-generic-function-methods
    414   private static final Primitive SET_GENERIC_FUNCTION_METHODS =
    415     new Primitive("set-generic-function-methods", PACKAGE_SYS, true)
    416     {
    417       @Override
    418       public LispObject execute(LispObject first, LispObject second)
    419 
    420       {
    421           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second;
    422           return second;
    423       }
    424     };
    425 
    426   // ### generic-function-method-class
    427   private static final Primitive GENERIC_FUNCTION_METHOD_CLASS =
    428     new Primitive("generic-function-method-class", PACKAGE_SYS, true)
    429     {
    430       @Override
    431       public LispObject execute(LispObject arg)
    432       {
    433           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS];
    434       }
    435     };
    436 
    437   // ### set-generic-function-method-class
    438   private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS =
    439     new Primitive("set-generic-function-method-class", PACKAGE_SYS, true)
    440     {
    441       @Override
    442       public LispObject execute(LispObject first, LispObject second)
    443 
    444       {
    445           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second;
    446           return second;
    447       }
    448     };
    449 
    450   // ### generic-function-method-combination
    451   private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION =
    452     new Primitive("generic-function-method-combination", PACKAGE_SYS, true)
    453     {
    454       @Override
    455       public LispObject execute(LispObject arg)
    456       {
    457           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION];
    458       }
    459     };
    460 
    461   // ### set-generic-function-method-combination
    462   private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION =
    463     new Primitive("set-generic-function-method-combination", PACKAGE_SYS, true)
    464     {
    465       @Override
    466       public LispObject execute(LispObject first, LispObject second)
    467 
    468       {
    469           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]
    470       = second;
    471           return second;
    472       }
    473     };
    474 
    475   // ### generic-function-argument-precedence-order
    476   private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER =
    477     new Primitive("generic-function-argument-precedence-order", PACKAGE_SYS, true)
    478     {
    479       @Override
    480       public LispObject execute(LispObject arg)
    481       {
    482           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass
    483                .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER];
    484       }
    485     };
    486 
    487   // ### set-generic-function-argument-precedence-order
    488   private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER =
    489     new Primitive("set-generic-function-argument-precedence-order", PACKAGE_SYS, true)
    490     {
    491       @Override
    492       public LispObject execute(LispObject first, LispObject second)
    493 
    494       {
    495           checkStandardGenericFunction(first)
    496       .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second;
    497           return second;
    498       }
    499     };
    500 
    501   // ### generic-function-classes-to-emf-table
    502   private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE =
    503     new Primitive("generic-function-classes-to-emf-table", PACKAGE_SYS, true)
    504     {
    505       @Override
    506       public LispObject execute(LispObject arg)
    507       {
    508           return checkStandardGenericFunction(arg)
    509       .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE];
    510       }
    511     };
    512 
    513   // ### set-generic-function-classes-to-emf-table
    514   private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE =
    515     new Primitive("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true)
    516     {
    517       @Override
    518       public LispObject execute(LispObject first, LispObject second)
    519 
    520       {
    521           checkStandardGenericFunction(first)
    522       .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second;
    523           return second;
    524       }
    525     };
    526 
    527   // ### generic-function-documentation
    528   private static final Primitive GENERIC_FUNCTION_DOCUMENTATION =
    529     new Primitive("generic-function-documentation", PACKAGE_SYS, true)
    530     {
    531       @Override
    532       public LispObject execute(LispObject arg)
    533       {
    534           return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION];
    535       }
    536     };
    537 
    538   // ### set-generic-function-documentation
    539   private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION =
    540     new Primitive("set-generic-function-documentation", PACKAGE_SYS, true)
    541     {
    542       @Override
    543       public LispObject execute(LispObject first, LispObject second)
    544 
    545       {
    546           checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]
    547       = second;
    548           return second;
    549       }
    550     };
    551 
    552   // ### %finalize-generic-function
    553   private static final Primitive _FINALIZE_GENERIC_FUNCTION =
    554     new Primitive("%finalize-generic-function", PACKAGE_SYS, true,
    555                   "generic-function")
    556     {
    557       @Override
    558       public LispObject execute(LispObject arg)
    559       {
    560           final StandardGenericFunction gf = checkStandardGenericFunction(arg);
    561           gf.finalizeInternal();       
    562           return T;
    563       }
    564     };
    565 
    566   // ### cache-emf
    567   private static final Primitive CACHE_EMF =
    568     new Primitive("cache-emf", PACKAGE_SYS, true, "generic-function args emf")
    569     {
    570       @Override
    571       public LispObject execute(LispObject first, LispObject second,
    572                                 LispObject third)
    573 
    574       {
    575         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    576         LispObject args = second;
    577         LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
    578         for (int i = gf.numberOfRequiredArgs; i-- > 0;)
    579           {
    580             array[i] = gf.getArgSpecialization(args.car());
    581             args = args.cdr();
    582           }
    583         CacheEntry specializations = new CacheEntry(array);
    584         ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
    585         if (ht == null)
    586             ht = gf.cache = new ConcurrentHashMap<CacheEntry,LispObject>();
    587         ht.put(specializations, third);
    588         return third;
    589       }
    590     };
    591 
    592   // ### get-cached-emf
    593   private static final Primitive GET_CACHED_EMF =
    594     new Primitive("get-cached-emf", PACKAGE_SYS, true, "generic-function args")
    595     {
    596       @Override
    597       public LispObject execute(LispObject first, LispObject second)
    598 
    599       {
    600         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    601         LispObject args = second;
    602         LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
    603         for (int i = gf.numberOfRequiredArgs; i-- > 0;)
    604           {
    605             array[i] = gf.getArgSpecialization(args.car());
    606             args = args.cdr();
    607           }
    608         CacheEntry specializations = new CacheEntry(array);
    609         ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
    610         if (ht == null)
    611           return NIL;
    612         LispObject emf = (LispObject) ht.get(specializations);
    613         return emf != null ? emf : NIL;
    614       }
    615     };
     361  private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION
     362    = new pf_set_funcallable_instance_function();
     363  @DocString(name="set-funcallable-instance-function",
     364             args="funcallable-instance function",
     365             returns="unspecified")
     366  private static final class pf_set_funcallable_instance_function extends Primitive
     367  {
     368    pf_set_funcallable_instance_function()
     369    {
     370      super("set-funcallable-instance-function", PACKAGE_MOP, true,
     371            "funcallable-instance function");
     372    }
     373    @Override
     374    public LispObject execute(LispObject first, LispObject second)
     375    {
     376      checkStandardGenericFunction(first).function = second;
     377      return second;
     378    }
     379  };
     380
     381  private static final Primitive GF_REQUIRED_ARGS
     382    = new pf_gf_required_args();
     383  @DocString(name="gf-required-args")
     384  private static final class pf_gf_required_args extends Primitive
     385  {
     386    pf_gf_required_args()
     387    {
     388      super("gf-required-args", PACKAGE_SYS, true);
     389    }
     390    @Override
     391    public LispObject execute(LispObject arg)
     392    {
     393      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS];
     394    }
     395  };
     396
     397  private static final Primitive _SET_GF_REQUIRED_ARGS
     398    = new pf__set_gf_required_args();
     399  @DocString(name="%set-gf-required-args")
     400  private static final class pf__set_gf_required_args extends Primitive
     401  {
     402    pf__set_gf_required_args()
     403    {
     404      super("%set-gf-required-args", PACKAGE_SYS, true);
     405    }
     406    @Override
     407    public LispObject execute(LispObject first, LispObject second)
     408    {
     409      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     410      gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second;
     411      gf.numberOfRequiredArgs = second.length();
     412      return second;
     413    }
     414  };
     415
     416  private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS
     417    = new pf_generic_function_initial_methods();
     418  @DocString(name="generic-function-initial-methods")
     419  private static final class pf_generic_function_initial_methods extends Primitive
     420  {
     421    pf_generic_function_initial_methods()
     422    {
     423      super("generic-function-initial-methods", PACKAGE_SYS, true);
     424    }
     425    @Override
     426    public LispObject execute(LispObject arg)
     427    {
     428      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS];
     429    }
     430  };
     431
     432  private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS
     433    = new pf_set_generic_function_initial_methods();
     434  @DocString(name="set-generic-function-initial-methods")
     435  private static final class pf_set_generic_function_initial_methods extends Primitive
     436  {
     437    pf_set_generic_function_initial_methods()
     438    {
     439      super("set-generic-function-initial-methods", PACKAGE_SYS, true);
     440    }
     441    @Override
     442    public LispObject execute(LispObject first, LispObject second)
     443    {
     444      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second;
     445      return second;
     446    }
     447  };
     448
     449  private static final Primitive GENERIC_FUNCTION_METHODS
     450    = new pf_generic_function_methods();
     451  @DocString(name="generic-function-methods")
     452  private static final class pf_generic_function_methods extends Primitive
     453  {
     454    pf_generic_function_methods()
     455    {
     456      super("generic-function-methods", PACKAGE_SYS, true);
     457    }
     458    @Override
     459    public LispObject execute(LispObject arg)
     460    {
     461      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS];
     462    }
     463  };
     464
     465  private static final Primitive SET_GENERIC_FUNCTION_METHODS
     466    = new pf_set_generic_function_methods();
     467  @DocString(name="set-generic-function-methods")
     468  private static final class pf_set_generic_function_methods extends Primitive
     469  {
     470    pf_set_generic_function_methods()
     471    {
     472      super("set-generic-function-methods", PACKAGE_SYS, true);
     473    }
     474    @Override
     475    public LispObject execute(LispObject first, LispObject second)
     476    {
     477      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second;
     478      return second;
     479    }
     480  };
     481
     482  private static final Primitive GENERIC_FUNCTION_METHOD_CLASS
     483    = new pf_generic_function_method_class();
     484  @DocString(name="generic-function-method-class")
     485  private static final class pf_generic_function_method_class extends Primitive
     486  {
     487    pf_generic_function_method_class()
     488    {
     489      super("generic-function-method-class", PACKAGE_SYS, true);
     490    }
     491    @Override
     492    public LispObject execute(LispObject arg)
     493    {
     494      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS];
     495    }
     496  };
     497
     498  private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS
     499    = new pf_set_generic_function_method_class();
     500  @DocString(name="set-generic-function-method-class")
     501  private static final class pf_set_generic_function_method_class extends Primitive
     502  {
     503    pf_set_generic_function_method_class()
     504    {
     505      super("set-generic-function-method-class", PACKAGE_SYS, true);
     506    }
     507    @Override
     508    public LispObject execute(LispObject first, LispObject second)
     509    {
     510      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second;
     511      return second;
     512    }
     513  };
     514
     515  private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION
     516    = new pf_generic_function_method_combination();
     517  @DocString(name="generic-function-method-combination")
     518  private static final class pf_generic_function_method_combination extends Primitive
     519  {
     520    pf_generic_function_method_combination()
     521    {
     522      super("generic-function-method-combination", PACKAGE_SYS, true);
     523    }
     524    @Override
     525    public LispObject execute(LispObject arg)
     526    {
     527      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION];
     528    }
     529  };
     530
     531  private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION
     532    = new pf_set_generic_function_method_combination();
     533  @DocString(name="set-generic-function-method-combination")
     534  private static final class pf_set_generic_function_method_combination extends Primitive
     535  {
     536    pf_set_generic_function_method_combination()
     537    {
     538      super("set-generic-function-method-combination", PACKAGE_SYS, true);
     539    }
     540    @Override
     541    public LispObject execute(LispObject first, LispObject second)
     542    {
     543      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]
     544        = second;
     545      return second;
     546    }
     547  };
     548
     549  private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER
     550    = new pf_generic_function_argument_precedence_order();
     551  @DocString(name="generic-function-argument-precedence-order")
     552  private static final class pf_generic_function_argument_precedence_order extends Primitive
     553  {
     554    pf_generic_function_argument_precedence_order()
     555    {
     556      super("generic-function-argument-precedence-order", PACKAGE_SYS, true);
     557    }
     558    @Override
     559    public LispObject execute(LispObject arg)
     560    {
     561      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass
     562                                                     .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER];
     563    }
     564  };
     565
     566  private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER
     567    = new pf_set_generic_function_argument_precedence_order();
     568  @DocString(name="set-generic-function-argument-precedence-order")
     569  private static final class pf_set_generic_function_argument_precedence_order extends Primitive
     570  {
     571    pf_set_generic_function_argument_precedence_order()
     572    {
     573      super("set-generic-function-argument-precedence-order", PACKAGE_SYS, true);
     574    }
     575    @Override
     576    public LispObject execute(LispObject first, LispObject second)
     577    {
     578      checkStandardGenericFunction(first)
     579        .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second;
     580      return second;
     581    }
     582  };
     583
     584  private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE
     585    = new pf_generic_function_classes_to_emf_table();
     586  @DocString(name="generic-function-classes-to-emf-table")
     587  private static final class pf_generic_function_classes_to_emf_table extends Primitive
     588  {
     589    pf_generic_function_classes_to_emf_table()
     590    {
     591      super("generic-function-classes-to-emf-table", PACKAGE_SYS, true);
     592    }
     593    @Override
     594    public LispObject execute(LispObject arg)
     595    {
     596      return checkStandardGenericFunction(arg)
     597        .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE];
     598    }
     599  };
     600
     601  private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE
     602    = new pf_set_generic_function_classes_to_emf_table();
     603  @DocString(name="set-generic-function-classes-to-emf-table")
     604  private static final class pf_set_generic_function_classes_to_emf_table extends Primitive
     605  {
     606    pf_set_generic_function_classes_to_emf_table()
     607    {
     608      super("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true);
     609    }
     610    @Override
     611    public LispObject execute(LispObject first, LispObject second)
     612    {
     613      checkStandardGenericFunction(first)
     614        .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second;
     615      return second;
     616    }
     617  };
     618
     619  private static final Primitive GENERIC_FUNCTION_DOCUMENTATION
     620    = new pf_generic_function_documentation();
     621  @DocString(name="generic-function-documentation")
     622  private static final class pf_generic_function_documentation extends Primitive
     623  {
     624    pf_generic_function_documentation()
     625    {
     626      super("generic-function-documentation", PACKAGE_SYS, true);
     627    }
     628    @Override
     629    public LispObject execute(LispObject arg)
     630    {
     631      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION];
     632    }
     633  };
     634
     635  private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION
     636    = new pf_set_generic_function_documentation();
     637  @DocString(name="set-generic-function-documentation")
     638  private static final class pf_set_generic_function_documentation extends Primitive
     639  {
     640    pf_set_generic_function_documentation()
     641    {
     642      super("set-generic-function-documentation", PACKAGE_SYS, true);
     643    }
     644    @Override
     645    public LispObject execute(LispObject first, LispObject second)
     646    {
     647      checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]
     648        = second;
     649      return second;
     650    }
     651  };
     652
     653  private static final Primitive _FINALIZE_GENERIC_FUNCTION
     654    = new pf__finalize_generic_function();
     655  @DocString(name="%finalize-generic-function",
     656             args="generic-function")
     657  private static final class  pf__finalize_generic_function extends Primitive
     658  {
     659    pf__finalize_generic_function()
     660    {
     661      super("%finalize-generic-function", PACKAGE_SYS, true,
     662            "generic-function");
     663    }
     664    @Override
     665    public LispObject execute(LispObject arg)
     666    {
     667      final StandardGenericFunction gf = checkStandardGenericFunction(arg);
     668      gf.finalizeInternal();       
     669      return T;
     670    }
     671  };
     672
     673  private static final Primitive CACHE_EMF
     674    = new pf_cache_emf();
     675  @DocString(name="cache-emf",
     676             args="generic-function args emf")
     677  private static final class pf_cache_emf extends Primitive
     678  {
     679    pf_cache_emf()
     680    {
     681      super("cache-emf", PACKAGE_SYS, true, "generic-function args emf");
     682    }
     683    @Override
     684    public LispObject execute(LispObject first, LispObject second,
     685                              LispObject third)
     686    {
     687      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     688      LispObject args = second;
     689      LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
     690      for (int i = gf.numberOfRequiredArgs; i-- > 0;)
     691        {
     692          array[i] = gf.getArgSpecialization(args.car());
     693          args = args.cdr();
     694        }
     695      CacheEntry specializations = new CacheEntry(array);
     696      ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
     697      if (ht == null)
     698        ht = gf.cache = new ConcurrentHashMap<CacheEntry,LispObject>();
     699      ht.put(specializations, third);
     700      return third;
     701    }
     702  };
     703
     704  private static final Primitive GET_CACHED_EMF
     705    = new pf_get_cached_emf();
     706  @DocString(name="get-cached-emf",
     707             args="generic-function args")
     708  private static final class pf_get_cached_emf extends Primitive
     709  {
     710    pf_get_cached_emf() {
     711      super("get-cached-emf", PACKAGE_SYS, true, "generic-function args");
     712    }
     713    @Override
     714    public LispObject execute(LispObject first, LispObject second)
     715    {
     716      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     717      LispObject args = second;
     718      LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
     719      for (int i = gf.numberOfRequiredArgs; i-- > 0;)
     720        {
     721          array[i] = gf.getArgSpecialization(args.car());
     722          args = args.cdr();
     723        }
     724      CacheEntry specializations = new CacheEntry(array);
     725      ConcurrentHashMap<CacheEntry,LispObject> ht = gf.cache;
     726      if (ht == null)
     727        return NIL;
     728      LispObject emf = (LispObject) ht.get(specializations);
     729      return emf != null ? emf : NIL;
     730    }
     731  };
    616732
    617733  /**
     
    681797  }
    682798
    683   // ### %get-arg-specialization
    684   private static final Primitive _GET_ARG_SPECIALIZATION =
    685     new Primitive("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg")
    686     {
    687       @Override
    688       public LispObject execute(LispObject first, LispObject second)
    689 
    690       {
    691         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    692         return gf.getArgSpecialization(second);
    693       }
    694     };
    695 
    696   // ### cache-slot-location
    697   private static final Primitive CACHE_SLOT_LOCATION =
    698     new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location")
    699     {
    700       @Override
    701       public LispObject execute(LispObject first, LispObject second,
     799  private static final Primitive _GET_ARG_SPECIALIZATION
     800    = new pf__get_arg_specialization();
     801  @DocString(name="%get-arg-specialization",
     802             args="generic-function arg")
     803  private static final class pf__get_arg_specialization extends Primitive
     804  {
     805    pf__get_arg_specialization()
     806    {
     807      super("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg");
     808    }
     809    @Override
     810    public LispObject execute(LispObject first, LispObject second)
     811    {
     812      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     813      return gf.getArgSpecialization(second);
     814    }
     815  };
     816
     817  private static final Primitive CACHE_SLOT_LOCATION
     818    = new pf_cache_slot_location();
     819  @DocString(name="cache-slot-location",
     820           args="generic-function layout location")
     821  private static final class pf_cache_slot_location extends Primitive
     822  {
     823    pf_cache_slot_location()
     824    {
     825      super("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location");
     826    }
     827    @Override
     828    public LispObject execute(LispObject first, LispObject second,
    702829                                LispObject third)
    703 
    704       {
    705         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    706         LispObject layout = second;
    707         LispObject location = third;
    708         ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
    709         if (ht == null)
    710           ht = gf.slotCache = new ConcurrentHashMap<LispObject,LispObject>();
    711         ht.put(layout, location);
    712         return third;
    713       }
    714     };
    715 
    716   // ### get-cached-slot-location
    717   private static final Primitive GET_CACHED_SLOT_LOCATION =
    718     new Primitive("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout")
    719     {
    720       @Override
    721       public LispObject execute(LispObject first, LispObject second)
    722 
    723       {
    724         final StandardGenericFunction gf = checkStandardGenericFunction(first);
    725         LispObject layout = second;
    726         ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
    727         if (ht == null)
    728           return NIL;
    729         LispObject location = (LispObject) ht.get(layout);
    730         return location != null ? location : NIL;
    731       }
    732     };
     830    {
     831      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     832      LispObject layout = second;
     833      LispObject location = third;
     834      ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
     835      if (ht == null)
     836        ht = gf.slotCache = new ConcurrentHashMap<LispObject,LispObject>();
     837      ht.put(layout, location);
     838      return third;
     839    }
     840  };
     841
     842  private static final Primitive GET_CACHED_SLOT_LOCATION
     843    = new pf_get_cached_slot_location();
     844  @DocString(name="get-cached-slot-location")
     845  private static final class pf_get_cached_slot_location extends Primitive
     846  {
     847    pf_get_cached_slot_location()
     848    {
     849      super("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout");
     850    }
     851    @Override
     852    public LispObject execute(LispObject first, LispObject second)
     853    {
     854      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     855      LispObject layout = second;
     856      ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
     857      if (ht == null)
     858        return NIL;
     859      LispObject location = (LispObject) ht.get(layout);
     860      return location != null ? location : NIL;
     861    }
     862  };
    733863
    734864  private static final StandardGenericFunction GENERIC_FUNCTION_NAME =
     
    776906  EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
    777907
    778     // ### %init-eql-specializations
    779     private static final Primitive _INIT_EQL_SPECIALIZATIONS
    780       = new Primitive("%init-eql-specializations", PACKAGE_SYS, true,
    781         "generic-function eql-specilizer-objects-list")
    782       {
    783         @Override
    784         public LispObject execute(LispObject first, LispObject second)
    785 
    786         {
    787           final StandardGenericFunction gf = checkStandardGenericFunction(first);
    788           LispObject eqlSpecializerObjects = second;
    789           gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
    790           for (int i = 0; i < gf.eqlSpecializations.length; i++) {
    791       gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
    792       eqlSpecializerObjects = eqlSpecializerObjects.cdr();
    793           }
    794           return NIL;
    795         }
    796       };
     908  private static final Primitive _INIT_EQL_SPECIALIZATIONS 
     909    = new pf__init_eql_specializations();
     910  @DocString(name="%init-eql-specializations",
     911             args="generic-function eql-specilizer-objects-list")
     912  private static final class pf__init_eql_specializations extends Primitive
     913  {
     914    pf__init_eql_specializations()
     915    {
     916      super("%init-eql-specializations", PACKAGE_SYS, true,
     917            "generic-function eql-specilizer-objects-list");
     918    }
     919    @Override
     920    public LispObject execute(LispObject first, LispObject second)
     921    {
     922      final StandardGenericFunction gf = checkStandardGenericFunction(first);
     923      LispObject eqlSpecializerObjects = second;
     924      gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
     925      for (int i = 0; i < gf.eqlSpecializations.length; i++) {
     926        gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
     927        eqlSpecializerObjects = eqlSpecializerObjects.cdr();
     928      }
     929      return NIL;
     930    }
     931  };
    797932
    798933  private static class EqlSpecialization extends LispObject
     
    807942 
    808943  public static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
    809 
    810944  {
    811945    if (obj instanceof StandardGenericFunction)
  • trunk/abcl/src/org/armedbear/lisp/StandardMethod.java

    r13440 r13541  
    6464  }
    6565
    66   // ### method-lambda-list
    67   // generic function
    68   private static final Primitive METHOD_LAMBDA_LIST =
    69     new Primitive("method-lambda-list", PACKAGE_SYS, true, "method")
    70     {
    71       @Override
    72       public LispObject execute(LispObject arg)
    73       {
    74           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST];
    75       }
    76     };
    77 
    78   // ### set-method-lambda-list
    79   private static final Primitive SET_METHOD_LAMBDA_LIST =
    80     new Primitive("set-method-lambda-list", PACKAGE_SYS, true,
    81                   "method lambda-list")
    82     {
    83       @Override
    84       public LispObject execute(LispObject first, LispObject second)
    85 
    86       {
    87           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second;
    88           return second;
    89       }
    90     };
    91 
    92   // ### method-qualifiers
    93   private static final Primitive _METHOD_QUALIFIERS =
    94     new Primitive("%method-qualifiers", PACKAGE_SYS, true, "method")
    95     {
    96       @Override
    97       public LispObject execute(LispObject arg)
    98       {
    99           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS];
    100       }
    101     };
    102 
    103   // ### set-method-qualifiers
    104   private static final Primitive SET_METHOD_QUALIFIERS =
    105     new Primitive("set-method-qualifiers", PACKAGE_SYS, true,
    106                   "method qualifiers")
    107     {
    108       @Override
    109       public LispObject execute(LispObject first, LispObject second)
    110 
    111       {         
    112           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = second;
    113           return second;
    114       }
    115     };
    116 
    117   // ### method-documentation
    118   private static final Primitive METHOD_DOCUMENTATION =
    119     new Primitive("method-documentation", PACKAGE_SYS, true, "method")
    120     {
    121       @Override
    122       public LispObject execute(LispObject arg)
    123       {
    124           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION];
    125       }
    126     };
    127 
    128   // ### set-method-documentation
    129   private static final Primitive SET_METHOD_DOCUMENTATION =
    130     new Primitive("set-method-documentation", PACKAGE_SYS, true,
    131                   "method documentation")
    132     {
    133       @Override
    134       public LispObject execute(LispObject first, LispObject second)
    135 
    136       {
    137           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = second;
    138           return second;
    139       }
    140     };
     66  private static final Primitive METHOD_LAMBDA_LIST
     67    = new pf_method_lambda_list();
     68  @DocString(name="method-lambda-list",
     69             args="generic-method")
     70  private static final class pf_method_lambda_list extends Primitive
     71  {
     72    pf_method_lambda_list()
     73    {
     74      super("method-lambda-list", PACKAGE_SYS, true, "generic-method");
     75    }
     76    @Override
     77    public LispObject execute(LispObject arg)
     78    {
     79      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST];
     80    }
     81  };
     82
     83  private static final Primitive SET_METHOD_LAMBDA_LIST
     84    = new pf_set_method_lambda_list();
     85  @DocString(name="set-method-lambda-list",
     86             args="method lambda-list")
     87  private static final class pf_set_method_lambda_list extends Primitive
     88  {
     89    pf_set_method_lambda_list()
     90    {
     91      super("set-method-lambda-list", PACKAGE_SYS, true,
     92            "method lambda-list");
     93    }
     94    @Override
     95    public LispObject execute(LispObject first, LispObject second)
     96    {
     97      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second;
     98      return second;
     99    }
     100  };
     101
     102
     103  private static final Primitive _METHOD_QUALIFIERS
     104    = new gf__method_qualifiers();
     105  @DocString(name="%method-qualifiers",
     106             args="method")
     107  private static final class gf__method_qualifiers extends Primitive
     108  {
     109    gf__method_qualifiers()
     110    {
     111      super("%method-qualifiers", PACKAGE_SYS, true, "method");
     112    }
     113    @Override
     114    public LispObject execute(LispObject arg)
     115    {
     116      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS];
     117    }
     118  };
     119
     120  private static final Primitive SET_METHOD_QUALIFIERS
     121    = new pf_set_method_qualifiers();
     122  @DocString(name="set-method-qualifiers",
     123             args="method qualifiers")
     124  private static final class pf_set_method_qualifiers extends Primitive
     125  {
     126    pf_set_method_qualifiers()
     127    {
     128      super("set-method-qualifiers", PACKAGE_SYS, true,
     129            "method qualifiers");
     130    }
     131    @Override
     132    public LispObject execute(LispObject first, LispObject second)
     133    {         
     134      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = second;
     135      return second;
     136    }
     137  };
     138
     139  private static final Primitive METHOD_DOCUMENTATION
     140    = new pf_method_documentation();
     141  @DocString(name="method-documentation",
     142             args="method")
     143  private static final class pf_method_documentation extends Primitive
     144  {
     145    pf_method_documentation()
     146    {
     147      super("method-documentation", PACKAGE_SYS, true, "method");
     148    }
     149    @Override
     150    public LispObject execute(LispObject arg)
     151    {
     152      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION];
     153    }
     154  };
     155
     156  private static final Primitive SET_METHOD_DOCUMENTATION
     157    = new pf_set_method_documentation();
     158  @DocString(name="set-method-documentation",
     159             args="method documentation")
     160  private static final class pf_set_method_documentation extends Primitive
     161  {
     162    pf_set_method_documentation()
     163    {
     164      super("set-method-documentation", PACKAGE_SYS, true,
     165            "method documentation");
     166    }
     167    @Override
     168    public LispObject execute(LispObject first, LispObject second)
     169    {
     170      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = second;
     171      return second;
     172    }
     173  };
    141174
    142175  public LispObject getFunction()
     
    191224  }
    192225
    193   // ### %method-generic-function
    194   private static final Primitive _METHOD_GENERIC_FUNCTION =
    195     new Primitive("%method-generic-function", PACKAGE_SYS, true)
    196     {
    197       @Override
    198       public LispObject execute(LispObject arg)
    199       {
    200           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION];
    201       }
    202     };
    203 
    204   // ### %set-method-generic-function
    205   private static final Primitive _SET_METHOD_GENERICFUNCTION =
    206     new Primitive("%set-method-generic-function", PACKAGE_SYS, true)
    207     {
    208       @Override
    209       public LispObject execute(LispObject first, LispObject second)
    210 
    211       {
    212           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = second;
    213           return second;
    214       }
    215     };
    216 
    217   // ### %method-function
    218   private static final Primitive _METHOD_FUNCTION =
    219     new Primitive("%method-function", PACKAGE_SYS, true, "method")
    220     {
    221       @Override
    222       public LispObject execute(LispObject arg)
    223       {
     226  private static final Primitive _METHOD_GENERIC_FUNCTION
     227    = new pf__method_generic_function();
     228  @DocString(name="%method-generic-function")
     229  private static final class pf__method_generic_function extends Primitive
     230  {
     231    pf__method_generic_function()
     232    {
     233      super("%method-generic-function", PACKAGE_SYS, true);
     234    }
     235    @Override
     236    public LispObject execute(LispObject arg)
     237    {
     238      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION];
     239    }
     240  };
     241
     242  private static final Primitive _SET_METHOD_GENERICFUNCTION
     243    = new pf__set_method_genericfunction();
     244  @DocString(name="%set-method-generic-function")
     245  private static final class pf__set_method_genericfunction extends Primitive
     246  {
     247    pf__set_method_genericfunction()
     248    {
     249      super("%set-method-generic-function", PACKAGE_SYS, true);
     250    }
     251    @Override
     252    public LispObject execute(LispObject first, LispObject second)
     253    {
     254      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = second;
     255      return second;
     256    }
     257  };
     258
     259  private static final Primitive _METHOD_FUNCTION
     260    = new pf__method_function();
     261  @DocString(name="%method-function")
     262  private static final class pf__method_function extends Primitive
     263  {
     264    pf__method_function()
     265    {
     266      super("%method-function", PACKAGE_SYS, true, "method");
     267    }
     268    @Override
     269    public LispObject execute(LispObject arg)
     270    {
    224271          return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FUNCTION];
    225       }
    226     };
    227 
    228   // ### %set-method-function
    229   private static final Primitive _SET_METHOD_FUNCTION =
    230     new Primitive("%set-method-function", PACKAGE_SYS, true,
    231                   "method function")
    232     {
    233       @Override
    234       public LispObject execute(LispObject first, LispObject second)
    235 
    236       {
    237           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = second;
    238           return second;
    239       }
    240     };
    241 
    242   // ### %method-fast-function
    243   private static final Primitive _METHOD_FAST_FUNCTION =
    244     new Primitive("%method-fast-function", PACKAGE_SYS, true, "method")
    245     {
    246       @Override
    247       public LispObject execute(LispObject arg)
    248       {
    249           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION];
    250       }
    251     };
    252 
    253   // ### %set-method-fast-function
    254   private static final Primitive _SET_METHOD_FAST_FUNCTION =
    255     new Primitive("%set-method-fast-function", PACKAGE_SYS, true,
    256                   "method fast-function")
    257     {
    258       @Override
    259       public LispObject execute(LispObject first, LispObject second)
    260 
    261       {
    262           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = second;
    263           return second;
    264       }
    265     };
    266 
    267   // ### %method-specializers
    268   private static final Primitive _METHOD_SPECIALIZERS =
    269     new Primitive("%method-specializers", PACKAGE_SYS, true, "method")
    270     {
    271       @Override
    272       public LispObject execute(LispObject arg)
    273       {
    274           return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS];
    275       }
    276     };
    277 
    278   // ### %set-method-specializers
    279   private static final Primitive _SET_METHOD_SPECIALIZERS =
    280     new Primitive("%set-method-specializers", PACKAGE_SYS, true,
    281                   "method specializers")
    282     {
    283       @Override
    284       public LispObject execute(LispObject first, LispObject second)
    285 
    286       {
    287           checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = second;
    288           return second;
    289       }
    290     };
     272    }
     273  };
     274
     275  private static final Primitive _SET_METHOD_FUNCTION
     276    = new pf__set_method_function();
     277  @DocString(name="%set-method-function",
     278             args="method function")
     279  private static final class pf__set_method_function extends Primitive
     280  {
     281    pf__set_method_function()
     282    {
     283      super("%set-method-function", PACKAGE_SYS, true,
     284            "method function");
     285    }
     286    @Override
     287    public LispObject execute(LispObject first, LispObject second)
     288    {
     289      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = second;
     290      return second;
     291    }
     292  };
     293
     294  private static final Primitive _METHOD_FAST_FUNCTION
     295    = new pf__method_fast_function();
     296  @DocString(name="%method-fast-function",
     297             args="method")
     298  private static final class pf__method_fast_function extends Primitive
     299  {
     300    pf__method_fast_function()
     301    {
     302      super("%method-fast-function", PACKAGE_SYS, true, "method");
     303    }
     304    @Override
     305    public LispObject execute(LispObject arg)
     306    {
     307      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION];
     308    }
     309  };
     310
     311  private static final Primitive _SET_METHOD_FAST_FUNCTION
     312    = new pf__set_method_fast_function();
     313  @DocString(name="%set-method-fast-function",
     314             args="method fast-function")
     315  private static final class pf__set_method_fast_function extends Primitive
     316  {
     317    pf__set_method_fast_function()
     318    {
     319      super("%set-method-fast-function", PACKAGE_SYS, true,
     320            "method fast-function");
     321    }
     322    @Override
     323    public LispObject execute(LispObject first, LispObject second)
     324    {
     325      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = second;
     326      return second;
     327    }
     328  };
     329
     330  private static final Primitive _METHOD_SPECIALIZERS
     331    = new pf__method_specializers();
     332  @DocString(name="%method-specializers")
     333  private static final class pf__method_specializers extends Primitive
     334  {
     335    pf__method_specializers()
     336    {
     337      super("%method-specializers", PACKAGE_SYS, true, "method");
     338    }
     339    @Override
     340    public LispObject execute(LispObject arg)
     341    {
     342      return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS];
     343    }
     344  };
     345
     346  private static final Primitive _SET_METHOD_SPECIALIZERS
     347    = new pf__set_method_specializers();
     348  @DocString(name="%set-method-specializers",
     349             args="method specializers")
     350  private static final class pf__set_method_specializers extends Primitive
     351  {
     352    pf__set_method_specializers()
     353    {
     354      super("%set-method-specializers", PACKAGE_SYS, true,
     355            "method specializers");
     356    }
     357    @Override
     358    public LispObject execute(LispObject first, LispObject second)
     359    {
     360      checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = second;
     361      return second;
     362    }
     363  };
    291364
    292365  private static final StandardGenericFunction METHOD_SPECIALIZERS =
     
    306379                                list(StandardClass.STANDARD_METHOD));
    307380
    308         final public static StandardMethod checkStandardMethod(LispObject first)
    309         {
    310                 if (first instanceof StandardMethod)
    311                         return (StandardMethod) first;
    312                 return (StandardMethod) type_error(first, Symbol.METHOD);
    313         }
    314 
     381  final public static StandardMethod checkStandardMethod(LispObject first)
     382  {
     383    if (first instanceof StandardMethod)
     384      return (StandardMethod) first;
     385    return (StandardMethod) type_error(first, Symbol.METHOD);
     386  }
    315387}
  • trunk/abcl/src/org/armedbear/lisp/StandardObject.java

    r13440 r13541  
    321321    Debug.assertTrue(layout != null);
    322322    int index = layout.getSlotIndex(slotName);
    323     //### FIXME: should call SLOT-MISSING (clhs)
     323    // FIXME: should call SLOT-MISSING (clhs)
    324324    if (index < 0)
    325325      error(new LispError("Missing slot " + slotName.princToString()));
    326326    slots[index] = newValue;
    327327  }
    328 
    329         final public static StandardObject checkStandardObject(LispObject first)
    330         {
    331                 if (first instanceof StandardObject)
    332                         return (StandardObject) first;
    333                 return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT);
    334         }
     328 
     329  final public static StandardObject checkStandardObject(LispObject first)
     330  {
     331    if (first instanceof StandardObject)
     332      return (StandardObject) first;
     333    return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT);
     334  }
    335335       
    336   // ### swap-slots instance-1 instance-2 => nil
    337   private static final Primitive SWAP_SLOTS =
    338     new Primitive("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2")
    339     {
    340       @Override
    341       public LispObject execute(LispObject first, LispObject second)
    342 
    343       {
    344         final StandardObject obj1 = checkStandardObject(first);
    345         final StandardObject obj2 = checkStandardObject(second);
    346         LispObject[] temp = obj1.slots;
    347         obj1.slots = obj2.slots;
    348         obj2.slots = temp;
    349         return NIL;
    350       }
    351     };
    352 
    353   // ### std-instance-layout
    354   private static final Primitive STD_INSTANCE_LAYOUT =
    355     new Primitive("std-instance-layout", PACKAGE_SYS, true)
    356     {
    357       @Override
    358       public LispObject execute(LispObject arg)
    359       {
    360         final StandardObject instance = checkStandardObject(arg);
    361         Layout layout = instance.layout;
    362         if (layout.isInvalid())
    363           {
    364             // Update instance.
    365             layout = instance.updateLayout();
    366           }
    367         return layout;
    368       }
    369     };
    370 
    371   // ### %set-std-instance-layout
    372   private static final Primitive _SET_STD_INSTANCE_LAYOUT =
    373     new Primitive("%set-std-instance-layout", PACKAGE_SYS, true)
    374     {
    375       @Override
    376       public LispObject execute(LispObject first, LispObject second)
    377 
    378       {
    379           checkStandardObject(first).layout = checkLayout(second);         
    380           return second;
    381       }
    382     };
    383 
    384   // ### std-instance-class
    385   private static final Primitive STD_INSTANCE_CLASS =
    386     new Primitive("std-instance-class", PACKAGE_SYS, true)
    387     {
    388       @Override
    389       public LispObject execute(LispObject arg)
    390       {
    391           return checkStandardObject(arg).layout.getLispClass();
    392       }
    393     };
    394 
    395   // ### standard-instance-access instance location => value
    396   private static final Primitive STANDARD_INSTANCE_ACCESS =
    397     new Primitive("standard-instance-access", PACKAGE_SYS, true,
    398                   "instance location")
    399     {
    400       @Override
    401       public LispObject execute(LispObject first, LispObject second)
    402 
    403       {
    404         final StandardObject instance = checkStandardObject(first);
    405         final int index;
    406         if (second instanceof Fixnum)
    407           {
    408             index = ((Fixnum)second).value;
    409           }
    410         else
    411           {
    412             return type_error(second,
    413                                    list(Symbol.INTEGER, Fixnum.ZERO,
    414                                          Fixnum.getInstance(instance.slots.length)));
    415           }
    416         LispObject value;
    417         try
    418           {
    419             value = instance.slots[index];
    420           }
    421         catch (ArrayIndexOutOfBoundsException e)
    422           {
    423             return type_error(second,
    424                                    list(Symbol.INTEGER, Fixnum.ZERO,
    425                                          Fixnum.getInstance(instance.slots.length)));
    426           }
    427         if (value == UNBOUND_VALUE)
    428           {
    429             LispObject slotName = instance.layout.getSlotNames()[index];
    430             value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(),
    431                                                 instance, slotName);
    432             LispThread.currentThread()._values = null;
    433           }
    434         return value;
    435       }
    436     };
    437 
    438   // ### %set-standard-instance-access instance location new-value => new-value
    439   private static final Primitive _SET_STANDARD_INSTANCE_ACCESS =
    440     new Primitive("%set-standard-instance-access", PACKAGE_SYS, true)
    441     {
    442       @Override
    443       public LispObject execute(LispObject first, LispObject second,
    444                                 LispObject third)
    445 
    446       {
    447           checkStandardObject(first).slots[Fixnum.getValue(second)] = third; // FIXME
    448           return third;
    449       }
    450     };
    451 
    452   // ### std-slot-boundp
    453   private static final Primitive STD_SLOT_BOUNDP =
    454     new Primitive(Symbol.STD_SLOT_BOUNDP, "instance slot-name")
    455     {
    456       @Override
    457       public LispObject execute(LispObject first, LispObject second)
    458 
    459       {
    460         final StandardObject instance = checkStandardObject(first);
    461         Layout layout = instance.layout;
    462         if (layout.isInvalid())
    463           {
    464             // Update instance.
    465             layout = instance.updateLayout();
    466           }
    467         final LispObject index = layout.slotTable.get(second);
    468         if (index != null)
    469           {
    470             // Found instance slot.
    471             return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL;
    472           }
    473         // Check for shared slot.
    474         final LispObject location = layout.getSharedSlotLocation(second);
    475         if (location != null)
    476           return location.cdr() != UNBOUND_VALUE ? T : NIL;
    477         // Not found.
    478         final LispThread thread = LispThread.currentThread();
    479         LispObject value =
    480           thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(),
    481                          instance, second, Symbol.SLOT_BOUNDP);
    482         // "If SLOT-MISSING is invoked and returns a value, a boolean
    483         // equivalent to its primary value is returned by SLOT-BOUNDP."
    484         thread._values = null;
    485         return value != NIL ? T : NIL;
    486       }
    487     };
     336  private static final Primitive SWAP_SLOTS
     337    = new pf_swap_slots();
     338  @DocString(name="swap-slots",
     339             args="instance-1 instance-2",
     340             returns="nil")
     341  private static final class pf_swap_slots extends Primitive
     342  {
     343    pf_swap_slots()
     344    {
     345      super("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2");
     346    }
     347    @Override
     348    public LispObject execute(LispObject first, LispObject second)
     349    {
     350      final StandardObject obj1 = checkStandardObject(first);
     351      final StandardObject obj2 = checkStandardObject(second);
     352      LispObject[] temp = obj1.slots;
     353      obj1.slots = obj2.slots;
     354      obj2.slots = temp;
     355      return NIL;
     356    }
     357  };
     358
     359  private static final Primitive STD_INSTANCE_LAYOUT
     360    = new pf_std_instance_layout();
     361  @DocString(name="std-instance-layout")
     362  private static final class pf_std_instance_layout extends Primitive
     363  {
     364    pf_std_instance_layout()
     365    {
     366      super("std-instance-layout", PACKAGE_SYS, true);
     367    }
     368    @Override
     369    public LispObject execute(LispObject arg)
     370    {
     371      final StandardObject instance = checkStandardObject(arg);
     372      Layout layout = instance.layout;
     373      if (layout.isInvalid())
     374        {
     375          // Update instance.
     376          layout = instance.updateLayout();
     377        }
     378      return layout;
     379    }
     380  };
     381
     382  private static final Primitive _SET_STD_INSTANCE_LAYOUT
     383    = new pf__set_std_instance_layout();
     384  @DocString(name="%set-std-instance-layout")
     385  private static final class pf__set_std_instance_layout extends Primitive
     386  {
     387    pf__set_std_instance_layout()
     388    {
     389      super("%set-std-instance-layout", PACKAGE_SYS, true);
     390    }
     391    @Override
     392    public LispObject execute(LispObject first, LispObject second)
     393    {
     394      checkStandardObject(first).layout = checkLayout(second);         
     395      return second;
     396    }
     397  };
     398
     399  private static final Primitive STD_INSTANCE_CLASS
     400    = new pf_std_instance_class();
     401  @DocString(name="std-instance-class")
     402  private static final class pf_std_instance_class extends Primitive
     403  {
     404    pf_std_instance_class()
     405    {
     406      super("std-instance-class", PACKAGE_SYS, true);
     407    }
     408    @Override
     409    public LispObject execute(LispObject arg)
     410    {
     411      return checkStandardObject(arg).layout.getLispClass();
     412    }
     413  };
     414
     415  private static final Primitive STANDARD_INSTANCE_ACCESS
     416    = new pf_standard_instance_access();
     417  @DocString(name="standard-instance-access",
     418             args="instance location",
     419             returns="value")
     420  private static final class pf_standard_instance_access extends Primitive
     421  {
     422    pf_standard_instance_access()
     423    {
     424      super("standard-instance-access", PACKAGE_SYS, true,
     425            "instance location");
     426    }
     427    @Override
     428    public LispObject execute(LispObject first, LispObject second)
     429    {
     430      final StandardObject instance = checkStandardObject(first);
     431      final int index;
     432      if (second instanceof Fixnum)
     433        {
     434          index = ((Fixnum)second).value;
     435        }
     436      else
     437        {
     438          return type_error(second,
     439                            list(Symbol.INTEGER, Fixnum.ZERO,
     440                                 Fixnum.getInstance(instance.slots.length)));
     441        }
     442      LispObject value;
     443      try
     444        {
     445          value = instance.slots[index];
     446        }
     447      catch (ArrayIndexOutOfBoundsException e)
     448        {
     449          return type_error(second,
     450                            list(Symbol.INTEGER, Fixnum.ZERO,
     451                                 Fixnum.getInstance(instance.slots.length)));
     452        }
     453      if (value == UNBOUND_VALUE)
     454        {
     455          LispObject slotName = instance.layout.getSlotNames()[index];
     456          value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(),
     457                                              instance, slotName);
     458          LispThread.currentThread()._values = null;
     459        }
     460      return value;
     461    }
     462  };
     463
     464  private static final Primitive _SET_STANDARD_INSTANCE_ACCESS
     465    = new pf__set_standard_instance_access();
     466  @DocString(name="%set-standard-instance-access",
     467             args="instance location new-value",
     468             returns="new-value")
     469  private static final class pf__set_standard_instance_access extends Primitive
     470  {
     471    pf__set_standard_instance_access()
     472    {
     473      super("%set-standard-instance-access", PACKAGE_SYS, true);
     474    }
     475    @Override
     476    public LispObject execute(LispObject first, LispObject second,
     477                              LispObject third)
     478    {
     479      checkStandardObject(first).slots[Fixnum.getValue(second)] = third; // FIXME
     480      return third;
     481    }
     482  };
     483
     484  private static final Primitive STD_SLOT_BOUNDP
     485    = new pf_std_slot_boundp();
     486  @DocString(name="std-slot-boundp")
     487  private static final class pf_std_slot_boundp extends Primitive
     488  {
     489    pf_std_slot_boundp()
     490    {
     491      super(Symbol.STD_SLOT_BOUNDP, "instance slot-name");
     492    }
     493    @Override
     494    public LispObject execute(LispObject first, LispObject second)
     495    {
     496      final StandardObject instance = checkStandardObject(first);
     497      Layout layout = instance.layout;
     498      if (layout.isInvalid())
     499        {
     500          // Update instance.
     501          layout = instance.updateLayout();
     502        }
     503      final LispObject index = layout.slotTable.get(second);
     504      if (index != null)
     505        {
     506          // Found instance slot.
     507          return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL;
     508        }
     509      // Check for shared slot.
     510      final LispObject location = layout.getSharedSlotLocation(second);
     511      if (location != null)
     512        return location.cdr() != UNBOUND_VALUE ? T : NIL;
     513      // Not found.
     514      final LispThread thread = LispThread.currentThread();
     515      LispObject value =
     516        thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(),
     517                       instance, second, Symbol.SLOT_BOUNDP);
     518      // "If SLOT-MISSING is invoked and returns a value, a boolean
     519      // equivalent to its primary value is returned by SLOT-BOUNDP."
     520      thread._values = null;
     521      return value != NIL ? T : NIL;
     522    }
     523  };
    488524
    489525  @Override
     
    519555  }
    520556
    521   // ### std-slot-value
    522   private static final Primitive STD_SLOT_VALUE =
    523     new Primitive(Symbol.STD_SLOT_VALUE, "instance slot-name")
    524     {
    525       @Override
    526       public LispObject execute(LispObject first, LispObject second)
    527 
    528       {
    529         return first.SLOT_VALUE(second);
    530       }
    531     };
     557  private static final Primitive STD_SLOT_VALUE
     558    = new pf_std_slot_value();
     559  @DocString(name="std-slot-value")
     560  private static final class pf_std_slot_value extends Primitive
     561  {
     562    pf_std_slot_value()
     563    {
     564      super(Symbol.STD_SLOT_VALUE, "instance slot-name");
     565    }
     566    @Override
     567    public LispObject execute(LispObject first, LispObject second)
     568    {
     569      return first.SLOT_VALUE(second);
     570    }
     571  };
    532572
    533573  @Override
    534574  public void setSlotValue(LispObject slotName, LispObject newValue)
    535 
    536575  {
    537576    if (layout.isInvalid())
     
    563602  }
    564603
    565   // ### set-std-slot-value
    566   private static final Primitive SET_STD_SLOT_VALUE =
    567     new Primitive(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value")
    568     {
    569       @Override
    570       public LispObject execute(LispObject first, LispObject second,
    571                                 LispObject third)
    572 
    573       {
    574         first.setSlotValue(second, third);
    575         return third;
    576       }
    577     };
     604  private static final Primitive SET_STD_SLOT_VALUE
     605    = new pf_set_std_slot_value();
     606  @DocString(name="set-std-slot-value")
     607  private static final class pf_set_std_slot_value extends Primitive
     608  {
     609    pf_set_std_slot_value()
     610    {
     611      super(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value");
     612    }
     613    @Override
     614    public LispObject execute(LispObject first, LispObject second,
     615                              LispObject third)
     616    {
     617      first.setSlotValue(second, third);
     618      return third;
     619    }
     620  };
    578621}
  • trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java

    r13440 r13541  
    3838public class StandardObjectFunctions
    3939{
    40   // ### %std-allocate-instance class => instance
    41   private static final Primitive _STD_ALLOCATE_INSTANCE =
    42     new Primitive("%std-allocate-instance", PACKAGE_SYS, true, "class")
     40  private static final Primitive _STD_ALLOCATE_INSTANCE
     41    = new pf__std_allocate_instance();
     42  @DocString(name="%std-allocate-instance",
     43             args="class",
     44             returns="instance")
     45  private static final class pf__std_allocate_instance extends Primitive
     46  {
     47    pf__std_allocate_instance()
    4348    {
    44       @Override
    45       public LispObject execute(LispObject arg)
    46       {
    47         if (arg == StandardClass.STANDARD_CLASS)
    48           return new StandardClass();
    49         if (arg instanceof StandardClass)
    50             return ((StandardClass)arg).allocateInstance();
    51         if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
    52             LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
    53             if (! (l instanceof Layout))
    54                 return error(new ProgramError("Invalid standard class layout for: " + arg.princToString()));
    55            
    56             return new StandardObject((Layout)l);
    57         }
    58         return type_error(arg, Symbol.STANDARD_CLASS);
     49      super("%std-allocate-instance", PACKAGE_SYS, true, "class");
     50    }
     51    @Override
     52    public LispObject execute(LispObject arg)
     53    {
     54      if (arg == StandardClass.STANDARD_CLASS)
     55        return new StandardClass();
     56      if (arg instanceof StandardClass)
     57        return ((StandardClass)arg).allocateInstance();
     58      if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
     59        LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
     60        if (! (l instanceof Layout))
     61          return error(new ProgramError("Invalid standard class layout for: " + arg.princToString()));
     62       
     63        return new StandardObject((Layout)l);
    5964      }
    60     };
     65      return type_error(arg, Symbol.STANDARD_CLASS);
     66    }
     67  };
    6168}
  • trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java

    r12288 r13541  
    4444  }
    4545
    46   // ### reader-method-slot-name
    47   private static final Primitive READER_METHOD_SLOT_NAME =
    48       new Primitive("reader-method-slot-name", PACKAGE_MOP, false, "reader-method")
     46  private static final Primitive READER_METHOD_SLOT_NAME
     47      = new pf_reader_method_slot_name();
     48  @DocString(name="reader-method-slot-name",
     49             args="reader-method")
     50  private static final class pf_reader_method_slot_name extends Primitive
    4951  {
     52      pf_reader_method_slot_name()
     53      {
     54          super("reader-method-slot-name", PACKAGE_MOP, false, "reader-method");
     55      }
    5056      @Override
    5157      public LispObject execute(LispObject arg)
     
    5763  };
    5864
    59   // ### set-reader-method-slot-name
    60   private static final Primitive SET_READER_METHOD_SLOT_NAME =
    61       new Primitive("set-reader-method-slot-name", PACKAGE_MOP, false,
    62                     "reader-method slot-name")
     65  private static final Primitive SET_READER_METHOD_SLOT_NAME
     66      = new pf_set_reader_method_slot_name();
     67    @DocString(name="set-reader-method-slot-name",
     68               args="reader-method slot-name")
     69  private static final class pf_set_reader_method_slot_name extends Primitive
    6370  {
     71      pf_set_reader_method_slot_name()
     72      {
     73          super("set-reader-method-slot-name", PACKAGE_MOP, false,
     74                "reader-method slot-name");
     75      }
    6476      @Override
    6577      public LispObject execute(LispObject first, LispObject second)
  • trunk/abcl/src/org/armedbear/lisp/StructureObject.java

    r13440 r13541  
    523523  }
    524524
    525   // ### structure-object-p object => generalized-boolean
    526   private static final Primitive STRUCTURE_OBJECT_P =
    527     new Primitive("structure-object-p", PACKAGE_SYS, true, "object")
    528     {
    529       @Override
    530       public LispObject execute(LispObject arg)
    531       {
    532         return arg instanceof StructureObject ? T : NIL;
    533       }
    534     };
    535 
    536   // ### structure-length instance => length
    537   private static final Primitive STRUCTURE_LENGTH =
    538     new Primitive("structure-length", PACKAGE_SYS, true, "instance")
    539     {
    540       @Override
    541       public LispObject execute(LispObject arg)
    542       {
    543           if (arg instanceof StructureObject)
    544             return Fixnum.getInstance(((StructureObject)arg).slots.length);
    545         return type_error(arg, Symbol.STRUCTURE_OBJECT);
    546       }
    547     };
    548 
    549   // ### structure-ref instance index => value
    550   private static final Primitive STRUCTURE_REF =
    551     new Primitive("structure-ref", PACKAGE_SYS, true)
    552     {
    553       @Override
    554       public LispObject execute(LispObject first, LispObject second)
    555 
    556       {
    557     if (first instanceof StructureObject)
     525  private static final Primitive STRUCTURE_OBJECT_P
     526    = new pf_structure_object_p();
     527  @DocString(name="structure-object-p",
     528             args="object",
     529             returns="generalized-boolean")
     530  private static final class pf_structure_object_p extends Primitive
     531  {
     532    pf_structure_object_p()
     533    {
     534      super("structure-object-p", PACKAGE_SYS, true, "object");
     535    }
     536    @Override
     537    public LispObject execute(LispObject arg)
     538    {
     539      return arg instanceof StructureObject ? T : NIL;
     540    }
     541  };
     542
     543  private static final Primitive STRUCTURE_LENGTH
     544    = new pf_structure_length();
     545  @DocString(name="structure-length",
     546             args="instance",
     547             returns="length")
     548  private static final class pf_structure_length extends Primitive
     549  {
     550    pf_structure_length()
     551    {
     552      super("structure-length", PACKAGE_SYS, true, "instance");
     553    }
     554    @Override
     555    public LispObject execute(LispObject arg)
     556    {
     557      if (arg instanceof StructureObject)
     558        return Fixnum.getInstance(((StructureObject)arg).slots.length);
     559      return type_error(arg, Symbol.STRUCTURE_OBJECT);
     560    }
     561  };
     562
     563  private static final Primitive STRUCTURE_REF
     564    = new pf_structure_ref();
     565  @DocString(name="structure-ref",
     566             args="instance index",
     567             returns="value")
     568  private static final class pf_structure_ref extends Primitive
     569  {
     570    pf_structure_ref()
     571    {
     572      super("structure-ref", PACKAGE_SYS, true);
     573    }
     574    @Override
     575    public LispObject execute(LispObject first, LispObject second)
     576    {
     577      if (first instanceof StructureObject)
    558578        try
    559579          {
     
    566586          }     
    567587      return type_error(first, Symbol.STRUCTURE_OBJECT);
    568       }
    569     };
    570 
    571   // ### structure-set instance index new-value => new-value
    572   private static final Primitive STRUCTURE_SET =
    573     new Primitive("structure-set", PACKAGE_SYS, true)
    574     {
    575       @Override
    576       public LispObject execute(LispObject first, LispObject second,
    577                                 LispObject third)
    578 
    579       {
    580          
    581             if (first instanceof StructureObject)
    582                 try
    583                   {
    584                     ((StructureObject)first).slots[Fixnum.getValue(second)] = third;
    585                     return third;
    586                   }
    587                 catch (ArrayIndexOutOfBoundsException e)
    588                   {
    589                     // Shouldn't happen.
    590                     return error(new LispError("Internal error."));
    591                   }     
    592               return type_error(first, Symbol.STRUCTURE_OBJECT);
    593               }     
    594     };
    595 
    596   // ### make-structure
    597   private static final Primitive MAKE_STRUCTURE =
    598     new Primitive("make-structure", PACKAGE_SYS, true)
    599     {
    600       @Override
    601       public LispObject execute(LispObject first, LispObject second)
    602 
    603       {
    604           return new StructureObject(checkSymbol(first), second);
    605       }
    606       @Override
    607       public LispObject execute(LispObject first, LispObject second,
    608                                 LispObject third)
    609 
    610       {
    611           return new StructureObject(checkSymbol(first), second, third);
    612       }
    613       @Override
    614       public LispObject execute(LispObject first, LispObject second,
    615                                 LispObject third, LispObject fourth)
    616 
    617       {
    618           return new StructureObject(checkSymbol(first), second, third, fourth);
    619       }
    620       @Override
    621       public LispObject execute(LispObject first, LispObject second,
    622                                 LispObject third, LispObject fourth,
    623                                 LispObject fifth)
    624 
    625       {
    626           return new StructureObject(checkSymbol(first), second, third, fourth,
    627                   fifth);
    628       }
    629       @Override
    630       public LispObject execute(LispObject first, LispObject second,
    631                                 LispObject third, LispObject fourth,
    632                                 LispObject fifth, LispObject sixth)
    633 
    634       {
    635           return new StructureObject(checkSymbol(first), second, third, fourth,
    636                   fifth, sixth);
    637       }
    638       @Override
    639       public LispObject execute(LispObject first, LispObject second,
    640                                 LispObject third, LispObject fourth,
    641                                 LispObject fifth, LispObject sixth,
    642                                 LispObject seventh)
    643 
    644       {
    645           return new StructureObject(checkSymbol(first), second, third, fourth,
    646                   fifth, sixth, seventh);
    647       }
    648     };
    649 
    650   // ### %make-structure name slot-values => object
    651   private static final Primitive _MAKE_STRUCTURE =
    652     new Primitive("%make-structure", PACKAGE_SYS, true)
    653     {
    654       @Override
    655       public LispObject execute(LispObject first, LispObject second)
    656 
    657       {
    658           return new StructureObject(checkSymbol(first), second.copyToArray());
    659       }
    660     };
    661 
    662   // ### copy-structure structure => copy
    663   private static final Primitive COPY_STRUCTURE =
    664     new Primitive(Symbol.COPY_STRUCTURE, "structure")
    665     {
    666       @Override
    667       public LispObject execute(LispObject arg)
    668       {
    669           if (arg instanceof StructureObject)
    670             return new StructureObject((StructureObject)arg);
    671           return type_error(arg, Symbol.STRUCTURE_OBJECT);
    672       }
    673     };
     588    }
     589  };
     590
     591  private static final Primitive STRUCTURE_SET
     592    = new pf_structure_set();
     593  @DocString(name="structure-set",
     594             args="instance index new-value",
     595             returns="new-value")
     596  private static final class pf_structure_set extends Primitive
     597  {
     598    pf_structure_set()
     599    {
     600      super("structure-set", PACKAGE_SYS, true);
     601    }
     602    @Override
     603    public LispObject execute(LispObject first, LispObject second,
     604                              LispObject third)
     605    {
     606      if (first instanceof StructureObject)
     607        try
     608          {
     609            ((StructureObject)first).slots[Fixnum.getValue(second)] = third;
     610            return third;
     611          }
     612        catch (ArrayIndexOutOfBoundsException e)
     613          {
     614            // Shouldn't happen.
     615            return error(new LispError("Internal error."));
     616          }     
     617      return type_error(first, Symbol.STRUCTURE_OBJECT);
     618    }     
     619  };
     620
     621  private static final Primitive MAKE_STRUCTURE
     622    = new pf_make_structure();
     623  @DocString(name="make-structure")
     624  private static final class pf_make_structure extends Primitive
     625  {
     626    pf_make_structure()
     627    {
     628      super("make-structure", PACKAGE_SYS, true);
     629    }
     630    @Override
     631    public LispObject execute(LispObject first, LispObject second)
     632    {
     633      return new StructureObject(checkSymbol(first), second);
     634    }
     635    @Override
     636    public LispObject execute(LispObject first, LispObject second,
     637                              LispObject third)
     638     
     639    {
     640      return new StructureObject(checkSymbol(first), second, third);
     641    }
     642    @Override
     643    public LispObject execute(LispObject first, LispObject second,
     644                              LispObject third, LispObject fourth)
     645     
     646    {
     647      return new StructureObject(checkSymbol(first), second, third, fourth);
     648    }
     649    @Override
     650    public LispObject execute(LispObject first, LispObject second,
     651                              LispObject third, LispObject fourth,
     652                              LispObject fifth)
     653    {
     654      return new StructureObject(checkSymbol(first), second, third, fourth,
     655                                 fifth);
     656    }
     657    @Override
     658    public LispObject execute(LispObject first, LispObject second,
     659                              LispObject third, LispObject fourth,
     660                              LispObject fifth, LispObject sixth)
     661    {
     662      return new StructureObject(checkSymbol(first), second, third, fourth,
     663                                 fifth, sixth);
     664    }
     665    @Override
     666    public LispObject execute(LispObject first, LispObject second,
     667                              LispObject third, LispObject fourth,
     668                              LispObject fifth, LispObject sixth,
     669                              LispObject seventh)
     670    {
     671      return new StructureObject(checkSymbol(first), second, third, fourth,
     672                                 fifth, sixth, seventh);
     673    }
     674  };
     675
     676  private static final Primitive _MAKE_STRUCTURE
     677    = new pf__make_structure();
     678  @DocString(name="%make-structure",
     679             args="name slot-values",
     680             returns="object")
     681  private static final class pf__make_structure extends Primitive
     682  {
     683    pf__make_structure()
     684    {
     685      super("%make-structure", PACKAGE_SYS, true);
     686    }
     687    @Override
     688    public LispObject execute(LispObject first, LispObject second)
     689    {
     690      return new StructureObject(checkSymbol(first), second.copyToArray());
     691    }
     692  };
     693
     694  private static final Primitive COPY_STRUCTURE
     695    = new pf_copy_structure();
     696  @DocString(name="copy-structure",
     697             args="structure",
     698             returns="copy")
     699  private static final class pf_copy_structure extends Primitive
     700  {
     701    pf_copy_structure()
     702    {
     703      super(Symbol.COPY_STRUCTURE, "structure");
     704    }
     705    @Override
     706    public LispObject execute(LispObject arg)
     707    {
     708      if (arg instanceof StructureObject)
     709        return new StructureObject((StructureObject)arg);
     710      return type_error(arg, Symbol.STRUCTURE_OBJECT);
     711    }
     712  };
    674713}
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13377 r13541  
    2424  superclass is suitable for use as a superclass of class."))
    2525
     26;;; TODO Hook VALIDATE-SUPERCLASS into during class metaobject
     27;;; initialization and reinitialization. (AMOP p.240-1)
    2628(defmethod validate-superclass ((class class) (superclass class))
    2729  (or (eql (class-name superclass) t)
Note: See TracChangeset for help on using the changeset viewer.