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

Correct typing for `or'.

Browse Source 
svn: r17665

original commit: 3fc133a0b84476a121b129f41e2c260e0d4593c0
This commit is contained in:
Sam Tobin-Hochstadt 2010-01-15 19:39:46 +00:00
parent 12be4e80ab
commit 34bb0090a0
2 changed files with 29 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -787,6 +787,10 @@
(+ 1 (car l))
7))
-Number]
(tc-e (or (string->number "7") 7)
#:ret (ret -Number (-FS (list) (list (make-Bot)))))
[tc-e (let ([x 1]) (if x x (add1 x)))
#:ret (ret -Pos (-FS (list) (list (make-Bot))))]
)
(test-suite
"check-type tests"

31
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -4,10 +4,11 @@
(require (rename-in "../utils/utils.ss" [private private-in]))
(require syntax/kerncase mzlib/trace
scheme/match (prefix-in - scheme/contract)
"signatures.ss"
(types utils convenience union subtype)
"signatures.ss" "tc-envops.ss" "tc-metafunctions.ss"
(types utils convenience union subtype remove-intersect)
(private-in parse-type type-annotation)
(rep type-rep)
(only-in (infer infer) restrict)
(except-in (utils tc-utils stxclass-util))
(env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env)
@ -249,6 +250,22 @@
[checked? expected]
[else (tc-expr/check/internal form expected)]))))
(define (tc-or e1 e2 or-part [expected #f])
(match (single-value e1)
[(tc-result1: t1 (and f1 (FilterSet: fs+ fs-)) o1)
(let*-values ([(flag+ flag-) (values (box #t) (box #t))])
(match-let* ([(tc-result1: t2 f2 o2) (with-lexical-env
(env+ (lexical-env) fs+ flag+)
(with-lexical-env/extend
(list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))]
[t1* (remove t1 (-val #f))]
[f1* (-FS fs+ (list (make-Bot)))])
;; if we have the same number of values in both cases
(let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)])
(if expected
(check-below r expected)
r))))]))
;; tc-expr/check : syntax tc-results -> tc-results
(define (tc-expr/check/internal form expected)
(parameterize ([current-orig-stx form])
@ -325,13 +342,14 @@
(let-values (((_ _) (#%plain-app find-method/who _ rcvr _)))
(#%plain-app _ _ args ...)))
(tc/send #'rcvr #'meth #'(args ...) expected)]
;; let
;; or
[(let-values ([(or-part) e1]) (if op1 op2 e2))
(and
(identifier? #'op1) (identifier? #'op2)
(free-identifier=? #'or-part #'op1)
(free-identifier=? #'or-part #'op2))
(tc-expr/check #'(if e1 e1 (let-values ([(or-part) e1]) e2)) expected)]
(tc-or #'e1 #'e2 #'or-part expected)]
;; let
[(let-values ([(name ...) expr] ...) . body)
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
[(letrec-values ([(name) expr]) name*)
@ -393,12 +411,13 @@
(let-values (((_ _) (#%plain-app find-method/who _ rcvr _)))
(#%plain-app _ _ args ...)))
(tc/send #'rcvr #'meth #'(args ...))]
;; let
;; or
[(let-values ([(or-part) e1]) (if op1 op2 e2))
(and (identifier? #'op1) (identifier? #'op2)
(free-identifier=? #'or-part #'op1)
(free-identifier=? #'or-part #'op2))
(tc-expr #'(if e1 e1 (let-values ([(or-part) e1]) e2)))]
(tc-or #'e1 #'e2 #'or-part)]
;; let
[(let-values ([(name ...) expr] ...) . body)
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form)]
[(letrec-values ([(name ...) expr] ...) . body)