From a96eb725c8b9082a576d2ea51a42cdc31fde3ea0 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 19 Nov 2002 16:00:19 +0000 Subject: [PATCH] 0.7.9.57: DEFINE-METHOD-COMBINATION now works with the :ARGUMENTS option (more or less as per Gerd Moellmann cmucl-imp 2002-10-19) ... extra slot, extra logic; ... test from CLHS DEFINE-METHOD-COMBINATION page. --- NEWS | 19 +++--- src/pcl/combin.lisp | 25 ++++++-- src/pcl/defcombin.lisp | 158 ++++++++++++++++++++++++++++++++++-------------- src/pcl/defs.lisp | 11 +++- tests/clos.impure.lisp | 36 ++++++++++- version.lisp-expr | 2 +- 6 files changed, 190 insertions(+), 61 deletions(-) diff --git a/NEWS b/NEWS index 0ab4e51..09cfa7f 100644 --- a/NEWS +++ b/NEWS @@ -1376,28 +1376,29 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: ** COMPUTE-SLOTS :AROUND now assigns locations sequentially based on the order returned by the primary method for classes of class STANDARD-CLASS; + ** DEFINE-METHOD-COMBINATION now works with the :ARGUMENTS option. * fixed some bugs shown by Paul Dietz' test suite: - ** DOLIST puts its body in TAGBODY + ** DOLIST puts its body in TAGBODY; ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the - correct order + correct order; ** MULTIPLE-VALUE-SETQ evaluates side-effectful places before - value producing form + value producing form; ** if more variables are given to PROGV than values, extra - variables are bound and made to have no value + variables are bound and made to have no value; ** NSUBSTITUTE on list arguments gets the right answer with - :FROM-END + :FROM-END; ** ELT signals an error of type TYPE-ERROR when the index argument is not a valid sequence index; ** LOOP signals (at macroexpansion time) an error of type PROGRAM-ERROR when duplicate variable names are found; - ** LOOP supports DOWNTO and ABOVE properly (thanks to Matthew Danish) + ** LOOP supports DOWNTO and ABOVE properly; (thanks to Matthew Danish) ** FUNCALL of special-operators now cause an error of type UNDEFINED-FUNCTION; ** PSETQ now works as required in the presence of side-effecting symbol-macro places; - ** NCONC accepts any object as its last argument - ** :COUNT argument to sequence functions may be BIGNUM (thanks to - Gerd Moellman); + ** NCONC accepts any object as its last argument; + ** :COUNT argument to sequence functions may be BIGNUM; (thanks to + Gerd Moellman) ** Loop-package does not require a package to be explicitely specified; * fixed bug 166: compiler preserves "there is a way to go" diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index bb04d62..5be842e 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -174,10 +174,13 @@ (get-generic-fun-info gf) (declare (ignore nreq nkeys arg-info)) (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) - ;; When there are no primary methods and a next-method call occurs - ;; effective-method is (error "No mumble..") and the defined - ;; args are not used giving a compiler warning. - (error-p (eq (first effective-method) '%no-primary-method))) + (error-p (eq (first effective-method) '%no-primary-method)) + (mc-args-p + (when (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-args-lambda-list combin)))))) (cond (error-p `(lambda (.pv-cell. .next-method-call. &rest .args.) @@ -185,6 +188,20 @@ (flet ((%no-primary-method (gf args) (apply #'no-primary-method gf args))) ,effective-method))) + (mc-args-p + (let* ((required + ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp + (let (req) + (dotimes (i (length metatypes) (nreverse req)) + (push (dfun-arg-symbol i) req)))) + (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 ,@(if error-p ll '(.pv-cell. .next-method-call.)))) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 56d0759..7975e13 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -54,12 +54,12 @@ ;;;; and runs the same rule. (defclass short-method-combination (standard-method-combination) - ((operator - :reader short-combination-operator - :initarg :operator) - (identity-with-one-argument - :reader short-combination-identity-with-one-argument - :initarg :identity-with-one-argument)) + ((operator + :reader short-combination-operator + :initarg :operator) + (identity-with-one-argument + :reader short-combination-identity-with-one-argument + :initarg :identity-with-one-argument)) (:predicate-name short-method-combination-p)) (defun expand-short-defcombin (whole) @@ -170,10 +170,6 @@ ;;;; long method combinations -(defclass long-method-combination (standard-method-combination) - ((function :initarg :function - :reader long-method-combination-function))) - (defun expand-long-defcombin (form) (let ((type (cadr form)) (lambda-list (caddr form)) @@ -189,11 +185,12 @@ (make-long-method-combination-function type lambda-list method-group-specifiers args-option gf-var body) - `(load-long-defcombin ',type ',documentation #',function)))) + `(load-long-defcombin ',type ',documentation #',function + ',args-option)))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) -(defun load-long-defcombin (type doc function) +(defun load-long-defcombin (type doc function args-lambda-list) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -213,6 +210,7 @@ (make-instance 'long-method-combination :type type :options options + :args-lambda-list args-lambda-list :documentation doc)) args)) :definition-source `((define-method-combination ,type) @@ -256,7 +254,8 @@ (values documentation `(lambda (.generic-function. .method-combination. .applicable-methods.) - (progn .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 @@ -372,36 +371,105 @@ ;;; ;;; At compute-effective-method time, the symbols in the :arguments ;;; option are bound to the symbols in the intercept lambda list. -(defun deal-with-args-option (wrapped-body args-option) - (let* ((intercept-lambda-list - (let (collect) - (dolist (arg args-option) - (if (memq arg lambda-list-keywords) - (push arg collect) - (push (gensym) collect))) - (nreverse collect))) - (intercept-rebindings - (loop for arg in args-option - for int in intercept-lambda-list - unless (memq arg lambda-list-keywords) - collect `(,arg ',int)))) - (setf (cadr wrapped-body) - (append intercept-rebindings (cadr wrapped-body))) - - ;; Be sure to fill out the intercept lambda list so that it can - ;; be too short if it wants to. - (cond ((memq '&rest intercept-lambda-list)) - ((memq '&allow-other-keys intercept-lambda-list)) - ((memq '&key intercept-lambda-list) - (setq intercept-lambda-list - (append intercept-lambda-list '(&allow-other-keys)))) - (t - (setq intercept-lambda-list - (append intercept-lambda-list '(&rest .ignore.))))) +(defun deal-with-args-option (wrapped-body args-lambda-list) + (let ((intercept-rebindings + (let (rebindings) + (dolist (arg args-lambda-list (nreverse rebindings)) + (unless (member arg lambda-list-keywords) + (push `(,arg ',arg) rebindings))))) + (nreq 0) + (nopt 0) + (whole nil)) + ;; Count the number of required and optional parameters in + ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the + ;; name of a &WHOLE parameter, if any. + (when (member '&whole (rest args-lambda-list)) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list args-lambda-list))) + (loop with state = 'required + for arg in args-lambda-list do + (if (memq arg lambda-list-keywords) + (setq state arg) + (case state + (required (incf nreq)) + (&optional (incf nopt)) + (&whole (setq whole arg state 'required))))) + ;; This assumes that the head of WRAPPED-BODY is a let, and it + ;; injects let-bindings of the form (ARG 'SYM) for all variables + ;; of the argument-lambda-list; SYM is a gensym. + (aver (memq (first wrapped-body) '(let let*))) + (setf (second wrapped-body) + (append intercept-rebindings (second wrapped-body))) + ;; 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) + '(&allow-other-keys) + '(&rest .ignore.)) + aux)))) + ;; .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 + ;; ARGS-LAMBDA-LIST to actual generic function arguments. Because + ;; ARGS-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) + (gf-lambda-list (generic-function-lambda-list .generic-function.))) + `(destructuring-bind ,',args-lambda-list + (frob-combined-method-args + .gf-args. ',gf-lambda-list + ,',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 .gf-args.)) + ,inner-result.)))) - `(let ((inner-result. ,wrapped-body)) - `(apply #'(lambda ,',intercept-lambda-list - ,,(when (memq '.ignore. intercept-lambda-list) - ''(declare (ignore .ignore.))) - ,inner-result.) - .combined-method-args.)))) +;;; 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, and what +;;; is left as rest from VALUES. +(defun frob-combined-method-args (values lambda-list nreq nopt) + (loop with section = 'required + 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))))) \ No newline at end of file diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index fe77969..02f7edc 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -804,6 +804,14 @@ :reader method-combination-options :initarg :options))) +(defclass long-method-combination (standard-method-combination) + ((function + :initarg :function + :reader long-method-combination-function) + (args-lambda-list + :initarg :args-lambda-list + :reader long-method-combination-args-lambda-list))) + (defparameter *early-class-predicates* '((specializer specializerp) (exact-class-specializer exact-class-specializer-p) @@ -824,5 +832,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/tests/clos.impure.lisp b/tests/clos.impure.lisp index bd46fa1..7b80f6b 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -444,6 +444,40 @@ (call-next-method))) (assert (= (call-next-method-lexical-args 3) 3)) +;;; DEFINE-METHOD-COMBINATION with arguments was hopelessly broken +;;; until 0.7.9.5x +(defvar *d-m-c-args-test* nil) +(define-method-combination progn-with-lock () + ((methods ())) + (:arguments object) + `(unwind-protect + (progn (lock (object-lock ,object)) + ,@(mapcar #'(lambda (method) + `(call-method ,method)) + methods)) + (unlock (object-lock ,object)))) +(defun object-lock (obj) + (push "object-lock" *d-m-c-args-test*) + obj) +(defun unlock (obj) + (push "unlock" *d-m-c-args-test*) + obj) +(defun lock (obj) + (push "lock" *d-m-c-args-test*) + obj) +(defgeneric d-m-c-args-test (x) + (:method-combination progn-with-lock)) +(defmethod d-m-c-args-test ((x symbol)) + (push "primary" *d-m-c-args-test*)) +(defmethod d-m-c-args-test ((x number)) + (error "foo")) +(assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock"))) +(assert (equal *d-m-c-args-test* + '("unlock" "object-lock" "primary" "lock" "object-lock"))) +(setf *d-m-c-args-test* nil) +(ignore-errors (d-m-c-args-test 1)) +(assert (equal *d-m-c-args-test* + '("unlock" "object-lock" "lock" "object-lock"))) + ;;;; success - (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index fc037a8..1dcebb6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.56" +"0.7.9.57" -- 1.7.10.4