From c4827066097ae076b47302a267ba867e51823ed7 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 18 May 2003 18:09:31 +0000
Subject: [PATCH] 	Paul Dietz' DEFGENERIC.ERROR.4.  Check for repeated
 lambda 	variables.

	* src/pcl/boot.lisp (parse-generic-function-lambda-list)
	(analyze-lambda-list, parse-specialized-lambda-list):
	Use parse-lambda-list.
	(expand-defmethod): Proclaim the generic function using
	the unspecialized lambda list, not the method's specialized
	lambda list.

	* src/pcl/low.lisp (parse-lambda-list): New function.
---
 pcl/boot.lisp | 33 ++++++++++++---------------------
 pcl/low.lisp  | 45 ++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 56 insertions(+), 22 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index f1135c8a2..e514a0849 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.56 2003/05/18 12:23:21 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.57 2003/05/18 18:09:31 gerd Exp $")
 
 (in-package :pcl)
 
@@ -171,15 +171,13 @@ work during bootstrapping.
 ;;;
 
 (defun parse-generic-function-lambda-list (lambda-list)
-  ;; This is like kernel:parse-lambda-list, but returns an additional
+  ;; This is like PARSE-LAMBDA-LIST, but returns an additional
   ;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword.
   (multiple-value-bind (required optional restp rest keyp keys
-				 allow-other-keys-p aux morep
-				 more-context more-count)
-      (kernel:parse-lambda-list lambda-list)
+				 allow-other-keys-p aux)
+      (parse-lambda-list lambda-list)
     (values required optional restp rest keyp keys allow-other-keys-p
-	    (or aux (member '&aux lambda-list :test #'eq)) aux
-	    morep more-context more-count)))
+	    (or aux (member '&aux lambda-list :test #'eq)) aux)))
 
 (defun check-generic-function-lambda-list (function-specifier lambda-list)
   (multiple-value-bind (required optional restp rest keyp keys
@@ -405,9 +403,9 @@ work during bootstrapping.
 	  (let ((initargs-form (make-method-initargs-form 
 				proto-gf proto-method
 				method-function-lambda initargs env)))
-	    (tell-compiler-about-gf name lambda-list)
+	    (tell-compiler-about-gf name unspecialized-lambda-list)
 	    `(progn
-	       (proclaim-defgeneric ',name ',lambda-list)
+	       (proclaim-defgeneric ',name ',unspecialized-lambda-list)
 	       ,(make-defmethod-form name qualifiers specializers
 				     unspecialized-lambda-list
 				     (if proto-method
@@ -1265,13 +1263,9 @@ work during bootstrapping.
 
 (defun analyze-lambda-list (lambda-list)
   (multiple-value-bind (required optional restp rest keyp keys
-				 allow-other-keys-p aux morep
-				 more-context more-count)
-      (kernel:parse-lambda-list lambda-list)
-    (declare (ignore rest aux more-context more-count))
-    (when morep
-      (simple-program-error "Lambda list keyword ~s not allowed here."
-			    '&more))
+				 allow-other-keys-p aux)
+      (parse-lambda-list lambda-list t)
+    (declare (ignore rest aux))
     (flet ((keyword-parameter-keyword (x)
 	     (let ((key (if (atom x) x (car x))))
 	       (if (atom key)
@@ -2191,12 +2185,9 @@ work during bootstrapping.
 
 (defun parse-specialized-lambda-list (lambda-list)
   (multiple-value-bind (required optional restp rest keyp keys
-				 allow-other-keys-p aux morep
-				 more-context more-count)
-      (kernel:parse-lambda-list lambda-list)
+				 allow-other-keys-p aux)
+      (parse-lambda-list lambda-list t)
     (declare (ignore more-context more-count))
-    (when morep
-      (error "~@<~s is not allowed in specialized lambda-lists~@:>" :more))
     (collect ((req) (spec))
       (dolist (x required)
 	(req (if (consp x) (car x) x))
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 3fdf23bfa..0cfd04749 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.28 2003/05/13 10:16:58 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.29 2003/05/18 18:09:30 gerd Exp $")
 
 ;;; 
 ;;; This file contains optimized low-level constructs for PCL.
@@ -336,6 +336,49 @@ the compiler as completely as possible.  Currently this means that
 (defmacro slot-ref (slots index)
   `(svref ,slots ,index))
 
+;;;
+;;; Like KERNEL::PARSE-LAMBDA-LIST, but check for repeated lambda
+;;; variable and &MORE.
+;;;
+(defun parse-lambda-list (lambda-list &optional specialized-p)
+  (multiple-value-bind (required optional restp rest keyp keys
+				 allow-other-keys-p aux morep)
+      (kernel:parse-lambda-list lambda-list)
+    (when morep
+      (simple-program-error "~@<~s not allowed here~@:>" 'c:&more))
+    (collect ((vars))
+      (labels ((check-var (var)
+		 (cond ((not (symbolp var))
+			(simple-program-error
+			 "~@<Invalid lambda variable: ~s~@:>" var))
+		       ((memq var (vars))
+			(simple-program-error
+			 "~@<Repeated lambda variable: ~s~@:>" var))
+		       (t
+			(vars var))))
+	       (check-required (var)
+		 (if (and (consp var) specialized-p)
+		     (check-var (car var))
+		     (check-var var)))
+	       (check-optional (var)
+		 (if (consp var)
+		     (destructuring-bind (var &optional value supplied-p)
+			 var
+		       (if (consp var)
+			   (check-var (cadr var))
+			   (check-var var))
+		       (when supplied-p
+			 (check-var supplied-p)))
+		     (check-var var))))
+	(mapc #'check-required required)
+	(mapc #'check-optional optional)
+	(mapc #'check-optional keys)
+	(when restp (check-var rest))
+	(mapc #'check-optional aux)
+	(values required optional restp rest keyp keys
+		allow-other-keys-p aux)))))
+
+    
 ;;;
 ;;; The problem with unbound markers is that they cannot be dumped to
 ;;; fasl files.  So, we need to create unbound markers in some way,
-- 
GitLab