0.pre8.43

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

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 6ab148a..5be842e 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -95,7 +95,7 @@
 
 (defun make-effective-method-function-simple
     (generic-function form &optional no-fmf-p)
-  ;; The effective method is just a call to call-method. This opens up
+  ;; The effective method is just a call to CALL-METHOD. This opens up
   ;; the possibility of just using the method function of the method as
   ;; the effective method function.
   ;;
@@ -174,13 +174,38 @@
       (get-generic-fun-info gf)
     (declare (ignore nreq nkeys arg-info))
     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
-         ;; When there are no primary methods and a next-method call occurs
-         ;; effective-method is (error "No mumble..") and the defined
-         ;; args are not used giving a compiler warning.
-         (error-p (eq (first effective-method) 'error)))
-      `(lambda ,ll
-        (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
-        ,effective-method))))
+         (error-p (eq (first effective-method) '%no-primary-method))
+         (mc-args-p
+          (when (eq *boot-state* 'complete)
+            ;; Otherwise the METHOD-COMBINATION slot is not bound.
+            (let ((combin (generic-function-method-combination gf)))
+              (and (long-method-combination-p combin)
+                   (long-method-combination-args-lambda-list combin))))))
+      (cond
+       (error-p
+        `(lambda (.pv-cell. .next-method-call. &rest .args.)
+          (declare (ignore .pv-cell. .next-method-call.))
+          (flet ((%no-primary-method (gf args)
+                   (apply #'no-primary-method gf args)))
+            ,effective-method)))
+       (mc-args-p
+        (let* ((required
+                ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
+                (let (req)
+                  (dotimes (i (length metatypes) (nreverse req))
+                    (push (dfun-arg-symbol i) req))))
+               (gf-args (if applyp
+                            `(list* ,@required .dfun-rest-arg.)
+                            `(list ,@required))))
+          `(lambda ,ll
+            (declare (ignore .pv-cell. .next-method-call.))
+            (let ((.gf-args. ,gf-args))
+              (declare (ignorable .gf-args.))
+              ,effective-method))))
+       (t
+        `(lambda ,ll
+          (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+          ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))
@@ -341,19 +366,19 @@
          primary (reverse primary)
          around  (reverse around))
     (cond ((null primary)
-          `(error "There is no primary method for the generic function ~S."
-                  ',generic-function))
+          `(%no-primary-method ',generic-function .args.))
          ((and (null before) (null after) (null around))
-          ;; By returning a single call-method `form' here we enable an
-          ;; important implementation-specific optimization.
+          ;; By returning a single call-method `form' here we enable
+          ;; an important implementation-specific optimization.
           `(call-method ,(first primary) ,(rest primary)))
          (t
           (let ((main-effective-method
                   (if (or before after)
                       `(multiple-value-prog1
-                         (progn ,(make-call-methods before)
-                                (call-method ,(first primary)
-                                             ,(rest primary)))
+                         (progn
+                           ,(make-call-methods before)
+                           (call-method ,(first primary)
+                                        ,(rest primary)))
                          ,(make-call-methods (reverse after)))
                       `(call-method ,(first primary) ,(rest primary)))))
             (if around