From ecc1facdaa8b8440707c4d567485efcf3203af96 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 12 Dec 2013 16:51:03 -0600
Subject: [PATCH] improve source locations for uses of contracted variables

---
 .../racket/contract/private/provide.rkt        | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt
index 6fd365b10e..6548725807 100644
--- a/racket/collects/racket/contract/private/provide.rkt
+++ b/racket/collects/racket/contract/private/provide.rkt
@@ -83,6 +83,8 @@
                             #'(quote-module-name))))])
                 (when key (hash-set! saved-id-table key lifted-neg-party))
                 ;; Expand to a use of the lifted expression:
+                (define (adjust-location new-stx)
+                  (datum->syntax new-stx (syntax-e new-stx) stx new-stx))
                 (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
                   (syntax-case stx (set!)
                     [name 
@@ -94,7 +96,7 @@
                                  (syntax-local-lift-expression
                                   #'(partially-applied-id lifted-neg-party))))])
                        (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
-                       (syntax-local-introduce lifted-ctc-val))]
+                       (adjust-location (syntax-local-introduce lifted-ctc-val)))]
                     [(set! id arg)
                      (raise-syntax-error
                       'contract/out
@@ -102,9 +104,10 @@
                       stx #'id)]
                     [(name more ...)
                      (with-syntax ([app (datum->syntax stx '#%app)])
-                       #'(app extra-neg-party-argument-fn 
-                              lifted-neg-party
-                              more ...))])))
+                       (adjust-location
+                        #'(app extra-neg-party-argument-fn 
+                               lifted-neg-party
+                               more ...)))])))
               ;; In case of partial expansion for module-level and internal-defn
               ;; contexts, delay expansion until it's a good time to lift
               ;; expressions:
@@ -128,12 +131,14 @@
                            (syntax-local-lift-expression
                             #'(partially-applied-id (quote-module-name)))))])
                 (when key (hash-set! saved-id-table key lifted-ctcd-val))
+                (define (adjust-location new-stx)
+                  (datum->syntax new-stx (syntax-e new-stx) stx new-stx))
                 ;; Expand to a use of the lifted expression:
                 (with-syntax ([lifted-ctcd-val (syntax-local-introduce lifted-ctcd-val)])
                   (syntax-case stx (set!)
                     [name 
                      (identifier? #'name)
-                     #'lifted-ctcd-val]
+                     (adjust-location #'lifted-ctcd-val)]
                     [(set! id arg)
                      (raise-syntax-error
                       'contract/out
@@ -141,7 +146,8 @@
                       stx #'id)]
                     [(name more ...)
                      (with-syntax ([app (datum->syntax stx '#%app)])
-                       #'(app lifted-ctcd-val more ...))])))
+                       (adjust-location 
+                        #'(app lifted-ctcd-val more ...)))])))
               ;; In case of partial expansion for module-level and internal-defn
               ;; contexts, delay expansion until it's a good time to lift
               ;; expressions: