Changeset 13781

Timestamp:

01/15/12 19:51:35 (11 years ago)

Author:

ehuelsmann

Message:

Support for the FUNCTION-KEYWORDS protocol, required to implement
keyword argument verification for effective methods.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (3 diffs)
• StandardMethod.java (modified) (3 diffs)
• StandardMethodClass.java (modified) (2 diffs)
• StandardReaderMethodClass.java (modified) (2 diffs)
• clos.lisp (modified) (7 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -578 +578 @@
         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);
@@ -638 +639 @@
         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);
@@ -649 +651 @@
         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");

trunk/abcl/src/org/armedbear/lisp/StandardMethod.java

@@ -57 +57 @@
     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;
@@ -64 +66 @@
   }
 
-  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")
@@ -96 +98 @@
     {
       checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second;
+      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;
     }

trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java

@@ -38 +38 @@
 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()
@@ -54 +58 @@
         Symbol.GENERIC_FUNCTION,
         pkg.intern("LAMBDA-LIST"),
+        pkg.intern("KEYWORDS"),
+        pkg.intern("OTHER_KEYWORDS_P"),
         pkg.intern("SPECIALIZERS"),
         pkg.intern("QUALIFIERS"),

trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java

@@ -41 +41 @@
   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()
@@ -59 +62 @@
         Symbol.GENERIC_FUNCTION,
         pkg.intern("LAMBDA-LIST"),
+        pkg.intern("KEYWORDS"),
+        pkg.intern("OTHER_KEYWORDS_P"),
         pkg.intern("SPECIALIZERS"),
         pkg.intern("QUALIFIERS"),

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -129 +129 @@
          (apply #',%name args)))))
 
+;;
+;;  DEFINE PLACE HOLDER FUNCTIONS
+;;
+
 (define-class->%class-forwarder class-name)
 (define-class->%class-forwarder (setf class-name))
@@ -156 +160 @@
          generic-function
          args))
+
+(defun function-keywords (method)
+  (%function-keywords method))
 
 
@@ -1420 +1427 @@
                  (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)
@@ -1758 +1766 @@
                                       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)
@@ -1766 +1776 @@
     (%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))
 
@@ -1928 +1941 @@
                         (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))
@@ -3329 +3344 @@
 (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)))