~ chicken-core (chicken-5) 353cf3afdc8cf5b7ef481a6db9ff4c6545923d43

commit 353cf3afdc8cf5b7ef481a6db9ff4c6545923d43
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Mar 17 12:42:28 2011 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Mar 17 12:42:28 2011 +0100

    validate-type cleans up and validates llists

diff --git a/expand.scm b/expand.scm
index 05d0c54b..264bd519 100644
--- a/expand.scm
+++ b/expand.scm
@@ -127,7 +127,8 @@
 (define (##sys#globalize sym se)
   (if (symbol? sym)
       (let loop ((se se))			; ignores syntax bindings
-	(cond ((null? se) (##sys#alias-global-hook sym #f #f)) ;XXX could hint at decl (3rd arg)
+	(cond ((null? se)
+	       (##sys#alias-global-hook sym #f #f)) ;XXX could hint at decl (3rd arg)
 	      ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
 	      (else (loop (cdr se)))))
       sym))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 4aac1a35..a4c92e7f 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -747,10 +747,26 @@
 (define (validate-type type name)
   ;; - returns converted type or #f
   ;; - also converts "(... -> ...)" types
+  ;; - drops "#!key ..." args by converting to #!rest
   (define (upto lst p)
     (let loop ((lst lst))
       (cond ((eq? lst p) '())
 	    (else (cons (car lst) (loop (cdr lst)))))))
+  (define (validate-llist llist)
+    (cond ((null? llist) '())
+	  ((symbol? llist) '(#!rest *))
+	  ((not (pair? llist)) #f)
+	  ((eq? '#!optional (car llist))
+	   (cons '#!optional (validate-llist (cdr llist))))
+	  ((eq? '#!rest (car llist))
+	   (cond ((null? (cdr llist)) '(#!rest *))
+		 ((not (pair? (cdr llist))) #f)
+		 ((and (pair? (cddr llist))
+		       (eq? '#!key (caddr llist)))
+		  `(#!rest ,(validate (cadr llist))))
+		 (else #f)))
+	  ((eq? '#!key (car llist)) '(#!rest *))
+	  (else (cons (validate (car llist)) (validate-llist (cdr llist))))))
   (define (validate t)
     (cond ((memq t '(* string symbol char number boolean list pair
 		       procedure vector null eof undefined port blob
@@ -775,14 +791,9 @@
 		       (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
 		  (and (pair? t2)
 		       (list? (car t2))
-		       (let ((ts (map (lambda (x)
-					(if (memq 
-					     x
-					     '(#!optional #!rest values))
-					    x
-					    (validate x)))
-				      (car t2))))
-			 (and (every identity ts)
+		       (let ((ts (validate-llist (car t2))))
+			 (and ts
+			      (every identity ts)
 			      (let ((rt (if (eq? '* (cddr t2))
 					    (cddr t2)
 					    (and (list? (cddr t2))