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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Mar 18 15:08:57 2012
New Revision: 13888

Log:
Clobber subclasses of standard-generic-function into workingness.

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

Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java	Sun Mar 18 15:08:54 2012	(r13887)
+++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java	Sun Mar 18 15:08:57 2012	(r13888)
@@ -186,10 +186,13 @@
     {
       if (arg.typep(StandardClass.FUNCALLABLE_STANDARD_CLASS) != NIL) {
         LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
-        if (! (l instanceof Layout))
+        if (! (l instanceof Layout)) {
           return error(new ProgramError("Invalid standard class layout for: " + arg.princToString()));
-
-        return new FuncallableStandardObject((Layout)l);
+        }
+        // KLUDGE (rudi 2012-03-17): make (make-instance
+        // 'standard-generic-function) work -- subsequent code expects
+        // the additional slots to be present.
+        return new StandardGenericFunction((Layout)l);
       }
       return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS);
     }

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Mar 18 15:08:54 2012	(r13887)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Mar 18 15:08:57 2012	(r13888)
@@ -49,6 +49,26 @@
           StandardClass.STANDARD_GENERIC_FUNCTION.getClassLayout().getLength());
   }
 
+  public StandardGenericFunction(Layout layout)
+  {
+    super(layout);
+    slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = NIL;
+    numberOfRequiredArgs = 0;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] =
+      StandardClass.STANDARD_METHOD;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] =
+      Symbol.STANDARD;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
+      NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL;
+    slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
+  }
+
   public StandardGenericFunction(String name, Package pkg, boolean exported,
                                  Function function, LispObject lambdaList,
                                  LispObject specializers)

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Mar 18 15:08:54 2012	(r13887)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Mar 18 15:08:57 2012	(r13888)
@@ -3775,6 +3775,21 @@
 (defmethod class-prototype ((class structure-class))
   (allocate-instance class))
 
+(defmethod shared-initialize :after ((instance standard-generic-function)
+                                     slot-names
+                                     &key lambda-list argument-precedence-order
+                                     &allow-other-keys)
+  (let* ((plist (analyze-lambda-list lambda-list))
+         (required-args (getf plist ':required-args)))
+    (%set-gf-required-args instance required-args)
+    (%set-gf-optional-args instance (getf plist :optional-args))
+    (set-generic-function-argument-precedence-order instance
+                                                    (if argument-precedence-order
+                                                        (canonicalize-argument-precedence-order argument-precedence-order
+                                                                                                required-args)
+                                                        nil)))
+  (finalize-standard-generic-function instance))
+
 ;;; Readers for generic function metaobjects
 ;;; See AMOP pg. 216ff.
 (atomic-defgeneric generic-function-argument-precedence-order (generic-function)