[armedbear-cvs] r12738 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Fri Jun 4 21:50:23 UTC 2010
Author: astalla
Date: Fri Jun 4 17:50:22 2010
New Revision: 12738
Log:
Initial support for custom slot definition metaobjects in MOP.
Modified:
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Fri Jun 4 17:50:22 2010
@@ -44,6 +44,12 @@
slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
}
+ public SlotDefinition(StandardClass clazz)
+ {
+ super(clazz, clazz.getClassLayout().getLength());
+ slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
+ }
+
public SlotDefinition(LispObject name, LispObject readers)
{
this();
@@ -113,15 +119,20 @@
return unreadableString(sb.toString());
}
- // ### make-slot-definition
+ // ### make-slot-definition &optional class
private static final Primitive MAKE_SLOT_DEFINITION =
- new Primitive("make-slot-definition", PACKAGE_SYS, true, "")
+ new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class")
{
@Override
public LispObject execute()
{
return new SlotDefinition();
}
+ @Override
+ public LispObject execute(LispObject slotDefinitionClass)
+ {
+ return new SlotDefinition((StandardClass) slotDefinitionClass);
+ }
};
// ### %slot-definition-name
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jun 4 17:50:22 2010
@@ -384,6 +384,11 @@
STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
}
+ public static final StandardClass DIRECT_SLOT_DEFINITION =
+ addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION));
+ public static final StandardClass EFFECTIVE_SLOT_DEFINITION =
+ addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION));
+
// BuiltInClass.FUNCTION is also null here (see previous comment).
public static final StandardClass GENERIC_FUNCTION =
addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION,
@@ -721,6 +726,13 @@
// There are no inherited slots.
SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions());
+ DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ DIRECT_SLOT_DEFINITION.finalizeClass();
+ EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION,
+ STANDARD_OBJECT, BuiltInClass.CLASS_T);
+ EFFECTIVE_SLOT_DEFINITION.finalizeClass();
+
// STANDARD-METHOD
Debug.assertTrue(STANDARD_METHOD.isFinalized());
STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT,
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jun 4 17:50:22 2010
@@ -2943,6 +2943,10 @@
PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST");
public static final Symbol STANDARD_READER_METHOD =
PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
+ public static final Symbol DIRECT_SLOT_DEFINITION =
+ PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION");
+ public static final Symbol EFFECTIVE_SLOT_DEFINITION =
+ PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION");
// Java interface.
public static final Symbol JAVA_EXCEPTION =
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jun 4 17:50:22 2010
@@ -60,6 +60,8 @@
(defconstant +the-standard-generic-function-class+
(find-class 'standard-generic-function))
(defconstant +the-T-class+ (find-class 'T))
+(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
+(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
;; Don't use DEFVAR, because that disallows loading clos.lisp
;; after compiling it: the binding won't get assigned to T anymore
@@ -259,40 +261,46 @@
(defun make-initfunction (initform)
`(function (lambda () ,initform)))
-(defun make-direct-slot-definition (class &key name
- (initargs ())
- (initform nil)
- (initfunction nil)
- (readers ())
- (writers ())
- (allocation :instance)
- &allow-other-keys)
- (let ((slot (make-slot-definition)))
- (set-slot-definition-name slot name)
- (set-slot-definition-initargs slot initargs)
- (set-slot-definition-initform slot initform)
- (set-slot-definition-initfunction slot initfunction)
- (set-slot-definition-readers slot readers)
- (set-slot-definition-writers slot writers)
- (set-slot-definition-allocation slot allocation)
- (set-slot-definition-allocation-class slot class)
- slot))
-
-(defun make-effective-slot-definition (&key name
- (initargs ())
- (initform nil)
- (initfunction nil)
- (allocation :instance)
- (allocation-class nil)
- &allow-other-keys)
- (let ((slot (make-slot-definition)))
- (set-slot-definition-name slot name)
- (set-slot-definition-initargs slot initargs)
- (set-slot-definition-initform slot initform)
- (set-slot-definition-initfunction slot initfunction)
- (set-slot-definition-allocation slot allocation)
- (set-slot-definition-allocation-class slot allocation-class)
- slot))
+(defun init-slot-definition (slot &key name
+ (initargs ())
+ (initform nil)
+ (initfunction nil)
+ (readers ())
+ (writers ())
+ (allocation :instance)
+ &allow-other-keys)
+ (set-slot-definition-name slot name)
+ (set-slot-definition-initargs slot initargs)
+ (set-slot-definition-initform slot initform)
+ (set-slot-definition-initfunction slot initfunction)
+ (set-slot-definition-readers slot readers)
+ (set-slot-definition-writers slot writers)
+ (set-slot-definition-allocation slot allocation)
+ slot)
+
+(defun make-direct-slot-definition (class &rest args)
+ (let ((slot-class (direct-slot-definition-class class)))
+ (if (eq slot-class +the-direct-slot-definition-class+)
+ (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
+ (apply #'init-slot-definition slot args)
+ (set-slot-definition-allocation-class slot class)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class args)))
+ (set-slot-definition-allocation-class slot class)
+ slot)))))
+
+(defun make-effective-slot-definition (class &rest args)
+ (let ((slot-class (effective-slot-definition-class class)))
+ (if (eq slot-class +the-effective-slot-definition-class+)
+ (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
+ (apply #'init-slot-definition slot args)
+ (set-slot-definition-allocation-class slot class)
+ slot)
+ (progn
+ (let ((slot (apply #'make-instance slot-class args)))
+ (set-slot-definition-allocation-class slot class)
+ slot)))))
;;; finalize-inheritance
@@ -455,10 +463,10 @@
all-names)))
(defun std-compute-effective-slot-definition (class direct-slots)
- (declare (ignore class))
(let ((initer (find-if-not #'null direct-slots
:key #'%slot-definition-initfunction)))
(make-effective-slot-definition
+ class
:name (%slot-definition-name (car direct-slots))
:initform (if initer
(%slot-definition-initform initer)
@@ -559,6 +567,12 @@
:direct-default-initargs direct-default-initargs)
class))
+;(defun convert-to-direct-slot-definition (class canonicalized-slot)
+; (apply #'make-instance
+; (apply #'direct-slot-definition-class
+; class canonicalized-slot)
+; canonicalized-slot))
+
(defun std-after-initialization-for-classes (class
&key direct-superclasses direct-slots
direct-default-initargs
@@ -1899,7 +1913,17 @@
(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
+(defgeneric direct-slot-definition-class (class &rest initargs))
+
+(defmethod direct-slot-definition-class ((class class) &rest initargs)
+ (declare (ignore initargs))
+ +the-direct-slot-definition-class+)
+
+(defgeneric effective-slot-definition-class (class &rest initargs))
+(defmethod effective-slot-definition-class ((class class) &rest initargs)
+ (declare (ignore initargs))
+ +the-effective-slot-definition-class+)
(fmakunbound 'documentation)
(defgeneric documentation (x doc-type))
@@ -2212,6 +2236,17 @@
(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
(std-shared-initialize instance slot-names initargs))
+(defmethod shared-initialize ((slot slot-definition) slot-names
+ &rest initargs
+ &key name initargs initform initfunction
+ readers writers allocation
+ &allow-other-keys)
+ ;;Keyword args are duplicated from init-slot-definition only to have
+ ;;them checked.
+ (declare (ignore slot-names)) ;;TODO?
+ (declare (ignore name initargs initform initfunction readers writers allocation))
+ (apply #'init-slot-definition slot initargs))
+
;;; change-class
(defgeneric change-class (instance new-class &key))
More information about the armedbear-cvs
mailing list