From 11f325e1c685fd0d941661bddfdb4becffdc85ff Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 10 Mar 2009 20:29:02 +0000
Subject: [PATCH] Correctly report syntax def from define-struct: Add alias in
 type env when rename transformer is used.

svn: r14034

original commit: 79ee9fbee8868a4f5911356d2c1d2a9b0d7fd016
---
 collects/typed-scheme/env/type-name-env.ss          |  7 +++++++
 collects/typed-scheme/typecheck/provide-handling.ss |  5 ++++-
 collects/typed-scheme/typecheck/tc-structs.ss       | 12 +++++++-----
 3 files changed, 18 insertions(+), 6 deletions(-)

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