diff --git a/collects/syntax/module-reader.rkt b/collects/syntax/module-reader.rkt index 953e7983db2..04420453487 100644 --- a/collects/syntax/module-reader.rkt +++ b/collects/syntax/module-reader.rkt @@ -188,7 +188,7 @@ [body (wrap-module-begin body)] [all-loc (vector src line col pos (let-values ([(l c p) (port-next-location port)]) - (and p (- p pos))))] + (and p pos (- p pos))))] [p-name (object-name port)] [name (if (path? p-name) (let-values ([(base name dir?) (split-path p-name)]) @@ -199,9 +199,9 @@ (if stx? (datum->syntax #f v (vector src line col pos - (- (or (syntax-position modpath) - (add1 pos)) - pos))) + (and pos (- (or (syntax-position modpath) + (add1 pos)) + pos)))) v))] [r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)]) (if stx? (datum->syntax #f r all-loc) r))) diff --git a/collects/tests/syntax/module-reader-synthetic-pos.rkt b/collects/tests/syntax/module-reader-synthetic-pos.rkt new file mode 100644 index 00000000000..300e6fe182d --- /dev/null +++ b/collects/tests/syntax/module-reader-synthetic-pos.rkt @@ -0,0 +1,109 @@ +#lang racket/base + +;; Playing with input-port-append and transplant-input-port, +;; with the idea of adding the #lang line for arbitrary text +;; without screwing up the original input port's locations. +(provide prepend-lang-line) + +(require racket/port) + +;; prepend-lang-line: string input-port -> input-port +;; Prepends the lang line to the input port. +(define (prepend-lang-line lang-line ip) + (define lang-ip (open-input-string lang-line)) + (port-count-lines! ip) + (port-count-lines! lang-ip) + (define concatenated-port (input-port-append #f lang-ip ip)) + (port-count-lines! concatenated-port) + + (define (get-location) + (define-values (line column position) (port-next-location concatenated-port)) + (cond [(<= position (string-length lang-line)) + (values #f #f #f)] + [else + (values (and line (sub1 line)) + column + (and position (- position (string-length lang-line))))])) + + (define transplanted-port + (transplant-input-port concatenated-port get-location 1 #f)) + (port-count-lines! transplanted-port) + transplanted-port) + +(module* test racket/base + (require (submod "..") + rackunit + syntax/parse + (for-syntax racket/base syntax/parse)) + + (define-syntax (check-position stx) + (syntax-parse stx + [(_ source-stx + #:source source + #:line line + #:column column + #:position position + #:span span) + (let ([syntax-loc-info (lambda (s) + (quasisyntax (list + (make-check-location + (list #,(syntax-source s) + #,(syntax-line s) + #,(syntax-column s) + #,(syntax-position s) + #,(syntax-span s))))))]) + (quasisyntax/loc stx + (let ([stx-v source-stx]) + (with-check-info* #,(syntax-loc-info #'source) + (lambda () + (check-equal? (syntax-source stx-v) source))) + (with-check-info* #,(syntax-loc-info #'line) + (lambda () (check-equal? (syntax-line stx-v) line))) + (with-check-info* #,(syntax-loc-info #'column) + (lambda () (check-equal? (syntax-column stx-v) column))) + (with-check-info* #,(syntax-loc-info #'position) + (lambda () (check-equal? (syntax-position stx-v) position))) + (with-check-info* #,(syntax-loc-info #'span) + (lambda () (check-equal? (syntax-span stx-v) span))))))])) + + (define an-input-port + (prepend-lang-line "#lang racket\n" + (open-input-string "(+ 1\n 2 three)\n"))) + + (define the-stx + (parameterize ([read-accept-reader #t]) + (read-syntax 'my-source an-input-port))) + + (syntax-parse the-stx + [(m n l (#%mb (~and (plus ONE TWO THREE) + papp))) + (check-position #'papp + #:source 'my-source + #:line 1 + #:column 0 + #:position 1 + #:span 14) + (check-position #'plus + #:source 'my-source + #:line 1 + #:column 1 + #:position 2 + #:span 1) + (check-position #'ONE + #:source 'my-source + #:line 1 + #:column 3 + #:position 4 + #:span 1) + (check-position #'TWO + #:source 'my-source + #:line 2 + #:column 1 + #:position 7 + #:span 1) + (check-position #'THREE + #:source 'my-source + #:line 2 + #:column 3 + #:position 9 + #:span 5)]))