[armedbear-cvs] r13781 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun Jan 15 19:51:36 UTC 2012
Author: ehuelsmann
Date: Sun Jan 15 11:51:35 2012
New Revision: 13781
Log:
Support for the FUNCTION-KEYWORDS protocol, required to implement
keyword argument verification for effective methods.
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/StandardMethod.java
trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java
trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 11:45:23 2012 (r13780)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 11:51:35 2012 (r13781)
@@ -577,6 +577,7 @@
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");
@@ -637,6 +638,7 @@
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);
@@ -648,6 +650,7 @@
autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "get-function-info-value", "function_info");
autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true);
+ autoload(PACKAGE_SYS, "gf-optional-args", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions");
autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions");
autoload(PACKAGE_SYS, "layout-class", "Layout", true);
Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Jan 15 11:45:23 2012 (r13780)
+++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Jan 15 11:51:35 2012 (r13781)
@@ -56,6 +56,8 @@
this();
slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = gf;
slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = lambdaList;
+ slots[StandardMethodClass.SLOT_INDEX_KEYWORDS] = NIL;
+ slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P] = NIL;
slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = specializers;
slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = NIL;
slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = NIL;
@@ -63,8 +65,8 @@
slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = NIL;
}
- private static final Primitive METHOD_LAMBDA_LIST
- = new pf_method_lambda_list();
+ private static final Primitive METHOD_LAMBDA_LIST
+ = new pf_method_lambda_list();
@DocString(name="method-lambda-list",
args="generic-method")
private static final class pf_method_lambda_list extends Primitive
@@ -98,6 +100,50 @@
return second;
}
};
+
+ private static final Primitive _FUNCTION_KEYWORDS
+ = new pf__function_keywords();
+ @DocString(name="%function-keywords",
+ args="standard-method")
+ private static final class pf__function_keywords extends Primitive
+ {
+ pf__function_keywords()
+ {
+ super("%function-keywords", PACKAGE_SYS, true, "method");
+ }
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ StandardMethod method = checkStandardMethod(arg);
+ LispThread thread = LispThread.currentThread();
+
+ return thread
+ .setValues(method.slots[StandardMethodClass.SLOT_INDEX_KEYWORDS],
+ method.slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P]);
+ }
+ };
+
+ private static final Primitive _SET_FUNCTION_KEYWORDS
+ = new pf__set_function_keywords();
+ @DocString(name="%set-function-keywords",
+ args="standard-method keywords other-keywords-p")
+ private static final class pf__set_function_keywords extends Primitive
+ {
+ pf__set_function_keywords()
+ {
+ super("%set-function-keywords", PACKAGE_SYS, true,
+ "method keywords");
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third)
+ {
+ StandardMethod method = checkStandardMethod(first);
+ method.slots[StandardMethodClass.SLOT_INDEX_KEYWORDS] = second;
+ method.slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P] = third;
+ return second;
+ }
+ };
private static final Primitive _METHOD_QUALIFIERS
Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java Sun Jan 15 11:45:23 2012 (r13780)
+++ trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java Sun Jan 15 11:51:35 2012 (r13781)
@@ -37,13 +37,17 @@
public final class StandardMethodClass extends StandardClass
{
+ // When changing this list, don't forget to edit
+ // StandardReaderMethodClass as well
public static final int SLOT_INDEX_GENERIC_FUNCTION = 0;
public static final int SLOT_INDEX_LAMBDA_LIST = 1;
- public static final int SLOT_INDEX_SPECIALIZERS = 2;
- public static final int SLOT_INDEX_QUALIFIERS = 3;
- public static final int SLOT_INDEX_FUNCTION = 4;
- public static final int SLOT_INDEX_FAST_FUNCTION = 5;
- public static final int SLOT_INDEX_DOCUMENTATION = 6;
+ public static final int SLOT_INDEX_KEYWORDS = 2;
+ public static final int SLOT_INDEX_OTHER_KEYWORDS_P = 3;
+ public static final int SLOT_INDEX_SPECIALIZERS = 4;
+ public static final int SLOT_INDEX_QUALIFIERS = 5;
+ public static final int SLOT_INDEX_FUNCTION = 6;
+ public static final int SLOT_INDEX_FAST_FUNCTION = 7;
+ public static final int SLOT_INDEX_DOCUMENTATION = 8;
public StandardMethodClass()
{
@@ -53,6 +57,8 @@
{
Symbol.GENERIC_FUNCTION,
pkg.intern("LAMBDA-LIST"),
+ pkg.intern("KEYWORDS"),
+ pkg.intern("OTHER_KEYWORDS_P"),
pkg.intern("SPECIALIZERS"),
pkg.intern("QUALIFIERS"),
Symbol.FUNCTION,
Modified: trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java Sun Jan 15 11:45:23 2012 (r13780)
+++ trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java Sun Jan 15 11:51:35 2012 (r13781)
@@ -40,14 +40,17 @@
// From StandardMethodClass.java:
public static final int SLOT_INDEX_GENERIC_FUNCTION = 0;
public static final int SLOT_INDEX_LAMBDA_LIST = 1;
- public static final int SLOT_INDEX_SPECIALIZERS = 2;
- public static final int SLOT_INDEX_QUALIFIERS = 3;
- public static final int SLOT_INDEX_FUNCTION = 4;
- public static final int SLOT_INDEX_FAST_FUNCTION = 5;
- public static final int SLOT_INDEX_DOCUMENTATION = 6;
+ public static final int SLOT_INDEX_KEYWORDS = 2;
+ public static final int SLOT_INDEX_OTHER_KEYWORDS_P = 3;
+ public static final int SLOT_INDEX_SPECIALIZERS = 4;
+ public static final int SLOT_INDEX_QUALIFIERS = 5;
+ public static final int SLOT_INDEX_FUNCTION = 6;
+ public static final int SLOT_INDEX_FAST_FUNCTION = 7;
+ public static final int SLOT_INDEX_DOCUMENTATION = 8;
+
// Added:
- public static final int SLOT_INDEX_SLOT_NAME = 7;
+ public static final int SLOT_INDEX_SLOT_NAME = 9;
public StandardReaderMethodClass()
{
@@ -58,6 +61,8 @@
{
Symbol.GENERIC_FUNCTION,
pkg.intern("LAMBDA-LIST"),
+ pkg.intern("KEYWORDS"),
+ pkg.intern("OTHER_KEYWORDS_P"),
pkg.intern("SPECIALIZERS"),
pkg.intern("QUALIFIERS"),
Symbol.FUNCTION,
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:45:23 2012 (r13780)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:51:35 2012 (r13781)
@@ -128,6 +128,10 @@
(defun ,name (&rest args)
(apply #',%name args)))))
+;;
+;; DEFINE PLACE HOLDER FUNCTIONS
+;;
+
(define-class->%class-forwarder class-name)
(define-class->%class-forwarder (setf class-name))
(define-class->%class-forwarder class-slots)
@@ -156,6 +160,9 @@
generic-function
args))
+(defun function-keywords (method)
+ (%function-keywords method))
+
(defmacro push-on-end (value location)
@@ -1419,6 +1426,7 @@
(let* ((plist (analyze-lambda-list lambda-list))
(required-args (getf plist ':required-args)))
(%set-gf-required-args gf required-args)
+ (%set-gf-optional-args gf (getf plist :optional-args))
(when apo-p
(setf (generic-function-argument-precedence-order gf)
(if argument-precedence-order
@@ -1757,7 +1765,9 @@
function
fast-function)
(declare (ignore gf))
- (let ((method (std-allocate-instance +the-standard-method-class+)))
+ (let ((method (std-allocate-instance +the-standard-method-class+))
+ (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))
@@ -1765,6 +1775,9 @@
(%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))
method))
(defun %add-method (gf method)
@@ -1927,6 +1940,8 @@
(if emfun
(funcall emfun args)
(slow-method-lookup gf args))))))
+;; (let ((non-key-args (+ number-required
+;; (length (gf-optional-args gf))))))
#'(lambda (&rest args)
(declare (optimize speed))
(let ((len (length args)))
@@ -3328,8 +3343,9 @@
;; FIXME
(defgeneric no-next-method (generic-function method &rest args))
-;; FIXME
-(defgeneric function-keywords (method))
+(atomic-defgeneric function-keywords (method)
+ (:method ((method standard-method))
+ (%function-keywords method)))
(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
More information about the armedbear-cvs
mailing list