- (let* ((next-methods (car cm-args))
- (next (make-effective-method-function-simple1
- gf (car next-methods)
- (list* (cdr next-methods) (cdr cm-args))
- fmf-p method-alist wrappers))
- (arg-info (method-function-get fmf :arg-info)))
- (make-fast-method-call :function fmf
- :pv-cell pv-cell
- :next-method-call next
- :arg-info arg-info))
- (if real-mf-p
- (make-method-call :function mf
- :call-method-args cm-args)
- mf))))
+ (let* ((next-methods (car cm-args))
+ (next (make-effective-method-function-simple1
+ gf (car next-methods)
+ (list* (cdr next-methods) (cdr cm-args))
+ fmf-p method-alist wrappers))
+ (arg-info (method-plist-value method :arg-info))
+ (default (cons nil nil))
+ (value (method-plist-value method :constant-value default)))
+ (if (eq value default)
+ (make-fast-method-call :function fmf :pv pv
+ :next-method-call next :arg-info arg-info)
+ (make-constant-fast-method-call
+ :function fmf :pv pv :next-method-call next
+ :arg-info arg-info :value value)))
+ (if real-mf-p
+ (flet ((frob-cm-arg (arg)
+ (if (if (listp arg)
+ (eq (car arg) :early-method)
+ (method-p arg))
+ arg
+ (if (and (consp arg) (eq (car arg) 'make-method))
+ (let ((emf (make-effective-method-function
+ gf (cadr arg) method-alist wrappers)))
+ (etypecase emf
+ (method-call
+ (make-instance 'standard-method
+ :specializers nil ; XXX
+ :qualifiers nil ; XXX
+ :function (method-call-function emf)))
+ (fast-method-call
+ (let* ((fmf (fast-method-call-function emf))
+ (fun (method-function-from-fast-method-call emf))
+ (mf (%make-method-function fmf nil)))
+ (set-funcallable-instance-function mf fun)
+ (make-instance 'standard-method
+ :specializers nil ; XXX
+ :qualifiers nil
+ :function mf)))))
+ arg))))
+ (let* ((default (cons nil nil))
+ (value
+ (method-plist-value method :constant-value default))
+ ;; FIXME: this is wrong. Very wrong. It assumes
+ ;; that the only place that can have make-method
+ ;; calls is in the list structure of the second
+ ;; argument to CALL-METHOD, but AMOP says that
+ ;; CALL-METHOD can be more complicated if
+ ;; COMPUTE-EFFECTIVE-METHOD (and presumably
+ ;; MAKE-METHOD-LAMBDA) is adjusted to match.
+ ;;
+ ;; On the other hand, it's a start, because
+ ;; without this calls to MAKE-METHOD in method
+ ;; combination where one of the methods is of a
+ ;; user-defined class don't work at all. -- CSR,
+ ;; 2006-08-05
+ (args (cons (mapcar #'frob-cm-arg (car cm-args))
+ (cdr cm-args))))
+ (if (eq value default)
+ (make-method-call :function mf :call-method-args args)
+ (make-constant-method-call :function mf :value value
+ :call-method-args args))))
+ mf))))