[armedbear-cvs] r13837 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Tue Jan 31 23:01:46 UTC 2012
Author: rschlatte
Date: Tue Jan 31 15:01:45 2012
New Revision: 13837
Log:
Implement specializer-method--related protocol.
Add add-direct-method, remove-direct-method, specializer-direct-methods,
specializer-direct-generic-functions
Modified:
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/mop.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Jan 31 09:24:52 2012 (r13836)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Jan 31 15:01:45 2012 (r13837)
@@ -5561,7 +5561,7 @@
if (arg instanceof LispClass)
return ((LispClass)arg).getDocumentation();
else
- return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
+ return ((StandardObject)arg).getInstanceSlotValue(Symbol.DOCUMENTATION);
}
};
@@ -5579,7 +5579,7 @@
if (first instanceof LispClass)
((LispClass)first).setDocumentation(second);
else
- ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
+ ((StandardObject)first).setInstanceSlotValue(Symbol.DOCUMENTATION, second);
return second;
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 31 09:24:52 2012 (r13836)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 31 15:01:45 2012 (r13837)
@@ -48,8 +48,6 @@
= PACKAGE_MOP.intern("PRECEDENCE-LIST");
public static Symbol symDirectMethods
= PACKAGE_MOP.intern("DIRECT-METHODS");
- public static Symbol symDocumentation
- = PACKAGE_MOP.intern("DOCUMENTATION");
public static Symbol symDirectSlots
= PACKAGE_MOP.intern("DIRECT-SLOTS");
public static Symbol symSlots
@@ -61,6 +59,17 @@
public static Symbol symFinalizedP
= PACKAGE_MOP.intern("FINALIZED-P");
+ // used as init-function for slots in this file.
+ static Function constantlyNil = new Function() {
+ @Override
+ public LispObject execute()
+ {
+ return NIL;
+ }
+ };
+
+
+
static Layout layoutStandardClass =
new Layout(null,
list(symName,
@@ -74,7 +83,7 @@
symDirectDefaultInitargs,
symDefaultInitargs,
symFinalizedP,
- symDocumentation),
+ Symbol.DOCUMENTATION),
NIL)
{
@Override
@@ -226,13 +235,13 @@
@Override
public LispObject getDocumentation()
{
- return getInstanceSlotValue(symDocumentation);
+ return getInstanceSlotValue(Symbol.DOCUMENTATION);
}
@Override
public void setDocumentation(LispObject doc)
{
- setInstanceSlotValue(symDocumentation, doc);
+ setInstanceSlotValue(Symbol.DOCUMENTATION, doc);
}
@Override
@@ -334,28 +343,18 @@
private static final LispObject standardClassSlotDefinitions()
{
- // (CONSTANTLY NIL)
- Function initFunction = new Function() {
- @Override
- public LispObject execute()
- {
- return NIL;
- }
- };
-
return
- list(helperMakeSlotDefinition("NAME", initFunction),
- helperMakeSlotDefinition("LAYOUT", initFunction),
- helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction),
- helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction),
- helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction),
- helperMakeSlotDefinition("DIRECT-METHODS", initFunction),
- helperMakeSlotDefinition("DIRECT-SLOTS", initFunction),
- helperMakeSlotDefinition("SLOTS", initFunction),
- helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction),
- helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction),
- helperMakeSlotDefinition("FINALIZED-P", initFunction),
- helperMakeSlotDefinition("DOCUMENTATION", initFunction));
+ list(helperMakeSlotDefinition("NAME", constantlyNil),
+ helperMakeSlotDefinition("LAYOUT", constantlyNil),
+ helperMakeSlotDefinition("DIRECT-SUPERCLASSES", constantlyNil),
+ helperMakeSlotDefinition("DIRECT-SUBCLASSES", constantlyNil),
+ helperMakeSlotDefinition("PRECEDENCE-LIST", constantlyNil),
+ helperMakeSlotDefinition("DIRECT-SLOTS", constantlyNil),
+ helperMakeSlotDefinition("SLOTS", constantlyNil),
+ helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", constantlyNil),
+ helperMakeSlotDefinition("DEFAULT-INITARGS", constantlyNil),
+ helperMakeSlotDefinition("FINALIZED-P", constantlyNil),
+ helperMakeSlotDefinition("DOCUMENTATION", constantlyNil));
}
@@ -673,25 +672,26 @@
EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT,
STANDARD_OBJECT, BuiltInClass.CLASS_T);
EQL_SPECIALIZER.setDirectSlotDefinitions(
- list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT")))));
+ list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil),
+ new SlotDefinition(symDirectMethods, NIL, constantlyNil)));
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)));
+ list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL, constantlyNil),
+ new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil),
+ new SlotDefinition(Symbol.KEYWORDS, NIL, constantlyNil),
+ new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL, constantlyNil),
+ new SlotDefinition(Symbol.SPECIALIZERS, NIL, constantlyNil),
+ new SlotDefinition(Symbol.QUALIFIERS, NIL, constantlyNil),
+ new SlotDefinition(Symbol.FUNCTION, NIL, constantlyNil),
+ new SlotDefinition(Symbol.FAST_FUNCTION, NIL, constantlyNil),
+ new SlotDefinition(Symbol.DOCUMENTATION, NIL, constantlyNil)));
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)));
+ list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL)));
STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD,
STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
METHOD, METAOBJECT, STANDARD_OBJECT,
@@ -704,9 +704,11 @@
BuiltInClass.CLASS_T);
METHOD_COMBINATION.setDirectSlotDefinitions(
list(new SlotDefinition(Symbol.NAME,
- list(Symbol.METHOD_COMBINATION_NAME)),
+ list(Symbol.METHOD_COMBINATION_NAME),
+ constantlyNil),
new SlotDefinition(Symbol.DOCUMENTATION,
- list(Symbol.METHOD_COMBINATION_DOCUMENTATION))));
+ list(Symbol.METHOD_COMBINATION_DOCUMENTATION),
+ constantlyNil)));
SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION,
METHOD_COMBINATION, METAOBJECT,
STANDARD_OBJECT, BuiltInClass.CLASS_T);
@@ -813,7 +815,6 @@
STANDARD_CLASS.finalizeClass();
STANDARD_OBJECT.finalizeClass();
FUNCALLABLE_STANDARD_OBJECT.finalizeClass();
- CLASS.finalizeClass();
FUNCALLABLE_STANDARD_CLASS.finalizeClass();
FORWARD_REFERENCED_CLASS.finalizeClass();
GENERIC_FUNCTION.finalizeClass();
@@ -840,6 +841,8 @@
STANDARD_READER_METHOD.finalizeClass();
STANDARD_WRITER_METHOD.finalizeClass();
SPECIALIZER.finalizeClass();
+ CLASS.finalizeClass();
+ BUILT_IN_CLASS.finalizeClass();
EQL_SPECIALIZER.finalizeClass();
METHOD_COMBINATION.finalizeClass();
SHORT_METHOD_COMBINATION.finalizeClass();
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 31 09:24:52 2012 (r13836)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 31 15:01:45 2012 (r13837)
@@ -1181,6 +1181,7 @@
;; setup, so have to rely on plain functions here.
(let ((instance (std-allocate-instance (find-class 'eql-specializer))))
(setf (std-slot-value instance 'sys::object) object)
+ (setf (std-slot-value instance 'direct-methods) nil)
instance))))
(defun eql-specializer-object (eql-specializer)
@@ -1776,6 +1777,21 @@
(getf analyzed-args :allow-other-keys))
method))
+;;; To be redefined as generic functions later
+(declaim (notinline add-direct-method))
+(defun add-direct-method (specializer method)
+ (if (typep specializer 'eql-specializer)
+ (pushnew method (std-slot-value specializer 'direct-methods))
+ (pushnew method (class-direct-methods specializer))))
+
+(declaim (notinline remove-direct-method))
+(defun remove-direct-method (specializer method)
+ (if (typep specializer 'eql-specializer)
+ (setf (std-slot-value specializer 'direct-methods)
+ (remove method (std-slot-value specializer 'direct-methods)))
+ (setf (class-direct-methods specializer)
+ (remove method (class-direct-methods specializer)))))
+
(defun std-add-method (gf method)
(when (and (method-generic-function method)
(not (eql gf (method-generic-function method))))
@@ -1790,9 +1806,7 @@
(setf (std-slot-value method 'generic-function) gf)
(push method (generic-function-methods gf))
(dolist (specializer (method-specializers method))
- ;; FIXME use add-direct-method here (AMOP pg. 165))
- (when (typep specializer 'class)
- (pushnew method (class-direct-methods specializer))))
+ (add-direct-method specializer method))
(finalize-standard-generic-function gf)
gf)
@@ -1801,10 +1815,7 @@
(remove method (generic-function-methods gf)))
(setf (std-slot-value method 'generic-function) nil)
(dolist (specializer (method-specializers method))
- ;; FIXME use remove-direct-method here (AMOP pg. 227)
- (when (typep specializer 'class)
- (setf (class-direct-methods specializer)
- (remove method (class-direct-methods specializer)))))
+ (remove-direct-method specializer method))
(finalize-standard-generic-function gf)
gf)
@@ -3727,6 +3738,45 @@
(:method ((method standard-accessor-method))
(std-accessor-method-slot-definition method)))
+;;; specializer-direct-method and friends.
+
+;;; AMOP pg. 237
+(defgeneric specializer-direct-generic-functions (specializer))
+
+(defmethod specializer-direct-generic-functions ((specializer class))
+ (delete-duplicates (mapcar #'method-generic-function
+ (class-direct-methods specializer))))
+
+(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
+ (delete-duplicates (mapcar #'method-generic-function
+ (slot-value specializer 'direct-methods))))
+
+;;; AMOP pg. 238
+(defgeneric specializer-direct-methods (specializer))
+
+(defmethod specializer-direct-methods ((specializer class))
+ (class-direct-methods specializer))
+
+(defmethod specializer-direct-methods ((specializer eql-specializer))
+ (slot-value specializer 'direct-methods))
+
+;;; AMOP pg. 165
+(atomic-defgeneric add-direct-method (specializer method)
+ (:method ((specializer class) (method method))
+ (pushnew method (class-direct-methods specializer)))
+ (:method ((specializer eql-specializer) (method method))
+ (pushnew method (slot-value specializer 'direct-methods))))
+
+
+;;; AMOP pg. 227
+(atomic-defgeneric remove-direct-method (specializer method)
+ (:method ((specializer class) (method method))
+ (setf (class-direct-methods specializer)
+ (remove method (class-direct-methods specializer))))
+ (:method ((specializer eql-specializer) (method method))
+ (setf (slot-value specializer 'direct-methods)
+ (remove method (slot-value specializer 'direct-methods)))))
+
;;; SLIME compatibility functions.
(defun %method-generic-function (method)
Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 31 09:24:52 2012 (r13836)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 31 15:01:45 2012 (r13837)
@@ -73,11 +73,16 @@
slot-definition-readers
slot-definition-writers
+ intern-eql-specializer
eql-specializer-object
+ specializer-direct-methods
+ specializer-direct-generic-functions
+ add-direct-method
+ remove-direct-method
+
extract-lambda-list
extract-specializer-names
-
- intern-eql-specializer))
+ ))
(provide 'mop)
More information about the armedbear-cvs
mailing list