diff --git a/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl b/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl index a39f4d088e..0a498f7eb2 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl @@ -486,16 +486,28 @@ Illegal as an expression form. The @racket[unsyntax-splicing] form is for use only with a @racket[quasisyntax] template.} -@defform[(syntax/loc stx-expr template)]{ +@defform[(syntax/loc stx-expr template) + #:contracts ([stx-expr syntax?])]{ Like @racket[syntax], except that the immediate resulting syntax object takes its source-location information from the result of -@racket[stx-expr] (which must produce a syntax object), unless the -@racket[template] is just a pattern variable, or both the source and -position of @racket[stx-expr] are @racket[#f].} +@racket[stx-expr] (which must produce a syntax object). +Only the source location of the immediate result---the ``outermost'' +syntax object---is adjusted. The source location is @emph{not} +adjusted if both the source and position of @racket[stx-expr] are +@racket[#f]. The source location is adjusted only if the resulting +syntax object comes from the template itself rather than the value of +a syntax pattern variable. For example, if @racket[_x] is a syntax +pattern variable, then @racket[(syntax/loc stx-expr _x)] does not use +the location of @racket[stx-expr]. -@defform[(quasisyntax/loc stx-expr template)]{ +@history[#:changed "6.90.0.25" @elem{Previously, @racket[syntax/loc] +did not enforce the contract on @racket[stx-expr] if @racket[template] +was just a pattern variable.}]} + +@defform[(quasisyntax/loc stx-expr template) + #:contracts ([stx-expr syntax?])]{ Like @racket[quasisyntax], but with source-location assignment like @racket[syntax/loc].} diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index d8f8ae881c..6a2596effd 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2646,6 +2646,26 @@ (with-syntax ([(x ...) #'(4 5 6)]) (syntax->datum #'((~? x) ...)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests for syntax/loc + +(let () + (define (f stx) (list (syntax-source stx) (syntax-position stx))) + (define (same-src? x y) (equal? (syntax-source x) (syntax-source y))) + (define good1 (datum->syntax #f 'good '(source #f #f 1 4))) + (define good3 (datum->syntax #f 'good '(source #f #f #f #f))) + (define good4 (datum->syntax #f 'good '(#f #f #f 1 4))) + (define bad1 (datum->syntax #f 'bad #f)) + (test '(source 1) 'syntax/loc (f (syntax/loc good1 (x)))) + (test '(source #f) 'syntax/loc (f (syntax/loc good3 (x)))) + (test '(#f 1) 'syntax/loc (f (syntax/loc good4 (x)))) + (test #t 'syntax/loc (same-src? (syntax/loc bad1 (x)) (syntax (x)))) + ;; syntax/loc only applies loc to *new* syntax + (with-syntax ([x #'here]) + (test #t 'syntax/loc (same-src? (syntax/loc good1 x) (syntax x)))) + (with-syntax ([(x ...) #'()] [y #'(here)]) + (test #t 'syntax/loc (same-src? (syntax/loc good1 (x ... . y)) (syntax y))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/collects/racket/private/template.rkt b/racket/collects/racket/private/template.rkt index 10fe69c3c3..57f19d9053 100644 --- a/racket/collects/racket/private/template.rkt +++ b/racket/collects/racket/private/template.rkt @@ -596,9 +596,15 @@ (do-template stx (cadr s) #f #f) (raise-syntax-error #f "bad syntax" stx))) +;; check-loc : Symbol Any -> (U Syntax #f) +;; Raise exn if not syntax. Returns same syntax if suitable for srcloc +;; (ie, if at least syntax-source or syntax-position set), #f otherwise. (define (check-loc who x) - (if (syntax? x) x (raise-argument-error who "syntax?" x))) - + (if (syntax? x) + (if (or (syntax-source x) (syntax-position x)) + x + #f) + (raise-argument-error who "syntax?" x))) ;; ============================================================ ;; Run-time support @@ -653,7 +659,7 @@ (define (t-append xs ys) (if (null? ys) xs (append xs ys))) (define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx)) -(define (t-relocate g loc) (datum->syntax g (syntax-e g) loc g)) +(define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g)) (define (t-orelse* g1 g2) ((let/ec escape (with-continuation-mark