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

factor out create-ehpat code

Browse Source
This commit is contained in:
Ryan Culpepper 2013-03-27 18:54:50 -04:00
parent 1b729d34d8
commit 3dfab4d0aa
2 changed files with 27 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -384,6 +384,23 @@ A SideClause is one of
;; ----
(define (create-ehpat head repc)
(let* ([iattrs0 (pattern-attrs head)]
[iattrs (repc-adjust-attrs iattrs0 repc)])
(ehpat iattrs head repc)))
(define (repc-adjust-attrs iattrs repc)
(cond [(rep:once? repc)
iattrs]
[(rep:optional? repc)
(map attr-make-uncertain iattrs)]
[(or (rep:bounds? repc) (eq? #f repc))
(map increase-depth iattrs)]
[else
(error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
;; ----
(define (action/head-pattern->list-pattern p)
(cond [(action-pattern? p)
(create-pat:action p (create-pat:any))]

39
collects/syntax/parse/private/rep.rkt
View File

@ -588,9 +588,9 @@
(for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))])
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)])
(list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt))
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(eh-alternative-repc alt))
(list (create-ehpat
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(eh-alternative-repc alt))
(replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))]
[(~or . _)
@ -612,18 +612,7 @@
(list (parse*-ehpat/bounds stx decls))]
[_
(let ([head (parse-head-pattern stx decls)])
(list (list (make ehpat (map increase-depth (pattern-attrs head))
head
#f)
stx)))]))
(define (repc-adjust-attrs iattrs repc)
(cond [(or (rep:once? repc) (rep:optional? repc))
iattrs]
[(or (rep:bounds? repc) (eq? #f repc))
(map increase-depth iattrs)]
[else
(error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
(list (list (create-ehpat head #f) stx)))]))
(define (replace-eh-alternative-attrs alt sattrs)
(match alt
@ -945,10 +934,7 @@
(define (parse-pat:plus-dots stx head tail decls)
(define headp (parse-head-pattern head decls))
(define tailp (parse-single-pattern tail decls))
(define head/rep
(make-ehpat (map increase-depth (pattern-attrs headp))
headp
(make-rep:bounds 1 +inf.0 #f #f #f)))
(define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f)))
(create-pat:dots (list head/rep) tailp))
(define (parse-pat:bind stx decls)
@ -1080,9 +1066,7 @@
(define (parse*-ehpat/optional stx decls)
(define-values (head-stx head iattrs name too-many-msg defaults)
(parse*-optional-pattern stx decls eh-optional-directive-table))
(list (make ehpat iattrs
head
(make rep:optional name too-many-msg defaults))
(list (create-ehpat head (make rep:optional name too-many-msg defaults))
head-stx))
;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx)
@ -1102,9 +1086,7 @@
(options-select-value chunks '#:too-many #:default #'#f)]
[name
(options-select-value chunks '#:name #:default #'#f)])
(list (make ehpat (pattern-attrs head)
head
(make rep:once name too-few-msg too-many-msg))
(list (create-ehpat head (make rep:once name too-few-msg too-many-msg))
#'p))]))
;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx)
@ -1135,10 +1117,9 @@
(options-select-value chunks '#:too-many #:default #'#f)]
[name
(options-select-value chunks '#:name #:default #'#f)])
(list (make ehpat (map increase-depth (pattern-attrs head))
head
(make rep:bounds #'min #'max
name too-few-msg too-many-msg))
(list (create-ehpat head
(make rep:bounds #'min #'max
name too-few-msg too-many-msg))
#'p)))]))
;; -----