Changeset 13814
- Timestamp:
- 01/27/12 13:06:03 (11 years ago)
- 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 536 536 autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true); 537 537 autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false); 538 autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);539 autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);540 538 autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true); 541 539 autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true); … … 560 558 autoload(PACKAGE_SYS, "%make-string", "StringFunctions"); 561 559 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);566 560 autoload(PACKAGE_SYS, "%nstring-capitalize", "StringFunctions"); 567 561 autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions"); … … 575 569 autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true); 576 570 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);582 571 autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives"); 583 572 autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector"); … … 638 627 autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); 639 628 autoload(PACKAGE_SYS, "function-info", "function_info"); 640 autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true);641 629 autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true); 642 630 autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); … … 667 655 autoload(PACKAGE_SYS, "make-structure-class", "StructureClass"); 668 656 autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives"); 669 autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true);670 autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true);671 657 autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions"); 672 658 autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); … … 681 667 autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true); 682 668 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);686 669 autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true); 687 670 autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true); -
trunk/abcl/src/org/armedbear/lisp/Profiler.java
r12513 r13814 72 72 object.setCallCount(0); 73 73 object.setHotCount(0); 74 LispObject methods = null; 74 75 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); 81 89 methods = methods.cdr(); 82 90 } -
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
r13791 r13814 562 562 563 563 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)); 569 568 570 569 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)); 576 574 577 575 public static final StandardClass STANDARD_GENERIC_FUNCTION = … … 678 676 list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT"))))); 679 677 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); 680 703 METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, 681 704 BuiltInClass.CLASS_T); … … 812 835 JAVA_EXCEPTION.finalizeClass(); 813 836 METAOBJECT.finalizeClass(); 837 METHOD.finalizeClass(); 838 STANDARD_METHOD.finalizeClass(); 839 STANDARD_ACCESSOR_METHOD.finalizeClass(); 840 STANDARD_READER_METHOD.finalizeClass(); 841 STANDARD_WRITER_METHOD.finalizeClass(); 814 842 SPECIALIZER.finalizeClass(); 815 843 EQL_SPECIALIZER.finalizeClass(); … … 863 891 STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass(); 864 892 865 // STANDARD-METHOD866 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-METHOD874 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 882 893 // STANDARD-GENERIC-FUNCTION 883 894 Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized()); -
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
r13782 r13814 72 72 slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = 73 73 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); 76 89 slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = 77 90 list(method); -
trunk/abcl/src/org/armedbear/lisp/Symbol.java
r13780 r13814 2976 2976 public static final Symbol FUNCALLABLE_STANDARD_CLASS = 2977 2977 PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); 2978 public static final Symbol GENERIC_FUNCTION_METHODS = 2979 PACKAGE_MOP.addExternalSymbol("GENERIC-FUNCTION-METHODS"); 2978 2980 public static final Symbol SHORT_METHOD_COMBINATION = 2979 2981 PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); … … 2984 2986 public static final Symbol SPECIALIZER = 2985 2987 PACKAGE_MOP.addExternalSymbol("SPECIALIZER"); 2988 public static final Symbol STANDARD_ACCESSOR_METHOD = 2989 PACKAGE_MOP.addExternalSymbol("STANDARD-ACCESSOR-METHOD"); 2986 2990 public static final Symbol STANDARD_READER_METHOD = 2987 2991 PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); 2992 public static final Symbol STANDARD_WRITER_METHOD = 2993 PACKAGE_MOP.addExternalSymbol("STANDARD-WRITER-METHOD"); 2988 2994 public static final Symbol DIRECT_SLOT_DEFINITION = 2989 2995 PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION"); … … 3150 3156 public static final Symbol EXPECTED_TYPE = 3151 3157 PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE"); 3158 public static final Symbol FAST_FUNCTION = 3159 PACKAGE_SYS.addInternalSymbol("FAST-FUNCTION"); 3152 3160 public static final Symbol FORMAT_ARGUMENTS = 3153 3161 PACKAGE_SYS.addInternalSymbol("FORMAT-ARGUMENTS"); 3154 3162 public static final Symbol FORMAT_CONTROL = 3155 3163 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"); 3158 3165 public static final Symbol FUNCTION_PRELOAD = 3159 3166 PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD"); 3160 3167 public static final Symbol INSTANCE = 3161 3168 PACKAGE_SYS.addInternalSymbol("INSTANCE"); 3169 public static final Symbol KEYWORDS = 3170 PACKAGE_SYS.addInternalSymbol("KEYWORDS"); 3162 3171 public static final Symbol MACROEXPAND_MACRO = 3163 3172 PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO"); 3164 3173 public static final Symbol MAKE_FUNCTION_PRELOADING_CONTEXT = 3165 3174 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"); 3170 3177 public static final Symbol OPERANDS = 3171 3178 PACKAGE_SYS.addInternalSymbol("OPERANDS"); 3172 3179 public static final Symbol OPERATION = 3173 3180 PACKAGE_SYS.addInternalSymbol("OPERATION"); 3181 public static final Symbol OTHER_KEYWORDS_P = 3182 PACKAGE_SYS.addInternalSymbol("OTHER-KEYWORDS-P"); 3174 3183 public static final Symbol PROXY_PRELOADED_FUNCTION = 3175 3184 PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION"); 3185 public static final Symbol QUALIFIERS = 3186 PACKAGE_SYS.addInternalSymbol("QUALIFIERS"); 3176 3187 public static final Symbol _SOURCE = 3177 3188 PACKAGE_SYS.addInternalSymbol("%SOURCE"); 3178 3189 public static final Symbol SOCKET_STREAM = 3179 3190 PACKAGE_SYS.addInternalSymbol("SOCKET-STREAM"); 3191 public static final Symbol SPECIALIZERS = 3192 PACKAGE_SYS.addInternalSymbol("SPECIALIZERS"); 3180 3193 public static final Symbol STRING_INPUT_STREAM = 3181 3194 PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM"); -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13800 r13814 66 66 ;; Some functionality implemented in the temporary regular functions 67 67 ;; 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). 71 75 ;; 72 76 ;; When hacking this file, note that some important parts are implemented … … 83 87 ;; 84 88 ;; 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. 86 90 ;; 87 91 ;; The API functions need to be declaimed NOTINLINE explicitly, because … … 108 112 (defconstant +the-standard-reader-method-class+ 109 113 (find-class 'standard-reader-method)) 114 (defconstant +the-standard-writer-method-class+ 115 (find-class 'standard-writer-method)) 110 116 (defconstant +the-standard-generic-function-class+ 111 117 (find-class 'standard-generic-function)) … … 165 171 166 172 (defun function-keywords (method) 167 ( %function-keywords method))173 (std-function-keywords method)) 168 174 169 175 … … 740 746 (dolist (direct-slot slots) 741 747 (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)) 743 749 (dolist (writer (slot-definition-writers direct-slot)) 744 750 (add-writer-method class writer (slot-definition-name direct-slot))))) … … 1005 1011 ',args-var 1006 1012 (second method))))) 1007 (t ( %method-function method)))1013 (t (method-function method))) 1008 1014 ,',args-var 1009 1015 ,(unless (null next-method-list) … … 1182 1188 (std-slot-value eql-specializer 'sys::object)) 1183 1189 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 1184 1233 ;; MOP (p. 216) specifies the following reader generic functions: 1185 1234 ;; generic-function-argument-precedence-order … … 1232 1281 1233 1282 (defun (setf method-lambda-list) (new-value method) 1234 (set -method-lambda-list methodnew-value))1283 (setf (std-slot-value method 'sys::lambda-list) new-value)) 1235 1284 1236 1285 (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)) 1238 1290 1239 1291 (defun (setf method-documentation) (new-value method) 1240 (set -method-documentation methodnew-value))1292 (setf (std-slot-value method 'documentation) new-value)) 1241 1293 1242 1294 ;;; defgeneric … … 1404 1456 (let ((result nil)) 1405 1457 (dolist (method (generic-function-methods generic-function)) 1406 (dolist (specializer ( %method-specializers method))1458 (dolist (specializer (method-specializers method)) 1407 1459 (when (typep specializer 'eql-specializer) 1408 1460 (pushnew (eql-specializer-object specializer) … … 1711 1763 (declare (ignore gf)) 1712 1764 (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))) 1715 1766 (setf (method-lambda-list method) lambda-list) 1716 1767 (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)) 1718 1770 (setf (method-documentation method) documentation) 1719 ( %set-method-generic-function method nil)1720 ( %set-method-function methodfunction)1721 ( %set-method-fast-function methodfast-function)1722 ( %set-function-keywords method1723 (getf analyzed-args :keywords)1724 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)) 1725 1777 method)) 1726 1778 1727 1779 (defun std-add-method (gf method) 1728 (when ( %method-generic-function method)1780 (when (method-generic-function method) 1729 1781 (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)))) 1732 1784 ;; 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))) 1735 1787 (when old-method 1736 1788 (std-remove-method gf old-method))) 1737 ( %set-method-generic-function methodgf)1789 (setf (std-slot-value method 'generic-function) gf) 1738 1790 (push method (generic-function-methods gf)) 1739 (dolist (specializer ( %method-specializers method))1791 (dolist (specializer (method-specializers method)) 1740 1792 (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? 1741 1793 (pushnew method (class-direct-methods specializer)))) … … 1746 1798 (setf (generic-function-methods gf) 1747 1799 (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)) 1750 1802 (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? 1751 1803 (setf (class-direct-methods specializer) … … 1769 1821 (method-qualifiers method)) 1770 1822 (equal canonical-specializers 1771 ( %method-specializers method))))1823 (method-specializers method)))) 1772 1824 (generic-function-methods gf)))) 1773 1825 (if (and (null method) errorp) … … 1792 1844 ;; standard-generic-function, so we call various 1793 1845 ;; 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. 1794 1848 (cond 1795 1849 ((and (= (length (sys:%generic-function-methods gf)) 1) 1796 1850 (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method)) 1797 1851 (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)))) 1800 1854 #'(lambda (arg) 1801 1855 (declare (optimize speed)) … … 1828 1882 (= (length (sys:%generic-function-methods gf)) 1)) 1829 1883 (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)))) 1833 1887 (if (typep specializer 'eql-specializer) 1834 1888 (let ((specializer-object (eql-specializer-object specializer))) … … 1886 1940 (funcall emfun args) 1887 1941 (slow-method-lookup gf args)))))) 1888 ;; (let ((non-key-args (+ number-required1889 ;; (length (gf-optional-args gf))))))1942 ;; (let ((non-key-args (+ number-required 1943 ;; (length (gf-optional-args gf)))))) 1890 1944 #'(lambda (&rest args) 1891 1945 (declare (optimize speed)) … … 1912 1966 1913 1967 (defun method-applicable-p (method args) 1914 (do* ((specializers ( %method-specializers method) (cdr specializers))1968 (do* ((specializers (method-specializers method) (cdr specializers)) 1915 1969 (args args (cdr args))) 1916 1970 ((null specializers) t) … … 1940 1994 ;;; 1941 1995 (defun method-applicable-using-classes-p (method classes) 1942 (do* ((specializers ( %method-specializers method) (cdr specializers))1996 (do* ((specializers (method-specializers method) (cdr specializers)) 1943 1997 (classes classes (cdr classes)) 1944 1998 (knownp t)) … … 2040 2094 (defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order) 2041 2095 (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))) 2044 2098 (dolist (index argument-precedence-order) 2045 2099 (let ((spec1 (nth index specializers-1)) … … 2053 2107 (return (sub-specializer-p spec1 spec2 2054 2108 (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)) 2057 2111 (classes required-classes (cdr classes))) 2058 2112 ((null specializers-1) nil) … … 2137 2191 gf (remove around methods)))) 2138 2192 (setf emf-form 2139 (generate-emf-lambda ( %method-function around) next-emfun))))2193 (generate-emf-lambda (std-method-function around) next-emfun)))) 2140 2194 ((eq mc-name 'standard) 2141 2195 (let* ((next-emfun (compute-primary-emfun (cdr primaries))) … … 2146 2200 (cond 2147 2201 ((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)))) 2149 2203 (if fast-function 2150 2204 (ecase (length (gf-required-args gf)) … … 2157 2211 (declare (optimize speed)) 2158 2212 (funcall fast-function (car args) (cadr args))))) 2159 (generate-emf-lambda ( %method-function (car primaries))2213 (generate-emf-lambda (std-method-function (car primaries)) 2160 2214 next-emfun)))) 2161 2215 (t 2162 (let ((method-function ( %method-function (car primaries))))2216 (let ((method-function (std-method-function (car primaries)))) 2163 2217 #'(lambda (args) 2164 2218 (declare (optimize speed)) 2165 2219 (dolist (before befores) 2166 (funcall ( %method-function before) args nil))2220 (funcall (std-method-function before) args nil)) 2167 2221 (multiple-value-prog1 2168 2222 (funcall method-function args next-emfun) 2169 2223 (dolist (after reverse-afters) 2170 (funcall ( %method-function after) args nil))))))))))2224 (funcall (std-method-function after) args nil)))))))))) 2171 2225 (long-method-combination-p 2172 2226 (let* ((mc-obj (get mc-name 'method-combination-object)) … … 2189 2243 (if (and (null (cdr primaries)) 2190 2244 (not (null ioa))) 2191 (generate-emf-lambda ( %method-function (car primaries)) nil)2245 (generate-emf-lambda (std-method-function (car primaries)) nil) 2192 2246 `(lambda (args) 2193 2247 (,operator ,@(mapcar 2194 2248 (lambda (primary) 2195 `(funcall ,( %method-function primary) args nil))2249 `(funcall ,(std-method-function primary) args nil)) 2196 2250 primaries))))))))) 2197 2251 (assert (not (null emf-form))) … … 2211 2265 (let ((next-emfun (compute-primary-emfun (cdr methods)))) 2212 2266 #'(lambda (args) 2213 (funcall ( %method-function (car methods)) args next-emfun)))))2267 (funcall (std-method-function (car methods)) args next-emfun))))) 2214 2268 2215 2269 (defvar *call-next-method-p*) … … 2382 2436 function 2383 2437 fast-function 2384 slot- name)2438 slot-definition) 2385 2439 (declare (ignore gf)) 2386 2440 (let ((method (std-allocate-instance +the-standard-reader-method-class+))) 2387 2441 (setf (method-lambda-list method) lambda-list) 2388 2442 (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)) 2390 2445 (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) 2396 2452 method)) 2397 2453 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 2400 2460 (if (eq (class-of class) +the-standard-class+) 2401 2461 `(lambda (object) (std-slot-value object ',slot-name)) 2402 2462 `(lambda (object) (slot-value object ',slot-name)))) 2403 2463 (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))) 2426 2504 2427 2505 (defun add-writer-method (class function-name slot-name) … … 2650 2728 2651 2729 2652 2730 ;;; AMOP pg. 180 2653 2731 (defgeneric direct-slot-definition-class (class &rest initargs)) 2654 2732 … … 2657 2735 +the-standard-direct-slot-definition-class+) 2658 2736 2737 ;;; AMOP pg. 181 2659 2738 (defgeneric effective-slot-definition-class (class &rest initargs)) 2660 2739 … … 2662 2741 (declare (ignore initargs)) 2663 2742 +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+) 2664 2758 2665 2759 (atomic-defgeneric documentation (x doc-type) … … 3503 3597 (atomic-defgeneric function-keywords (method) 3504 3598 (:method ((method standard-method)) 3505 ( %function-keywords method)))3599 (std-function-keywords method))) 3506 3600 3507 3601 (setf *gf-initialize-instance* (symbol-function 'initialize-instance)) … … 3557 3651 (sys:%generic-function-name generic-function))) 3558 3652 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 3559 3681 (eval-when (:compile-toplevel :load-toplevel :execute) 3560 3682 (require "MOP")) -
trunk/abcl/src/org/armedbear/lisp/mop.lisp
r13789 r13814 58 58 standard-method 59 59 method-function 60 method-specializers 61 method-generic-function 62 60 63 standard-accessor-method 61 64 standard-reader-method -
trunk/abcl/src/org/armedbear/lisp/print-object.lisp
r13378 r13814 56 56 class) 57 57 58 (defmethod print-object ((gf standard-generic-function) stream)58 (defmethod print-object ((gf generic-function) stream) 59 59 (print-unreadable-object (gf stream :identity t) 60 60 (format stream "~S ~S" 61 61 (class-name (class-of gf)) 62 ( %generic-function-name gf)))62 (mop:generic-function-name gf))) 63 63 gf) 64 64 65 (defmethod print-object ((method standard-method) stream)65 (defmethod print-object ((method method) stream) 66 66 (print-unreadable-object (method stream :identity t) 67 67 (format stream "~S ~S~{ ~S~} ~S" 68 68 (class-name (class-of method)) 69 ( %generic-function-name70 ( %method-generic-function method))69 (mop:generic-function-name 70 (mop:method-generic-function method)) 71 71 (method-qualifiers method) 72 72 (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)) 75 75 (class-name c))) 76 ( %method-specializers method))))76 (mop:method-specializers method)))) 77 77 method) 78 78 -
trunk/abcl/src/org/armedbear/lisp/profiler.lisp
r12682 r13814 68 68 (dolist (method 69 69 (mop::generic-function-methods definition)) 70 (let ((function ( sys:%method-function method)))70 (let ((function (mop:method-function method))) 71 71 (setf full-count (sys:call-count function)) 72 72 (setf hot-count (sys:hot-count function))) … … 83 83 object) 84 84 ((typep object 'generic-function) 85 ( sys:%generic-function-name object))85 (mop:generic-function-name object)) 86 86 ((typep object 'method) 87 87 (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))))) 90 90 91 91 (defun object-compiled-function-p (object) … … 93 93 (compiled-function-p (fdefinition object))) 94 94 ((typep object 'method) 95 (compiled-function-p ( sys:%method-function object)))95 (compiled-function-p (mop:method-function object))) 96 96 (t 97 97 (compiled-function-p object))))
Note: See TracChangeset
for help on using the changeset viewer.