- (multiple-value-bind (outer-decls inner-decls body-sans-decls)
- (split-declarations
- body req-args (or (getf (cdr lmf-params) :call-next-method-p)
- (getf (cdr lmf-params) :setq-p)))
- (let* ((rest-arg (when restp '.rest-arg.))
- (args+rest-arg (if restp
- (append req-args (list rest-arg))
- req-args)))
- `(list*
- :function
- (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
- ,@(when (body-method-name body)
- ;; function name
- (list (cons 'fast-method (body-method-name body))))
- (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
- ;; body of the function
- (declare (ignorable .pv-cell. .next-method-call.)
- (disable-package-locks pv-env-environment))
- ,@outer-decls
- (symbol-macrolet ((pv-env-environment default))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body-sans-decls))))
- (mf (%make-method-function fmf nil)))
- (set-funcallable-instance-function
- mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
- mf)
- ',initargs))))
+ (let* (;; The lambda-list of the method, minus specifiers
+ (lambda-list (car lmf-params))
+ ;; Names of the parameters that will be in the outermost lambda-list
+ ;; (and whose bound declarations thus need to be in OUTER-DECLS).
+ (outer-parameters req-args)
+ ;; The lambda-list used by BIND-ARGS
+ (bind-list lambda-list)
+ (setq-p (getf (cdr lmf-params) :setq-p))
+ (auxp (member '&aux bind-list))
+ (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
+ ;; Try to use the normal function call machinery instead of BIND-ARGS
+ ;; binding the arguments, unless:
+ (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
+ ;; in any case.
+ (and (not restp) (not auxp))
+ ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
+ ;; list of all non-required arguments.
+ call-next-method-p)
+ (setf ;; We don't want a binding for .REST-ARG.
+ restp nil
+ ;; Get all the parameters for declaration parsing
+ outer-parameters (lambda-list-parameter-names lambda-list)
+ ;; Ensure that BIND-ARGS won't do anything (since
+ ;; BIND-LIST won't contain any non-required parameters,
+ ;; and REQ-ARGS will be of an equal length). We still want
+ ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
+ ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
+ ;; of rebinding SETQd required arguments around the method
+ ;; body.
+ bind-list req-args))
+ (multiple-value-bind (outer-decls inner-decls body-sans-decls)
+ (split-declarations
+ body outer-parameters (or call-next-method-p setq-p))
+ (let* ((rest-arg (when restp
+ '.rest-arg.))
+ (fmf-lambda-list (if rest-arg
+ (append req-args (list '&rest rest-arg))
+ (if call-next-method-p
+ req-args
+ lambda-list))))
+ `(list*
+ :function
+ (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ ;; function name
+ (list (cons 'fast-method (body-method-name body))))
+ ;; The lambda-list of the FMF
+ (.pv-cell. .next-method-call. ,@fmf-lambda-list)
+ ;; body of the function
+ (declare (ignorable .pv-cell. .next-method-call.)
+ (disable-package-locks pv-env-environment))
+ ,@outer-decls
+ (symbol-macrolet ((pv-env-environment default))
+ (fast-lexical-method-functions
+ (,bind-list .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body-sans-decls))))
+ (mf (%make-method-function fmf nil)))
+ (set-funcallable-instance-function
+ mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
+ mf)
+ ',initargs)))))