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* define-basic-syntax-class*
pattern pattern
basic-syntax-class basic-syntax-class
~and
~or
...*
syntax-parse syntax-parse
syntax-parser syntax-parser
with-patterns with-patterns
...* attribute
current-expression current-expression
current-macro-name current-macro-name

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

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

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

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

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

@ -6,7 +6,8 @@
syntax/boundmap syntax/boundmap
syntax/stx syntax/stx
"../util.ss" "../util.ss"
"rep-data.ss") "rep-data.ss"
"codegen-data.ss")
(provide/contract (provide/contract
[parse-whole-pattern [parse-whole-pattern
@ -21,7 +22,10 @@
rhs?)] rhs?)]
[check-literals-list [check-literals-list
(-> syntax? (-> syntax?
(listof (list/c identifier? identifier?)))]) (listof (list/c identifier? identifier?)))]
[pairK kind?]
[vectorK kind?]
[boxK kind?])
(define (atomic-datum? stx) (define (atomic-datum? stx)
(let ([datum (syntax-e stx)]) (let ([datum (syntax-e stx)])
@ -47,6 +51,40 @@
(and (identifier? stx) (and (identifier? stx)
(free-identifier=? stx (quote-syntax ...*)))) (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 ;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
@ -146,12 +184,15 @@
pattern) pattern)
;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern ;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
(define (parse-pattern stx decls depth) (define (parse-pattern stx decls depth
(syntax-case stx () #:allow-orseq-pattern? [allow-orseq-pattern? #f])
[dots (syntax-case stx (~and ~or)
(or (dots? #'dots) [gdots
(gdots? #'dots)) (gdots? #'gdots)
(wrong-syntax stx "ellipses not allowed here")] (wrong-syntax stx "obsolete (...*) sequence syntax")]
[reserved
(reserved? #'reserved)
(wrong-syntax #'reserved "not allowed here")]
[id [id
(identifier? #'id) (identifier? #'id)
(match (declenv-lookup decls #'id) (match (declenv-lookup decls #'id)
@ -169,25 +210,46 @@
[datum [datum
(atomic-datum? #'datum) (atomic-datum? #'datum)
(make pat:datum stx null depth (syntax->datum #'datum))] (make pat:datum stx null depth (syntax->datum #'datum))]
[(heads gdots . tail) [(~and . rest)
(gdots? #'gdots) (begin (unless (stx-list? #'rest)
(let* ([heads (parse-heads #'heads decls depth)] (wrong-syntax stx "expected list of patterns"))
[tail (parse-pattern #'tail decls depth)] (parse-and-pattern stx decls depth))]
[hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))] [(~or . heads)
[tattrs (pattern-attrs tail)]) (begin (unless (stx-list? #'heads)
(make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))] (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) [(head dots . tail)
(dots? #'dots) (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)] [tail (parse-pattern #'tail decls depth)]
[head (pattern->head headp)] [hattrs (pattern-attrs headp)]
[attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))]) [tattrs (pattern-attrs tail)])
(make pat:gseq stx attrs depth (list head) tail))] (make pat:gseq stx (append-attrs (list hattrs tattrs))
depth heads tail))]
[(a . b) [(a . b)
(let ([pa (parse-pattern #'a decls depth)] (let ([pa (parse-pattern #'a decls depth)]
[pb (parse-pattern #'b decls depth)]) [pb (parse-pattern #'b decls depth)])
(let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))]) (define attrs
(make pat:pair stx attrs depth pa pb)))])) (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) (define (id-pattern-attrs name sc depth)
(cond [(wildcard? name) null] (cond [(wildcard? name) null]
@ -201,16 +263,27 @@
[else [else
(list (make attr name depth null))])) (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) (define (pattern->head p)
(match p (match p
[(struct pattern (orig-stx iattrs depth)) [(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 (define head-directive-table
(list (list '#:min check-nat/f) (list (list '#:min check-nat/f)
(list '#:max check-nat/f) (list '#:max check-nat/f)
(list '#:occurs check-id)
(list '#:default values)
(list '#:opt) (list '#:opt)
(list '#:mand))) (list '#:mand)))
@ -221,7 +294,6 @@
"empty head sequence not allowed")] "empty head sequence not allowed")]
[({p ...} . more) [({p ...} . more)
(let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)]) (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) (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
(parse-heads rest decls enclosing-depth)))] (parse-heads rest decls enclosing-depth)))]
[() [()
@ -232,11 +304,9 @@
[else #f]) [else #f])
"expected sequence of patterns or sequence directive")])) "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)] (let* ([min-row (assq '#:min chunks)]
[max-row (assq '#:max chunks)] [max-row (assq '#:max chunks)]
[occurs-row (assq '#:occurs chunks)]
[default-row (assq '#:default chunks)]
[opt-row (assq '#:opt chunks)] [opt-row (assq '#:opt chunks)]
[mand-row (assq '#:mand chunks)] [mand-row (assq '#:mand chunks)]
[min-stx (and min-row (caddr min-row))] [min-stx (and min-row (caddr min-row))]
@ -252,44 +322,25 @@
(when (and (or min-row max-row) (or opt-row mand-row)) (when (and (or min-row max-row) (or opt-row mand-row))
(wrong-syntax (or min-stx max-stx) (wrong-syntax (or min-stx max-stx)
"min/max-constraints are incompatible with opt/mand directives")) "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 (parse-head/options pstx
decls decls
enclosing-depth depth
(cond [opt-row 0] [mand-row 1] [else min]) (cond [opt-row 0] [mand-row 1] [else min])
(cond [opt-row 1] [mand-row 1] [else max]) (cond [opt-row 1] [mand-row 1] [else max])
(not (or opt-row mand-row)) (not (or opt-row mand-row)))))
(and occurs-row (caddr occurs-row))
default-row)))
(define (parse-head/options pstx decls enclosing-depth (define (parse-head/options pstx decls depth min max as-list?)
min max as-list? occurs-pvar default-row) (let* ([effective-depth (if as-list? depth (sub1 depth))]
(let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
[heads [heads
(for/list ([p (syntax->list pstx)]) (for/list ([p (stx->list pstx)])
(parse-pattern p decls depth))] (parse-pattern p decls effective-depth))]
[heads-attrs [heads-attrs
(append-attrs (map pattern-attrs heads))]) (append-attrs (map pattern-attrs heads))])
(when default-row (make head pstx
(unless (and (= (length heads-attrs) 1) heads-attrs
(= enclosing-depth (attr-depth (car heads-attrs))) depth
(null? (attr-inner (car heads-attrs)))) heads
(wrong-syntax (cadr default-row) min max as-list?)))
"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))))))
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id) ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
;; -> stx DeclEnv RemapEnv (listof SideClause) ;; -> 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) ;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx) (define (check-attr-arity-list stx)
(unless (stx-list? stx) (unless (stx-list? stx)
@ -421,3 +479,7 @@
(list '#:rename check-id check-id) (list '#:rename check-id check-id)
(list '#:with values values) (list '#:with values values)
(list '#:when 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")) (for-syntax "../util/error.ss"))
(provide pattern (provide pattern
basic-syntax-class basic-syntax-class
~and
~or
...* ...*
with-enclosing-fail with-enclosing-fail
@ -41,8 +43,9 @@
(define-keyword pattern) (define-keyword pattern)
(define-keyword basic-syntax-class) (define-keyword basic-syntax-class)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ...*) (define-keyword ...*)
(define-keyword ...**)
;; Parameters & Syntax Parameters ;; Parameters & Syntax Parameters
@ -106,8 +109,8 @@
;; Runtime: parsing failures/expectations ;; Runtime: parsing failures/expectations
;; An Expectation is ;; An Expectation is
;; (make-expc (listof scdyn) (listof expc) (listof atom) (listof id)) ;; (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id))
(define-struct expc (stxclasses pairs? data literals) (define-struct expc (stxclasses compound data literals)
#:transparent) #:transparent)
(define-struct scdyn (name desc failure) (define-struct scdyn (name desc failure)
@ -116,7 +119,7 @@
(define expectation/c (or/c expc?)) (define expectation/c (or/c expc?))
(define (make-stxclass-expc scdyn) (define (make-stxclass-expc scdyn)
(make-expc (list scdyn) #f null null)) (make-expc (list scdyn) null null null))
(begin-for-syntax (begin-for-syntax
(define certify (syntax-local-certifier)) (define certify (syntax-local-certifier))
@ -131,18 +134,22 @@
(make-scdyn 'name (desc-var arg ...) (make-scdyn 'name (desc-var arg ...)
(if (failed? #,result-var) #,result-var #f))))))) (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] (with-syntax ([(datum ...) data]
[(literal ...) literals] [(literal ...) literals]
[pairs? pairs?]) [pairs? pairs?]
[description
(if pairs?
(list (or description #t))
null)])
(certify (certify
#'(make-expc null 'pairs? (list 'datum ...) #'(make-expc null 'description (list 'datum ...)
(list (quote-syntax literal) ...))))) (list (quote-syntax literal) ...)))))
(define (expectation-of/message msg) (define (expectation-of/message msg)
(with-syntax ([msg msg]) (with-syntax ([msg msg])
(certify (certify
#'(make-expc '() #f '((msg)) '()))))) #'(make-expc '() '() '((msg)) '())))))
(define-syntax (try stx) (define-syntax (try stx)
(syntax-case stx () (syntax-case stx ()
@ -174,7 +181,7 @@
(define (merge-expectations e1 e2) (define (merge-expectations e1 e2)
(make-expc (union (expc-stxclasses e1) (expc-stxclasses 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-data e1) (expc-data e2))
(union (expc-literals e1) (expc-literals e2)))) (union (expc-literals e1) (expc-literals e2))))
@ -183,9 +190,9 @@
(define (expectation-of-null? e) (define (expectation-of-null? e)
(match e (match e
[(struct expc (scs pairs? data literals)) [(struct expc (scs compound data literals))
(and (null? scs) (and (null? scs)
(not pairs?) (null? compound)
(null? literals) (null? literals)
(and (pair? data) (null? (cdr data))) (and (pair? data) (null? (cdr data)))
(equal? (car data) '()))] (equal? (car data) '()))]
@ -193,16 +200,18 @@
(define (expectation->string e) (define (expectation->string e)
(match e (match e
[(struct expc (_ #t _ _)) [(struct expc (stxclasses compound data literals))
#f] (cond [(null? compound)
[(struct expc (stxclasses pairs? data literals)) (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
(let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))] [s2 (and (pair? data) (string-of-data data))]
[s2 (and (pair? data) (string-of-data data))] [s3 (and (pair? literals) (string-of-literals literals))])
[s3 (and (pair? literals) (string-of-literals literals))] (join-sep (filter string? (list s1 s2 s3))
[s4 (and pairs? string-of-pairs?)]) ";"
(join-sep (filter string? (list s1 s2 s3 s4)) "or"))]
";" [(andmap string? compound)
"or"))])) (join-sep compound ";" "or")]
[else
#f])]))
(define (string-of-stxclasses scdyns) (define (string-of-stxclasses scdyns)
(comma-list (map string-of-stxclass scdyns))) (comma-list (map string-of-stxclass scdyns)))

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

@ -24,6 +24,8 @@
pattern pattern
basic-syntax-class basic-syntax-class
~and
~or
...* ...*
attribute 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 The grammar of patterns accepted by @scheme[syntax-parse] and
@scheme[syntax-parser] follows: @scheme[syntax-parser] follows:
@schemegrammar*[#:literals (_ ...*) @schemegrammar*[#:literals (_ ~or ~and)
[syntax-pattern [syntax-pattern
pvar-id pvar-id
pvar-id:syntax-class-id pvar-id:syntax-class-id
literal-id literal-id
atomic-datum atomic-datum
(syntax-pattern . syntax-pattern) (syntax-pattern . syntax-pattern)
(syntax-pattern #,ellipses . syntax-pattern) (ellipsis-head-pattern #,ellipses . syntax-pattern)
((head ...+) ...* . syntax-pattern)] (~and maybe-description syntax-pattern ...)]
[ellipsis-head-pattern
(~or head ...+)
syntax-pattern]
[maybe-description
(code:line)
(code:line #:description string)]
[pvar-id [pvar-id
_ _
id]] id]]
@ -116,17 +122,8 @@ Matches a syntax pair whose head matches the first pattern and whose
tail matches the second. tail matches the second.
} }
@;{
@specsubform[(syntax-splice-pattern . syntax-pattern)]{
Matches a syntax object which consists of any sequence of syntax @specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{
objects matching the splice pattern followed by a tail matching the
given tail pattern.
}
}
@specsubform[(syntax-pattern #,ellipses . syntax-pattern)]{
Matches a sequence of the first pattern ending in a tail matching the Matches a sequence of the first pattern ending in a tail matching the
second pattern. 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 need not be a list) or a pair whose head matches the first pattern and
whose tail recursively matches the whole sequence pattern. whose tail recursively matches the whole sequence pattern.
} The head pattern can be either an ordinary pattern or an
@specsubform/subs[#:literals (...*) or/sequence-pattern:
((head ...+) ...* . syntax-pattern)
@specsubform/subs[#:literals (~or)
(~or head ...+)
([head ([head
(code:line (syntax-pattern ...+) head-directive ...)] (code:line (syntax-pattern ...+) head-directive ...)]
[head-directive [head-directive
(code:line #:min min-reps) (code:line #:min min-reps)
(code:line #:max max-reps) (code:line #:max max-reps)
(code:line #:mand) (code:line #:mand)])]{
#| (code:line #:opt)
(code:line #:occurs occurs-pvar-id)
(code:line #:default default-form)
|#])]{
Matches a sequence of any combination of the heads ending in a tail If the head is an or/sequence-pattern (introduced by @scheme[~or]),
matching the final pattern. The match is subject to constraints then the whole sequence pattern matches any combination of the head
specified on the heads. sequences followed by a tail matching the final pattern.
@specsubform[(code:line #:min min-reps)]{ @specsubform[(code:line #:min min-reps)]{
@ -175,27 +170,16 @@ in the preceding head are not bound at a higher ellipsis nesting
depth. depth.
} }
@;{
@specsubform[#:opt]{
(Probably a bad idea.)
} }
} }
} @specsubform/subs[#:literals (~and)
@;{ (~and maybe-description syntax-pattern ...)
The variants of @scheme[_syntax-splice-pattern] follow: ([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 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 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))) (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
(check-equal? (syntax->datum #'(t.b ...)) '(2 5 7))) (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 #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee"))) (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 #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee"))) (check-equal? (stx->datum #'(s ...)) '("whee")))
(test-patterns ({{1} #:min 1 #:max 1 (test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1 {2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...*) {3} #:min 1 #:max 1} ...)
#'(1 2 3) #'(1 2 3)
'ok) '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 #'(a ...)) '(three))
(check-equal? (stx->datum #'(b ...)) '(2)) (check-equal? (stx->datum #'(b ...)) '(2))
(check-equal? (stx->datum #'(c ...)) '("one"))) (check-equal? (stx->datum #'(c ...)) '("one")))
(test-patterns ({{1} #:min 1 #:max 1 (test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1 {2} #:min 1 #:max 1
{3} #:min 1 #:max 1 {3} #:min 1 #:max 1
{x} #:min 1 #:max 1 {x} #:min 1 #:max 1
{y} #:min 1 #:max 1 {y} #:min 1 #:max 1
{w} #:min 1 #:max 1} ...*) {w} #:min 1 #:max 1} ...)
#'(1 2 3 x y z) #'(1 2 3 x y z)
(for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s)) (for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s))
(check-equal? (sort (check-equal? (sort
(map symbol->string (stx->datum #'(x ... y ... w ...))) (map symbol->string (stx->datum #'(x ... y ... w ...)))
string<?) string<?)
'("x" "y" "z"))) '("x" "y" "z")))
(test-patterns ({{x} (test-patterns ({~or {x}
{1} #:min 1 #:max 1 {1} #:min 1 #:max 1
{2} #:min 1 #:max 1 {2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...*) {3} #:min 1 #:max 1} ...)
#'(1 2 3 x y z) #'(1 2 3 x y z)
(check-equal? (stx->datum #'(x ...)) '(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 ...) (pattern (case-lambda f:fun-ty/one ...)
#:with t (make-Function (syntax->datum #'(f.arr ...)))) #: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 #:with t
(make-Class (make-Class
(syntax->datum #'(pos-args.t ...)) (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 (syntax-parse stx
[(_ lib [nm:opt-rename ty] ...) [(_ lib [nm:opt-rename ty] ...)
#'(begin (require/typed nm ty lib) ...)] #'(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)] (with-syntax ([cnt* (generate-temporary #'nm.nm)]
[sm (if #'parent [sm (if #'parent
#'(#:struct-maker 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 (define-syntax-class name-exists-kw
(pattern #:name-exists)) (pattern #:name-exists))
(syntax-parse stx (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))) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin

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

@ -82,7 +82,7 @@
(define-syntax (->key stx) (define-syntax (->key stx)
(syntax-parse 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 #'(make-Function
(list (list
(make-arr* (list ty ...) (make-arr* (list ty ...)

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

@ -7,9 +7,9 @@
(define-syntax (defintern stx) (define-syntax (defintern stx)
(syntax-parse 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 ...)] #'(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 #'(define *name
(let ([table (make-ht)]) (let ([table (make-ht)])
(lambda (arg ...) (lambda (arg ...)

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

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