From 2aab5762370806fb648694cbbd6cb1c44ba2fc83 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 3 Apr 2009 22:42:29 +0000 Subject: [PATCH] Report more information for untyped imported identifiers svn: r14418 --- .../tests/typed-scheme/fail/untyped-srfi1.ss | 7 +++++++ collects/typed-scheme/env/lexical-env.ss | 2 +- collects/typed-scheme/env/type-env.ss | 2 +- collects/typed-scheme/env/type-name-env.ss | 2 +- collects/typed-scheme/private/type-utils.ss | 17 +++++++++++++++-- 5 files changed, 25 insertions(+), 5 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/untyped-srfi1.ss diff --git a/collects/tests/typed-scheme/fail/untyped-srfi1.ss b/collects/tests/typed-scheme/fail/untyped-srfi1.ss new file mode 100644 index 0000000000..3a4ec74c09 --- /dev/null +++ b/collects/tests/typed-scheme/fail/untyped-srfi1.ss @@ -0,0 +1,7 @@ +#; +(exn-pred ".*untyped identifier map.*" ".*srfi.*") +#lang typed-scheme + +(require srfi/1) + +map diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 63a1295b76..9ade4f0a67 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -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 diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index 59eb3cad7e..fd2b65db49 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -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))) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index 2fc2c9007d..f5656c13be 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -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))) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index 0617aa0f86..510273a2ce 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -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)))