Changeset 13774

Timestamp:

01/14/12 16:52:48 (11 years ago)

Author:

rschlatte

Message:

introduce funcallable-standard-class

... not yet usable as metaclass since various machinery is missing

... also make #'documentation work for all class objects, not just

standard-class

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• StandardClass.java (modified) (2 diffs)
• Symbol.java (modified) (1 diff)
• clos.lisp (modified) (4 diffs)
• mop.lisp (modified) (1 diff)

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

@@ -451 +451 @@
     addStandardClass(Symbol.STRUCTURE_CLASS, list(CLASS));
 
+  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));
@@ -572 +582 @@
   }
 
+  // ### TODO move functionality upwards into funcallable-stanard-object
+  // and use addStandardClass() here
   public static final StandardClass STANDARD_GENERIC_FUNCTION =
     new StandardGenericFunctionClass();

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

@@ -2974 +2974 @@
   public static final Symbol FUNCALLABLE_STANDARD_OBJECT =
     PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT");
+  public static final Symbol FUNCALLABLE_STANDARD_CLASS =
+    PACKAGE_CL.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS");
   public static final Symbol SHORT_METHOD_COMBINATION =
     PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION");

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

@@ -2473 +2473 @@
                        #'(lambda (class-name)
                            `(:method (new-value (class ,class-name))
-                                     (,%name new-value class)))
-                     #'(lambda (class-name)
-                         `(:method ((class ,class-name))
-                                   (,%name class))))
-                   '(built-in-class
-                     forward-referenced-class
-                     structure-class))
-         (:method (,@(when (consp name) (list 'new-value))
-                   (class standard-class))
-             ,(if (consp name)
-                  `(setf (slot-value class ',slot) new-value)
-                `(slot-value class ',slot))))))
+                              (,%name new-value class)))
+                       #'(lambda (class-name)
+                           `(:method ((class ,class-name))
+                              (,%name class))))
+                   '(built-in-class forward-referenced-class structure-class))
+         ,@(mapcar #'(lambda (class-name)
+                       `(:method (,@(when (consp name) (list 'new-value))
+                                  (class ,class-name))
+                          ,(if (consp name)
+                               `(setf (slot-value class ',slot) new-value)
+                               `(slot-value class ',slot))))
+                   '(standard-class funcallable-standard-class)))))
 
 
@@ -2566 +2566 @@
   new-value)
 
-(defmethod documentation ((x standard-class) (doc-type (eql 't)))
+(defmethod documentation ((x class) (doc-type (eql 't)))
   (class-documentation x))
 
-(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
+(defmethod documentation ((x class) (doc-type (eql 'type)))
   (class-documentation x))
 
-(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
+(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't)))
   (%set-class-documentation x new-value))
 
-(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
+(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type)))
   (%set-class-documentation x new-value))
 
@@ -3004 +3004 @@
 (atomic-defgeneric finalize-inheritance (class)
     (:method ((class standard-class))
+       (std-finalize-inheritance class))
+    (:method ((class funcallable-standard-class))
        (std-finalize-inheritance class)))
 
@@ -3016 +3018 @@
 (defgeneric compute-slots (class))
 (defmethod compute-slots ((class standard-class))
+  (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
   (std-compute-slots class))
 

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

@@ -2 +2 @@
 
 (in-package #:mop)
-
-(defclass funcallable-standard-class (class))
-
-(defmethod class-name ((class funcallable-standard-class))
-  'funcallable-standard-class)
 
 ;;; StandardGenericFunction.java defines FUNCALLABLE-INSTANCE-FUNCTION and