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

rschlatte at common-lisp.net rschlatte at common-lisp.net
Sat Jan 14 20:07:01 UTC 2012


Author: rschlatte
Date: Sat Jan 14 12:07:00 2012
New Revision: 13775

Log:
Support for funcallable instances.

... Move execute, set-funcallable-instance-function upwards from
    StandardGenericFunction to new class FuncallableStandardObject.

... Add various MOPpy methods for funcallable-standard-class, which
    isn't a subclass of standard-class, unfortunately.

Added:
   trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java
Modified:
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/StandardClass.java
   trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.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	Sat Jan 14 08:52:48 2012	(r13774)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sat Jan 14 12:07:00 2012	(r13775)
@@ -534,11 +534,11 @@
         autoload(PACKAGE_JAVA, "%add-to-classpath", "JavaClassLoader");
         autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader");
         autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true);
-        autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
+        autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false);
         autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
         autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
         autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);
-        autoload(PACKAGE_MOP, "set-funcallable-instance-function", "StandardGenericFunction", true);
+        autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true);
         autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true);
         autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true);
         autoload(PACKAGE_SYS, "%%string=", "StringFunctions");
@@ -693,6 +693,7 @@
         autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates");
         autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true);
         autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true);
+        autoload(PACKAGE_SYS, "%allocate-funcallable-instance", "FuncallableStandardObject", true);
         autoload(PACKAGE_SYS, "unzip", "unzip", true);
         autoload(PACKAGE_SYS, "zip", "zip", true);
 

Added: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java	Sat Jan 14 12:07:00 2012	(r13775)
@@ -0,0 +1,287 @@
+/*
+ * FuncallableStandardObject.java
+ *
+ * Copyright (C) 2003-2006 Peter Graves, 2012 Rudolf Schlatte
+ * $Id$
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module.  An independent module is a module which is not derived from
+ * or based on this library.  If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so.  If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+
+// TODO: swap-slots is currently handled by StandardObject, so doesn't
+// exchange the functions.
+package org.armedbear.lisp;
+
+import static org.armedbear.lisp.Lisp.*;
+
+public class FuncallableStandardObject extends StandardObject
+{
+  protected LispObject function;
+  protected int numberOfRequiredArgs;
+
+  protected FuncallableStandardObject()
+  {
+    super();
+  }
+
+
+  protected FuncallableStandardObject(Layout layout)
+  {
+    this(layout, layout.getLength());
+  }
+
+  protected FuncallableStandardObject(Layout layout, int length)
+  {
+    super(layout, length);
+  }
+
+
+  protected FuncallableStandardObject(LispClass cls, int length)
+  {
+    super(cls, length);
+  }
+
+  protected FuncallableStandardObject(LispClass cls)
+  {
+    super(cls);
+  }
+
+  @Override
+  public LispObject typep(LispObject type)
+  {
+    if (type == Symbol.COMPILED_FUNCTION)
+      {
+        if (function != null)
+          return function.typep(type);
+        else
+          return NIL;
+      }
+    if (type == Symbol.FUNCALLABLE_STANDARD_OBJECT)
+      return T;
+    if (type == StandardClass.FUNCALLABLE_STANDARD_OBJECT)
+      return T;
+    return super.typep(type);
+  }
+
+  @Override
+  public LispObject execute()
+  {
+    return function.execute();
+  }
+
+  @Override
+  public LispObject execute(LispObject arg)
+  {
+    return function.execute(arg);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second)
+
+  {
+    return function.execute(first, second);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third)
+
+  {
+    return function.execute(first, second, third);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third, LispObject fourth)
+
+  {
+    return function.execute(first, second, third, fourth);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third, LispObject fourth,
+                            LispObject fifth)
+
+  {
+    return function.execute(first, second, third, fourth,
+                            fifth);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third, LispObject fourth,
+                            LispObject fifth, LispObject sixth)
+
+  {
+    return function.execute(first, second, third, fourth,
+                            fifth, sixth);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third, LispObject fourth,
+                            LispObject fifth, LispObject sixth,
+                            LispObject seventh)
+
+  {
+    return function.execute(first, second, third, fourth,
+                            fifth, sixth, seventh);
+  }
+
+  @Override
+  public LispObject execute(LispObject first, LispObject second,
+                            LispObject third, LispObject fourth,
+                            LispObject fifth, LispObject sixth,
+                            LispObject seventh, LispObject eighth)
+
+  {
+    return function.execute(first, second, third, fourth,
+                            fifth, sixth, seventh, eighth);
+  }
+
+  @Override
+  public LispObject execute(LispObject[] args)
+  {
+    return function.execute(args);
+  }
+
+  private static final Primitive _ALLOCATE_FUNCALLABLE_INSTANCE
+    = new pf__allocate_funcallable_instance();
+  @DocString(name="%allocate-funcallable-instance",
+             args="class",
+             returns="instance")
+  private static final class pf__allocate_funcallable_instance extends Primitive
+  {
+    pf__allocate_funcallable_instance()
+    {
+      super("%allocate-funcallable-instance", PACKAGE_SYS, true, "class");
+    }
+    @Override
+    public LispObject execute(LispObject arg)
+    {
+      if (arg.typep(StandardClass.FUNCALLABLE_STANDARD_CLASS) != NIL) {
+        LispObject l = Symbol.CLASS_LAYOUT.execute(arg);
+        if (! (l instanceof Layout))
+          return error(new ProgramError("Invalid standard class layout for: " + arg.princToString()));
+
+        return new FuncallableStandardObject((Layout)l);
+      }
+      return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS);
+    }
+  };
+
+  // AMOP p. 230
+  private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION
+    = new pf_set_funcallable_instance_function();
+  @DocString(name="set-funcallable-instance-function",
+             args="funcallable-instance function",
+             returns="unspecified")
+  private static final class pf_set_funcallable_instance_function extends Primitive 
+  {
+    pf_set_funcallable_instance_function()
+    {
+      super("set-funcallable-instance-function", PACKAGE_MOP, true,
+            "funcallable-instance function");
+    }
+    @Override
+    public LispObject execute(LispObject first, LispObject second)
+    {
+      checkFuncallableStandardObject(first).function = second;
+      return second;
+    }
+  };
+
+  private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION
+    = new pf_funcallable_instance_function();
+  @DocString(name="funcallable-instance-function",
+             args="funcallable-instance",
+             returns="function")
+  private static final class pf_funcallable_instance_function extends Primitive 
+  {
+    pf_funcallable_instance_function()
+    {
+      super("funcallable-instance-function", PACKAGE_MOP, false,
+            "funcallable-instance");
+    }
+    @Override
+    public LispObject execute(LispObject arg)
+    {
+      return checkFuncallableStandardObject(arg).function;
+    }
+  };
+
+
+  // Profiling.
+  private int callCount;
+  private int hotCount;
+
+  @Override
+  public final int getCallCount()
+  {
+    return callCount;
+  }
+
+  @Override
+  public void setCallCount(int n)
+  {
+    callCount = n;
+  }
+
+  @Override
+  public final void incrementCallCount()
+  {
+    ++callCount;
+  }
+
+  @Override
+  public final int getHotCount()
+  {
+    return hotCount;
+  }
+
+  @Override
+  public void setHotCount(int n)
+  {
+    hotCount = n;
+  }
+
+  @Override
+  public final void incrementHotCount()
+  {
+    ++hotCount;
+  }
+
+  public static final FuncallableStandardObject checkFuncallableStandardObject(LispObject obj)
+  {
+    if (obj instanceof FuncallableStandardObject)
+      return (FuncallableStandardObject) obj;
+    return (FuncallableStandardObject) // Not reached.
+      type_error(obj, Symbol.FUNCALLABLE_STANDARD_OBJECT);
+  }
+
+}

Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sat Jan 14 08:52:48 2012	(r13774)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sat Jan 14 12:07:00 2012	(r13775)
@@ -452,13 +452,6 @@
 
   public static final StandardClass FUNCALLABLE_STANDARD_CLASS =
     addStandardClass(Symbol.FUNCALLABLE_STANDARD_CLASS, list(CLASS));
-  static
-  {
-    // funcallable-standard-class has more or less the same interface as
-    // standard-class.
-    FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass);
-    FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
-  }
 
   public static final StandardClass CONDITION =
     addStandardClass(Symbol.CONDITION, list(STANDARD_OBJECT));
@@ -581,8 +574,6 @@
     addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD);
   }
 
-  // ### TODO move functionality upwards into funcallable-stanard-object
-  // and use addStandardClass() here
   public static final StandardClass STANDARD_GENERIC_FUNCTION =
     new StandardGenericFunctionClass();
   static
@@ -749,6 +740,13 @@
                           CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T);
     STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, SPECIALIZER, METAOBJECT,
                           STANDARD_OBJECT, BuiltInClass.CLASS_T);
+    FUNCALLABLE_STANDARD_CLASS.setCPL(FUNCALLABLE_STANDARD_CLASS, CLASS,
+                                      SPECIALIZER, METAOBJECT, STANDARD_OBJECT,
+                                      BuiltInClass.CLASS_T);
+    // funcallable-standard-class has the same interface as
+    // standard-class.
+    FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass);
+    FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
     STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T);
     STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION,
                              STANDARD_OBJECT, BuiltInClass.CLASS_T);
@@ -786,6 +784,7 @@
     STANDARD_OBJECT.finalizeClass();
     FUNCALLABLE_STANDARD_OBJECT.finalizeClass();
     CLASS.finalizeClass();
+    FUNCALLABLE_STANDARD_CLASS.finalizeClass();
     GENERIC_FUNCTION.finalizeClass();
     ARITHMETIC_ERROR.finalizeClass();
     CELL_ERROR.finalizeClass();

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sat Jan 14 08:52:48 2012	(r13774)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sat Jan 14 12:07:00 2012	(r13775)
@@ -37,11 +37,8 @@
 
 import java.util.concurrent.ConcurrentHashMap;
 
-public final class StandardGenericFunction extends StandardObject
+public final class StandardGenericFunction extends FuncallableStandardObject
 {
-  LispObject function;
-
-  int numberOfRequiredArgs;
 
   ConcurrentHashMap<CacheEntry,LispObject> cache;
   ConcurrentHashMap<LispObject,LispObject> slotCache;
@@ -120,89 +117,6 @@
   }
 
   @Override
-  public LispObject execute()
-  {
-    return function.execute();
-  }
-
-  @Override
-  public LispObject execute(LispObject arg)
-  {
-    return function.execute(arg);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second)
-
-  {
-    return function.execute(first, second);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third)
-
-  {
-    return function.execute(first, second, third);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third, LispObject fourth)
-
-  {
-    return function.execute(first, second, third, fourth);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third, LispObject fourth,
-                            LispObject fifth)
-
-  {
-    return function.execute(first, second, third, fourth,
-                            fifth);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third, LispObject fourth,
-                            LispObject fifth, LispObject sixth)
-
-  {
-    return function.execute(first, second, third, fourth,
-                            fifth, sixth);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third, LispObject fourth,
-                            LispObject fifth, LispObject sixth,
-                            LispObject seventh)
-
-  {
-    return function.execute(first, second, third, fourth,
-                            fifth, sixth, seventh);
-  }
-
-  @Override
-  public LispObject execute(LispObject first, LispObject second,
-                            LispObject third, LispObject fourth,
-                            LispObject fifth, LispObject sixth,
-                            LispObject seventh, LispObject eighth)
-
-  {
-    return function.execute(first, second, third, fourth,
-                            fifth, sixth, seventh, eighth);
-  }
-
-  @Override
-  public LispObject execute(LispObject[] args)
-  {
-    return function.execute(args);
-  }
-
-  @Override
   public String printObject()
   {
     LispObject name = getGenericFunctionName();
@@ -224,46 +138,6 @@
     return super.printObject();
   }
 
-  // Profiling.
-  private int callCount;
-  private int hotCount;
-
-  @Override
-  public final int getCallCount()
-  {
-    return callCount;
-  }
-
-  @Override
-  public void setCallCount(int n)
-  {
-    callCount = n;
-  }
-
-  @Override
-  public final void incrementCallCount()
-  {
-    ++callCount;
-  }
-
-  @Override
-  public final int getHotCount()
-  {
-    return hotCount;
-  }
-
-  @Override
-  public void setHotCount(int n)
-  {
-    hotCount = n;
-  }
-
-  @Override
-  public final void incrementHotCount()
-  {
-    ++hotCount;
-  }
-
   // AMOP (p. 216) specifies the following readers as generic functions:
   //   generic-function-argument-precedence-order
   //   generic-function-declarations
@@ -337,46 +211,6 @@
       return second;
     }
   };
-
-  private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION 
-    = new pf_funcallable_instance_function();
-  @DocString(name="funcallable-instance-function",
-             args="funcallable-instance",
-             returns="function")
-  private static final class pf_funcallable_instance_function extends Primitive 
-  {
-    pf_funcallable_instance_function()
-    {
-      super("funcallable-instance-function", PACKAGE_MOP, false,
-            "funcallable-instance");
-    }
-    @Override
-    public LispObject execute(LispObject arg)
-    {
-      return checkStandardGenericFunction(arg).function;
-    }
-  };
-
-  // AMOP p. 230
-  private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION 
-    = new pf_set_funcallable_instance_function();
-  @DocString(name="set-funcallable-instance-function",
-             args="funcallable-instance function",
-             returns="unspecified")
-  private static final class pf_set_funcallable_instance_function extends Primitive 
-  {
-    pf_set_funcallable_instance_function()
-    {
-      super("set-funcallable-instance-function", PACKAGE_MOP, true,
-            "funcallable-instance function");
-    }
-    @Override
-    public LispObject execute(LispObject first, LispObject second)
-    {
-      checkStandardGenericFunction(first).function = second;
-      return second;
-    }
-  };
 
   private static final Primitive GF_REQUIRED_ARGS 
     = new pf_gf_required_args();

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Jan 14 08:52:48 2012	(r13774)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Jan 14 12:07:00 2012	(r13775)
@@ -686,6 +686,11 @@
     (std-finalize-inheritance class))
   (sys::%std-allocate-instance class))
 
+(defun allocate-funcallable-instance (class)
+  (unless (class-finalized-p class)
+    (std-finalize-inheritance class))
+  (sys::%allocate-funcallable-instance class))
+
 (defun make-instance-standard-class (metaclass
 				     &rest initargs
                                      &key name direct-superclasses direct-slots
@@ -2650,7 +2655,9 @@
 
 (defmethod slot-value-using-class ((class standard-class) instance slot-name)
   (std-slot-value instance slot-name))
-
+(defmethod slot-value-using-class ((class funcallable-standard-class)
+                                   instance slot-name)
+  (std-slot-value instance slot-name))
 (defmethod slot-value-using-class ((class structure-class) instance slot-name)
   (std-slot-value instance slot-name))
 
@@ -2663,6 +2670,12 @@
   (setf (std-slot-value instance slot-name) new-value))
 
 (defmethod (setf slot-value-using-class) (new-value
+                                          (class funcallable-standard-class)
+                                          instance
+                                          slot-name)
+  (setf (std-slot-value instance slot-name) new-value))
+
+(defmethod (setf slot-value-using-class) (new-value
                                           (class structure-class)
                                           instance
                                           slot-name)
@@ -2675,6 +2688,8 @@
 
 (defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
   (std-slot-exists-p instance slot-name))
+(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name)
+  (std-slot-exists-p instance slot-name))
 
 (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
   (dolist (dsd (class-slots class))
@@ -2685,6 +2700,8 @@
 (defgeneric slot-boundp-using-class (class instance slot-name))
 (defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
   (std-slot-boundp instance slot-name))
+(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name)
+  (std-slot-boundp instance slot-name))
 (defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
   "Structure slots can't be unbound, so this method always returns T."
   (declare (ignore class instance slot-name))
@@ -2695,6 +2712,10 @@
                                         instance
                                         slot-name)
   (std-slot-makunbound instance slot-name))
+(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
+                                        instance
+                                        slot-name)
+  (std-slot-makunbound instance slot-name))
 (defmethod slot-makunbound-using-class ((class structure-class)
                                         instance
                                         slot-name)
@@ -2720,6 +2741,10 @@
   (declare (ignore initargs))
   (std-allocate-instance class))
 
+(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
+  (declare (ignore initargs))
+  (allocate-funcallable-instance class))
+
 (defmethod allocate-instance ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (%make-structure (class-name class)
@@ -2811,7 +2836,7 @@
 
 (defgeneric make-instance (class &rest initargs &key &allow-other-keys))
 
-(defmethod make-instance ((class standard-class) &rest initargs)
+(defmethod make-instance ((class class) &rest initargs)
   (when (oddp (length initargs))
     (error 'program-error :format-control "Odd number of keyword arguments."))
   (unless (class-finalized-p class)
@@ -2827,7 +2852,7 @@
             (setf default-initargs (append default-initargs (list key (funcall fn))))))
         (setf initargs (append initargs default-initargs)))))
 
-  (let ((instance (std-allocate-instance class)))
+  (let ((instance (allocate-instance class)))
     (check-initargs (list #'allocate-instance #'initialize-instance)
                     (list* instance initargs)
                     instance t initargs
@@ -2955,7 +2980,8 @@
 
 (defmethod make-instances-obsolete ((class standard-class))
   (%make-instances-obsolete class))
-
+(defmethod make-instances-obsolete ((class funcallable-standard-class))
+  (%make-instances-obsolete class))
 (defmethod make-instances-obsolete ((class symbol))
   (make-instances-obsolete (find-class class))
   class)
@@ -2987,6 +3013,10 @@
 (defmethod initialize-instance :after ((class standard-class) &rest args)
   (apply #'std-after-initialization-for-classes class args))
 
+(defmethod initialize-instance :after ((class funcallable-standard-class)
+                                       &rest args)
+  (apply #'std-after-initialization-for-classes class args))
+
 (defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
   (remhash class *make-instance-initargs-cache*)
   (remhash class *reinitialize-instance-initargs-cache*)
@@ -3012,6 +3042,8 @@
 (defgeneric compute-class-precedence-list (class))
 (defmethod compute-class-precedence-list ((class standard-class))
   (std-compute-class-precedence-list class))
+(defmethod compute-class-precedence-list ((class funcallable-standard-class))
+  (std-compute-class-precedence-list class))
 
 ;;; Slot inheritance
 
@@ -3025,7 +3057,9 @@
 (defmethod compute-effective-slot-definition
   ((class standard-class) name direct-slots)
   (std-compute-effective-slot-definition class name direct-slots))
-
+(defmethod compute-effective-slot-definition
+  ((class funcallable-standard-class) name direct-slots)
+  (std-compute-effective-slot-definition class name direct-slots))
 ;;; Methods having to do with generic function metaobjects.
 
 (defmethod initialize-instance :after ((gf standard-generic-function) &key)
@@ -3313,6 +3347,9 @@
 (defmethod class-prototype ((class standard-class))
   (allocate-instance class))
 
+(defmethod class-prototype ((class funcallable-standard-class))
+  (allocate-instance class))
+
 (defmethod class-prototype ((class structure-class))
   (allocate-instance class))
 




More information about the armedbear-cvs mailing list