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

syntax/parse: added ~and H-patterns, ~not S-patterns (no docs yet)

Browse Source 
svn: r16070
This commit is contained in:
Ryan Culpepper 2009-09-19 15:48:07 +00:00
parent e2bf9883cb
commit a58389ad20
6 changed files with 162 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/syntax/private/stxparse/parse.ss
View File

@ -247,6 +247,13 @@
(try (parse:S x fc subpattern
(disjunct subpattern success (enclosing-fail) (id ...)))
...)))]
[#s(pat:not () subpattern)
#`(let ([fail-to-succeed (lambda (_failure) k)]
[outer-fail enclosing-fail])
(with-enclosing-fail* fail-to-succeed
(parse:S x fc subpattern
(with-enclosing-fail outer-fail
(fail x #:expect (expectation pattern0) #:fce fc)))))]
[#s(pat:compound attrs kind0 (part-pattern ...))
(let ([kind (get-kind (wash #'kind0))])
(with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))])
@ -376,6 +383,10 @@
#'null])))
k))
(fail x #:expect result #:fce fc)))]
[#s(hpat:and (a ...) head single)
#`(parse:H x fc head rest index
(let ([lst (stx-list-take x index)])
(parse:S lst fc single k)))]
[#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
@ -560,6 +571,8 @@
#''ineffable]
[(_ #s(pat:fail _ condition message))
#'(expectation-of-message message)]
[(_ #s(pat:not _ pattern))
#''ineffable]
))
;; ----

3
collects/syntax/private/stxparse/rep-attrs.ss
View File

@ -3,8 +3,7 @@
scheme/match
syntax/stx
syntax/id-table
"../util.ss"
"rep-patterns.ss")
"../util.ss")
(provide (struct-out attr))
#|

90
collects/syntax/private/stxparse/rep-patterns.ss
View File

@ -1,5 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base
(require "rep-attrs.ss"
"../util.ss"
(for-syntax scheme/base
syntax/stx
"../util.ss"))
(provide (all-defined-out))
@ -27,6 +29,7 @@ A SinglePattern is one of
(make-pat:dots SPBase (listof EllipsisHeadPattern) SinglePattern)
(make-pat:and SPBase (listof SinglePattern))
(make-pat:or SPBase (listof SinglePattern))
(make-pat:not SPBase SinglePattern)
(make-pat:compound SPBase Kind (listof SinglePattern))
(make-pat:cut SPBase SinglePattern)
(make-pat:describe SPBase stx boolean SinglePattern)
@ -50,6 +53,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:dots (attrs heads tail) #:prefab)
(define-struct pat:and (attrs patterns) #:prefab)
(define-struct pat:or (attrs patterns) #:prefab)
(define-struct pat:not (attrs pattern) #:prefab)
(define-struct pat:compound (attrs kind patterns) #:prefab)
(define-struct pat:cut (attrs pattern) #:prefab)
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
@ -60,6 +64,7 @@ A ListPattern is a subtype of SinglePattern; one of
A HeadPattern is one of
(make-hpat:ssc HPBase id id boolean boolean)
(make-hpat:seq HPBase ListPattern)
(make-hpat:and HPBase HeadPattern SinglePattern)
(make-hpat:or HPBase (listof HeadPattern))
(make-hpat:describe HPBase stx/#f boolean HeadPattern)
(make-hpat:optional HPBase HeadPattern (listof clause:attr))
@ -68,6 +73,7 @@ A HeadPattern is one of
(define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
(define-struct hpat:optional (attrs inner defaults) #:prefab)
@ -105,6 +111,7 @@ A Kind is one of
(pat:dots? x)
(pat:and? x)
(pat:or? x)
(pat:not? x)
(pat:compound? x)
(pat:cut? x)
(pat:describe? x)
@ -114,6 +121,7 @@ A Kind is one of
(define (head-pattern? x)
(or (hpat:ssc? x)
(hpat:seq? x)
(hpat:and? x)
(hpat:or? x)
(hpat:describe? x)
(hpat:optional? x)))
@ -143,7 +151,81 @@ A Kind is one of
(cond [(pred x) (accessor x)] ...
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:name pat:any pat:sc pat:datum pat:literal pat:head
pat:dots pat:and pat:or pat:compound pat:cut pat:describe
pat:bind pat:fail
hpat:ssc hpat:seq hpat:or hpat:describe hpat:optional
pat:dots pat:and pat:or pat:not pat:compound pat:cut
pat:describe pat:bind pat:fail
hpat:ssc hpat:seq hpat:and hpat:or hpat:describe
hpat:optional
ehpat)))
;; ----
;; Helpers to handle attribute calculations
;; Too complicated for a few pattern forms; those are handled in rep.ss
(define (create-pat:any)
(make pat:any null))
(define (create-pat:name pattern ids)
(let ([as (for/list ([id ids]) (make attr id 0 #t))])
(make pat:name (append as (pattern-attrs pattern)) pattern ids)))
(define (create-pat:datum datum)
(make pat:datum null datum))
(define (create-pat:literal literal)
(make pat:literal null literal))
(define (create-pat:compound kind ps)
(make pat:compound (append-iattrs (map pattern-attrs ps)) kind ps))
(define (create-pat:cut inner)
(make pat:cut (pattern-attrs inner) inner))
(define (create-pat:describe description transparent? p)
(make pat:describe (pattern-attrs p) description transparent? p))
(define (create-pat:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make pat:and attrs patterns)))
(define (create-pat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make pat:or attrs patterns)))
(define (create-pat:not pattern)
(make pat:not null pattern))
(define (create-pat:dots headps tailp)
(let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))])
(make pat:dots attrs headps tailp)))
(define (create-pat:fail condition message)
(make pat:fail null condition message))
(define (create-pat:head headp tailp)
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))])
(make pat:head attrs headp tailp)))
;; ----
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))
(define (create-hpat:describe description transparent? p)
(make hpat:describe (pattern-attrs p) description transparent? p))
(define (create-hpat:and hp sp)
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))
(define (create-hpat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make hpat:or attrs patterns)))
;; ----
(define (head-pattern->list-pattern hp)
;; simplification: just extract list pattern from hpat:seq
(if (hpat:seq? hp)
(hpat:seq-inner hp)
(create-pat:head hp (create-pat:datum '()))))

95
collects/syntax/private/stxparse/rep.ss
View File

@ -73,8 +73,10 @@
(list (quote-syntax _)
(quote-syntax ||)
(quote-syntax ...)
(quote-syntax ~var)
(quote-syntax ~and)
(quote-syntax ~or)
(quote-syntax ~not)
(quote-syntax ~seq)
(quote-syntax ~rep)
(quote-syntax ~once)
@ -252,10 +254,10 @@
;; parse-single-pattern : stx DeclEnv -> SinglePattern
(define (parse-single-pattern stx decls)
(syntax-case stx (~and ~or ~rest ~struct ~! ~describe ~bind ~fail)
(syntax-case stx (~var ~and ~or ~not ~rest ~struct ~! ~describe ~bind ~fail)
[wildcard
(wildcard? #'wildcard)
(make pat:any null)]
(create-pat:any)]
[reserved
(reserved? #'reserved)
(wrong-syntax stx "not allowed here")]
@ -264,21 +266,23 @@
(parse-pat:id stx decls #f)]
[datum
(atomic-datum? #'datum)
(make pat:datum null (syntax->datum #'datum))]
(create-pat:datum (syntax->datum #'datum))]
[(~and . rest)
(parse-pat:and stx decls)]
(parse-pat:and stx decls #f)]
[(~or . rest)
(parse-pat:or stx decls #f)]
[(~not . rest)
(parse-pat:not stx decls)]
[(head dots . tail)
(dots? #'dots)
(parse-pat:dots stx #'head #'tail decls)]
[(~struct key . contents)
(let ([lp (parse-single-pattern (syntax/loc stx contents) decls)]
[key (syntax->datum #'key)])
(make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp)))]
(create-pat:compound `(#:pstruct ,key) (list lp)))]
[(~! . rest)
(let ([inner (parse-single-pattern (syntax/loc stx rest) decls)])
(make pat:cut (pattern-attrs inner) inner))]
(create-pat:cut inner))]
[(~describe . rest)
(parse-pat:describe stx decls #f)]
[(~bind . rest)
@ -291,25 +295,27 @@
(parse-pat:pair stx #'head #'tail decls)]
[#(a ...)
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
(make pat:compound (pattern-attrs lp) '#:vector (list lp)))]
(create-pat:compound '#:vector (list lp)))]
[b
(box? (syntax-e #'b))
(let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)])
(make pat:compound (pattern-attrs bp) '#:box (list bp)))]
(create-pat:compound '#:box (list bp)))]
[s
(and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
(let* ([s (syntax-e #'s)]
[key (prefab-struct-key s)]
[contents (cdr (vector->list (struct->vector s)))])
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
(make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp))))]))
(create-pat:compound `(#:pstruct ,key) (list lp))))]))
;; parse-head-pattern : stx DeclEnv -> HeadPattern
(define (parse-head-pattern stx decls)
(syntax-case stx (~or ~seq ~describe ~optional)
(syntax-case stx (~var ~and ~or ~seq ~describe ~optional)
[id
(and (identifier? #'id) (not (reserved? #'id)))
(parse-pat:id stx decls #t)]
[(~and . rest)
(parse-pat:and stx decls #t)]
[(~or . rest)
(parse-pat:or stx decls #t)]
[(~seq . rest)
@ -342,7 +348,7 @@
(define entry (declenv-lookup decls id))
(match entry
[(list 'literal internal-id literal-id)
(make pat:literal null literal-id)]
(create-pat:literal literal-id)]
[(list 'stxclass _ _ _)
(error 'parse-pat:id
"(internal error) decls had leftover 'stxclass entry: ~s"
@ -370,7 +376,7 @@
(stxclass-description sc)
(stxclass-attrs sc))]
[else
(wrap/name name (make pat:any null))]))]))
(wrap/name name (create-pat:any))]))]))
(define (parse-pat:id/s stx name parser description attrs)
(define prefix (name->prefix name))
@ -398,8 +404,7 @@
(cond [(wildcard? id) pattern]
[(epsilon? id) pattern]
[else
(let ([a (make attr id 0 #t)])
(make pat:name (cons a (pattern-attrs pattern)) pattern (list id)))]))
(create-pat:name pattern (list id))]))
;; id-pattern-attrs : (listof SAttr) id/#f IdPrefix -> (listof IAttr)
(define (id-pattern-attrs sattrs bind prefix)
@ -436,31 +441,49 @@
[(description pattern)
(let ([p (parse-some-pattern #'pattern decls allow-head?)])
(if (head-pattern? p)
(make hpat:describe (pattern-attrs p)
#'description transparent? p)
(make pat:describe (pattern-attrs p)
#'description transparent? p)))]))]))
(create-hpat:describe #'description transparent? p)
(create-pat:describe #'description transparent? p)))]))]))
(define (parse-pat:or stx decls allow-head?)
(define patterns (parse-cdr-patterns stx decls allow-head? #f))
(cond [(null? (cdr patterns))
(car patterns)]
[else
(let ()
(define attrs (union-iattrs (map pattern-attrs patterns)))
(cond [(ormap head-pattern? patterns)
(make-hpat:or attrs patterns)]
[else
(make-pat:or attrs patterns)]))]))
(cond [(ormap head-pattern? patterns)
(create-hpat:or patterns)]
[else
(create-pat:or patterns)])]))
(define (parse-pat:and stx decls)
(define patterns (parse-cdr-patterns stx decls #f #t))
(make pat:and (append-iattrs (map pattern-attrs patterns)) patterns))
(define (parse-pat:and stx decls allow-head?)
(define patterns (parse-cdr-patterns stx decls allow-head? #t))
(cond [(null? (cdr patterns))
(car patterns)]
[(ormap head-pattern? patterns)
;; Check to make sure *all* are head patterns
(for ([pattern patterns]
[pattern-stx (stx->list (stx-cdr stx))])
(unless (head-pattern? pattern)
(wrong-syntax
pattern-stx
"single-term pattern not allowed after head pattern")))
(let ([p0 (car patterns)]
[lps (map head-pattern->list-pattern (cdr patterns))])
(create-hpat:and p0 (create-pat:and lps)))]
[else
(create-pat:and patterns)]))
(define (parse-pat:not stx decls)
(syntax-case stx (~not)
[(~not pattern)
(let ([p (parse-single-pattern #'pattern decls)])
(create-pat:not p))]
[_
(wrong-syntax stx "expected a single subpattern")]))
(define (parse-hpat:seq stx list-stx decls)
(define pattern (parse-single-pattern list-stx decls))
(check-list-pattern pattern stx)
(make hpat:seq (pattern-attrs pattern) pattern))
(create-hpat:seq pattern))
(define (parse-cdr-patterns stx decls allow-head? allow-cut?)
(unless (stx-list? stx)
@ -477,7 +500,7 @@
(define (parse-cut-in-and stx)
(syntax-case stx (~!)
[~! (make pat:cut null (make pat:any null))]
[~! (create-pat:cut (create-pat:any))]
[_ #f]))
(define (parse-some-pattern stx decl allow-head?)
@ -501,10 +524,7 @@
[_
(list (parse-ellipsis-head-pattern head decls))]))
(define tailp (parse-single-pattern tail decls))
(define attrs
(append-iattrs (cons (pattern-attrs tailp)
(map pattern-attrs headps))))
(make pat:dots attrs headps tailp))
(create-pat:dots headps tailp))
(define (parse-pat:bind stx decls)
(syntax-case stx ()
@ -531,7 +551,7 @@
#`(not #,(caddr chunk)))))])
(syntax-case rest ()
[(message)
(make pat:fail null condition #'message)]
(create-pat:fail condition #'message)]
[()
(wrong-syntax stx "missing message expression")]
[_
@ -545,14 +565,11 @@
(define (parse-pat:pair stx head tail decls)
(define headp (parse-head-pattern head decls))
(define tailp (parse-single-pattern tail decls))
(define attrs
(append-iattrs
(list (pattern-attrs headp) (pattern-attrs tailp))))
;; Only make pat:head if head is complicated; otherwise simple compound/pair
;; FIXME: Could also inline ~seq patterns from head...?
(if (head-pattern? headp)
(make pat:head attrs headp tailp)
(make pat:compound attrs '#:pair (list headp tailp))))
(create-pat:head headp tailp)
(create-pat:compound '#:pair (list headp tailp))))
(define (check-list-pattern pattern stx)
(match pattern

4
collects/syntax/private/stxparse/runtime.ss
View File

@ -11,8 +11,10 @@
"../util.ss"))
(provide pattern
~var
~and
~or
~not
~seq
~bounds
~once
@ -74,8 +76,10 @@
(raise-syntax-error #f "keyword used out of context" stx))))
(define-keyword pattern)
(define-keyword ~var)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ~not)
(define-keyword ~seq)
(define-keyword ~bounds)
(define-keyword ~once)

2
collects/syntax/private/stxparse/sc.ss
View File

@ -26,8 +26,10 @@
syntax-parser
pattern
~var
~and
~or
~not
~seq
~bounds
~once