[armedbear-cvs] r13726 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Fri Jan 6 22:45:49 UTC 2012
Author: ehuelsmann
Date: Fri Jan 6 14:45:48 2012
New Revision: 13726
Log:
Patch by Rudi Schlatte: Make method combinations real classes.
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 6 14:14:08 2012 (r13725)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 6 14:45:48 2012 (r13726)
@@ -425,6 +425,15 @@
addStandardClass(Symbol.GENERIC_FUNCTION, list(METAOBJECT,
BuiltInClass.FUNCTION));
+ public static final StandardClass METHOD_COMBINATION =
+ addStandardClass(Symbol.METHOD_COMBINATION, list(METAOBJECT));
+
+ public static final StandardClass SHORT_METHOD_COMBINATION =
+ addStandardClass(Symbol.SHORT_METHOD_COMBINATION, list(METHOD_COMBINATION));
+
+ public static final StandardClass LONG_METHOD_COMBINATION =
+ addStandardClass(Symbol.LONG_METHOD_COMBINATION, list(METHOD_COMBINATION));
+
public static final StandardClass CLASS =
addStandardClass(Symbol.CLASS, list(SPECIALIZER));
@@ -651,6 +660,42 @@
EQL_SPECIALIZER.setDirectSlotDefinitions(
list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT")))));
METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
+ METHOD_COMBINATION.setDirectSlotDefinitions(
+ list(new SlotDefinition(Symbol.NAME,
+ list(Symbol.METHOD_COMBINATION_NAME)),
+ new SlotDefinition(Symbol.DOCUMENTATION,
+ list(Symbol.METHOD_COMBINATION_DOCUMENTATION))));
+ SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION,
+ METHOD_COMBINATION, METAOBJECT,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ SHORT_METHOD_COMBINATION.setDirectSlotDefinitions(
+ list(new SlotDefinition(Symbol.OPERATOR,
+ list(Symbol.SHORT_METHOD_COMBINATION_OPERATOR)),
+ new SlotDefinition(Symbol.IDENTITY_WITH_ONE_ARGUMENT,
+ list(Symbol.SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT))));
+ LONG_METHOD_COMBINATION.setCPL(LONG_METHOD_COMBINATION,
+ METHOD_COMBINATION, METAOBJECT,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ LONG_METHOD_COMBINATION.setDirectSlotDefinitions(
+ list(new SlotDefinition(Symbol.LAMBDA_LIST,
+ list(Symbol.LONG_METHOD_COMBINATION_LAMBDA_LIST)),
+ new SlotDefinition(Symbol.METHOD_GROUP_SPECS,
+ list(Symbol.LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS)),
+ new SlotDefinition(Symbol.ARGS_LAMBDA_LIST,
+ list(Symbol.LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST)),
+ new SlotDefinition(Symbol.GENERIC_FUNCTION_SYMBOL,
+ list(Symbol.LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL)),
+ new SlotDefinition(Symbol.FUNCTION,
+ list(Symbol.LONG_METHOD_COMBINATION_FUNCTION)),
+ new SlotDefinition(Symbol.ARGUMENTS,
+ list(Symbol.LONG_METHOD_COMBINATION_ARGUMENTS)),
+ new SlotDefinition(Symbol.DECLARATIONS,
+ list(Symbol.LONG_METHOD_COMBINATION_DECLARATIONS)),
+ new SlotDefinition(Symbol.FORMS,
+ list(Symbol.LONG_METHOD_COMBINATION_FORMS))));
+
PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
STANDARD_OBJECT, BuiltInClass.CLASS_T);
PACKAGE_ERROR.setDirectSlotDefinitions(
@@ -740,6 +785,9 @@
METAOBJECT.finalizeClass();
SPECIALIZER.finalizeClass();
EQL_SPECIALIZER.finalizeClass();
+ METHOD_COMBINATION.finalizeClass();
+ SHORT_METHOD_COMBINATION.finalizeClass();
+ LONG_METHOD_COMBINATION.finalizeClass();
PACKAGE_ERROR.finalizeClass();
PARSE_ERROR.finalizeClass();
PRINT_NOT_READABLE.finalizeClass();
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 6 14:14:08 2012 (r13725)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 6 14:45:48 2012 (r13726)
@@ -2971,6 +2971,10 @@
PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER");
public static final Symbol EQL_SPECIALIZER_OBJECT =
PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT");
+ public static final Symbol SHORT_METHOD_COMBINATION =
+ PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION");
+ public static final Symbol LONG_METHOD_COMBINATION =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION");
public static final Symbol METAOBJECT =
PACKAGE_MOP.addExternalSymbol("METAOBJECT");
public static final Symbol SPECIALIZER =
@@ -2987,6 +2991,48 @@
PACKAGE_MOP.addExternalSymbol("STANDARD-DIRECT-SLOT-DEFINITION");
public static final Symbol STANDARD_EFFECTIVE_SLOT_DEFINITION =
PACKAGE_MOP.addExternalSymbol("STANDARD-EFFECTIVE-SLOT-DEFINITION");
+ // MOP method combination readers.
+ public static final Symbol METHOD_COMBINATION_NAME =
+ PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-NAME");
+ public static final Symbol METHOD_COMBINATION_DOCUMENTATION =
+ PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-DOCUMENTATION");
+ public static final Symbol SHORT_METHOD_COMBINATION_OPERATOR =
+ PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-OPERATOR");
+ public static final Symbol SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT =
+ PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT");
+ public static final Symbol LONG_METHOD_COMBINATION_LAMBDA_LIST =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-LAMBDA-LIST");
+ public static final Symbol LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS");
+ public static final Symbol LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST");
+ public static final Symbol LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL");
+ public static final Symbol LONG_METHOD_COMBINATION_FUNCTION =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FUNCTION");
+ public static final Symbol LONG_METHOD_COMBINATION_ARGUMENTS =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGUMENTS");
+ public static final Symbol LONG_METHOD_COMBINATION_DECLARATIONS =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-DECLARATIONS");
+ public static final Symbol LONG_METHOD_COMBINATION_FORMS =
+ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FORMS");
+ public static final Symbol OPERATOR =
+ PACKAGE_MOP.addInternalSymbol("OPERATOR");
+ public static final Symbol IDENTITY_WITH_ONE_ARGUMENT =
+ PACKAGE_MOP.addInternalSymbol("IDENTITY-WITH-ONE-ARGUMENT");
+ public static final Symbol METHOD_GROUP_SPECS =
+ PACKAGE_MOP.addInternalSymbol("METHOD-GROUP-SPECS");
+ public static final Symbol ARGS_LAMBDA_LIST =
+ PACKAGE_MOP.addInternalSymbol("ARGS-LAMBDA-LIST");
+ public static final Symbol GENERIC_FUNCTION_SYMBOL =
+ PACKAGE_MOP.addInternalSymbol("GENERIC-FUNCTION-SYMBOL");
+ public static final Symbol ARGUMENTS =
+ PACKAGE_MOP.addInternalSymbol("ARGUMENTS");
+ public static final Symbol DECLARATIONS =
+ PACKAGE_MOP.addInternalSymbol("DECLARATIONS");
+ public static final Symbol FORMS =
+ PACKAGE_MOP.addInternalSymbol("FORMS");
+
// Java interface.
public static final Symbol JAVA_EXCEPTION =
@@ -3138,6 +3184,8 @@
PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME");
public static final Symbol JAVA_STACK_FRAME =
PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME");
+ public static final Symbol LAMBDA_LIST =
+ PACKAGE_SYS.addInternalSymbol("LAMBDA-LIST");
// CDR6
public static final Symbol _INSPECTOR_HOOK_ =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 6 14:14:08 2012 (r13725)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 6 14:45:48 2012 (r13726)
@@ -826,26 +826,6 @@
,(canonicalize-direct-slots direct-slots)
,@(canonicalize-defclass-options options)))
-(defstruct method-combination
- name
- documentation)
-
-(defstruct (short-method-combination
- (:include method-combination))
- operator
- identity-with-one-argument)
-
-(defstruct (long-method-combination
- (:include method-combination))
- lambda-list
- method-group-specs
- args-lambda-list
- generic-function-symbol
- function
- arguments
- declarations
- forms)
-
(defun expand-long-defcombin (name args)
(destructuring-bind (lambda-list method-groups &rest body) args
`(apply #'define-long-form-method-combination
@@ -854,6 +834,96 @@
(list ,@(mapcar #'canonicalize-method-group-spec method-groups))
',body)))
+;;; The class method-combination and its subclasses are defined in
+;;; StandardClass.java, but we cannot use make-instance and slot-value
+;;; yet.
+(defun make-short-method-combination (&key name documentation operator identity-with-one-argument)
+ (let ((instance (std-allocate-instance (find-class 'short-method-combination))))
+ (when name (setf (std-slot-value instance 'sys::name) name))
+ (when documentation
+ (setf (std-slot-value instance 'documentation) documentation))
+ (when operator (setf (std-slot-value instance 'operator) operator))
+ (when identity-with-one-argument
+ (setf (std-slot-value instance 'identity-with-one-argument)
+ identity-with-one-argument))
+ instance))
+
+(defun make-long-method-combination (&key name documentation lambda-list
+ method-group-specs args-lambda-list
+ generic-function-symbol function
+ arguments declarations forms)
+ (let ((instance (std-allocate-instance (find-class 'long-method-combination))))
+ (when name (setf (std-slot-value instance 'sys::name) name))
+ (when documentation
+ (setf (std-slot-value instance 'documentation) documentation))
+ (when lambda-list
+ (setf (std-slot-value instance 'sys::lambda-list) lambda-list))
+ (when method-group-specs
+ (setf (std-slot-value instance 'method-group-specs) method-group-specs))
+ (when args-lambda-list
+ (setf (std-slot-value instance 'args-lambda-list) args-lambda-list))
+ (when generic-function-symbol
+ (setf (std-slot-value instance 'generic-function-symbol)
+ generic-function-symbol))
+ (when function
+ (setf (std-slot-value instance 'function) function))
+ (when arguments
+ (setf (std-slot-value instance 'arguments) arguments))
+ (when declarations
+ (setf (std-slot-value instance 'declarations) declarations))
+ (when forms
+ (setf (std-slot-value instance 'forms) forms))
+ instance))
+
+(defun method-combination-name (method-combination)
+ (check-type method-combination method-combination)
+ (std-slot-value method-combination 'sys::name))
+
+(defun method-combination-documentation (method-combination)
+ (check-type method-combination method-combination)
+ (std-slot-value method-combination 'documentation))
+
+(defun short-method-combination-operator (method-combination)
+ (check-type method-combination short-method-combination)
+ (std-slot-value method-combination 'operator))
+
+(defun short-method-combination-identity-with-one-argument (method-combination)
+ (check-type method-combination short-method-combination)
+ (std-slot-value method-combination 'identity-with-one-argument))
+
+(defun long-method-combination-lambda-list (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'sys::lambda-list))
+
+(defun long-method-combination-method-group-specs (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'method-group-specs))
+
+(defun long-method-combination-args-lambda-list (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'args-lambda-list))
+
+(defun long-method-combination-generic-function-symbol (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'generic-function-symbol))
+
+(defun long-method-combination-function (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'function))
+
+(defun long-method-combination-arguments (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'arguments))
+
+(defun long-method-combination-declarations (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'declarations))
+
+(defun long-method-combination-forms (method-combination)
+ (check-type method-combination long-method-combination)
+ (std-slot-value method-combination 'forms))
+
+
(defun expand-short-defcombin (whole)
(let* ((name (cadr whole))
(documentation
More information about the armedbear-cvs
mailing list