X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fcombin.lisp;h=54306cac95944c964d795516def087d3ba2f67df;hb=e972550db41da8a21a89d0215670de70802bd3ee;hp=6ab148a3eaf98abd0be0f6ef44a221bab4aad1d0;hpb=f6a2be77637d025bfded9430f02863c28f74f77a;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 6ab148a..54306ca 100644
--- 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,48 @@
       (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))))
+	  (check-applicable-keywords
+	   (when (and applyp (gf-requires-emf-keyword-checks gf))
+	     '((check-applicable-keywords))))
+	  (error-p (or (eq (first effective-method) '%no-primary-method)
+		       (eq (first effective-method) '%invalid-qualifiers)))
+	  (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.))
+	   (declare (ignorable .args.))
+	   (flet ((%no-primary-method (gf args)
+		    (apply #'no-primary-method gf args))
+		  (%invalid-qualifiers (gf combin method)
+		    (invalid-qualifiers gf combin method)))
+	     (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
+	     ,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.))
+	       ,@check-applicable-keywords
+	       ,effective-method))))
+	(t
+	 `(lambda ,ll
+	   (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+	   ,@check-applicable-keywords
+	   ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))
@@ -190,68 +225,80 @@
   (declare (ignore args))
   `(error "~S outside of a effective method form" 'call-method))
 
+(defun make-effective-method-list-fun-type
+    (generic-function form method-alist-p wrappers-p)
+  (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))
+
 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (case (make-effective-method-fun-type
-		generic-function form method-alist-p wrappers-p)
-	   (fast-method-call
-	    '.fast-call-method.)
-	   (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)))
-			  (cdr form))
-		   'fast-method-call
-		   t)
-	   (fast-method-call
-	    '.fast-call-method-list.)
-	   (t
-	    '.call-method-list.)))
-	(t
-	 (default-test-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (case (make-effective-method-fun-type
+	    generic-function form method-alist-p wrappers-p)
+       (fast-method-call '.fast-call-method.)
+       (t '.call-method.)))
+    (call-method-list
+     (case (make-effective-method-list-fun-type
+	    generic-function form method-alist-p wrappers-p)
+       (fast-method-call '.fast-call-method-list.)
+       (t '.call-method-list.)))
+    (check-applicable-keywords 'check-applicable-keywords)
+    (t (default-test-converter form))))
 
+;;; CMUCL comment (2003-10-15):
+;;;
+;;;   This function is called via the GET-FUNCTION mechanism on forms
+;;;   of an emf lambda.  First value returned replaces FORM in the emf
+;;;   lambda.  Second value is a list of variable names that become
+;;;   closure variables.
 (defun memf-code-converter
     (form generic-function metatypes applyp method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (let ((gensym (get-effective-method-gensym)))
-	   (values (make-emf-call metatypes applyp gensym
-				  (make-effective-method-fun-type
-				   generic-function form method-alist-p wrappers-p))
-		   (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)))
-				(cdr form))
-			 'fast-method-call
-			 t)))
-	   (values `(dolist (emf ,gensym nil)
-		      ,(make-emf-call metatypes applyp 'emf type))
-		   (list gensym))))
-	(t
-	 (default-code-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (let ((gensym (get-effective-method-gensym)))
+       (values (make-emf-call
+		metatypes applyp gensym
+		(make-effective-method-fun-type
+		 generic-function form method-alist-p wrappers-p))
+	       (list gensym))))
+    (call-method-list
+     (let ((gensym (get-effective-method-gensym))
+	   (type (make-effective-method-list-fun-type
+		  generic-function form method-alist-p wrappers-p)))
+       (values `(dolist (emf ,gensym nil)
+		 ,(make-emf-call metatypes applyp 'emf type))
+	       (list gensym))))
+    (check-applicable-keywords
+     (values `(check-applicable-keywords
+	       .dfun-rest-arg. .keyargs-start. .valid-keys.)
+	     '(.keyargs-start. .valid-keys.)))
+    
+    (t
+     (default-code-converter form))))
 
 (defun memf-constant-converter (form generic-function)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (list (cons '.meth.
-		     (make-effective-method-function-simple
-		      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))
-			     (cdr form)))))
-	(t
-	 (default-constant-converter form))))
+  (case (and (consp form) (car form))
+    (call-method
+     (list (cons '.meth.
+		 (make-effective-method-function-simple
+		  generic-function form))))
+    (call-method-list
+     (list (cons '.meth-list.
+		 (mapcar (lambda (form)
+			   (make-effective-method-function-simple
+			    generic-function form))
+			 (cdr form)))))
+    (check-applicable-keywords
+     '(.keyargs-start. .valid-keys.))
+    (t
+     (default-constant-converter form))))
 
+(defvar *applicable-methods*)
 (defun make-effective-method-function-internal
     (generic-function effective-method method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
@@ -277,27 +324,29 @@
 		    (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)))))))
+	  (multiple-value-bind (valid-keys keyargs-start)
+	      (when (memq '.valid-keys. constants)
+		(compute-applicable-keywords
+		 generic-function *applicable-methods*))
+	    (flet ((compute-constant (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))
+			 (case constant
+			   (.keyargs-start. keyargs-start)
+			   (.valid-keys. valid-keys)
+			   (t constant)))))
+	      (let ((fun (apply cfunction
+				(mapcar #'compute-constant constants))))
+		(set-fun-name fun `(combined-method ,name))
+		(make-fast-method-call :function fun
+				       :arg-info arg-info)))))))))
 
 (defmacro call-method-list (&rest calls)
   `(progn ,@calls))
@@ -306,62 +355,118 @@
   `(call-method-list
     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
 
-(defun standard-compute-effective-method (generic-function combin applicable-methods)
-  (declare (ignore combin))
-  (let ((before ())
-	(primary ())
-	(after ())
-	(around ()))
-    (flet ((lose (method why)
-             (invalid-method-error
-              method
-              "The method ~S ~A.~%~
-               Standard method combination requires all methods to have one~%~
-               of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
-               have no qualifier at all."
-              method why)))
+(defun gf-requires-emf-keyword-checks (generic-function)
+  (member '&key (gf-lambda-list generic-function)))
+
+(defun standard-compute-effective-method
+    (generic-function combin applicable-methods)
+  (collect ((before) (primary) (after) (around))
+    (flet ((invalid (gf combin m)
+	     (if *in-precompute-effective-methods-p*
+		 (return-from standard-compute-effective-method
+		   `(%invalid-qualifiers ',gf ',combin ',m))
+		 (invalid-qualifiers gf combin m))))
       (dolist (m applicable-methods)
-        (let ((qualifiers (if (listp m)
-                            (early-method-qualifiers m)
-                            (method-qualifiers m))))
-          (cond
-            ((null qualifiers) (push m primary))
-            ((cdr qualifiers)
-              (lose m "has more than one qualifier"))
-            ((eq (car qualifiers) :around)
-              (push m around))
-            ((eq (car qualifiers) :before)
-              (push m before))
-            ((eq (car qualifiers) :after)
-              (push m after))
-            (t
-              (lose m "has an illegal qualifier"))))))
-    (setq before  (reverse before)
-	  after   (reverse after)
-	  primary (reverse primary)
-	  around  (reverse around))
-    (cond ((null primary)
-	   `(error "There is no primary method for the generic function ~S."
-		   ',generic-function))
-	  ((and (null before) (null after) (null around))
-	   ;; By returning a single call-method `form' here we enable an
-	   ;; important implementation-specific optimization.
-	   `(call-method ,(first primary) ,(rest primary)))
+	(let ((qualifiers (if (listp m)
+			      (early-method-qualifiers m)
+			      (method-qualifiers m))))
+	  (cond
+	    ((null qualifiers) (primary m))
+	    ((cdr qualifiers) (invalid generic-function combin m))
+	    ((eq (car qualifiers) :around) (around m))
+	    ((eq (car qualifiers) :before) (before m))
+	    ((eq (car qualifiers) :after) (after m))
+	    (t (invalid generic-function combin m))))))
+    (cond ((null (primary))
+	   `(%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; that
+	   ;; is, we can use the fast method function directly as the
+	   ;; effective method function.
+	   ;;
+	   ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
+	   ;; function argument checking inhibits this, as we don't
+	   ;; perform this checking in fast-method-functions given
+	   ;; that they are not solely used for effective method
+	   ;; functions, but also in combination, when they should not
+	   ;; perform argument checks.
+	   (let ((call-method
+		  `(call-method ,(first (primary)) ,(rest (primary)))))
+	     (if (gf-requires-emf-keyword-checks generic-function)
+		 ;; the PROGN inhibits the above optimization
+		 `(progn ,call-method)
+		 call-method)))
 	  (t
 	   (let ((main-effective-method
-		   (if (or before after)
+		   (if (or (before) (after))
 		       `(multiple-value-prog1
-			  (progn ,(make-call-methods before)
-				 (call-method ,(first primary)
-					      ,(rest primary)))
-			  ,(make-call-methods (reverse after)))
-		       `(call-method ,(first primary) ,(rest primary)))))
-	     (if around
-		 `(call-method ,(first around)
-			       (,@(rest around)
+			  (progn
+			    ,(make-call-methods (before))
+			    (call-method ,(first (primary))
+					 ,(rest (primary))))
+			  ,(make-call-methods (reverse (after))))
+		       `(call-method ,(first (primary)) ,(rest (primary))))))
+	     (if (around)
+		 `(call-method ,(first (around))
+			       (,@(rest (around))
 				  (make-method ,main-effective-method)))
 		 main-effective-method))))))
 
+;;; helper code for checking keywords in generic function calls.
+(defun compute-applicable-keywords (gf methods)
+  (let ((any-keyp nil))
+    (flet ((analyze (lambda-list)
+	     (multiple-value-bind (nreq nopt keyp restp allowp keys)
+		 (analyze-lambda-list lambda-list)
+	       (declare (ignore nreq restp))
+	       (when keyp
+		 (setq any-keyp t))
+	       (values nopt allowp keys))))
+      (multiple-value-bind (nopt allowp keys)
+	  (analyze (generic-function-lambda-list gf))
+	(dolist (method methods)
+	  (let ((ll (if (consp method)
+			(early-method-lambda-list method)
+			(method-lambda-list method))))
+	    (multiple-value-bind (n allowp method-keys)
+		(analyze ll)
+	      (declare (ignore n))
+	      (when allowp
+		(return-from compute-applicable-keywords (values t nopt)))
+	      (setq keys (union method-keys keys)))))
+	(aver any-keyp)
+	(values (if allowp t keys) nopt)))))
+
+(defun check-applicable-keywords (args start valid-keys)
+  (let ((allow-other-keys-seen nil)
+	(allow-other-keys nil)
+	(args (nthcdr start args)))
+    (collect ((invalid))
+      (loop
+       (when (null args)
+	 (when (and (invalid) (not allow-other-keys))
+	   (error 'simple-program-error
+		  :format-control "~@<invalid keyword argument~P: ~
+                                   ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
+		  :format-arguments (list (length (invalid)) (invalid) valid-keys)))
+	 (return))
+       (let ((key (pop args)))
+	 (cond
+	   ((not (symbolp key))
+	    (error 'simple-program-error
+		   :format-control "~@<keyword argument not a symbol: ~S.~@:>"
+		   :format-arguments (list key)))
+	   ((null args) (sb-c::%odd-key-args-error))
+	   ((eq key :allow-other-keys)
+	    ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
+	    (unless allow-other-keys-seen
+	      (setq allow-other-keys-seen t
+		    allow-other-keys (car args))))
+	   ((eq t valid-keys))
+	   ((not (memq key valid-keys)) (invalid key))))
+       (pop args)))))
+
 ;;;; the STANDARD method combination type. This is coded by hand
 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
 ;;;; and efficiency reasons. Note that the definition of the
@@ -380,12 +485,14 @@
 				     applicable-methods))
 
 (defun invalid-method-error (method format-control &rest format-arguments)
-  (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
-	 method
-	 format-control
-	 format-arguments))
+  (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+    (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
+	   method
+	   format-control
+	   format-arguments)))
 
 (defun method-combination-error (format-control &rest format-arguments)
-  (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
-	 format-control
-	 format-arguments))
+  (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+    (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+	   format-control
+	   format-arguments)))