[armedbear-cvs] r13970 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Sun Jun 17 10:54:12 UTC 2012
Author: rschlatte
Date: Sun Jun 17 03:54:11 2012
New Revision: 13970
Log:
implement generic-function-declarations
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jun 16 15:02:34 2012 (r13969)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jun 17 03:54:11 2012 (r13970)
@@ -65,6 +65,7 @@
Symbol.STANDARD;
slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
NIL;
+ slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL;
slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL;
slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
}
@@ -114,6 +115,7 @@
Symbol.STANDARD;
slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
NIL;
+ slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL;
slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] =
NIL;
slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
@@ -484,6 +486,43 @@
}
};
+ private static final Primitive GENERIC_FUNCTION_DECLARATIONS
+ = new pf_generic_function_declarations();
+ @DocString(name="%generic-function-declarations")
+ private static final class pf_generic_function_declarations extends Primitive
+ {
+ pf_generic_function_declarations()
+ {
+ super("%generic-function-declarations", PACKAGE_SYS, true);
+ }
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ return checkStandardGenericFunction(arg)
+ .slots[StandardGenericFunctionClass .SLOT_INDEX_DECLARATIONS];
+ }
+ };
+
+ private static final Primitive SET_GENERIC_FUNCTION_DECLARATIONS
+ = new pf_set_generic_function_declarations();
+ @DocString(name="set-generic-function-declarations")
+ private static final class pf_set_generic_function_declarations extends Primitive
+ {
+ pf_set_generic_function_declarations()
+ {
+ super("set-generic-function-declarations", PACKAGE_SYS, true);
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+ {
+ checkStandardGenericFunction(first)
+ .slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = second;
+ return second;
+ }
+ };
+
+
+
private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE
= new pf_generic_function_classes_to_emf_table();
@DocString(name="generic-function-classes-to-emf-table")
Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sat Jun 16 15:02:34 2012 (r13969)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sun Jun 17 03:54:11 2012 (r13970)
@@ -46,8 +46,9 @@
public static final int SLOT_INDEX_METHOD_CLASS = 6;
public static final int SLOT_INDEX_METHOD_COMBINATION = 7;
public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 8;
- public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 9;
- public static final int SLOT_INDEX_DOCUMENTATION = 10;
+ public static final int SLOT_INDEX_DECLARATIONS = 9;
+ public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 10;
+ public static final int SLOT_INDEX_DOCUMENTATION = 11;
public StandardGenericFunctionClass()
{
@@ -65,6 +66,7 @@
pkg.intern("METHOD-CLASS"),
pkg.intern("%METHOD-COMBINATION"),
pkg.intern("ARGUMENT-PRECEDENCE-ORDER"),
+ Symbol.DECLARATIONS,
pkg.intern("CLASSES-TO-EMF-TABLE"),
Symbol._DOCUMENTATION
};
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jun 16 15:02:34 2012 (r13969)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 03:54:11 2012 (r13970)
@@ -1412,10 +1412,17 @@
&rest options-and-method-descriptions)
(let ((options ())
(methods ())
+ (declarations ())
(documentation nil))
(dolist (item options-and-method-descriptions)
(case (car item)
- (declare) ; FIXME
+ (declare
+ (when declarations
+ (error 'program-error
+ :format-control "Two declare forms in definition of generic function ~S."
+ :format-arguments (list function-name)))
+ (setf declarations t)
+ (push (list :declarations (cdr item)) options))
(:documentation
(when documentation
(error 'program-error
@@ -1608,6 +1615,7 @@
method-class
method-combination
argument-precedence-order
+ declarations
documentation)
;; to avoid circularities, we do not call generic functions in here.
(declare (ignore generic-function-class))
@@ -1618,6 +1626,7 @@
(set-generic-function-methods gf ())
(set-generic-function-method-class gf method-class)
(set-generic-function-method-combination gf method-combination)
+ (set-generic-function-declarations gf declarations)
(set-generic-function-documentation gf documentation)
(set-generic-function-classes-to-emf-table gf nil)
(let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
@@ -4030,15 +4039,14 @@
(finalize-standard-generic-function instance))
;;; Readers for generic function metaobjects
-;;; See AMOP pg. 216ff.
+;;; AMOP pg. 216ff.
(atomic-defgeneric generic-function-argument-precedence-order (generic-function)
(:method ((generic-function standard-generic-function))
(sys:%generic-function-argument-precedence-order generic-function)))
(atomic-defgeneric generic-function-declarations (generic-function)
(:method ((generic-function standard-generic-function))
- ;; TODO: add slot to StandardGenericFunctionClass.java, use it
- nil))
+ (sys:%generic-function-declarations generic-function)))
(atomic-defgeneric generic-function-lambda-list (generic-function)
(:method ((generic-function standard-generic-function))
@@ -4254,10 +4262,12 @@
method-class
method-combination
argument-precedence-order
+ declarations
documentation
&allow-other-keys)
(declare (ignore lambda-list generic-function-class method-class
- method-combination argument-precedence-order documentation))
+ method-combination argument-precedence-order declarations
+ documentation))
(apply #'ensure-generic-function-using-class
(find-generic-function function-name nil)
function-name all-keys))
More information about the armedbear-cvs
mailing list