diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt index 1f5b901cad..0b84d52f46 100644 --- a/collects/syntax/parse/private/litconv.rkt +++ b/collects/syntax/parse/private/litconv.rkt @@ -14,6 +14,7 @@ [syntax/parse/private/rep ;; keep abs. path (parse-kw-formals check-conventions-rules + check-datum-literals-list create-aux-def)])) ;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) ;; Without this, dependencies don't get collected. @@ -79,6 +80,7 @@ (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) stx) +;; check-litset-list : stx stx -> (listof (cons id literalset)) (define-for-syntax (check-litset-list stx ctx) (syntax-case stx () [(litset-id ...) @@ -101,17 +103,23 @@ (list #'id #'id)] [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) -(define-for-syntax (check-duplicate-literals stx imports lits) +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) (let ([lit-t (make-hasheq)]) ;; sym => #t (define (check+enter! key blame-stx) (when (hash-ref lit-t key #f) - (raise-syntax-error #f (format "duplicate literal: ~a" key) stx blame-stx)) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) (hash-set! lit-t key #t)) (for ([id+litset (in-list imports)]) (let ([litset-id (car id+litset)] [litset (cdr id+litset)]) (for ([entry (in-list (literalset-literals litset))]) - (check+enter! (car entry) litset-id)))) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) (for ([lit (in-list lits)]) (check+enter! (syntax-e (car lit)) (car lit))))) @@ -122,6 +130,7 @@ (parse-keyword-options #'rest `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) (#:phase ,check-phase-level) (#:for-template) (#:for-syntax) @@ -136,28 +145,35 @@ [(assq '#:for-syntax chunks) 1] [(assq '#:for-label chunks) #f] [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] [lits (syntax-case rest () [( (lit ...) ) (for/list ([lit (in-list (syntax->list #'(lit ...)))]) (check-literal-entry/litset lit stx))] [_ (raise-syntax-error #f "bad syntax" stx)])] [imports (options-select-value chunks '#:literal-sets #:default null)]) - (check-duplicate-literals stx imports lits) + (check-duplicate-literals stx imports lits datum-lits) (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] [(litset-id ...) (map car imports)] [relphase relphase]) #`(begin (define phase-of-literals - (if 'relphase - (+ (phase-of-enclosing-module) 'relphase) - 'relphase)) + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) (define-syntax name (make-literalset (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) ... - (list (list 'internal - (quote-syntax external) - (quote-syntax phase-of-literals)) + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) ...)))) (begin-for-syntax/once (for ([x (in-list (syntax->list #'(external ...)))]) @@ -174,26 +190,42 @@ (quote-syntax #,stx) x))))))))])) #| -Literal sets: The goal is for literals to refer to their bindings at +NOTES ON PHASES AND BINDINGS - phase 0 relative to the enclosing module +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) -Use cases, explained: -1) module X with def-lit-set is required-for-syntax - phase-of-mod-inst = 1 - phase-of-def = 0 - literals looked up at abs phase 1 - which is phase 0 rel to module X -2) module X with local def-lit-set within define-syntax - phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax) - phase-of-def = 1 - literals looked up at abs phase 0 - which is phase 0 rel to module X -3) module X with def-lit-set in phase-2 position (really uncommon case!) - phase-of-mod-inst = 1 (not 2, apparently) - phase-of-def = 2 - literals looked up at abs phase 0 - (that's why the weird (if (z?) 0 1) term) +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require syntax/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) |# ;; FIXME: keep one copy of each identifier (?) @@ -205,7 +237,10 @@ Use cases, explained: (syntax-local-value/record #'litset-id literalset?))]) (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) (let ([lits (literalset-literals val)]) - (with-syntax ([((_sym lit phase-var) ...) lits]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))]) #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)))))])) (define (make-literal-set-predicate lits) diff --git a/collects/syntax/parse/private/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt index 63b5da4375..c186ff97a2 100644 --- a/collects/syntax/parse/private/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -72,6 +72,7 @@ DeclEnv = DeclEntry = (den:lit id id ct-phase ct-phase) + (den:datum-lit id symbol) (den:class id id Arguments) (den:magic-class id id Arguments stx) (den:parser id (listof SAttr) bool bool bool) @@ -82,6 +83,7 @@ Arguments is defined in rep-patterns.rkt A DeclEnv is built up in stages: 1) syntax-parse (or define-syntax-class) directives #:literals -> den:lit + #:datum-literals -> den:datum-lit #:local-conventions -> den:class #:conventions -> den:delayed #:literal-sets -> den:lit @@ -101,20 +103,22 @@ expressions are duplicated, and may be evaluated in different scopes. (define-struct declenv (table conventions)) -(define-struct den:lit (internal external input-phase lit-phase)) (define-struct den:class (name class argu)) (define-struct den:magic-class (name class argu role)) (define-struct den:parser (parser attrs splicing? commit? delimit-cut?)) -;; and from residual.rkt: (define-struct den:delayed (parser class)) +;; and from residual.rkt: +;; (define-struct den:lit (internal external input-phase lit-phase)) +;; (define-struct den:datum-lit (internal external)) +;; (define-struct den:delayed (parser class)) (define (new-declenv literals #:conventions [conventions null]) - (make-declenv - (for/fold ([table (make-immutable-bound-id-table)]) - ([literal (in-list literals)]) - (bound-id-table-set table (car literal) - (make den:lit (first literal) (second literal) - (third literal) (fourth literal)))) - conventions)) + (let* ([table (make-immutable-bound-id-table)] + [table (for/fold ([table table]) ([literal (in-list literals)]) + (let ([id (cond [(den:lit? literal) (den:lit-internal literal)] + [(den:datum-lit? literal) (den:datum-lit-internal literal)])]) + ;;(eprintf ">> added ~e\n" id) + (bound-id-table-set table id literal)))]) + (make-declenv table conventions))) (define (declenv-lookup env id #:use-conventions? [use-conventions? #t]) (or (bound-id-table-ref (declenv-table env) id #f) @@ -129,6 +133,8 @@ expressions are duplicated, and may be evaluated in different scopes. (match val [(den:lit _i _e _ip _lp) (wrong-syntax id "identifier previously declared as literal")] + [(den:datum-lit _i _e) + (wrong-syntax id "identifier previously declared as literal")] [(den:magic-class name _c _a _r) (if (and blame-declare? stxclass-name) (wrong-syntax name @@ -191,7 +197,7 @@ expressions are duplicated, and may be evaluated in different scopes. (define DeclEnv/c declenv?) (define DeclEntry/c - (or/c den:lit? den:class? den:magic-class? den:parser? den:delayed?)) + (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?)) (define SideClause/c (or/c clause:fail? clause:with? clause:attr? clause:do?)) @@ -200,11 +206,12 @@ expressions are duplicated, and may be evaluated in different scopes. ;; usually = #'(syntax-local-phase-level) (define ct-phase/c syntax?) -(provide (struct-out den:lit) - (struct-out den:class) +(provide (struct-out den:class) (struct-out den:magic-class) (struct-out den:parser) ;; from residual.rkt: + (struct-out den:lit) + (struct-out den:datum-lit) (struct-out den:delayed)) (provide/contract @@ -218,7 +225,7 @@ expressions are duplicated, and may be evaluated in different scopes. [stxclass-colon-notation? (parameter/c boolean?)] [new-declenv - (->* [(listof (list/c identifier? identifier? ct-phase/c ct-phase/c))] + (->* [(listof (or/c den:lit? den:datum-lit?))] [#:conventions list?] DeclEnv/c)] [declenv-lookup diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index 36d145afcd..5e836db058 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -4,6 +4,7 @@ syntax/parse/private/keywords syntax/parse/private/residual ;; keep abs. path syntax/parse/private/runtime) + racket/list racket/contract/base "minimatch.rkt" syntax/private/id-table @@ -61,6 +62,9 @@ [check-conventions-rules (-> syntax? syntax? (listof (list/c regexp? any/c)))] + [check-datum-literals-list + (-> syntax? syntax? + (listof den:datum-lit?))] [check-attr-arity-list (-> syntax? syntax? (listof sattr?))]) @@ -220,11 +224,12 @@ ;; get-decls : chunks -> (values DeclEnv (listof syntax)) (define (get-decls chunks strict?) (define lits (options-select-value chunks '#:literals #:default null)) + (define datum-lits (options-select-value chunks '#:datum-literals #:default null)) (define litsets (options-select-value chunks '#:literal-sets #:default null)) (define convs (options-select-value chunks '#:conventions #:default null)) (define localconvs (options-select-value chunks '#:local-conventions #:default null)) (define literals - (append-lits+litsets lits litsets)) + (append/check-lits+litsets lits datum-lits litsets)) (define-values (convs-rules convs-defs) (for/fold ([convs-rules null] [convs-defs null]) ([conv-entry (in-list convs)]) @@ -260,6 +265,8 @@ (match entry [(den:lit _i _e _ip _lp) (values entry null)] + [(den:datum-lit _i _e) + (values entry null)] [(den:magic-class name class argu role) (values entry null)] [(den:class name class argu) @@ -288,14 +295,39 @@ [(den:delayed _p _c) (values entry null)])) -(define (append-lits+litsets lits litsets) - (define seen (make-bound-id-table lits)) - (for ([litset (in-list litsets)]) - (for ([lit (in-list litset)]) - (when (bound-id-table-ref seen (car lit) #f) - (wrong-syntax (car lit) "duplicate literal declaration")) - (bound-id-table-set! seen (car lit) #t))) - (apply append lits litsets)) +;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit)) +(define (append/check-lits+litsets lits datum-lits litsets) + (define seen (make-bound-id-table)) + (define (check-id id [blame-ctx id]) + (if (bound-id-table-ref seen id #f) + (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id)) + (bound-id-table-set! seen id #t)) + id) + (let* ([litsets* + (for/list ([entry (in-list litsets)]) + (let ([litset-id (first entry)] + [litset (second entry)] + [lctx (third entry)] + [input-phase (fourth entry)]) + (define (get/check-id sym) + (check-id (datum->syntax lctx sym) litset-id)) + (for/list ([lse (in-list (literalset-literals litset))]) + (match lse + [(lse:lit internal external lit-phase) + (let ([internal (get/check-id internal)]) + (make den:lit internal external input-phase lit-phase))] + [(lse:datum-lit internal external) + (let ([internal (get/check-id internal)]) + (make den:datum-lit internal external))]))))] + [lits* + (for/list ([lit (in-list lits)]) + (check-id (den:lit-internal lit)) + lit)] + [datum-lits* + (for/list ([datum-lit (in-list datum-lits)]) + (check-id (den:datum-lit-internal datum-lit)) + datum-lit)]) + (apply append lits* datum-lits* litsets*))) ;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS (define (parse-variant stx splicing? decls0 expected-attrs) @@ -609,6 +641,8 @@ (match entry [(den:lit internal literal input-phase lit-phase) (create-pat:literal literal input-phase lit-phase)] + [(den:datum-lit internal sym) + (create-pat:datum sym)] [(den:magic-class name class argu role) (let* ([pos-count (length (arguments-pargs argu))] [kws (arguments-kws argu)] @@ -1222,24 +1256,20 @@ [_ (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) -;; check-literals-list : stx stx -> (listof (list id id ct-phase ct-phase)) +;; check-literals-list : stx stx -> (listof den:lit) ;; - txlifts defs of phase expressions ;; - txlifts checks that literals are bound (define (check-literals-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literals list" ctx stx)) - (let ([lits - (for/list ([x (in-list (stx->list stx))]) - (check-literal-entry x ctx))]) - (let ([dup (check-duplicate-identifier (map car lits))]) - (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup))) - lits)) + (for/list ([x (in-list (stx->list stx))]) + (check-literal-entry x ctx))) -;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase) +;; check-literal-entry : stx stx -> den:lit (define (check-literal-entry stx ctx) (define (go internal external phase) (txlift #`(check-literal #,external #,phase #,ctx)) - (list internal external phase phase)) + (make den:lit internal external phase phase)) (syntax-case stx () [(internal external #:phase phase) (and (identifier? #'internal) (identifier? #'external)) @@ -1251,32 +1281,44 @@ (identifier? #'id) (go #'id #'id #'(syntax-local-phase-level))] [_ - (raise-syntax-error #f "expected literal entry" - ctx stx)])) + (raise-syntax-error #f "expected literal entry" ctx stx)])) + +;; check-datum-literals-list : stx stx -> (listof den:datum-lit) +(define (check-datum-literals-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected datum-literals list" ctx stx)) + (for/list ([x (in-list (stx->list stx))]) + (check-datum-literal-entry x ctx))) + +;; check-datum-literal-entry : stx stx -> den:datum-lit +(define (check-datum-literal-entry stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (make den:datum-lit #'internal (syntax-e #'external))] + [id + (identifier? #'id) + (make den:datum-lit #'id (syntax-e #'id))] + [_ + (raise-syntax-error #f "expected datum-literal entry" ctx stx)])) ;; Literal sets - Import -;; check-literal-sets-list : stx stx -> (listof (listof (list id id ct-phase^2))) +;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx)) (define (check-literal-sets-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literal-set list" ctx stx)) (for/list ([x (in-list (stx->list stx))]) (check-literal-set-entry x ctx))) -;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2)) +;; check-literal-set-entry : stx stx -> (list id literalset stx stx) (define (check-literal-set-entry stx ctx) (define (elaborate litset-id lctx phase) (let ([litset (syntax-local-value/record litset-id literalset?)]) (unless litset (raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id)) - (elaborate2 litset lctx phase))) - (define (elaborate2 litset lctx phase) - (for/list ([entry (in-list (literalset-literals litset))]) - (list (datum->syntax lctx (car entry) stx) - (cadr entry) - phase - (caddr entry)))) + (list litset-id litset lctx phase))) (syntax-case stx () [(litset . more) (and (identifier? #'litset)) @@ -1483,6 +1525,7 @@ (define common-parse-directive-table (list (list '#:disable-colon-notation) (list '#:literals check-literals-list) + (list '#:datum-literals check-datum-literals-list) (list '#:literal-sets check-literal-sets-list) (list '#:conventions check-conventions-list) (list '#:local-conventions check-conventions-rules))) diff --git a/collects/syntax/parse/private/residual-ct.rkt b/collects/syntax/parse/private/residual-ct.rkt index a99d49a94a..ae6bed829f 100644 --- a/collects/syntax/parse/private/residual-ct.rkt +++ b/collects/syntax/parse/private/residual-ct.rkt @@ -5,8 +5,12 @@ (struct-out integrate) (struct-out conventions) (struct-out literalset) + (struct-out lse:lit) + (struct-out lse:datum-lit) (struct-out eh-alternative-set) (struct-out eh-alternative) + (struct-out den:lit) + (struct-out den:datum-lit) (struct-out den:delayed)) ;; == from rep-attr.rkt @@ -38,9 +42,14 @@ A ConventionRule is (list regexp DeclEntry) #| A LiteralSet is - (make-literalset (listof (list symbol id phase-var-id))) + (make-literalset (listof LiteralSetEntry)) +An LiteralSetEntry is one of + - (make-lse:lit symbol id ct-phase) + - (make-lse:datum-lit symbol symbol) |# (define-struct literalset (literals) #:transparent) +(define-struct lse:lit (internal external phase) #:transparent) +(define-struct lse:datum-lit (internal external) #:transparent) #| An EH-alternative-set is @@ -51,4 +60,6 @@ An EH-alternative is (define-struct eh-alternative-set (alts)) (define-struct eh-alternative (repc attrs parser)) +(define-struct den:lit (internal external input-phase lit-phase) #:transparent) +(define-struct den:datum-lit (internal external) #:transparent) (define-struct den:delayed (parser class)) diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl index 09a46da28a..d8a56e4450 100644 --- a/collects/syntax/scribblings/parse/litconv.scrbl +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -15,7 +15,8 @@ As a remedy, @racketmodname[syntax/parse] offers @deftech{literal sets}. A literal set is defined via @racket[define-literal-set] and used via the @racket[#:literal-set] option of @racket[syntax-parse]. -@defform/subs[(define-literal-set id maybe-phase maybe-imports (literal ...)) +@defform/subs[(define-literal-set id maybe-phase maybe-imports maybe-datum-literals + (literal ...)) ([literal literal-id (pattern-id literal-id)] [maybe-phase (code:line) @@ -23,6 +24,8 @@ used via the @racket[#:literal-set] option of @racket[syntax-parse]. (code:line #:for-syntax) (code:line #:for-label) (code:line #:phase phase-level)] + [maybe-datum-literals (code:line) + (code:line #:datum-literals (datum-literal ...))] [maybe-imports (code:line) (code:line #:literal-sets (imported-litset-id ...))])]{ diff --git a/collects/syntax/scribblings/parse/parsing.scrbl b/collects/syntax/scribblings/parse/parsing.scrbl index 084dbb6199..732cb0b27f 100644 --- a/collects/syntax/scribblings/parse/parsing.scrbl +++ b/collects/syntax/scribblings/parse/parsing.scrbl @@ -23,6 +23,7 @@ Two parsing forms are provided: @racket[syntax-parse] and @defform/subs[(syntax-parse stx-expr parse-option ... clause ...+) ([parse-option (code:line #:context context-expr) (code:line #:literals (literal ...)) + (code:line #:datum-literals (datum-literal ...)) (code:line #:literal-sets (literal-set ...)) (code:line #:conventions (convention-id ...)) (code:line #:local-conventions (convention-rule ...)) @@ -30,6 +31,8 @@ Two parsing forms are provided: @racket[syntax-parse] and [literal literal-id (pattern-id literal-id) (pattern-id literal-id #:phase phase-expr)] + [datum-literal literal-id + (pattern-id literal-id)] [literal-set literal-set-id (literal-set-id literal-set-option ...)] [literal-set-option (code:line #:at context-id) @@ -76,10 +79,12 @@ failures; otherwise @racket[stx-expr] is used. The (pattern-id literal-id) (pattern-id literal-id #:phase phase-expr)]) #:contracts ([phase-expr (or/c exact-integer? #f)])]{ + @margin-note*{ Unlike @racket[syntax-case], @racket[syntax-parse] requires all literals to have a binding. To match identifiers by their symbolic - names, use the @racket[~datum] pattern form instead. + names, use @racket[#:datum-literals] or the @racket[~datum] pattern + form instead. } @; The @racket[#:literals] option specifies identifiers that should be @@ -94,6 +99,23 @@ If the @racket[#:phase] option is given, then the literal is compared at phase @racket[phase-expr]. Specifically, the binding of the @racket[literal-id] at phase @racket[phase-expr] must match the input's binding at phase @racket[phase-expr]. + +In other words, the @racket[syntax-pattern]s are interpreted as if each +occurrence of @racket[pattern-id] were replaced with the following pattern: +@racketblock[(~literal literal-id #:phase phase-expr)] +} + +@specsubform/subs[(code:line #:datum-literals (datum-literal ...)) + ([datum-literal literal-id + (pattern-id literal-id)])]{ + +Like @racket[#:literals], but the literals are matched as symbols +instead of as identifiers. + +In other words, the @racket[syntax-pattern]s are interpreted as if each +occurrence of @racket[pattern-id] were replaced with the following +pattern: +@racketblock[(~datum literal-id)] } @specsubform/subs[(code:line #:literal-sets (literal-set ...)) diff --git a/collects/syntax/scribblings/parse/patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl index a1f047dc82..7655072fb0 100644 --- a/collects/syntax/scribblings/parse/patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -40,7 +40,7 @@ means specifically @tech{@Spattern}. (@#,ref[~var s-] id) (@#,ref[~var s+] id syntax-class-id maybe-role) (@#,ref[~var s+] id (syntax-class-id arg ...) maybe-role) - (~literal literal-id) + (~literal literal-id maybe-phase) atomic-datum (~datum datum) (H-pattern . S-pattern) @@ -298,7 +298,9 @@ combined with the syntax class's description in error messages. ] } -@specsubform[(@#,defhere[~literal] literal-id)]{ +@specsubform/subs[(@#,defhere[~literal] literal-id maybe-phase) + ([maybe-phase (code:line) + (code:line #:phase phase-expr)])]{ A @deftech{literal} identifier pattern. Matches any identifier @racket[free-identifier=?] to @racket[literal-id]. @@ -309,6 +311,10 @@ A @deftech{literal} identifier pattern. Matches any identifier (syntax-parse #'(lambda x 12) [((~literal define) var:id body:expr) 'ok]) ] + +The identifiers are compared at the phase given by +@racket[phase-expr], if it is given, or +@racket[(syntax-local-phase-level)] otherwise. } @specsubform[atomic-datum]{ diff --git a/collects/syntax/scribblings/parse/stxclasses.scrbl b/collects/syntax/scribblings/parse/stxclasses.scrbl index 843cc140da..05247d46c6 100644 --- a/collects/syntax/scribblings/parse/stxclasses.scrbl +++ b/collects/syntax/scribblings/parse/stxclasses.scrbl @@ -29,6 +29,7 @@ structures can share syntax class definitions. (code:line #:commit) (code:line #:no-delimit-cut) (code:line #:literals (literal-entry ...)) + (code:line #:datum-literals (datum-literal-entry ...)) (code:line #:literal-sets (literal-set ...)) (code:line #:conventions (convention-id ...)) (code:line #:local-conventions (convention-rule ...)) @@ -107,7 +108,8 @@ It is an error to use both @racket[#:commit] and @racket[#:no-delimit-cut]. } -@specsubform[(code:line #:literals (literal-entry))] +@specsubform[(code:line #:literals (literal-entry ...))] +@specsubform[(code:line #:datum-literals (datum-literal-entry ...))] @specsubform[(code:line #:literal-sets (literal-set ...))] @specsubform[(code:line #:conventions (convention-id ...))]{ diff --git a/collects/tests/stxparse/test-litset.rkt b/collects/tests/stxparse/test-litset.rkt index 40bf0b5af3..4c61efa492 100644 --- a/collects/tests/stxparse/test-litset.rkt +++ b/collects/tests/stxparse/test-litset.rkt @@ -97,6 +97,18 @@ (go #'begin #f) (void))) +;; Litsets with datum-lits + +(test-case "litset, datum-lits" + (let ([one 1]) + (define-literal-set lits-d #:datum-literals (one two) ()) + (syntax-parse #'one #:literal-sets (lits-d) + [one (void)]) + (let ([one 2]) + (syntax-parse #'one #:literal-sets (lits-d) [one (void)])))) + +;; literal-set->predicate + (require (for-label '#%kernel)) (test-case "litset->pred" diff --git a/collects/tests/stxparse/test.rkt b/collects/tests/stxparse/test.rkt index e195005b63..161da86ad7 100644 --- a/collects/tests/stxparse/test.rkt +++ b/collects/tests/stxparse/test.rkt @@ -79,6 +79,14 @@ [+ (void)] [_ (error 'wrong)])) +(test-case "datum literals" + (syntax-parse #'one #:datum-literals (one) + [one (void)])) +(test-case "datum literals (not id=?)" + (let ([one 1]) + (syntax-parse (let ([one 2]) #'one) #:datum-literals (one) + [one (void)]))) + ;; compound patterns (tok (a b c) (x y z) (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))