Changeset 14499

Timestamp:

05/15/13 06:45:13 (10 years ago)

Author:

rschlatte

Message:

Move standard-generic-function definition into Lisp

Slightly tricky since we need to avoid redefining
standard-generic-function during compilation of abcl itself, hence
make-or-find-instance-funcallable-standard-class

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• StandardClass.java (modified) (2 diffs)
• StandardObject.java (modified) (1 diff)
• clos.lisp (modified) (6 diffs)

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

@@ -573 +573 @@
   public static final StandardClass STANDARD_METHOD =
     addStandardClass(Symbol.STANDARD_METHOD, list(METHOD));
-
-  public static final StandardClass STANDARD_GENERIC_FUNCTION =
-    addFuncallableStandardClass(Symbol.STANDARD_GENERIC_FUNCTION,
-                                list(GENERIC_FUNCTION));
 
   public static void initializeStandardClasses()
@@ -812 +808 @@
     STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
 
-    // STANDARD-GENERIC-FUNCTION
-    STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION,
-                                     GENERIC_FUNCTION, METAOBJECT,
-                                     FUNCALLABLE_STANDARD_OBJECT,
-                                     STANDARD_OBJECT,
-                                     BuiltInClass.FUNCTION,
-                                     BuiltInClass.CLASS_T);
-    STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(
-      list(new SlotDefinition(Symbol.NAME, NIL, constantlyNil),
-           new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil),
-           new SlotDefinition(Symbol.REQUIRED_ARGS, NIL, constantlyNil),
-           new SlotDefinition(Symbol.OPTIONAL_ARGS, NIL, constantlyNil),
-           new SlotDefinition(Symbol.INITIAL_METHODS, NIL, constantlyNil),
-           new SlotDefinition(Symbol.METHODS, NIL, constantlyNil),
-           new SlotDefinition(Symbol.METHOD_CLASS, NIL, constantlyNil),
-           new SlotDefinition(Symbol._METHOD_COMBINATION, NIL, constantlyNil,
-                              list(internKeyword("METHOD-COMBINATION"))),
-           new SlotDefinition(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL,
-                              constantlyNil),
-           new SlotDefinition(Symbol.DECLARATIONS, NIL, constantlyNil),
-           new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil,
-                              list(internKeyword("DOCUMENTATION")))));
-    // There are no inherited slots.
-    STANDARD_GENERIC_FUNCTION.finalizeClass();
   }
 }

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

@@ -669 +669 @@
     public LispObject execute(LispObject arg)
     {
-      if (arg == StandardClass.STANDARD_CLASS) {
+      if (arg == StandardClass.FUNCALLABLE_STANDARD_CLASS) {
+        return new FuncallableStandardClass();
+      } else if (arg == StandardClass.STANDARD_CLASS) {
         return new StandardClass();
       } else if (arg instanceof StandardClass) {

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

@@ -119 +119 @@
   (find-class 'funcallable-standard-object))
 (defconstant +the-standard-method-class+ (find-class 'standard-method))
-(defconstant +the-standard-generic-function-class+
-  (find-class 'standard-generic-function))
 (defconstant +the-T-class+ (find-class 'T))
 (defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
@@ -195 +193 @@
     (add-subclasses 'specializer '(class))
     (add-subclasses 'funcallable-standard-object 'generic-function)
-    (add-subclasses 'generic-function 'standard-generic-function)
     (add-subclasses 'method 'standard-method)
     (add-subclasses 'slot-definition
@@ -862 +859 @@
     class))
 
+(defun make-or-find-instance-funcallable-standard-class
+    (metaclass &rest initargs &key name direct-superclasses direct-slots
+                                direct-default-initargs documentation)
+  (declare (ignore metaclass initargs))
+  (or (find-class name nil)
+      (let ((class (std-allocate-instance +the-funcallable-standard-class+)))
+        (%set-class-name name class)
+        (unless *clos-booting* (%set-class-layout nil class))
+        (%set-class-direct-subclasses ()  class)
+        (%set-class-direct-methods ()  class)
+        (%set-class-documentation class documentation)
+        (std-after-initialization-for-classes class
+                                              :direct-superclasses direct-superclasses
+                                              :direct-slots direct-slots
+                                              :direct-default-initargs direct-default-initargs)
+        class)))
+
 ;(defun convert-to-direct-slot-definition (class canonicalized-slot)
 ;  (apply #'make-instance
@@ -896 +910 @@
   (values))
 
-;;; Bootstrap the lower parts of the metaclass hierarchy.
-
 (defmacro define-primordial-class (name superclasses direct-slots)
   "Primitive class definition tool.
@@ -905 +917 @@
   (let ((class (gensym)))
     `(let ((,class (make-instance-standard-class
+                    nil
+                    :name ',name
+                    :direct-superclasses ',(mapcar #'find-class superclasses)
+                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
+       (%set-find-class ',name ,class)
+       ,class)))
+
+(defmacro define-funcallable-primordial-class (name superclasses direct-slots)
+  "Primitive funcallable class definition tool.
+No non-standard metaclasses, accessor methods, duplicate slots,
+non-existent superclasses, default initargs, or other complicated stuff.
+Handle with care.
+Will not modify existing classes to avoid breaking std-generic-function-p."
+  (let ((class (gensym)))
+    `(let ((,class (make-or-find-instance-funcallable-standard-class
                     nil
                     :name ',name
@@ -969 +996 @@
 (defconstant +the-forward-referenced-class+
   (find-class 'forward-referenced-class))
+
+(define-funcallable-primordial-class standard-generic-function (generic-function)
+  ((sys::name :initarg :name :initform nil)
+   (sys::lambda-list :initarg :lambda-list :initform nil)
+   (sys::required-args :initarg :required-args :initform nil)
+   (sys::optional-args :initarg :optional-args :initform nil)
+   (sys::initial-methods :initarg :initial-methods :initform nil)
+   (sys::methods :initarg :methods :initform nil)
+   (sys::method-class :initarg :method-class
+                      :initform +the-standard-method-class+)
+   (sys::%method-combination :initarg :method-combination
+                             :initform (std-find-method-combination 'standard))
+   (sys::argument-precedence-order :initarg :argument-precedence-order
+                                   :initform nil)
+   (sys::declarations :initarg :declarations :initform nil)
+   (sys::%documentation :initarg :documentation :initform nil)))
+(defconstant +the-standard-generic-function-class+
+  (find-class 'standard-generic-function))
 
 (defun std-generic-function-p (gf)