0.9.15.17:

[sbcl.git] / src / pcl / combin.lisp

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 6c43380..b2743d3 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -30,8 +30,8 @@
         (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
@@ -41,8 +41,7 @@
                   (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)))))))
 
@@ -81,9 +80,9 @@
                   (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))))
@@ -129,14 +128,62 @@
                       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