From 7abbff4749dbe79a6ad80a4d4f14ff289a462585 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 19 Aug 2010 07:37:47 -0600
Subject: [PATCH] adjust rename-transformer expansion to transfer srcloc of use
 to expansion

---
 src/racket/src/env.c     |  3 ++-
 src/racket/src/eval.c    | 11 ++++++-----
 src/racket/src/schpriv.h |  2 ++
 src/racket/src/stxobj.c  | 34 ++++++++++++++++++++++++++++++++++
 4 files changed, 44 insertions(+), 6 deletions(-)

diff --git a/src/racket/src/env.c b/src/racket/src/env.c
index 660bb9ceb3..dbb94167bc 100644
--- a/src/racket/src/env.c
+++ b/src/racket/src/env.c
@@ -4711,7 +4711,8 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
     v = SCHEME_PTR_VAL(v);
     if (scheme_is_rename_transformer(v)) {
       sym = scheme_rename_transformer_id(v);
-      sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1);
+      sym = scheme_transfer_srcloc(scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1),
+                                   v);
       renamed = 1;
       menv = NULL;
       SCHEME_USE_FUEL(1);
diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c
index 24c9bab96e..0b3d616ab4 100644
--- a/src/racket/src/eval.c
+++ b/src/racket/src/eval.c
@@ -6577,8 +6577,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
       } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
         if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
           /* It's a rename. Look up the target name and try again. */
-          name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), 
-                                 scheme_false, menv, name, NULL, 1);
+          name = scheme_transfer_srcloc(scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), 
+                                                        scheme_false, menv, name, NULL, 1),
+                                        name);
           menv = NULL;
           SCHEME_USE_FUEL(1);
         } else {
@@ -6782,7 +6783,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 	    new_name = scheme_stx_track(new_name, find_name, find_name);
 	  }
 	  new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
-	  find_name = new_name;
+	  find_name = scheme_transfer_srcloc(new_name, find_name);
 	  SCHEME_USE_FUEL(1);
 	  menv = NULL;
 	  protected = 0;
@@ -6899,7 +6900,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 	    new_name = scheme_stx_track(new_name, find_name, find_name);
 	  }
 	  new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
-	  find_name = new_name;
+          find_name = scheme_transfer_srcloc(new_name, find_name);
 	  SCHEME_USE_FUEL(1);
 	  menv = NULL;
 	} else
@@ -6986,7 +6987,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 	  new_name = scheme_stx_track(new_name, find_name, find_name);
 	}
 	new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
-	find_name = new_name;
+        find_name = scheme_transfer_srcloc(new_name, find_name);
 	SCHEME_USE_FUEL(1);
 	menv = NULL;
       } else
diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h
index 172400e209..fd5e7b6901 100644
--- a/src/racket/src/schpriv.h
+++ b/src/racket/src/schpriv.h
@@ -1023,6 +1023,8 @@ XFORM_NONGCING Scheme_Object *scheme_phase_index_symbol(int src_phase_index);
 Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht);
 void scheme_populate_pt_ht(struct Scheme_Module_Phase_Exports * pt);
 
+Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from);
+
 /*========================================================================*/
 /*                   syntax run-time structures                           */
 /*========================================================================*/
diff --git a/src/racket/src/stxobj.c b/src/racket/src/stxobj.c
index 9984e9e456..c9d682bd9a 100644
--- a/src/racket/src/stxobj.c
+++ b/src/racket/src/stxobj.c
@@ -8855,6 +8855,40 @@ static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv)
   return scheme_stx_track(argv[0], argv[1], argv[2]);
 }
 
+Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from)
+{
+  if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) {
+    Scheme_Stx *stx = (Scheme_Stx *)to;
+    Scheme_Object *wraps, *modinfo_cache;
+    Scheme_Object *certs;
+    long lazy_prefix;
+
+    wraps = stx->wraps;
+    if (STX_KEY(stx) & STX_SUBSTX_FLAG) {
+      modinfo_cache = NULL;
+      lazy_prefix = stx->u.lazy_prefix;
+    } else {
+      modinfo_cache = stx->u.modinfo_cache;
+      lazy_prefix = 0;
+    }
+    certs = stx->certs;
+
+    stx = (Scheme_Stx *)scheme_make_stx(stx->val, 
+                                        ((Scheme_Stx *)from)->srcloc,
+                                        stx->props);
+
+    stx->wraps = wraps;
+    if (modinfo_cache)
+      stx->u.modinfo_cache = modinfo_cache;
+    else
+      stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */
+    stx->certs = certs;
+
+    return (Scheme_Object *)stx;
+  } else
+    return to;
+}
+
 static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p)
 {
   Scheme_Object *r, *delta;