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

syntax/parse: factor out stxclass options passed on to pattern reps

Browse Source 
And fix recent pattern-has-cut? for stxclasses w/ no-delimit-cut option.
This commit is contained in:
Ryan Culpepper 2016-12-07 17:13:42 -05:00
parent 8e5ccd3239
commit e0ccdc769a
10 changed files with 65 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/collects/syntax/parse/experimental/provide.rkt
View File

@ -61,7 +61,7 @@
(join-sep (map kw->string maxkws*) "," "and")
(join-sep (map kw->string maxkws) "," "and")))
(with-syntax ([scname scname]
[#s(stxclass name arity attrs parser splicing? commit? delimit? inline desc)
[#s(stxclass name arity attrs parser splicing? opts inline)
stxclass]
[#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
(opc ...) (okw ...) (okwc ...))
@ -100,8 +100,7 @@
'attrs
(quote-syntax contracted-parser)
'splicing?
'commit? 'delimit?
#f 'desc)) ;; must disable integration
'opts #f)) ;; must disable inlining
(provide (rename-out [contracted-scname scname])))))))])))
(define-syntax (provide-syntax-class/contract stx)

5
racket/collects/syntax/parse/experimental/reflect.rkt
View File

@ -12,8 +12,7 @@
(begin-for-syntax
(lazy-require
[syntax/parse/private/rep-data ;; keep abs. path
(get-stxclass
stxclass-delimit-cut?)]))
(get-stxclass)]))
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path (for-meta 2 '#%kernel))
@ -26,7 +25,7 @@
(with-disappeared-uses
(let* ([stxclass (get-stxclass #'sc)]
[splicing? (stxclass-splicing? stxclass)])
(unless (stxclass-delimit-cut? stxclass)
(unless (scopts-delimit-cut? (stxclass-opts stxclass))
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
stx #'sc))
(with-syntax ([name (stxclass-name stxclass)]

7
racket/collects/syntax/parse/experimental/specialize.rkt
View File

@ -27,17 +27,14 @@
[splicing? (stxclass-splicing? target)]
[arity arity]
[attrs (stxclass-attrs target)]
[commit? (stxclass-commit? target)]
[delimit-cut? (stxclass-delimit-cut? target)]
[opts (stxclass-opts target)]
[target-parser (stxclass-parser target)]
[desc (stxclass-desc target)]
[argu argu])
#`(begin (define-syntax name
(stxclass 'name 'arity 'attrs
(quote-syntax parser)
'splicing?
'commit? 'delimit-cut?
#f 'desc))
'opts #f))
(define-values (parser)
(lambda (x cx pr es fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

4
racket/collects/syntax/parse/experimental/splicing.rkt
View File

@ -58,8 +58,8 @@
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
(quote-syntax parser)
#t
#t #t
#f #f)))]))
(scopts (length '(a.name ...)) #t #t #f)
#f)))]))
(define (mk-permute unsorted-attrs)
(let ([sorted-attrs

6
racket/collects/syntax/parse/private/opt.rkt
View File

@ -170,7 +170,7 @@
(match p
[(pat:any) #t]
[(pat:svar _n) #t]
[(pat:var/p _n _p _argu _na _ac commit? _r)
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
;; commit? implies delimit-cut
commit?]
[(? pat:integrated?) #t]
@ -211,7 +211,7 @@
[(pat:post pattern)
(pattern-factorable? pattern)]
;; ----
[(hpat:var/p _name _parser _argu _na _ac commit? _role)
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
commit?]
[(hpat:seq inner)
(pattern-factorable? inner)]
@ -410,7 +410,7 @@
(format-symbol "~a:~a" (or name '_) desc)]
[(pat:svar name)
(syntax-e name)]
[(pat:var/p name parser _ _ _ _ _)
[(pat:var/p name parser _ _ _ _)
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m)
(format-symbol "~a:~a" (or name '_) (cadr m)))]

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

@ -68,10 +68,8 @@
'attrs
(quote-syntax parser)
'#,splicing?
'commit?
'delimit-cut?
#f
'desc))
(scopts (length 'attrs) 'commit? 'delimit-cut? desc)
#f))
(define-values (parser)
(parser/rhs name formals attrs rhss #,splicing? #,stx)))))))])))
@ -89,10 +87,8 @@
(stxclass 'name no-arity '()
(quote-syntax parser)
#f
#t
#t
(quote-syntax predicate)
'description))
(scopts 0 #t #t 'description)
(quote-syntax predicate)))
(define (parser x cx pr es fh0 cp0 rl success)
(if (predicate x)
(success fh0)
@ -526,7 +522,8 @@ Conventions:
[#s(pat:svar name)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)]
[#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role _desc)
[#s(pat:var/p name parser argu (nested-a ...) role
#s(scopts attr-count commit? _delimit? _desc))
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -695,8 +692,8 @@ Conventions:
#''(any)]
[#s(pat:svar name)
#''(any)]
[#s(pat:var/p _ ...)
#`(quote #,(pat:var/p-desc (syntax-e #'p)))]
[#s(pat:var/p _ _ _ _ _ #s(scopts _ _ _ desc))
#'(quote desc)]
[#s(pat:datum d)
#''(datum d)]
[#s(pat:literal id _ip _lp)
@ -720,7 +717,7 @@ Conventions:
(syntax-case stx ()
[(fdh hpat)
(syntax-case #'hpat ()
[#s(hpat:var/p _n _p _a _na _ac _c? _r desc) #'desc]
[#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)]
[#s(hpat:seq lp) #'(first-desc:L lp)]
[#s(hpat:describe _hp desc _t? _r)
#`(quote #,(or (constant-desc #'desc) #'#f))]
@ -814,7 +811,8 @@ Conventions:
(parse:H x cx rest-x rest-cx rest-pr pattern pr* es*
(let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
k)))]
[#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role _desc)
[#s(hpat:var/p name parser argu (nested-a ...) role
#s(scopts attr-count commit? _delimit? _desc))
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)

11
racket/collects/syntax/parse/private/rep-data.rkt
View File

@ -4,7 +4,6 @@
syntax/private/id-table
racket/syntax
syntax/parse/private/residual-ct ;; keep abs. path
"make.rkt"
"minimatch.rkt"
"kws.rkt")
;; from residual.rkt
@ -46,7 +45,7 @@
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
(define (make-dummy-stxclass name)
(make stxclass (syntax-e name) #f null #f #f #f #t #f #f))
(stxclass (syntax-e name) #f null #f #f (scopts 0 #t #t #f) #f))
;; Environments
@ -60,7 +59,7 @@ DeclEntry =
- (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 String/#f)
- (den:parser Id (Listof SAttr) Bool scopts)
- (den:delayed Id Id)
Arguments is defined in rep-patterns.rkt
@ -90,7 +89,7 @@ expressions are duplicated, and may be evaluated in different scopes.
(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? desc))
(define-struct den:parser (parser attrs splicing? opts))
;; and from residual.rkt:
;; (define-struct den:lit (internal external input-phase lit-phase))
;; (define-struct den:datum-lit (internal external))
@ -135,7 +134,7 @@ expressions are duplicated, and may be evaluated in different scopes.
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(den:parser _p _a _sp _c _dc? _desc)
[(den:parser _p _a _sp _opts)
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
@ -143,7 +142,7 @@ expressions are duplicated, and may be evaluated in different scopes.
(declenv-check-unbound env id)
(make-declenv
(bound-id-table-set (declenv-table env) id
(make den:magic-class id stxclass-name argu role))
(den:magic-class id stxclass-name argu role))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a

20
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -13,7 +13,7 @@ Uses Arguments from kws.rkt
A SinglePattern is one of
(pat:any)
(pat:svar id) -- "simple" var, no stxclass
(pat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f) -- var with parser
(pat:var/p Id Id Arguments (Listof IAttr) Stx scopts) -- var with parser
(pat:literal identifier Stx Stx)
(pat:datum datum)
(pat:action ActionPattern SinglePattern)
@ -44,7 +44,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:any () #:prefab)
(define-struct pat:svar (name) #:prefab)
(define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab)
(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab)
(define-struct pat:literal (id input-phase lit-phase) #:prefab)
(define-struct pat:datum (datum) #:prefab)
(define-struct pat:action (action inner) #:prefab)
@ -91,7 +91,7 @@ A SideClause is just an ActionPattern
#|
A HeadPattern is one of
(hpat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f)
(hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts)
(hpat:seq ListPattern)
(hpat:action ActionPattern HeadPattern)
(hpat:and HeadPattern SinglePattern)
@ -106,7 +106,7 @@ A HeadPattern is one of
(hpat:peek-not HeadPattern)
|#
(define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab)
(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab)
(define-struct hpat:seq (inner) #:prefab)
(define-struct hpat:action (action inner) #:prefab)
(define-struct hpat:and (head single) #:prefab)
@ -214,7 +214,7 @@ A RepConstraint is one of
null]
[(pat:svar name)
(list (attr name 0 #t))]
[(pat:var/p name _ _ nested-attrs _ _ _ _)
[(pat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
@ -274,7 +274,7 @@ A RepConstraint is one of
(pattern-attrs sp)]
;; -- H patterns
[(hpat:var/p name _ _ nested-attrs _ _ _ _)
[(hpat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
@ -315,9 +315,7 @@ A RepConstraint is one of
;; -- S patterns
[(pat:any) #f]
[(pat:svar name) #f]
[(pat:var/p name _ _ _ _ _ _ _)
;; FIXME: need delimit-cut? info from stxclass
#f]
[(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(pat:reflect _ _ _ name nested-attrs) #f]
[(pat:datum _) #f]
[(pat:literal _ _ _) #f]
@ -349,9 +347,7 @@ A RepConstraint is one of
[(action:post sp) (pattern-has-cut? sp)]
;; -- H patterns
[(hpat:var/p name _ _ _ _ _ _ _)
;; FIXME: need delimit-cut?
#f]
[(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(hpat:reflect _ _ _ name nested-attrs) #f]
[(hpat:seq lp) (pattern-has-cut? lp)]
[(hpat:action a hp) (or (pattern-has-cut? a) (pattern-has-cut? hp))]

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

@ -266,11 +266,11 @@
;; FIXME: replace with txlift mechanism
(define (create-aux-def entry)
(match entry
[(den:lit _i _e _ip _lp)
[(? den:lit?)
(values entry null)]
[(den:datum-lit _i _e)
[(? den:datum-lit?)
(values entry null)]
[(den:magic-class name class argu role)
[(? den:magic-class?)
(values entry null)]
[(den:class name class argu)
;; FIXME: integrable syntax classes?
@ -283,8 +283,7 @@
(with-syntax ([parser (generate-temporary class)])
(values (make den:parser #'parser
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc) (stxclass-delimit-cut? sc)
(stxclass-desc sc))
(stxclass-opts sc))
(list #`(define-values (parser)
(curried-stxclass-parser #,class #,argu)))))))]
[(regexp? name)
@ -295,9 +294,9 @@
(values (make den:delayed #'parser class)
(list #`(define-values (parser)
(curried-stxclass-parser #,class #,argu)))))])]
[(den:parser _p _a _sp _c _dc? _desc)
[(? den:parser?)
(values entry null)]
[(den:delayed _p _c)
[(? den:delayed?)
(values entry null)]))
;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit))
@ -646,7 +645,8 @@
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)])
(list (create-ehpat
(hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f #f)
(hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f
(scopts attr-count #f #t #f))
(eh-alternative-repc alt)
#f)
(replace-eh-alternative-attrs
@ -720,14 +720,14 @@
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(den:parser parser attrs splicing? commit? delimit-cut? desc)
(check-no-delimit-cut-in-not id delimit-cut?)
[(den:parser parser attrs splicing? opts)
(check-no-delimit-cut-in-not id (scopts-delimit-cut? opts))
(cond [splicing?
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id parser no-arguments attrs commit? "." #f desc)]
(parse-pat:id/h id parser no-arguments attrs "." #f opts)]
[else
(parse-pat:id/s id parser no-arguments attrs commit? "." #f desc)])]
(parse-pat:id/s id parser no-arguments attrs "." #f opts)])]
[(den:delayed parser class)
(let ([sc (get-stxclass class)])
(parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))]))
@ -773,20 +773,19 @@
(define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*)
;; if parser* not #f, overrides sc parser
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
(check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc)))
(cond [(and (stxclass/s? sc)
(stxclass-inline sc)
(equal? argu no-arguments))
(parse-pat:id/s/integrate name (stxclass-inline sc) (stxclass-desc sc) role)]
(parse-pat:id/s/integrate name (stxclass-inline sc) (scopts-desc (stxclass-opts sc)) role)]
[(stxclass/s? sc)
(parse-pat:id/s name
(or parser* (stxclass-parser sc))
argu
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx
role
(stxclass-desc sc))]
(stxclass-opts sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax stx "splicing syntax class not allowed here"))
@ -794,24 +793,23 @@
(or parser* (stxclass-parser sc))
argu
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx
role
(stxclass-desc sc))]))
(stxclass-opts sc))]))
(define (parse-pat:id/s name parser argu attrs commit? pfx role desc)
(define (parse-pat:id/s name parser argu attrs pfx role opts)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc))
(pat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts))
(define (parse-pat:id/s/integrate name predicate description role)
(define bind (name->bind name))
(pat:integrated bind predicate description role))
(define (parse-pat:id/h name parser argu attrs commit? pfx role desc)
(define (parse-pat:id/h name parser argu attrs pfx role opts)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc))
(hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts))
(define (name->prefix id pfx)
(cond [(wildcard? id) #f]

12
racket/collects/syntax/parse/private/residual-ct.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(provide (struct-out attr)
(struct-out stxclass)
(struct-out scopts)
(struct-out conventions)
(struct-out literalset)
(struct-out lse:lit)
@ -27,16 +28,23 @@
;; == from rep-data.rkt
;; A stxclass is #s(stxclass Symbol Symbols SAttrs Id Bool Bool BoolOptions Id/#f String/#f)
;; A stxclass is #s(stxclass Symbol Arity SAttrs Id Bool scopts Id/#f)
(define-struct stxclass
(name ;; Symbol
arity ;; Arity (defined in kws.rkt)
attrs ;; (Listof SAttr)
parser ;; Id, reference to parser (see parse.rkt for parser signature)
splicing? ;; Bool
opts ;; scopts
inline ;; Id/#f, reference to a predicate
) #:prefab)
;; A scopts is #s(scopts Nat Bool Bool String/#f)
;; These are passed on to var patterns.
(define-struct scopts
(attr-count ;; Nat
commit? ;; Bool
delimit-cut? ;; Bool
inline ;; Id/#f, reference to a predicate
desc ;; String/#f, String = known constant description
) #:prefab)