[armedbear-cvs] r13774 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Sat Jan 14 16:52:48 UTC 2012
Author: rschlatte
Date: Sat Jan 14 08:52:48 2012
New Revision: 13774
Log:
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
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/mop.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:37:32 2012 (r13773)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:52:48 2012 (r13774)
@@ -450,6 +450,16 @@
public static final StandardClass STRUCTURE_CLASS =
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));
@@ -571,6 +581,8 @@
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
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jan 14 08:37:32 2012 (r13773)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jan 14 08:52:48 2012 (r13774)
@@ -2973,6 +2973,8 @@
PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT");
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");
public static final Symbol LONG_METHOD_COMBINATION =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 08:37:32 2012 (r13773)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 08:52:48 2012 (r13774)
@@ -2472,18 +2472,18 @@
,@(mapcar (if (consp name)
#'(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)))))
(redefine-class-forwarder class-name name)
@@ -2565,16 +2565,16 @@
(push (cons doc-type new-value) alist)))))
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))
(defmethod documentation ((x structure-class) (doc-type (eql 't)))
@@ -3003,6 +3003,8 @@
(atomic-defgeneric finalize-inheritance (class)
(:method ((class standard-class))
+ (std-finalize-inheritance class))
+ (:method ((class funcallable-standard-class))
(std-finalize-inheritance class)))
;;; Class precedence lists
@@ -3016,6 +3018,8 @@
(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))
(defgeneric compute-effective-slot-definition (class name direct-slots))
(defmethod compute-effective-slot-definition
Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 14 08:37:32 2012 (r13773)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 14 08:52:48 2012 (r13774)
@@ -2,11 +2,6 @@
(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
;;; SET-FUNCALLABLE-INSTANCE-FUNCTION.
;;;
More information about the armedbear-cvs
mailing list