Changeset 13273


Ignore:
Timestamp:
05/01/11 22:34:47 (11 years ago)
Author:
astalla
Message:

Correct support for custom slots definitions in MOP:

  • class hierarchy for slot definitions as specified by AMOP (except the METAOBJECT superclass)
  • above class hierarchy is extensible by users
  • custom slot options are not evaluated
  • compute-effective-slot-definition lambda list updated to take NAME argument (2nd)
  • a few more symbols exported from the MOP package

There are no new ANSI tests failures caused by these changes on my machine.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/LispClass.java

    r13221 r13273  
    4242          = new ConcurrentHashMap<Symbol, LispObject>();
    4343
    44   public static LispClass addClass(Symbol symbol, LispClass c)
     44  public static <T extends LispClass> T addClass(Symbol symbol, T c)
    4545  {
    4646    map.put(symbol, c);

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

    r12752 r13273  
    4040  public SlotDefinition()
    4141  {
    42     super(StandardClass.SLOT_DEFINITION,
    43           StandardClass.SLOT_DEFINITION.getClassLayout().getLength());
     42    super(StandardClass.STANDARD_SLOT_DEFINITION,
     43          StandardClass.STANDARD_SLOT_DEFINITION.getClassLayout().getLength());
    4444    slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
    4545  }
    4646
    47     public SlotDefinition(StandardClass clazz)
    48   {
    49     super(clazz, clazz.getClassLayout().getLength());
    50     slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
    51   }
     47    public SlotDefinition(StandardClass clazz) {
     48        super(clazz, clazz.getClassLayout().getLength());
     49        slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
     50    }
     51
     52    public SlotDefinition(StandardClass clazz, LispObject name) {
     53        super(clazz, clazz.getClassLayout().getLength());
     54        slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name;
     55        slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = NIL;
     56        slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] =
     57            new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName()));
     58        slots[SlotDefinitionClass.SLOT_INDEX_READERS] = NIL;
     59        slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
     60        slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
     61    }
    5262
    5363  public SlotDefinition(LispObject name, LispObject readers)
    … …  
    93103  public static StandardObject checkSlotDefinition(LispObject obj) {
    94104          if (obj instanceof StandardObject) return (StandardObject)obj;
    95       return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);     
     105      return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION);
    96106  }
    97107
    … …  
    132142      public LispObject execute(LispObject slotDefinitionClass)
    133143      {
    134     return new SlotDefinition((StandardClass) slotDefinitionClass);
     144          return new SlotDefinition((StandardClass) slotDefinitionClass);
    135145      }
    136146    };

  • trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java

    r12288 r13273  
    4848    public static final int SLOT_INDEX_LOCATION         = 8;
    4949
    50     public SlotDefinitionClass()
    51     {
    52         super(Symbol.SLOT_DEFINITION, list(StandardClass.STANDARD_OBJECT));
     50    /**
     51     * For internal use only. This constructor hardcodes the layout of the class, and can't be used
     52     * to create arbitrary subclasses of slot-definition.
     53     */
     54    public SlotDefinitionClass(Symbol symbol, LispObject cpl) {
     55        super(symbol, cpl);
    5356        Package pkg = PACKAGE_SYS;
    5457        LispObject[] instanceSlotNames = {
    … …  
    6467        };
    6568        setClassLayout(new Layout(this, instanceSlotNames, NIL));
     69        //Set up slot definitions so that this class can be extended by users
     70        LispObject slotDefinitions = NIL;
     71        for(int i = instanceSlotNames.length - 1; i >= 0; i--) {
     72            slotDefinitions = slotDefinitions.push(new SlotDefinition(this, instanceSlotNames[i]));
     73        }
     74        setDirectSlotDefinitions(slotDefinitions);
     75        setSlotDefinitions(slotDefinitions);
     76
    6677        setFinalized(true);
    6778    }

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

    r13195 r13273  
    387387    addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T));
    388388
    389   public static final StandardClass SLOT_DEFINITION =
    390     new SlotDefinitionClass();
     389    public static final StandardClass SLOT_DEFINITION =
     390        addStandardClass(Symbol.SLOT_DEFINITION, list(STANDARD_OBJECT));
     391    public static final StandardClass STANDARD_SLOT_DEFINITION =
     392        addClass(Symbol.STANDARD_SLOT_DEFINITION, new SlotDefinitionClass(Symbol.STANDARD_SLOT_DEFINITION, list(SLOT_DEFINITION)));
     393
    391394  static
    392395  {
    393     addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);
     396      SLOT_DEFINITION.finalizeClass();
    394397
    395398    STANDARD_CLASS.setClassLayout(layoutStandardClass);
    … …  
    400403      addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION));
    401404    public static final StandardClass EFFECTIVE_SLOT_DEFINITION =
    402       addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION));
     405        addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION));
     406    //      addStandardClass(Symbol.STANDARD_SLOT_DEFINITION, list(SLOT_DEFINITION));
     407    public static final StandardClass STANDARD_DIRECT_SLOT_DEFINITION =
     408        addClass(Symbol.STANDARD_DIRECT_SLOT_DEFINITION,
     409                 new SlotDefinitionClass(Symbol.STANDARD_DIRECT_SLOT_DEFINITION,
     410                                         list(STANDARD_SLOT_DEFINITION, DIRECT_SLOT_DEFINITION)));
     411    public static final StandardClass STANDARD_EFFECTIVE_SLOT_DEFINITION =
     412        addClass(Symbol.STANDARD_EFFECTIVE_SLOT_DEFINITION,
     413                 new SlotDefinitionClass(Symbol.STANDARD_EFFECTIVE_SLOT_DEFINITION,
     414                                         list(STANDARD_SLOT_DEFINITION, EFFECTIVE_SLOT_DEFINITION)));
     415
    403416
    404417  // BuiltInClass.FUNCTION is also null here (see previous comment).
    … …  
    742755
    743756    DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION,
    744           STANDARD_OBJECT, BuiltInClass.CLASS_T);
     757                                  STANDARD_OBJECT, BuiltInClass.CLASS_T);
    745758    DIRECT_SLOT_DEFINITION.finalizeClass();
    746759    EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION,
    747              STANDARD_OBJECT, BuiltInClass.CLASS_T);
     760                                     STANDARD_OBJECT, BuiltInClass.CLASS_T);
    748761    EFFECTIVE_SLOT_DEFINITION.finalizeClass();
     762    STANDARD_SLOT_DEFINITION.setCPL(STANDARD_SLOT_DEFINITION, SLOT_DEFINITION,
     763                                    STANDARD_OBJECT, BuiltInClass.CLASS_T);
     764    STANDARD_SLOT_DEFINITION.finalizeClass();
     765    STANDARD_DIRECT_SLOT_DEFINITION.setCPL(STANDARD_DIRECT_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION,
     766                                           DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT,
     767                                           BuiltInClass.CLASS_T);
     768    STANDARD_DIRECT_SLOT_DEFINITION.finalizeClass();
     769    STANDARD_EFFECTIVE_SLOT_DEFINITION.setCPL(STANDARD_EFFECTIVE_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION,
     770                                              EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT,
     771                                              BuiltInClass.CLASS_T);
     772    STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
    749773
    750774    // STANDARD-METHOD

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

    r13259 r13273  
    29622962  public static final Symbol EFFECTIVE_SLOT_DEFINITION =
    29632963    PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION");
     2964  public static final Symbol STANDARD_SLOT_DEFINITION =
     2965    PACKAGE_MOP.addExternalSymbol("STANDARD-SLOT-DEFINITION");
     2966  public static final Symbol STANDARD_DIRECT_SLOT_DEFINITION =
     2967    PACKAGE_MOP.addExternalSymbol("STANDARD-DIRECT-SLOT-DEFINITION");
     2968  public static final Symbol STANDARD_EFFECTIVE_SLOT_DEFINITION =
     2969    PACKAGE_MOP.addExternalSymbol("STANDARD-EFFECTIVE-SLOT-DEFINITION");
    29642970
    29652971  // Java interface.

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

    r13220 r13273  
    3232
    3333;;; Originally based on Closette.
    34      
     34
    3535;;; Closette Version 1.0 (February 10, 1991)
    3636;;;
    … …  
    9797;;
    9898
    99 (export '(class-precedence-list class-slots))
     99(export '(class-precedence-list class-slots
     100          slot-definition-name))
    100101(defconstant +the-standard-class+ (find-class 'standard-class))
    101102(defconstant +the-structure-class+ (find-class 'structure-class))
    … …  
    107108  (find-class 'standard-generic-function))
    108109(defconstant +the-T-class+ (find-class 'T))
    109 (defconstant +the-slot-definition-class+ (find-class 'slot-definition))
    110 (defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
    111 (defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
     110(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
     111(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
     112(defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition))
    112113
    113114;; Don't use DEFVAR, because that disallows loading clos.lisp
    … …  
    255256            (t
    256257             (push-on-end `(quote ,(car olist)) non-std-options)
    257              (push-on-end (cadr olist) non-std-options))))
     258             (push-on-end `(quote ,(cadr olist)) non-std-options))))
    258259        `(list
    259260          :name ',name
    … …  
    378379
    379380(defun init-slot-definition (slot &key name
    380            (initargs ())
    381            (initform nil)
    382            (initfunction nil)
    383            (readers ())
    384            (writers ())
    385            (allocation :instance)
    386            (allocation-class nil))
     381                             (initargs ())
     382                             (initform nil)
     383                             (initfunction nil)
     384                             (readers ())
     385                             (writers ())
     386                             (allocation :instance)
     387                             (allocation-class nil))
    387388  (setf (slot-definition-name slot) name)
    388389  (setf (slot-definition-initargs slot) initargs)
    … …  
    397398(defun make-direct-slot-definition (class &rest args)
    398399  (let ((slot-class (direct-slot-definition-class class)))
    399     (if (eq slot-class +the-direct-slot-definition-class+)
    400   (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
     400    (if (eq slot-class +the-standard-direct-slot-definition-class+)
     401  (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
    401402    (apply #'init-slot-definition slot :allocation-class class args)
    402403    slot)
    … …  
    408409(defun make-effective-slot-definition (class &rest args)
    409410  (let ((slot-class (effective-slot-definition-class class)))
    410     (if (eq slot-class +the-effective-slot-definition-class+)
    411   (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
     411    (if (eq slot-class +the-standard-effective-slot-definition-class+)
     412  (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
    412413    (apply #'init-slot-definition slot args)
    413414    slot)
    … …  
    581582                    #'compute-effective-slot-definition)
    582583                class
     584                name
    583585                (remove name all-slots
    584586                        :key 'slot-definition-name
    … …  
    586588            all-names)))
    587589
    588 (defun std-compute-effective-slot-definition (class direct-slots)
     590(defun std-compute-effective-slot-definition (class name direct-slots)
    589591  (let ((initer (find-if-not #'null direct-slots
    590592                             :key 'slot-definition-initfunction)))
    591593    (make-effective-slot-definition
    592594     class
    593      :name (slot-definition-name (car direct-slots))
     595     :name name
    594596     :initform (if initer
    595597                   (slot-definition-initform initer)
    … …  
    774776    (dolist (class direct-superclasses)
    775777      (when (and (typep class 'built-in-class)
    776     (not (member class *extensible-built-in-classes*)))
     778                (not (member class *extensible-built-in-classes*)))
    777779        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
    778780  (let ((old-class (find-class name nil)))
    … …  
    795797                 (t
    796798                  ;; We're redefining the class.
    797                   (remhash old-class *make-instance-initargs-cache*)
    798                   (remhash old-class *reinitialize-instance-initargs-cache*)
    799                   (%make-instances-obsolete old-class)
    800                   (setf (class-finalized-p old-class) nil)
    801                   (check-initargs (list #'allocate-instance
    802                                         #'initialize-instance)
    803                                   (list* old-class all-keys)
    804                                   old-class t all-keys
    805                                   nil)
    806                   (apply #'std-after-initialization-for-classes old-class all-keys)
     799                  (apply #'reinitialize-instance old-class all-keys)
    807800                  old-class)))
    808801          (t
    … …  
    23852378(defmethod direct-slot-definition-class ((class class) &rest initargs)
    23862379  (declare (ignore initargs))
    2387   +the-direct-slot-definition-class+)
     2380  +the-standard-direct-slot-definition-class+)
    23882381
    23892382(defgeneric effective-slot-definition-class (class &rest initargs))
    … …  
    23912384(defmethod effective-slot-definition-class ((class class) &rest initargs)
    23922385  (declare (ignore initargs))
    2393   +the-effective-slot-definition-class+)
     2386  +the-standard-effective-slot-definition-class+)
    23942387
    23952388(atomic-defgeneric documentation (x doc-type)
    … …  
    27322725  ;; checking initarg validity
    27332726  (do* ((tail all-keys (cddr tail))
    2734   (initarg (car tail) (car tail)))
     2727        (initarg (car tail) (car tail)))
    27352728      ((null tail))
    27362729    (unless (symbolp initarg)
    27372730      (error 'program-error
    2738        :format-control "Invalid initarg ~S."
    2739        :format-arguments (list initarg))))
     2731             :format-control "Invalid initarg ~S."
     2732             :format-arguments (list initarg))))
    27402733  (dolist (slot (class-slots (class-of instance)))
    27412734    (let ((slot-name (slot-definition-name slot)))
    … …  
    27582751
    27592752(defmethod shared-initialize ((slot slot-definition) slot-names
    2760             &rest args
    2761             &key name initargs initform initfunction
    2762             readers writers allocation
    2763             &allow-other-keys)
     2753                              &rest args
     2754                              &key name initargs initform initfunction
     2755                              readers writers allocation
     2756                              &allow-other-keys)
    27642757  ;;Keyword args are duplicated from init-slot-definition only to have
    27652758  ;;them checked.
    … …  
    28552848  (apply #'std-after-initialization-for-classes class args))
    28562849
     2850(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
     2851  (remhash class *make-instance-initargs-cache*)
     2852  (remhash class *reinitialize-instance-initargs-cache*)
     2853  (%make-instances-obsolete class)
     2854  (setf (class-finalized-p class) nil)
     2855  (check-initargs (list #'allocate-instance
     2856                        #'initialize-instance)
     2857                  (list* class all-keys)
     2858                  class t all-keys
     2859                  nil)
     2860  (apply #'std-after-initialization-for-classes class all-keys))
     2861
    28572862;;; Finalize inheritance
    28582863
    … …  
    28732878  (std-compute-slots class))
    28742879
    2875 (defgeneric compute-effective-slot-definition (class direct-slots))
     2880(defgeneric compute-effective-slot-definition (class name direct-slots))
    28762881(defmethod compute-effective-slot-definition
    2877   ((class standard-class) direct-slots)
    2878   (std-compute-effective-slot-definition class direct-slots))
     2882  ((class standard-class) name direct-slots)
     2883  (std-compute-effective-slot-definition class name direct-slots))
    28792884
    28802885;;; Methods having to do with generic function metaobjects.
    … …  
    29102915  `(let (($cl (class-of ,slot-definition)))
    29112916     (case $cl
    2912        ((+the-slot-definition-class+
    2913    +the-direct-slot-definition-class+
    2914    +the-effective-slot-definition-class+)
    2915   ,std-form)
     2917       ((+the-standard-slot-definition-class+
     2918         +the-standard-direct-slot-definition-class+
     2919         +the-standard-effective-slot-definition-class+)
     2920        ,std-form)
    29162921       (t ,generic-form))))
    29172922
    … …  
    29332938      (%slot-definition-initargs slot-definition)
    29342939      (slot-value slot-definition 'sys::initargs))))
    2935 
    2936 (atomic-defgeneric (setf slot-definition-initargs) (value slot-definition)
    2937   (:method (value (slot-definition slot-definition))
    2938     (slot-definition-dispatch slot-definition
    2939       (set-slot-definition-initargs slot-definition value)
    2940       (setf (slot-value slot-definition 'sys::initargs) value))))
    29412940
    29422941(atomic-defgeneric slot-definition-initform (slot-definition)
Note: See TracChangeset for help on using the changeset viewer.