diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index d6773f0e..2fc2c900 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -3,12 +3,15 @@ (require syntax/boundmap mzlib/trace + (env type-alias-env) (utils tc-utils) + (rep type-rep) (private type-utils)) (provide register-type-name lookup-type-name register-type-names + add-alias type-name-env-map) ;; a mapping from id -> type (where id is the name of the type) @@ -42,3 +45,7 @@ ;; (id type -> T) -> listof[T] (define (type-name-env-map f) (module-identifier-mapping-map the-mapping f)) + +(define (add-alias from to) + (when (lookup-type-name to (lambda () #f)) + (register-resolved-type-alias from (make-Name to)))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index d3fb28c9..791d6384 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -3,6 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (only-in srfi/1/list s:member) syntax/kerncase syntax/boundmap + (env type-name-env type-alias-env) mzlib/trace (private type-contract) (rep type-rep) @@ -73,7 +74,9 @@ #`(begin (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) + (begin + (add-alias #'export-id #'id) + (make-rename-transformer #'id)) (lambda (stx) (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) (provide (rename-out [export-id out-id]))))))] diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index b95c06da..207e34d7 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -132,11 +132,13 @@ (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) null))) (register-type-name nm (wrapper sty)) - (for/list ([e bindings]) - (let ([nm (car e)] - [t (cdr e)]) - (register-type nm t) - (make-def-binding nm t)))) + (cons + (make-def-stx-binding nm) + (for/list ([e bindings]) + (let ([nm (car e)] + [t (cdr e)]) + (register-type nm t) + (make-def-binding nm t))))) ;; check and register types for a polymorphic define struct ;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void