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

syntax/parse: added explicit ~var and ~literal forms (no docs yet)

Browse Source 
svn: r16077
This commit is contained in:
Ryan Culpepper 2009-09-19 20:04:00 +00:00
parent 3ce1ce4c73
commit 282d36e363
6 changed files with 131 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -202,20 +202,17 @@
(parse:S x fc pattern k))]
[#s(pat:any attrs)
#'k]
[#s(pat:sc (a ...) parser description bind-term? bind-attrs?)
#`(let ([result (parser x)])
[#s(pat:var _attrs name #f () ())
#'(let-attributes ([#s(attr name 0 #t) x])
k)]
[#s(pat:var _attrs name parser (arg ...) (nested-a ...))
#`(let ([result (parser x arg ...)])
(if (ok? result)
(let/unpack ((a ...)
#,(let ([bind-term? (syntax-e #'bind-term?)]
[bind-attrs? (syntax-e #'bind-attrs?)])
(cond [(and bind-term? bind-attrs?)
#'(cons x result)]
[bind-term? ;; not possible, I think
#'(list x)]
[bind-attrs?
#'result]
[else #'null])))
k)
(let-attributes (#,@(if (identifier? #'name)
#'([#s(attr name 0 #t) x])
#'()))
(let/unpack ((nested-a ...) result)
k))
(fail x #:expect result #:fce fc)))]
[#s(pat:datum attrs datum)
#`(let ([d (syntax-e x)])
@ -365,23 +362,17 @@
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k)))))]
[#s(hpat:ssc (a ...) parser description bind-term? bind-attrs?)
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...))
#`(let ([result (parser x)])
(if (ok? result)
(let ([rest (car result)]
[index (cadr result)])
(let/unpack ((a ...)
#,(let ([bind-term? (syntax-e #'bind-term?)]
[bind-attrs? (syntax-e #'bind-attrs?)])
(cond [(and bind-term? bind-attrs?)
#`(cons (stx-list-take x index) (cddr result))]
[bind-term?
#'(list (stx-list-take x index))]
[bind-attrs?
#'(cddr result)]
[else
#'null])))
k))
(let-attributes (#,@(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x index)])
#'()))
(let/unpack ((nested-a ...) (cddr result))
k)))
(fail x #:expect result #:fce fc)))]
[#s(hpat:and (a ...) head single)
#`(parse:H x fc head rest index

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

@ -20,9 +20,8 @@ If identifier, it already includes the colon part, unless epsilon
#|
A SinglePattern is one of
(make-pat:name SPBase SinglePattern (listof identifier))
(make-pat:any SPBase)
(make-pat:sc SPBase id id boolean boolean)
(make-pat:var SPBase id id (listof stx) (listof IAttr))
(make-pat:datum SPBase datum)
(make-pat:literal SPBase identifier)
(make-pat:head SPBase HeadPattern SinglePattern)
@ -44,9 +43,8 @@ A ListPattern is a subtype of SinglePattern; one of
(make-pat:cut SPBase ListPattern)
|#
(define-struct pat:name (attrs pattern names) #:prefab)
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:sc (attrs parser description bind-term? bind-attrs?) #:prefab)
(define-struct pat:var (attrs name parser args nested-attrs) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:literal (attrs id) #:prefab)
(define-struct pat:head (attrs head tail) #:prefab)
@ -61,8 +59,8 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:bind (attrs clauses) #:prefab)
#|
A HeadPattern is one of
(make-hpat:ssc HPBase id id boolean boolean)
A HeadPattern is one of
(make-pat:var SPBase id id (listof stx) (listof IAttr))
(make-hpat:seq HPBase ListPattern)
(make-hpat:and HPBase HeadPattern SinglePattern)
(make-hpat:or HPBase (listof HeadPattern))
@ -70,7 +68,7 @@ A HeadPattern is one of
(make-hpat:optional HPBase HeadPattern (listof clause:attr))
|#
(define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab)
(define-struct hpat:var (attrs name parser args nested-attrs) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
@ -102,9 +100,8 @@ A Kind is one of
|#
(define (pattern? x)
(or (pat:name? x)
(pat:any? x)
(pat:sc? x)
(or (pat:any? x)
(pat:var? x)
(pat:datum? x)
(pat:literal? x)
(pat:head? x)
@ -119,7 +116,7 @@ A Kind is one of
(pat:fail? x)))
(define (head-pattern? x)
(or (hpat:ssc? x)
(or (hpat:var? x)
(hpat:seq? x)
(hpat:and? x)
(hpat:or? x)
@ -150,10 +147,10 @@ A Kind is one of
#'(lambda (x)
(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:not pat:compound pat:cut
pat:describe pat:bind pat:fail
hpat:ssc hpat:seq hpat:and hpat:or hpat:describe
(mk-get-attrs pat:any pat:var pat:datum pat:literal pat:head pat:dots
pat:and pat:or pat:not pat:compound
pat:cut pat:describe pat:bind pat:fail
hpat:var hpat:seq hpat:and hpat:or hpat:describe
hpat:optional
ehpat)))
@ -166,9 +163,10 @@ A Kind is one of
(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:var name parser args nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser args nested-attrs)))
(define (create-pat:datum datum)
(make pat:datum null datum))
@ -209,6 +207,11 @@ A Kind is one of
;; ----
(define (create-hpat:var name parser args nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser args nested-attrs)))
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))

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

@ -74,6 +74,7 @@
(quote-syntax ||)
(quote-syntax ...)
(quote-syntax ~var)
(quote-syntax ~literal)
(quote-syntax ~and)
(quote-syntax ~or)
(quote-syntax ~not)
@ -94,6 +95,10 @@
(for/or ([kw keywords])
(free-identifier=? stx kw))))
(define (safe-name? stx)
(and (identifier? stx)
(not (regexp-match? #rx"^~" (symbol->string (syntax-e stx))))))
;; ---
;; parse-rhs : stx boolean boolean stx -> RHS
@ -254,7 +259,8 @@
;; parse-single-pattern : stx DeclEnv -> SinglePattern
(define (parse-single-pattern stx decls)
(syntax-case stx (~var ~and ~or ~not ~rest ~struct ~! ~describe ~bind ~fail)
(syntax-case stx (~var ~literal ~and ~or ~not ~rest ~struct
~! ~describe ~bind ~fail)
[wildcard
(wildcard? #'wildcard)
(create-pat:any)]
@ -267,6 +273,10 @@
[datum
(atomic-datum? #'datum)
(create-pat:datum (syntax->datum #'datum))]
[(~var . rest)
(parse-pat:var stx decls #f)]
[(~literal . rest)
(parse-pat:literal stx decls)]
[(~and . rest)
(parse-pat:and stx decls #f)]
[(~or . rest)
@ -314,6 +324,8 @@
[id
(and (identifier? #'id) (not (reserved? #'id)))
(parse-pat:id stx decls #t)]
[(~var . rest)
(parse-pat:var stx decls #t)]
[(~and . rest)
(parse-pat:and stx decls #t)]
[(~or . rest)
@ -358,37 +370,73 @@
"(internal error) decls had leftover 'splicing-stxclass entry: ~s"
entry)]
[(list 'parser parser description attrs)
(parse-pat:id/s id id parser description attrs)]
(parse-pat:id/s id parser null attrs)]
[(list 'splicing-parser parser description attrs)
(parse-pat:id/h id id parser description attrs)]
(parse-pat:id/h id parser null attrs)]
[#f
#|
(unless (safe-name? id)
(wrong-syntax id "expected identifier not starting with ~ character"))
|#
(let-values ([(name sc) (split-id/get-stxclass id decls)])
(cond [(stxclass/s? sc)
(parse-pat:id/s id name
(stxclass-parser-name sc)
(stxclass-description sc)
(stxclass-attrs sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id name
(stxclass-parser-name sc)
(stxclass-description sc)
(stxclass-attrs sc))]
[else
(wrap/name name (create-pat:any))]))]))
(if sc
(parse-pat:var* id allow-head? name sc null)
(create-pat:var name #f null null)))]))
(define (parse-pat:id/s stx name parser description attrs)
(define (parse-pat:var stx decls allow-head?)
(define name0
(syntax-case stx (~var)
[(~var name . _)
(unless (identifier? #'name)
(wrong-syntax #'name "expected identifier"))
#'name]
[_
(wrong-syntax stx "bad ~var form")]))
(define-values (scname args)
(syntax-case stx (~var)
[(~var _name)
(values #f null)]
[(~var _name sc)
(identifier? #'sc)
(values #'sc null)]
[(~var _name (sc arg ...))
(identifier? #'sc)
(values #'sc (syntax->list #'(arg ...)))]
[_
(wrong-syntax stx "bad ~var form")]))
(cond [(and (epsilon? name0) (not scname))
(wrong-syntax name0 "illegal pattern variable name")]
[(and (wildcard? name0) (not scname))
(create-pat:any)]
[scname
(let ([sc (get-stxclass/check-arg-count scname (length args))])
(parse-pat:var* stx allow-head? name0 sc args))]
[else ;; Just proper name
(create-pat:var name0 #f null null)]))
(define (parse-pat:var* stx allow-head? name sc args)
(cond [(stxclass/s? sc)
(parse-pat:id/s name
(stxclass-parser-name sc)
args
(stxclass-attrs sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax stx "splicing syntax class not allowed here"))
(parse-pat:id/h name
(stxclass-parser-name sc)
args
(stxclass-attrs sc))]))
(define (parse-pat:id/s name parser args attrs)
(define prefix (name->prefix name))
(define bind (name->bind name))
(make pat:sc (id-pattern-attrs attrs bind prefix)
parser description (and bind #t) (and prefix #t)))
(create-pat:var bind parser args (id-pattern-attrs attrs prefix)))
(define (parse-pat:id/h stx name parser description attrs)
(define (parse-pat:id/h name parser args attrs)
(define prefix (name->prefix name))
(define bind (name->bind name))
(make hpat:ssc (id-pattern-attrs attrs bind prefix)
parser description (and bind #t) (and prefix #t)))
(create-hpat:var bind parser args (id-pattern-attrs attrs prefix)))
(define (name->prefix id)
(cond [(wildcard? id) #f]
@ -400,22 +448,12 @@
[(epsilon? id) #f]
[else id]))
(define (wrap/name id pattern)
(cond [(wildcard? id) pattern]
[(epsilon? id) pattern]
[else
(create-pat:name pattern (list id))]))
;; id-pattern-attrs : (listof SAttr) id/#f IdPrefix -> (listof IAttr)
(define (id-pattern-attrs sattrs bind prefix)
(let ([rest
(if prefix
(for/list ([a sattrs])
(prefix-attr a prefix))
null)])
(if bind
(cons (make attr bind 0 #t) rest)
rest)))
;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr)
(define (id-pattern-attrs sattrs prefix)
(if prefix
(for/list ([a sattrs])
(prefix-attr a prefix))
null))
;; prefix-attr : SAttr identifier -> IAttr
(define (prefix-attr a prefix)
@ -429,6 +467,15 @@
;; ----
(define (parse-pat:literal stx decls)
(syntax-case stx (~literal)
[(~literal lit)
(unless (identifier? #'lit)
(wrong-syntax #'lit "expected identifier"))
(create-pat:literal #'lit)]
[_
(wrong-syntax stx "bad ~literal pattern")]))
(define (parse-pat:describe stx decls allow-head?)
(syntax-case stx ()
[(_ . rest)
@ -581,8 +628,6 @@
(check-list-pattern tail stx)]
[(struct pat:compound (_base '#:pair (list _head tail)))
(check-list-pattern tail stx)]
[(struct pat:name (_ pattern _))
(check-list-pattern pattern stx)]
[else
(wrong-syntax stx "expected proper list pattern")]))

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

@ -12,6 +12,7 @@
(provide pattern
~var
~literal
~and
~or
~not
@ -77,6 +78,7 @@
(define-keyword pattern)
(define-keyword ~var)
(define-keyword ~literal)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ~not)
@ -342,8 +344,11 @@ An Expectation is one of
#'name))))])))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])

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

@ -27,6 +27,7 @@
pattern
~var
~literal
~and
~or
~not

2
collects/tests/stxclass/test.ss
View File

@ -109,7 +109,7 @@
;; check if wildcard, no attr bound
(terx (1) _:two "expected two")
(terx (1 2) _:one "expected one")
;(terx (1 2) _:one "expected one")
(terx (1 (2 3)) (_:one _:two) "expected one")
(terx ((1) 2) (_:one _:two) "expected two")