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

Control multiple errors with a parameter.

Browse Source 
Don't use same code for handling type ascription and annotation.

svn: r9529
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-29 01:42:07 +00:00
parent 2837df70a6
commit 1d21ec5dda
3 changed files with 28 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/typed-scheme/private/tc-expr-unit.ss
View File

@ -78,9 +78,7 @@
ty (Poly-n ty) (length (syntax->list inst)))]
[else
(let ([ty* (if inst
(begin
(printf/log "Type Instantiation: ~a~n" (syntax-e id))
(instantiate-poly ty (map parse-type (syntax->list inst))))
(instantiate-poly ty (map parse-type (syntax->list inst)))
ty)])
(ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))])))
@ -142,7 +140,8 @@
[(#%variable-reference . _)
(tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")]
;; identifiers
[x (identifier? #'x) (check-below (tc-id #'x) expected)]
[x (identifier? #'x)
(check-below (tc-id #'x) expected)]
;; w-c-m
[(with-continuation-mark e1 e2 e3)
(begin (tc-expr/check #'e1 Univ)
@ -277,8 +276,7 @@
(unless (syntax? form)
(int-err "bad form input to tc-expr: ~a" form))
;; typecheck form
(cond [(type-annotation form) => (lambda (ann)
;(printf "annotated~n")
(cond [(type-ascription form) => (lambda (ann)
(tc-expr/check form ann))]
[else (internal-tc-expr form)])))

6
collects/typed-scheme/private/tc-utils.ss
View File

@ -55,8 +55,12 @@
(unless (null? stxs)
(raise-typecheck-error "Errors encountered" (apply append stxs))))]))
(define delay-errors? (make-parameter #t))
(define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest)
(set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors)))
(if (delay-errors?)
(set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors))
(raise-typecheck-error (apply format msg rest) (list (locate-stx stx)))))
;; produce a type error, using the current syntax
(define (tc-error msg . rest)

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

@ -8,6 +8,7 @@
get-type/infer
type-label-symbol
type-ascrip-symbol
type-ascription
check-type)
(define type-label-symbol 'type-label)
@ -23,7 +24,7 @@
;; get the type annotation of this syntax
;; syntax -> Maybe[Type]
(define (type-annotation stx)
(define (type-annotation stx #:infer [let-binding #f])
(define (pt prop)
(print-size prop)
(if (syntax? prop)
@ -32,13 +33,24 @@
(cond
[(syntax-property stx type-label-symbol) => pt]
[(syntax-property stx type-ascrip-symbol) => pt]
[(and (identifier? stx) (lookup-type stx (lambda () #f)))
;; this is so that : annotation works in internal def ctxts
[(and let-binding (identifier? stx) (lookup-type stx (lambda () #f)))
=>
(lambda (t)
(maybe-finish-register-type stx)
t)]
[else #f]))
(define (type-ascription stx)
(define (pt prop)
(print-size prop)
(if (syntax? prop)
(parse-type prop)
(parse-type/id stx prop)))
(cond
[(syntax-property stx type-ascrip-symbol) => pt]
[else #f]))
(define (log/ann stx ty)
(printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty))
(define (log/extra stx ty ty2)
@ -72,10 +84,11 @@
[else (log/noann stx ty) ty]))
stx ty)]
[(list (list stx) ty)
(cond [(type-annotation stx) => (lambda (ann)
(check-type stx ty ann)
(log/extra stx ty ann)
(list ann))]
(cond [(type-annotation stx #:infer #t)
=> (lambda (ann)
(check-type stx ty ann)
(log/extra stx ty ann)
(list ann))]
[else (log/noann stx ty) (list ty)])]
[else (int-err "wrong type arity - get-type/infer ~a ~a" stxs e-type)]))