X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=5be842e33e28c6aaff308cf562d7111d7b9a1823;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=76746897f06ba462d4f69171bef52c20ba8897fe;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 7674689..5be842e 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -60,7 +60,7 @@
       (make-effective-method-function-simple generic-function form)
       ;; We have some sort of `real' effective method. Go off and get a
       ;; compiled function for it. Most of the real hair here is done by
-      ;; the GET-FUNCTION mechanism.
+      ;; the GET-FUN mechanism.
       (make-effective-method-function-internal generic-function form
 					       method-alist-p wrappers-p)))
 
@@ -74,7 +74,7 @@
 	     (method (car cm-args)))
 	(when method
 	  (if (if (listp method)
-		  (eq (car method) ':early-method)
+		  (eq (car method) :early-method)
 		  (method-p method))
 	      (if method-alist-p
 		  t
@@ -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.
   ;;
@@ -111,9 +111,13 @@
 		     (null (cddr cm-args))))
 	 (method (car cm-args))
 	 (cm-args1 (cdr cm-args)))
-    #'(lambda (method-alist wrappers)
-	(make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
-						method-alist wrappers))))
+    (lambda (method-alist wrappers)
+      (make-effective-method-function-simple1 generic-function
+					      method
+					      cm-args1
+					      fmf-p
+					      method-alist
+					      wrappers))))
 
 (defun make-emf-from-method
     (method cm-args &optional gf fmf-p method-alist wrappers)
@@ -125,7 +129,7 @@
 		      gf (car next-methods)
 		      (list* (cdr next-methods) (cdr cm-args))
 		      fmf-p method-alist wrappers))
-	       (arg-info (method-function-get fmf ':arg-info)))
+	       (arg-info (method-function-get fmf :arg-info)))
 	  (make-fast-method-call :function fmf
 				 :pv-cell pv-cell
 				 :next-method-call next
@@ -139,7 +143,7 @@
     (gf method cm-args fmf-p &optional method-alist wrappers)
   (when method
     (if (if (listp method)
-	    (eq (car method) ':early-method)
+	    (eq (car method) :early-method)
 	    (method-p method))
 	(make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
 	(if (and (consp method) (eq (car method) 'make-method))
@@ -167,16 +171,41 @@
 (defun expand-effective-method-function (gf effective-method &optional env)
   (declare (ignore env))
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info gf)
+      (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))
@@ -195,11 +224,11 @@
 	   (t
 	    '.call-method.)))
 	((and (consp form) (eq (car form) 'call-method-list))
-	 (case (if (every #'(lambda (form)
-			      (eq 'fast-method-call
-				  (make-effective-method-fun-type
-				   generic-function form
-				   method-alist-p wrappers-p)))
+	 (case (if (every (lambda (form)
+			    (eq 'fast-method-call
+				(make-effective-method-fun-type
+				 generic-function form
+				 method-alist-p wrappers-p)))
 			  (cdr form))
 		   'fast-method-call
 		   t)
@@ -220,11 +249,11 @@
 		   (list gensym))))
 	((and (consp form) (eq (car form) 'call-method-list))
 	 (let ((gensym (get-effective-method-gensym))
-	       (type (if (every #'(lambda (form)
-				    (eq 'fast-method-call
-					(make-effective-method-fun-type
-					 generic-function form
-					 method-alist-p wrappers-p)))
+	       (type (if (every (lambda (form)
+				  (eq 'fast-method-call
+				      (make-effective-method-fun-type
+				       generic-function form
+				       method-alist-p wrappers-p)))
 				(cdr form))
 			 'fast-method-call
 			 t)))
@@ -241,9 +270,9 @@
 		      generic-function form))))
 	((and (consp form) (eq (car form) 'call-method-list))
 	 (list (cons '.meth-list.
-		     (mapcar #'(lambda (form)
-				 (make-effective-method-function-simple
-				  generic-function form))
+		     (mapcar (lambda (form)
+			       (make-effective-method-function-simple
+				generic-function form))
 			     (cdr form)))))
 	(t
 	 (default-constant-converter form))))
@@ -251,7 +280,7 @@
 (defun make-effective-method-function-internal
     (generic-function effective-method method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nkeys arg-info))
     (let* ((*rebound-effective-method-gensyms*
 	    *global-effective-method-gensyms*)
@@ -262,45 +291,45 @@
 	   (effective-method-lambda (expand-effective-method-function
 				     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)
-	  (get-function1 effective-method-lambda
-			 #'(lambda (form)
-			     (memf-test-converter form generic-function
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-code-converter form generic-function
-						  metatypes applyp
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-constant-converter form generic-function)))
-	#'(lambda (method-alist wrappers)
-	    (let* ((constants
-		    (mapcar #'(lambda (constant)
-				(if (consp constant)
-				    (case (car constant)
-				      (.meth.
-				       (funcall (cdr constant)
-						method-alist wrappers))
-				      (.meth-list.
-				       (mapcar #'(lambda (fn)
-						   (funcall fn
-							    method-alist
-							    wrappers))
-					       (cdr constant)))
-				      (t constant))
-				    constant))
-			    constants))
-		   (function (set-fun-name
-			      (apply cfunction constants)
-			      `(combined-method ,name))))
-	      (make-fast-method-call :function function
-				     :arg-info arg-info)))))))
+	  (get-fun1 effective-method-lambda
+		    (lambda (form)
+		      (memf-test-converter form generic-function
+					   method-alist-p wrappers-p))
+		    (lambda (form)
+		      (memf-code-converter form generic-function
+					   metatypes applyp
+					   method-alist-p wrappers-p))
+		    (lambda (form)
+		      (memf-constant-converter form generic-function)))
+	(lambda (method-alist wrappers)
+	  (let* ((constants
+		  (mapcar (lambda (constant)
+			    (if (consp constant)
+				(case (car constant)
+				  (.meth.
+				   (funcall (cdr constant)
+					    method-alist wrappers))
+				  (.meth-list.
+				   (mapcar (lambda (fn)
+					     (funcall fn
+						      method-alist
+						      wrappers))
+					   (cdr constant)))
+				  (t constant))
+				constant))
+			  constants))
+		 (function (set-fun-name
+			    (apply cfunction constants)
+			    `(combined-method ,name))))
+	    (make-fast-method-call :function function
+				   :arg-info arg-info)))))))
 
 (defmacro call-method-list (&rest calls)
   `(progn ,@calls))
 
 (defun make-call-methods (methods)
   `(call-method-list
-    ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+    ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
 
 (defun standard-compute-effective-method (generic-function combin applicable-methods)
   (declare (ignore combin))
@@ -337,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