Changeset 13814


Ignore:
Timestamp:
01/27/12 13:06:03 (9 years ago)
Author:
rschlatte
Message:

implement classes standard-method, standard-reader-method in Lisp

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

Legend:

Unmodified
Added
Removed

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

    r13782 r13814  
    536536        autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true);
    537537        autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false);
    538         autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
    539         autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);
    540538        autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true);
    541539        autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true);
    … …  
    560558        autoload(PACKAGE_SYS, "%make-string", "StringFunctions");
    561559        autoload(PACKAGE_SYS, "%make-string-output-stream", "StringOutputStream");
    562         autoload(PACKAGE_SYS, "%method-fast-function", "StandardMethod", true);
    563         autoload(PACKAGE_SYS, "%method-function", "StandardMethod", true);
    564         autoload(PACKAGE_SYS, "%method-generic-function", "StandardMethod", true);
    565         autoload(PACKAGE_SYS, "%method-specializers", "StandardMethod", true);
    566560        autoload(PACKAGE_SYS, "%nstring-capitalize", "StringFunctions");
    567561        autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions");
    … …  
    575569        autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true);
    576570        autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true);
    577         autoload(PACKAGE_SYS, "%set-method-fast-function", "StandardMethod", true);
    578         autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true);
    579         autoload(PACKAGE_SYS, "%set-function-keywords", "StandardMethod", true);
    580         autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true);
    581         autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true);
    582571        autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives");
    583572        autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector");
    … …  
    638627        autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true);
    639628        autoload(PACKAGE_SYS, "function-info", "function_info");
    640         autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true);
    641629        autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true);
    642630        autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true);
    … …  
    667655        autoload(PACKAGE_SYS, "make-structure-class", "StructureClass");
    668656        autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives");
    669         autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true);
    670         autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true);
    671657        autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions");
    672658        autoload(PACKAGE_SYS, "puthash", "HashTableFunctions");
    … …  
    681667        autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true);
    682668        autoload(PACKAGE_SYS, "set-generic-function-methods","StandardGenericFunction", true);
    683         autoload(PACKAGE_SYS, "set-method-documentation", "StandardMethod", true);
    684         autoload(PACKAGE_SYS, "set-method-lambda-list", "StandardMethod", true);
    685         autoload(PACKAGE_SYS, "set-method-qualifiers", "StandardMethod", true);
    686669        autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true);
    687670        autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true);

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

    r12513 r13814  
    7272                            object.setCallCount(0);
    7373                            object.setHotCount(0);
     74                            LispObject methods = null;
    7475                            if (object instanceof StandardGenericFunction) {
    75                                 LispObject methods =
    76                                     PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object);
    77                                 while (methods != NIL) {
    78                                     StandardMethod method = (StandardMethod) methods.car();
    79                                     method.getFunction().setCallCount(0);
    80                                     method.getFunction().setHotCount(0);
     76                                methods =
     77                                    Symbol.GENERIC_FUNCTION_METHODS.execute(object);
     78                            }
     79                            // TODO: extract methods from non-standard
     80                            // generic functions here once they are
     81                            // implemented
     82                            while (methods != null && methods != NIL) {
     83                                LispObject maybeMethod = methods.car();
     84                                if (maybeMethod instanceof StandardObject) {
     85                                    StandardObject method = (StandardObject) maybeMethod;
     86                                    LispObject function = method.getInstanceSlotValue(Symbol.FUNCTION);
     87                                    function.setCallCount(0);
     88                                    function.setHotCount(0);
    8189                                    methods = methods.cdr();
    8290                                }

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

    r13791 r13814  
    562562
    563563  public static final StandardClass STANDARD_METHOD =
    564     new StandardMethodClass();
    565   static
    566   {
    567     addClass(Symbol.STANDARD_METHOD, STANDARD_METHOD);
    568   }
     564    addStandardClass(Symbol.STANDARD_METHOD, list(METHOD));
     565
     566  public static final StandardClass STANDARD_ACCESSOR_METHOD =
     567    addStandardClass(Symbol.STANDARD_ACCESSOR_METHOD, list(STANDARD_METHOD));
    569568
    570569  public static final StandardClass STANDARD_READER_METHOD =
    571     new StandardReaderMethodClass();
    572   static
    573   {
    574     addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD);
    575   }
     570      addStandardClass(Symbol.STANDARD_READER_METHOD, list(STANDARD_ACCESSOR_METHOD));
     571
     572  public static final StandardClass STANDARD_WRITER_METHOD =
     573      addStandardClass(Symbol.STANDARD_WRITER_METHOD, list(STANDARD_ACCESSOR_METHOD));
    576574
    577575  public static final StandardClass STANDARD_GENERIC_FUNCTION =
    … …  
    678676      list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT")))));
    679677    METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
     678    STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
     679                           BuiltInClass.CLASS_T);
     680    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)));
     690    STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
     691                                    METHOD, METAOBJECT, STANDARD_OBJECT,
     692                                    BuiltInClass.CLASS_T);
     693    STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions(
     694       list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL)));
     695    STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD,
     696                                  STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
     697                                  METHOD, METAOBJECT, STANDARD_OBJECT,
     698                                  BuiltInClass.CLASS_T);
     699    STANDARD_WRITER_METHOD.setCPL(STANDARD_WRITER_METHOD,
     700                                  STANDARD_ACCESSOR_METHOD, STANDARD_METHOD,
     701                                  METHOD, METAOBJECT, STANDARD_OBJECT,
     702                                  BuiltInClass.CLASS_T);
    680703    METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT,
    681704                              BuiltInClass.CLASS_T);
    … …  
    812835    JAVA_EXCEPTION.finalizeClass();
    813836    METAOBJECT.finalizeClass();
     837    METHOD.finalizeClass();
     838    STANDARD_METHOD.finalizeClass();
     839    STANDARD_ACCESSOR_METHOD.finalizeClass();
     840    STANDARD_READER_METHOD.finalizeClass();
     841    STANDARD_WRITER_METHOD.finalizeClass();
    814842    SPECIALIZER.finalizeClass();
    815843    EQL_SPECIALIZER.finalizeClass();
    … …  
    863891    STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
    864892
    865     // STANDARD-METHOD
    866     Debug.assertTrue(STANDARD_METHOD.isFinalized());
    867     STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
    868                            BuiltInClass.CLASS_T);
    869     STANDARD_METHOD.setDirectSlotDefinitions(STANDARD_METHOD.getClassLayout().generateSlotDefinitions());
    870     // There are no inherited slots.
    871     STANDARD_METHOD.setSlotDefinitions(STANDARD_METHOD.getDirectSlotDefinitions());
    872 
    873     // STANDARD-READER-METHOD
    874     Debug.assertTrue(STANDARD_READER_METHOD.isFinalized());
    875     STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_METHOD,
    876                                   METHOD, METAOBJECT, STANDARD_OBJECT,
    877                                   BuiltInClass.CLASS_T);
    878     STANDARD_READER_METHOD.setSlotDefinitions(STANDARD_READER_METHOD.getClassLayout().generateSlotDefinitions());
    879     // All but the last slot are inherited.
    880     STANDARD_READER_METHOD.setDirectSlotDefinitions(list(STANDARD_READER_METHOD.getSlotDefinitions().reverse().car()));
    881 
    882893    // STANDARD-GENERIC-FUNCTION
    883894    Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized());

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

    r13782 r13814  
    7272    slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] =
    7373      NIL;
    74     StandardMethod method =
    75       new StandardMethod(this, function, lambdaList, specializers);
     74    StandardObject method
     75        = (StandardObject)StandardClass.STANDARD_METHOD.allocateInstance();
     76    method.setInstanceSlotValue(Symbol.GENERIC_FUNCTION, this);
     77    method.setInstanceSlotValue(Symbol.LAMBDA_LIST, lambdaList);
     78    method.setInstanceSlotValue(Symbol.KEYWORDS, NIL);
     79    method.setInstanceSlotValue(Symbol.OTHER_KEYWORDS_P, NIL);
     80    method.setInstanceSlotValue(Symbol.SPECIALIZERS, specializers);
     81    method.setInstanceSlotValue(Symbol.QUALIFIERS, NIL);
     82    // Setting the function slot to nil is a transcription of what the
     83    // constructor for StandardMethod instances did (that Java class was
     84    // removed for the implementation of subclassable standard-method).
     85    // (rudi 2012-01-27)
     86    method.setInstanceSlotValue(Symbol.FUNCTION, NIL);
     87    method.setInstanceSlotValue(Symbol.FAST_FUNCTION, function);
     88    method.setInstanceSlotValue(Symbol.DOCUMENTATION, NIL);
    7689    slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] =
    7790      list(method);

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

    r13780 r13814  
    29762976  public static final Symbol FUNCALLABLE_STANDARD_CLASS =
    29772977    PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS");
     2978  public static final Symbol GENERIC_FUNCTION_METHODS =
     2979    PACKAGE_MOP.addExternalSymbol("GENERIC-FUNCTION-METHODS");
    29782980  public static final Symbol SHORT_METHOD_COMBINATION =
    29792981    PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION");
    … …  
    29842986  public static final Symbol SPECIALIZER =
    29852987    PACKAGE_MOP.addExternalSymbol("SPECIALIZER");
     2988  public static final Symbol STANDARD_ACCESSOR_METHOD =
     2989    PACKAGE_MOP.addExternalSymbol("STANDARD-ACCESSOR-METHOD");
    29862990  public static final Symbol STANDARD_READER_METHOD =
    29872991    PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD");
     2992  public static final Symbol STANDARD_WRITER_METHOD =
     2993    PACKAGE_MOP.addExternalSymbol("STANDARD-WRITER-METHOD");
    29882994  public static final Symbol DIRECT_SLOT_DEFINITION =
    29892995    PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION");
    … …  
    31503156  public static final Symbol EXPECTED_TYPE =
    31513157    PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE");
     3158  public static final Symbol FAST_FUNCTION =
     3159    PACKAGE_SYS.addInternalSymbol("FAST-FUNCTION");
    31523160  public static final Symbol FORMAT_ARGUMENTS =
    31533161    PACKAGE_SYS.addInternalSymbol("FORMAT-ARGUMENTS");
    31543162  public static final Symbol FORMAT_CONTROL =
    31553163    PACKAGE_SYS.addInternalSymbol("FORMAT-CONTROL");
    3156   public static final Symbol FSET =
    3157     PACKAGE_SYS.addInternalSymbol("FSET");
     3164  public static final Symbol FSET = PACKAGE_SYS.addInternalSymbol("FSET");
    31583165  public static final Symbol FUNCTION_PRELOAD =
    31593166    PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD");
    31603167  public static final Symbol INSTANCE =
    31613168    PACKAGE_SYS.addInternalSymbol("INSTANCE");
     3169  public static final Symbol KEYWORDS =
     3170    PACKAGE_SYS.addInternalSymbol("KEYWORDS");
    31623171  public static final Symbol MACROEXPAND_MACRO =
    31633172    PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO");
    31643173  public static final Symbol MAKE_FUNCTION_PRELOADING_CONTEXT =
    31653174    PACKAGE_SYS.addInternalSymbol("MAKE-FUNCTION-PRELOADING-CONTEXT");
    3166   public static final Symbol NAME =
    3167     PACKAGE_SYS.addInternalSymbol("NAME");
    3168   public static final Symbol OBJECT =
    3169     PACKAGE_SYS.addInternalSymbol("OBJECT");
     3175  public static final Symbol NAME = PACKAGE_SYS.addInternalSymbol("NAME");
     3176  public static final Symbol OBJECT = PACKAGE_SYS.addInternalSymbol("OBJECT");
    31703177  public static final Symbol OPERANDS =
    31713178    PACKAGE_SYS.addInternalSymbol("OPERANDS");
    31723179  public static final Symbol OPERATION =
    31733180    PACKAGE_SYS.addInternalSymbol("OPERATION");
     3181  public static final Symbol OTHER_KEYWORDS_P =
     3182    PACKAGE_SYS.addInternalSymbol("OTHER-KEYWORDS-P");
    31743183  public static final Symbol PROXY_PRELOADED_FUNCTION =
    31753184    PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION");
     3185  public static final Symbol QUALIFIERS =
     3186    PACKAGE_SYS.addInternalSymbol("QUALIFIERS");
    31763187  public static final Symbol _SOURCE =
    31773188    PACKAGE_SYS.addInternalSymbol("%SOURCE");
    31783189  public static final Symbol SOCKET_STREAM =
    31793190    PACKAGE_SYS.addInternalSymbol("SOCKET-STREAM");
     3191  public static final Symbol SPECIALIZERS =
     3192    PACKAGE_SYS.addInternalSymbol("SPECIALIZERS");
    31803193  public static final Symbol STRING_INPUT_STREAM =
    31813194    PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM");

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

    r13800 r13814  
    6666;; Some functionality implemented in the temporary regular functions
    6767;; needs to be available later as a method definition to be dispatched
    68 ;; to for the STANDARD-CLASS case.  To prevent repeated code, the
    69 ;; functions are implemented in functions by the same name as the
    70 ;; API functions, but with the STD- prefix.
     68;; to for the standard case, e.g. with arguments of type STANDARD-CLASS
     69;; or STANDARD-GENERIC-FUNCTION.  To prevent repeated code, the
     70;; functions are implemented in functions by the same name as the API
     71;; functions, but with the STD- prefix.  These functions are sometimes
     72;; used in regular code as well, either in a "fast path" or to break a
     73;; circularity (e.g., within compute-discriminating-function when the
     74;; user adds a method to compute-discriminating-function).
    7175;;
    7276;; When hacking this file, note that some important parts are implemented
    … …  
    8387;;
    8488;; In case of function names, those defined on the Java side can be
    85 ;; recognized by their prefixed percent sign.
     89;; recognized by their prefixed percent (%) sign.
    8690;;
    8791;; The API functions need to be declaimed NOTINLINE explicitly, because
    … …  
    108112(defconstant +the-standard-reader-method-class+
    109113  (find-class 'standard-reader-method))
     114(defconstant +the-standard-writer-method-class+
     115  (find-class 'standard-writer-method))
    110116(defconstant +the-standard-generic-function-class+
    111117  (find-class 'standard-generic-function))
    … …  
    165171
    166172(defun function-keywords (method)
    167   (%function-keywords method))
     173  (std-function-keywords method))
    168174
    169175
    … …  
    740746    (dolist (direct-slot slots)
    741747      (dolist (reader (slot-definition-readers direct-slot))
    742         (add-reader-method class reader (slot-definition-name direct-slot)))
     748        (add-reader-method class reader direct-slot))
    743749      (dolist (writer (slot-definition-writers direct-slot))
    744750        (add-writer-method class writer (slot-definition-name direct-slot)))))
    … …  
    10051011                                                     ',args-var
    10061012                                                     (second method)))))
    1007               (t (%method-function method)))
     1013              (t (method-function method)))
    10081014            ,',args-var
    10091015            ,(unless (null next-method-list)
    … …  
    11821188  (std-slot-value eql-specializer 'sys::object))
    11831189
     1190;;; Initial versions of some method metaobject readers.  Defined on
     1191;;; AMOP pg. 218ff, will be redefined when generic functions are set up.
     1192
     1193(defun std-method-function (method)
     1194  (std-slot-value method 'cl:function))
     1195
     1196(defun std-method-generic-function (method)
     1197  (std-slot-value method 'cl:generic-function))
     1198
     1199(defun std-method-specializers (method)
     1200  (std-slot-value method 'sys::specializers))
     1201
     1202(defun std-method-qualifiers (method)
     1203  (std-slot-value method 'sys::qualifiers))
     1204
     1205(defun std-accessor-method-slot-definition (accessor-method)
     1206  (std-slot-value accessor-method 'sys:slot-definition))
     1207
     1208;;; Additional method readers
     1209(defun std-method-fast-function (method)
     1210  (std-slot-value method 'sys::fast-function))
     1211
     1212(defun std-function-keywords (method)
     1213  (values (std-slot-value method 'sys::keywords)
     1214          (std-slot-value method 'sys::other-keywords-p)))
     1215
     1216;;; Preliminary accessor definitions, will be redefined as generic
     1217;;; functions later in this file
     1218
     1219(declaim (notinline method-generic-function))
     1220(defun method-generic-function (method)
     1221  (std-method-generic-function method))
     1222
     1223(declaim (notinline method-specializers))
     1224(defun method-specializers (method)
     1225  (std-method-specializers method))
     1226
     1227(declaim (notinline method-qualifiers))
     1228(defun method-qualifiers (method)
     1229  (std-method-qualifiers method))
     1230
     1231
     1232
    11841233;; MOP (p. 216) specifies the following reader generic functions:
    11851234;;   generic-function-argument-precedence-order
    … …  
    12321281
    12331282(defun (setf method-lambda-list) (new-value method)
    1234   (set-method-lambda-list method new-value))
     1283  (setf (std-slot-value method 'sys::lambda-list) new-value))
    12351284
    12361285(defun (setf method-qualifiers) (new-value method)
    1237   (set-method-qualifiers method new-value))
     1286  (setf (std-slot-value method 'sys::qualifiers) new-value))
     1287
     1288(defun method-documentation (method)
     1289  (std-slot-value method 'documentation))
    12381290
    12391291(defun (setf method-documentation) (new-value method)
    1240   (set-method-documentation method new-value))
     1292  (setf (std-slot-value method 'documentation) new-value))
    12411293
    12421294;;; defgeneric
    … …  
    14041456  (let ((result nil))
    14051457    (dolist (method (generic-function-methods generic-function))
    1406       (dolist (specializer (%method-specializers method))
     1458      (dolist (specializer (method-specializers method))
    14071459        (when (typep specializer 'eql-specializer)
    14081460          (pushnew (eql-specializer-object specializer)
    … …  
    17111763  (declare (ignore gf))
    17121764  (let ((method (std-allocate-instance +the-standard-method-class+))
    1713         (analyzed-args (analyze-lambda-list lambda-list))
    1714         )
     1765        (analyzed-args (analyze-lambda-list lambda-list)))
    17151766    (setf (method-lambda-list method) lambda-list)
    17161767    (setf (method-qualifiers method) qualifiers)
    1717     (%set-method-specializers method (canonicalize-specializers specializers))
     1768    (setf (std-slot-value method 'sys::specializers)
     1769          (canonicalize-specializers specializers))
    17181770    (setf (method-documentation method) documentation)
    1719     (%set-method-generic-function method nil)
    1720     (%set-method-function method function)
    1721     (%set-method-fast-function method fast-function)
    1722     (%set-function-keywords method
    1723                             (getf analyzed-args :keywords)
    1724                             (getf analyzed-args :allow-other-keys))
     1771    (setf (std-slot-value method 'generic-function) nil) ; set by add-method
     1772    (setf (std-slot-value method 'function) function)
     1773    (setf (std-slot-value method 'sys::fast-function) fast-function)
     1774    (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords))
     1775    (setf (std-slot-value method 'sys::other-keywords-p)
     1776          (getf analyzed-args :allow-other-keys))
    17251777    method))
    17261778
    17271779(defun std-add-method (gf method)
    1728   (when (%method-generic-function method)
     1780  (when (method-generic-function method)
    17291781    (error 'simple-error
    1730            :format-control "ADD-METHOD: ~S is a method of ~S."
    1731            :format-arguments (list method (%method-generic-function method))))
     1782           :format-control "ADD-METHOD: ~S is already a method of ~S."
     1783           :format-arguments (list method (method-generic-function method))))
    17321784  ;; Remove existing method with same qualifiers and specializers (if any).
    1733   (let ((old-method (%find-method gf (method-qualifiers method)
    1734                                  (%method-specializers method) nil)))
     1785  (let ((old-method (%find-method gf (std-method-qualifiers method)
     1786                                 (method-specializers method) nil)))
    17351787    (when old-method
    17361788      (std-remove-method gf old-method)))
    1737   (%set-method-generic-function method gf)
     1789  (setf (std-slot-value method 'generic-function) gf)
    17381790  (push method (generic-function-methods gf))
    1739   (dolist (specializer (%method-specializers method))
     1791  (dolist (specializer (method-specializers method))
    17401792    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
    17411793      (pushnew method (class-direct-methods specializer))))
    … …  
    17461798  (setf (generic-function-methods gf)
    17471799        (remove method (generic-function-methods gf)))
    1748   (%set-method-generic-function method nil)
    1749   (dolist (specializer (%method-specializers method))
     1800  (setf (std-slot-value method 'generic-function) gf)
     1801  (dolist (specializer (method-specializers method))
    17501802    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
    17511803      (setf (class-direct-methods specializer)
    … …  
    17691821                                  (method-qualifiers method))
    17701822                           (equal canonical-specializers
    1771                                   (%method-specializers method))))
     1823                                  (method-specializers method))))
    17721824                   (generic-function-methods gf))))
    17731825    (if (and (null method) errorp)
    … …  
    17921844  ;; standard-generic-function, so we call various
    17931845  ;; sys:%generic-function-foo readers to break circularities.
     1846  ;; (rudi 2012-01-27): maybe we need to discriminate between
     1847  ;; standard-methods and methods as well.
    17941848  (cond
    17951849    ((and (= (length (sys:%generic-function-methods gf)) 1)
    17961850          (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method))
    17971851     (let* ((method (%car (sys:%generic-function-methods gf)))
    1798             (class (car (%method-specializers method)))
    1799             (slot-name (reader-method-slot-name method)))
     1852            (class (car (std-method-specializers method)))
     1853            (slot-name (slot-definition-name (accessor-method-slot-definition method))))
    18001854       #'(lambda (arg)
    18011855           (declare (optimize speed))
    … …  
    18281882                      (= (length (sys:%generic-function-methods gf)) 1))
    18291883                 (let* ((method (%car (sys:%generic-function-methods gf)))
    1830                         (specializer (car (%method-specializers method)))
    1831                         (function (or (%method-fast-function method)
    1832                                       (%method-function method))))
     1884                        (specializer (car (std-method-specializers method)))
     1885                        (function (or (std-method-fast-function method)
     1886                                      (std-method-function method))))
    18331887                   (if (typep specializer 'eql-specializer)
    18341888                       (let ((specializer-object (eql-specializer-object specializer)))
    … …  
    18861940                        (funcall emfun args)
    18871941                        (slow-method-lookup gf args))))))
    1888 ;;           (let ((non-key-args (+ number-required
    1889 ;;                                  (length (gf-optional-args gf))))))
     1942           ;;           (let ((non-key-args (+ number-required
     1943           ;;                                  (length (gf-optional-args gf))))))
    18901944           #'(lambda (&rest args)
    18911945               (declare (optimize speed))
    … …  
    19121966
    19131967(defun method-applicable-p (method args)
    1914   (do* ((specializers (%method-specializers method) (cdr specializers))
     1968  (do* ((specializers (method-specializers method) (cdr specializers))
    19151969        (args args (cdr args)))
    19161970       ((null specializers) t)
    … …  
    19401994;;;
    19411995(defun method-applicable-using-classes-p (method classes)
    1942   (do* ((specializers (%method-specializers method) (cdr specializers))
     1996  (do* ((specializers (method-specializers method) (cdr specializers))
    19431997  (classes classes (cdr classes))
    19441998  (knownp t))
    … …  
    20402094(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
    20412095  (if argument-precedence-order
    2042       (let ((specializers-1 (%method-specializers method1))
    2043             (specializers-2 (%method-specializers method2)))
     2096      (let ((specializers-1 (std-method-specializers method1))
     2097            (specializers-2 (std-method-specializers method2)))
    20442098        (dolist (index argument-precedence-order)
    20452099          (let ((spec1 (nth index specializers-1))
    … …  
    20532107                     (return (sub-specializer-p spec1 spec2
    20542108                                                (nth index required-classes)))))))))
    2055       (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
    2056            (specializers-2 (%method-specializers method2) (cdr specializers-2))
     2109      (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1))
     2110           (specializers-2 (std-method-specializers method2) (cdr specializers-2))
    20572111           (classes required-classes (cdr classes)))
    20582112          ((null specializers-1) nil)
    … …  
    21372191               gf (remove around methods))))
    21382192         (setf emf-form
    2139                (generate-emf-lambda (%method-function around) next-emfun))))
     2193               (generate-emf-lambda (std-method-function around) next-emfun))))
    21402194      ((eq mc-name 'standard)
    21412195       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
    … …  
    21462200               (cond
    21472201                 ((and (null befores) (null reverse-afters))
    2148                   (let ((fast-function (%method-fast-function (car primaries))))
     2202                  (let ((fast-function (std-method-fast-function (car primaries))))
    21492203                    (if fast-function
    21502204                        (ecase (length (gf-required-args gf))
    … …  
    21572211                               (declare (optimize speed))
    21582212                               (funcall fast-function (car args) (cadr args)))))
    2159                         (generate-emf-lambda (%method-function (car primaries))
     2213                        (generate-emf-lambda (std-method-function (car primaries))
    21602214                                             next-emfun))))
    21612215                 (t
    2162                   (let ((method-function (%method-function (car primaries))))
     2216                  (let ((method-function (std-method-function (car primaries))))
    21632217                    #'(lambda (args)
    21642218                        (declare (optimize speed))
    21652219                        (dolist (before befores)
    2166                           (funcall (%method-function before) args nil))
     2220                          (funcall (std-method-function before) args nil))
    21672221                        (multiple-value-prog1
    21682222                            (funcall method-function args next-emfun)
    21692223                          (dolist (after reverse-afters)
    2170                             (funcall (%method-function after) args nil))))))))))
     2224                            (funcall (std-method-function after) args nil))))))))))
    21712225      (long-method-combination-p
    21722226       (let* ((mc-obj (get mc-name 'method-combination-object))
    … …  
    21892243                 (if (and (null (cdr primaries))
    21902244                          (not (null ioa)))
    2191                      (generate-emf-lambda (%method-function (car primaries)) nil)
     2245                     (generate-emf-lambda (std-method-function (car primaries)) nil)
    21922246                     `(lambda (args)
    21932247                        (,operator ,@(mapcar
    21942248                                      (lambda (primary)
    2195                                         `(funcall ,(%method-function primary) args nil))
     2249                                        `(funcall ,(std-method-function primary) args nil))
    21962250                                      primaries)))))))))
    21972251    (assert (not (null emf-form)))
    … …  
    22112265      (let ((next-emfun (compute-primary-emfun (cdr methods))))
    22122266        #'(lambda (args)
    2213            (funcall (%method-function (car methods)) args next-emfun)))))
     2267           (funcall (std-method-function (car methods)) args next-emfun)))))
    22142268
    22152269(defvar *call-next-method-p*)
    … …  
    23822436                                             function
    23832437                                             fast-function
    2384                                              slot-name)
     2438                                             slot-definition)
    23852439  (declare (ignore gf))
    23862440  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
    23872441    (setf (method-lambda-list method) lambda-list)
    23882442    (setf (method-qualifiers method) qualifiers)
    2389     (%set-method-specializers method (canonicalize-specializers specializers))
     2443    (setf (std-slot-value method 'sys::specializers)
     2444          (canonicalize-specializers specializers))
    23902445    (setf (method-documentation method) documentation)
    2391     (%set-method-generic-function method nil)
    2392     (%set-method-function method function)
    2393     (%set-method-fast-function method fast-function)
    2394     (set-reader-method-slot-name method slot-name)
    2395     (%set-function-keywords method nil nil)
     2446    (setf (std-slot-value method 'generic-function) nil)
     2447    (setf (std-slot-value method 'function) function)
     2448    (setf (std-slot-value method 'sys::fast-function) fast-function)
     2449    (setf (std-slot-value method 'sys:slot-definition) slot-definition)
     2450    (setf (std-slot-value method 'sys::keywords) nil)
     2451    (setf (std-slot-value method 'sys::other-keywords-p) nil)
    23962452    method))
    23972453
    2398 (defun add-reader-method (class function-name slot-name)
    2399   (let* ((lambda-expression
     2454(defun add-reader-method (class function-name slot-definition)
     2455  (let* ((method-class (if (eq (class-of class) +the-standard-class+)
     2456                           +the-standard-reader-method-class+
     2457                           (reader-method-class class)))
     2458         (slot-name (slot-definition-name slot-definition))
     2459         (lambda-expression
    24002460          (if (eq (class-of class) +the-standard-class+)
    24012461              `(lambda (object) (std-slot-value object ',slot-name))
    24022462              `(lambda (object) (slot-value object ',slot-name))))
    24032463         (method-function (compute-method-function lambda-expression))
    2404          (fast-function (compute-method-fast-function lambda-expression)))
    2405     (let ((method-lambda-list '(object))
    2406           (gf (find-generic-function function-name nil)))
    2407       (if gf
    2408           (check-method-lambda-list function-name
    2409                                     method-lambda-list
    2410                                     (generic-function-lambda-list gf))
    2411         (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
    2412       (let ((method
    2413              (make-instance-standard-reader-method gf
    2414                                                    :lambda-list '(object)
    2415                                                    :qualifiers ()
    2416                                                    :specializers (list class)
    2417                                                    :function (if (autoloadp 'compile)
    2418                                                                  method-function
    2419                                                                  (autocompile method-function))
    2420                                                    :fast-function (if (autoloadp 'compile)
    2421                                                                       fast-function
    2422                                                                       (autocompile fast-function))
    2423                                                    :slot-name slot-name)))
    2424         (std-add-method gf method)
    2425         method))))
     2464         (fast-function (compute-method-fast-function lambda-expression))
     2465         (method-lambda-list '(object))
     2466         (gf (find-generic-function function-name nil)))
     2467    ;; required by AMOP pg. 225
     2468    (assert (subtypep method-class +the-standard-reader-method-class+))
     2469    (if gf
     2470        (check-method-lambda-list function-name
     2471                                  method-lambda-list
     2472                                  (generic-function-lambda-list gf))
     2473        (setf gf (ensure-generic-function function-name
     2474                                          :lambda-list method-lambda-list)))
     2475    (let ((method
     2476           (if (eq method-class +the-standard-reader-method-class+)
     2477               (make-instance-standard-reader-method
     2478                gf
     2479                :lambda-list method-lambda-list
     2480                :qualifiers ()
     2481                :specializers (list class)
     2482                :function (if (autoloadp 'compile)
     2483                              method-function
     2484                              (autocompile method-function))
     2485                :fast-function (if (autoloadp 'compile)
     2486                                   fast-function
     2487                                   (autocompile fast-function))
     2488                :slot-definition slot-definition)
     2489               (make-instance method-class
     2490                              :lambda-list method-lambda-list
     2491                              :qualifiers ()
     2492                              :specializers (list class)
     2493                              :function (if (autoloadp 'compile)
     2494                                            method-function
     2495                                            (autocompile method-function))
     2496                              :fast-function (if (autoloadp 'compile)
     2497                                                 fast-function
     2498                                                 (autocompile fast-function))
     2499                              :slot-definition slot-definition))))
     2500      (if (eq (class-of gf) +the-standard-generic-function-class+)
     2501          (std-add-method gf method)
     2502          (add-method gf method))
     2503      method)))
    24262504
    24272505(defun add-writer-method (class function-name slot-name)
    … …  
    26502728
    26512729
    2652 
     2730;;; AMOP pg. 180
    26532731(defgeneric direct-slot-definition-class (class &rest initargs))
    26542732
    … …  
    26572735  +the-standard-direct-slot-definition-class+)
    26582736
     2737;;; AMOP pg. 181
    26592738(defgeneric effective-slot-definition-class (class &rest initargs))
    26602739
    … …  
    26622741  (declare (ignore initargs))
    26632742  +the-standard-effective-slot-definition-class+)
     2743
     2744;;; AMOP pg. 224
     2745(defgeneric reader-method-class (class direct-slot &rest initargs))
     2746
     2747(defmethod reader-method-class ((class standard-class)
     2748                                (direct-slot standard-direct-slot-definition)
     2749                                &rest initargs)
     2750  (declare (ignore initargs))
     2751  +the-standard-reader-method-class+)
     2752
     2753(defmethod reader-method-class ((class funcallable-standard-class)
     2754                                (direct-slot standard-direct-slot-definition)
     2755                                &rest initargs)
     2756  (declare (ignore initargs))
     2757  +the-standard-reader-method-class+)
    26642758
    26652759(atomic-defgeneric documentation (x doc-type)
    … …  
    35033597(atomic-defgeneric function-keywords (method)
    35043598  (:method ((method standard-method))
    3505     (%function-keywords method)))
     3599    (std-function-keywords method)))
    35063600
    35073601(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
    … …  
    35573651    (sys:%generic-function-name generic-function)))
    35583652
     3653;;; Readers for Method Metaobjects
     3654;;; AMOP pg. 218ff.
     3655
     3656(atomic-defgeneric method-function (method)
     3657  (:method ((method standard-method))
     3658    (std-method-function method)))
     3659
     3660(atomic-defgeneric method-generic-function (method)
     3661  (:method ((method standard-method))
     3662    (std-method-generic-function method)))
     3663
     3664(atomic-defgeneric method-lambda-list (method)
     3665  (:method ((method standard-method))
     3666    (std-slot-value method 'sys::lambda-list)))
     3667
     3668(atomic-defgeneric method-specializers (method)
     3669  (:method ((method standard-method))
     3670    (std-method-specializers method)))
     3671
     3672(atomic-defgeneric method-qualifiers (method)
     3673  (:method ((method standard-method))
     3674    (std-method-qualifiers method)))
     3675
     3676(atomic-defgeneric accessor-method-slot-definition (method)
     3677  (:method ((method standard-accessor-method))
     3678    (std-accessor-method-slot-definition method)))
     3679
     3680
    35593681(eval-when (:compile-toplevel :load-toplevel :execute)
    35603682  (require "MOP"))

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

    r13789 r13814  
    5858          standard-method
    5959          method-function
     60          method-specializers
     61          method-generic-function
     62
    6063          standard-accessor-method
    6164          standard-reader-method

  • trunk/abcl/src/org/armedbear/lisp/print-object.lisp

    r13378 r13814  
    5656  class)
    5757
    58 (defmethod print-object ((gf standard-generic-function) stream)
     58(defmethod print-object ((gf generic-function) stream)
    5959  (print-unreadable-object (gf stream :identity t)
    6060    (format stream "~S ~S"
    6161            (class-name (class-of gf))
    62             (%generic-function-name gf)))
     62            (mop:generic-function-name gf)))
    6363  gf)
    6464
    65 (defmethod print-object ((method standard-method) stream)
     65(defmethod print-object ((method method) stream)
    6666  (print-unreadable-object (method stream :identity t)
    6767    (format stream "~S ~S~{ ~S~} ~S"
    6868            (class-name (class-of method))
    69             (%generic-function-name
    70              (%method-generic-function method))
     69            (mop:generic-function-name
     70             (mop:method-generic-function method))
    7171            (method-qualifiers method)
    7272            (mapcar #'(lambda (c)
    73                         (if (typep c 'mop::eql-specializer)
    74                             `(eql ,(mop::eql-specializer-object c))
     73                        (if (typep c 'mop:eql-specializer)
     74                            `(eql ,(mop:eql-specializer-object c))
    7575                          (class-name c)))
    76                     (%method-specializers method))))
     76                    (mop:method-specializers method))))
    7777  method)
    7878

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

    r12682 r13814  
    6868                       (dolist (method
    6969                                 (mop::generic-function-methods definition))
    70                          (let ((function (sys:%method-function method)))
     70                         (let ((function (mop:method-function method)))
    7171                           (setf full-count (sys:call-count function))
    7272                           (setf hot-count (sys:hot-count function)))
    … …  
    8383         object)
    8484        ((typep object 'generic-function)
    85          (sys:%generic-function-name object))
     85         (mop:generic-function-name object))
    8686        ((typep object 'method)
    8787         (list 'METHOD
    88                (sys:%generic-function-name (sys:%method-generic-function object))
    89                (sys:%method-specializers object)))))
     88               (mop:generic-function-name (mop:method-generic-function object))
     89               (mop:method-specializers object)))))
    9090
    9191(defun object-compiled-function-p (object)
    … …  
    9393         (compiled-function-p (fdefinition object)))
    9494        ((typep object 'method)
    95          (compiled-function-p (sys:%method-function object)))
     95         (compiled-function-p (mop:method-function object)))
    9696        (t
    9797         (compiled-function-p object))))
Note: See TracChangeset for help on using the changeset viewer.