X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=5be842e33e28c6aaff308cf562d7111d7b9a1823;hb=4d8378af498b544256340e09919758e1f88029ac;hp=3429ad7da885f6288871d979052cf6eab348a799;hpb=106e6fe2df729b6027718f6f056721a95c047c17;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 3429ad7..5be842e 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -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