[armedbear-cvs] r13777 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Jan 15 05:06:26 2012
New Revision: 13777

Log:
Record optional parameters in generic function objects for quick retrieval.

Modified:
   trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
   trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sat Jan 14 23:24:34 2012	(r13776)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Jan 15 05:06:26 2012	(r13777)
@@ -66,6 +66,8 @@
       lambdaList;
     slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] =
       lambdaList;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] =
+      NIL;
     numberOfRequiredArgs = lambdaList.length();
     slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] =
       NIL;
@@ -246,6 +248,40 @@
       return second;
     }
   };
+
+  private static final Primitive GF_OPTIONAL_ARGS 
+    = new pf_gf_optional_args();
+  @DocString(name="gf-optional-args")
+  private static final class pf_gf_optional_args extends Primitive 
+  {
+    pf_gf_optional_args()
+    {
+      super("gf-optional-args", PACKAGE_SYS, true);
+    }
+    @Override
+    public LispObject execute(LispObject arg)
+    {
+      return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS];
+    }
+  };
+
+  private static final Primitive _SET_GF_OPTIONAL_ARGS
+    = new pf__set_gf_optional_args();
+  @DocString(name="%set-gf-optional-args")
+  private static final class pf__set_gf_optional_args extends Primitive
+  {
+    pf__set_gf_optional_args()
+    {
+      super("%set-gf-optional-args", PACKAGE_SYS, true);
+    }
+    @Override
+    public LispObject execute(LispObject first, LispObject second)
+    {
+      final StandardGenericFunction gf = checkStandardGenericFunction(first);
+      gf.slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = second;
+      return second;
+    }
+  };
 
   private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS 
     = new pf_generic_function_initial_methods();

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java	Sat Jan 14 23:24:34 2012	(r13776)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java	Sun Jan 15 05:06:26 2012	(r13777)
@@ -40,13 +40,14 @@
   public static final int SLOT_INDEX_NAME                      = 0;
   public static final int SLOT_INDEX_LAMBDA_LIST               = 1;
   public static final int SLOT_INDEX_REQUIRED_ARGS             = 2;
-  public static final int SLOT_INDEX_INITIAL_METHODS           = 3;
-  public static final int SLOT_INDEX_METHODS                   = 4;
-  public static final int SLOT_INDEX_METHOD_CLASS              = 5;
-  public static final int SLOT_INDEX_METHOD_COMBINATION        = 6;
-  public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 7;
-  public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE      = 8;
-  public static final int SLOT_INDEX_DOCUMENTATION             = 9;
+  public static final int SLOT_INDEX_OPTIONAL_ARGS             = 3;
+  public static final int SLOT_INDEX_INITIAL_METHODS           = 4;
+  public static final int SLOT_INDEX_METHODS                   = 5;
+  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 StandardGenericFunctionClass()
   {
@@ -58,6 +59,7 @@
         pkg.intern("NAME"),
         pkg.intern("LAMBDA-LIST"),
         pkg.intern("REQUIRED-ARGS"),
+        pkg.intern("OPTIONAL-ARGS"),
         pkg.intern("INITIAL-METHODS"),
         pkg.intern("METHODS"),
         pkg.intern("METHOD-CLASS"),