suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix bug with match dots.

Browse Source 
Fix handling of keywords.
Add keywords in call-with-input/output-port.

svn: r14469

original commit: ac7e87936043f80e97057c252b855159349001d6
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-08 20:24:05 +00:00
parent d946fc3b79
commit b111dc6b98
5 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/tests/typed-scheme/succeed/match-dots.ss Normal file
View File

@ -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]))

8
collects/tests/typed-scheme/xfail/apply-map-bug.ss Normal file
View File

@ -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))

9
collects/typed-scheme/private/base-env.ss
View File

@ -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)]

6
collects/typed-scheme/rep/type-rep.ss
View File

@ -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

6
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -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*))