From 8edd010bec3bea2ab19525b93a426f80c00d75c2 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 11 Feb 2013 16:42:06 -0600
Subject: [PATCH] improve ->'s source location tracking

closes PR 13514
---
 collects/racket/contract/private/arrow.rkt |  7 ++++---
 collects/tests/racket/contract-test.rktl   | 18 ++++++++++++++++++
 2 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 05dfd60371..21a40d933a 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -778,7 +778,7 @@ v4 todo:
                             null
                             (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))])
         (syntax-property
-         (syntax
+         (syntax/loc stx
           (build--> '->
                     #f #f
                     (list dom-ctcs ...) '() #f
@@ -915,7 +915,8 @@ v4 todo:
                              [(rng ...) (generate-temporaries (or rng-ctc '()))]
                              [(this-parameter ...)
                               (make-this-parameters (car (generate-temporaries '(this))))])
-                 #`(build-->
+                 (quasisyntax/loc stx
+                   (build-->
                     '->*
                     #,(if pre #`(λ () #,pre) #'#f)
                     #,(if post #`(λ () #,post) #'#f)
@@ -951,7 +952,7 @@ v4 todo:
                               (syntax->list #'(mandatory-dom-kwd-proj ...)))
                          (map list (syntax->list #'(optional-dom-kwd ...))
                               (syntax->list #'(optional-dom-kwd-proj ...)))
-                         (if rng-ctc (syntax->list #'(rng-proj ...)) #f))))))))))]))
+                         (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))]))
 
 (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
 
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 25b206fc04..da5859324a 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -14852,6 +14852,24 @@ so that propagation occurs.
    'make-proj-contract-4
    '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
 
+  ;; errortrace test
+  (let ()
+    (define sp (open-input-string (format "~s\n" '(-> (λ (a b c) #f) any))))
+    (define stx (read-syntax 'whereitsat sp))
+    (define exn
+      (parameterize ([current-namespace (make-base-namespace)])
+        (namespace-require 'racket/contract)
+        (namespace-require 'errortrace)
+        (with-handlers ((exn:fail? values))
+          (eval stx))))
+    (define sp2 (open-output-string))
+    (parameterize ([current-error-port sp2])
+      ((error-display-handler) (exn-message exn) exn))
+    (test #t 
+          'checking-arrow-src-locs
+          (regexp-match? #rx"whereitsat" (get-output-string sp2))))
+
+  
   (report-errs)
 
 ))