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

Default types for lambda formals.

Browse Source 
svn: r13539

original commit: e61075a4fd7a40c2641f06553aecdfedff48ed23
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-12 23:55:53 +00:00
parent aafbd385f1
commit 2076decb19
2 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/typed-scheme/private/type-annotation.ss
View File

@ -9,6 +9,7 @@
scheme/match mzlib/trace)
(provide type-annotation
get-type
get-types
get-type/infer
type-label-symbol
type-ascrip-symbol
@ -71,17 +72,23 @@
(printf/log "Unannotated Variable: ~a ~a~n" (syntax-e stx) ty))
;; get the type annotation of this identifier, otherwise error
;; identifier -> Type
(define (get-type stx)
;; if #:default is provided, return that instead of error
;; identifier #:default Type -> Type
(define (get-type stx #:default [default #f])
(parameterize
([current-orig-stx stx])
(cond
[(type-annotation stx #:infer #t)]
[default default]
[(not (syntax-original? stx))
(tc-error "untyped var: ~a" (syntax-e stx))]
[else
(tc-error "no type information on variable ~a" (syntax-e stx))])))
;; Listof[identifer] #:default Type -> Listof[Type]
(define (get-types stxs #:default [default #f])
(map (lambda (e) (get-type e #:default default)) stxs))
;; get the type annotations on this list of identifiers
;; if not all identifiers have annotations, return the supplied inferred type
;; list[identifier] type -> list[type]

14
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -44,7 +44,7 @@
(let* ([arg-len (length arg-list)]
[tys-len (length arg-tys)]
[arg-types (if (andmap type-annotation arg-list)
(map get-type arg-list)
(get-types arg-list #:default Univ)
(cond
[(= arg-len tys-len) arg-tys]
[(< arg-len tys-len) (take arg-tys arg-len)]
@ -79,14 +79,14 @@
[(dotted? rest)
=>
(lambda (b)
(let ([dty (get-type rest)])
(let ([dty (get-type rest #:default Univ)])
(with-dotted-env/extend
rest dty b
(check-body))))]
[else
(let ([rest-type (cond
[rest-ty rest-ty]
[(type-annotation rest) (get-type rest)]
[(type-annotation rest) (get-type rest #:default Univ)]
[(< arg-len tys-len) (list-ref arg-tys arg-len)]
[else (Un)])])
(with-lexical-env/extend
@ -108,7 +108,7 @@
(syntax-case args ()
[(args ...)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (map get-type arg-list)])
[arg-types (get-types arg-list #:default Univ)])
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(with-lexical-env/extend
arg-list arg-types
@ -124,7 +124,7 @@
[t (int-err "bad match - not a tc-result: ~a no ret-ty" t)])))]
[(args ... . rest)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (map get-type arg-list)])
[arg-types (get-types arg-list #:default Univ)])
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) (cons #'rest arg-list))
(cond
[(dotted? #'rest)
@ -138,7 +138,7 @@
(extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
(current-tvars))])
(get-type #'rest))])
(get-type #'rest #:default Univ))])
(with-lexical-env/extend
arg-list
arg-types
@ -148,7 +148,7 @@
(match-let ([(tc-result: t thn els) (tc-exprs (syntax->list body))])
(make-arr-dots arg-types t rest-type bound))))))]
[else
(let ([rest-type (get-type #'rest)])
(let ([rest-type (get-type #'rest #:default Univ)])
(with-lexical-env/extend
(cons #'rest arg-list)
(cons (make-Listof rest-type) arg-types)