From 6d42033ba4d27215dda45e55df1441d733414248 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 4 May 2003 00:37:34 +0000
Subject: [PATCH] 	Detect odd-length keyword argument lists, invalid
 keyword 	arguments is methods.  Change lambda-lists of some gfs and
 methods 	to include &key, or &key &allow-other-keys.  Bugs found by
 Paul 	Dietz in his test suite.

	* src/pcl/boot.lisp (bind-args): Handle the case that &key is
	in the lambda-list, but no keyword args.
	(get-key-arg1): Additional argument first-time; check for
	invalid keyword arguments, and add number of args when true.
	(get-key-arg): Call get-key-arg1.
	(odd-number-of-keyword-arguments, invalid-keyword-argument):
	New functions.

	* src/pcl/init.lisp (make-instance) <symbol, class>: Add &key.
	(initialize-instance) <slot-object>: Likewise.
	(reinitialize-instance) <slot-object>: Likewise.
	(update-instance-for-different-class): Likewise.
	(update-instance-for-redefined-class): Likewise.
	(shared-initialize) <slot-object>: Likewise.
	* src/pcl/std-class.lisp (change-class): Likewise.
	* src/pcl/slots.lisp (allocate-instance) <standard-class>:
	(allocate-instance) <structure-class>: Likewise.
	* src/pcl/methods.lisp (reinitialize-instance) <standard-method>:
	Likewise.
	* src/pcl/generic-functions.lisp (change-class)
	(allocate-instance, update-instance-for-different-class)
	(update-instance-for-redefined-class): Add &key &allow-other-keys.
	* src/pcl/fsc.lisp (allocate-instance)
	<funcallable-standard-class>: Add &key.

	* src/pcl/std-class.lisp (make-defstruct-allocation-function): Fix
	a paren bug.
---
 pcl/boot.lisp              | 138 +++++++++++++++++++++----------------
 pcl/fsc.lisp               |   6 +-
 pcl/generic-functions.lisp |  14 ++--
 pcl/init.lisp              |  17 ++---
 pcl/methods.lisp           |   4 +-
 pcl/slots.lisp             |   6 +-
 pcl/std-class.lisp         |  20 +++---
 7 files changed, 114 insertions(+), 91 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index f2fe7f1e3..c3518c30c 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.49 2003/03/26 17:15:22 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.50 2003/05/04 00:37:34 gerd Exp $")
 
 (in-package :pcl)
 
@@ -924,77 +924,95 @@ work during bootstrapping.
 (defmacro bind-args ((lambda-list args) &body body)
   (let ((args-tail '.args-tail.)
 	(key '.key.)
-	(state 'required))
+	(state 'required)
+	(key-seen nil)
+	(nkeys 0))
     (flet ((process-var (var)
 	     (if (memq var lambda-list-keywords)
 		 (progn
-		   (case var
+		   (ecase var
 		     (&optional         (setq state 'optional))
-		     (&key              (setq state 'key))
+		     (&key              (setq state 'key key-seen t))
 		     (&allow-other-keys)
 		     (&rest             (setq state 'rest))
-		     (&aux              (setq state 'aux))
-		     (otherwise
-		      (internal-error "Encountered the non-standard ~
-				       lambda list keyword ~S."
-				      var)))
+		     (&aux              (setq state 'aux)))
 		   nil)
 		 (case state
-		   (required `((,var (pop ,args-tail))))
-		   (optional (cond ((not (consp var))
-				    `((,var (when ,args-tail (pop ,args-tail)))))
-				   ((null (cddr var))
-				    `((,(car var) (if ,args-tail
-						      (pop ,args-tail)
-						      ,(cadr var)))))
-				   (t
-				    `((,(caddr var) ,args-tail)
-				      (,(car var) (if ,args-tail
-						      (pop ,args-tail)
-						      ,(cadr var)))))))
-		   (rest `((,var ,args-tail)))
-		   (key (cond ((not (consp var))
-			       `((,var (get-key-arg ,(make-keyword var)
-					            ,args-tail))))
-			      ((null (cddr var))
-			       (multiple-value-bind (keyword variable)
-				   (if (consp (car var))
-				       (values (caar var) (cadar var))
-				       (values (make-keyword (car var)) (car var)))
-				 `((,key (get-key-arg1 ',keyword ,args-tail))
-				   (,variable (if (consp ,key)
-						  (car ,key)
-						  ,(cadr var))))))
-			      (t
-			       (multiple-value-bind (keyword variable)
-				   (if (consp (car var))
-				       (values (caar var) (cadar var))
-				       (values (make-keyword (car var)) (car var)))
-				 `((,key (get-key-arg1 ',keyword ,args-tail))
-				   (,(caddr var) ,key)
-				   (,variable (if (consp ,key)
-						  (car ,key)
-						  ,(cadr var))))))))
-		   (aux `(,var))))))
+		   (required
+		    `((,var (pop ,args-tail))))
+		   (optional
+		    (cond ((not (consp var))
+			   `((,var (when ,args-tail (pop ,args-tail)))))
+			  ((null (cddr var))
+			   `((,(car var) (if ,args-tail
+					     (pop ,args-tail)
+					     ,(cadr var)))))
+			  (t
+			   `((,(caddr var) ,args-tail)
+			     (,(car var) (if ,args-tail
+					     (pop ,args-tail)
+					     ,(cadr var)))))))
+		   (rest
+		    `((,var ,args-tail)))
+		   (key
+		    (incf nkeys)
+		    (cond ((not (consp var))
+			   `((,var (get-key-arg ,(make-keyword var)
+						,args-tail ',(= 1 nkeys)))))
+			  ((null (cddr var))
+			   (multiple-value-bind (keyword variable)
+			       (if (consp (car var))
+				   (values (caar var) (cadar var))
+				   (values (make-keyword (car var)) (car var)))
+			     `((,key (get-key-arg1 ',keyword ,args-tail
+						   ',(= 1 nkeys)))
+			       (,variable (if (consp ,key)
+					      (car ,key)
+					      ,(cadr var))))))
+			  (t
+			   (multiple-value-bind (keyword variable)
+			       (if (consp (car var))
+				   (values (caar var) (cadar var))
+				   (values (make-keyword (car var)) (car var)))
+			     `((,key (get-key-arg1 ',keyword ,args-tail
+						   ',(= 1 nkeys)))
+			       (,(caddr var) ,key)
+			       (,variable (if (consp ,key)
+					      (car ,key)
+					      ,(cadr var))))))))
+		   (aux
+		    `(,var))))))
       (let ((bindings (mapcan #'process-var lambda-list)))
 	`(let* ((,args-tail ,args)
-		,@bindings)
-	   (declare (ignorable ,args-tail))
+		,@bindings
+		(.dummy. ,@(when (and key-seen (zerop nkeys))
+			     `((get-key-arg1 :allow-other-keys
+					     ,args-tail t)))))
+	   (declare (ignorable ,args-tail .dummy.))
 	   ,@body)))))
 
-(defun get-key-arg (keyword list)
-  (loop for (key . more) on list by #'cddr
-	when (null more) do
-	  (simple-program-error "Odd number of keyword arguments.")
-	when (eq key keyword)
-	  return (car more)))
-
-(defun get-key-arg1 (keyword list)
-  (loop for (key . more) on list by #'cddr
-	when (null more) do
-	  (simple-program-error "Odd number of keyword arguments.")
-	when (eq key keyword)
-	  return more))
+(defun odd-number-of-keyword-arguments ()
+  (simple-program-error "Odd number of keyword arguments."))
+
+(defun invalid-keyword-argument (key)
+  (simple-program-error "Invalid keyword argument ~s" key))
+
+(defun get-key-arg (keyword list first-time)
+  (car (get-key-arg1 keyword list first-time)))
+
+(defun get-key-arg1 (keyword list first-time)
+  (if first-time
+      (loop with cell = nil
+	    for (key . more) on list by #'cddr do
+	      (cond ((not (symbolp key))
+		     (invalid-keyword-argument key))
+		    ((null more)
+		     (odd-number-of-keyword-arguments))
+		    ((and (null cell) (eq key keyword))
+		     (setq cell more)))
+	    finally (return cell))
+      (loop for (key . more) on list by #'cddr
+	    when (eq key keyword) return more)))
 
 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
   (let ((call-next-method-p nil)   ;flag indicating that call-next-method
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
index 434b20ff3..ff9bb225f 100644
--- a/pcl/fsc.lisp
+++ b/pcl/fsc.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.11 2003/03/22 16:15:16 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.12 2003/05/04 00:37:34 gerd Exp $")
 ;;;
 ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS
 ;;; metaclass.  Much of the implementation of this metaclass is actually
@@ -62,8 +62,8 @@
     (or (eq new-super-meta-class *the-class-std-class*)
 	(eq (class-of fsc) new-super-meta-class))))
 
-(defmethod allocate-instance
-	   ((class funcallable-standard-class) &rest initargs)
+(defmethod allocate-instance ((class funcallable-standard-class)
+			      &rest initargs &key)
   (declare (ignore initargs))
   (unless (class-finalized-p class) (finalize-inheritance class))
   (allocate-funcallable-instance (class-wrapper class)))
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
index 26189aa96..6f241fecc 100644
--- a/pcl/generic-functions.lisp
+++ b/pcl/generic-functions.lisp
@@ -1,7 +1,7 @@
 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.23 2003/04/29 10:33:51 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.24 2003/05/04 00:37:33 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -487,7 +487,8 @@
 (defgeneric add-method (generic-function method))
 ;          (standard-generic-function method)
 
-(defgeneric change-class (instance new-class-name &rest initargs))
+(defgeneric change-class (instance new-class-name &rest initargs
+				   &key &allow-other-keys))
 ;          (standard-object standard-class)
 ;          (funcallable-standard-object funcallable-standard-class)
 ;          (t symbol)
@@ -715,7 +716,7 @@
 
 
 ;;; keyword arguments  
-(defgeneric allocate-instance (class &rest initargs))
+(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
 ;          (standard-class)
 ;          (structure-class)
 ;          (funcallable-standard-class)
@@ -768,9 +769,12 @@
 
 (defgeneric update-dependent (metaobject dependent &rest initargs))
 
-(defgeneric update-instance-for-different-class (previous current &rest initargs))
+(defgeneric update-instance-for-different-class
+    (previous current &rest initargs &key &allow-other-keys))
 
-(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs))
+(defgeneric update-instance-for-redefined-class
+    (instance added-slots discarded-slots property-list &rest initargs
+	      &key &allow-other-keys))
 
 (defgeneric writer-method-class (class direct-slot &rest initargs))
 ;          (slot-class t)
diff --git a/pcl/init.lisp b/pcl/init.lisp
index e4848421e..3f44fed64 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.20 2003/05/02 12:43:06 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.21 2003/05/04 00:37:33 gerd Exp $")
 
 ;;;
 ;;; This file defines the initialization and related protocols.
@@ -34,10 +34,10 @@
 
 (in-package :pcl)
 
-(defmethod make-instance ((class symbol) &rest initargs)
+(defmethod make-instance ((class symbol) &rest initargs &key)
   (apply #'make-instance (find-class class) initargs))
 
-(defmethod make-instance ((class class) &rest initargs)
+(defmethod make-instance ((class class) &rest initargs &key)
   ;;
   ;; Try to use an optimized constructor if there is one.
   (let ((instance (call-ctor class initargs)))
@@ -73,16 +73,16 @@
 	finally
 	  (return (append supplied-initargs default-initargs))))
 
-(defmethod initialize-instance ((instance slot-object) &rest initargs)
+(defmethod initialize-instance ((instance slot-object) &rest initargs &key)
   (apply #'shared-initialize instance t initargs))
 
-(defmethod reinitialize-instance ((instance slot-object) &rest initargs)
+(defmethod reinitialize-instance ((instance slot-object) &rest initargs &key)
   (check-ri-initargs instance initargs)
   (apply #'shared-initialize instance nil initargs)
   instance)
 
 (defmethod update-instance-for-different-class
-    ((previous standard-object) (current standard-object) &rest initargs)
+    ((previous standard-object) (current standard-object) &rest initargs &key)
   ;; First we must compute the newly added slots.  The spec defines
   ;; newly added slots as "those local slots for which no slot of
   ;; the same name exists in the previous class."
@@ -105,7 +105,7 @@
      added-slots
      discarded-slots
      property-list
-     &rest initargs)
+     &rest initargs &key)
   (check-initargs
    (class-of instance) initargs
    (list (list* 'update-instance-for-redefined-class
@@ -134,7 +134,8 @@
 ;;;            no slots are set from initforms
 ;;;
 
-(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
+(defmethod shared-initialize ((instance slot-object) slot-names
+			      &rest initargs &key)
   (let ((structure-p (structure-class-p (class-of instance))))
     (flet ((initialize-slot-from-initarg (class instance slotd)
 	     (let ((slot-initargs (slot-definition-initargs slotd)))
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index e8294b6a0..56f91cc98 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.27 2003/04/25 17:43:50 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.28 2003/05/04 00:37:33 gerd Exp $")
 
 (in-package :pcl)
 
@@ -160,7 +160,7 @@
   (find-class 'standard-generic-function))
 
 
-(defmethod reinitialize-instance ((method standard-method) &rest initargs)
+(defmethod reinitialize-instance ((method standard-method) &rest initargs &key)
   (declare (ignore initargs))
   (error "~@<Attempt to reinitialize the method ~S.  ~
           Method objects cannot be reinitialized.~@:>"
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
index c3ca8e646..2fd01dae4 100644
--- a/pcl/slots.lisp
+++ b/pcl/slots.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.19 2003/04/26 14:30:39 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.20 2003/05/04 00:37:33 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -295,12 +295,12 @@
 		   (car position)))))
 
 
-(defmethod allocate-instance ((class standard-class) &rest initargs)
+(defmethod allocate-instance ((class standard-class) &rest initargs &key)
   (declare (ignore initargs))
   (unless (class-finalized-p class) (finalize-inheritance class))
   (allocate-standard-instance (class-wrapper class)))
 
-(defmethod allocate-instance ((class structure-class) &rest initargs)
+(defmethod allocate-instance ((class structure-class) &rest initargs &key)
   (declare (ignore initargs))
   (let ((constructor (class-defstruct-constructor class)))
     (if constructor
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index cc4007d84..75627f7e4 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.59 2003/05/03 14:46:12 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.60 2003/05/04 00:37:33 gerd Exp $")
 
 (in-package :pcl)
 
@@ -728,10 +728,9 @@
 	(setf (kernel::%instance-layout instance)
 	      (kernel::compiler-layout-or-lose (kernel::dd-name dd)))
 	(when raw-index
-	  (setf (kernel::%instance-ref
-		 instance raw-index
-		 (make-array (kernel::dd-raw-length dd)
-			     :element-type '(unsigned-byte 32)))))
+	  (setf (kernel::%instance-ref instance raw-index)
+		(make-array (kernel::dd-raw-length dd)
+			    :element-type '(unsigned-byte 32))))
 	instance))))
     
 (defmethod direct-slot-definition-class ((class structure-class)
@@ -1482,17 +1481,17 @@
 
 (defmethod change-class ((instance standard-object)
 			 (new-class standard-class)
-			 &rest initargs)
+			 &rest initargs &key)
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance funcallable-standard-object)
 			 (new-class funcallable-standard-class)
-			 &rest initargs)
+			 &rest initargs &key)
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance standard-object)
 			 (new-class funcallable-standard-class)
-			 &rest initargs)
+			 &rest initargs &key)
   (declare (ignore initargs))
   (error "~@<Can't change the class of ~S to ~S ~
           because it isn't already an instance with metaclass ~S.~@:>"
@@ -1500,13 +1499,14 @@
 
 (defmethod change-class ((instance funcallable-standard-object)
 			 (new-class standard-class)
-			 &rest initargs)
+			 &rest initargs &key)
   (declare (ignore initargs))
   (error "~@<Can't change the class of ~S to ~S ~
           because it isn't already an instance with metaclass ~S.~@:>"
 	 instance new-class 'funcallable-standard-class))
 
-(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
+(defmethod change-class ((instance t) (new-class-name symbol)
+			 &rest initargs &key)
   (apply #'change-class instance (find-class new-class-name) initargs))
 
 
-- 
GitLab