diff --git a/collects/tests/unstable/syntax.rkt b/collects/tests/unstable/syntax.rkt index 2804963ee0..2c4974906f 100644 --- a/collects/tests/unstable/syntax.rkt +++ b/collects/tests/unstable/syntax.rkt @@ -54,4 +54,21 @@ (test-case "identifier" (check bound-identifier=? (with-syntax* ([a #'id] [b #'a]) #'b) - #'id)))))) + #'id)))) + + (test-suite "syntax-within?" + (let* ([a #'a] + [b #'b] + [c #'(a b c)] + [c1 (car (syntax->list c))] + [c2 (cadr (syntax->list c))]) + (test-case "reflexive" + (check-equal? (syntax-within? a a) #t)) + (test-case "unrelated" + (check-equal? (syntax-within? a b) #f)) + (test-case "child" + (check-equal? (syntax-within? c1 c) #t)) + (test-case "parent" + (check-equal? (syntax-within? c c1) #f)) + (test-case "sibling" + (check-equal? (syntax-within? c2 c1) #f)))))) diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 2fcab2e2ec..ec15246327 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -34,7 +34,7 @@ resolved module path or @racket[#f] for the ``self'' module. @;{----} -@margin-note{This binding was added by Vincent St-Amour.} +@addition{@author+email["Vincent St-Amour" "stamourv@racket-lang.org"]} @defproc[(format-unique-id [lctx (or/c syntax? #f)] [fmt string?] [v (or/c string? symbol? identifier? keyword? char? number?)] ... @@ -44,6 +44,11 @@ resolved module path or @racket[#f] for the ``self'' module. identifier?]{ Like @racket[format-id], but returned identifiers are guaranteed to be unique. } +@defproc[(syntax-within? [a syntax?] [b syntax?]) + boolean?]{ +Returns true is syntax @racket[a] is within syntax @racket[b] in the source. +Bounds are inclusive. +} @;{----} diff --git a/collects/unstable/syntax.rkt b/collects/unstable/syntax.rkt index 44d9810efa..bb0ff6b23a 100644 --- a/collects/unstable/syntax.rkt +++ b/collects/unstable/syntax.rkt @@ -12,6 +12,7 @@ ;; by stamourv: format-unique-id + syntax-within? ;; by ryanc explode-module-path-index) @@ -62,6 +63,17 @@ lctx #:source src #:props props #:cert cert fmt args))) +;; is syntax a contained within syntax b, inclusively +(define (syntax-within? a b) + (let ([pos-a (syntax-position a)] + [span-a (syntax-span a)] + [pos-b (syntax-position b)] + [span-b (syntax-span b)]) + (and pos-a span-a pos-b span-b + (<= pos-b pos-a) + (>= (+ pos-b span-b) (+ pos-a span-a))))) + + ;; by ryanc (define (explode-module-path-index mpi)