From 774b02a0b827996506fb6b9396adf5226e68337c Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 16 May 2018 13:28:41 -0500 Subject: [PATCH] syntax/parse: Add #:track-literals and syntax-parse-track-literals --- .../syntax/scribblings/parse/define.scrbl | 5 +- .../syntax/scribblings/parse/lib.scrbl | 10 +++- .../syntax/scribblings/parse/parsing.scrbl | 20 ++++++++ .../syntax/scribblings/parse/state.scrbl | 42 +++++++++++++++++ pkgs/racket-test/tests/stxparse/test.rkt | 21 +++++++++ racket/collects/syntax/parse/pre.rkt | 6 ++- racket/collects/syntax/parse/private/lib.rkt | 4 +- .../collects/syntax/parse/private/parse.rkt | 47 +++++++++++-------- racket/collects/syntax/parse/private/rep.rkt | 1 + .../syntax/parse/private/residual.rkt | 21 ++++++++- 10 files changed, 152 insertions(+), 25 deletions(-) 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*))))))