Changeset 13837


Ignore:
Timestamp:
01/31/12 23:01:45 (9 years ago)
Author:
rschlatte
Message:

Implement specializer-method--related protocol.

Add add-direct-method, remove-direct-method, specializer-direct-methods,
specializer-direct-generic-functions

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

Legend:

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

    r13819 r13837  
    55625562                return ((LispClass)arg).getDocumentation();
    55635563            else
    5564                 return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
     5564                return ((StandardObject)arg).getInstanceSlotValue(Symbol.DOCUMENTATION);
    55655565        }
    55665566    };
     
    55805580                ((LispClass)first).setDocumentation(second);
    55815581            else
    5582                 ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
     5582                ((StandardObject)first).setInstanceSlotValue(Symbol.DOCUMENTATION, second);
    55835583            return second;
    55845584        }
  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r13814 r13837  
    4949  public static Symbol symDirectMethods
    5050    = PACKAGE_MOP.intern("DIRECT-METHODS");
    51   public static Symbol symDocumentation
    52     = PACKAGE_MOP.intern("DOCUMENTATION");
    5351  public static Symbol symDirectSlots
    5452    = PACKAGE_MOP.intern("DIRECT-SLOTS");
     
    6159  public static Symbol symFinalizedP
    6260    = PACKAGE_MOP.intern("FINALIZED-P");
     61
     62  // used as init-function for slots in this file.
     63  static Function constantlyNil = new Function() {
     64    @Override
     65    public LispObject execute()
     66    {
     67      return NIL;
     68    }
     69  };
     70
     71
    6372
    6473  static Layout layoutStandardClass =
     
    7584                      symDefaultInitargs,
    7685                      symFinalizedP,
    77                       symDocumentation),
     86                      Symbol.DOCUMENTATION),
    7887                 NIL)
    7988      {
     
    227236  public LispObject getDocumentation()
    228237  {
    229     return getInstanceSlotValue(symDocumentation);
     238    return getInstanceSlotValue(Symbol.DOCUMENTATION);
    230239  }
    231240
     
    233242  public void setDocumentation(LispObject doc)
    234243  {
    235     setInstanceSlotValue(symDocumentation, doc);
     244    setInstanceSlotValue(Symbol.DOCUMENTATION, doc);
    236245  }
    237246
     
    335344  private static final LispObject standardClassSlotDefinitions()
    336345  {
    337       // (CONSTANTLY NIL)
    338     Function initFunction = new Function() {
    339       @Override
    340       public LispObject execute()
    341       {
    342          return NIL;
    343       }
    344     };
    345 
    346346    return
    347         list(helperMakeSlotDefinition("NAME", initFunction),
    348              helperMakeSlotDefinition("LAYOUT", initFunction),
    349              helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction),
    350              helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction),
    351              helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction),
    352              helperMakeSlotDefinition("DIRECT-METHODS", initFunction),
    353              helperMakeSlotDefinition("DIRECT-SLOTS", initFunction),
    354              helperMakeSlotDefinition("SLOTS", initFunction),
    355              helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction),
    356              helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction),
    357              helperMakeSlotDefinition("FINALIZED-P", initFunction),
    358              helperMakeSlotDefinition("DOCUMENTATION", initFunction));
     347        list(helperMakeSlotDefinition("NAME", constantlyNil),
     348             helperMakeSlotDefinition("LAYOUT", constantlyNil),
     349             helperMakeSlotDefinition("DIRECT-SUPERCLASSES", constantlyNil),
     350             helperMakeSlotDefinition("DIRECT-SUBCLASSES", constantlyNil),
     351             helperMakeSlotDefinition("PRECEDENCE-LIST", constantlyNil),
     352             helperMakeSlotDefinition("DIRECT-SLOTS", constantlyNil),
     353             helperMakeSlotDefinition("SLOTS", constantlyNil),
     354             helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", constantlyNil),
     355             helperMakeSlotDefinition("DEFAULT-INITARGS", constantlyNil),
     356             helperMakeSlotDefinition("FINALIZED-P", constantlyNil),
     357             helperMakeSlotDefinition("DOCUMENTATION", constantlyNil));
    359358  }
    360359
     
    674673                           STANDARD_OBJECT, BuiltInClass.CLASS_T);
    675674    EQL_SPECIALIZER.setDirectSlotDefinitions(
    676       list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT")))));
     675      list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil),
     676           new SlotDefinition(symDirectMethods, NIL, constantlyNil)));
    677677    METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
    678678    STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
    679679                           BuiltInClass.CLASS_T);
    680680    STANDARD_METHOD.setDirectSlotDefinitions(
    681       list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL),
    682            new SlotDefinition(Symbol.LAMBDA_LIST, NIL),
    683            new SlotDefinition(Symbol.KEYWORDS, NIL),
    684            new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL),
    685            new SlotDefinition(Symbol.SPECIALIZERS, NIL),
    686            new SlotDefinition(Symbol.QUALIFIERS, NIL),
    687            new SlotDefinition(Symbol.FUNCTION, NIL),
    688            new SlotDefinition(Symbol.FAST_FUNCTION, NIL),
    689            new SlotDefinition(Symbol.DOCUMENTATION, NIL)));
     681      list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL, constantlyNil),
     682           new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil),
     683           new SlotDefinition(Symbol.KEYWORDS, NIL, constantlyNil),
     684           new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL, constantlyNil),
     685           new SlotDefinition(Symbol.SPECIALIZERS, NIL, constantlyNil),
     686           new SlotDefinition(Symbol.QUALIFIERS, NIL, constantlyNil),
     687           new SlotDefinition(Symbol.FUNCTION, NIL, constantlyNil),
     688           new SlotDefinition(Symbol.FAST_FUNCTION, NIL, constantlyNil),
     689           new SlotDefinition(Symbol.DOCUMENTATION, NIL, constantlyNil)));
    690690    STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
    691691                                    METHOD, METAOBJECT, STANDARD_OBJECT,
    692692                                    BuiltInClass.CLASS_T);
    693693    STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions(
    694        list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL)));
     694      list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL)));
    695695    STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD,
    696696                                  STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
     
    705705    METHOD_COMBINATION.setDirectSlotDefinitions(
    706706      list(new SlotDefinition(Symbol.NAME,
    707                               list(Symbol.METHOD_COMBINATION_NAME)),
     707                              list(Symbol.METHOD_COMBINATION_NAME),
     708                              constantlyNil),
    708709           new SlotDefinition(Symbol.DOCUMENTATION,
    709                               list(Symbol.METHOD_COMBINATION_DOCUMENTATION))));
     710                              list(Symbol.METHOD_COMBINATION_DOCUMENTATION),
     711                              constantlyNil)));
    710712    SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION,
    711713                                    METHOD_COMBINATION, METAOBJECT,
     
    814816    STANDARD_OBJECT.finalizeClass();
    815817    FUNCALLABLE_STANDARD_OBJECT.finalizeClass();
    816     CLASS.finalizeClass();
    817818    FUNCALLABLE_STANDARD_CLASS.finalizeClass();
    818819    FORWARD_REFERENCED_CLASS.finalizeClass();
     
    841842    STANDARD_WRITER_METHOD.finalizeClass();
    842843    SPECIALIZER.finalizeClass();
     844    CLASS.finalizeClass();
     845    BUILT_IN_CLASS.finalizeClass();
    843846    EQL_SPECIALIZER.finalizeClass();
    844847    METHOD_COMBINATION.finalizeClass();
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13830 r13837  
    11821182            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
    11831183              (setf (std-slot-value instance 'sys::object) object)
     1184              (setf (std-slot-value instance 'direct-methods) nil)
    11841185              instance))))
    11851186
     
    17771778    method))
    17781779
     1780;;; To be redefined as generic functions later
     1781(declaim (notinline add-direct-method))
     1782(defun add-direct-method (specializer method)
     1783  (if (typep specializer 'eql-specializer)
     1784      (pushnew method (std-slot-value specializer 'direct-methods))
     1785      (pushnew method (class-direct-methods specializer))))
     1786
     1787(declaim (notinline remove-direct-method))
     1788(defun remove-direct-method (specializer method)
     1789  (if (typep specializer 'eql-specializer)
     1790      (setf (std-slot-value specializer 'direct-methods)
     1791            (remove method (std-slot-value specializer 'direct-methods)))
     1792      (setf (class-direct-methods specializer)
     1793            (remove method (class-direct-methods specializer)))))
     1794
    17791795(defun std-add-method (gf method)
    17801796  (when (and (method-generic-function method)
     
    17911807  (push method (generic-function-methods gf))
    17921808  (dolist (specializer (method-specializers method))
    1793     ;; FIXME use add-direct-method here (AMOP pg. 165))
    1794     (when (typep specializer 'class)
    1795       (pushnew method (class-direct-methods specializer))))
     1809    (add-direct-method specializer method))
    17961810  (finalize-standard-generic-function gf)
    17971811  gf)
     
    18021816  (setf (std-slot-value method 'generic-function) nil)
    18031817  (dolist (specializer (method-specializers method))
    1804     ;; FIXME use remove-direct-method here (AMOP pg. 227)
    1805     (when (typep specializer 'class)
    1806       (setf (class-direct-methods specializer)
    1807             (remove method (class-direct-methods specializer)))))
     1818    (remove-direct-method specializer method))
    18081819  (finalize-standard-generic-function gf)
    18091820  gf)
     
    37283739    (std-accessor-method-slot-definition method)))
    37293740
     3741;;; specializer-direct-method and friends.
     3742
     3743;;; AMOP pg. 237
     3744(defgeneric specializer-direct-generic-functions (specializer))
     3745
     3746(defmethod specializer-direct-generic-functions ((specializer class))
     3747  (delete-duplicates (mapcar #'method-generic-function
     3748                             (class-direct-methods specializer))))
     3749
     3750(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
     3751  (delete-duplicates (mapcar #'method-generic-function
     3752                             (slot-value specializer 'direct-methods))))
     3753
     3754;;; AMOP pg. 238
     3755(defgeneric specializer-direct-methods (specializer))
     3756
     3757(defmethod specializer-direct-methods ((specializer class))
     3758  (class-direct-methods specializer))
     3759
     3760(defmethod specializer-direct-methods ((specializer eql-specializer))
     3761  (slot-value specializer 'direct-methods))
     3762
     3763;;; AMOP pg. 165
     3764(atomic-defgeneric add-direct-method (specializer method)
     3765  (:method ((specializer class) (method method))
     3766    (pushnew method (class-direct-methods specializer)))
     3767  (:method ((specializer eql-specializer) (method method))
     3768    (pushnew method (slot-value specializer 'direct-methods))))
     3769
     3770
     3771;;; AMOP pg. 227
     3772(atomic-defgeneric remove-direct-method (specializer method)
     3773  (:method ((specializer class) (method method))
     3774    (setf (class-direct-methods specializer)
     3775          (remove method (class-direct-methods specializer))))
     3776  (:method ((specializer eql-specializer) (method method))
     3777    (setf (slot-value specializer 'direct-methods)
     3778          (remove method (slot-value specializer 'direct-methods)))))
     3779
    37303780;;; SLIME compatibility functions.
    37313781
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13817 r13837  
    7474          slot-definition-writers
    7575
     76          intern-eql-specializer
    7677          eql-specializer-object
     78          specializer-direct-methods
     79          specializer-direct-generic-functions
     80          add-direct-method
     81          remove-direct-method
     82
    7783          extract-lambda-list
    7884          extract-specializer-names
    79 
    80           intern-eql-specializer))
     85          ))
    8186
    8287(provide 'mop)
Note: See TracChangeset for help on using the changeset viewer.