Changeset 13775
- Timestamp:
- 01/14/12 20:07:00 (12 years ago)
- 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 535 535 autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader"); 536 536 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); 538 538 autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); 539 539 autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); 540 540 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); 542 542 autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true); 543 543 autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true); … … 694 694 autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true); 695 695 autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true); 696 autoload(PACKAGE_SYS, "%allocate-funcallable-instance", "FuncallableStandardObject", true); 696 697 autoload(PACKAGE_SYS, "unzip", "unzip", true); 697 698 autoload(PACKAGE_SYS, "zip", "zip", true); -
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
r13774 r13775 453 453 public static final StandardClass FUNCALLABLE_STANDARD_CLASS = 454 454 addStandardClass(Symbol.FUNCALLABLE_STANDARD_CLASS, list(CLASS)); 455 static456 {457 // funcallable-standard-class has more or less the same interface as458 // standard-class.459 FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass);460 FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());461 }462 455 463 456 public static final StandardClass CONDITION = … … 582 575 } 583 576 584 // ### TODO move functionality upwards into funcallable-stanard-object585 // and use addStandardClass() here586 577 public static final StandardClass STANDARD_GENERIC_FUNCTION = 587 578 new StandardGenericFunctionClass(); … … 750 741 STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, SPECIALIZER, METAOBJECT, 751 742 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()); 752 750 STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T); 753 751 STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION, … … 787 785 FUNCALLABLE_STANDARD_OBJECT.finalizeClass(); 788 786 CLASS.finalizeClass(); 787 FUNCALLABLE_STANDARD_CLASS.finalizeClass(); 789 788 GENERIC_FUNCTION.finalizeClass(); 790 789 ARITHMETIC_ERROR.finalizeClass(); -
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
r13541 r13775 38 38 import java.util.concurrent.ConcurrentHashMap; 39 39 40 public final class StandardGenericFunction extends StandardObject40 public final class StandardGenericFunction extends FuncallableStandardObject 41 41 { 42 LispObject function;43 44 int numberOfRequiredArgs;45 42 46 43 ConcurrentHashMap<CacheEntry,LispObject> cache; … … 121 118 122 119 @Override 123 public LispObject execute()124 {125 return function.execute();126 }127 128 @Override129 public LispObject execute(LispObject arg)130 {131 return function.execute(arg);132 }133 134 @Override135 public LispObject execute(LispObject first, LispObject second)136 137 {138 return function.execute(first, second);139 }140 141 @Override142 public LispObject execute(LispObject first, LispObject second,143 LispObject third)144 145 {146 return function.execute(first, second, third);147 }148 149 @Override150 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 @Override158 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 @Override168 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 @Override178 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 @Override189 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 @Override200 public LispObject execute(LispObject[] args)201 {202 return function.execute(args);203 }204 205 @Override206 120 public String printObject() 207 121 { … … 225 139 } 226 140 227 // Profiling.228 private int callCount;229 private int hotCount;230 231 @Override232 public final int getCallCount()233 {234 return callCount;235 }236 237 @Override238 public void setCallCount(int n)239 {240 callCount = n;241 }242 243 @Override244 public final void incrementCallCount()245 {246 ++callCount;247 }248 249 @Override250 public final int getHotCount()251 {252 return hotCount;253 }254 255 @Override256 public void setHotCount(int n)257 {258 hotCount = n;259 }260 261 @Override262 public final void incrementHotCount()263 {264 ++hotCount;265 }266 267 141 // AMOP (p. 216) specifies the following readers as generic functions: 268 142 // generic-function-argument-precedence-order … … 335 209 { 336 210 checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second; 337 return second;338 }339 };340 341 private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION342 = 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 Primitive347 {348 pf_funcallable_instance_function()349 {350 super("funcallable-instance-function", PACKAGE_MOP, false,351 "funcallable-instance");352 }353 @Override354 public LispObject execute(LispObject arg)355 {356 return checkStandardGenericFunction(arg).function;357 }358 };359 360 // AMOP p. 230361 private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION362 = 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 Primitive367 {368 pf_set_funcallable_instance_function()369 {370 super("set-funcallable-instance-function", PACKAGE_MOP, true,371 "funcallable-instance function");372 }373 @Override374 public LispObject execute(LispObject first, LispObject second)375 {376 checkStandardGenericFunction(first).function = second;377 211 return second; 378 212 } -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13774 r13775 686 686 (std-finalize-inheritance class)) 687 687 (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)) 688 693 689 694 (defun make-instance-standard-class (metaclass … … 2651 2656 (defmethod slot-value-using-class ((class standard-class) instance slot-name) 2652 2657 (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)) 2654 2661 (defmethod slot-value-using-class ((class structure-class) instance slot-name) 2655 2662 (std-slot-value instance slot-name)) … … 2664 2671 2665 2672 (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 2666 2679 (class structure-class) 2667 2680 instance … … 2675 2688 2676 2689 (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) 2677 2692 (std-slot-exists-p instance slot-name)) 2678 2693 … … 2686 2701 (defmethod slot-boundp-using-class ((class standard-class) instance slot-name) 2687 2702 (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)) 2688 2705 (defmethod slot-boundp-using-class ((class structure-class) instance slot-name) 2689 2706 "Structure slots can't be unbound, so this method always returns T." … … 2693 2710 (defgeneric slot-makunbound-using-class (class instance slot-name)) 2694 2711 (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) 2695 2716 instance 2696 2717 slot-name) … … 2720 2741 (declare (ignore initargs)) 2721 2742 (std-allocate-instance class)) 2743 2744 (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) 2745 (declare (ignore initargs)) 2746 (allocate-funcallable-instance class)) 2722 2747 2723 2748 (defmethod allocate-instance ((class structure-class) &rest initargs) … … 2812 2837 (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) 2813 2838 2814 (defmethod make-instance ((class standard-class) &rest initargs)2839 (defmethod make-instance ((class class) &rest initargs) 2815 2840 (when (oddp (length initargs)) 2816 2841 (error 'program-error :format-control "Odd number of keyword arguments.")) … … 2828 2853 (setf initargs (append initargs default-initargs))))) 2829 2854 2830 (let ((instance ( std-allocate-instance class)))2855 (let ((instance (allocate-instance class))) 2831 2856 (check-initargs (list #'allocate-instance #'initialize-instance) 2832 2857 (list* instance initargs) … … 2956 2981 (defmethod make-instances-obsolete ((class standard-class)) 2957 2982 (%make-instances-obsolete class)) 2958 2983 (defmethod make-instances-obsolete ((class funcallable-standard-class)) 2984 (%make-instances-obsolete class)) 2959 2985 (defmethod make-instances-obsolete ((class symbol)) 2960 2986 (make-instances-obsolete (find-class class)) … … 2988 3014 (apply #'std-after-initialization-for-classes class args)) 2989 3015 3016 (defmethod initialize-instance :after ((class funcallable-standard-class) 3017 &rest args) 3018 (apply #'std-after-initialization-for-classes class args)) 3019 2990 3020 (defmethod reinitialize-instance :after ((class standard-class) &rest all-keys) 2991 3021 (remhash class *make-instance-initargs-cache*) … … 3013 3043 (defmethod compute-class-precedence-list ((class standard-class)) 3014 3044 (std-compute-class-precedence-list class)) 3045 (defmethod compute-class-precedence-list ((class funcallable-standard-class)) 3046 (std-compute-class-precedence-list class)) 3015 3047 3016 3048 ;;; Slot inheritance … … 3026 3058 ((class standard-class) name direct-slots) 3027 3059 (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)) 3029 3063 ;;; Methods having to do with generic function metaobjects. 3030 3064 … … 3314 3348 (allocate-instance class)) 3315 3349 3350 (defmethod class-prototype ((class funcallable-standard-class)) 3351 (allocate-instance class)) 3352 3316 3353 (defmethod class-prototype ((class structure-class)) 3317 3354 (allocate-instance class))
Note: See TracChangeset
for help on using the changeset viewer.