From 3c5ed5d8e12c8c28715be69454e19909c1a01704 Mon Sep 17 00:00:00 2001
From: Alex Knauth <alexander@knauth.org>
Date: Tue, 9 Jun 2015 10:57:45 -0400
Subject: [PATCH] syntax-parse: keep more srclocs in attribute bindings

to cooperate more with DrRacket check-syntax arrows
---
 .../syntax/parse/private/rep-data.rkt         | 21 +++++++++++++++++--
 racket/collects/syntax/parse/private/rep.rkt  |  7 +++++--
 2 files changed, 24 insertions(+), 4 deletions(-)

diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt
index 8b9b449bdc..977cc57bf5 100644
--- a/racket/collects/syntax/parse/private/rep-data.rkt
+++ b/racket/collects/syntax/parse/private/rep-data.rkt
@@ -286,10 +286,20 @@ expressions are duplicated, and may be evaluated in different scopes.
   (cond [(and (stxclass-colon-notation?)
               (regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))))
          => (lambda (m)
+              (define-values [src ln col pos span]
+                (syntax-srcloc-values id0))
+              (define id-str (cadr m))
+              (define id-len (string-length id-str))
+              (define suffix-str (caddr m))
+              (define suffix-len (string-length suffix-str))
               (define id
-                (datum->syntax id0 (string->symbol (cadr m)) id0 id0))
+                (datum->syntax id0 (string->symbol id-str)
+                  (list src ln col pos id-len)
+                  id0))
               (define suffix
-                (datum->syntax id0 (string->symbol (caddr m)) id0 id0))
+                (datum->syntax id0 (string->symbol suffix-str)
+                  (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len)
+                  id0))
               (declenv-check-unbound decls id (syntax-e suffix)
                                      #:blame-declare? #t)
               (let ([suffix-entry (declenv-lookup decls suffix)])
@@ -300,6 +310,13 @@ expressions are duplicated, and may be evaluated in different scopes.
                          (values id sc))])))]
         [else (values id0 #f)]))
 
+(define (syntax-srcloc-values stx)
+  (values (syntax-source stx)
+          (syntax-line stx)
+          (syntax-column stx)
+          (syntax-position stx)
+          (syntax-span stx)))
+
 ;; ----
 
 (provide get-eh-alternative-set)
diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt
index b2a651b4e7..a1aaf36230 100644
--- a/racket/collects/syntax/parse/private/rep.rkt
+++ b/racket/collects/syntax/parse/private/rep.rkt
@@ -812,7 +812,7 @@
 (define (name->prefix id pfx)
   (cond [(wildcard? id) #f]
         [(epsilon? id) id]
-        [else (format-id id "~a~a" (syntax-e id) pfx)]))
+        [else (format-id id "~a~a" (syntax-e id) pfx #:source id)]))
 
 (define (name->bind id)
   (cond [(wildcard? id) #f]
@@ -834,7 +834,10 @@
 
 ;; prefix-attr-name : id symbol -> id
 (define (prefix-attr-name prefix name)
-  (format-id prefix "~a~a" (syntax-e prefix) name))
+  (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix)))
+
+(define (orig stx)
+  (syntax-property stx 'original-for-check-syntax #t))
 
 ;; ----