Report more information for untyped imported identifiers

svn: r14418

original commit: 2aab5762370806fb648694cbbd6cb1c44ba2fc83
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-03 22:42:29 +00:00
parent 35a67354ca
commit 7b70ced131
5 changed files with 25 additions and 5 deletions

View File

@ -0,0 +1,7 @@
#;
(exn-pred ".*untyped identifier map.*" ".*srfi.*")
#lang typed-scheme
(require srfi/1)
map

View File

@ -33,7 +33,7 @@
=>
(lambda (a)
(-lst (substitute Univ (cdr a) (car a))))]
[else (lookup-fail (syntax-e i))]))))))
[else (lookup-fail i)]))))))
;; refine the type of i in the lexical env
;; (identifier type -> type) identifier -> environment

View File

@ -39,7 +39,7 @@
;; given an identifier, return the type associated with it
;; if none found, calls lookup-fail
;; identifier -> type
(define (lookup-type id [fail-handler (lambda () (lookup-fail (syntax-e id)))])
(define (lookup-type id [fail-handler (lambda () (lookup-type-fail id))])
(let ([v (module-identifier-mapping-get the-mapping id fail-handler)])
(if (box? v) (unbox v) v)))

View File

@ -35,7 +35,7 @@
;; given an identifier, return the type associated with it
;; optional argument is failure continuation - default calls lookup-fail
;; identifier (-> error) -> type
(define (lookup-type-name id [k (lambda () (lookup-fail (syntax-e id)))])
(define (lookup-type-name id [k (lambda () (lookup-type-fail id))])
(begin0
(module-identifier-mapping-get the-mapping id k)
(add-type-name-reference id)))

View File

@ -29,7 +29,8 @@
(struct-out DottedBoth)
just-Dotted?
tc-error/expr
lookup-fail)
lookup-fail
lookup-type-fail)
;; substitute : Type Name Type -> Type
@ -218,4 +219,16 @@
return)
;; error for unbound variables
(define (lookup-fail e) (tc-error/expr "unbound identifier ~a" e))
(define (lookup-fail e)
(match (identifier-binding e)
['lexical (int-err "untyped lexical variable ~a" (syntax-e e))]
[#f (int-err "untyped top-level variable ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])
(cond [(and (not x) (not y))
(tc-error/expr "untyped identifier ~a" (syntax-e e))]
[else
(tc-error/expr "untyped identifier ~a imported from module <~a>" (syntax-e e) x)]))]))
(define (lookup-type-fail i)
(tc-error/expr "~a is not bound as a type" (syntax-e i)))