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

fix some small bugs

Browse Source 
svn: r14352
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-30 12:51:02 +00:00
parent fcc2a24545
commit ebdd60a3a3
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 #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 (provide current-tvars
extend extend
env? env?
lookup lookup
make-empty-env
extend-env extend-env
extend/values extend/values
dotted-env dotted-env
@ -15,9 +19,8 @@
env-keys+vals env-keys+vals
with-dotted-env/extend) with-dotted-env/extend)
(require (prefix-in r: "../utils/utils.ss")) (provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)]
(require scheme/match [])
(except-in (r:utils tc-utils) make-env))
;; eq? has the type of equal?, and l is an alist (with conses!) ;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l)) (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 ;; typecheck an expression, but throw away the effect
;; tc-expr/t : Expr -> Type ;; tc-expr/t : Expr -> Type
(define (tc-expr/t e) (match (tc-expr e) (define (tc-expr/t e) (match (tc-expr e)
[(tc-result: t _ _) t] [(tc-result1: t _ _) t]
[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) [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) (define (tc-expr/check/t e t)
(match (tc-expr/check 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/if-twoarm tst thn els [expected #f])
(define (tc e) (if expected (tc-expr/check e expected) (tc-expr e))) (define (tc e) (if expected (tc-expr/check e expected) (tc-expr e)))
(match (tc-expr tst) (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))] (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))]) [(tc-results: us fs3 _) (with-lexical-env (env+ (lexical-env) fs-) (tc els))])
;; if we have the same number of values in both cases ;; if we have the same number of values in both cases
(cond [(= (length ts) (length us)) (cond [(= (length ts) (length us))
(for/list ([t ts] [u us] [f2 fs2] [f3 fs3]) (ret (for/list ([t ts] [u us]) (Un t u))
(ret (Un t u) (combine-filter f1 f2 f2)))] (for/list ([f2 fs2] [f3 fs3])
(combine-filter f1 f2 f2)))]
[else [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" "Expected the same number of values from both branches of if expression, but got ~a and ~a"
(length ts) (length us))]))] (length ts) (length us))]))]
[(tc-results: t _ _) [(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)])) "Test expression expects one value, given ~a" t)]))
(define tc/if-twoarm/check tc/if-twoarm) (define tc/if-twoarm/check tc/if-twoarm)