From 2011272c06d649591f6a18ac4c015eccb12727c1 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Sat, 7 Nov 2009 02:07:16 +0000
Subject: [PATCH] Fixed source locations for `term' and `term-let' errors.

svn: r16592
---
 collects/redex/private/term-test.ss | 61 ++++++++++++++++++++++++++++-
 collects/redex/private/term.ss      | 14 +++----
 2 files changed, 67 insertions(+), 8 deletions(-)

diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss
index 81ab570a52..fa35933612 100644
--- a/collects/redex/private/term-test.ss
+++ b/collects/redex/private/term-test.ss
@@ -1,7 +1,9 @@
 (module term-test scheme
   (require "term.ss"
            "matcher.ss"
-           "test-util.ss")
+           "test-util.ss"
+           errortrace/errortrace-lib
+           errortrace/errortrace-key)
   
   (reset-count)
   (test (term 1) 1)
@@ -99,5 +101,62 @@
                      (term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
                                (term ((f x ...) ...))))
         '(3 12 6))
+
+  (define-namespace-anchor here)
+  (define ns (namespace-anchor->namespace here))
+  
+  (define (runtime-error-source sexp src)
+    (let/ec return
+      (cadar
+       (continuation-mark-set->list
+        (exn-continuation-marks
+         (with-handlers ((exn:fail? values))
+           (parameterize ([current-namespace ns])
+             (parameterize ([current-compile (make-errortrace-compile-handler)])
+               (eval (read-syntax src (open-input-string (format "~s" sexp))))))
+           (return 'no-source)))
+        errortrace-key))))
+  
+  (let ([src 'term-template])
+    (test
+     (runtime-error-source
+      '(term-let ([(x ...) '(a b c)]
+                  [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
+                 (term (((x y) ...) ...)))
+      src)
+     src))
+  
+  (let ([src 'term-template-metafunc])
+    (test
+     (runtime-error-source 
+      '(term-let-fn ((f car))
+                    (term-let ([(x ...) '(a b c)]
+                               [((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
+                              (term ((((f x) y) ...) ...))))
+      src)
+     src))
+  
+  (let ([src 'term-let-rhs])
+    (test
+     (runtime-error-source
+      '(term-let ([(x ...) 'a])
+                 3)
+      src)
+     src))
+  
+  (define (syntax-error-sources sexp src)
+    (let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
+      (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
+        (parameterize ([current-namespace ns])
+          (expand p))
+        null)))
+  
+  (let ([src 'term-template])
+    (test 
+     (syntax-error-sources
+      '(term-let ([(x ...) '(a b c)])
+                 (term x))
+      src)
+     (list src)))
   
   (print-tests-passed 'term-test.ss))
diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss
index cc6482a45a..af222ed97f 100644
--- a/collects/redex/private/term.ss
+++ b/collects/redex/private/term.ss
@@ -65,7 +65,8 @@
        (and (identifier? (syntax x))
             (term-id? (syntax-local-value (syntax x) (λ () #f))))
        (let ([id (syntax-local-value/catch (syntax x) (λ (x) #t))])
-         (values (term-id-id id) (term-id-depth id)))]
+         (values (datum->syntax (term-id-id id) (syntax-e (term-id-id id)) (syntax x))
+                 (term-id-depth id)))]
       [(unquote x)
        (values (syntax (unsyntax x)) 0)]
       [(unquote . x)
@@ -101,10 +102,7 @@
                                           (i-loop (cdr xs))])
                               (values (cons fst rst)
                                       (max fst-max-depth rst-max-depth))))]))])
-         
-         (with-syntax ([x-rewrite x-rewrite])
-           (values (syntax/loc stx x-rewrite)
-                   max-depth)))]
+         (values (datum->syntax stx x-rewrite stx) max-depth))]
       
       [_ (values stx 0)]))
   
@@ -180,13 +178,15 @@
        (with-syntax ([(orig-names ...) orig-names]
                      [(new-names ...) new-names]
                      [(depths ...) depths]
-                     [new-x1 new-x1])
+                     [new-x1 new-x1]
+                     [no-match (syntax/loc (syntax rhs1)
+                                 (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1))])
          (syntax
           (syntax-case rhs1 ()
             [new-x1 
              (let-syntax ([orig-names (make-term-id #'new-names (syntax-e #'depths))] ...)
                (term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
-            [_ (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1)]))))]
+            [_ no-match]))))]
     [(_ error-name () body1 body2 ...)
      (syntax
       (begin body1 body2 ...))]