/[gcl]/gcl/pcl/pcl_defcombin.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_defcombin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by camm, Tue Oct 7 21:06:33 2003 UTC revision 1.3 by camm, Fri Oct 10 03:35:53 2003 UTC
# Line 405  Line 405 
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)))))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26