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

minor refactorings

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-11 11:53:39 -04:00
parent 5f069ed4bb
commit 4f2952f4b9
1 changed files with 30 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/typed-scheme/private/with-types.rkt
View File

@ -1,63 +1,57 @@
#lang scheme/base #lang racket/base
(require (for-syntax scheme/base syntax/parse mzlib/etc scheme/match) (require racket/require racket/contract/regions racket/contract/base
scheme/require "base-env.rkt" "base-special-env.rkt" "base-env-numeric.rkt"
"base-env.rkt" "base-env-indexing.rkt" "extra-procs.rkt" "prims.rkt"
"base-special-env.rkt"
"base-env-numeric.rkt"
"base-env-indexing.rkt"
"extra-procs.rkt"
"prims.rkt"
racket/contract/regions racket/contract/base
(for-syntax (for-syntax
"base-types-extra.rkt" scheme/base syntax/parse racket/block racket/match
unstable/debug unstable/sequence unstable/debug "base-types-extra.rkt"
(path-up "env/type-name-env.rkt" (except-in (path-up "env/type-name-env.rkt"
"env/type-alias-env.rkt" "env/type-alias-env.rkt"
"infer/infer-dummy.rkt" "infer/infer-dummy.rkt"
"private/parse-type.rkt" "private/parse-type.rkt"
"private/type-contract.rkt" "private/type-contract.rkt"
"typecheck/typechecker.rkt" "typecheck/typechecker.rkt"
"env/type-environments.rkt" "env/type-environments.rkt"
"env/type-env.rkt" "env/type-env.rkt"
"infer/infer.rkt" "infer/infer.rkt"
"utils/tc-utils.rkt" "utils/tc-utils.rkt"
"types/utils.rkt") "types/utils.rkt"
(except-in (path-up "utils/utils.rkt" "types/convenience.rkt" "types/abbrev.rkt") infer ->))) "types/convenience.rkt"
"types/abbrev.rkt")
->)
(except-in (path-up "utils/utils.rkt") infer)))
(provide with-type) (provide with-type)
(define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) (define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx)
(begin-with-definitions (block
(define old-context (unbox typed-context?)) (define old-context (unbox typed-context?))
(define ((no-contract t [stx stx]))
(tc-error/stx stx "Type ~a could not be converted to a contract." t))
(set-box! typed-context? #t) (set-box! typed-context? #t)
(define fv-types (for/list ([t (in-list (syntax->list fvtys))]) (define fv-types (for/list ([t (in-list (syntax->list fvtys))])
(parse-type t))) (parse-type t)))
(define fv-cnts (for/list ([t (in-list fv-types)] (define fv-cnts (for/list ([t (in-list fv-types)]
[stx (in-list (syntax->list fvtys))]) [stx (in-list (syntax->list fvtys))])
(type->contract t #:typed-side #f (type->contract t #:typed-side #f (no-contract t))))
(lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t)))))
(define ex-types (for/list ([t (syntax->list extys)]) (define ex-types (for/list ([t (syntax->list extys)])
(parse-type t))) (parse-type t)))
(define ex-cnts (for/list ([t (in-list ex-types)] (define ex-cnts (for/list ([t (in-list ex-types)]
[stx (in-list (syntax->list extys))]) [stx (in-list (syntax->list extys))])
(type->contract t #:typed-side #t (type->contract t #:typed-side #t (no-contract t))))
(lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t)))))
(define region-tc-result (define region-tc-result
(and expr? (parse-tc-results resty))) (and expr? (parse-tc-results resty)))
(define region-cnts (define region-cnts
(if region-tc-result (if region-tc-result
(match region-tc-result (match region-tc-result
[(tc-result1: t) [(tc-result1: t)
(list (type->contract (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))]
t
#:typed-side #t
(lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t))))]
[(tc-results: ts) [(tc-results: ts)
(for/list ([t (in-list ts)]) (for/list ([t (in-list ts)])
(type->contract (type->contract
t #:typed-side #t t #:typed-side #t
(lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t))))]) (no-contract t #'region-ty-stx)))])
null)) null))
(for ([i (in-list (syntax->list fvids))] (for ([i (in-list (syntax->list fvids))]
[ty (in-list fv-types)]) [ty (in-list fv-types)])
@ -91,10 +85,8 @@
[type-name-references null] [type-name-references null]
;; for error reporting ;; for error reporting
[orig-module-stx stx] [orig-module-stx stx]
[expanded-module-stx expanded-body]) [expanded-module-stx expanded-body])
(if expr? (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types))))
(tc-expr/check expanded-body region-tc-result)
(tc-expr/check expanded-body (ret ex-types))))
(report-all-errors) (report-all-errors)
(set-box! typed-context? old-context) (set-box! typed-context? old-context)
;; then clear the new entries from the env ht ;; then clear the new entries from the env ht