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

fix some small bugs

Browse Source 
svn: r14352

original commit: ebdd60a3a3cbdc7904f71c93316379caf866afdf
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-30 12:51:02 +00:00
parent fc897da813
commit 5949a60cf7
3 changed files with 15 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -1,10 +1,14 @@
#lang scheme/base
(require scheme/contract
(prefix-in r: "../utils/utils.ss")
scheme/match
(except-in (r:utils tc-utils) make-env))
(provide current-tvars
extend
env?
lookup
make-empty-env
extend-env
extend/values
dotted-env
@ -15,9 +19,8 @@
env-keys+vals
with-dotted-env/extend)
(require (prefix-in r: "../utils/utils.ss"))
(require scheme/match
(except-in (r:utils tc-utils) make-env))
(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)]
[])
;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l))

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

@ -114,8 +114,8 @@
;; typecheck an expression, but throw away the effect
;; tc-expr/t : Expr -> Type
(define (tc-expr/t e) (match (tc-expr e)
[(tc-result: t _ _) t]
[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))]))
[(tc-result1: t _ _) t]
[t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))]))
(define (tc-expr/check/t e t)
(match (tc-expr/check e t)

11
collects/typed-scheme/typecheck/tc-new-if.ss
View File

@ -21,19 +21,20 @@
(define (tc/if-twoarm tst thn els [expected #f])
(define (tc e) (if expected (tc-expr/check e expected) (tc-expr e)))
(match (tc-expr tst)
[(list (tc-result: _ (and f1 (FilterSet: fs+ fs-)) _))
[(tc-result1: _ (and f1 (FilterSet: fs+ fs-)) _)
(match-let ([(tc-results: ts fs2 _) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))]
[(tc-results: us fs3 _) (with-lexical-env (env+ (lexical-env) fs-) (tc els))])
;; if we have the same number of values in both cases
(cond [(= (length ts) (length us))
(for/list ([t ts] [u us] [f2 fs2] [f3 fs3])
(ret (Un t u) (combine-filter f1 f2 f2)))]
(ret (for/list ([t ts] [u us]) (Un t u))
(for/list ([f2 fs2] [f3 fs3])
(combine-filter f1 f2 f2)))]
[else
(tc-error/expr #:ret (ret Err)
(tc-error/expr #:return (ret Err)
"Expected the same number of values from both branches of if expression, but got ~a and ~a"
(length ts) (length us))]))]
[(tc-results: t _ _)
(tc-error/expr #:ret (ret (or expected Err))
(tc-error/expr #:return (ret (or expected Err))
"Test expression expects one value, given ~a" t)]))
(define tc/if-twoarm/check tc/if-twoarm)