From b111dc6b989f6f49ad299b7cb279ba2de7e12ce6 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 8 Apr 2009 20:24:05 +0000
Subject: [PATCH] Fix bug with match dots. Fix handling of keywords. Add
 keywords in call-with-input/output-port.

svn: r14469

original commit: ac7e87936043f80e97057c252b855159349001d6
---
 collects/tests/typed-scheme/succeed/match-dots.ss  | 8 ++++++++
 collects/tests/typed-scheme/xfail/apply-map-bug.ss | 8 ++++++++
 collects/typed-scheme/private/base-env.ss          | 9 +++++----
 collects/typed-scheme/rep/type-rep.ss              | 6 ++----
 collects/typed-scheme/typecheck/tc-app-unit.ss     | 6 +++---
 5 files changed, 26 insertions(+), 11 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/match-dots.ss
 create mode 100644 collects/tests/typed-scheme/xfail/apply-map-bug.ss

diff --git a/collects/tests/typed-scheme/succeed/match-dots.ss b/collects/tests/typed-scheme/succeed/match-dots.ss
new file mode 100644
index 00000000..c8a526c5
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/match-dots.ss
@@ -0,0 +1,8 @@
+#lang typed-scheme
+
+(require scheme/match)
+
+(: parse-sexpr : Any -> Number)
+(define (parse-sexpr sexpr)
+  (match sexpr
+    [(list #{(? symbol? a) : (Listof Symbol)} ...) 1]))
diff --git a/collects/tests/typed-scheme/xfail/apply-map-bug.ss b/collects/tests/typed-scheme/xfail/apply-map-bug.ss
new file mode 100644
index 00000000..d08a5c2f
--- /dev/null
+++ b/collects/tests/typed-scheme/xfail/apply-map-bug.ss
@@ -0,0 +1,8 @@
+
+#lang typed-scheme
+
+(: add-lists ((Listof Number) (Listof Number) * -> (Listof Number)))
+(define (add-lists lst . lsts)
+ (apply map #{+ :: (Number Number * -> Number)} lst lsts))
+
+(add-lists '(1 2 3) '(4 5 6) '(7 8 9))
\ No newline at end of file
diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 399202cc..4fbde9fb 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -419,11 +419,12 @@
 [symbol->string (Sym . -> . -String)]
 [vector-length (-poly (a) ((-vec a) . -> . -Integer))]
 
-[call-with-input-file (-poly (a) (cl-> [(-String (-Port . -> . a))  a]
-                                       [(-String (-Port . -> . a) Sym)  a]))]
+[call-with-input-file (-poly (a) (-String (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key .  a))]
+[call-with-output-file (-poly (a) (-String (-Output-Port . -> . a)
+                                   #:exists (one-of/c error 'append 'update 'replace 'truncate 'truncate/replace) #f
+                                   #:mode (Un (-val 'binary) (-val 'text)) #f 
+                                   . ->key .  a))]
 
-[call-with-output-file (-poly (a) (cl-> [(-String (-Port . -> . a))  a]
-                                        [(-String (-Port . -> . a) Sym)  a]))]
 [current-output-port (-Param -Output-Port -Output-Port)]
 [current-error-port (-Param -Output-Port -Output-Port)]
 [current-input-port (-Param -Input-Port -Input-Port)]
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index 1a6aae41..579d1cf8 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -364,8 +364,7 @@
                         (cons (sb (car drest))
                               (if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
                         #f)
-                    (for/list ([kw kws])
-                      (cons (car kw) (sb (cdr kw))))
+                    (map sb kws)
                     (map (lambda (e) (sub-eff sb e)) thn-eff)
                     (map (lambda (e) (sub-eff sb e)) els-eff))]
        [#:ValuesDots tys dty dbound
@@ -410,8 +409,7 @@
                         (cons (sb (car drest))
                               (if (eqv? (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
                         #f)
-                    (for/list ([kw kws])
-                      (cons (car kw) (sb (cdr kw))))
+                    (map sb kws)
                     (map (lambda (e) (sub-eff sb e)) thn-eff)
                     (map (lambda (e) (sub-eff sb e)) els-eff))]
        [#:ValuesDots tys dty dbound
diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss
index 61b4f54b..63db7660 100644
--- a/collects/typed-scheme/typecheck/tc-app-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-app-unit.ss
@@ -576,7 +576,7 @@
       [c:lv-clause
        #:with (#%plain-app reverse n:id) #'c.e
        #:with (v) #'(c.v ...) 
-       #:when (free-identifier=? name #'v)
+       #:when (free-identifier=? name #'n)
        (type-annotation #'v)]
       [_ #f]))
   (syntax-parse stx
@@ -757,8 +757,8 @@
      (match (tc-expr #'fn)
        [(tc-result: (Function: arities)) 
         (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
-       [t (tc-error/expr #:return (ret (Un))
-                         "Cannot apply expression of type ~a, since it is not a function type" t)])]
+       [(tc-result: t) (tc-error/expr #:return (ret (Un))
+                                      "Cannot apply expression of type ~a, since it is not a function type" t)])]
     ;; even more special case for match
     [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
      (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))