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

syntax/parse: allow phase spec for literals

Browse Source
This commit is contained in:
Ryan Culpepper 2010-04-29 10:58:04 -06:00
parent 8af4134991
commit f42adad3f8
7 changed files with 171 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/syntax/private/stxparse/parse.rkt
View File

@ -8,6 +8,7 @@
"rep-data.ss"
"rep.ss"
"codegen-data.ss"
"../util/txlift.ss"
"../util.ss")
scheme/stxparam
scheme/list
@ -158,7 +159,8 @@
(syntax-case stx ()
[(parse:clauses x clauses ctx)
(with-disappeared-uses
(let ()
(with-txlifts
(lambda ()
(define-values (chunks clauses-stx)
(parse-keyword-options #'clauses parse-directive-table
#:context #'ctx
@ -191,19 +193,13 @@
(clause-success () (let () . rest)))))))]))
(unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
(raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx))
(with-syntax ([(def ...) defs]
(with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
[(alternative ...)
(map for-clause (stx->list clauses-stx))])
#`(let ([fail (syntax-patterns-fail #,context)])
def ...
(with-enclosing-fail* fail
(try alternative ...))))))]))
(define-for-syntax (wash-literal stx)
(syntax-case stx ()
[(a b) (list #'a #'b)]))
(define-for-syntax (wash-literals stx)
(wash-list wash-literal stx))
(try alternative ...)))))))]))
;; (clause-success (IAttr ...) expr) : expr
(define-syntax (clause-success stx)
@ -262,12 +258,20 @@
(fail x
#:expect (expectation pattern0)
#:fce fc)))]
[#s(pat:literal attrs literal)
[#s(pat:literal attrs literal #f)
#`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal)))
k
(fail x
#:expect (expectation pattern0)
#:fce fc))]
[#s(pat:literal attrs literal phase)
#`(if (and (identifier? x)
(free-identifier=? x (quote-syntax literal)
(phase+ (syntax-local-phase-level) phase)))
k
(fail x
#:expect (expectation pattern0)
#:fce fc))]
[#s(pat:ghost attrs ghost subpattern)
#'(parse:G x fc ghost (parse:S x fc subpattern k))]
[#s(pat:head attrs head tail)
@ -625,7 +629,7 @@
[(_ #s(pat:datum attrs d))
#'(begin (collect-error '(datum d))
(make-expect:atom 'd))]
[(_ #s(pat:literal attrs lit))
[(_ #s(pat:literal attrs lit phase))
#'(begin (collect-error '(literal lit))
(make-expect:literal (quote-syntax lit)))]
;; 2 pat:compound patterns

18
collects/syntax/private/stxparse/rep-data.rkt
View File

@ -92,7 +92,7 @@ A ConventionRule is (list regexp DeclEntry)
#|
A LiteralSet is
(make-literalset (listof (list symbol id)))
(make-literalset (listof (list symbol id ct-phase)))
|#
(define-struct literalset (literals) #:transparent)
@ -110,14 +110,14 @@ DeclEnv =
(listof ConventionRule))
DeclEntry =
(make-den:lit id id)
(make-den:lit id id ct-phase)
(make-den:class id id (listof syntax) bool)
(make-den:parser id id (listof SAttr) bool bool)
(make-den:delayed id id id)
|#
(define-struct declenv (table conventions))
(define-struct den:lit (internal external))
(define-struct den:lit (internal external phase))
(define-struct den:class (name class args))
(define-struct den:parser (parser description attrs splicing? commit?))
(define-struct den:delayed (parser description class))
@ -127,7 +127,7 @@ DeclEntry =
(for/fold ([table (make-immutable-bound-id-table)])
([literal literals])
(bound-id-table-set table (car literal)
(make den:lit (car literal) (cadr literal))))
(make den:lit (car literal) (cadr literal) (caddr literal))))
conventions))
(define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
@ -141,7 +141,7 @@ DeclEntry =
;; So blame-declare? only applies to stxclass declares
(let ([val (declenv-lookup env id #:use-conventions? #f)])
(match val
[(struct den:lit (_i _e))
[(struct den:lit (_i _e _p))
(wrong-syntax id "identifier previously declared as literal")]
[(struct den:class (name _c _a))
(if (and blame-declare? stxclass-name)
@ -205,6 +205,11 @@ DeclEntry =
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr?))
;; ct-phase
;; #f means not specified, ie default, ie 0
;; syntax means computed by given expr
(define ct-phase/c (or/c syntax? #f))
(provide (struct-out den:lit)
(struct-out den:class)
(struct-out den:parser)
@ -214,12 +219,13 @@ DeclEntry =
[DeclEnv/c contract?]
[DeclEntry/c contract?]
[SideClause/c contract?]
[ct-phase/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]
[stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
[new-declenv
(->* [(listof (list/c identifier? identifier?))]
(->* [(listof (list/c identifier? identifier? ct-phase/c))]
[#:conventions list?]
DeclEnv/c)]
[declenv-lookup

8
collects/syntax/private/stxparse/rep-patterns.rkt
View File

@ -17,7 +17,7 @@ A Base is (listof IAttr)
A SinglePattern is one of
(make-pat:any Base)
(make-pat:var Base id id (listof stx) (listof IAttr) bool)
(make-pat:literal Base identifier)
(make-pat:literal Base identifier ct-phase)
(make-pat:datum Base datum)
(make-pat:ghost Base GhostPattern SinglePattern)
(make-pat:head Base HeadPattern SinglePattern)
@ -38,7 +38,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
(define-struct pat:literal (attrs id) #:prefab)
(define-struct pat:literal (attrs id phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:ghost (attrs ghost inner) #:prefab)
(define-struct pat:head (attrs head tail) #:prefab)
@ -186,8 +186,8 @@ A Kind is one of
(define (create-pat:datum datum)
(make pat:datum null datum))
(define (create-pat:literal literal)
(make pat:literal null literal))
(define (create-pat:literal literal phase)
(make pat:literal null literal phase))
(define (create-pat:ghost g sp)
(cond [(ghost:and? g)

99
collects/syntax/private/stxparse/rep.rkt
View File

@ -9,6 +9,7 @@
syntax/keyword
unstable/syntax
unstable/struct
"../util/txlift.ss"
"rep-data.ss"
"codegen-data.ss")
@ -42,12 +43,14 @@
(-> DeclEntry/c
(values DeclEntry/c (listof syntax?)))]
[check-literals-list
;; NEEDS txlift context
(-> syntax? syntax?
(listof (list/c identifier? identifier?)))]
(listof (list/c identifier? identifier? ct-phase/c)))]
#|
[check-literal-sets-list
;; NEEDS txlift context
(-> syntax? syntax?
(listof (listof (list/c identifier? identifier?))))]
(listof (listof (list/c identifier? identifier? ct-phase/c))))]
|#
[check-conventions-rules
(-> syntax? syntax?
@ -124,22 +127,26 @@
;; literals must be bound. Set to #f for pass1 (attr collection);
;; parser requires stxclasses to be bound.
(define (parse-rhs stx expected-attrs splicing? #:context ctx)
(parameterize ((current-syntax-context ctx))
(define-values (rest description transp? attributes auto-nested?
decls defs commit?)
(parse-rhs/part1 stx splicing? (and expected-attrs #t)))
(define patterns
(parameterize ((stxclass-lookup-config
(cond [expected-attrs 'yes]
[auto-nested? 'try]
[else 'no])))
(parse-variants rest decls splicing? expected-attrs)))
(when (null? patterns)
(wrong-syntax #f "expected at least one variant"))
(let ([sattrs
(or attributes
(intersect-sattrss (map variant-attrs patterns)))])
(make rhs stx sattrs transp? description patterns defs commit?))))
(call/txlifts
(lambda ()
(parameterize ((current-syntax-context ctx))
(define-values (rest description transp? attributes auto-nested?
decls defs commit?)
(parse-rhs/part1 stx splicing? (and expected-attrs #t)))
(define patterns
(parameterize ((stxclass-lookup-config
(cond [expected-attrs 'yes]
[auto-nested? 'try]
[else 'no])))
(parse-variants rest decls splicing? expected-attrs)))
(when (null? patterns)
(wrong-syntax #f "expected at least one variant"))
(let ([sattrs
(or attributes
(intersect-sattrss (map variant-attrs patterns)))])
(make rhs stx sattrs transp? description patterns
(append (get-txlifts-as-definitions) defs)
commit?))))))
(define (parse-rhs/part1 stx splicing? strict?)
(define-values (chunks rest)
@ -232,7 +239,7 @@
;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
(define (create-aux-def entry)
(match entry
[(struct den:lit (_i _e))
[(struct den:lit (_i _e _p))
(values entry null)]
[(struct den:class (name class args))
(cond [(identifier? name)
@ -476,8 +483,8 @@
(define (parse-pat:id id decls allow-head?)
(define entry (declenv-lookup decls id))
(match entry
[(struct den:lit (internal literal))
(create-pat:literal literal)]
[(struct den:lit (internal literal phase))
(create-pat:literal literal phase)]
[(struct den:class (_n _c _a))
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
@ -604,9 +611,10 @@
(define (parse-pat:literal stx decls)
(syntax-case stx (~literal)
[(~literal lit)
;; FIXME: support #:phase option here
(unless (identifier? #'lit)
(wrong-syntax #'lit "expected identifier"))
(create-pat:literal #'lit)]
(create-pat:literal #'lit #f)]
[_
(wrong-syntax stx "bad ~~literal pattern")]))
@ -969,7 +977,7 @@
[_
(raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
;; check-literals-list : stx stx -> (listof (list id id))
;; check-literals-list : stx stx -> (listof (list id id ct-phase))
(define (check-literals-list stx ctx)
(unless (stx-list? stx)
(raise-syntax-error #f "expected literals list" ctx stx))
@ -978,15 +986,18 @@
(when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
lits))
;; check-literal-entry : stx stx -> (list id id)
;; check-literal-entry : stx stx -> (list id id ct-phase)
(define (check-literal-entry stx ctx)
(syntax-case stx ()
[(internal external #:phase phase)
(and (identifier? #'internal) (identifier? #'external))
(list #'internal #'external (txlift #'phase))]
[(internal external)
(and (identifier? #'internal) (identifier? #'external))
(list #'internal #'external)]
(list #'internal #'external #f)]
[id
(identifier? #'id)
(list #'id #'id)]
(list #'id #'id #f)]
[_
(raise-syntax-error #f "expected literal (identifier or pair of identifiers)"
ctx stx)]))
@ -997,27 +1008,38 @@
(for/list ([x (stx->list stx)])
(check-literal-set-entry x ctx)))
;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase))
(define (check-literal-set-entry stx ctx)
(define (elaborate litset-id lctx)
(define (elaborate litset-id lctx phase)
;; phase is #f (not specified, means 0) or syntax (expr)
(let ([litset (syntax-local-value/catch litset-id literalset?)])
(unless litset
(raise-syntax-error #f "expected identifier defined as a literal-set"
ctx litset-id))
(elaborate-litset litset lctx stx)))
(elaborate-litset litset lctx phase stx)))
(syntax-case stx ()
[(litset #:at lctx)
(and (identifier? #'litset) (identifier? #'lctx))
(elaborate #'litset #'lctx)]
[(litset . more)
(and (identifier? #'litset))
(let* ([chunks (parse-keyword-options/eol #'more litset-directive-table
#:no-duplicates? #t
#:context ctx)]
[lctx (options-select-value chunks '#:at #:default #'litset)]
[phase (options-select-value chunks '#:phase #:default #f)])
(elaborate #'litset lctx (and phase (txlift phase))))]
[litset
(identifier? #'litset)
(elaborate #'litset #'litset)]
(elaborate #'litset #'litset #f)]
[_
(raise-syntax-error #f "expected literal-set entry" ctx stx)]))
(define (elaborate-litset litset lctx srcctx)
(define (elaborate-litset litset lctx phase srcctx)
;; phase is #f (not specified, means 0) or syntax (expr)
(for/list ([entry (literalset-literals litset)])
(list (datum->syntax lctx (car entry) srcctx)
(cadr entry))))
(cadr entry)
(cond [(not (caddr entry)) phase]
[(not phase) (caddr entry)]
[else #`(phase+ #,(caddr entry) #,phase)]))))
;; returns (listof (cons Conventions (listof syntax)))
(define (check-conventions-list stx ctx)
@ -1140,3 +1162,12 @@
;; h-optional-directive-table
(define h-optional-directive-table
(list (list '#:defaults check-bind-clause-list)))
;; phase-directive-table
(define phase-directive-table
(list (list '#:phase check-expression)))
;; litset-directive-table
(define litset-directive-table
(cons (list '#:at check-identifier)
phase-directive-table))

9
collects/syntax/private/stxparse/runtime.rkt
View File

@ -356,6 +356,8 @@ A Dynamic Frontier Context (DFC) is one of
;; == Expectations
;; FIXME: add phase to expect:literal
#|
An Expectation is one of
'ineffable
@ -599,3 +601,10 @@ An Expectation is one of
#'(k))])
#'(values (lambda (x extra ...) (parser x extra ... arg ...))
(lambda () (get-description arg ...)))))]))
;;
(provide phase+)
(define (phase+ a b)
(and (number? a) (number? b) (+ a b)))

18
collects/syntax/private/stxparse/sc.rkt
View File

@ -4,6 +4,7 @@
unstable/syntax
unstable/struct
"minimatch.ss"
"../util/txlift.ss"
"rep-data.ss"
"rep.ss")
racket/list
@ -146,11 +147,18 @@
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(let ([lits (check-literals-list #'(lit ...) stx)])
(with-syntax ([((internal external) ...) lits])
#'(define-syntax name
(make-literalset
(list (list 'internal (quote-syntax external)) ...))))))]))
(with-txlifts/defs
(lambda ()
(let ([lits (check-literals-list #'(lit ...) stx)])
(with-syntax ([((internal external _) ...) lits]
[(phase ...)
(for/list ([lit lits])
(if (caddr lit)
#`(quote-syntax #,(caddr lit))
#'(quote #f)))])
#'(define-syntax name
(make-literalset
(list (list 'internal (quote-syntax external) phase) ...))))))))]))
;; ----

53
collects/syntax/private/util/txlift.ss Normal file
View File

@ -0,0 +1,53 @@
#lang scheme/base
(require (for-template scheme/base))
(provide txlift
get-txlifts
get-txlifts-as-definitions
call/txlifts
with-txlifts
with-txlifts/defs)
;; Like lifting definitions, but within a single transformer.
(define current-liftbox (make-parameter #f))
(define (call/txlifts proc)
(parameterize ((current-liftbox (box null)))
(proc)))
(define (txlift expr)
(let ([liftbox (current-liftbox)])
(check 'txlift liftbox)
(let ([var (car (generate-temporaries '(txlift)))])
(set-box! liftbox (cons (list var expr) (unbox liftbox)))
var)))
(define (get-txlifts)
(let ([liftbox (current-liftbox)])
(check 'get-txlifts liftbox)
(reverse (unbox liftbox))))
(define (get-txlifts-as-definitions)
(let ([liftbox (current-liftbox)])
(check 'get-txlifts-as-definitions liftbox)
(map (lambda (p)
#`(define #,@p))
(reverse (unbox liftbox)))))
(define (check who lb)
(unless (box? lb)
(error who "not in a txlift-catching context")))
(define (with-txlifts proc)
(call/txlifts
(lambda ()
(let ([v (proc)])
(with-syntax ([((var rhs) ...) (get-txlifts)])
#`(let* ([var rhs] ...) #,v))))))
(define (with-txlifts/defs proc)
(call/txlifts
(lambda ()
(let ([v (proc)])
(with-syntax ([(def ...) (get-txlifts-as-definitions)])
#`(begin def ... #,v))))))