Changeset 13983
- Timestamp:
- 06/24/12 11:04:25 (9 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
r13956 r13983 775 775 new SlotDefinition(Symbol._DOCUMENTATION, 776 776 list(Symbol.METHOD_COMBINATION_DOCUMENTATION), 777 constantlyNil, list(internKeyword("DOCUMENTATION"))))); 777 constantlyNil, list(internKeyword("DOCUMENTATION"))), 778 new SlotDefinition(PACKAGE_MOP.intern("OPTIONS"), 779 NIL, constantlyNil, 780 list(internKeyword("OPTIONS"))))); 778 781 SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION, 779 782 METHOD_COMBINATION, METAOBJECT, -
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
r13970 r13983 63 63 StandardClass.STANDARD_METHOD; 64 64 slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = 65 Symbol.STANDARD; 65 Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp 66 66 slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = 67 67 NIL; … … 113 113 StandardClass.STANDARD_METHOD; 114 114 slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = 115 Symbol.STANDARD; 115 Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp 116 116 slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = 117 117 NIL; -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13980 r13983 185 185 ;; Make the result of class-direct-subclasses for the pre-built 186 186 ;; classes agree with AMOP Table 5.1 (pg. 141). This could be done in 187 ;; StandardClass.java where these classes are defined, but here it's188 ;; less painful187 ;; StandardClass.java where these classes are defined, but it's less 188 ;; painful to do it Lisp-side. 189 189 (flet ((add-subclasses (class subclasses) 190 190 (when (atom subclasses) (setf subclasses (list subclasses))) … … 198 198 '(generic-function method method-combination 199 199 slot-definition specializer)) 200 (add-subclasses 'method-combination 201 '(long-method-combination short-method-combination)) 200 202 (add-subclasses 'funcallable-standard-object 'generic-function) 201 203 (add-subclasses 'generic-function 'standard-generic-function) … … 912 914 (setf (std-slot-value instance 'declarations) declarations) 913 915 (setf (std-slot-value instance 'forms) forms) 916 (setf (std-slot-value instance 'options) nil) 914 917 instance)) 915 918 … … 980 983 (setf (std-slot-value instance 'identity-with-one-argument) 981 984 ',identity-with-one-arg) 985 (setf (std-slot-value instance 'options) nil) 982 986 (setf (get ',name 'method-combination-object) instance) 983 987 ',name)))) … … 1002 1006 ;;; long form of define-method-combination (from Sacla and XCL) 1003 1007 ;;; 1004 (defun define-method-combination-type (name &rest initargs)1005 (setf (get name 'method-combination-object)1006 (apply '%make-long-method-combination initargs)))1007 1008 1008 (defun method-group-p (selecter qualifiers) 1009 1009 ;; selecter::= qualifier-pattern | predicate … … 1285 1285 ,@(long-form-method-combination-args args))) 1286 1286 (lambda-expression (apply #'method-combination-type-lambda initargs))) 1287 (apply #'define-method-combination-type name 1288 `(,@initargs 1289 ;; :function ,(compile nil lambda-expression) 1290 :function ,(coerce-to-function lambda-expression))) 1287 (setf (get name 'method-combination-object) 1288 (apply '%make-long-method-combination 1289 :function (coerce-to-function lambda-expression) initargs)) 1291 1290 name)) 1291 1292 (defun std-find-method-combination (gf name options) 1293 (declare (ignore gf)) 1294 (when (and (eql name 'standard) options) 1295 ;; CLHS DEFGENERIC 1296 (error "The standard method combination does not accept any arguments.")) 1297 (let ((mc (get name 'method-combination-object))) 1298 (cond 1299 ((null mc) (error "Method combination ~S not found" name)) 1300 ((null options) mc) 1301 ((typep mc 'short-method-combination) 1302 (make-instance 1303 'short-method-combination 1304 :name name 1305 :documentation (method-combination-documentation mc) 1306 :operator (short-method-combination-operator mc) 1307 :identity-with-one-argument 1308 (short-method-combination-identity-with-one-argument mc) 1309 :options options)) 1310 ((typep mc 'long-method-combination) 1311 (make-instance 1312 'long-method-combination 1313 :name name 1314 :documentation (method-combination-documentation mc) 1315 :lambda-list (long-method-combination-lambda-list mc) 1316 :method-group-specs (long-method-combination-method-group-specs mc) 1317 :args-lambda-list (long-method-combination-args-lambda-list mc) 1318 :generic-function-symbol (long-method-combination-generic-function-symbol mc) 1319 :function (long-method-combination-function mc) 1320 :arguments (long-method-combination-arguments mc) 1321 :declarations (long-method-combination-declarations mc) 1322 :forms (long-method-combination-forms mc) 1323 :options options))))) 1324 1325 (declaim (notinline find-method-combination)) 1326 (defun find-method-combination (gf name options) 1327 (std-find-method-combination gf name options)) 1328 1329 (defconstant +the-standard-method-combination+ 1330 (let ((instance (std-allocate-instance (find-class 'method-combination)))) 1331 (setf (std-slot-value instance 'sys::name) 'standard) 1332 (setf (std-slot-value instance 'sys:%documentation) 1333 "The standard method combination.") 1334 (setf (std-slot-value instance 'options) nil) 1335 instance) 1336 "The standard method combination. 1337 Do not use this object for identity since it changes between 1338 compile-time and run-time. To detect the standard method combination, 1339 compare the method combination name to the symbol 'standard.") 1340 (setf (get 'standard 'method-combination-object) +the-standard-method-combination+) 1292 1341 1293 1342 (defparameter *eql-specializer-table* (make-hash-table :test 'eql)) … … 1385 1434 (sys:%generic-function-method-combination gf)) 1386 1435 (defun (setf generic-function-method-combination) (new-value gf) 1436 (assert (typep new-value 'method-combination)) 1387 1437 (set-generic-function-method-combination gf new-value)) 1388 1438 … … 1535 1585 (generic-function-class +the-standard-generic-function-class+) 1536 1586 (method-class +the-standard-method-class+) 1537 (method-combination 'standard)1587 (method-combination +the-standard-method-combination+ mc-p) 1538 1588 argument-precedence-order 1539 1589 documentation … … 1567 1617 :format-control "~A already names an ordinary function, macro, or special operator." 1568 1618 :format-arguments (list function-name))) 1619 (when mc-p 1620 (error "Preliminary ensure-method does not support :method-combination argument.")) 1569 1621 (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+) 1570 1622 #'make-instance-standard-generic-function … … 1983 2035 1984 2036 (defun fast-callable-p (gf) 1985 (and (eq (generic-function-method-combination gf) 'standard) 2037 (and (eq (method-combination-name (generic-function-method-combination gf)) 2038 'standard) 1986 2039 (null (intersection (%generic-function-lambda-list gf) 1987 2040 '(&rest &optional &key &allow-other-keys &aux))))) … … 2042 2095 ((= number-required 1) 2043 2096 (cond 2044 ((and (eq ( sys:%generic-function-method-combination gf) 'standard)2097 ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard) 2045 2098 (= (length (sys:%generic-function-methods gf)) 1)) 2046 2099 (let* ((method (%car (sys:%generic-function-methods gf))) … … 2319 2372 next-method-list)) 2320 2373 2321 (defun std-compute-effective-method (gf mc methods) 2322 (let* ((mc-name (if (atom mc) mc (%car mc))) 2323 (options (if (atom mc) '() (%cdr mc))) 2374 (defun std-compute-effective-method (gf method-combination methods) 2375 (assert (typep method-combination 'method-combination)) 2376 (let* ((mc-name (method-combination-name method-combination)) 2377 (options (slot-value method-combination 'options)) 2324 2378 (order (car options)) 2325 2379 (primaries '()) … … 2328 2382 emf-form 2329 2383 (long-method-combination-p 2330 (typep (get mc-name 'method-combination-object)'long-method-combination)))2384 (typep method-combination 'long-method-combination))) 2331 2385 (unless long-method-combination-p 2332 2386 (dolist (m methods) … … 2335 2389 (if (eq mc-name 'standard) 2336 2390 (push m primaries) 2337 (error "Method combination type mismatch .")))2391 (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination))) 2338 2392 ((cdr qualifiers) 2339 2393 (error "Invalid method qualifiers.")) … … 2358 2412 #'std-compute-effective-method 2359 2413 #'compute-effective-method) 2360 gf (generic-function-method-combination gf) 2361 (remove around methods)))) 2414 gf method-combination (remove around methods)))) 2362 2415 (setf emf-form 2363 (generate-emf-lambda ( std-method-function around) next-emfun))))2416 (generate-emf-lambda (method-function around) next-emfun)))) 2364 2417 ((eq mc-name 'standard) 2365 2418 (let* ((next-emfun (compute-primary-emfun (cdr primaries))) … … 2384 2437 next-emfun)))) 2385 2438 (t 2386 (let ((method-function ( std-method-function (car primaries))))2439 (let ((method-function (method-function (car primaries)))) 2387 2440 #'(lambda (args) 2388 2441 (declare (optimize speed)) 2389 2442 (dolist (before befores) 2390 (funcall ( std-method-function before) args nil))2443 (funcall (method-function before) args nil)) 2391 2444 (multiple-value-prog1 2392 2445 (funcall method-function args next-emfun) 2393 2446 (dolist (after reverse-afters) 2394 (funcall ( std-method-function after) args nil))))))))))2447 (funcall (method-function after) args nil)))))))))) 2395 2448 (long-method-combination-p 2396 (let* ((mc-obj (get mc-name 'method-combination-object)) 2397 (function (long-method-combination-function mc-obj)) 2398 (arguments (rest (slot-value gf 'method-combination)))) 2399 (assert (typep mc-obj 'long-method-combination)) 2449 (let ((function (long-method-combination-function method-combination)) 2450 (arguments (slot-value method-combination 'options))) 2400 2451 (assert function) 2401 2452 (setf emf-form … … 2404 2455 (funcall function gf methods))))) 2405 2456 (t 2406 (let ((mc-obj (get mc-name 'method-combination-object))) 2407 (unless (typep mc-obj 'short-method-combination) 2408 (error "Unsupported method combination type ~A." 2409 mc-name)) 2410 (let* ((operator (short-method-combination-operator mc-obj)) 2411 (ioa (short-method-combination-identity-with-one-argument mc-obj))) 2412 (setf emf-form 2413 (if (and (null (cdr primaries)) 2414 (not (null ioa))) 2415 (generate-emf-lambda (std-method-function (car primaries)) nil) 2416 `(lambda (args) 2417 (,operator ,@(mapcar 2418 (lambda (primary) 2419 `(funcall ,(std-method-function primary) args nil)) 2420 primaries))))))))) 2457 (unless (typep method-combination 'short-method-combination) 2458 (error "Unsupported method combination type ~A." mc-name)) 2459 (let ((operator (short-method-combination-operator method-combination)) 2460 (ioa (short-method-combination-identity-with-one-argument method-combination))) 2461 (setf emf-form 2462 (if (and ioa (null (cdr primaries))) 2463 (generate-emf-lambda (method-function (car primaries)) nil) 2464 `(lambda (args) 2465 (,operator ,@(mapcar 2466 (lambda (primary) 2467 `(funcall ,(method-function primary) args nil)) 2468 primaries)))))))) 2421 2469 (assert (not (null emf-form))) 2422 2470 (or #+nil (ignore-errors (autocompile emf-form)) … … 4066 4114 (set-generic-function-argument-precedence-order 4067 4115 instance (or argument-precedence-order required-args))) 4116 (when (eq (generic-function-method-combination instance) 'standard) 4117 ;; fix up "naked" (make-instance 'standard-generic-function) -- gfs 4118 ;; created via defgeneric have that slot initalized properly 4119 (set-generic-function-method-combination instance 4120 +the-standard-method-combination+)) 4068 4121 (finalize-standard-generic-function instance)) 4069 4122 … … 4129 4182 (:method ((method standard-accessor-method)) 4130 4183 (std-accessor-method-slot-definition method))) 4184 4185 4186 ;;; find-method-combination 4187 4188 ;;; AMOP pg. 191 4189 (atomic-defgeneric find-method-combination (gf name options) 4190 (:method (gf (name symbol) options) 4191 (std-find-method-combination gf name options))) 4131 4192 4132 4193 ;;; specializer-direct-method and friends. … … 4227 4288 lambda-list 4228 4289 (method-class +the-standard-method-class+) 4290 (method-combination +the-standard-method-combination+) 4229 4291 &allow-other-keys) 4230 4292 (setf all-keys (copy-list all-keys)) ; since we modify it … … 4244 4306 (error "The method class ~S is incompatible with the existing methods of ~S." 4245 4307 method-class generic-function)) 4308 (unless (typep method-combination 'method-combination) 4309 (setf method-combination 4310 (find-method-combination generic-function 4311 (car method-combination) 4312 (cdr method-combination)))) 4246 4313 (apply #'reinitialize-instance generic-function 4247 :method-class method-class all-keys) 4314 :method-combination method-combination 4315 :method-class method-class 4316 all-keys) 4248 4317 generic-function) 4249 4318 … … 4253 4322 &key (generic-function-class +the-standard-generic-function-class+) 4254 4323 (method-class +the-standard-method-class+) 4255 (method-combination 'standard)4324 (method-combination +the-standard-method-combination+) 4256 4325 &allow-other-keys) 4257 4326 (setf all-keys (copy-list all-keys)) ; since we modify it … … 4260 4329 (setf generic-function-class (find-class generic-function-class))) 4261 4330 (unless (classp method-class) (setf method-class (find-class method-class))) 4331 (unless (typep method-combination 'method-combination) 4332 (setf method-combination 4333 (find-method-combination (class-prototype generic-function-class) 4334 (car method-combination) 4335 (cdr method-combination)))) 4262 4336 (when (and (null *clos-booting*) (fboundp function-name)) 4263 4337 (if (autoloadp function-name) -
trunk/abcl/src/org/armedbear/lisp/mop.lisp
r13979 r13983 122 122 remove-direct-method 123 123 124 find-method-combination 125 124 126 extract-lambda-list 125 127 extract-specializer-names -
trunk/abcl/src/org/armedbear/lisp/print-object.lisp
r13930 r13983 75 75 method) 76 76 77 (defmethod print-object ((method-combination method-combination) stream) 78 (print-unreadable-object (method-combination stream :identity t) 79 (format stream "~A ~S" (class-name (class-of method-combination)) 80 (mop::method-combination-name method-combination))) 81 method-combination) 82 77 83 (defmethod print-object ((restart restart) stream) 78 84 (if *print-escape*
Note: See TracChangeset
for help on using the changeset viewer.