diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt index 7629ac2304..0fc6fc1c22 100644 --- a/collects/syntax/parse/private/litconv.rkt +++ b/collects/syntax/parse/private/litconv.rkt @@ -3,6 +3,7 @@ "sc.rkt" "lib.rkt" unstable/syntax + syntax/keyword "rep-data.rkt" "rep.rkt" "kws.rkt") @@ -57,25 +58,52 @@ def ... (list parser ...)))))])) +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + (define-syntax (define-literal-set stx) (syntax-case stx () - [(define-literal-set name (lit ...)) - (let ([phase-of-definition (syntax-local-phase-level)]) + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) (unless (identifier? #'name) (raise-syntax-error #f "expected identifier" stx #'name)) - (let ([lits (check-literals-list/litset #'(lit ...) stx)]) - (with-syntax ([((internal external) ...) lits]) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [lits (syntax-case rest () + [( (lit ...) ) + (check-literals-list/litset #'(lit ...) stx)] + [_ (raise-syntax-error #f "bad syntax" stx)])]) + (with-syntax ([((internal external) ...) lits] + [relphase relphase]) #`(begin (define phase-of-literals - (phase-of-enclosing-module)) + (if 'relphase + (+ (phase-of-enclosing-module) 'relphase) + 'relphase)) (define-syntax name (make-literalset (list (list 'internal (quote-syntax external)) ...) (quote-syntax phase-of-literals))) (begin-for-syntax/once (for ([x (in-list (syntax->list #'(external ...)))]) - (unless (identifier-binding x 0) - (raise-syntax-error #f "literal is unbound in phase 0" + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a" 'relphase) (quote-syntax #,stx) x))))))))])) (define-syntax (phase-of-enclosing-module stx) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 0470c41796..34a6ab258f 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -266,9 +266,10 @@ (eq? namex namey) (equal? phasex phasey)))] [else - ;; One must be lexical (can't be #f, since one must be bound) - ;; lexically-bound names bound in only one phase; just compare - (free-identifier=? x y)]))) + (and (eq? bx 'lexical) (eq? by 'lexical) + ;; One must be lexical (can't be #f, since one must be bound) + ;; lexically-bound names bound in only one phase; just compare + (free-identifier=? x y))]))) ;; ---- diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl index cbcdc3f090..610c804bd9 100644 --- a/collects/syntax/scribblings/parse/litconv.scrbl +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -15,9 +15,14 @@ As a remedy, @schememodname[syntax/parse] offers @deftech{literal sets}. A literal set is defined via @scheme[define-literal-set] and used via the @scheme[#:literal-set] option of @scheme[syntax-parse]. -@defform/subs[(define-literal-set name-id (literal ...)) +@defform/subs[(define-literal-set name-id maybe-phase (literal ...)) ([literal literal-id - (pattern-id literal-id)])]{ + (pattern-id literal-id)] + [maybe-phase (code:line) + (code:line #:for-template) + (code:line #:for-syntax) + (code:line #:for-label) + (code:line #:phase phase-level)])]{ Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal] can have a separate @scheme[pattern-id] and @scheme[literal-id]. The @@ -34,8 +39,14 @@ identifiers the literal matches. [(define-syntaxes (x:id ...) e:expr) 's]) ] -The literals in a literal set always refer to the phase-0 bindings of -the enclosing module. For example: +The literals in a literal set always refer to the bindings at phase +@scheme[phase-level] @emph{relative to the enclosing module}. If the +@scheme[#:for-template] option is given, @scheme[phase-level] is +@scheme[-1]; @scheme[#:for-syntax] means @racket[1], and +@racket[#:for-label] means @racket[#f]. If no phase keyword option is +given, then @racket[phase-level] is @racket[0]. + +For example: @myexamples[ (module common racket/base @@ -52,7 +63,17 @@ In the literal set @scheme[common-lits], the literal @scheme[x] always recognizes identifiers bound to the variable @scheme[x] defined in module @schememodname['common]. -When a literal set is used with the @scheme[#:phase phase-expr] +The following module defines an equivalent literal set, but imports +the @racket['common] module for-template instead: + +@myexamples[ +(module lits racket/base + (require syntax/parse (for-template 'common)) + (define-literal-set common-lits #:for-template (x)) + (provide common-lits)) +] + +When a literal set is @emph{used} with the @scheme[#:phase phase-expr] option, the literals' fixed bindings are compared against the binding of the input literal at the specified phase. Continuing the example: diff --git a/collects/tests/stxparse/litset-phases.rkt b/collects/tests/stxparse/litset-phases.rkt index abcd9ee7c1..5347a04bf1 100644 --- a/collects/tests/stxparse/litset-phases.rkt +++ b/collects/tests/stxparse/litset-phases.rkt @@ -1,10 +1,15 @@ -#lang racket/load +#lang scheme +(require syntax/parse + syntax/parse/debug + rackunit + "setup.rkt") +(require (for-syntax syntax/parse)) +#| (module a racket (require syntax/parse) (define-literal-set lits (begin)) (provide lits)) - (module b racket (require (for-syntax 'a syntax/parse)) (require (for-syntax syntax/parse/private/runtime)) @@ -14,8 +19,54 @@ #:literal-sets (lits) [(snarf (begin e)) #'e])) (provide snarf)) - (module c racket (require (for-syntax 'b racket/base)) (begin-for-syntax (displayln (snarf (begin 5))))) +|# + +(define-literal-set lits0 #:phase 0 + (define lambda)) + +(tcerr "litset unbound" + (let () + (define-literal-set lits #:phase 0 + (none-such)) + (void))) + +(tcerr "litset unbound, phase" + (let () + (define-literal-set lits #:for-template + (lambda)) + (void))) + +(tcerr "litset ok, use fails" + (let () + (define-literal-set lits #:phase 0 + (define lambda)) + (syntax-parse #'foo #:literal-sets (lits) + [lambda (void)]))) + +(define-literal-set lits #:phase 0 + (define lambda)) +(require (prefix-in mz: racket/base)) + +(test-case "litset ok, use ok" + (syntax-parse #'lambda #:literal-sets (lits) + [lambda (void)])) + +(test-case "litset ok, use ok prefix" + (syntax-parse #'mz:lambda #:literal-sets (lits) + [lambda (void)])) + +(require (for-meta 2 (only-in '#%kernel #%app))) +(define-literal-set litsk #:phase 2 + (#%app)) + +(test-case "litset, phase" + (syntax-parse #'#%plain-app #:literal-sets (litsk) + [#%app (void)])) + +(tcerr "litset, phase fail" + (syntax-parse #'#%app #:literal-sets (litsk) + [#%app (void)]))