From cffc0e2563b8ed0fd9ebddf0e46c7bff93541a2d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 7 Jan 2010 21:45:57 +0000
Subject: [PATCH] Better error message for functions that don't have the same
 arity as the expected. Add some tests for errors.

svn: r17551

original commit: eaad64d6120e70e59200fb2cec58f4af5a777ed4
---
 .../tests/typed-scheme/fail/all-bad-syntax.ss | 25 +++++++++++++++++++
 collects/tests/typed-scheme/fail/bad-ann.ss   | 14 +++++++++++
 .../tests/typed-scheme/fail/duplicate-ann.ss  | 19 ++++++++++++++
 .../typed-scheme/typecheck/tc-lambda-unit.ss  |  2 +-
 4 files changed, 59 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-scheme/fail/all-bad-syntax.ss
 create mode 100644 collects/tests/typed-scheme/fail/bad-ann.ss
 create mode 100644 collects/tests/typed-scheme/fail/duplicate-ann.ss

diff --git a/collects/tests/typed-scheme/fail/all-bad-syntax.ss b/collects/tests/typed-scheme/fail/all-bad-syntax.ss
new file mode 100644
index 00000000..c076f4d3
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/all-bad-syntax.ss
@@ -0,0 +1,25 @@
+#;
+(exn-pred 1)
+#lang typed-scheme
+
+(require scheme/list)
+
+(define-type-alias (BT a) (U Boolean (node a)))
+(define-struct: (a) node ([key : a] [l : (BT a)] [r : (BT a)]))
+
+(: traverse-4 (All (a i) (BT a) (a ( -> i) ( -> i) -> i) i -> i))
+(define (traverse-4 abt f i)
+  (cond
+    [(boolean? abt) i]
+    [(node? abt) (f (node-key abt)
+                    (lambda () (traverse-4 (node-l abt) f i))
+                    (lambda () (traverse-4 (node-r abt) f i)))]))
+
+(define: (a) (inorder-4 [abt : (BT a)]) : (Listof a)
+  (traverse-4 abt
+              (lambda: ([key : a] [lt : ( -> (Listof a))] [rt : ( -> (Listof a))])
+                (append (lt)
+                        (list key)
+                        (rt)))
+              #;empty))
+(+ 'foo)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/fail/bad-ann.ss b/collects/tests/typed-scheme/fail/bad-ann.ss
new file mode 100644
index 00000000..ca749ff2
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/bad-ann.ss
@@ -0,0 +1,14 @@
+#;
+(exn-pred 2)
+#lang typed/scheme
+
+
+(: f : Number  -> Number)
+(define (f a b)
+  (+ a b))
+
+(define: (g [a : Number] [b : Number]) : Number
+  (+ a b))
+
+(f 1 2)
+(g 1 2)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/fail/duplicate-ann.ss b/collects/tests/typed-scheme/fail/duplicate-ann.ss
new file mode 100644
index 00000000..97a97424
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/duplicate-ann.ss
@@ -0,0 +1,19 @@
+#lang scheme/load
+
+(module square typed-scheme
+  
+  ;(provide: [square (Integer -> Integer)])
+  (provide: [square (Integer -> Integer)])
+  ;(: square (Number -> Number))
+  (define: (square [n : Number]) : Number
+    (* n n))
+  )
+
+(module squareclient typed-scheme
+  
+  (require 'square)
+  
+  (square 10)  ;; 100
+  (integer? 10.1)  ;; #f
+  (square 10.1)  ;; 102.009999...
+  )
\ No newline at end of file
diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
index bb1d173c..e4656128 100644
--- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
@@ -66,7 +66,7 @@
     (define (check-body)
       (with-lexical-env/extend 
        arg-list arg-types
-       (make-lam-result (map list arg-list arg-types) null rest-ty drest 
+       (make-lam-result (for/list ([al arg-list] [at arg-types] [a-ty arg-tys]) (list al at)) null rest-ty drest 
                         (tc-exprs/check (syntax->list body) ret-ty))))
     (when (or (not (= arg-len tys-len))
               (and (or rest-ty drest) (not rest)))