diff --git a/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl
index 6bb8a592b0..1d587a8283 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl
@@ -20,6 +20,7 @@ Defines a macro named @racket[macro-id]; equivalent to the following:
@racketblock[
(define-syntax (macro-id stx)
(syntax-parse stx
+ #:track-literals
[((~var macro-id id) . pattern) pattern-directive ... (syntax template)]))
]
@@ -41,7 +42,9 @@ Defines a macro named @racket[macro-id]; equivalent to the following:
@history[#:changed "6.12.0.3" @elem{Changed pattern head to @racket[(~var macro-id id)] from
@racket[macro-id], allowing tilde-prefixed identifiers or
identifiers containing colons to be used as @racket[macro-id]
- without producing a syntax error.}]
+ without producing a syntax error.}
+ #:changed "6.90.0.29" @elem{Changed to always use the @racket[#:track-literals]
+ @racket[syntax-parse] option.}]
}
@defform[(define-syntax-parser macro-id parse-option ... clause ...+)]{
diff --git a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
index c489bca67c..bf75ab7e2f 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
@@ -73,7 +73,15 @@ When used outside of the dynamic extent of a macro transformer (see
@racket[syntax-transforming?]), matching fails.
The attribute @var[value] contains the value the name is bound to.
-}
+
+If matching succeeds, @racket[static] additionally adds the matched identifier
+to the current @racket[syntax-parse] state under the key @racket['literals]
+using @racket[syntax-parse-state-cons!], in the same way as identifiers matched
+using @racket[#:literals] or @racket[~literal].
+
+@history[#:changed "6.90.0.29"
+ @elem{Changed to add matched identifiers to the @racket[syntax-parse]
+ state under the key @racket['literals].}]}
@defstxclass[(expr/c [contract-expr syntax?]
[#:positive pos-blame
diff --git a/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl
index 133df9639d..9a9491efa9 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl
@@ -3,6 +3,7 @@
scribble/struct
scribble/decode
scribble/eval
+ "../common.rkt"
"parse-common.rkt"
(for-label racket/syntax))
@@ -28,6 +29,7 @@ Two parsing forms are provided: @racket[syntax-parse] and
(code:line #:literals (literal ...))
(code:line #:datum-literals (datum-literal ...))
(code:line #:literal-sets (literal-set ...))
+ #:track-literals
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))
(code:line #:disable-colon-notation)]
@@ -157,6 +159,24 @@ patterns are treated as literals; this option is useful primarily for
macros that generate @racket[syntax-parse] expressions.
}
+@specsubform[(code:line #:track-literals)]{
+
+If specified, each final @racket[body] expression is further constrained to
+produce a single value, which must be a @tech[#:doc refman]{syntax object}, and
+its @racket['disappeared-use] @tech[#:doc refman]{syntax property} is
+automatically extended to include literals matched as part of pattern-matching.
+Literals are automatically tracked from uses of @racket[#:literals],
+@racket[#:literal-sets], or @racket[~literal], but they can also be manually
+tracked using @racket[syntax-parse-state-cons!]. The property is added or
+extended in the same way as a property added by
+@racket[syntax-parse-track-literals].
+
+Due to the way the @racket[body] forms are wrapped, specifying this option means
+the final @racket[body] form will no longer be in tail position with respect to
+the enclosing @racket[syntax-parse] form.
+
+@history[#:added "6.90.0.29"]}
+
@specsubform[(code:line #:conventions (conventions-id ...))]{
Imports @tech{convention}s that give default syntax classes to pattern
diff --git a/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl
index 68cb0566d7..c74d8ca913 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl
@@ -3,6 +3,7 @@
scribble/struct
scribble/decode
scribble/eval
+ "../common.rkt"
"parse-common.rkt")
@(define the-eval (make-sp-eval))
@@ -50,4 +51,45 @@ automatically adds identifiers that match literals (from
@history[#:added "6.11.0.4"]
}
+@defproc[(syntax-parse-track-literals [stx syntax?] [#:introduce? introduce? any/c #t]) syntax?]{
+
+Add a @racket['disappeared-use] @tech[#:doc refman]{syntax property} to
+@racket[stx] containing the information stored in the current
+@racket[syntax-parse] state under the key @racket['literals]. If
+@racket[stx] already has a @racket['disappeared-use] property, the
+added information is @racket[cons]ed onto the property’s current value.
+
+Due to the way @racket[syntax-parse] automatically adds identifiers that match
+literals to the state under the key @racket['literals], as described in the
+documentation for @racket[syntax-parse-state-ref],
+@racket[syntax-parse-track-literals] can be used to automatically add any
+identifiers used as literals to the @racket['disappeared-use] property.
+
+If @racket[syntax-parse-track-literals] is called within the dynamic
+extent of a @tech[#:doc refman]{syntax transformer} (see
+@racket[syntax-transforming?]), @racket[introduce?] is not @racket[#f], and the
+value in the current @racket[syntax-parse] state under the key
+@racket['literals] is a list, then @racket[syntax-local-introduce] is applied to
+any identifiers in the list before they are added to @racket[stx]’s
+@racket['disappeared-use] property.
+
+Most of the time, it is unnecessary to call this function directly. Instead, the
+@racket[#:track-literals] option should be provided to @racket[syntax-parse],
+which will automatically call @racket[syntax-parse-track-literals] on
+syntax-valued results.
+
+@examples[#:eval the-eval
+(define-syntax-class cond-clause
+ #:literals (=> else)
+ (pattern [test:expr => ~! answer:expr ...])
+ (pattern [else answer:expr ...])
+ (pattern [test:expr answer:expr ...]))
+(syntax-property
+ (syntax-parse #'(cond [A => B] [else C])
+ [(_ c:cond-clause ...) (syntax-parse-track-literals #'#f)])
+ 'disappeared-use)
+]
+
+@history[#:added "6.90.0.29"]}
+
@(close-eval the-eval)
diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt
index c733f68df4..a053394dba 100644
--- a/pkgs/racket-test/tests/stxparse/test.rkt
+++ b/pkgs/racket-test/tests/stxparse/test.rkt
@@ -571,6 +571,27 @@
[(_ lambda) (syntax-parse-state-ref 'literals null)]))
'(lambda)))
+(test-case "track disappeared uses (implicit)"
+ (check-equal?
+ (map syntax-e
+ (syntax-property (syntax-parse #'(define lambda)
+ #:literals (define lambda)
+ #:track-literals
+ [(define define) #'#f]
+ [(_ lambda) #'#f])
+ 'disappeared-use))
+ '(lambda)))
+
+(test-case "track disappeared uses (explicit)"
+ (check-equal?
+ (map syntax-e
+ (syntax-property (syntax-parse #'(define lambda)
+ #:literals (define lambda)
+ [(define define) (syntax-parse-track-literals #'#f)]
+ [(_ lambda) (syntax-parse-track-literals #'#f)])
+ 'disappeared-use))
+ '(lambda)))
+
;; == Lib tests
;; test string, bytes act as stxclasses
diff --git a/racket/collects/syntax/parse/pre.rkt b/racket/collects/syntax/parse/pre.rkt
index 1ee5047490..e88ac50ea3 100644
--- a/racket/collects/syntax/parse/pre.rkt
+++ b/racket/collects/syntax/parse/pre.rkt
@@ -12,7 +12,8 @@
syntax-parse-state-ref
syntax-parse-state-set!
syntax-parse-state-update!
- syntax-parse-state-cons!)
+ syntax-parse-state-cons!
+ syntax-parse-track-literals)
(define not-given (gensym))
@@ -44,3 +45,6 @@
(check-update 'syntax-parse-state-cons!)
(define old (hash-ref (current-state) key default))
(current-state (hash-set (current-state) key (cons value old))))
+
+(define (syntax-parse-track-literals stx #:introduce? [introduce? #t])
+ (track-literals 'syntax-parse-track-literals stx #:introduce? introduce?))
diff --git a/racket/collects/syntax/parse/private/lib.rkt b/racket/collects/syntax/parse/private/lib.rkt
index f1374b60cf..275ebd7645 100644
--- a/racket/collects/syntax/parse/private/lib.rkt
+++ b/racket/collects/syntax/parse/private/lib.rkt
@@ -1,6 +1,7 @@
#lang racket/base
(require "sc.rkt"
"keywords.rkt"
+ (only-in "residual.rkt" state-cons!)
(for-syntax syntax/parse/private/residual-ct)
(for-syntax racket/base))
@@ -83,4 +84,5 @@
"not within the dynamic extent of a macro transformation"
#:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f
- #:fail-unless (pred (attribute value)) #f))
+ #:fail-unless (pred (attribute value)) #f
+ #:do [(state-cons! 'literals #'x)]))
diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt
index bfa385b107..035629566c 100644
--- a/racket/collects/syntax/parse/private/parse.rkt
+++ b/racket/collects/syntax/parse/private/parse.rkt
@@ -406,6 +406,9 @@ Conventions:
(options-select-value chunks '#:context #:default #'x))
(define colon-notation?
(not (assq '#:disable-colon-notation chunks)))
+ (define track-literals?
+ (or (assq '#:track-literals chunks)
+ (eq? (syntax-e #'body-mode) 'one-template)))
(define-values (decls0 defs)
(get-decls+defs chunks #t #:context #'ctx))
;; for-clause : stx -> (values pattern stx (listof stx))
@@ -427,13 +430,16 @@ Conventions:
[_ (raise-syntax-error #f "expected exactly one template" #'ctx)]))
((body-sequence)
(syntax-case rest ()
- [(e0 e ...) #'(let () e0 e ...)]
+ [(e0 e ...)
+ #'(let () e0 e ...)]
[_ (raise-syntax-error #f "expected non-empty clause body"
#'ctx clause)]))
(else
(raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))])
(values pattern body-expr defs2)))]
[_ (raise-syntax-error #f "expected clause" #'ctx clause)]))
+ (define (wrap-track-literals stx)
+ (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx))
(unless (stx-list? clauses-stx)
(raise-syntax-error #f "expected sequence of clauses" #'ctx))
(define-values (patterns body-exprs defs2s)
@@ -451,25 +457,26 @@ Conventions:
(parameterize ((current-syntax-context (cadr ctx0))
(current-state '#hasheq())
(current-state-writable? #f))
- (with ([fail-handler fh0]
- [cut-prompt fh0]
- [undo-stack null])
- #,(cond [(pair? patterns)
- (with-syntax ([matrix
- (optimize-matrix
- (for/list ([pattern (in-list patterns)]
- [body-expr (in-list body-exprs)])
- (pk1 (list pattern) body-expr)))])
- #'(parse:matrix ((x cx pr es)) matrix))
- #|
- (with-syntax ([(alternative ...)
- (for/list ([pattern (in-list patterns)]
- [body-expr (in-list body-exprs)])
- #`(parse:S x cx #,pattern pr es #,body-expr))])
- #`(try alternative ...))
- |#]
- [else
- #`(fail (failure* pr es))]))))))))]))
+ #,(wrap-track-literals
+ #`(with ([fail-handler fh0]
+ [cut-prompt fh0]
+ [undo-stack null])
+ #,(cond [(pair? patterns)
+ (with-syntax ([matrix
+ (optimize-matrix
+ (for/list ([pattern (in-list patterns)]
+ [body-expr (in-list body-exprs)])
+ (pk1 (list pattern) body-expr)))])
+ #'(parse:matrix ((x cx pr es)) matrix))
+ #|
+ (with-syntax ([(alternative ...)
+ (for/list ([pattern (in-list patterns)]
+ [body-expr (in-list body-exprs)])
+ #`(parse:S x cx #,pattern pr es #,body-expr))])
+ #`(try alternative ...))
+ |#]
+ [else
+ #`(fail (failure* pr es))])))))))))]))
;; ----
diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt
index 91468a2a2b..228b1762a7 100644
--- a/racket/collects/syntax/parse/private/rep.rkt
+++ b/racket/collects/syntax/parse/private/rep.rkt
@@ -1610,6 +1610,7 @@
;; parse-directive-table
(define parse-directive-table
(list* (list '#:context check-expression)
+ (list '#:track-literals)
common-parse-directive-table))
;; rhs-directive-table
diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt
index 27e503780e..33fe04a96e 100644
--- a/racket/collects/syntax/parse/private/residual.rkt
+++ b/racket/collects/syntax/parse/private/residual.rkt
@@ -253,7 +253,8 @@
maybe-add-state-undo
current-state
current-state-writable?
- state-cons!)
+ state-cons!
+ track-literals)
(define (unwind-to undos base)
;; PRE: undos = (list* proc/hash ... base)
@@ -279,3 +280,21 @@
(define (state-cons! key value)
(define state (current-state))
(current-state (hash-set state key (cons value (hash-ref state key null)))))
+
+(define (track-literals who v #:introduce? [introduce? #t])
+ (unless (syntax? v)
+ (raise-argument-error who "syntax?" v))
+ (let* ([literals (hash-ref (current-state) 'literals '())])
+ (if (null? literals)
+ v
+ (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
+ (for/list ([literal (in-list literals)])
+ (if (identifier? literal)
+ (syntax-local-introduce literal)
+ literal))
+ literals)]
+ [old-val (syntax-property v 'disappeared-use)])
+ (syntax-property v 'disappeared-use
+ (if old-val
+ (cons literals* old-val)
+ literals*))))))