From cee4566ed4644ecad5dd444d51a9e221c3ad79cd Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 16 Aug 2011 19:17:50 -0500 Subject: [PATCH] Makes test work when compilation strips source locations --- collects/redex/tests/check-syntax-test.rkt | 43 ++++++++++++++-------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/collects/redex/tests/check-syntax-test.rkt b/collects/redex/tests/check-syntax-test.rkt index d0fd3f51be..357fd0c3a3 100644 --- a/collects/redex/tests/check-syntax-test.rkt +++ b/collects/redex/tests/check-syntax-test.rkt @@ -7,6 +7,19 @@ (reset-count) +(define-syntax (identifier stx) + (syntax-case stx () + [(_ x) + (identifier? #'x) + #`(let ([p (open-input-string (format "~s" 'x))]) + (port-count-lines! p) + (set-port-next-location! + p + #,(syntax-line #'x) + #,(syntax-column #'x) + #,(syntax-position #'x)) + (read-syntax '#,(syntax-source #'x) p))])) + (define (source stx) (list (syntax-source stx) (syntax-line stx) @@ -64,15 +77,15 @@ (define-values (add-syntax done) (make-traversal module-namespace #f)) - (define language-def-name #'L) - (define language-use-name #'L) + (define language-def-name (identifier L)) + (define language-use-name (identifier L)) - (define mode-name #'J) - (define contract-name #'J) - (define conclusion-name #'J) - (define premise-name #'J) - (define render-name #'J) - (define holds-name #'J) + (define mode-name (identifier J)) + (define contract-name (identifier J)) + (define conclusion-name (identifier J)) + (define premise-name (identifier J)) + (define render-name (identifier J)) + (define holds-name (identifier J)) (define language-binding (list language-def-name language-use-name)) @@ -106,14 +119,14 @@ (define-values (add-syntax done) (make-traversal module-namespace #f)) - (define language-def-name #'L) - (define language-use-name #'L) + (define language-def-name (identifier L)) + (define language-use-name (identifier L)) - (define contract-name #'f) - (define lhs-name #'f) - (define rhs-name #'f) - (define render-name #'f) - (define term-name #'f) + (define contract-name (identifier f)) + (define lhs-name (identifier f)) + (define rhs-name (identifier f)) + (define render-name (identifier f)) + (define term-name (identifier f)) (define language-binding (list language-def-name language-use-name))