Skip to content

Commit

Permalink
Allow various srcloc values in syntax/loc and quasisyntax/loc
Browse files Browse the repository at this point in the history
Fix #1463
  • Loading branch information
sorawee committed Aug 9, 2021
1 parent e19f854 commit 0321945
Show file tree
Hide file tree
Showing 3 changed files with 81 additions and 12 deletions.
20 changes: 17 additions & 3 deletions pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl
Original file line number Diff line number Diff line change
Expand Up @@ -493,7 +493,17 @@ for use only with a @racket[quasisyntax] template.}


@defform[(syntax/loc stx-expr template)
#:contracts ([stx-expr syntax?])]{
#:contracts ([stx-expr (or/c #f srcloc? syntax?
(list/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f))
(vector/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)))])]{

Like @racket[syntax], except that the immediate resulting syntax
object takes its source-location information from the result of
Expand All @@ -510,14 +520,18 @@ the location of @racket[stx-expr].

@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.}]}
was just a pattern variable.}
#:changed "8.2.0.6" @elem{Allows @racket[stx-expr] to be any
source location value that @racket[datum->syntax] accepts.}]}

@defform[(quasisyntax/loc stx-expr template)
#:contracts ([stx-expr syntax?])]{

Like @racket[quasisyntax], but with source-location assignment like
@racket[syntax/loc].}
@racket[syntax/loc].

@history[#:changed "8.2.0.6" @elem{Allows @racket[stx-expr] to be any
source location value that @racket[datum->syntax] accepts.}]}

@defform[(quote-syntax/prune id)]{

Expand Down
13 changes: 11 additions & 2 deletions pkgs/racket-test-core/tests/racket/stx.rktl
Original file line number Diff line number Diff line change
Expand Up @@ -2782,7 +2782,7 @@
(syntax->datum #'((~? x) ...))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for syntax/loc
;; Tests for syntax/loc and quasisyntax/loc

(let ()
(define (f stx) (list (syntax-source stx) (syntax-position stx)))
Expand All @@ -2794,12 +2794,21 @@
(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 '(source 1) 'syntax/loc (f (syntax/loc (srcloc 'source #f #f 1 4) (x))))
(test '(source 1) 'syntax/loc (f (syntax/loc (list 'source #f #f 1 4) (x))))
(test '(source 1) 'syntax/loc (f (syntax/loc (vector 'source #f #f 1 4) (x))))
(test #t 'syntax/loc (same-src? (syntax/loc #f (x)) (syntax (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)))))
(test #t 'syntax/loc (same-src? (syntax/loc good1 (x ... . y)) (syntax y))))

(test '(source 1) 'quasisyntax/loc (f (quasisyntax/loc (srcloc 'source #f #f 1 4) (x))))
(test '(source 1) 'quasisyntax/loc (f (quasisyntax/loc (list 'source #f #f 1 4) (x))))
(test '(source 1) 'quasisyntax/loc (f (quasisyntax/loc (vector 'source #f #f 1 4) (x))))
(test #t 'quasisyntax/loc (same-src? (quasisyntax/loc #f (x)) (syntax (x)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Expand Down
60 changes: 53 additions & 7 deletions racket/collects/racket/private/template.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -582,15 +582,61 @@
(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
(define (check-option pred x)
(if x (pred x) #t))

;; check-loc : Symbol Any -> (U Syntax
;; (List Any (Option Pos) (Option Nonneg) (Option Pos) (Option Nonneg))
;; (Vector Any (Option Pos) (Option Nonneg) (Option Pos) (Option Nonneg))
;; Srcloc
;; #f)
;; Raise exn if not srcloc-like value. 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)
(if (or (syntax-source x) (syntax-position x))
x
#f)
(raise-argument-error who "syntax?" x)))
(cond
[(not x) x]
[(srcloc? x) (if (or (srcloc-source x) (srcloc-position x))
x
#f)]
[(syntax? x) (check-loc who (syntax-srcloc x))]
[(and (list? x)
(= (length x) 5)
(check-option exact-positive-integer? (list-ref x 1))
(check-option exact-nonnegative-integer? (list-ref x 2))
(check-option exact-positive-integer? (list-ref x 3))
(check-option exact-nonnegative-integer? (list-ref x 4)))
(check-loc who (srcloc (list-ref x 0)
(list-ref x 1)
(list-ref x 2)
(list-ref x 3)
(list-ref x 4)))]
[(and (vector? x)
(= (vector-length x) 5)
(check-option exact-positive-integer? (vector-ref x 1))
(check-option exact-nonnegative-integer? (vector-ref x 2))
(check-option exact-positive-integer? (vector-ref x 3))
(check-option exact-nonnegative-integer? (vector-ref x 4)))
(check-loc who (srcloc (vector-ref x 0)
(vector-ref x 1)
(vector-ref x 2)
(vector-ref x 3)
(vector-ref x 4)))]
[else
(raise-argument-error
who
(string-append "(or/c #f srcloc? syntax?\n"
" (list/c any/c\n"
" (or/c exact-positive-integer? #f)\n"
" (or/c exact-nonnegative-integer? #f)\n"
" (or/c exact-positive-integer? #f)\n"
" (or/c exact-nonnegative-integer? #f))\n"
" (vector/c any/c\n"
" (or/c exact-positive-integer? #f)\n"
" (or/c exact-nonnegative-integer? #f)\n"
" (or/c exact-positive-integer? #f)\n"
" (or/c exact-nonnegative-integer? #f)))")
x)]))

;; ============================================================
;; Run-time support
Expand Down

0 comments on commit 0321945

Please sign in to comment.