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

syntax/parse: added phase options to define-literal-set

Browse Source
This commit is contained in:
Ryan Culpepper 2011-04-01 00:57:04 -06:00
parent 2e2bc02303
commit 896cb86dc4
4 changed files with 119 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/syntax/parse/private/litconv.rkt
View File

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

7
collects/syntax/parse/private/runtime.rkt
View File

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

31
collects/syntax/scribblings/parse/litconv.scrbl
View File

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

57
collects/tests/stxparse/litset-phases.rkt
View File

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