~ chicken-core (chicken-5) 30750024747f36e2e48d573722eebbbbf93eb544

commit 30750024747f36e2e48d573722eebbbbf93eb544
Author:     felix <felix@z.(none)>
AuthorDate: Thu Mar 10 20:55:54 2011 +0100
Commit:     felix <felix@z.(none)>
CommitDate: Thu Mar 10 20:55:54 2011 +0100

    validate converts (... -> ...) type syntax

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 136b45bc..b889f7d3 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1117,15 +1117,14 @@
  (##sys#er-transformer
   (lambda (x r c)
     (##sys#check-syntax ': x '(_ symbol _))
-    (let ((name (##sys#globalize (cadr x)))
-	  (type (##sys#strip-syntax (caddr x))))
-      (validate-type type name)
-      (cond ((memq #:csi ##sys#features) '(##core#undefined))
+    (let* ((name (##sys#globalize (cadr x)))
+	   (type1 (##sys#strip-syntax (caddr x)))
+	   (name1 (##sys#strip-syntax (cadr x)))
+	   (type (validate-type type1 name1)))
+      (cond ((not type)
+	     (syntax-error ': "invalid type syntax" name1 type1))
+	    ((memq #:csi ##sys#features) '(##core#undefined))
 	    (else
-	     (when (and (pair? type) 
-			(eq? 'procedure (car type))
-			(not (symbol? (cadr type))))
-	       (set! type `(procedure ,(##sys#strip-syntax name) ,@(cdr type))))
 	     `(##core#declare (type (,name ,type)))))))))
 
 
diff --git a/compiler.scm b/compiler.scm
index 2beb740a..277b5f92 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1471,14 +1471,16 @@
 	       (let ((name (globalize (car spec)))
 		     (type (##sys#strip-syntax (cadr spec))))
 		 (cond ((validate-type type name)
-			(##sys#put! name '##core#type type)
-			(##sys#put! name '##core#declared-type #t)
+			(mark-variable name '##core#type type)
+			(mark-variable name '##core#declared-type)
 			(when (pair? (cddr spec))
-			  (##sys#put! 
+			  (mark-variable
 			   name '##core#specializations
 			   (##sys#strip-syntax (cddr spec)))))
 		       (else
-			(warning "illegal type declaration" (##sys#strip-syntax spec)))))))
+			(warning 
+			 "illegal type declaration"
+			 (##sys#strip-syntax spec)))))))
 	 (cdr spec)))
        ((unsafe-specialized-arithmetic)
 	(set! unchecked-specialized-arithmetic #t))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index a785b4ed..4aac1a35 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -745,26 +745,62 @@
     (copy-node! (build-node-graph (subst template)) node)))
 
 (define (validate-type type name)
+  ;; - returns converted type or #f
+  ;; - also converts "(... -> ...)" types
+  (define (upto lst p)
+    (let loop ((lst lst))
+      (cond ((eq? lst p) '())
+	    (else (cons (car lst) (loop (cdr lst)))))))
   (define (validate t)
     (cond ((memq t '(* string symbol char number boolean list pair
 		       procedure vector null eof undefined port blob
-		       pointer locative fixnum float pointer-vector deprecated)))
-	  ((not (pair? t)) #f)
+		       pointer locative fixnum float pointer-vector
+		       deprecated))
+	   t)
+	  ((not (pair? t)) t)
 	  ((eq? 'or (car t)) 
 	   (and (list t)
-		(every validate (cdr t))))
+		(let ((ts (map validate (cdr t))))
+		  (and (every identity ts)
+		       `(or ,@ts)))))
 	  ((eq? 'struct (car t))
-	   (and (= 2 (length t)) (symbol? (cadr t))))
+	   (and (= 2 (length t))
+		(symbol? (cadr t))
+		t))
 	  ((eq? 'procedure (car t))
 	   (and (pair? (cdr t))
-		(let ((t (if (symbol? (cadr t)) (cddr t) (cdr t))))
-		  (and (pair? t)
-		       (list? (car t))
-		       (every
-			validate
-			(remove (cut memq <> '(#!optional #!rest values)) (car t)))
-		       (or (eq? '* (cddr t))
-			   (and (list? (cddr t))
-				(every validate (cddr t))))))))
+		(let* ((name (if (symbol? (cadr t))
+				 (cadr t)
+				 name))
+		       (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 ((rt (if (eq? '* (cddr t2))
+					    (cddr t2)
+					    (and (list? (cddr t2))
+						 (let ((rts
+							(map
+							 validate
+							 (cddr t2))))
+						   (and (every identity rts)
+							rts))))))
+				(and rt
+				     `(procedure 
+				       ,@(if name (list name) '())
+				       ,ts
+				       ,@rt)))))))))
+	  ((and (pair? (cdr t)) (memq '-> (cadr t))) =>
+	   (lambda (p)
+	     (validate
+	      `(procedure ,(upto t p) ,@(cdr p))
+	      name)))
 	  (else #f)))
   (validate type))