From baf0b858ef24bc35c531b62ad2b8b8192ee4cf42 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Fri, 9 May 2003 17:09:52 +0000
Subject: [PATCH] 	Found by Christophe Rhodes:

	(defgeneric foo (&rest x &key))
	(defmethod foo (&rest x) x)
	(foo 1)

	should signal an error.  This fix works only for methods defined
	with DEFMETHOD.  MAKE-METHOD-LAMBDA doesn't have enough
	information available to always do the right thing, alas.

	* src/pcl/boot.lisp (*make-method-lambda-gf-name*): New variable.
	(expand-defmethod): Bind it to the gf's name.
	(gf-key-p): New function.
	(make-method-lambda-internal): Determine from
	*make-method-lambda-gf-name* if the gf has &key and add &key to
	the method function's lambda-list if appropriate.
---
 pcl/boot.lisp | 42 ++++++++++++++++++++++++++++++------------
 1 file changed, 30 insertions(+), 12 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 02141257a..b544af355 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.54 2003/05/07 16:59:30 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.55 2003/05/09 17:09:52 gerd Exp $")
 
 (in-package :pcl)
 
@@ -375,13 +375,14 @@ work during bootstrapping.
 
 (defvar *inline-access*)
 (defvar *method-source-info*)
+(defvar *make-method-lambda-gf-name* nil)
 
 (defun expand-defmethod (name proto-gf proto-method qualifiers
 			 lambda-list body env)
-  (let ((*inline-access* ()))
+  (let ((*inline-access* ())
+	(*make-method-lambda-gf-name* name))
     (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
 	(add-method-declarations name qualifiers lambda-list body env)
-
       (let* ((auto-compile-p (auto-compile-p name qualifiers specializers))
 	     (*method-source-info*
 	      (when (and auto-compile-p
@@ -389,10 +390,8 @@ work during bootstrapping.
 			     (and (null (c::lexenv-functions env))
 				  (null (c::lexenv-variables env)))))
 		(list (copy-tree body) lambda-list))))
-	
 	(multiple-value-bind (method-function-lambda initargs)
 	    (make-method-lambda proto-gf proto-method method-lambda env)
-
 	  (when (and *inline-access*
 		     auto-compile-p
 		     env
@@ -403,7 +402,6 @@ work during bootstrapping.
                    non-null lexical environment means that it cannot be ~
                    automatically recompiled.~@:>"
 		  name qualifiers lambda-list))
-
 	  (let ((initargs-form (make-method-initargs-form 
 				proto-gf proto-method
 				method-function-lambda initargs env)))
@@ -560,6 +558,11 @@ work during bootstrapping.
       (when (and (consp form) (eq (car form) name))
 	(return-from get-declaration (cdr form))))))
 
+(defun gf-key-p (gf-name)
+  (let ((info (and gf-name (info function type gf-name))))
+    (and (kernel::function-type-p info)
+	 (kernel::function-type-keyp info))))
+  
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
     (error "~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>"
@@ -573,6 +576,7 @@ work during bootstrapping.
 	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
       (multiple-value-bind (parameters lambda-list specializers)
 	  (parse-specialized-lambda-list specialized-lambda-list)
+	;;
 	(let* ((required-parameters
 		(mapcar (lambda (r s) (declare (ignore s)) r)
 			parameters
@@ -655,6 +659,20 @@ work during bootstrapping.
 					   ,pv-table-symbol)
 			       ,@walked-lambda-body))))))
 		;;
+		;; When the GF contains &KEY, and the method has no
+		;; &KEY, add &KEY to the method function's
+		;; lambda-list, so that it checks for invalid keyword
+		;; arguments lists.  This is hack that works only for
+		;; methods defined with DEFMETHOD.  Don't know how to
+		;; do any better, though.  MAKE-METHOD-LAMBDA really
+		;; wants a NAME argument telling it the name of the
+		;; generic function for which the method lambda is
+		;; made, or maybe the lambda-list of the generic
+		;; function, or something.
+		(when (and (gf-key-p *make-method-lambda-gf-name*)
+			   (not (memq '&key lambda-list)))
+		  (setq lambda-list (append lambda-list '(&key))))
+		;;
 		;; When the lambda-list contains &KEY but not
 		;; &ALLOW-OTHER-KEYS, insert an &ALLOW-OTHER-KEYS
 		;; into the lambda-list.
@@ -1155,7 +1173,7 @@ work during bootstrapping.
   "When true, compile interpreted method functions.")
 
 (defun load-defmethod-internal
-    (method-class gf-spec qualifiers specializers lambda-list 
+    (method-class gf-name qualifiers specializers lambda-list 
      initargs pv-table-symbol inline-access method-info)
   (when pv-table-symbol
     (setf (getf (getf initargs :plist) :pv-table-symbol)
@@ -1171,17 +1189,17 @@ work during bootstrapping.
 		 (let* ((type (ecase key
 				(:fast-function 'fast-method)
 				(:function 'method)))
-			(name `(,type ,gf-spec ,@qualifiers ,specializers)))
+			(name `(,type ,gf-name ,@qualifiers ,specializers)))
 		   (compile name fn)
 		   (setf (getf initargs key) (fdefinition name)))))))
       (maybe-compile :fast-function)
       (maybe-compile :function)))
   ;;
   (let ((method (apply #'add-named-method
-		       gf-spec qualifiers specializers lambda-list
-		       :definition-source `((defmethod ,gf-spec
+		       gf-name qualifiers specializers lambda-list
+		       :definition-source `((defmethod ,gf-name
 						,@qualifiers
-					      ,specializers)
+						,specializers)
 					    ,*load-pathname*)
 		       initargs)))
     ;;
@@ -1195,7 +1213,7 @@ work during bootstrapping.
                was compiled, the method class for that generic function was ~
                ~S.  But, the method class is now ~S, this ~
                may mean that this method was compiled improperly.~@:>"
-	      qualifiers specializers gf-spec
+	      qualifiers specializers gf-name
 	      method-class (class-name (class-of method))))
     method))
 
-- 
GitLab