[armedbear-cvs] r13814 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Fri Jan 27 13:06:04 UTC 2012
Author: rschlatte
Date: Fri Jan 27 05:06:03 2012
New Revision: 13814
Log:
implement classes standard-method, standard-reader-method in Lisp
Deleted:
trunk/abcl/src/org/armedbear/lisp/StandardMethod.java
trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java
trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java
trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Profiler.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/mop.lisp
trunk/abcl/src/org/armedbear/lisp/print-object.lisp
trunk/abcl/src/org/armedbear/lisp/profiler.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Jan 27 05:06:03 2012 (r13814)
@@ -535,8 +535,6 @@
autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader");
autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true);
autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false);
- autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
- autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);
autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true);
autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true);
autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true);
@@ -559,10 +557,6 @@
autoload(PACKAGE_SYS, "%make-socket", "make_socket");
autoload(PACKAGE_SYS, "%make-string", "StringFunctions");
autoload(PACKAGE_SYS, "%make-string-output-stream", "StringOutputStream");
- autoload(PACKAGE_SYS, "%method-fast-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%method-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%method-generic-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%method-specializers", "StandardMethod", true);
autoload(PACKAGE_SYS, "%nstring-capitalize", "StringFunctions");
autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions");
autoload(PACKAGE_SYS, "%nstring-upcase", "StringFunctions");
@@ -574,11 +568,6 @@
autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true);
- autoload(PACKAGE_SYS, "%set-method-fast-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%set-function-keywords", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true);
- autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true);
autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector");
@@ -637,7 +626,6 @@
autoload(PACKAGE_SYS, "float-nan-p", "FloatFunctions", true);
autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true);
autoload(PACKAGE_SYS, "function-info", "function_info");
- autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true);
autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true);
autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true);
autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true);
@@ -666,8 +654,6 @@
autoload(PACKAGE_SYS, "make-slot-definition", "SlotDefinition", true);
autoload(PACKAGE_SYS, "make-structure-class", "StructureClass");
autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives");
- autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true);
- autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true);
autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions");
autoload(PACKAGE_SYS, "puthash", "HashTableFunctions");
autoload(PACKAGE_SYS, "puthash", "HashTableFunctions");
@@ -680,9 +666,6 @@
autoload(PACKAGE_SYS, "set-generic-function-method-class","StandardGenericFunction", true);
autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true);
autoload(PACKAGE_SYS, "set-generic-function-methods","StandardGenericFunction", true);
- autoload(PACKAGE_SYS, "set-method-documentation", "StandardMethod", true);
- autoload(PACKAGE_SYS, "set-method-lambda-list", "StandardMethod", true);
- autoload(PACKAGE_SYS, "set-method-qualifiers", "StandardMethod", true);
autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true);
autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true);
autoload(PACKAGE_SYS, "set-slot-definition-initargs", "SlotDefinition", true);
Modified: trunk/abcl/src/org/armedbear/lisp/Profiler.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Profiler.java Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/Profiler.java Fri Jan 27 05:06:03 2012 (r13814)
@@ -71,13 +71,21 @@
if (object != null) {
object.setCallCount(0);
object.setHotCount(0);
+ LispObject methods = null;
if (object instanceof StandardGenericFunction) {
- LispObject methods =
- PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object);
- while (methods != NIL) {
- StandardMethod method = (StandardMethod) methods.car();
- method.getFunction().setCallCount(0);
- method.getFunction().setHotCount(0);
+ methods =
+ Symbol.GENERIC_FUNCTION_METHODS.execute(object);
+ }
+ // TODO: extract methods from non-standard
+ // generic functions here once they are
+ // implemented
+ while (methods != null && methods != NIL) {
+ LispObject maybeMethod = methods.car();
+ if (maybeMethod instanceof StandardObject) {
+ StandardObject method = (StandardObject) maybeMethod;
+ LispObject function = method.getInstanceSlotValue(Symbol.FUNCTION);
+ function.setCallCount(0);
+ function.setHotCount(0);
methods = methods.cdr();
}
}
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 27 05:06:03 2012 (r13814)
@@ -561,18 +561,16 @@
addStandardClass(Symbol.METHOD, list(METAOBJECT));
public static final StandardClass STANDARD_METHOD =
- new StandardMethodClass();
- static
- {
- addClass(Symbol.STANDARD_METHOD, STANDARD_METHOD);
- }
+ addStandardClass(Symbol.STANDARD_METHOD, list(METHOD));
+
+ public static final StandardClass STANDARD_ACCESSOR_METHOD =
+ addStandardClass(Symbol.STANDARD_ACCESSOR_METHOD, list(STANDARD_METHOD));
public static final StandardClass STANDARD_READER_METHOD =
- new StandardReaderMethodClass();
- static
- {
- addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD);
- }
+ addStandardClass(Symbol.STANDARD_READER_METHOD, list(STANDARD_ACCESSOR_METHOD));
+
+ public static final StandardClass STANDARD_WRITER_METHOD =
+ addStandardClass(Symbol.STANDARD_WRITER_METHOD, list(STANDARD_ACCESSOR_METHOD));
public static final StandardClass STANDARD_GENERIC_FUNCTION =
new StandardGenericFunctionClass();
@@ -677,6 +675,31 @@
EQL_SPECIALIZER.setDirectSlotDefinitions(
list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT")))));
METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
+ STANDARD_METHOD.setDirectSlotDefinitions(
+ list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL),
+ new SlotDefinition(Symbol.LAMBDA_LIST, NIL),
+ new SlotDefinition(Symbol.KEYWORDS, NIL),
+ new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL),
+ new SlotDefinition(Symbol.SPECIALIZERS, NIL),
+ new SlotDefinition(Symbol.QUALIFIERS, NIL),
+ new SlotDefinition(Symbol.FUNCTION, NIL),
+ new SlotDefinition(Symbol.FAST_FUNCTION, NIL),
+ new SlotDefinition(Symbol.DOCUMENTATION, NIL)));
+ STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
+ METHOD, METAOBJECT, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
+ STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions(
+ list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL)));
+ STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD,
+ STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
+ METHOD, METAOBJECT, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
+ STANDARD_WRITER_METHOD.setCPL(STANDARD_WRITER_METHOD,
+ STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
+ METHOD, METAOBJECT, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT,
BuiltInClass.CLASS_T);
METHOD_COMBINATION.setDirectSlotDefinitions(
@@ -811,6 +834,11 @@
FLOATING_POINT_UNDERFLOW.finalizeClass();
JAVA_EXCEPTION.finalizeClass();
METAOBJECT.finalizeClass();
+ METHOD.finalizeClass();
+ STANDARD_METHOD.finalizeClass();
+ STANDARD_ACCESSOR_METHOD.finalizeClass();
+ STANDARD_READER_METHOD.finalizeClass();
+ STANDARD_WRITER_METHOD.finalizeClass();
SPECIALIZER.finalizeClass();
EQL_SPECIALIZER.finalizeClass();
METHOD_COMBINATION.finalizeClass();
@@ -862,23 +890,6 @@
BuiltInClass.CLASS_T);
STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
- // STANDARD-METHOD
- Debug.assertTrue(STANDARD_METHOD.isFinalized());
- STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
- BuiltInClass.CLASS_T);
- STANDARD_METHOD.setDirectSlotDefinitions(STANDARD_METHOD.getClassLayout().generateSlotDefinitions());
- // There are no inherited slots.
- STANDARD_METHOD.setSlotDefinitions(STANDARD_METHOD.getDirectSlotDefinitions());
-
- // STANDARD-READER-METHOD
- Debug.assertTrue(STANDARD_READER_METHOD.isFinalized());
- STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_METHOD,
- METHOD, METAOBJECT, STANDARD_OBJECT,
- BuiltInClass.CLASS_T);
- STANDARD_READER_METHOD.setSlotDefinitions(STANDARD_READER_METHOD.getClassLayout().generateSlotDefinitions());
- // All but the last slot are inherited.
- STANDARD_READER_METHOD.setDirectSlotDefinitions(list(STANDARD_READER_METHOD.getSlotDefinitions().reverse().car()));
-
// STANDARD-GENERIC-FUNCTION
Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized());
STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION,
Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Jan 27 05:06:03 2012 (r13814)
@@ -71,8 +71,21 @@
numberOfRequiredArgs = lambdaList.length();
slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] =
NIL;
- StandardMethod method =
- new StandardMethod(this, function, lambdaList, specializers);
+ StandardObject method
+ = (StandardObject)StandardClass.STANDARD_METHOD.allocateInstance();
+ method.setInstanceSlotValue(Symbol.GENERIC_FUNCTION, this);
+ method.setInstanceSlotValue(Symbol.LAMBDA_LIST, lambdaList);
+ method.setInstanceSlotValue(Symbol.KEYWORDS, NIL);
+ method.setInstanceSlotValue(Symbol.OTHER_KEYWORDS_P, NIL);
+ method.setInstanceSlotValue(Symbol.SPECIALIZERS, specializers);
+ method.setInstanceSlotValue(Symbol.QUALIFIERS, NIL);
+ // Setting the function slot to nil is a transcription of what the
+ // constructor for StandardMethod instances did (that Java class was
+ // removed for the implementation of subclassable standard-method).
+ // (rudi 2012-01-27)
+ method.setInstanceSlotValue(Symbol.FUNCTION, NIL);
+ method.setInstanceSlotValue(Symbol.FAST_FUNCTION, function);
+ method.setInstanceSlotValue(Symbol.DOCUMENTATION, NIL);
slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] =
list(method);
slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] =
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 27 05:06:03 2012 (r13814)
@@ -2975,6 +2975,8 @@
PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT");
public static final Symbol FUNCALLABLE_STANDARD_CLASS =
PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS");
+ public static final Symbol GENERIC_FUNCTION_METHODS =
+ PACKAGE_MOP.addExternalSymbol("GENERIC-FUNCTION-METHODS");
public static final Symbol SHORT_METHOD_COMBINATION =
PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION");
public static final Symbol LONG_METHOD_COMBINATION =
@@ -2983,8 +2985,12 @@
PACKAGE_MOP.addExternalSymbol("METAOBJECT");
public static final Symbol SPECIALIZER =
PACKAGE_MOP.addExternalSymbol("SPECIALIZER");
+ public static final Symbol STANDARD_ACCESSOR_METHOD =
+ PACKAGE_MOP.addExternalSymbol("STANDARD-ACCESSOR-METHOD");
public static final Symbol STANDARD_READER_METHOD =
PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
+ public static final Symbol STANDARD_WRITER_METHOD =
+ PACKAGE_MOP.addExternalSymbol("STANDARD-WRITER-METHOD");
public static final Symbol DIRECT_SLOT_DEFINITION =
PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION");
public static final Symbol EFFECTIVE_SLOT_DEFINITION =
@@ -3149,34 +3155,41 @@
PACKAGE_SYS.addInternalSymbol("DEFTYPE-DEFINITION");
public static final Symbol EXPECTED_TYPE =
PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE");
+ public static final Symbol FAST_FUNCTION =
+ PACKAGE_SYS.addInternalSymbol("FAST-FUNCTION");
public static final Symbol FORMAT_ARGUMENTS =
PACKAGE_SYS.addInternalSymbol("FORMAT-ARGUMENTS");
public static final Symbol FORMAT_CONTROL =
PACKAGE_SYS.addInternalSymbol("FORMAT-CONTROL");
- public static final Symbol FSET =
- PACKAGE_SYS.addInternalSymbol("FSET");
+ public static final Symbol FSET = PACKAGE_SYS.addInternalSymbol("FSET");
public static final Symbol FUNCTION_PRELOAD =
PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD");
public static final Symbol INSTANCE =
PACKAGE_SYS.addInternalSymbol("INSTANCE");
+ public static final Symbol KEYWORDS =
+ PACKAGE_SYS.addInternalSymbol("KEYWORDS");
public static final Symbol MACROEXPAND_MACRO =
PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO");
public static final Symbol MAKE_FUNCTION_PRELOADING_CONTEXT =
PACKAGE_SYS.addInternalSymbol("MAKE-FUNCTION-PRELOADING-CONTEXT");
- public static final Symbol NAME =
- PACKAGE_SYS.addInternalSymbol("NAME");
- public static final Symbol OBJECT =
- PACKAGE_SYS.addInternalSymbol("OBJECT");
+ public static final Symbol NAME = PACKAGE_SYS.addInternalSymbol("NAME");
+ public static final Symbol OBJECT = PACKAGE_SYS.addInternalSymbol("OBJECT");
public static final Symbol OPERANDS =
PACKAGE_SYS.addInternalSymbol("OPERANDS");
public static final Symbol OPERATION =
PACKAGE_SYS.addInternalSymbol("OPERATION");
+ public static final Symbol OTHER_KEYWORDS_P =
+ PACKAGE_SYS.addInternalSymbol("OTHER-KEYWORDS-P");
public static final Symbol PROXY_PRELOADED_FUNCTION =
PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION");
+ public static final Symbol QUALIFIERS =
+ PACKAGE_SYS.addInternalSymbol("QUALIFIERS");
public static final Symbol _SOURCE =
PACKAGE_SYS.addInternalSymbol("%SOURCE");
public static final Symbol SOCKET_STREAM =
PACKAGE_SYS.addInternalSymbol("SOCKET-STREAM");
+ public static final Symbol SPECIALIZERS =
+ PACKAGE_SYS.addInternalSymbol("SPECIALIZERS");
public static final Symbol STRING_INPUT_STREAM =
PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM");
public static final Symbol STRING_OUTPUT_STREAM =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 27 05:06:03 2012 (r13814)
@@ -65,9 +65,13 @@
;;
;; Some functionality implemented in the temporary regular functions
;; needs to be available later as a method definition to be dispatched
-;; to for the STANDARD-CLASS case. To prevent repeated code, the
-;; functions are implemented in functions by the same name as the
-;; API functions, but with the STD- prefix.
+;; to for the standard case, e.g. with arguments of type STANDARD-CLASS
+;; or STANDARD-GENERIC-FUNCTION. To prevent repeated code, the
+;; functions are implemented in functions by the same name as the API
+;; functions, but with the STD- prefix. These functions are sometimes
+;; used in regular code as well, either in a "fast path" or to break a
+;; circularity (e.g., within compute-discriminating-function when the
+;; user adds a method to compute-discriminating-function).
;;
;; When hacking this file, note that some important parts are implemented
;; in the Java world. These Java bits can be found in the files
@@ -82,7 +86,7 @@
;; * Layout.java
;;
;; In case of function names, those defined on the Java side can be
-;; recognized by their prefixed percent sign.
+;; recognized by their prefixed percent (%) sign.
;;
;; The API functions need to be declaimed NOTINLINE explicitly, because
;; that prevents inlining in the current FASL (which is allowed by the
@@ -107,6 +111,8 @@
(find-class 'forward-referenced-class))
(defconstant +the-standard-reader-method-class+
(find-class 'standard-reader-method))
+(defconstant +the-standard-writer-method-class+
+ (find-class 'standard-writer-method))
(defconstant +the-standard-generic-function-class+
(find-class 'standard-generic-function))
(defconstant +the-T-class+ (find-class 'T))
@@ -164,7 +170,7 @@
args))
(defun function-keywords (method)
- (%function-keywords method))
+ (std-function-keywords method))
@@ -739,7 +745,7 @@
(setf (class-direct-slots class) slots)
(dolist (direct-slot slots)
(dolist (reader (slot-definition-readers direct-slot))
- (add-reader-method class reader (slot-definition-name direct-slot)))
+ (add-reader-method class reader direct-slot))
(dolist (writer (slot-definition-writers direct-slot))
(add-writer-method class writer (slot-definition-name direct-slot)))))
(setf (class-direct-default-initargs class) direct-default-initargs)
@@ -1004,7 +1010,7 @@
,(wrap-with-call-method-macro ,gf
',args-var
(second method)))))
- (t (%method-function method)))
+ (t (method-function method)))
,',args-var
,(unless (null next-method-list)
;; by not generating an emf when there are no next methods,
@@ -1181,6 +1187,49 @@
(check-type eql-specializer eql-specializer)
(std-slot-value eql-specializer 'sys::object))
+;;; Initial versions of some method metaobject readers. Defined on
+;;; AMOP pg. 218ff, will be redefined when generic functions are set up.
+
+(defun std-method-function (method)
+ (std-slot-value method 'cl:function))
+
+(defun std-method-generic-function (method)
+ (std-slot-value method 'cl:generic-function))
+
+(defun std-method-specializers (method)
+ (std-slot-value method 'sys::specializers))
+
+(defun std-method-qualifiers (method)
+ (std-slot-value method 'sys::qualifiers))
+
+(defun std-accessor-method-slot-definition (accessor-method)
+ (std-slot-value accessor-method 'sys:slot-definition))
+
+;;; Additional method readers
+(defun std-method-fast-function (method)
+ (std-slot-value method 'sys::fast-function))
+
+(defun std-function-keywords (method)
+ (values (std-slot-value method 'sys::keywords)
+ (std-slot-value method 'sys::other-keywords-p)))
+
+;;; Preliminary accessor definitions, will be redefined as generic
+;;; functions later in this file
+
+(declaim (notinline method-generic-function))
+(defun method-generic-function (method)
+ (std-method-generic-function method))
+
+(declaim (notinline method-specializers))
+(defun method-specializers (method)
+ (std-method-specializers method))
+
+(declaim (notinline method-qualifiers))
+(defun method-qualifiers (method)
+ (std-method-qualifiers method))
+
+
+
;; MOP (p. 216) specifies the following reader generic functions:
;; generic-function-argument-precedence-order
;; generic-function-declarations
@@ -1231,13 +1280,16 @@
(set-generic-function-classes-to-emf-table gf new-value))
(defun (setf method-lambda-list) (new-value method)
- (set-method-lambda-list method new-value))
+ (setf (std-slot-value method 'sys::lambda-list) new-value))
(defun (setf method-qualifiers) (new-value method)
- (set-method-qualifiers method new-value))
+ (setf (std-slot-value method 'sys::qualifiers) new-value))
+
+(defun method-documentation (method)
+ (std-slot-value method 'documentation))
(defun (setf method-documentation) (new-value method)
- (set-method-documentation method new-value))
+ (setf (std-slot-value method 'documentation) new-value))
;;; defgeneric
@@ -1403,7 +1455,7 @@
(defun collect-eql-specializer-objects (generic-function)
(let ((result nil))
(dolist (method (generic-function-methods generic-function))
- (dolist (specializer (%method-specializers method))
+ (dolist (specializer (method-specializers method))
(when (typep specializer 'eql-specializer)
(pushnew (eql-specializer-object specializer)
result
@@ -1710,33 +1762,33 @@
fast-function)
(declare (ignore gf))
(let ((method (std-allocate-instance +the-standard-method-class+))
- (analyzed-args (analyze-lambda-list lambda-list))
- )
+ (analyzed-args (analyze-lambda-list lambda-list)))
(setf (method-lambda-list method) lambda-list)
(setf (method-qualifiers method) qualifiers)
- (%set-method-specializers method (canonicalize-specializers specializers))
+ (setf (std-slot-value method 'sys::specializers)
+ (canonicalize-specializers specializers))
(setf (method-documentation method) documentation)
- (%set-method-generic-function method nil)
- (%set-method-function method function)
- (%set-method-fast-function method fast-function)
- (%set-function-keywords method
- (getf analyzed-args :keywords)
- (getf analyzed-args :allow-other-keys))
+ (setf (std-slot-value method 'generic-function) nil) ; set by add-method
+ (setf (std-slot-value method 'function) function)
+ (setf (std-slot-value method 'sys::fast-function) fast-function)
+ (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords))
+ (setf (std-slot-value method 'sys::other-keywords-p)
+ (getf analyzed-args :allow-other-keys))
method))
(defun std-add-method (gf method)
- (when (%method-generic-function method)
+ (when (method-generic-function method)
(error 'simple-error
- :format-control "ADD-METHOD: ~S is a method of ~S."
- :format-arguments (list method (%method-generic-function method))))
+ :format-control "ADD-METHOD: ~S is already a method of ~S."
+ :format-arguments (list method (method-generic-function method))))
;; Remove existing method with same qualifiers and specializers (if any).
- (let ((old-method (%find-method gf (method-qualifiers method)
- (%method-specializers method) nil)))
+ (let ((old-method (%find-method gf (std-method-qualifiers method)
+ (method-specializers method) nil)))
(when old-method
(std-remove-method gf old-method)))
- (%set-method-generic-function method gf)
+ (setf (std-slot-value method 'generic-function) gf)
(push method (generic-function-methods gf))
- (dolist (specializer (%method-specializers method))
+ (dolist (specializer (method-specializers method))
(when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
(pushnew method (class-direct-methods specializer))))
(finalize-standard-generic-function gf)
@@ -1745,8 +1797,8 @@
(defun std-remove-method (gf method)
(setf (generic-function-methods gf)
(remove method (generic-function-methods gf)))
- (%set-method-generic-function method nil)
- (dolist (specializer (%method-specializers method))
+ (setf (std-slot-value method 'generic-function) gf)
+ (dolist (specializer (method-specializers method))
(when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
(setf (class-direct-methods specializer)
(remove method (class-direct-methods specializer)))))
@@ -1768,7 +1820,7 @@
(and (equal qualifiers
(method-qualifiers method))
(equal canonical-specializers
- (%method-specializers method))))
+ (method-specializers method))))
(generic-function-methods gf))))
(if (and (null method) errorp)
(error "No such method for ~S." (%generic-function-name gf))
@@ -1791,12 +1843,14 @@
;; In this function, we know that gf is of class
;; standard-generic-function, so we call various
;; sys:%generic-function-foo readers to break circularities.
+ ;; (rudi 2012-01-27): maybe we need to discriminate between
+ ;; standard-methods and methods as well.
(cond
((and (= (length (sys:%generic-function-methods gf)) 1)
(typep (car (sys:%generic-function-methods gf)) 'standard-reader-method))
(let* ((method (%car (sys:%generic-function-methods gf)))
- (class (car (%method-specializers method)))
- (slot-name (reader-method-slot-name method)))
+ (class (car (std-method-specializers method)))
+ (slot-name (slot-definition-name (accessor-method-slot-definition method))))
#'(lambda (arg)
(declare (optimize speed))
(let* ((layout (std-instance-layout arg))
@@ -1827,9 +1881,9 @@
((and (eq (sys:%generic-function-method-combination gf) 'standard)
(= (length (sys:%generic-function-methods gf)) 1))
(let* ((method (%car (sys:%generic-function-methods gf)))
- (specializer (car (%method-specializers method)))
- (function (or (%method-fast-function method)
- (%method-function method))))
+ (specializer (car (std-method-specializers method)))
+ (function (or (std-method-fast-function method)
+ (std-method-function method))))
(if (typep specializer 'eql-specializer)
(let ((specializer-object (eql-specializer-object specializer)))
#'(lambda (arg)
@@ -1885,8 +1939,8 @@
(if emfun
(funcall emfun args)
(slow-method-lookup gf args))))))
-;; (let ((non-key-args (+ number-required
-;; (length (gf-optional-args gf))))))
+ ;; (let ((non-key-args (+ number-required
+ ;; (length (gf-optional-args gf))))))
#'(lambda (&rest args)
(declare (optimize speed))
(let ((len (length args)))
@@ -1911,7 +1965,7 @@
(method-more-specific-p gf m1 m2 required-classes))))))
(defun method-applicable-p (method args)
- (do* ((specializers (%method-specializers method) (cdr specializers))
+ (do* ((specializers (method-specializers method) (cdr specializers))
(args args (cdr args)))
((null specializers) t)
(let ((specializer (car specializers)))
@@ -1939,7 +1993,7 @@
;;; the classes of its arguments only.
;;;
(defun method-applicable-using-classes-p (method classes)
- (do* ((specializers (%method-specializers method) (cdr specializers))
+ (do* ((specializers (method-specializers method) (cdr specializers))
(classes classes (cdr classes))
(knownp t))
((null specializers)
@@ -2039,8 +2093,8 @@
(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
(if argument-precedence-order
- (let ((specializers-1 (%method-specializers method1))
- (specializers-2 (%method-specializers method2)))
+ (let ((specializers-1 (std-method-specializers method1))
+ (specializers-2 (std-method-specializers method2)))
(dolist (index argument-precedence-order)
(let ((spec1 (nth index specializers-1))
(spec2 (nth index specializers-2)))
@@ -2052,8 +2106,8 @@
(t
(return (sub-specializer-p spec1 spec2
(nth index required-classes)))))))))
- (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
- (specializers-2 (%method-specializers method2) (cdr specializers-2))
+ (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1))
+ (specializers-2 (std-method-specializers method2) (cdr specializers-2))
(classes required-classes (cdr classes)))
((null specializers-1) nil)
(let ((spec1 (car specializers-1))
@@ -2136,7 +2190,7 @@
#'compute-effective-method-function)
gf (remove around methods))))
(setf emf-form
- (generate-emf-lambda (%method-function around) next-emfun))))
+ (generate-emf-lambda (std-method-function around) next-emfun))))
((eq mc-name 'standard)
(let* ((next-emfun (compute-primary-emfun (cdr primaries)))
(befores (remove-if-not #'before-method-p methods))
@@ -2145,7 +2199,7 @@
(setf emf-form
(cond
((and (null befores) (null reverse-afters))
- (let ((fast-function (%method-fast-function (car primaries))))
+ (let ((fast-function (std-method-fast-function (car primaries))))
(if fast-function
(ecase (length (gf-required-args gf))
(1
@@ -2156,18 +2210,18 @@
#'(lambda (args)
(declare (optimize speed))
(funcall fast-function (car args) (cadr args)))))
- (generate-emf-lambda (%method-function (car primaries))
+ (generate-emf-lambda (std-method-function (car primaries))
next-emfun))))
(t
- (let ((method-function (%method-function (car primaries))))
+ (let ((method-function (std-method-function (car primaries))))
#'(lambda (args)
(declare (optimize speed))
(dolist (before befores)
- (funcall (%method-function before) args nil))
+ (funcall (std-method-function before) args nil))
(multiple-value-prog1
(funcall method-function args next-emfun)
(dolist (after reverse-afters)
- (funcall (%method-function after) args nil))))))))))
+ (funcall (std-method-function after) args nil))))))))))
(long-method-combination-p
(let* ((mc-obj (get mc-name 'method-combination-object))
(function (long-method-combination-function mc-obj))
@@ -2188,11 +2242,11 @@
(setf emf-form
(if (and (null (cdr primaries))
(not (null ioa)))
- (generate-emf-lambda (%method-function (car primaries)) nil)
+ (generate-emf-lambda (std-method-function (car primaries)) nil)
`(lambda (args)
(,operator ,@(mapcar
(lambda (primary)
- `(funcall ,(%method-function primary) args nil))
+ `(funcall ,(std-method-function primary) args nil))
primaries)))))))))
(assert (not (null emf-form)))
(or #+nil (ignore-errors (autocompile emf-form))
@@ -2210,7 +2264,7 @@
nil
(let ((next-emfun (compute-primary-emfun (cdr methods))))
#'(lambda (args)
- (funcall (%method-function (car methods)) args next-emfun)))))
+ (funcall (std-method-function (car methods)) args next-emfun)))))
(defvar *call-next-method-p*)
(defvar *next-method-p-p*)
@@ -2381,48 +2435,72 @@
documentation
function
fast-function
- slot-name)
+ slot-definition)
(declare (ignore gf))
(let ((method (std-allocate-instance +the-standard-reader-method-class+)))
(setf (method-lambda-list method) lambda-list)
(setf (method-qualifiers method) qualifiers)
- (%set-method-specializers method (canonicalize-specializers specializers))
+ (setf (std-slot-value method 'sys::specializers)
+ (canonicalize-specializers specializers))
(setf (method-documentation method) documentation)
- (%set-method-generic-function method nil)
- (%set-method-function method function)
- (%set-method-fast-function method fast-function)
- (set-reader-method-slot-name method slot-name)
- (%set-function-keywords method nil nil)
+ (setf (std-slot-value method 'generic-function) nil)
+ (setf (std-slot-value method 'function) function)
+ (setf (std-slot-value method 'sys::fast-function) fast-function)
+ (setf (std-slot-value method 'sys:slot-definition) slot-definition)
+ (setf (std-slot-value method 'sys::keywords) nil)
+ (setf (std-slot-value method 'sys::other-keywords-p) nil)
method))
-(defun add-reader-method (class function-name slot-name)
- (let* ((lambda-expression
+(defun add-reader-method (class function-name slot-definition)
+ (let* ((method-class (if (eq (class-of class) +the-standard-class+)
+ +the-standard-reader-method-class+
+ (reader-method-class class)))
+ (slot-name (slot-definition-name slot-definition))
+ (lambda-expression
(if (eq (class-of class) +the-standard-class+)
`(lambda (object) (std-slot-value object ',slot-name))
`(lambda (object) (slot-value object ',slot-name))))
(method-function (compute-method-function lambda-expression))
- (fast-function (compute-method-fast-function lambda-expression)))
- (let ((method-lambda-list '(object))
- (gf (find-generic-function function-name nil)))
- (if gf
- (check-method-lambda-list function-name
- method-lambda-list
- (generic-function-lambda-list gf))
- (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
- (let ((method
- (make-instance-standard-reader-method gf
- :lambda-list '(object)
- :qualifiers ()
- :specializers (list class)
- :function (if (autoloadp 'compile)
- method-function
- (autocompile method-function))
- :fast-function (if (autoloadp 'compile)
- fast-function
- (autocompile fast-function))
- :slot-name slot-name)))
- (std-add-method gf method)
- method))))
+ (fast-function (compute-method-fast-function lambda-expression))
+ (method-lambda-list '(object))
+ (gf (find-generic-function function-name nil)))
+ ;; required by AMOP pg. 225
+ (assert (subtypep method-class +the-standard-reader-method-class+))
+ (if gf
+ (check-method-lambda-list function-name
+ method-lambda-list
+ (generic-function-lambda-list gf))
+ (setf gf (ensure-generic-function function-name
+ :lambda-list method-lambda-list)))
+ (let ((method
+ (if (eq method-class +the-standard-reader-method-class+)
+ (make-instance-standard-reader-method
+ gf
+ :lambda-list method-lambda-list
+ :qualifiers ()
+ :specializers (list class)
+ :function (if (autoloadp 'compile)
+ method-function
+ (autocompile method-function))
+ :fast-function (if (autoloadp 'compile)
+ fast-function
+ (autocompile fast-function))
+ :slot-definition slot-definition)
+ (make-instance method-class
+ :lambda-list method-lambda-list
+ :qualifiers ()
+ :specializers (list class)
+ :function (if (autoloadp 'compile)
+ method-function
+ (autocompile method-function))
+ :fast-function (if (autoloadp 'compile)
+ fast-function
+ (autocompile fast-function))
+ :slot-definition slot-definition))))
+ (if (eq (class-of gf) +the-standard-generic-function-class+)
+ (std-add-method gf method)
+ (add-method gf method))
+ method)))
(defun add-writer-method (class function-name slot-name)
(let* ((lambda-expression
@@ -2649,19 +2727,35 @@
,@(canonicalize-defclass-options options)))
-
+;;; AMOP pg. 180
(defgeneric direct-slot-definition-class (class &rest initargs))
(defmethod direct-slot-definition-class ((class class) &rest initargs)
(declare (ignore initargs))
+the-standard-direct-slot-definition-class+)
+;;; AMOP pg. 181
(defgeneric effective-slot-definition-class (class &rest initargs))
(defmethod effective-slot-definition-class ((class class) &rest initargs)
(declare (ignore initargs))
+the-standard-effective-slot-definition-class+)
+;;; AMOP pg. 224
+(defgeneric reader-method-class (class direct-slot &rest initargs))
+
+(defmethod reader-method-class ((class standard-class)
+ (direct-slot standard-direct-slot-definition)
+ &rest initargs)
+ (declare (ignore initargs))
+ +the-standard-reader-method-class+)
+
+(defmethod reader-method-class ((class funcallable-standard-class)
+ (direct-slot standard-direct-slot-definition)
+ &rest initargs)
+ (declare (ignore initargs))
+ +the-standard-reader-method-class+)
+
(atomic-defgeneric documentation (x doc-type)
(:method ((x symbol) doc-type)
(%documentation x doc-type))
@@ -3502,7 +3596,7 @@
(atomic-defgeneric function-keywords (method)
(:method ((method standard-method))
- (%function-keywords method)))
+ (std-function-keywords method)))
(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
@@ -3556,6 +3650,34 @@
(:method ((generic-function standard-generic-function))
(sys:%generic-function-name generic-function)))
+;;; Readers for Method Metaobjects
+;;; AMOP pg. 218ff.
+
+(atomic-defgeneric method-function (method)
+ (:method ((method standard-method))
+ (std-method-function method)))
+
+(atomic-defgeneric method-generic-function (method)
+ (:method ((method standard-method))
+ (std-method-generic-function method)))
+
+(atomic-defgeneric method-lambda-list (method)
+ (:method ((method standard-method))
+ (std-slot-value method 'sys::lambda-list)))
+
+(atomic-defgeneric method-specializers (method)
+ (:method ((method standard-method))
+ (std-method-specializers method)))
+
+(atomic-defgeneric method-qualifiers (method)
+ (:method ((method standard-method))
+ (std-method-qualifiers method)))
+
+(atomic-defgeneric accessor-method-slot-definition (method)
+ (:method ((method standard-accessor-method))
+ (std-accessor-method-slot-definition method)))
+
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "MOP"))
Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Fri Jan 27 05:06:03 2012 (r13814)
@@ -57,6 +57,9 @@
standard-method
method-function
+ method-specializers
+ method-generic-function
+
standard-accessor-method
standard-reader-method
standard-writer-method
Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Jan 27 05:06:03 2012 (r13814)
@@ -55,25 +55,25 @@
(class-name class)))
class)
-(defmethod print-object ((gf standard-generic-function) stream)
+(defmethod print-object ((gf generic-function) stream)
(print-unreadable-object (gf stream :identity t)
(format stream "~S ~S"
(class-name (class-of gf))
- (%generic-function-name gf)))
+ (mop:generic-function-name gf)))
gf)
-(defmethod print-object ((method standard-method) stream)
+(defmethod print-object ((method method) stream)
(print-unreadable-object (method stream :identity t)
(format stream "~S ~S~{ ~S~} ~S"
(class-name (class-of method))
- (%generic-function-name
- (%method-generic-function method))
+ (mop:generic-function-name
+ (mop:method-generic-function method))
(method-qualifiers method)
(mapcar #'(lambda (c)
- (if (typep c 'mop::eql-specializer)
- `(eql ,(mop::eql-specializer-object c))
+ (if (typep c 'mop:eql-specializer)
+ `(eql ,(mop:eql-specializer-object c))
(class-name c)))
- (%method-specializers method))))
+ (mop:method-specializers method))))
method)
(defmethod print-object ((restart restart) stream)
Modified: trunk/abcl/src/org/armedbear/lisp/profiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/profiler.lisp Fri Jan 27 02:15:39 2012 (r13813)
+++ trunk/abcl/src/org/armedbear/lisp/profiler.lisp Fri Jan 27 05:06:03 2012 (r13814)
@@ -67,7 +67,7 @@
full-count hot-count) result)
(dolist (method
(mop::generic-function-methods definition))
- (let ((function (sys:%method-function method)))
+ (let ((function (mop:method-function method)))
(setf full-count (sys:call-count function))
(setf hot-count (sys:hot-count function)))
(unless (zerop full-count)
@@ -82,17 +82,17 @@
(cond ((symbolp object)
object)
((typep object 'generic-function)
- (sys:%generic-function-name object))
+ (mop:generic-function-name object))
((typep object 'method)
(list 'METHOD
- (sys:%generic-function-name (sys:%method-generic-function object))
- (sys:%method-specializers object)))))
+ (mop:generic-function-name (mop:method-generic-function object))
+ (mop:method-specializers object)))))
(defun object-compiled-function-p (object)
(cond ((symbolp object)
(compiled-function-p (fdefinition object)))
((typep object 'method)
- (compiled-function-p (sys:%method-function object)))
+ (compiled-function-p (mop:method-function object)))
(t
(compiled-function-p object))))
More information about the armedbear-cvs
mailing list