Ignore:
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:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java

    r12576 r12738  
    4545  }
    4646
     47    public SlotDefinition(StandardClass clazz)
     48  {
     49    super(clazz, clazz.getClassLayout().getLength());
     50    slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
     51  }
     52
    4753  public SlotDefinition(LispObject name, LispObject readers)
    4854  {
     
    114120  }
    115121
    116   // ### make-slot-definition
     122  // ### make-slot-definition &optional class
    117123  private static final Primitive MAKE_SLOT_DEFINITION =
    118     new Primitive("make-slot-definition", PACKAGE_SYS, true, "")
     124    new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class")
    119125    {
    120126      @Override
     
    122128      {
    123129        return new SlotDefinition();
     130      }
     131      @Override
     132      public LispObject execute(LispObject slotDefinitionClass)
     133      {
     134    return new SlotDefinition((StandardClass) slotDefinitionClass);
    124135      }
    125136    };
  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r12620 r12738  
    384384    STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions());
    385385  }
     386
     387    public static final StandardClass DIRECT_SLOT_DEFINITION =
     388      addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION));
     389    public static final StandardClass EFFECTIVE_SLOT_DEFINITION =
     390      addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION));
    386391
    387392  // BuiltInClass.FUNCTION is also null here (see previous comment).
     
    722727    SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions());
    723728
     729    DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION,
     730          STANDARD_OBJECT, BuiltInClass.CLASS_T);
     731    DIRECT_SLOT_DEFINITION.finalizeClass();
     732    EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION,
     733             STANDARD_OBJECT, BuiltInClass.CLASS_T);
     734    EFFECTIVE_SLOT_DEFINITION.finalizeClass();
     735
    724736    // STANDARD-METHOD
    725737    Debug.assertTrue(STANDARD_METHOD.isFinalized());
  • trunk/abcl/src/org/armedbear/lisp/Symbol.java

    r12713 r12738  
    29442944  public static final Symbol STANDARD_READER_METHOD =
    29452945    PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
     2946  public static final Symbol DIRECT_SLOT_DEFINITION =
     2947    PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION");
     2948  public static final Symbol EFFECTIVE_SLOT_DEFINITION =
     2949    PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION");
    29462950
    29472951  // Java interface.
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12715 r12738  
    6161  (find-class 'standard-generic-function))
    6262(defconstant +the-T-class+ (find-class 'T))
     63(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
     64(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
    6365
    6466;; Don't use DEFVAR, because that disallows loading clos.lisp
     
    260262  `(function (lambda () ,initform)))
    261263
    262 (defun make-direct-slot-definition (class &key name
    263                                           (initargs ())
    264                                           (initform nil)
    265                                           (initfunction nil)
    266                                           (readers ())
    267                                           (writers ())
    268                                           (allocation :instance)
    269                                           &allow-other-keys)
    270   (let ((slot (make-slot-definition)))
    271     (set-slot-definition-name slot name)
    272     (set-slot-definition-initargs slot initargs)
    273     (set-slot-definition-initform slot initform)
    274     (set-slot-definition-initfunction slot initfunction)
    275     (set-slot-definition-readers slot readers)
    276     (set-slot-definition-writers slot writers)
    277     (set-slot-definition-allocation slot allocation)
    278     (set-slot-definition-allocation-class slot class)
    279     slot))
    280 
    281 (defun make-effective-slot-definition (&key name
    282                                             (initargs ())
    283                                             (initform nil)
    284                                             (initfunction nil)
    285                                             (allocation :instance)
    286                                             (allocation-class nil)
    287                                             &allow-other-keys)
    288   (let ((slot (make-slot-definition)))
    289     (set-slot-definition-name slot name)
    290     (set-slot-definition-initargs slot initargs)
    291     (set-slot-definition-initform slot initform)
    292     (set-slot-definition-initfunction slot initfunction)
    293     (set-slot-definition-allocation slot allocation)
    294     (set-slot-definition-allocation-class slot allocation-class)
    295     slot))
     264(defun init-slot-definition (slot &key name
     265            (initargs ())
     266            (initform nil)
     267            (initfunction nil)
     268            (readers ())
     269            (writers ())
     270            (allocation :instance)
     271            &allow-other-keys)
     272  (set-slot-definition-name slot name)
     273  (set-slot-definition-initargs slot initargs)
     274  (set-slot-definition-initform slot initform)
     275  (set-slot-definition-initfunction slot initfunction)
     276  (set-slot-definition-readers slot readers)
     277  (set-slot-definition-writers slot writers)
     278  (set-slot-definition-allocation slot allocation)
     279  slot)
     280
     281(defun make-direct-slot-definition (class &rest args)
     282  (let ((slot-class (direct-slot-definition-class class)))
     283    (if (eq slot-class +the-direct-slot-definition-class+)
     284  (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
     285    (apply #'init-slot-definition slot args)
     286    (set-slot-definition-allocation-class slot class)
     287    slot)
     288  (progn
     289    (let ((slot (apply #'make-instance slot-class args)))
     290      (set-slot-definition-allocation-class slot class)
     291      slot)))))
     292
     293(defun make-effective-slot-definition (class &rest args)
     294  (let ((slot-class (effective-slot-definition-class class)))
     295    (if (eq slot-class +the-effective-slot-definition-class+)
     296  (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
     297    (apply #'init-slot-definition slot args)
     298    (set-slot-definition-allocation-class slot class)
     299    slot)
     300  (progn
     301    (let ((slot (apply #'make-instance slot-class args)))
     302      (set-slot-definition-allocation-class slot class)
     303      slot)))))
    296304
    297305;;; finalize-inheritance
     
    456464
    457465(defun std-compute-effective-slot-definition (class direct-slots)
    458   (declare (ignore class))
    459466  (let ((initer (find-if-not #'null direct-slots
    460467                             :key #'%slot-definition-initfunction)))
    461468    (make-effective-slot-definition
     469     class
    462470     :name (%slot-definition-name (car direct-slots))
    463471     :initform (if initer
     
    559567                                          :direct-default-initargs direct-default-initargs)
    560568    class))
     569
     570;(defun convert-to-direct-slot-definition (class canonicalized-slot)
     571;  (apply #'make-instance
     572;         (apply #'direct-slot-definition-class
     573;                class canonicalized-slot)
     574;         canonicalized-slot))
    561575
    562576(defun std-after-initialization-for-classes (class
     
    19001914(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
    19011915
    1902 
     1916(defgeneric direct-slot-definition-class (class &rest initargs))
     1917
     1918(defmethod direct-slot-definition-class ((class class) &rest initargs)
     1919  (declare (ignore initargs))
     1920  +the-direct-slot-definition-class+)
     1921
     1922(defgeneric effective-slot-definition-class (class &rest initargs))
     1923
     1924(defmethod effective-slot-definition-class ((class class) &rest initargs)
     1925  (declare (ignore initargs))
     1926  +the-effective-slot-definition-class+)
    19031927
    19041928(fmakunbound 'documentation)
     
    22122236(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
    22132237  (std-shared-initialize instance slot-names initargs))
     2238
     2239(defmethod shared-initialize ((slot slot-definition) slot-names
     2240            &rest initargs
     2241            &key name initargs initform initfunction
     2242            readers writers allocation
     2243            &allow-other-keys)
     2244  ;;Keyword args are duplicated from init-slot-definition only to have
     2245  ;;them checked.
     2246  (declare (ignore slot-names)) ;;TODO?
     2247  (declare (ignore name initargs initform initfunction readers writers allocation))
     2248  (apply #'init-slot-definition slot initargs))
    22142249
    22152250;;; change-class
Note: See TracChangeset for help on using the changeset viewer.