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

new branch

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-02 20:42:22 -05:00
parent 76f41c2a1c
commit 536b94c305
4 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,7 @@
(require syntax/kerncase mzlib/trace (require syntax/kerncase mzlib/trace
scheme/match (prefix-in - scheme/contract) scheme/match (prefix-in - scheme/contract)
"signatures.ss" "tc-envops.ss" "tc-metafunctions.ss" "signatures.ss" "tc-envops.ss" "tc-metafunctions.ss"
(types utils convenience union subtype remove-intersect) (types utils convenience union subtype remove-intersect type-table)
(private-in parse-type type-annotation) (private-in parse-type type-annotation)
(rep type-rep) (rep type-rep)
(only-in (infer infer) restrict) (only-in (infer infer) restrict)
@ -231,6 +231,7 @@
(lambda (ann) (lambda (ann)
(let* ([r (tc-expr/check/internal form ann)] (let* ([r (tc-expr/check/internal form ann)]
[r* (check-below r expected)]) [r* (check-below r expected)])
(add-typeof-expr form expected)
;; around again in case there is an instantiation ;; around again in case there is an instantiation
;; remove the ascription so we don't loop infinitely ;; remove the ascription so we don't loop infinitely
(loop (remove-ascription form) r* #t)))] (loop (remove-ascription form) r* #t)))]
@ -242,13 +243,16 @@
;; do the instantiation on the old type ;; do the instantiation on the old type
(let* ([ts* (do-inst form ts)] (let* ([ts* (do-inst form ts)]
[ts** (ret ts* fs os)]) [ts** (ret ts* fs os)])
(add-typeof-expr form ts**)
;; make sure the new type is ok ;; make sure the new type is ok
(check-below ts** expected))] (check-below ts** expected))]
;; no annotations possible on dotted results ;; no annotations possible on dotted results
[ty ty])] [ty (add-typeof-expr form ty) ty])]
;; nothing to see here ;; nothing to see here
[checked? expected] [checked? expected]
[else (tc-expr/check/internal form expected)])))) [else (let ([t (tc-expr/check/internal form expected)])
(add-typeof-expr form t)
t)]))))
(define (tc-or e1 e2 or-part [expected #f]) (define (tc-or e1 e2 or-part [expected #f])
(match (single-value e1) (match (single-value e1)
@ -469,8 +473,10 @@
[else (internal-tc-expr form)])]) [else (internal-tc-expr form)])])
(match ty (match ty
[(tc-results: ts fs os) [(tc-results: ts fs os)
(let ([ts* (do-inst form ts)]) (let* ([ts* (do-inst form ts)]
(ret ts* fs os))])))) [r (ret ts* fs os)])
(add-typeof-expr form r)
r)]))))
(define (tc/send rcvr method args [expected #f]) (define (tc/send rcvr method args [expected #f])
(match (tc-expr rcvr) (match (tc-expr rcvr)

5
collects/typed-scheme/typed-scheme.ss
View File

@ -6,7 +6,7 @@
(for-syntax (for-syntax
(except-in syntax/parse id) (except-in syntax/parse id)
scheme/base scheme/base
(private type-contract) (private type-contract optimize)
(types utils convenience) (types utils convenience)
(typecheck typechecker provide-handling) (typecheck typechecker provide-handling)
(env type-environments type-name-env type-alias-env) (env type-environments type-name-env type-alias-env)
@ -79,7 +79,8 @@
(type-check #'(body2 ...)))] (type-check #'(body2 ...)))]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
[(transformed-body ...) (remove-provides #'(body2 ...))])] [(transformed-body ...) (remove-provides #'(body2 ...))])]
[with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]) [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]
[with-syntax ([(transformed-body ...) (map optimize (syntax->list #'(transformed-body ...)))])])
(do-time "Typechecked") (do-time "Typechecked")
#;(printf "checked ~a~n" module-name) #;(printf "checked ~a~n" module-name)
#;(printf "created ~a types~n" (count!)) #;(printf "created ~a types~n" (count!))

2
collects/typed-scheme/types/abbrev.ss
View File

@ -2,7 +2,7 @@
(require "../utils/utils.ss") (require "../utils/utils.ss")
(require (rep type-rep object-rep filter-rep) (require (rep type-rep object-rep filter-rep rep-utils)
"printer.ss" "utils.ss" "printer.ss" "utils.ss"
(utils tc-utils) (utils tc-utils)
scheme/list scheme/list

2
collects/typed-scheme/utils/utils.ss
View File

@ -160,7 +160,7 @@ at least theoretically.
;; turn contracts on and off - off by default for performance. ;; turn contracts on and off - off by default for performance.
(define-for-syntax enable-contracts? #f) (define-for-syntax enable-contracts? #t)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
;; these are versions of the contract forms conditionalized by `enable-contracts?' ;; these are versions of the contract forms conditionalized by `enable-contracts?'