(multiple-value-bind (mf fmf)
(if (listp method)
(early-method-function method)
- (values nil (method-fast-function method)))
- (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (values nil (safe-method-fast-function method)))
+ (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
(if (and fmf (or (null pv-table) wrappers))
(let* ((pv-wrappers (when pv-table
(pv-wrappers-from-all-wrappers
(values mf t fmf pv-cell))
(values
(or mf (if (listp method)
- (setf (cadr method)
- (method-function-from-fast-function fmf))
+ (bug "early method with no method-function")
(method-function method)))
t nil nil)))))))
(multiple-value-bind (mf fmf)
(if (listp method)
(early-method-function method)
- (values nil (method-fast-function method)))
+ (values nil (safe-method-fast-function method)))
(declare (ignore mf))
- (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
(if (and fmf (or (null pv-table) wrappers-p))
'fast-method-call
'method-call))))
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))
+ (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-cell pv-cell
+ :next-method-call next :arg-info arg-info)
+ (make-constant-fast-method-call
+ :function fmf :pv-cell pv-cell :next-method-call next
+ :arg-info arg-info :value value)))
(if real-mf-p
- (make-method-call :function mf
- :call-method-args cm-args)
+ (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))))
(defun make-effective-method-function-simple1