suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: Add #:track-literals and syntax-parse-track-literals

Browse Source
This commit is contained in:
Alexis King 2018-05-16 13:28:41 -05:00
parent 1532ded5d1
commit 774b02a0b8
10 changed files with 152 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-doc/syntax/scribblings/parse/define.scrbl
View File

@ -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 ...+)]{

10
pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
View File

@ -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

20
pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl
View File

@ -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

42
pkgs/racket-doc/syntax/scribblings/parse/state.scrbl
View File

@ -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)

21
pkgs/racket-test/tests/stxparse/test.rkt
View File

@ -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

6
racket/collects/syntax/parse/pre.rkt
View File

@ -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?))

4
racket/collects/syntax/parse/private/lib.rkt
View File

@ -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)]))

47
racket/collects/syntax/parse/private/parse.rkt
View File

@ -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))])))))))))]))
;; ----

1
racket/collects/syntax/parse/private/rep.rkt
View File

@ -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

21
racket/collects/syntax/parse/private/residual.rkt
View File

@ -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*))))))