diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index f39f5c2902725d82349d5efad7f70969d68a80e3..aba56c8085ae162cfd845c04caf0c23f4d1631eb 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.16 2002/09/09 16:48:45 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.17 2002/10/19 01:19:30 pmai Exp $") ;;; (in-package :pcl) @@ -218,9 +218,16 @@ ;;; ;;; +(defvar *combined-method-args*) +(defvar *generic-function*) + (defclass long-method-combination (standard-method-combination) - ((function :initarg :function - :reader long-method-combination-function))) + ((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)) @@ -238,12 +245,13 @@ type lambda-list method-group-specifiers arguments-option gf-var body) (make-top-level-form `(define-method-combination ,type) - '(load eval) - `(load-long-defcombin ',type ',documentation #',function))))) + '(:load-toplevel :execute) + `(load-long-defcombin ',type ',documentation #',function + ',arguments-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 arguments-lambda-list) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -263,6 +271,9 @@ (make-instance 'long-method-combination :type type :options options + :function function + :arguments-lambda-list + arguments-lambda-list :documentation doc)) args)) :definition-source `((define-method-combination ,type) @@ -271,6 +282,23 @@ (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method))) +(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) @@ -331,7 +359,8 @@ (push name names) (push specializer-cache specializer-caches) (push `((or ,@tests) - (if (equal ,specializer-cache .specializers.) + (if (and (equal ,specializer-cache .specializers.) + (not (null .specializers.))) (return-from .long-method-combination-function. '(error "More than one method of type ~S ~ with the same specializers." @@ -361,7 +390,7 @@ (dolist (.method. .applicable-methods.) (let ((.qualifiers. (method-qualifiers .method.)) (.specializers. (method-specializers .method.))) - (progn .qualifiers. .specializers.) + (declare (ignorable .qualifiers. .specializers.)) (cond ,@(nreverse cond-clauses)))) ,@(nreverse required-checks) ,@(nreverse order-cleanups) @@ -369,22 +398,20 @@ (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) - (loop - with name = (pop method-group-specifier) - for pattern = (pop method-group-specifier) - until (null pattern) - until (memq pattern '(:description :order :required)) - collect pattern into patterns - collect (parse-qualifier-pattern name pattern) into tests - finally - (return - (values name - tests - (getf method-group-specifier :description - (make-default-method-group-description - (nreverse patterns))) - (getf method-group-specifier :order :most-specific-first) - (getf method-group-specifier :required nil))))) + (loop with name = (pop method-group-specifier) + for rest on method-group-specifier + for pattern = (car rest) + until (memq pattern '(:description :order :required)) + collect pattern into patterns + collect (parse-qualifier-pattern name pattern) into tests + finally + (return (values name + tests + (getf rest :description + (make-default-method-group-description + (nreverse patterns))) + (getf rest :order :most-specific-first) + (getf rest :required nil))))) (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) @@ -428,39 +455,98 @@ ;;; At compute-effective-method time, the symbols in the :arguments ;;; option are bound to the symbols in the intercept lambda list. ;;; -(defun deal-with-arguments-option (wrapped-body arguments-option) - (let* ((intercept-lambda-list - (loop for arg in arguments-option - collect (if (memq arg lambda-list-keywords) - arg - (gensym)))) - (intercept-rebindings - (loop for arg in arguments-option - and int in intercept-lambda-list - unless (memq arg lambda-list-keywords) - collect `(,arg ',int)))) +(defun deal-with-arguments-option (wrapped-body args-lambda-list) + (let ((intercept-rebindings + (loop for arg in args-lambda-list + unless (memq arg lambda-list-keywords) + collect `(,arg ',arg))) + (nreq 0) + (nopt 0) + whole) + (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))))) ;; + ;; This assumes that the cadr of the 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. + (assert (memq (first wrapped-body) '(let let*))) + (setf (second wrapped-body) + (append intercept-rebindings (second wrapped-body))) ;; - (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.))))) + ;; 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)))) + ;; + ;; 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. + ;; + ;; 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)) - `(apply (lambda ,',intercept-lambda-list - ,,(when (memq '.ignore. intercept-lambda-list) - ''(declare (ignore .ignore.))) - ,inner-result.) - .combined-method-args.)))) - + `(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.)))) +;;; +;;; 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 +;;; is left as rest from VALUES. +;;; +(defun frob-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)))))