Changeset 12738 for trunk/abcl/src/org/armedbear

Timestamp:

06/04/10 21:50:22 (12 years ago)

Author:

astalla

Message:

Initial support for custom slot definition metaobjects in MOP.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• SlotDefinition.java (modified) (3 diffs)
• StandardClass.java (modified) (2 diffs)
• Symbol.java (modified) (1 diff)
• clos.lisp (modified) (6 diffs)

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

@@ -45 +45 @@
   }
 
+    public SlotDefinition(StandardClass clazz)
+  {
+    super(clazz, clazz.getClassLayout().getLength());
+    slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
+  }
+
   public SlotDefinition(LispObject name, LispObject readers)
   {
@@ -114 +120 @@
   }
 
-  // ### 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
@@ -122 +128 @@
       {
         return new SlotDefinition();
+      }
+      @Override
+      public LispObject execute(LispObject slotDefinitionClass)
+      {
+    return new SlotDefinition((StandardClass) slotDefinitionClass);
       }
     };

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

@@ -384 +384 @@
     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).
@@ -722 +727 @@
     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());

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

@@ -2944 +2944 @@
   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.

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

@@ -61 +61 @@
   (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
@@ -260 +262 @@
   `(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
@@ -456 +464 @@
 
 (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
@@ -559 +567 @@
                                           :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
@@ -1900 +1914 @@
 (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)
@@ -2212 +2236 @@
 (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