From 24ef6882fb811a77cc24df62db089a3840c0f1b2 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Fri, 3 Jan 2003 18:50:24 +0000 Subject: [PATCH] Entomotomy Bug: define-method-combination-arguments-broken Updated the fix for the broken handling of the :arguments option to define-method-combination to Gerd Moellmann's latest patch. Also includes various indentation fixes and a smallish documentation/comment fix. --- pcl/combin.lisp | 36 ++++++-- pcl/defcombin.lisp | 183 ++++++++++++++++--------------------- pcl/defs.lisp | 11 ++- pcl/generic-functions.lisp | 5 +- pcl/methods.lisp | 3 +- 5 files changed, 121 insertions(+), 117 deletions(-) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index 5e57beb30..2c11eb50f 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.12 2002/12/18 19:16:28 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.13 2003/01/03 18:50:23 pmai Exp $") ;;; (in-package :pcl) @@ -182,15 +182,30 @@ ;; which we define here to collect all gf arguments, to pass ;; those together with the GF to no-primary-method: ((eq (first effective-method) '%no-primary-method) - `(lambda (.pv-cell. .next-method-call. &rest .args.) - (declare (ignore .pv-cell. .next-method-call.)) - (flet ((%no-primary-method (gf) - (apply #'no-primary-method gf .args.))) - ,effective-method))) + `(lambda (.pv-cell. .next-method-call. &rest .args.) + (declare (ignore .pv-cell. .next-method-call.)) + (flet ((%no-primary-method (gf) + (apply #'no-primary-method gf .args.))) + ,effective-method))) + ;; When the method combination uses the :arguments option + ((and (eq *boot-state* 'complete) + ;; Otherwise the METHOD-COMBINATION slot is not bound. + (let ((combin (generic-function-method-combination gf))) + (and (long-method-combination-p combin) + (long-method-combination-arguments-lambda-list combin)))) + (let* ((required (dfun-arg-symbol-list metatypes)) + (gf-args (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + (let ((.gf-args. ,gf-args)) + (declare (ignorable .gf-args.)) + ,effective-method)))) (t - `(lambda ,ll - (declare (ignore .pv-cell. .next-method-call.)) - ,effective-method)))))) + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + ,effective-method)))))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) @@ -313,7 +328,8 @@ `(call-method-list ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) -(defun standard-compute-effective-method (generic-function combin applicable-methods) +(defun standard-compute-effective-method + (generic-function combin applicable-methods) (declare (ignore combin)) (let ((before ()) (primary ()) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 5c7857308..22fdecfe5 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.19 2003/01/02 13:11:57 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.20 2003/01/03 18:50:23 pmai Exp $") ;;; (in-package :pcl) @@ -219,17 +219,6 @@ ;;; ;;; -(defvar *combined-method-args*) -(defvar *generic-function*) - -(defclass long-method-combination (standard-method-combination) - ((function - :initarg :function - :reader long-method-combination-function) - (arguments-lambda-list - :initarg :arguments-lambda-list - :reader long-method-combination-arguments-lambda-list))) - (defun expand-long-defcombin (form) (let ((type (cadr form)) (lambda-list (caddr form)) @@ -284,23 +273,6 @@ (add-method #'find-method-combination new-method) type)) -(defmethod compute-discriminating-function :around - ((gf standard-generic-function)) - (let ((dfun (call-next-method))) - (if (let ((combin (generic-function-method-combination gf))) - (and (typep combin 'long-method-combination) - (long-method-combination-arguments-lambda-list combin))) - #'(kernel:instance-lambda (&rest args) - (let ((old (kernel:funcallable-instance-function gf)) - (*combined-method-args* args) - (*generic-function* gf)) - (unwind-protect - (progn - (set-funcallable-instance-function gf dfun) - (apply gf args)) - (set-funcallable-instance-function gf old)))) - dfun))) - (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) @@ -314,23 +286,22 @@ ;;; ;;; (defun make-long-method-combination-function - (type ll method-group-specifiers arguments-option gf-var body) - ;;(declare (values documentation function)) + (type ll method-group-specifiers arguments-option gf-var body) (declare (ignore type)) (multiple-value-bind (real-body declarations documentation) ;; Note that PARSE-BODY ignores its second arg ENVIRONMENT. (system:parse-body body nil) (let ((wrapped-body - (wrap-method-group-specifier-bindings method-group-specifiers - declarations - real-body))) + (wrap-method-group-specifier-bindings method-group-specifiers + declarations + real-body))) (when gf-var (push `(,gf-var .generic-function.) (cadr wrapped-body))) (when arguments-option - (setq wrapped-body (deal-with-arguments-option wrapped-body - arguments-option))) + (setq wrapped-body + (deal-with-arguments-option wrapped-body arguments-option))) (when ll (setq wrapped-body @@ -338,10 +309,11 @@ (method-combination-options .method-combination.)))) (values - documentation - `(lambda (.generic-function. .method-combination. .applicable-methods.) - (progn .generic-function. .method-combination. .applicable-methods.) - (block .long-method-combination-function. ,wrapped-body)))))) + documentation + `(lambda (.generic-function. .method-combination. .applicable-methods.) + (declare (ignorable .generic-function. .method-combination. + .applicable-methods.)) + (block .long-method-combination-function. ,wrapped-body)))))) ;; ;; parse-method-group-specifiers parse the method-group-specifiers ;; @@ -448,33 +420,34 @@ ;;; -;;; This baby is a complete mess. I can't believe we put it in this -;;; way. No doubt this is a large part of what drives MLY crazy. -;;; -;;; At runtime (when the effective-method is run), we bind an intercept -;;; lambda-list to the arguments to the generic function. -;;; -;;; At compute-effective-method time, the symbols in the :arguments -;;; option are bound to the symbols in the intercept lambda list. +;;; Return a form that deals with the :ARGUMENTS lambda-list of a long +;;; method combination. WRAPPED-BODY is the body of the method +;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments +;;; lambda-list of the method combination. ;;; -(defun deal-with-arguments-option (wrapped-body args-lambda-list) +(defun deal-with-arguments-option (wrapped-body arguments-lambda-list) (let ((intercept-rebindings - (loop for arg in args-lambda-list + (loop for arg in arguments-lambda-list unless (memq arg lambda-list-keywords) collect `(,arg ',arg))) (nreq 0) (nopt 0) whole) + ;; + ;; Count the number of required and optional parameters in + ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the + ;; name of a &WHOLE parameter, if any. (loop with state = 'required - for arg in args-lambda-list do + for arg in arguments-lambda-list do (if (memq arg lambda-list-keywords) (setq state arg) (case state (required (incf nreq)) (&optional (incf nopt)) - (&whole (setq whole arg))))) + (&whole (setq whole arg + state 'required))))) ;; - ;; This assumes that the cadr of the WRAPPED-BODY is a let, and it + ;; This assumes that the WRAPPED-BODY is a let/let* form, and it ;; injects let-bindings of the form (ARG 'SYM) for all variables ;; of the argument-lambda-list; SYM is a gensym. (assert (memq (first wrapped-body) '(let let*))) @@ -483,72 +456,74 @@ ;; ;; Be sure to fill out the args lambda list so that it can be too ;; short if it wants to. - (unless (or (memq '&rest args-lambda-list) - (memq '&allow-other-keys args-lambda-list)) - (let ((aux (memq '&aux args-lambda-list))) - (setq args-lambda-list - (append (ldiff args-lambda-list aux) - (if (memq '&key args-lambda-list) + (unless (or (memq '&rest arguments-lambda-list) + (memq '&allow-other-keys arguments-lambda-list)) + (let ((aux (memq '&aux arguments-lambda-list))) + (setq arguments-lambda-list + (append (ldiff arguments-lambda-list aux) + (if (memq '&key arguments-lambda-list) '(&allow-other-keys) '(&rest .ignore.)) aux)))) - ;; - ;; the DESTRUCTURING-BIND binds the parameters of the - ;; ARGS-LAMBDA-LIST to actual generic function arguments. - ;; *COMBINEND-METHOD-ARGS* is bound to the generic function - ;; arguments by the discriminating functions created for generic - ;; functions having a method combination that uses :ARGUMENTS. + ;; .GENERIC-FUNCTION. is bound to the generic function in the + ;; method combination function, and .GF-ARGS* is bound to the + ;; generic function arguments in effective method functions + ;; created for generic functions having a method combination that + ;; uses :ARGUMENTS. + ;; + ;; The DESTRUCTURING-BIND binds the parameters of the + ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments. + ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the + ;; generic function's lambda list, which is only known at run time, + ;; this destructuring has to be done on a slighly modified list of + ;; actual arguments, from which values might be stripped or added. ;; ;; Using one of the variable names in the body inserts a symbol ;; into the effective method, and running the effective method ;; produces the value of actual argument that is bound to the ;; symbol. - `(let ((inner-result. ,wrapped-body)) - `(destructuring-bind ,',args-lambda-list - (frob-args *combined-method-args* - (generic-function-lambda-list *generic-function*) - ,',nreq ,',nopt) - ,,(when (memq '.ignore. args-lambda-list) - ''(declare (ignore .ignore.))) - ;; If there is a &WHOLE in the args-lambda-list, let - ;; it result in the actual arguments of the generic-function - ;; not the frobbed list. - ,,(when whole - ``(setq ,',whole *combined-method-args*)) - ,inner-result.)))) + `(let ((inner-result. ,wrapped-body) + (gf-lambda-list (generic-function-lambda-list .generic-function.))) + `(destructuring-bind ,',arguments-lambda-list + (frob-combined-method-args + .gf-args. ',gf-lambda-list + ,',nreq ,',nopt) + ,,(when (memq '.ignore. arguments-lambda-list) + ''(declare (ignore .ignore.))) + ;; If there is a &WHOLE in the arguments-lambda-list, let + ;; it result in the actual arguments of the generic-function + ;; not the frobbed list. + ,,(when whole + ``(setq ,',whole .gf-args.)) + ,inner-result.)))) ;;; ;;; Partition VALUES into three sections required, optional, and the ;;; rest, according to required, optional, and other parameters in ;;; LAMBDA-LIST. Make the required and optional sections NREQ and ;;; NOPT elements long by discarding values or adding NILs. Value is -;;; the concatenated list of required and optional sections, plus what +;;; the concatenated list of required and optional sections, and what ;;; is left as rest from VALUES. ;;; -(defun frob-args (values lambda-list nreq nopt) +(defun frob-combined-method-args (values lambda-list nreq nopt) (loop with section = 'required - with required = () and optional = () - with nr = 0 and no = 0 - for arg in lambda-list do - (if (member arg lambda-list-keywords :test #'eq) - (unless (eq (setq section arg) '&optional) - (loop-finish)) - (case section - (required - (incf nr) - (push (pop values) required)) - (&optional - (incf no) - (push (pop values) optional)))) - finally - (flet ((frob (list n to) - (cond ((> n to) - (butlast (nreverse list) (- n to))) - ((< n to) - (nconc (nreverse list) (make-list (- to n)))) - (t - (nreverse list))))) - (return (append (frob required nr nreq) - (frob optional no nopt) - values))))) + for arg in lambda-list + if (memq arg lambda-list-keywords) do + (setq section arg) + (unless (eq section '&optional) + (loop-finish)) + else if (eq section 'required) + count t into nr + and collect (pop values) into required + else if (eq section '&optional) + count t into no + and collect (pop values) into optional + finally + (flet ((frob (list n m) + (cond ((> n m) (butlast list (- n m))) + ((< n m) (nconc list (make-list (- m n)))) + (t list)))) + (return (nconc (frob required nr nreq) + (frob optional no nopt) + values))))) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 97a3d8dd5..7cc2eea01 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -740,6 +740,14 @@ (options :reader method-combination-options :initarg :options))) +(defclass long-method-combination (standard-method-combination) + ((function + :initarg :function + :reader long-method-combination-function) + (arguments-lambda-list + :initarg :arguments-lambda-list + :reader long-method-combination-arguments-lambda-list))) + (defparameter *early-class-predicates* '((specializer specializerp) (exact-class-specializer exact-class-specializer-p) @@ -760,5 +768,6 @@ (standard-boundp-method standard-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) - (method-combination method-combination-p))) + (method-combination method-combination-p) + (long-method-combination long-method-combination-p))) diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index 5f7705c7c..74229192e 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -2,7 +2,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.16 2002/12/18 19:16:28 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.17 2003/01/03 18:50:23 pmai Exp $") ;;; (in-package :pcl) @@ -51,6 +51,9 @@ ; (short-method-combination) ; (t) +(defgeneric long-method-combination-p (object)) +; (long-method-combination) +; (t) (defgeneric slot-class-p (object)) ; (t) ; (slot-class) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index ca7d167df..8e54412ac 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -1,3 +1,4 @@ + ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* @@ -26,7 +27,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.21 2002/12/22 14:09:51 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.22 2003/01/03 18:50:24 pmai Exp $") ;;; (in-package :pcl) -- GitLab