From 1abaeeec6faf659d50e028a9ff6a06a79e2eecbe Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@benasque2.(none)>
Date: Mon, 1 Sep 2008 21:01:53 +0200
Subject: [PATCH] PROPAGATE-TYPES understands complex function types

---
 src/cmp/cmpenv.lsp  |  2 +-
 src/cmp/cmptype.lsp | 31 ++++++++++++++++++++++---------
 2 files changed, 23 insertions(+), 10 deletions(-)

diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp
index 2de5eeb2a..9cbd2f246 100644
--- a/src/cmp/cmpenv.lsp
+++ b/src/cmp/cmpenv.lsp
@@ -156,7 +156,7 @@
 	   with minarg = 0
 	   and maxarg = 0
 	   and in-optionals = nil
-	   do (cond ((member type '(* &rest &key &allow-other-keys))
+	   do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
 		     (return (values minarg call-arguments-limit)))
 		    ((eq type '&optional)
 		     (setf in-optionals t maxarg minarg))
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index 241f939a1..5e7b0ffe5 100644
--- a/src/cmp/cmptype.lsp
+++ b/src/cmp/cmptype.lsp
@@ -388,22 +388,35 @@
 	     fname
 	     forms)
     (when arg-types
-      (do ((fl forms (rest fl))
-	   (al lisp-forms (rest al))
-	   (i 1 (1+ i)))
-	  ((endp fl))
-	(unless (endp arg-types)
-	  ;; Check the type of the arguments.
+      (do* ((types arg-types (rest types))
+	    (fl forms (rest fl))
+	    (al lisp-forms (rest al))
+	    (i 1 (1+ i))
+	    (in-optionals nil))
+	   ((endp types)
+	    (when types
+	      (cmpwarn "Too many arguments passed to ~A" fname)))
+	(let ((expected-type (first types)))
+	  (when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq)
+	    (return))
+	  (when (eq expected-type '&optional)
+	    (when in-optionals
+	      (cmpwarn "Syntax error in type proclamation for function ~A.~&~A"
+		       fname arg-types))
+	    (setf in-optionals t))
+	  (when (endp fl)
+	    (unless in-optionals
+	      (cmpwarn "Too few arguments for proclaimed function ~A" fname))
+	    (return))
 	  (let* ((form (first fl))
 		 (lisp-form (first al))
-		 (expected-type (pop arg-types))
-                 (old-type (c1form-type form)))
+		 (old-type (c1form-type form)))
 	    (and-form-type expected-type form lisp-form
 			   :safe "In the argument ~d of a call to ~a" i fname)
 	    ;; In safe mode, we cannot assume that the type of the
 	    ;; argument is going to be the right one.
 	    (unless (zerop (cmp-env-optimization 'safety))
-              (setf (c1form-type form) old-type))))))
+	      (setf (c1form-type form) old-type))))))
     return-type))
 
 (defmacro def-type-propagator (fname lambda-list &body body)