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

stxclass: added and- and or-patterns, box and vector patterns

Browse Source 
svn: r13721
This commit is contained in:
Ryan Culpepper 2009-02-18 04:01:52 +00:00
parent b6c5e2ee3d
commit 59727cc4bc
14 changed files with 431 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/stxclass/main.ss
View File

@ -8,11 +8,14 @@
define-basic-syntax-class*
pattern
basic-syntax-class
~and
~or
...*
syntax-parse
syntax-parser
with-patterns
...*
attribute
current-expression
current-macro-name

36
collects/stxclass/private/codegen-data.ss
View File

@ -10,19 +10,27 @@
;; - 'fail' stxparameterized to (non-escaping!) failure procedure
(define-struct pk (ps k) #:transparent)
;; An ExtPK is one of
;; A Group (G) is one of
;; - PK
;; - (make-idpks stxclass (listof stx) (listof PK))
;; - (make-cpks (listof PK) (listof DatumPKS) (listof LiteralPKS))
;; the first field has only pair patterns
(define-struct idpks (stxclass args idpks))
(define-struct cpks (pairpks datumpks literalpks))
;; - (make-idG stxclass (listof stx) (listof PK))
;; where each PK starts with an id pattern of given stxclass/args
;; - (make-descrimG (listof DatumSG) (listof LiteralSG) (listof CompountSGs))
;; where each DatumSG/LiteralSG/CompoundSG has a different datum/lit/kind
(define-struct idG (stxclass args idpks) #:transparent)
(define-struct descrimG (datumSGs literalSGs kindSGs) #:transparent)
;; A DatumPKS is (make-datumpks datum (listof PK))
(define-struct datumpks (datum pks))
;; A DatumSG is (make-datumSG datum (listof PK))
;; where each PK starts with a datum pattern equal to datum
(define-struct datumSG (datum pks))
;; A LiteralSG is (make-literalSG id (listof PK))
;; where each PK starts with a literal pattern equal to literal
(define-struct literalSG (literal pks))
;; A CompoundSG is (make-compoundSG Kind (listof PK))
;; where each PK starts with a compound pattern of given kind
(define-struct compoundSG (kind pks))
;; A LiteralPKS is (make-literalpks identifier (listof PK))
(define-struct literalpks (literal pks))
;; A FrontierContextExpr (FCE) is one of
;; - (make-fce Id FrontierIndexExpr)
@ -55,6 +63,11 @@
(cons (fi:add-index (car (fce-indexes fc)) expr)
(cdr (fce-indexes fc)))))
(define (frontier:add-unvector fc)
(frontier:add-car fc (fce-stx fc)))
(define (frontier:add-unbox fc)
(frontier:add-car fc (fce-stx fc)))
(define (join-frontiers base ext)
(make-joined-frontier base ext))
@ -80,6 +93,7 @@
stx]
[(struct joined-frontier (base ext))
#`(let ([inner-failure #,ext])
(or (and (failed? inner-failure) (failed-frontier-stx inner-failure))
(or (and (failed? inner-failure)
(failed-frontier-stx inner-failure))
#,(loop base)))]))
(loop fc))

285
collects/stxclass/private/codegen.ss
View File

@ -33,13 +33,14 @@
"syntax class has no variants"))
(parse:pks (list #'x)
(list (empty-frontier #'x))
pks
#'fail-rhs))))]
#'fail-rhs
(list #f)
pks))))]
[(rhs:basic? rhs)
(rhs:basic-parser rhs)]))
;; parse:clauses : stx identifier identifier -> stx
(define (parse:clauses stx var failid)
(define (parse:clauses stx var phi)
(define clauses-kw-table
(list (list '#:literals check-literals-list)))
(define-values (chunks clauses-stx)
@ -70,8 +71,9 @@
(wrong-syntax stx "no variants"))
(parse:pks (list var)
(list (empty-frontier var))
pks
failid)))
phi
(list #f)
pks)))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
(define (rhs->pks rhs relsattrs main-var)
@ -117,8 +119,9 @@
[fail-k enclosing-fail])
#,(parse:pks (list #'x)
(list (done-frontier #'x))
(list (make-pk (list p) inner))
#'fail-k))))]))
#'fail-k
(list #f)
(list (make-pk (list p) inner))))))]))
;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx
(define (success-expr iattrs relsattrs remap main-var)
@ -142,47 +145,72 @@
;; Parsing
;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx
#|
The parsing algorithm is based on the classic backtracking
algorithm (see Optimizing Pattern Matching for an overview). A PK
corresponds to a row in the pattern matrix. The failure argument
corresponds to the static catch continuation.
The FCs (frontier contexts, one per column) are an addition for error
reporting. They track the matcher's progress into the term. The
matcher compares failures on backtracking, and reports the "furthest
along" failure, based on the frontiers.
Conventions:
<ParseConfig> =
vars : listof identifiers, variables, one per column
fcs : listof FCEs, failure contexts, one per column
phi : id, failure continuation
ds : listof (string/#f), description string
|#
;; parse:pks : <ParseConfig> (listof PK) -> stx
;; Each PK has a list of |vars| patterns.
;; The list of PKs must not be empty.
(define (parse:pks vars fcs pks failid)
(define (parse:pks vars fcs phi ds pks)
(cond [(null? pks)
(error 'parse:pks "internal error: empty list of rows")]
[(null? vars)
;; Success!
(let* ([failvar (car (generate-temporaries #'(fail-k)))]
(let* ([failvar (generate-temporary 'fail-k)]
[exprs
(for/list ([pk pks])
#`(with-enclosing-fail #,failvar #,(pk-k pk)))])
(with-syntax ([failvar failvar]
[(expr ...) exprs])
#`(try failvar [expr ...] #,failid)))]
#`(try failvar [expr ...] #,phi)))]
[else
(let-values ([(vars extpks) (split-pks vars pks)])
(let* ([failvar (car (generate-temporaries #'(fail-k)))]
(let-values ([(vars groups) (split-pks vars pks)])
(let* ([failvar (generate-temporary 'fail-k)]
[exprs
(for/list ([extpk extpks])
(parse:extpk vars fcs extpk failvar))])
(for/list ([group groups])
(parse:group vars fcs failvar ds group))])
(with-syntax ([failvar failvar]
[(expr ...) exprs])
#`(try failvar [expr ...] #,failid))))]))
#`(try failvar [expr ...] #,phi))))]))
;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx
;; parse:group : <ParseConfig> Group -> stx
;; Pre: vars is not empty
(define (parse:extpk vars fcs extpk failid)
(match extpk
[(struct idpks (stxclass args pks))
(define (parse:group vars fcs phi ds group)
(match group
[(struct idG (stxclass args pks))
(if stxclass
(parse:pk:id/stxclass vars fcs failid stxclass args pks)
(parse:pk:id/any vars fcs failid args pks))]
[(struct cpks (pairpks datumpkss literalpkss))
(parse:pk:c vars fcs failid pairpks datumpkss literalpkss)]
(parse:group:id/stxclass vars fcs phi ds stxclass args pks)
(parse:group:id/any vars fcs phi ds args pks))]
[(struct descrimG (datumSGs literalSGs kindSGs))
(parse:group:descrim vars fcs phi ds datumSGs literalSGs kindSGs)]
[(struct pk ((cons (? pat:and? and-pattern) rest-patterns) k))
(parse:group:and vars fcs phi ds and-pattern rest-patterns k)]
[(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k))
(parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)]))
(parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)]))
;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx
(define (parse:pk:id/stxclass vars fcs failid stxclass args pks)
;; parse:group:id/stxclass : <ParseConfig> SC stx (listof pk)
;; -> stx
(define (parse:group:id/stxclass vars fcs phi ds stxclass args pks)
(with-syntax ([var0 (car vars)]
[(arg ...) args]
[(arg-var ...) (generate-temporaries args)]
@ -191,77 +219,108 @@
#`(let ([arg-var arg] ...)
(let ([result (parser var0 arg-var ...)])
(if (ok? result)
#,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
#,(fail failid (car vars)
#,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))
#,(fail phi (car vars)
#:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result)
#:fce (join-frontiers (car fcs) #'result)))))))
;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx
(define (parse:pk:id/any vars fcs failid args pks)
;; parse:group:id/any : <ParseConfig> stx (listof pk) -> stx
(define (parse:group:id/any vars fcs phi ds args pks)
(with-syntax ([var0 (car vars)]
[(arg ...) args]
[(arg-var ...) (generate-temporaries args)]
[result (generate-temporary 'result)])
#`(let ([arg-var arg] ...)
(let ([result (list var0)])
#,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)))))
#,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))))))
;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx
(define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)
;; parse:group:descrim : <ParseConfig>
;; (listof DatumSG) (listof LiteralSG) (listof CompoundSG)
;; -> stx
(define (parse:group:descrim vars fcs phi ds datumSGs literalSGs compoundSGs)
(define var (car vars))
(define datum-var (generate-temporary 'datum))
(define (datumpks-test datumpks)
(let ([datum (datumpks-datum datumpks)])
(define (datumSG-test datumSG)
(let ([datum (datumSG-datum datumSG)])
#`(equal? #,datum-var (quote #,datum))))
(define (datumpks-rhs datumpks)
(let ([pks (datumpks-pks datumpks)])
(parse:pks (cdr vars) (cdr fcs) (shift-pks:datum pks) failid)))
(define (literalpks-test literalpks)
(let ([literal (literalpks-literal literalpks)])
(define (datumSG-rhs datumSG)
(let ([pks (datumSG-pks datumSG)])
(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:datum pks))))
(define (literalSG-test literalSG)
(let ([literal (literalSG-literal literalSG)])
#`(and (identifier? #,var)
(free-identifier=? #,var (quote-syntax #,literal)))))
(define (literalpks-rhs literalpks)
(let ([pks (literalpks-pks literalpks)])
(parse:pks (cdr vars) (cdr fcs) (shift-pks:literal pks) failid)))
(define (literalSG-rhs literalSG)
(let ([pks (literalSG-pks literalSG)])
(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:literal pks))))
(define (compoundSG-test compoundSG)
(let ([kind (compoundSG-kind compoundSG)])
#`(#,(kind-predicate kind) #,datum-var)))
(define (compoundSG-rhs compoundSG)
(let* ([pks (compoundSG-pks compoundSG)]
[kind (compoundSG-kind compoundSG)]
[selectors (kind-selectors kind)]
[frontier-procs (kind-frontier-procs kind)]
[part-vars (for/list ([selector selectors]) (generate-temporary 'part))]
[part-frontiers
(for/list ([fproc frontier-procs] [part-var part-vars])
(fproc (car fcs) part-var))]
[part-ds (for/list ([selector selectors]) (car ds))])
(with-syntax ([(part-var ...) part-vars]
[(part-expr ...)
(for/list ([selector selectors]) (selector var datum-var))])
#`(let ([part-var part-expr] ...)
#,(parse:pks (append part-vars (cdr vars))
(append part-frontiers (cdr fcs))
phi
(append part-ds (cdr ds))
(shift-pks:compound pks))))))
(define-pattern-variable var0 var)
(define-pattern-variable dvar0 datum-var)
(define-pattern-variable head-var (generate-temporary 'head))
(define-pattern-variable tail-var (generate-temporary 'tail))
(with-syntax ([(datum-clause ...)
(for/list ([datumpks datumpkss])
#`[#,(datumpks-test datumpks) #,(datumpks-rhs datumpks)])]
(for/list ([datumSG datumSGs])
#`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])]
[(lit-clause ...)
(for/list ([literalpks literalpkss])
#`[#,(literalpks-test literalpks) #,(literalpks-rhs literalpks)])])
(for/list ([literalSG literalSGs])
#`[#,(literalSG-test literalSG) #,(literalSG-rhs literalSG)])]
[(compound-clause ...)
(for/list ([compoundSG compoundSGs])
#`[#,(compoundSG-test compoundSG) #,(compoundSG-rhs compoundSG)])])
#`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)])
(cond #,@(if (pair? pairpks)
#`([(pair? dvar0)
(let ([head-var (car dvar0)]
[tail-var (datum->syntax var0 (cdr dvar0) var0)])
#,(parse:pks (list* #'head-var #'tail-var (cdr vars))
(list* (frontier:add-car (car fcs) #'head-var)
(frontier:add-cdr (car fcs))
(cdr fcs))
(shift-pks:pair pairpks)
failid))])
#`())
(cond compound-clause ...
lit-clause ...
datum-clause ...
[else
#,(fail failid (car vars)
#,(fail phi (car vars)
#:pattern (expectation-of-constants
(pair? pairpks)
(for/list ([d datumpkss])
(datumpks-datum d))
(for/list ([l literalpkss])
(literalpks-literal l)))
(pair? compoundSGs)
(for/list ([d datumSGs])
(datumSG-datum d))
(for/list ([l literalSGs])
(literalSG-literal l))
(car ds))
#:fce (car fcs))]))))
;; parse:pk:gseq : (listof id) (listof FCE) id
;; pat:gseq (listof Pattern)
;; ???
;; -> stx
(define (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)
;; parse:gseq:and : <ParseConfig> pat:and (listof Pattern) stx
;; -> stx
(define (parse:group:and vars fcs phi ds and-pattern rest-patterns k)
(match-define (struct pat:and (orig-stx attrs depth description patterns))
and-pattern)
;; FIXME: handle description
(let ([var0-copies (for/list ([p patterns]) (car vars))]
[fc0-copies (for/list ([p patterns]) (car fcs))]
[ds-copies (for/list ([p patterns]) (or description (car ds)))])
(parse:pks (append var0-copies (cdr vars))
(append fc0-copies (cdr fcs))
phi
(append ds-copies (cdr ds))
(list (make pk (append patterns rest-patterns) k)))))
;; parse:compound:gseq : <ParseConfig> pat:gseq (listof Pattern) stx
;; -> stx
(define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)
(match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern)
(define xvar (generate-temporary 'x))
(define head-lengths (for/list ([head heads]) (length (head-ps head))))
@ -269,9 +328,7 @@
(define hid-initss
(for/list ([head heads] [head-attrs head-attrss])
(for/list ([head-attr head-attrs])
(cond [(head-default head)
=> (lambda (x) #`(quote-syntax #,x))]
[(head-as-list? head) #'null]
(cond [(head-as-list? head) #'null]
[else #'#f]))))
(define combinerss
(for/list ([head heads] [head-attrs head-attrss])
@ -309,9 +366,6 @@
(if maxrep
#`(< #,repvar #,maxrep)
#`#t))]
[(occurs-binding ...)
(for/list ([head heads] [rep reps] #:when (head-occurs head))
#`[#,(head-occurs head) (positive? #,rep)])]
[(parse-loop failkv fail-tail)
(generate-temporaries #'(parse-loop failkv fail-tail))])
@ -344,12 +398,12 @@
#`(cond minrep-clause ...
[else
(let ([hid (finalize hid-arg)] ... ...
occurs-binding ...
[fail-tail enclosing-fail])
#,(parse:pks (cdr vars)
(cdr fcs)
(list (make-pk rest-patterns k))
#'fail-tail))])))
#'fail-tail
(cdr ds)
(list (make-pk rest-patterns k))))])))
(with-syntax ([tail-rhs tail-rhs-expr]
[(rhs ...)
@ -366,31 +420,33 @@
#,(parse:pks (list #'x)
(list (frontier:add-index (car fcs)
#'(calculate-index rep ...)))
#'failkv
(list (car ds))
(append
(map make-pk
(map list completed-heads)
(syntax->list #'(rhs ...)))
(list (make-pk (list tail) #`tail-rhs)))
#'failkv))
(list (make-pk (list tail) #`tail-rhs)))))
(let ([hid hid-init] ... ...
[rep 0] ...)
(parse-loop var0 hid ... ... rep ... #,failid))))))
(parse-loop var0 hid ... ... rep ... #,phi))))))
;; complete-heads-patterns : Head identifier number stx -> Pattern
(define (complete-heads-pattern head rest-var depth seq-orig-stx)
(define (loop ps pat)
(if (pair? ps)
(make-pat:pair (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
(append (pattern-attrs (car ps)) (pattern-attrs pat))
depth
(car ps)
(loop (cdr ps) pat))
(make pat:compound
(cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
(append (pattern-attrs (car ps)) (pattern-attrs pat))
depth
pairK
(list (car ps) (loop (cdr ps) pat)))
pat))
(define base
(make-pat:id seq-orig-stx
(list (make-attr rest-var depth null))
depth rest-var #f null))
(make pat:id
seq-orig-stx
(list (make-attr rest-var depth null))
depth rest-var #f null))
(loop (head-ps head) base))
;; split-pks : (listof identifier) (listof PK)
@ -406,7 +462,7 @@
(define (split-pks/first-column pks)
(define (get-pat x) (car (pk-ps x)))
(define (constructor-pat? p)
(or (pat:pair? p) (pat:datum? p) (pat:literal? p)))
(or (pat:compound? p) (pat:datum? p) (pat:literal? p)))
(define (constructor-pk? pk)
(constructor-pat? (get-pat pk)))
(define (id-pk? pk)
@ -453,13 +509,17 @@
(pat:id? p2)
(and (pat:datum? p1) (pat:datum? p2)
(equal? (pat:datum-datum p1) (pat:datum-datum p2)))
(and (pat:pair? p1) (pat:pair? p2)
(pattern-intersects? (pat:pair-head p1) (pat:pair-head p2))
(pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2)))
(and (pat:compound? p1) (pat:compound? p2)
(eq? (pat:compound-kind p1) (pat:compound-kind p2))
(andmap pattern-intersects?
(pat:compound-patterns p1)
(pat:compound-patterns p2)))
;; FIXME: conservative
(and (pat:literal? p1) (pat:literal? p2))
(pat:gseq? p1)
(pat:gseq? p2)))
(pat:gseq? p2)
(pat:and? p1)
(pat:and? p2)))
(define (major-loop pks epks)
(match pks
@ -481,18 +541,17 @@
tail
(list head)
null)])
(let ([id-epk (make idpks this-stxclass this-args (reverse r-id-pks))])
(let ([id-epk (make idG this-stxclass this-args (reverse r-id-pks))])
(major-loop tail (cons id-epk epks)))))]
;; Leave gseq- and and-patterns by themselves (at least for now)
[(cons head tail)
(major-loop tail (cons head epks))]))
;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK)
;; -> (listof PK) (listof PK)
(define (gather pred pks taken prefix)
#;(printf "called gather (~s pks, ~s prefix)\n" (length pks) (length prefix))
(match pks
['()
#;(printf "took ~s, left ~s\n" (length taken) (length prefix))
(values taken (reverse prefix))]
[(cons pk tail)
;; We can have it if it can move past everything in the prefix.
@ -504,16 +563,18 @@
;; group-constructor-pks : (listof PK) -> ExtPK
(define (group-constructor-pks reversed-pks)
(define pairpks null)
(define ht (make-hash))
(define compound-ht (make-hasheq))
(define datum-ht (make-hash))
(define lit-ht (make-bound-identifier-mapping))
(for ([pk reversed-pks])
(let ([p (get-pat pk)])
(cond [(pat:pair? p)
(set! pairpks (cons pk pairpks))]
(cond [(pat:compound? p)
(let ([kind (pat:compound-kind p)])
(hash-set! compound-ht
kind (cons pk (hash-ref compound-ht kind null))))]
[(pat:datum? p)
(let ([d (pat:datum-datum p)])
(hash-set! ht d (cons pk (hash-ref ht d null))))]
(hash-set! datum-ht d (cons pk (hash-ref datum-ht d null))))]
[(pat:literal? p)
(let ([lit (pat:literal-literal p)])
(bound-identifier-mapping-put!
@ -522,9 +583,10 @@
(cons pk
(bound-identifier-mapping-get lit-ht lit
(lambda () null)))))])))
(let ([datumpkss (hash-map ht make-datumpks)]
[litpkss (bound-identifier-mapping-map lit-ht make-literalpks)])
(make cpks pairpks datumpkss litpkss)))
(let ([datumSGs (hash-map datum-ht make-datumSG)]
[literalSGs (bound-identifier-mapping-map lit-ht make-literalSG)]
[compoundSGs (hash-map compound-ht make-compoundSG)])
(make descrimG datumSGs literalSGs compoundSGs)))
(major-loop pks null))
@ -565,13 +627,14 @@
(make-pk (cdr (pk-ps pk)) (pk-k pk)))
(map shift-pk pks))
;; shift-pks:pair : (listof PK) -> (listof PK)
(define (shift-pks:pair pks)
;; shift-pks:compound : (listof PK) -> (listof PK)
(define (shift-pks:compound pks)
(define (shift-pk pk0)
(match pk0
[(struct pk ((cons (struct pat:pair (orig-stx attrs depth head tail)) rest-ps)
[(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns))
rest-ps)
k))
(make-pk (list* head tail rest-ps) k)]))
(make-pk (append patterns rest-ps) k)]))
(map shift-pk pks))
;; wrap-pvars : (listof IAttr) stx -> stx

18
collects/stxclass/private/rep-data.ss
View File

@ -14,8 +14,11 @@
(struct-out pat:id)
(struct-out pat:datum)
(struct-out pat:literal)
(struct-out pat:pair)
(struct-out pat:compound)
(struct-out pat:gseq)
(struct-out pat:and)
(struct-out pat:orseq)
(struct-out kind)
(struct-out head)
(struct-out clause:when)
(struct-out clause:with))
@ -53,18 +56,24 @@
;; (make-pat:pair <Pattern> Pattern Pattern)
;; (make-pat:seq <Pattern> Pattern Pattern)
;; (make-pat:gseq <Pattern> (listof Head) Pattern)
;; (make-pat:and <Pattern> string/#f (listof Pattern))
;; (make-pat:compound <Pattern> Kind (listof Pattern))
;; when <Pattern> = stx (listof IAttr) number
(define-struct pattern (orig-stx attrs depth) #:transparent)
(define-struct (pat:id pattern) (name stxclass args) #:transparent)
(define-struct (pat:datum pattern) (datum) #:transparent)
(define-struct (pat:literal pattern) (literal) #:transparent)
(define-struct (pat:pair pattern) (head tail) #:transparent)
(define-struct (pat:gseq pattern) (heads tail) #:transparent)
(define-struct (pat:and pattern) (description subpatterns) #:transparent)
(define-struct (pat:orseq pattern) (heads) #:transparent)
(define-struct (pat:compound pattern) (kind patterns) #:transparent)
;; A Kind is (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE)))
(define-struct kind (predicate selectors frontier-procs) #:transparent)
;; A Head is
;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f)
(define-struct head (orig-stx attrs depth ps min max as-list? occurs default)
#:transparent)
(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent)
;; A SideClause is one of
;; (make-clause:with pattern stx)
@ -84,7 +93,6 @@
(and (attr? a) (symbol? (attr-name a))))
;; Environments
;; DeclEnv maps [id => DeclEntry]

178
collects/stxclass/private/rep.ss
View File

@ -6,7 +6,8 @@
syntax/boundmap
syntax/stx
"../util.ss"
"rep-data.ss")
"rep-data.ss"
"codegen-data.ss")
(provide/contract
[parse-whole-pattern
@ -21,7 +22,10 @@
rhs?)]
[check-literals-list
(-> syntax?
(listof (list/c identifier? identifier?)))])
(listof (list/c identifier? identifier?)))]
[pairK kind?]
[vectorK kind?]
[boxK kind?])
(define (atomic-datum? stx)
(let ([datum (syntax-e stx)])
@ -47,6 +51,40 @@
(and (identifier? stx)
(free-identifier=? stx (quote-syntax ...*))))
(define (and-kw? stx)
(and (identifier? stx)
(free-identifier=? stx (quote-syntax ~and))))
(define (orseq-kw? stx)
(and (identifier? stx)
(free-identifier=? stx (quote-syntax ~or))))
(define (reserved? stx)
(or (dots? stx)
(gdots? stx)
(and-kw? stx)
(orseq-kw? stx)))
;; ---- Kinds ----
(define pairK
(make-kind #'pair?
(list (lambda (s d) #`(car #,d))
(lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
(list (lambda (fc x) (frontier:add-car fc x))
(lambda (fc x) (frontier:add-cdr fc)))))
(define vectorK
(make-kind #'vector?
(list (lambda (s d)
#`(datum->syntax #,s (vector->list #,d) #,s)))
(list (lambda (fc x) (frontier:add-unvector fc)))))
(define boxK
(make-kind #'box?
(list (lambda (s d) #`(unbox #,d)))
(list (lambda (fc x) (frontier:add-unbox fc)))))
;; ---
;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
@ -146,12 +184,15 @@
pattern)
;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
(define (parse-pattern stx decls depth)
(syntax-case stx ()
[dots
(or (dots? #'dots)
(gdots? #'dots))
(wrong-syntax stx "ellipses not allowed here")]
(define (parse-pattern stx decls depth
#:allow-orseq-pattern? [allow-orseq-pattern? #f])
(syntax-case stx (~and ~or)
[gdots
(gdots? #'gdots)
(wrong-syntax stx "obsolete (...*) sequence syntax")]
[reserved
(reserved? #'reserved)
(wrong-syntax #'reserved "not allowed here")]
[id
(identifier? #'id)
(match (declenv-lookup decls #'id)
@ -169,25 +210,46 @@
[datum
(atomic-datum? #'datum)
(make pat:datum stx null depth (syntax->datum #'datum))]
[(heads gdots . tail)
(gdots? #'gdots)
(let* ([heads (parse-heads #'heads decls depth)]
[tail (parse-pattern #'tail decls depth)]
[hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))]
[tattrs (pattern-attrs tail)])
(make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))]
[(~and . rest)
(begin (unless (stx-list? #'rest)
(wrong-syntax stx "expected list of patterns"))
(parse-and-pattern stx decls depth))]
[(~or . heads)
(begin (unless (stx-list? #'heads)
(wrong-syntax stx "expected list of pattern sequences"))
(unless allow-orseq-pattern?
(wrong-syntax stx "or/sequence pattern not allowed here"))
(let* ([heads (parse-heads #'heads decls depth)]
[attrs
(append-attrs
(for/list ([head heads]) (head-attrs head)))])
(make pat:orseq stx attrs depth heads)))]
[(head dots . tail)
(dots? #'dots)
(let* ([headp (parse-pattern #'head decls (add1 depth))]
(let* ([headp (parse-pattern #'head decls (add1 depth)
#:allow-orseq-pattern? #t)]
[heads
(if (pat:orseq? headp)
(pat:orseq-heads headp)
(list (pattern->head headp)))]
[tail (parse-pattern #'tail decls depth)]
[head (pattern->head headp)]
[attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))])
(make pat:gseq stx attrs depth (list head) tail))]
[hattrs (pattern-attrs headp)]
[tattrs (pattern-attrs tail)])
(make pat:gseq stx (append-attrs (list hattrs tattrs))
depth heads tail))]
[(a . b)
(let ([pa (parse-pattern #'a decls depth)]
[pb (parse-pattern #'b decls depth)])
(let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))])
(make pat:pair stx attrs depth pa pb)))]))
(define attrs
(append-attrs (list (pattern-attrs pa) (pattern-attrs pb))))
(make pat:compound stx attrs depth pairK (list pa pb))
#| (make pat:pair stx attrs depth pa pb) |#)]
[#(a ...)
(let ([lp (parse-pattern (syntax/loc stx (a ...)) decls depth)])
(make pat:compound stx (pattern-attrs lp) depth vectorK (list lp)))]
[#&x
(let ([bp (parse-pattern #'x decls depth)])
(make pat:compound stx (pattern-attrs bp) depth boxK (list bp)))]))
(define (id-pattern-attrs name sc depth)
(cond [(wildcard? name) null]
@ -201,16 +263,27 @@
[else
(list (make attr name depth null))]))
;; parse-and-patttern : stxlist DeclEnv nat -> Pattern
(define (parse-and-pattern stx decls depth)
(define-values (chunks rest)
(chunk-kw-seq/no-dups (stx-cdr stx) and-pattern-directive-table))
(define description
(cond [(assq '#:description chunks) => caddr]
[else #f]))
(define patterns
(for/list ([x (stx->list rest)])
(parse-pattern x decls depth)))
(define attrs (append-attrs (map pattern-attrs patterns)))
(make pat:and stx attrs depth description patterns))
(define (pattern->head p)
(match p
[(struct pattern (orig-stx iattrs depth))
(make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
(make head orig-stx iattrs depth (list p) #f #f #t)]))
(define head-directive-table
(list (list '#:min check-nat/f)
(list '#:max check-nat/f)
(list '#:occurs check-id)
(list '#:default values)
(list '#:opt)
(list '#:mand)))
@ -221,7 +294,6 @@
"empty head sequence not allowed")]
[({p ...} . more)
(let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)])
(reject-duplicate-chunks chunks) ;; FIXME: needed?
(cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
(parse-heads rest decls enclosing-depth)))]
[()
@ -232,11 +304,9 @@
[else #f])
"expected sequence of patterns or sequence directive")]))
(define (parse-head/chunks pstx decls enclosing-depth chunks)
(define (parse-head/chunks pstx decls depth chunks)
(let* ([min-row (assq '#:min chunks)]
[max-row (assq '#:max chunks)]
[occurs-row (assq '#:occurs chunks)]
[default-row (assq '#:default chunks)]
[opt-row (assq '#:opt chunks)]
[mand-row (assq '#:mand chunks)]
[min-stx (and min-row (caddr min-row))]
@ -252,44 +322,25 @@
(when (and (or min-row max-row) (or opt-row mand-row))
(wrong-syntax (or min-stx max-stx)
"min/max-constraints are incompatible with opt/mand directives"))
(when default-row
(unless opt-row
(wrong-syntax (cadr default-row)
"default only allowed for optional patterns")))
(parse-head/options pstx
decls
enclosing-depth
depth
(cond [opt-row 0] [mand-row 1] [else min])
(cond [opt-row 1] [mand-row 1] [else max])
(not (or opt-row mand-row))
(and occurs-row (caddr occurs-row))
default-row)))
(not (or opt-row mand-row)))))
(define (parse-head/options pstx decls enclosing-depth
min max as-list? occurs-pvar default-row)
(let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
(define (parse-head/options pstx decls depth min max as-list?)
(let* ([effective-depth (if as-list? depth (sub1 depth))]
[heads
(for/list ([p (syntax->list pstx)])
(parse-pattern p decls depth))]
(for/list ([p (stx->list pstx)])
(parse-pattern p decls effective-depth))]
[heads-attrs
(append-attrs (map pattern-attrs heads))])
(when default-row
(unless (and (= (length heads-attrs) 1)
(= enclosing-depth (attr-depth (car heads-attrs)))
(null? (attr-inner (car heads-attrs))))
(wrong-syntax (cadr default-row)
"default only allowed for patterns with single simple pattern variable")))
(let ([occurs-attrs
(if occurs-pvar
(list (make-attr occurs-pvar depth null))
null)])
(make head pstx
(append-attrs (list occurs-attrs heads-attrs))
depth
heads
min max as-list?
occurs-pvar
(and default-row (caddr default-row))))))
(make head pstx
heads-attrs
depth
heads
min max as-list?)))
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
;; -> stx DeclEnv RemapEnv (listof SideClause)
@ -358,6 +409,13 @@
'()]))
;; check-lit-string : stx -> string
(define (check-lit-string stx)
(let ([x (syntax-e stx)])
(unless (string? x)
(wrong-syntax stx "expected string literal"))
x))
;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx)
(unless (stx-list? stx)
@ -421,3 +479,7 @@
(list '#:rename check-id check-id)
(list '#:with values values)
(list '#:when values)))
;; and-pattern-directive-table
(define and-pattern-directive-table
(list (list '#:description check-lit-string)))

51
collects/stxclass/private/runtime.ss
View File

@ -9,6 +9,8 @@
(for-syntax "../util/error.ss"))
(provide pattern
basic-syntax-class
~and
~or
...*
with-enclosing-fail
@ -41,8 +43,9 @@
(define-keyword pattern)
(define-keyword basic-syntax-class)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ...*)
(define-keyword ...**)
;; Parameters & Syntax Parameters
@ -106,8 +109,8 @@
;; Runtime: parsing failures/expectations
;; An Expectation is
;; (make-expc (listof scdyn) (listof expc) (listof atom) (listof id))
(define-struct expc (stxclasses pairs? data literals)
;; (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id))
(define-struct expc (stxclasses compound data literals)
#:transparent)
(define-struct scdyn (name desc failure)
@ -116,7 +119,7 @@
(define expectation/c (or/c expc?))
(define (make-stxclass-expc scdyn)
(make-expc (list scdyn) #f null null))
(make-expc (list scdyn) null null null))
(begin-for-syntax
(define certify (syntax-local-certifier))
@ -131,18 +134,22 @@
(make-scdyn 'name (desc-var arg ...)
(if (failed? #,result-var) #,result-var #f)))))))
(define (expectation-of-constants pairs? data literals)
(define (expectation-of-constants pairs? data literals description)
(with-syntax ([(datum ...) data]
[(literal ...) literals]
[pairs? pairs?])
[pairs? pairs?]
[description
(if pairs?
(list (or description #t))
null)])
(certify
#'(make-expc null 'pairs? (list 'datum ...)
#'(make-expc null 'description (list 'datum ...)
(list (quote-syntax literal) ...)))))
(define (expectation-of/message msg)
(with-syntax ([msg msg])
(certify
#'(make-expc '() #f '((msg)) '())))))
#'(make-expc '() '() '((msg)) '())))))
(define-syntax (try stx)
(syntax-case stx ()
@ -174,7 +181,7 @@
(define (merge-expectations e1 e2)
(make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
(or (expc-pairs? e1) (expc-pairs? e2))
(union (expc-compound e1) (expc-compound e2))
(union (expc-data e1) (expc-data e2))
(union (expc-literals e1) (expc-literals e2))))
@ -183,9 +190,9 @@
(define (expectation-of-null? e)
(match e
[(struct expc (scs pairs? data literals))
[(struct expc (scs compound data literals))
(and (null? scs)
(not pairs?)
(null? compound)
(null? literals)
(and (pair? data) (null? (cdr data)))
(equal? (car data) '()))]
@ -193,16 +200,18 @@
(define (expectation->string e)
(match e
[(struct expc (_ #t _ _))
#f]
[(struct expc (stxclasses pairs? data literals))
(let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
[s2 (and (pair? data) (string-of-data data))]
[s3 (and (pair? literals) (string-of-literals literals))]
[s4 (and pairs? string-of-pairs?)])
(join-sep (filter string? (list s1 s2 s3 s4))
";"
"or"))]))
[(struct expc (stxclasses compound data literals))
(cond [(null? compound)
(let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
[s2 (and (pair? data) (string-of-data data))]
[s3 (and (pair? literals) (string-of-literals literals))])
(join-sep (filter string? (list s1 s2 s3))
";"
"or"))]
[(andmap string? compound)
(join-sep compound ";" "or")]
[else
#f])]))
(define (string-of-stxclasses scdyns)
(comma-list (map string-of-stxclass scdyns)))

2
collects/stxclass/private/sc.ss
View File

@ -24,6 +24,8 @@
pattern
basic-syntax-class
~and
~or
...*
attribute

79
collects/stxclass/scribblings/parsing-syntax.scrbl
View File

@ -55,15 +55,21 @@ procedure accepts a single argument, which should be a syntax object.
The grammar of patterns accepted by @scheme[syntax-parse] and
@scheme[syntax-parser] follows:
@schemegrammar*[#:literals (_ ...*)
@schemegrammar*[#:literals (_ ~or ~and)
[syntax-pattern
pvar-id
pvar-id:syntax-class-id
literal-id
atomic-datum
(syntax-pattern . syntax-pattern)
(syntax-pattern #,ellipses . syntax-pattern)
((head ...+) ...* . syntax-pattern)]
(ellipsis-head-pattern #,ellipses . syntax-pattern)
(~and maybe-description syntax-pattern ...)]
[ellipsis-head-pattern
(~or head ...+)
syntax-pattern]
[maybe-description
(code:line)
(code:line #:description string)]
[pvar-id
_
id]]
@ -116,17 +122,8 @@ Matches a syntax pair whose head matches the first pattern and whose
tail matches the second.
}
@;{
@specsubform[(syntax-splice-pattern . syntax-pattern)]{
Matches a syntax object which consists of any sequence of syntax
objects matching the splice pattern followed by a tail matching the
given tail pattern.
}
}
@specsubform[(syntax-pattern #,ellipses . syntax-pattern)]{
@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{
Matches a sequence of the first pattern ending in a tail matching the
second pattern.
@ -135,23 +132,21 @@ That is, the sequence pattern matches either the second pattern (which
need not be a list) or a pair whose head matches the first pattern and
whose tail recursively matches the whole sequence pattern.
}
@specsubform/subs[#:literals (...*)
((head ...+) ...* . syntax-pattern)
The head pattern can be either an ordinary pattern or an
or/sequence-pattern:
@specsubform/subs[#:literals (~or)
(~or head ...+)
([head
(code:line (syntax-pattern ...+) head-directive ...)]
[head-directive
(code:line #:min min-reps)
(code:line #:max max-reps)
(code:line #:mand)
#| (code:line #:opt)
(code:line #:occurs occurs-pvar-id)
(code:line #:default default-form)
|#])]{
(code:line #:mand)])]{
Matches a sequence of any combination of the heads ending in a tail
matching the final pattern. The match is subject to constraints
specified on the heads.
If the head is an or/sequence-pattern (introduced by @scheme[~or]),
then the whole sequence pattern matches any combination of the head
sequences followed by a tail matching the final pattern.
@specsubform[(code:line #:min min-reps)]{
@ -175,27 +170,16 @@ in the preceding head are not bound at a higher ellipsis nesting
depth.
}
@;{
@specsubform[#:opt]{
(Probably a bad idea.)
}
}
}
@;{
The variants of @scheme[_syntax-splice-pattern] follow:
@specsubform/subs[#:literals (~and)
(~and maybe-description syntax-pattern ...)
([maybe-description
(code:line)
(code:line #:description string)])]{
@specsubform[pvar-id:syntax-splice-class-id]{
Matches any syntax that matches all of the included patterns.
Matches a sequence of syntax objects described by
@scheme[_syntax-splice-class-id].
The name @scheme[_pvar-id] is bound, but not allowed within
expressions or @scheme[syntax] templates (since it does not refer to a
particular syntax object). Only the prefixed attributes of the splice
class are usable.
}
}
Both @scheme[syntax-parse] and @scheme[syntax-parser] support
@ -241,10 +225,19 @@ backtracks as described above; otherwise, it continues.
}
@defidform[...*]{
@defidform[~and]{
Keyword recognized by @scheme[syntax-parse] etc as notation for
generalized sequences. It may not be used as an expression.
and-patterns.
}
@defidform[~or]{
Keyword recognized by @scheme[syntax-parse] etc as notation for
or/sequence-patterns (within sequences). It may not be used as an
expression.
}

32
collects/tests/stxclass/stxclass.ss
View File

@ -118,37 +118,37 @@
(check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
(check-equal? (syntax->datum #'(t.b ...)) '(2 5 7)))
(test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
(test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
(check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee")))
(test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
(test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
(check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee")))
(test-patterns ({{1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...*)
(test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...)
#'(1 2 3)
'ok)
(test-patterns ({{a:id} {b:nat} {c:str}} ...*) #'("one" 2 three)
(test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three)
(check-equal? (stx->datum #'(a ...)) '(three))
(check-equal? (stx->datum #'(b ...)) '(2))
(check-equal? (stx->datum #'(c ...)) '("one")))
(test-patterns ({{1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1
{x} #:min 1 #:max 1
{y} #:min 1 #:max 1
{w} #:min 1 #:max 1} ...*)
(test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1
{x} #:min 1 #:max 1
{y} #:min 1 #:max 1
{w} #:min 1 #:max 1} ...)
#'(1 2 3 x y z)
(for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s))
(check-equal? (sort
(map symbol->string (stx->datum #'(x ... y ... w ...)))
string<?)
'("x" "y" "z")))
(test-patterns ({{x}
{1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...*)
(test-patterns ({~or {x}
{1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...)
#'(1 2 3 x y z)
(check-equal? (stx->datum #'(x ...)) '(x y z)))
)))

2
collects/typed-scheme/private/parse-type.ss
View File

@ -251,7 +251,7 @@
(pattern (case-lambda f:fun-ty/one ...)
#:with t (make-Function (syntax->datum #'(f.arr ...))))
(pattern (t:Class (pos-args:type ...) ([fname:id fty:type ((rest:boolean) #:opt) ...*] ...) ([mname:id mty:type] ...))
(pattern (t:Class (pos-args:type ...) ([fname:id fty:type (~or (rest:boolean) #:opt) ...] ...) ([mname:id mty:type] ...))
#:with t
(make-Class
(syntax->datum #'(pos-args.t ...))

4
collects/typed-scheme/private/prims.ss
View File

@ -66,7 +66,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx
[(_ lib [nm:opt-rename ty] ...)
#'(begin (require/typed nm ty lib) ...)]
[(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*)
[(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...)
(with-syntax ([cnt* (generate-temporary #'nm.nm)]
[sm (if #'parent
#'(#:struct-maker parent)
@ -87,7 +87,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax-class name-exists-kw
(pattern #:name-exists))
(syntax-parse stx
[(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*)
[(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...)
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
(quasisyntax/loc stx
(begin

2
collects/typed-scheme/private/type-abbrev.ss
View File

@ -82,7 +82,7 @@
(define-syntax (->key stx)
(syntax-parse stx
[(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng)
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
#'(make-Function
(list
(make-arr* (list ty ...)

4
collects/typed-scheme/rep/interning.ss
View File

@ -7,9 +7,9 @@
(define-syntax (defintern stx)
(syntax-parse stx
[(_ name+args make-name key ([#:extra-arg e:expr]) ...*)
[(_ name+args make-name key (~or [#:extra-arg e:expr]) ...)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)]
[(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*)
[(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...)
#'(define *name
(let ([table (make-ht)])
(lambda (arg ...)

10
collects/typed-scheme/rep/rep-utils.ss
View File

@ -70,11 +70,11 @@
(define (mk par ht-stx)
(lambda (stx)
(syntax-parse stx
[(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt
[[#:intern intern?:expr]] #:opt
[[#:frees . frees:frees-pat]] #:opt
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
[no-provide?:no-provide-kw] #:opt) ...*)
[(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt
[[#:intern intern?:expr]] #:opt
[[#:frees . frees:frees-pat]] #:opt
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
[no-provide?:no-provide-kw] #:opt) ...)
(with-syntax*
([ex (mk-id #'nm #'nm ":")]
[kw-stx (string->keyword (symbol->string #'nm.datum))]