405 |
"methods matching the pattern: ~S" |
"methods matching the pattern: ~S" |
406 |
(car patterns)))) |
(car patterns)))) |
407 |
|
|
|
|
|
|
|
|
408 |
;;; |
;;; |
409 |
;;; This baby is a complete mess. I can't believe we put it in this |
;;; Return a form that deals with the :ARGUMENTS lambda-list of a long |
410 |
;;; way. No doubt this is a large part of what drives MLY crazy. |
;;; method combination. WRAPPED-BODY is the body of the method |
411 |
|
;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments |
412 |
|
;;; lambda-list of the method combination. |
413 |
;;; |
;;; |
414 |
;;; At runtime (when the effective-method is run), we bind an intercept |
(defun deal-with-arguments-option (wrapped-body arguments-lambda-list) |
415 |
;;; lambda-list to the arguments to the generic function. |
(let ((intercept-rebindings |
416 |
;;; |
(loop for arg in arguments-lambda-list |
417 |
;;; At compute-effective-method time, the symbols in the :arguments |
unless (memq arg lambda-list-keywords) |
418 |
;;; option are bound to the symbols in the intercept lambda list. |
collect `(,arg ',arg))) |
419 |
;;; |
(nreq 0) |
420 |
(defun deal-with-arguments-option (wrapped-body arguments-option) |
(nopt 0) |
421 |
(let* ((intercept-lambda-list |
whole) |
422 |
(gathering1 (collecting) |
;; |
423 |
(dolist (arg arguments-option) |
;; Count the number of required and optional parameters in |
424 |
(if (memq arg lambda-list-keywords) |
;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the |
425 |
(gather1 arg) |
;; name of a &WHOLE parameter, if any. |
426 |
(gather1 (gensym)))))) |
(loop with state = 'required |
427 |
(intercept-rebindings |
for arg in arguments-lambda-list do |
428 |
(gathering1 (collecting) |
(if (memq arg lambda-list-keywords) |
429 |
(iterate ((arg (list-elements arguments-option)) |
(setq state arg) |
430 |
(int (list-elements intercept-lambda-list))) |
(case state |
431 |
(unless (memq arg lambda-list-keywords) |
(required (incf nreq)) |
432 |
(gather1 `(,arg ',int))))))) |
(&optional (incf nopt)) |
433 |
;; |
(&whole (setq whole arg |
434 |
;; |
state 'required))))) |
435 |
(setf (cadr wrapped-body) |
;; |
436 |
(append intercept-rebindings (cadr wrapped-body))) |
;; This assumes that the WRAPPED-BODY is a let/let* form, and it |
437 |
;; |
;; injects let-bindings of the form (ARG 'SYM) for all variables |
438 |
;; Be sure to fill out the intercept lambda list so that it can |
;; of the argument-lambda-list; SYM is a gensym. |
439 |
;; be too short if it wants to. |
(assert (memq (first wrapped-body) '(let let*))) |
440 |
;; |
(setf (second wrapped-body) |
441 |
(cond ((memq '&rest intercept-lambda-list)) |
(append intercept-rebindings (second wrapped-body))) |
442 |
((memq '&allow-other-keys intercept-lambda-list)) |
;; |
443 |
((memq '&key intercept-lambda-list) |
;; Be sure to fill out the args lambda list so that it can be too |
444 |
(setq intercept-lambda-list |
;; short if it wants to. |
445 |
(append intercept-lambda-list '(&allow-other-keys)))) |
(unless (or (memq '&rest arguments-lambda-list) |
446 |
(t |
(memq '&allow-other-keys arguments-lambda-list)) |
447 |
(setq intercept-lambda-list |
(let ((aux (memq '&aux arguments-lambda-list))) |
448 |
(append intercept-lambda-list '(&rest .ignore.))))) |
(setq arguments-lambda-list |
449 |
|
(append (ldiff arguments-lambda-list aux) |
450 |
`(let ((inner-result. ,wrapped-body)) |
(if (memq '&key arguments-lambda-list) |
451 |
`(apply #'(lambda ,',intercept-lambda-list |
'(&allow-other-keys) |
452 |
,,(when (memq '.ignore. intercept-lambda-list) |
'(&rest .ignore.)) |
453 |
''(declare (ignore .ignore.))) |
aux)))) |
454 |
,inner-result.) |
;; |
455 |
.combined-method-args.)))) |
;; .GENERIC-FUNCTION. is bound to the generic function in the |
456 |
|
;; method combination function, and .GF-ARGS* is bound to the |
457 |
|
;; generic function arguments in effective method functions |
458 |
|
;; created for generic functions having a method combination that |
459 |
|
;; uses :ARGUMENTS. |
460 |
|
;; |
461 |
|
;; The DESTRUCTURING-BIND binds the parameters of the |
462 |
|
;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments. |
463 |
|
;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the |
464 |
|
;; generic function's lambda list, which is only known at run time, |
465 |
|
;; this destructuring has to be done on a slighly modified list of |
466 |
|
;; actual arguments, from which values might be stripped or added. |
467 |
|
;; |
468 |
|
;; Using one of the variable names in the body inserts a symbol |
469 |
|
;; into the effective method, and running the effective method |
470 |
|
;; produces the value of actual argument that is bound to the |
471 |
|
;; symbol. |
472 |
|
`(let ((inner-result. ,wrapped-body) |
473 |
|
(gf-lambda-list (generic-function-lambda-list .generic-function.))) |
474 |
|
`(destructuring-bind ,',arguments-lambda-list |
475 |
|
(frob-combined-method-args |
476 |
|
.gf-args. ',gf-lambda-list |
477 |
|
,',nreq ,',nopt) |
478 |
|
,,(when (memq '.ignore. arguments-lambda-list) |
479 |
|
''(declare (ignore .ignore.))) |
480 |
|
;; If there is a &WHOLE in the arguments-lambda-list, let |
481 |
|
;; it result in the actual arguments of the generic-function |
482 |
|
;; not the frobbed list. |
483 |
|
,,(when whole |
484 |
|
``(setq ,',whole .gf-args.)) |
485 |
|
,inner-result.)))) |
486 |
|
|
487 |
|
;;; |
488 |
|
;;; Partition VALUES into three sections required, optional, and the |
489 |
|
;;; rest, according to required, optional, and other parameters in |
490 |
|
;;; LAMBDA-LIST. Make the required and optional sections NREQ and |
491 |
|
;;; NOPT elements long by discarding values or adding NILs. Value is |
492 |
|
;;; the concatenated list of required and optional sections, and what |
493 |
|
;;; is left as rest from VALUES. |
494 |
|
;;; |
495 |
|
(defun frob-combined-method-args (values lambda-list nreq nopt) |
496 |
|
(loop with section = 'required |
497 |
|
for arg in lambda-list |
498 |
|
if (memq arg lambda-list-keywords) do |
499 |
|
(setq section arg) |
500 |
|
(unless (eq section '&optional) |
501 |
|
(loop-finish)) |
502 |
|
else if (eq section 'required) |
503 |
|
count t into nr |
504 |
|
and collect (pop values) into required |
505 |
|
else if (eq section '&optional) |
506 |
|
count t into no |
507 |
|
and collect (pop values) into optional |
508 |
|
finally |
509 |
|
(flet ((frob (list n m) |
510 |
|
(cond ((> n m) (butlast list (- n m))) |
511 |
|
((< n m) (nconc list (make-list (- m n)))) |
512 |
|
(t list)))) |
513 |
|
(return (nconc (frob required nr nreq) |
514 |
|
(frob optional no nopt) |
515 |
|
values))))) |