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

Better type annotation support.

Browse Source 
- Delay more errors for additional reporting.
 - Don't re-check expressions that were checked for inference.
 Closes PR 10098.
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-18 09:11:31 -05:00
parent 2c3db18852
commit 638245e4c5
7 changed files with 77 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/tests/typed-scheme/fail/dup-ann.rkt Normal file
View File

@ -0,0 +1,18 @@
#;
(exn-pred 4)
#lang typed/racket
(: bar : (String -> String))
(: bar : (Number -> Number))
(define (bar x)
(+ x 1))
(define: (foo) : Number
(: bar : (Number -> Number))
(define: (bar [x : Number]) : Number
(+ x 1))
(bar 5))
(: baz Number)
(define: baz : Number 7)

8
collects/tests/typed-scheme/fail/internal-ann.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme/base
(define (f x)
(: g (Integer -> Integer))
(define (g x)
(+ x 2))
(g x))

8
collects/tests/typed-scheme/xfail/cl-expected.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme
(: add (case-lambda (Integer -> Integer) (Integer Integer -> Integer)))
(define add
(case-lambda
[(x) (add x 0)]
[(x y) (+ x y)]))

26
collects/typed-scheme/env/type-env.rkt vendored
View File

@ -26,16 +26,19 @@
(free-id-table-set! the-mapping id type))
(define (register-type-if-undefined id type)
(if (free-id-table-ref the-mapping id (lambda _ #f))
(tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
(register-type id type)))
(cond [(free-id-table-ref the-mapping id (lambda _ #f))
=> (lambda (e)
(tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id))
(when (box? e)
(free-id-table-set! the-mapping id (unbox e))))]
[else (register-type id type)]))
;; add a single type to the mapping
;; identifier type -> void
(define (register-type/undefined id type)
;(printf "register-type/undef ~a~n" (syntax-e id))
(if (free-id-table-ref the-mapping id (lambda _ #f))
(tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
(void (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id)))
(free-id-table-set! the-mapping id (box type))))
;; add a bunch of types to the mapping
@ -61,7 +64,8 @@
(define (finish-register-type id)
(unless (maybe-finish-register-type id)
(tc-error/stx id "Duplicate defintion for ~a" (syntax-e id))))
(tc-error/expr #:stx id "Duplicate defintion for ~a" (syntax-e id)))
(void))
(define (check-all-registered-types)
(free-id-table-for-each
@ -69,11 +73,13 @@
(lambda (id e)
(when (box? e)
(let ([bnd (identifier-binding id)])
(tc-error/stx id "Declaration for ~a provided, but ~a ~a"
(syntax-e id) (syntax-e id)
(cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
[(not bnd) "has no definition"]
[else "is defined in another module"])))))))
(tc-error/expr #:stx id
"Declaration for ~a provided, but ~a ~a"
(syntax-e id) (syntax-e id)
(cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
[(not bnd) "has no definition"]
[else "is defined in another module"]))))
(void))))
;; map over the-mapping, producing a list
;; (id type -> T) -> listof[T]

12
collects/typed-scheme/private/type-annotation.rkt
View File

@ -37,7 +37,11 @@
;; is let-binding really necessary? - remember to record the bugs!
(define (type-annotation stx #:infer [let-binding #f])
(define (pt prop)
#;(print-size prop)
(when (and (identifier? stx)
let-binding
(lookup-type stx (lambda () #f)))
(maybe-finish-register-type stx)
(tc-error/expr #:stx stx "Duplicate type annotation for ~a" (syntax-e stx)))
(if (syntax? prop)
(parse-type prop)
(parse-type/id stx prop)))
@ -92,14 +96,14 @@
;; get the type annotation of this identifier, otherwise error
;; if #:default is provided, return that instead of error
;; identifier #:default Type -> Type
(define (get-type stx #:default [default #f])
(define (get-type stx #:default [default #f] #:infer [infer #t])
(parameterize
([current-orig-stx stx])
(cond
[(type-annotation stx #:infer #t)]
[(type-annotation stx #:infer infer)]
[default default]
[(not (syntax-original? stx))
(tc-error "untyped var: ~a" (syntax-e stx))]
(tc-error "untyped variable: ~a" (syntax-e stx))]
[else
(tc-error "no type information on variable ~a" (syntax-e stx))])))

2
collects/typed-scheme/typecheck/tc-let-unit.rkt
View File

@ -108,7 +108,7 @@
[(begin (quote-syntax (define-type-alias-internal nm ty)) (#%plain-app values))
(register-resolved-type-alias #'nm (parse-type #'ty))]
[(begin (quote-syntax (:-internal nm ty)) (#%plain-app values))
(register-type/undefined #'nm (parse-type #'ty))]
(register-type-if-undefined #'nm (parse-type #'ty))]
[_ (void)]))
names
exprs)

35
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -3,7 +3,7 @@
(require (rename-in "../utils/utils.rkt" [infer r:infer]))
(require syntax/kerncase
unstable/list unstable/syntax syntax/parse
unstable/list unstable/syntax syntax/parse unstable/debug
mzlib/etc
scheme/match
"signatures.rkt"
@ -14,7 +14,7 @@
(types utils convenience)
(private parse-type type-annotation type-contract)
(env type-env init-envs type-name-env type-alias-env lexical-env)
unstable/mutated-vars
unstable/mutated-vars syntax/id-table
(utils tc-utils)
"provide-handling.rkt"
"def-binding.rkt"
@ -27,6 +27,8 @@
(import tc-expr^ check-subforms^)
(export typechecker^)
(define unann-defs (make-free-id-table))
(define (tc-toplevel/pass1 form)
;(printf "form-top: ~a~n" form)
;; first, find the mutated variables:
@ -115,7 +117,7 @@
(cond
;; if all the variables have types, we stick them into the environment
[(andmap (lambda (s) (syntax-property s 'type-label)) vars)
(let ([ts (map get-type vars)])
(let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
(for-each register-type-if-undefined vars ts)
(map make-def-binding vars ts))]
;; if this already had an annotation, we just construct the binding reps
@ -123,16 +125,13 @@
(for-each finish-register-type vars)
(map (lambda (s) (make-def-binding s (lookup-type s))) vars)]
;; special case to infer types for top level defines - should handle the multiple values case here
[(and (= 1 (length vars))
(with-handlers ([exn:fail? (lambda _ #f)])
(save-errors!)
(begin0 (tc-expr #'expr)
(restore-errors!))))
=> (match-lambda
[(tc-result1: t)
(register-type (car vars) t)
(list (make-def-binding (car vars) t))]
[t (int-err "~a is not a tc-result" t)])]
[(= 1 (length vars))
(match (tc-expr #'expr)
[(tc-result1: t)
(register-type (car vars) t)
(free-id-table-set! unann-defs (car vars) #t)
(list (make-def-binding (car vars) t))]
[t (int-err "~a is not a tc-result" t)])]
[else
(tc-error "Untyped definition : ~a" (map syntax-e vars))]))]
@ -186,10 +185,12 @@
;; definitions just need to typecheck their bodies
[(define-values (var ...) expr)
(begin (let* ([vars (syntax->list #'(var ...))]
[ts (map lookup-type vars)])
(tc-expr/check #'expr (ret ts)))
(void))]
(let* ([vars (syntax->list #'(var ...))]
[ts (map lookup-type vars)])
(unless (for/and ([v (syntax->list #'(var ...))])
(free-id-table-ref unann-defs v (lambda _ #f)))
(tc-expr/check #'expr (ret ts)))
(void))]
;; to handle the top-level, we have to recur into begins
[(begin) (void)]