Changeset 13775


Ignore:
Timestamp:
01/14/12 20:07:00 (12 years ago)
Author:
rschlatte
Message:

Support for funcallable instances.

... Move execute, set-funcallable-instance-function upwards from

StandardGenericFunction? to new class FuncallableStandardObject?.

... Add various MOPpy methods for funcallable-standard-class, which

isn't a subclass of standard-class, unfortunately.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/Autoload.java

    r13715 r13775  
    535535        autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader");
    536536        autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true);
    537         autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
     537        autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false);
    538538        autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
    539539        autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
    540540        autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);
    541         autoload(PACKAGE_MOP, "set-funcallable-instance-function", "StandardGenericFunction", true);
     541        autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true);
    542542        autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true);
    543543        autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true);
    … …  
    694694        autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true);
    695695        autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true);
     696        autoload(PACKAGE_SYS, "%allocate-funcallable-instance", "FuncallableStandardObject", true);
    696697        autoload(PACKAGE_SYS, "unzip", "unzip", true);
    697698        autoload(PACKAGE_SYS, "zip", "zip", true);

  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r13774 r13775  
    453453  public static final StandardClass FUNCALLABLE_STANDARD_CLASS =
    454454    addStandardClass(Symbol.FUNCALLABLE_STANDARD_CLASS, list(CLASS));
    455   static
    456   {
    457     // funcallable-standard-class has more or less the same interface as
    458     // standard-class.
    459     FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass);
    460     FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
    461   }
    462455
    463456  public static final StandardClass CONDITION =
    … …  
    582575  }
    583576
    584   // ### TODO move functionality upwards into funcallable-stanard-object
    585   // and use addStandardClass() here
    586577  public static final StandardClass STANDARD_GENERIC_FUNCTION =
    587578    new StandardGenericFunctionClass();
    … …  
    750741    STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, SPECIALIZER, METAOBJECT,
    751742                          STANDARD_OBJECT, BuiltInClass.CLASS_T);
     743    FUNCALLABLE_STANDARD_CLASS.setCPL(FUNCALLABLE_STANDARD_CLASS, CLASS,
     744                                      SPECIALIZER, METAOBJECT, STANDARD_OBJECT,
     745                                      BuiltInClass.CLASS_T);
     746    // funcallable-standard-class has the same interface as
     747    // standard-class.
     748    FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass);
     749    FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
    752750    STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T);
    753751    STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION,
    … …  
    787785    FUNCALLABLE_STANDARD_OBJECT.finalizeClass();
    788786    CLASS.finalizeClass();
     787    FUNCALLABLE_STANDARD_CLASS.finalizeClass();
    789788    GENERIC_FUNCTION.finalizeClass();
    790789    ARITHMETIC_ERROR.finalizeClass();

  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r13541 r13775  
    3838import java.util.concurrent.ConcurrentHashMap;
    3939
    40 public final class StandardGenericFunction extends StandardObject
     40public final class StandardGenericFunction extends FuncallableStandardObject
    4141{
    42   LispObject function;
    43 
    44   int numberOfRequiredArgs;
    4542
    4643  ConcurrentHashMap<CacheEntry,LispObject> cache;
    … …  
    121118
    122119  @Override
    123   public LispObject execute()
    124   {
    125     return function.execute();
    126   }
    127 
    128   @Override
    129   public LispObject execute(LispObject arg)
    130   {
    131     return function.execute(arg);
    132   }
    133 
    134   @Override
    135   public LispObject execute(LispObject first, LispObject second)
    136 
    137   {
    138     return function.execute(first, second);
    139   }
    140 
    141   @Override
    142   public LispObject execute(LispObject first, LispObject second,
    143                             LispObject third)
    144 
    145   {
    146     return function.execute(first, second, third);
    147   }
    148 
    149   @Override
    150   public LispObject execute(LispObject first, LispObject second,
    151                             LispObject third, LispObject fourth)
    152 
    153   {
    154     return function.execute(first, second, third, fourth);
    155   }
    156 
    157   @Override
    158   public LispObject execute(LispObject first, LispObject second,
    159                             LispObject third, LispObject fourth,
    160                             LispObject fifth)
    161 
    162   {
    163     return function.execute(first, second, third, fourth,
    164                             fifth);
    165   }
    166 
    167   @Override
    168   public LispObject execute(LispObject first, LispObject second,
    169                             LispObject third, LispObject fourth,
    170                             LispObject fifth, LispObject sixth)
    171 
    172   {
    173     return function.execute(first, second, third, fourth,
    174                             fifth, sixth);
    175   }
    176 
    177   @Override
    178   public LispObject execute(LispObject first, LispObject second,
    179                             LispObject third, LispObject fourth,
    180                             LispObject fifth, LispObject sixth,
    181                             LispObject seventh)
    182 
    183   {
    184     return function.execute(first, second, third, fourth,
    185                             fifth, sixth, seventh);
    186   }
    187 
    188   @Override
    189   public LispObject execute(LispObject first, LispObject second,
    190                             LispObject third, LispObject fourth,
    191                             LispObject fifth, LispObject sixth,
    192                             LispObject seventh, LispObject eighth)
    193 
    194   {
    195     return function.execute(first, second, third, fourth,
    196                             fifth, sixth, seventh, eighth);
    197   }
    198 
    199   @Override
    200   public LispObject execute(LispObject[] args)
    201   {
    202     return function.execute(args);
    203   }
    204 
    205   @Override
    206120  public String printObject()
    207121  {
    … …  
    225139  }
    226140
    227   // Profiling.
    228   private int callCount;
    229   private int hotCount;
    230 
    231   @Override
    232   public final int getCallCount()
    233   {
    234     return callCount;
    235   }
    236 
    237   @Override
    238   public void setCallCount(int n)
    239   {
    240     callCount = n;
    241   }
    242 
    243   @Override
    244   public final void incrementCallCount()
    245   {
    246     ++callCount;
    247   }
    248 
    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 
    267141  // AMOP (p. 216) specifies the following readers as generic functions:
    268142  //   generic-function-argument-precedence-order
    … …  
    335209    {
    336210      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 
    360   // AMOP p. 230
    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;
    377211      return second;
    378212    }

  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13774 r13775  
    686686    (std-finalize-inheritance class))
    687687  (sys::%std-allocate-instance class))
     688
     689(defun allocate-funcallable-instance (class)
     690  (unless (class-finalized-p class)
     691    (std-finalize-inheritance class))
     692  (sys::%allocate-funcallable-instance class))
    688693
    689694(defun make-instance-standard-class (metaclass
    … …  
    26512656(defmethod slot-value-using-class ((class standard-class) instance slot-name)
    26522657  (std-slot-value instance slot-name))
    2653 
     2658(defmethod slot-value-using-class ((class funcallable-standard-class)
     2659                                   instance slot-name)
     2660  (std-slot-value instance slot-name))
    26542661(defmethod slot-value-using-class ((class structure-class) instance slot-name)
    26552662  (std-slot-value instance slot-name))
    … …  
    26642671
    26652672(defmethod (setf slot-value-using-class) (new-value
     2673                                          (class funcallable-standard-class)
     2674                                          instance
     2675                                          slot-name)
     2676  (setf (std-slot-value instance slot-name) new-value))
     2677
     2678(defmethod (setf slot-value-using-class) (new-value
    26662679                                          (class structure-class)
    26672680                                          instance
    … …  
    26752688
    26762689(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
     2690  (std-slot-exists-p instance slot-name))
     2691(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name)
    26772692  (std-slot-exists-p instance slot-name))
    26782693
    … …  
    26862701(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
    26872702  (std-slot-boundp instance slot-name))
     2703(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name)
     2704  (std-slot-boundp instance slot-name))
    26882705(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
    26892706  "Structure slots can't be unbound, so this method always returns T."
    … …  
    26932710(defgeneric slot-makunbound-using-class (class instance slot-name))
    26942711(defmethod slot-makunbound-using-class ((class standard-class)
     2712                                        instance
     2713                                        slot-name)
     2714  (std-slot-makunbound instance slot-name))
     2715(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
    26952716                                        instance
    26962717                                        slot-name)
    … …  
    27202741  (declare (ignore initargs))
    27212742  (std-allocate-instance class))
     2743
     2744(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
     2745  (declare (ignore initargs))
     2746  (allocate-funcallable-instance class))
    27222747
    27232748(defmethod allocate-instance ((class structure-class) &rest initargs)
    … …  
    28122837(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
    28132838
    2814 (defmethod make-instance ((class standard-class) &rest initargs)
     2839(defmethod make-instance ((class class) &rest initargs)
    28152840  (when (oddp (length initargs))
    28162841    (error 'program-error :format-control "Odd number of keyword arguments."))
    … …  
    28282853        (setf initargs (append initargs default-initargs)))))
    28292854
    2830   (let ((instance (std-allocate-instance class)))
     2855  (let ((instance (allocate-instance class)))
    28312856    (check-initargs (list #'allocate-instance #'initialize-instance)
    28322857                    (list* instance initargs)
    … …  
    29562981(defmethod make-instances-obsolete ((class standard-class))
    29572982  (%make-instances-obsolete class))
    2958 
     2983(defmethod make-instances-obsolete ((class funcallable-standard-class))
     2984  (%make-instances-obsolete class))
    29592985(defmethod make-instances-obsolete ((class symbol))
    29602986  (make-instances-obsolete (find-class class))
    … …  
    29883014  (apply #'std-after-initialization-for-classes class args))
    29893015
     3016(defmethod initialize-instance :after ((class funcallable-standard-class)
     3017                                       &rest args)
     3018  (apply #'std-after-initialization-for-classes class args))
     3019
    29903020(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
    29913021  (remhash class *make-instance-initargs-cache*)
    … …  
    30133043(defmethod compute-class-precedence-list ((class standard-class))
    30143044  (std-compute-class-precedence-list class))
     3045(defmethod compute-class-precedence-list ((class funcallable-standard-class))
     3046  (std-compute-class-precedence-list class))
    30153047
    30163048;;; Slot inheritance
    … …  
    30263058  ((class standard-class) name direct-slots)
    30273059  (std-compute-effective-slot-definition class name direct-slots))
    3028 
     3060(defmethod compute-effective-slot-definition
     3061  ((class funcallable-standard-class) name direct-slots)
     3062  (std-compute-effective-slot-definition class name direct-slots))
    30293063;;; Methods having to do with generic function metaobjects.
    30303064
    … …  
    33143348  (allocate-instance class))
    33153349
     3350(defmethod class-prototype ((class funcallable-standard-class))
     3351  (allocate-instance class))
     3352
    33163353(defmethod class-prototype ((class structure-class))
    33173354  (allocate-instance class))
Note: See TracChangeset for help on using the changeset viewer.