removed old stxclass collection
Please apply to release branch. svn: r16047
This commit is contained in:
Ryan Culpepper
parent
880f7f2707
commit
987ab4c5e8
|
|
@ -1,6 +0,0 @@
|
|||
#lang setup/infotab
|
||||
|
||||
#|
|
||||
(define scribblings
|
||||
'(("scribblings/stxclass.scrbl" (multi-page) (experimental))))
|
||||
|#
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require "private/sc.ss"
|
||||
"private/lib.ss")
|
||||
|
||||
(provide define-syntax-class
|
||||
pattern
|
||||
|
||||
~and
|
||||
~or
|
||||
...*
|
||||
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
with-patterns
|
||||
attribute
|
||||
|
||||
this-syntax
|
||||
|
||||
current-expression
|
||||
current-macro-name
|
||||
|
||||
(all-from-out "private/lib.ss")
|
||||
|
||||
(rename-out [parse-sc syntax-class-parse]
|
||||
[attrs-of syntax-class-attributes]))
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/match
|
||||
(for-template scheme/base "runtime.ss"))
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; A PK is (make-pk (listof Pattern) stx)
|
||||
;; k is the rhs expression:
|
||||
;; - open term with the attr names as free variables
|
||||
;; - attr name must be bound to variable of (listof^depth value)
|
||||
;; - 'fail' stxparameterized to (non-escaping!) failure procedure
|
||||
(define-struct pk (ps k) #:transparent)
|
||||
|
||||
;; A Group (G) is one of
|
||||
;; - PK
|
||||
;; - (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 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 FrontierContextExpr (FCE) is one of
|
||||
;; - (make-fce Id FrontierIndexExpr)
|
||||
;; - (make-joined-frontier FCE id)
|
||||
;; A FrontierIndexExpr is
|
||||
;; - `(+ ,Number ,Syntax ...)
|
||||
(define-struct fce (stx indexes))
|
||||
(define-struct joined-frontier (base ext) #:transparent)
|
||||
|
||||
(define (empty-frontier x)
|
||||
(make-fce x (list '(+ 0))))
|
||||
|
||||
(define (done-frontier x)
|
||||
(make-fce x (list '(+ +inf.0))))
|
||||
|
||||
(define (frontier:add-car fc x)
|
||||
(make-fce x (cons '(+ 0) (fce-indexes fc))))
|
||||
|
||||
(define (frontier:add-cdr fc)
|
||||
(define (fi:add1 fi)
|
||||
`(+ ,(add1 (cadr fi)) ,@(cddr fi)))
|
||||
(make-fce (fce-stx fc)
|
||||
(cons (fi:add1 (car (fce-indexes fc)))
|
||||
(cdr (fce-indexes fc)))))
|
||||
|
||||
(define (frontier:add-index fc expr)
|
||||
(define (fi:add-index fi expr)
|
||||
`(+ ,(cadr fi) ,expr ,@(cddr fi)))
|
||||
(make-fce (fce-stx fc)
|
||||
(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))
|
||||
|
||||
;; A DynamicFrontierContext (DFC) is a list of numbers.
|
||||
;; More operations on DFCs in runtime.ss
|
||||
|
||||
(define (frontier->dfc-expr fc)
|
||||
(define (loop fc)
|
||||
(match fc
|
||||
[(struct fce (stx indexes))
|
||||
#`(list #,@indexes)]
|
||||
[(struct joined-frontier (base ext))
|
||||
#`(let ([base #,(loop base)])
|
||||
(if (failed? #,ext)
|
||||
(append (reverse (failed-frontier #,ext)) base)
|
||||
base))]))
|
||||
#`(reverse #,(loop fc)))
|
||||
|
||||
(define (frontier->fstx-expr fc)
|
||||
(define (loop fc)
|
||||
(match fc
|
||||
[(struct fce (stx indexes))
|
||||
stx]
|
||||
[(struct joined-frontier (base ext))
|
||||
#`(let ([inner-failure #,ext])
|
||||
(or (and (failed? inner-failure)
|
||||
(failed-frontier-stx inner-failure))
|
||||
#,(loop base)))]))
|
||||
(loop fc))
|
||||
|
|
@ -1,650 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require (for-template scheme/base
|
||||
syntax/stx
|
||||
scheme/stxparam
|
||||
"runtime.ss")
|
||||
scheme/match
|
||||
scheme/contract
|
||||
scheme/private/sc
|
||||
syntax/stx
|
||||
syntax/boundmap
|
||||
"rep-data.ss"
|
||||
"rep.ss"
|
||||
"codegen-data.ss"
|
||||
"../util.ss")
|
||||
(provide/contract
|
||||
[parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)]
|
||||
[parse:clauses (syntax? identifier? identifier? . -> . syntax?)]
|
||||
[announce-failures? parameter?])
|
||||
|
||||
(define announce-failures? (make-parameter #f))
|
||||
|
||||
;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx
|
||||
;; Takes a list of the relevant attrs; order is significant!
|
||||
;; Returns either fail or a list having length same as 'relsattrs'
|
||||
(define (parse:rhs rhs relsattrs args)
|
||||
(with-syntax ([(arg ...) args])
|
||||
#`(lambda (x arg ...)
|
||||
(define (fail-rhs x expected frontier frontier-stx)
|
||||
#,(if (rhs-transparent? rhs)
|
||||
#`(make-failed x expected frontier frontier-stx)
|
||||
#'#f))
|
||||
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
|
||||
#,(let ([pks (rhs->pks rhs relsattrs #'x)])
|
||||
(unless (pair? pks)
|
||||
(wrong-syntax (rhs-ostx rhs)
|
||||
"syntax class has no variants"))
|
||||
(parse:pks (list #'x)
|
||||
(list (empty-frontier #'x))
|
||||
#'fail-rhs
|
||||
(list #f)
|
||||
pks))))))
|
||||
|
||||
;; parse:clauses : stx identifier identifier -> stx
|
||||
(define (parse:clauses stx var phi)
|
||||
(define clauses-kw-table
|
||||
(list (list '#:literals check-literals-list)))
|
||||
(define-values (chunks clauses-stx)
|
||||
(chunk-kw-seq/no-dups stx clauses-kw-table))
|
||||
(define literals
|
||||
(cond [(assq '#:literals chunks) => caddr]
|
||||
[else null]))
|
||||
(define (clause->pk clause)
|
||||
(syntax-case clause ()
|
||||
[(p . rest)
|
||||
(let-values ([(rest decls _ sides)
|
||||
(parse-pattern-directives #'rest
|
||||
#:sc? #f
|
||||
#:literals literals)])
|
||||
(let* ([pattern (parse-whole-pattern #'p decls)])
|
||||
(syntax-case rest ()
|
||||
[(b0 b ...)
|
||||
(let ([body #'(let () b0 b ...)])
|
||||
(make-pk (list pattern)
|
||||
(wrap-pvars (pattern-attrs pattern)
|
||||
(convert-sides sides var body))))]
|
||||
[_
|
||||
(wrong-syntax clause "expected body")])))]))
|
||||
(unless (stx-list? clauses-stx)
|
||||
(wrong-syntax clauses-stx "expected sequence of clauses"))
|
||||
(let ([pks (map clause->pk (stx->list clauses-stx))])
|
||||
(unless (pair? pks)
|
||||
(wrong-syntax stx "no variants"))
|
||||
(parse:pks (list var)
|
||||
(list (empty-frontier var))
|
||||
phi
|
||||
(list #f)
|
||||
pks)))
|
||||
|
||||
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
|
||||
(define (rhs->pks rhs relsattrs main-var)
|
||||
(match rhs
|
||||
[(struct rhs:union (_ attrs transparent? description patterns))
|
||||
(for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)])
|
||||
pk)]))
|
||||
|
||||
;; rhs-pattern->pks : RHS (listof SAttr) identifier -> (listof PK)
|
||||
(define (rhs-pattern->pks rhs relsattrs main-var)
|
||||
(match rhs
|
||||
[(struct rhs:pattern (ostx attrs pattern decls remap sides))
|
||||
(parameterize ((current-syntax-context ostx))
|
||||
(define iattrs
|
||||
(append-attrs
|
||||
(cons (pattern-attrs pattern)
|
||||
(for/list ([side sides] #:when (clause:with? side))
|
||||
(pattern-attrs (clause:with-pattern side))))))
|
||||
(define base-expr
|
||||
(success-expr iattrs relsattrs remap main-var))
|
||||
(define expr
|
||||
(wrap-pvars (pattern-attrs pattern)
|
||||
(convert-sides sides main-var base-expr)))
|
||||
(list (make-pk (list pattern) expr)))]))
|
||||
|
||||
;; convert-sides : (listof SideClause) id stx -> stx
|
||||
(define (convert-sides sides main-var body-expr)
|
||||
(match sides
|
||||
['() body-expr]
|
||||
[(cons (struct clause:when (e)) rest)
|
||||
#`(if #,e
|
||||
#,(convert-sides rest main-var body-expr)
|
||||
#,(fail #'enclosing-fail main-var
|
||||
#:pattern (expectation-of/message "side condition failed")
|
||||
#:fce (done-frontier main-var)))]
|
||||
[(cons (struct clause:with (p e)) rest)
|
||||
(let ([inner
|
||||
(wrap-pvars (pattern-attrs p)
|
||||
(convert-sides rest main-var body-expr))])
|
||||
(with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))])
|
||||
#`(let ([x #,e]
|
||||
[fail-k enclosing-fail])
|
||||
#,(parse:pks (list #'x)
|
||||
(list (done-frontier #'x))
|
||||
#'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)
|
||||
(let* ([reliattrs (reorder-iattrs relsattrs iattrs remap)]
|
||||
[flat-reliattrs (flatten-attrs* reliattrs)]
|
||||
[relids (map attr-name flat-reliattrs)])
|
||||
(with-syntax ([main main-var]
|
||||
[(relid ...) relids])
|
||||
#'(list main (attribute relid) ...))))
|
||||
|
||||
;; fail : id id #:pattern datum #:reason datum #:fce FCE #:fstx id -> stx
|
||||
(define (fail k x #:pattern p #:fce fce)
|
||||
(with-syntax ([k k]
|
||||
[x x]
|
||||
[p p]
|
||||
[fc-expr (frontier->dfc-expr fce)]
|
||||
[fstx-expr (frontier->fstx-expr fce)])
|
||||
#`(let ([failcontext fc-expr]
|
||||
[failcontext-syntax fstx-expr])
|
||||
#,(when (announce-failures?)
|
||||
#`(printf "failing on ~s\n reason: ~s\n" x p))
|
||||
(k x p failcontext failcontext-syntax))))
|
||||
|
||||
;; Parsing
|
||||
|
||||
#|
|
||||
|
||||
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 phi ds pks)
|
||||
(cond [(null? pks)
|
||||
(error 'parse:pks "internal error: empty list of rows")]
|
||||
[(null? vars)
|
||||
;; Success!
|
||||
(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 ...] #,phi)))]
|
||||
[else
|
||||
(let-values ([(vars groups) (split-pks vars pks)])
|
||||
(let* ([failvar (generate-temporary 'fail-k)]
|
||||
[exprs
|
||||
(for/list ([group groups])
|
||||
(parse:group vars fcs failvar ds group))])
|
||||
(with-syntax ([failvar failvar]
|
||||
[(expr ...) exprs])
|
||||
#`(try failvar [expr ...] #,phi))))]))
|
||||
|
||||
|
||||
;; parse:group : <ParseConfig> Group -> stx
|
||||
;; Pre: vars is not empty
|
||||
(define (parse:group vars fcs phi ds group)
|
||||
(match group
|
||||
[(struct idG (stxclass args pks))
|
||||
(if stxclass
|
||||
(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:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)]))
|
||||
|
||||
;; 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)]
|
||||
[parser (sc-parser-name stxclass)]
|
||||
[result (generate-temporary 'result)])
|
||||
#`(let ([arg-var arg] ...)
|
||||
(let ([result (parser var0 arg-var ...)])
|
||||
(if (ok? result)
|
||||
#,(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: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) phi (cdr ds) (shift-pks:id pks #'result))))))
|
||||
|
||||
;; 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 (datumSG-test datumSG)
|
||||
(let ([datum (datumSG-datum datumSG)])
|
||||
#`(equal? #,datum-var (quote #,datum))))
|
||||
(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 (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 ([datumSG datumSGs])
|
||||
#`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])]
|
||||
[(lit-clause ...)
|
||||
(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 compound-clause ...
|
||||
lit-clause ...
|
||||
datum-clause ...
|
||||
[else
|
||||
#,(fail phi (car vars)
|
||||
#:pattern (expectation-of-constants
|
||||
(pair? compoundSGs)
|
||||
(for/list ([d datumSGs])
|
||||
(datumSG-datum d))
|
||||
(for/list ([l literalSGs])
|
||||
(literalSG-literal l))
|
||||
(car ds))
|
||||
#:fce (car fcs))]))))
|
||||
|
||||
;; 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 (_ _ _ 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 (ostx attrs depth heads tail)) gseq-pattern)
|
||||
(define xvar (generate-temporary 'x))
|
||||
(define head-lengths (for/list ([head heads]) (length (head-ps head))))
|
||||
(define head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head))))
|
||||
(define hid-initss
|
||||
(for/list ([head heads] [head-attrs head-attrss])
|
||||
(for/list ([head-attr head-attrs])
|
||||
(cond [(head-as-list? head) #'null]
|
||||
[else #'#f]))))
|
||||
(define combinerss
|
||||
(for/list ([head heads] [head-attrs head-attrss])
|
||||
(for/list ([head-attr head-attrs])
|
||||
(if (head-as-list? head) #'cons #'or))))
|
||||
(define finalizess
|
||||
(for/list ([head heads] [head-attrs head-attrss])
|
||||
(for/list ([head-attr head-attrs])
|
||||
(if (head-as-list? head) #'reverse #'values))))
|
||||
(define head-idss
|
||||
(for/list ([head-attrs head-attrss])
|
||||
(map attr-name head-attrs)))
|
||||
(define completed-heads
|
||||
(for/list ([head heads])
|
||||
(complete-heads-pattern head xvar (add1 depth) ostx)))
|
||||
(define hid-argss (map generate-temporaries head-idss))
|
||||
(define hid-args (apply append hid-argss))
|
||||
(define mins (map head-min heads))
|
||||
(define maxs (map head-max heads))
|
||||
(define as-list?s (map head-as-list? heads))
|
||||
(define reps (generate-temporaries (for/list ([head heads]) 'rep)))
|
||||
|
||||
(with-syntax ([x xvar]
|
||||
[var0 (car vars)]
|
||||
[((hid ...) ...) head-idss]
|
||||
[((hid-arg ...) ...) hid-argss]
|
||||
[((hid-init ...) ...) hid-initss]
|
||||
[((combine ...) ...) combinerss]
|
||||
[((finalize ...) ...) finalizess]
|
||||
[(head-length ...) head-lengths]
|
||||
[(rep ...) reps]
|
||||
[(maxrepconstraint ...)
|
||||
;; FIXME: move to side condition to appropriate pattern
|
||||
(for/list ([repvar reps] [maxrep maxs])
|
||||
(if maxrep
|
||||
#`(< #,repvar #,maxrep)
|
||||
#`#t))]
|
||||
[(parse-loop failkv fail-tail)
|
||||
(generate-temporaries #'(parse-loop failkv fail-tail))])
|
||||
|
||||
(define (gen-head-rhs my-hids my-hid-args combiners repvar maxrep)
|
||||
(with-syntax ([(my-hid ...) my-hids]
|
||||
[(my-hid-arg ...) my-hid-args]
|
||||
[(combine ...) combiners]
|
||||
[rep repvar]
|
||||
[maxrep-constraint
|
||||
(if maxrep
|
||||
#`(< #,repvar #,maxrep)
|
||||
#`'#t)])
|
||||
#`(let ([my-hid-arg (combine my-hid my-hid-arg)] ...)
|
||||
(if maxrep-constraint
|
||||
(let ([rep (add1 rep)])
|
||||
(parse-loop x #,@hid-args #,@reps enclosing-fail))
|
||||
#,(fail #'enclosing-fail #'var0
|
||||
#:pattern (expectation-of/message "maximum rep constraint failed")
|
||||
#:fce (frontier:add-index (car fcs)
|
||||
#`(calculate-index #,@reps)))))))
|
||||
|
||||
(define tail-rhs-expr
|
||||
(with-syntax ([(minrep-clause ...)
|
||||
(for/list ([repvar reps] [minrep mins] #:when minrep)
|
||||
#`[(< #,repvar #,minrep)
|
||||
#,(fail #'enclosing-fail (car vars)
|
||||
#:pattern (expectation-of/message "mininum rep constraint failed")
|
||||
#:fce (frontier:add-index (car fcs)
|
||||
#`(calculate-index #,@reps)))])])
|
||||
#`(cond minrep-clause ...
|
||||
[else
|
||||
(let ([hid (finalize hid-arg)] ... ...
|
||||
[fail-tail enclosing-fail])
|
||||
#,(parse:pks (cdr vars)
|
||||
(cdr fcs)
|
||||
#'fail-tail
|
||||
(cdr ds)
|
||||
(list (make-pk rest-patterns k))))])))
|
||||
|
||||
(with-syntax ([tail-rhs tail-rhs-expr]
|
||||
[(rhs ...)
|
||||
(for/list ([hids head-idss]
|
||||
[hid-args hid-argss]
|
||||
[combiners combinerss]
|
||||
[repvar reps]
|
||||
[maxrep maxs])
|
||||
(gen-head-rhs hids hid-args combiners repvar maxrep))])
|
||||
#`(let ()
|
||||
(define (calculate-index rep ...)
|
||||
(+ (* rep head-length) ...))
|
||||
(define (parse-loop x hid-arg ... ... rep ... failkv)
|
||||
#,(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)))))
|
||||
(let ([hid hid-init] ... ...
|
||||
[rep 0] ...)
|
||||
(parse-loop var0 hid ... ... rep ... #,phi))))))
|
||||
|
||||
;; complete-heads-patterns : Head identifier number -> Pattern
|
||||
(define (complete-heads-pattern head rest-var depth seq-ostx)
|
||||
(define (loop ps pat)
|
||||
(if (pair? ps)
|
||||
(make pat:compound
|
||||
(cons (pattern-ostx (car ps)) (pattern-ostx 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-ostx
|
||||
(list (make-attr rest-var depth null))
|
||||
depth rest-var #f null))
|
||||
(loop (head-ps head) base))
|
||||
|
||||
;; split-pks : (listof identifier) (listof PK)
|
||||
;; -> (values (listof identifier) (listof ExtPK)
|
||||
(define (split-pks vars pks)
|
||||
(values vars
|
||||
(if (pair? vars)
|
||||
(split-pks/first-column pks)
|
||||
pks)))
|
||||
|
||||
;; split-pks/first-column : (listof PK) -> (listof ExtPK)
|
||||
;; Pre: the PKs have at least one column
|
||||
(define (split-pks/first-column pks)
|
||||
(define (get-pat x) (car (pk-ps x)))
|
||||
(define (constructor-pat? p)
|
||||
(or (pat:compound? p) (pat:datum? p) (pat:literal? p)))
|
||||
(define (constructor-pk? pk)
|
||||
(constructor-pat? (get-pat pk)))
|
||||
(define (id-pk? pk)
|
||||
(pat:id? (get-pat pk)))
|
||||
|
||||
(define pk-cache (make-hasheq))
|
||||
(define pattern-cache (make-hasheq))
|
||||
(define (commutes? pk1 pk2)
|
||||
(let ([pk1-ht (hash-ref pk-cache pk1
|
||||
(lambda ()
|
||||
(let ([pk1-ht (make-hasheq)])
|
||||
(hash-set! pk-cache pk1 pk1-ht)
|
||||
pk1-ht)))])
|
||||
(hash-ref pk1-ht pk2
|
||||
(lambda ()
|
||||
(let ([result (ormap pattern-commutes?
|
||||
(pk-ps pk1)
|
||||
(pk-ps pk2))])
|
||||
(hash-set! pk1-ht pk2 result)
|
||||
result)))))
|
||||
|
||||
(define (pattern-commutes? p1 p2)
|
||||
(let ([result (not (pattern-intersects? p1 p2))])
|
||||
(when #f ;; result
|
||||
(printf "commutes!\n ~s\n & ~s\n"
|
||||
(syntax->datum (pattern-ostx p1))
|
||||
(syntax->datum (pattern-ostx p2))))
|
||||
result))
|
||||
|
||||
(define (pattern-intersects? p1 p2)
|
||||
(let ([p1-ht (hash-ref pattern-cache p1
|
||||
(lambda ()
|
||||
(let ([p1-ht (make-hasheq)])
|
||||
(hash-set! pattern-cache p1 p1-ht)
|
||||
p1-ht)))])
|
||||
(hash-ref p1-ht p2
|
||||
(lambda ()
|
||||
(let ([result (do-pattern-intersects? p1 p2)])
|
||||
(hash-set! p1-ht p2 result)
|
||||
result)))))
|
||||
|
||||
(define (do-pattern-intersects? p1 p2)
|
||||
(or (pat:id? p1)
|
||||
(pat:id? p2)
|
||||
(and (pat:datum? p1) (pat:datum? p2)
|
||||
(equal? (pat:datum-datum p1) (pat:datum-datum 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:and? p1)
|
||||
(pat:and? p2)))
|
||||
|
||||
(define (major-loop pks epks)
|
||||
(match pks
|
||||
['() (reverse epks)]
|
||||
[(cons (? constructor-pk? head) tail)
|
||||
(let-values ([(r-constructor-pks tail)
|
||||
(gather constructor-pat? tail (list head) null)])
|
||||
(let ([c-epk (group-constructor-pks r-constructor-pks)])
|
||||
(major-loop tail (cons c-epk epks))))]
|
||||
[(cons (? id-pk? head) tail)
|
||||
(let* ([this-pat (get-pat head)]
|
||||
[this-stxclass (pat:id-stxclass this-pat)]
|
||||
[this-args (pat:id-args this-pat)])
|
||||
(let-values ([(r-id-pks tail)
|
||||
(gather (lambda (p)
|
||||
(and (pat:id? p)
|
||||
(equal? (pat:id-stxclass p) this-stxclass)
|
||||
(equal? (pat:id-args p) this-args)))
|
||||
tail
|
||||
(list head)
|
||||
null)])
|
||||
(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)
|
||||
(match pks
|
||||
['()
|
||||
(values taken (reverse prefix))]
|
||||
[(cons pk tail)
|
||||
;; We can have it if it can move past everything in the prefix.
|
||||
(if (and (pred (get-pat pk))
|
||||
(for/and ([prefixpk prefix])
|
||||
(commutes? pk prefixpk)))
|
||||
(gather pred tail (cons pk taken) prefix)
|
||||
(gather pred tail taken (cons pk prefix)))]))
|
||||
|
||||
;; group-constructor-pks : (listof PK) -> ExtPK
|
||||
(define (group-constructor-pks reversed-pks)
|
||||
(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: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! datum-ht d (cons pk (hash-ref datum-ht d null))))]
|
||||
[(pat:literal? p)
|
||||
(let ([lit (pat:literal-literal p)])
|
||||
(bound-identifier-mapping-put!
|
||||
lit-ht
|
||||
lit
|
||||
(cons pk
|
||||
(bound-identifier-mapping-get lit-ht lit
|
||||
(lambda () null)))))])))
|
||||
(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))
|
||||
|
||||
;; shift-pks:id : (listof PK) identifier -> (listof PK)
|
||||
(define (shift-pks:id pks matches-var)
|
||||
(map (lambda (pk) (shift-pk:id pk matches-var))
|
||||
pks))
|
||||
|
||||
;; shift-pk:id : PK identifier identifier -> PK
|
||||
;; FIXME: Assumes that all attrs are relevant!!!
|
||||
(define (shift-pk:id pk0 matches-var0)
|
||||
(match pk0
|
||||
[(struct pk ((cons (struct pat:id (_ attrs depth name _ _)) rest-ps) k))
|
||||
(let* ([flat-attrs (flatten-attrs* attrs depth #f #f)]
|
||||
;; FIXME: depth already included, right???
|
||||
[ids (map attr-name flat-attrs)]
|
||||
[depths (map attr-depth flat-attrs)])
|
||||
(with-syntax ([(id ...) ids]
|
||||
[(depth ...) depths])
|
||||
(make-pk rest-ps
|
||||
(if (pair? ids)
|
||||
#`(let-values ([(id ...)
|
||||
#,(if name
|
||||
#`(apply values #,matches-var0)
|
||||
#`(apply values (cdr #,matches-var0)))])
|
||||
#,k)
|
||||
k))))]))
|
||||
|
||||
;; shift-pks:datum : (listof PK) -> (listof PK)
|
||||
(define (shift-pks:datum pks)
|
||||
(define (shift-pk pk)
|
||||
(make-pk (cdr (pk-ps pk)) (pk-k pk)))
|
||||
(map shift-pk pks))
|
||||
|
||||
;; shift-pks:literal : (listof PK) -> (listof PK)
|
||||
(define (shift-pks:literal pks)
|
||||
(define (shift-pk pk)
|
||||
(make-pk (cdr (pk-ps pk)) (pk-k pk)))
|
||||
(map shift-pk pks))
|
||||
|
||||
;; shift-pks:compound : (listof PK) -> (listof PK)
|
||||
(define (shift-pks:compound pks)
|
||||
(define (shift-pk pk0)
|
||||
(match pk0
|
||||
[(struct pk ((cons (struct pat:compound (_ _ _ _ patterns)) rest-ps)
|
||||
k))
|
||||
(make-pk (append patterns rest-ps) k)]))
|
||||
(map shift-pk pks))
|
||||
|
||||
;; wrap-pvars : (listof IAttr) stx -> stx
|
||||
(define (wrap-pvars iattrs expr)
|
||||
(let* ([flat-iattrs (flatten-attrs* iattrs 0 #f #f)]
|
||||
[ids (map attr-name flat-iattrs)]
|
||||
[depths (map attr-depth flat-iattrs)])
|
||||
(with-syntax ([(id ...) ids]
|
||||
[(depth ...) depths]
|
||||
[expr expr])
|
||||
#'(let-attributes ([id depth id] ...)
|
||||
expr))))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "codegen.ss"))
|
||||
|
||||
(provide announce-parse-failures)
|
||||
|
||||
(define-syntax (announce-parse-failures stx)
|
||||
(syntax-case stx ()
|
||||
[(_ b)
|
||||
(begin (announce-failures? (and (syntax-e #'b) #t))
|
||||
#'(void))]
|
||||
[(_)
|
||||
#'(announce-failures #t)]))
|
||||
|
||||
|
|
@ -1,137 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "sc.ss"
|
||||
"../util.ss"
|
||||
syntax/stx
|
||||
syntax/kerncase
|
||||
scheme/struct-info
|
||||
scheme/private/contract-helpers
|
||||
(for-syntax scheme/base
|
||||
"rep.ss")
|
||||
(for-template scheme/base
|
||||
scheme/contract))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-syntax-rule (define-pred-stxclass name pred)
|
||||
(define-syntax-class name #:attributes ([datum 0])
|
||||
(pattern x
|
||||
#:with datum (if (syntax? #'x) (syntax-e #'x) #'x)
|
||||
#:when (pred (attribute datum)))))
|
||||
|
||||
(define-pred-stxclass identifier symbol?)
|
||||
(define-pred-stxclass boolean boolean?)
|
||||
(define-pred-stxclass str string?)
|
||||
(define-pred-stxclass character char?)
|
||||
(define-pred-stxclass keyword keyword?)
|
||||
|
||||
(define-pred-stxclass number number?)
|
||||
(define-pred-stxclass integer integer?)
|
||||
(define-pred-stxclass exact-integer exact-integer?)
|
||||
(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
|
||||
(define-pred-stxclass exact-positive-integer exact-positive-integer?)
|
||||
|
||||
(define-syntax-class (static-of name pred)
|
||||
#:attributes (value)
|
||||
(pattern x:id
|
||||
#:with value-list (syntax-local-value* #'x)
|
||||
#:when (pair? (attribute value-list))
|
||||
#:with value (car (attribute value-list))
|
||||
#:when (pred (attribute value))))
|
||||
|
||||
(define (syntax-local-value* id)
|
||||
(let/ec escape
|
||||
(list (syntax-local-value id (lambda () (escape null))))))
|
||||
|
||||
(define-syntax-class static #:attributes (value)
|
||||
(pattern x
|
||||
#:declare x (static-of "static" (lambda _ #t))
|
||||
#:with value #'x.value))
|
||||
|
||||
(define-syntax-class struct-name
|
||||
#:description "struct name"
|
||||
#:attributes (descriptor
|
||||
constructor
|
||||
predicate
|
||||
[accessor 1]
|
||||
super
|
||||
complete?)
|
||||
(pattern s
|
||||
#:declare s (static-of "struct name" struct-info?)
|
||||
#:with info (extract-struct-info (attribute s.value))
|
||||
#:with descriptor (list-ref (attribute info) 0)
|
||||
#:with constructor (list-ref (attribute info) 1)
|
||||
#:with predicate (list-ref (attribute info) 2)
|
||||
#:with r-accessors (reverse (list-ref (attribute info) 3))
|
||||
#:with (accessor ...)
|
||||
(datum->syntax #f (let ([r-accessors (attribute r-accessors)])
|
||||
(if (and (pair? r-accessors) (eq? #f (car r-accessors)))
|
||||
(cdr r-accessors)
|
||||
r-accessors)))
|
||||
#:with super (list-ref (attribute info) 5)
|
||||
#:with complete? (or (null? (attribute r-accessors))
|
||||
(and (pair? (attribute r-accessors))
|
||||
(not (eq? #f (car (attribute r-accessors))))))))
|
||||
|
||||
(define-syntax-class expr/local-expand
|
||||
#:attributes (expanded)
|
||||
(pattern x
|
||||
#:with expanded (local-expand #'x 'expression null)))
|
||||
|
||||
(define-syntax-class expr/head-local-expand
|
||||
#:attributes (expanded)
|
||||
(pattern x
|
||||
#:with expanded (local-expand #'x 'expression (kernel-form-identifier-list))))
|
||||
|
||||
(define-syntax-class block/head-local-expand
|
||||
#:attributes (expanded-block
|
||||
[expanded 1]
|
||||
[def 1]
|
||||
[vdef 1]
|
||||
[sdef 1]
|
||||
[expr 1])
|
||||
(pattern x
|
||||
#:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
|
||||
(datum->syntax #f
|
||||
(let-values ([(ex1 ex2 defs vdefs sdefs exprs)
|
||||
(head-local-expand-and-categorize-syntaxes
|
||||
#'x #f #| #t |#)])
|
||||
(list ex1 ex2 defs vdefs sdefs exprs)))))
|
||||
|
||||
(define-syntax-class internal-definitions
|
||||
#:attributes (expanded-block
|
||||
[expanded 1]
|
||||
[def 1]
|
||||
[vdef 1]
|
||||
[sdef 1]
|
||||
[expr 1])
|
||||
(pattern x
|
||||
#:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
|
||||
(datum->syntax #f
|
||||
(let-values ([(ex1 ex2 defs vdefs sdefs exprs)
|
||||
(head-local-expand-and-categorize-syntaxes
|
||||
#'x #t #| #f |#)])
|
||||
(list ex1 ex2 defs vdefs sdefs exprs)))))
|
||||
|
||||
(define-syntax-class expr
|
||||
#:attributes ()
|
||||
(pattern x
|
||||
#:when (and (syntax? #'x) (not (keyword? (syntax-e #'x))))))
|
||||
|
||||
|
||||
;; FIXME: hack
|
||||
(define expr/c-use-contracts? (make-parameter #t))
|
||||
|
||||
(define-syntax-class (expr/c ctc)
|
||||
#:attributes (c)
|
||||
(pattern x:expr
|
||||
#:with c #`(contract #,ctc
|
||||
x
|
||||
(quote #,(string->symbol (or (build-src-loc-string #'x) "")))
|
||||
(quote #,(or (current-macro-name) '<this-macro>))
|
||||
(quote-syntax #,(syntax/loc #'x (<there>))))))
|
||||
|
||||
;; Aliases
|
||||
|
||||
(define-syntax id (make-rename-transformer #'identifier))
|
||||
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
|
||||
(define-syntax char (make-rename-transformer #'character))
|
||||
|
|
@ -1,477 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
scheme/match
|
||||
syntax/stx
|
||||
syntax/boundmap
|
||||
"../util.ss")
|
||||
(provide (struct-out sc)
|
||||
(struct-out attr)
|
||||
(struct-out rhs)
|
||||
(struct-out rhs:union)
|
||||
(struct-out rhs:pattern)
|
||||
(struct-out pattern)
|
||||
(struct-out pat:id)
|
||||
(struct-out pat:datum)
|
||||
(struct-out pat:literal)
|
||||
(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))
|
||||
|
||||
;; An SC is one of (make-sc symbol (listof symbol) (list-of SAttr) identifier)
|
||||
(define-struct sc (name inputs attrs parser-name description)
|
||||
#:property prop:procedure (lambda (self stx) (sc-parser-name self))
|
||||
#:transparent)
|
||||
|
||||
;; An IAttr is (make-attr identifier number (listof SAttr))
|
||||
;; An SAttr is (make-attr symbol number (listof SAttr))
|
||||
(define-struct attr (name depth inner)
|
||||
#:transparent)
|
||||
|
||||
;; RHSBase is stx (listof SAttr) boolean stx/#f
|
||||
(define-struct rhs (ostx attrs transparent? description)
|
||||
#:transparent)
|
||||
|
||||
;; A RHS is one of
|
||||
;; (make-rhs:union <RHSBase> (listof RHS))
|
||||
(define-struct (rhs:union rhs) (patterns)
|
||||
#:transparent)
|
||||
|
||||
;; An RHSPattern is
|
||||
;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause))
|
||||
(define-struct rhs:pattern (stx attrs pattern decls remap sides)
|
||||
#:transparent)
|
||||
|
||||
#|
|
||||
|
||||
NOT YET ...
|
||||
|
||||
;; A Pattern is
|
||||
;; (make-pattern (listof IAttr) PCtx (listof id) string/#f Descriminator)
|
||||
(define-struct pattern (attrs ctx names description descrim) #:transparent)
|
||||
|
||||
;; A PatternContext (PCtx) is
|
||||
;; (make-pctx stx nat (listof IAttr) (listof IAttr))
|
||||
(define-struct pctx (ostx depth env outer-env) #:transparent)
|
||||
|
||||
;; A Descriminator is one of
|
||||
;; (make-d:any)
|
||||
;; (make-d:stxclass SC (listof stx))
|
||||
;; (make-d:datum datum)
|
||||
;; (make-d:literal id)
|
||||
;; (make-d:gseq (listof Head) Pattern)
|
||||
;; (make-d:and (listof Pattern))
|
||||
;; (make-d:orseq (listof Head))
|
||||
;; (make-d:compound Kind (listof Pattern))
|
||||
(define-struct d:any () #:transparent)
|
||||
(define-struct d:stxclass (stxclass args) #:transparent)
|
||||
(define-struct d:datum (datum) #:transparent)
|
||||
(define-struct d:literal (literal) #:transparent)
|
||||
(define-struct d:gseq (heads tail) #:transparent)
|
||||
(define-struct d:and (subpatterns) #:transparent)
|
||||
(define-struct d:orseq (heads) #:transparent)
|
||||
(define-struct d:compound (kind patterns) #:transparent)
|
||||
|#
|
||||
|
||||
;; A Pattern is one of
|
||||
;; (make-pat:id <Pattern> identifier SC/#f (listof stx))
|
||||
;; (make-pat:datum <Pattern> datum)
|
||||
;; (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 (ostx 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: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 (ostx attrs depth ps min max as-list?) #:transparent)
|
||||
|
||||
;; A SideClause is one of
|
||||
;; (make-clause:with pattern stx)
|
||||
;; (make-clause:when stx)
|
||||
(define-struct clause:with (pattern expr) #:transparent)
|
||||
(define-struct clause:when (expr) #:transparent)
|
||||
|
||||
;; make-empty-sc : identifier -> SC
|
||||
;; Dummy stxclass for calculating attributes of recursive stxclasses.
|
||||
(define (make-empty-sc name)
|
||||
(make sc (syntax-e name) null null #f #f))
|
||||
|
||||
(define (iattr? a)
|
||||
(and (attr? a) (identifier? (attr-name a))))
|
||||
|
||||
(define (sattr? a)
|
||||
(and (attr? a) (symbol? (attr-name a))))
|
||||
|
||||
|
||||
;; Environments
|
||||
|
||||
;; DeclEnv maps [id => DeclEntry]
|
||||
;; DeclEntry =
|
||||
;; (list 'literal id id)
|
||||
;; (list 'stxclass id id (listof stx))
|
||||
;; #f
|
||||
|
||||
(define-struct declenv (bm))
|
||||
|
||||
(define (new-declenv literals)
|
||||
(let ([decls (make-declenv (make-bound-identifier-mapping))])
|
||||
(for ([literal literals])
|
||||
(declenv-put-literal decls (car literal) (cadr literal)))
|
||||
decls))
|
||||
|
||||
(define (declenv-lookup env id)
|
||||
(bound-identifier-mapping-get (declenv-bm env) id (lambda () #f)))
|
||||
|
||||
(define (declenv-check-unbound env id [stxclass-name #f]
|
||||
#:blame-declare? [blame-declare? #f])
|
||||
;; Order goes: literals, pattern, declares
|
||||
;; So blame-declare? only applies to stxclass declares
|
||||
(let ([val (declenv-lookup env id)])
|
||||
(when val
|
||||
(cond [(eq? 'literal (car val))
|
||||
(wrong-syntax id "identifier previously declared as literal")]
|
||||
[(and blame-declare? stxclass-name)
|
||||
(wrong-syntax (cadr val)
|
||||
"identifier previously declared with syntax class ~a"
|
||||
stxclass-name)]
|
||||
[else
|
||||
(wrong-syntax (if blame-declare? (cadr val) id)
|
||||
"identifier previously declared")]))))
|
||||
|
||||
(define (declenv-put-literal env internal-id lit-id)
|
||||
(declenv-check-unbound env internal-id)
|
||||
(bound-identifier-mapping-put! (declenv-bm env) internal-id
|
||||
(list 'literal internal-id lit-id)))
|
||||
|
||||
(define (declenv-put-stxclass env id stxclass-name args)
|
||||
(declenv-check-unbound env id)
|
||||
(bound-identifier-mapping-put! (declenv-bm env) id
|
||||
(list 'stxclass id stxclass-name args)))
|
||||
|
||||
;; returns ids in domain of env but not in given list
|
||||
(define (declenv-domain-difference env ids)
|
||||
(define idbm (make-bound-identifier-mapping))
|
||||
(define excess null)
|
||||
(for ([id ids]) (bound-identifier-mapping-put! idbm id #t))
|
||||
(bound-identifier-mapping-for-each
|
||||
(declenv-bm env)
|
||||
(lambda (k v)
|
||||
(when (and (pair? v) (eq? (car v) 'stxclass))
|
||||
(unless (bound-identifier-mapping-get idbm k (lambda () #f))
|
||||
(set! excess (cons k excess))))))
|
||||
excess)
|
||||
|
||||
;; A RemapEnv is a bound-identifier-mapping
|
||||
|
||||
(define (new-remapenv)
|
||||
(make-bound-identifier-mapping))
|
||||
|
||||
(define (remapenv-lookup env id)
|
||||
(bound-identifier-mapping-get env id (lambda () (syntax-e id))))
|
||||
|
||||
(define (remapenv-put env id sym)
|
||||
(bound-identifier-mapping-put! env id sym))
|
||||
|
||||
(define (remapenv-domain env)
|
||||
(bound-identifier-mapping-map env (lambda (k v) k)))
|
||||
|
||||
(define trivial-remap
|
||||
(new-remapenv))
|
||||
|
||||
;; Contracts
|
||||
|
||||
(define DeclEnv/c
|
||||
(flat-named-contract "DeclEnv/c" declenv?))
|
||||
|
||||
(define RemapEnv/c
|
||||
(flat-named-contract "RemapEnv/c" bound-identifier-mapping?))
|
||||
|
||||
(define SideClause/c
|
||||
(or/c clause:with? clause:when?))
|
||||
|
||||
(provide/contract
|
||||
[DeclEnv/c contract?]
|
||||
[RemapEnv/c contract?]
|
||||
[SideClause/c contract?]
|
||||
|
||||
[make-empty-sc (-> identifier? sc?)]
|
||||
[allow-unbound-stxclasses (parameter/c boolean?)]
|
||||
[iattr? (any/c . -> . boolean?)]
|
||||
[sattr? (any/c . -> . boolean?)]
|
||||
|
||||
[new-declenv
|
||||
(-> (listof (list/c identifier? identifier?)) DeclEnv/c)]
|
||||
[declenv-lookup
|
||||
(-> declenv? identifier? any)]
|
||||
[declenv-put-literal
|
||||
(-> declenv? identifier? identifier? any)]
|
||||
[declenv-put-stxclass
|
||||
(-> declenv? identifier? identifier? (listof syntax?)
|
||||
any)]
|
||||
[declenv-domain-difference
|
||||
(-> declenv? (listof identifier?)
|
||||
(listof identifier?))]
|
||||
|
||||
[new-remapenv
|
||||
(-> RemapEnv/c)]
|
||||
[remapenv-lookup
|
||||
(-> RemapEnv/c identifier? symbol?)]
|
||||
[remapenv-put
|
||||
(-> RemapEnv/c identifier? symbol? any)]
|
||||
[remapenv-domain
|
||||
(-> RemapEnv/c list?)]
|
||||
[trivial-remap
|
||||
RemapEnv/c]
|
||||
|
||||
[iattr->sattr (iattr? . -> . sattr?)]
|
||||
[rename-attr
|
||||
(attr? symbol? . -> . sattr?)]
|
||||
[iattrs->sattrs
|
||||
(-> (listof iattr?) RemapEnv/c
|
||||
(listof sattr?))]
|
||||
[sattr->iattr/id (sattr? identifier? . -> . iattr?)]
|
||||
|
||||
[get-stxclass
|
||||
(-> identifier? any)]
|
||||
[get-stxclass/check-arg-count
|
||||
(-> identifier? exact-nonnegative-integer? any)]
|
||||
[split-id/get-stxclass
|
||||
(-> identifier? DeclEnv/c any)]
|
||||
|
||||
[intersect-attrss ((listof (listof sattr?)) syntax? . -> . (listof sattr?))]
|
||||
[join-attrs (sattr? sattr? syntax? . -> . sattr?)]
|
||||
[reorder-iattrs
|
||||
(-> (listof sattr?) (listof iattr?) RemapEnv/c
|
||||
(listof iattr?))]
|
||||
[restrict-iattrs
|
||||
(-> (listof sattr?) (listof iattr?) RemapEnv/c
|
||||
(listof iattr?))]
|
||||
[flatten-sattrs
|
||||
(->* [(listof sattr?)]
|
||||
[exact-integer? (or/c symbol? false/c)]
|
||||
(listof sattr?))]
|
||||
[intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))]
|
||||
[flatten-attrs*
|
||||
(->* [(listof iattr?)]
|
||||
[exact-nonnegative-integer? any/c any/c]
|
||||
(listof iattr?))]
|
||||
[append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))]
|
||||
[lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
|
||||
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
|
||||
)
|
||||
|
||||
|
||||
(define allow-unbound-stxclasses (make-parameter #f))
|
||||
|
||||
(define (iattr->sattr a)
|
||||
(match a
|
||||
[(struct attr (name depth inner))
|
||||
(make attr (syntax-e name) depth inner)]))
|
||||
|
||||
(define (rename-attr a name)
|
||||
(make attr name (attr-depth a) (attr-inner a)))
|
||||
|
||||
(define (iattrs->sattrs as remap)
|
||||
(if (pair? as)
|
||||
(let ([name* (remapenv-lookup remap (attr-name (car as)))])
|
||||
(if name*
|
||||
(cons (rename-attr (car as) name*)
|
||||
(iattrs->sattrs (cdr as) remap))
|
||||
(iattrs->sattrs (cdr as) remap)))
|
||||
null))
|
||||
|
||||
(define (sattr->iattr/id a id)
|
||||
(match a
|
||||
[(struct attr (name depth inner))
|
||||
(make attr (datum->syntax id name id) depth inner)]))
|
||||
|
||||
|
||||
(define (get-stxclass id)
|
||||
(define (no-good)
|
||||
(if (allow-unbound-stxclasses)
|
||||
(make-empty-sc id)
|
||||
(wrong-syntax id "not defined as syntax class")))
|
||||
(let ([sc (syntax-local-value/catch id sc?)])
|
||||
(if (sc? sc)
|
||||
sc
|
||||
(no-good))))
|
||||
|
||||
(define (get-stxclass/check-arg-count id arg-count)
|
||||
(let* ([sc (get-stxclass id)]
|
||||
[expected-arg-count (length (sc-inputs sc))])
|
||||
(unless (or (= expected-arg-count arg-count)
|
||||
(allow-unbound-stxclasses))
|
||||
;; (above: don't check error if stxclass may not be defined yet)
|
||||
(wrong-syntax id
|
||||
"too few arguments for syntax-class ~a (expected ~s)"
|
||||
(syntax-e id)
|
||||
expected-arg-count))
|
||||
sc))
|
||||
|
||||
(define (split-id/get-stxclass id0 decls)
|
||||
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
|
||||
=> (lambda (m)
|
||||
(define id
|
||||
(datum->syntax id0 (string->symbol (cadr m)) id0 id0))
|
||||
(define scname
|
||||
(datum->syntax id0 (string->symbol (caddr m)) id0 id0))
|
||||
(declenv-check-unbound decls id (syntax-e scname)
|
||||
#:blame-declare? #t)
|
||||
(let ([sc (get-stxclass/check-arg-count scname 0)])
|
||||
(values id sc null)))]
|
||||
[else (values id0 #f null)]))
|
||||
|
||||
;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr)
|
||||
(define (intersect-attrss attrss blamestx)
|
||||
(cond [(null? attrss) null]
|
||||
[else
|
||||
(let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)]
|
||||
[names (filter (lambda (s)
|
||||
(andmap (lambda (names) (memq s names))
|
||||
(cdr namess)))
|
||||
(car namess))]
|
||||
[ht (make-hasheq)]
|
||||
[put (lambda (attr) (hash-set! ht (attr-name attr) attr))]
|
||||
[fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))])
|
||||
(for* ([attrs attrss]
|
||||
[attr attrs]
|
||||
#:when (memq (attr-name attr) names))
|
||||
(put (join-attrs attr (fetch-like attr) blamestx)))
|
||||
(sort (hash-map ht (lambda (k v) v))
|
||||
(lambda (a b)
|
||||
(string<? (symbol->string (attr-name a))
|
||||
(symbol->string (attr-name b))))))]))
|
||||
|
||||
;; join-attrs : SAttr SAttr stx -> SAttr
|
||||
(define (join-attrs a b blamestx)
|
||||
(define (complain str . args)
|
||||
(apply wrong-syntax blamestx str args))
|
||||
(if (not b)
|
||||
a
|
||||
(begin
|
||||
(unless (equal? (attr-depth a) (attr-depth b))
|
||||
(complain "attribute '~a'occurs with different nesting depth"
|
||||
(attr-name a)))
|
||||
(make attr (attr-name a)
|
||||
(attr-depth a)
|
||||
(intersect-attrss (list (attr-inner a) (attr-inner b))
|
||||
blamestx)))))
|
||||
|
||||
;; reorder-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr)
|
||||
;; Reorders iattrs (and restricts) based on relsattrs
|
||||
;; If a relsattr is not found, or if depth or contents mismatches, raises error.
|
||||
(define (reorder-iattrs relsattrs iattrs remap)
|
||||
(let ([ht (make-hasheq)])
|
||||
(for ([iattr iattrs])
|
||||
(let ([remap-name (remapenv-lookup remap (attr-name iattr))])
|
||||
(hash-set! ht remap-name iattr)))
|
||||
(let loop ([relsattrs relsattrs])
|
||||
(match relsattrs
|
||||
['() null]
|
||||
[(cons (struct attr (name depth inner)) rest)
|
||||
(let ([iattr (hash-ref ht name #f)])
|
||||
(unless iattr
|
||||
(wrong-syntax #f "required attribute is not defined: ~s" name))
|
||||
(unless (= (attr-depth iattr) depth)
|
||||
(wrong-syntax (attr-name iattr)
|
||||
"attribute has wrong depth (expected ~s, found ~s)"
|
||||
depth (attr-depth iattr)))
|
||||
(cons (make attr (attr-name iattr)
|
||||
(attr-depth iattr)
|
||||
(intersect-sattrs inner (attr-inner iattr)))
|
||||
(loop rest)))]))))
|
||||
|
||||
;; restrict-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr)
|
||||
;; Preserves order of iattrs
|
||||
(define (restrict-iattrs relsattrs iattrs remap)
|
||||
(match iattrs
|
||||
['() null]
|
||||
[(cons (struct attr (name depth inner)) rest)
|
||||
(let ([sattr (lookup-sattr (remapenv-lookup remap name) relsattrs)])
|
||||
(if (and sattr (= depth (attr-depth sattr)))
|
||||
(cons (make attr name depth
|
||||
(intersect-sattrs inner (attr-inner sattr)))
|
||||
(restrict-iattrs relsattrs (cdr iattrs) remap))
|
||||
(restrict-iattrs relsattrs (cdr iattrs) remap)))]))
|
||||
|
||||
;; flatten-sattrs : (listof SAttr) num symbol -> (listof SAttr)
|
||||
(define (flatten-sattrs sattrs [depth-delta 0] [prefix #f])
|
||||
(match sattrs
|
||||
['()
|
||||
null]
|
||||
[(cons (struct attr (name depth nested)) rest)
|
||||
(let ([prefixed-name
|
||||
(if prefix
|
||||
(format-symbol "~a.~a" prefix name)
|
||||
name)])
|
||||
(append (list (make attr prefixed-name
|
||||
(+ depth-delta depth)
|
||||
null))
|
||||
(flatten-sattrs nested (+ depth depth-delta) prefixed-name)
|
||||
(flatten-sattrs rest depth-delta prefix)))]))
|
||||
|
||||
;; intersect-sattrs : (listof SAttr) (listof SAttr) -> (listof SAttr)
|
||||
;; Preserves order of first list of attrs.
|
||||
(define (intersect-sattrs as bs)
|
||||
(match as
|
||||
['() null]
|
||||
[(cons (struct attr (name depth inner)) rest)
|
||||
(let ([b (lookup-sattr name bs)])
|
||||
(if (and b (= depth (attr-depth b)))
|
||||
(cons (make attr name depth (intersect-sattrs inner (attr-inner b)))
|
||||
(intersect-sattrs (cdr as) bs))
|
||||
(intersect-sattrs (cdr as) bs)))]))
|
||||
|
||||
;; flatten-attrs* : (listof attr) num symbol stx -> (listof attr)
|
||||
(define (flatten-attrs* attrs [depth-delta 0] [prefix #f] [ctx #f])
|
||||
(match attrs
|
||||
['()
|
||||
null]
|
||||
[(cons (struct attr (name depth nested)) rest)
|
||||
(let ([prefixed-name
|
||||
(if prefix
|
||||
(format-symbol "~a.~a" prefix name)
|
||||
(syntax-e name))]
|
||||
[ctx (or ctx name)])
|
||||
(append (list (make attr (if ctx (datum->syntax ctx prefixed-name) name)
|
||||
(+ depth-delta depth)
|
||||
null))
|
||||
(flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx)
|
||||
(flatten-attrs* rest depth-delta prefix ctx)))]))
|
||||
|
||||
;; append-attrs : (listof (listof IAttr)) -> (listof IAttr)
|
||||
(define (append-attrs attrss)
|
||||
(let* ([all (apply append attrss)]
|
||||
[names (map attr-name all)]
|
||||
[dup (check-duplicate-identifier names)])
|
||||
(when dup
|
||||
(wrong-syntax dup "duplicate pattern variable"))
|
||||
all))
|
||||
|
||||
(define (lookup-sattr name sattrs)
|
||||
(cond [(null? sattrs) #f]
|
||||
[(eq? name (attr-name (car sattrs))) (car sattrs)]
|
||||
[else (lookup-sattr name (cdr sattrs))]))
|
||||
|
||||
(define (lookup-iattr name iattrs)
|
||||
(cond [(null? iattrs) #f]
|
||||
[(bound-identifier=? name (attr-name (car iattrs))) (car iattrs)]
|
||||
[else (lookup-iattr name (cdr iattrs))]))
|
||||
|
|
@ -1,462 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require (for-template scheme/base)
|
||||
(for-template "runtime.ss")
|
||||
scheme/contract
|
||||
scheme/match
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
"../util.ss"
|
||||
"rep-data.ss"
|
||||
"codegen-data.ss")
|
||||
|
||||
(provide/contract
|
||||
[parse-whole-pattern
|
||||
(-> syntax? DeclEnv/c
|
||||
pattern?)]
|
||||
[parse-pattern-directives
|
||||
(->* [stx-list?]
|
||||
[#:sc? boolean? #:literals (listof (list/c identifier? identifier?))]
|
||||
(values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))]
|
||||
[parse-rhs
|
||||
(-> syntax? boolean? syntax?
|
||||
rhs?)]
|
||||
[check-literals-list
|
||||
(-> syntax?
|
||||
(listof (list/c identifier? identifier?)))]
|
||||
[pairK kind?]
|
||||
[vectorK kind?]
|
||||
[boxK kind?])
|
||||
|
||||
(define (atomic-datum? stx)
|
||||
(let ([datum (syntax-e stx)])
|
||||
(or (null? datum)
|
||||
(boolean? datum)
|
||||
(string? datum)
|
||||
(number? datum)
|
||||
(keyword? datum))))
|
||||
|
||||
(define (wildcard? stx)
|
||||
(and (identifier? stx)
|
||||
(or (free-identifier=? stx (quote-syntax _)))))
|
||||
|
||||
(define (epsilon? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? stx (quote-syntax ||))))
|
||||
|
||||
(define (dots? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? stx (quote-syntax ...))))
|
||||
|
||||
(define (gdots? stx)
|
||||
(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
|
||||
;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
|
||||
;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
|
||||
(define (parse-rhs stx allow-unbound? ctx)
|
||||
(define-values (chunks rest)
|
||||
(chunk-kw-seq stx rhs-directive-table #:context ctx))
|
||||
(define lits0 (assq '#:literals chunks))
|
||||
(define desc0 (assq '#:description chunks))
|
||||
(define trans0 (assq '#:transparent chunks))
|
||||
(define attrs0 (assq '#:attributes chunks))
|
||||
(define literals (if lits0 (caddr lits0) null))
|
||||
(define description (and desc0 (caddr desc0)))
|
||||
(define transparent? (and trans0 #t))
|
||||
(define attributes (and attrs0 (caddr attrs0)))
|
||||
|
||||
(define (parse-rhs*-patterns rest)
|
||||
(define (gather-patterns stx)
|
||||
(syntax-case stx (pattern)
|
||||
[((pattern . _) . rest)
|
||||
(cons (parse-rhs-pattern (stx-car stx) allow-unbound? literals)
|
||||
(gather-patterns #'rest))]
|
||||
[()
|
||||
null]))
|
||||
(define patterns (gather-patterns rest))
|
||||
(when (null? patterns)
|
||||
(wrong-syntax ctx "expected at least one variant"))
|
||||
(let ([sattrs
|
||||
(or attributes
|
||||
(intersect-attrss (map rhs:pattern-attrs patterns) ctx))])
|
||||
(make rhs:union stx sattrs
|
||||
transparent?
|
||||
description
|
||||
patterns)))
|
||||
|
||||
(parse-rhs*-patterns rest))
|
||||
|
||||
;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS
|
||||
(define (parse-rhs-pattern stx allow-unbound? literals)
|
||||
(syntax-case stx (pattern)
|
||||
[(pattern p . rest)
|
||||
(parameterize ((allow-unbound-stxclasses allow-unbound?))
|
||||
(let-values ([(rest decls remap clauses)
|
||||
(parse-pattern-directives #'rest
|
||||
#:literals literals
|
||||
#:sc? #t)])
|
||||
(unless (stx-null? rest)
|
||||
(wrong-syntax (if (pair? rest) (car rest) rest)
|
||||
"unexpected terms after pattern directives"))
|
||||
(let* ([pattern (parse-whole-pattern #'p decls)]
|
||||
[with-patterns
|
||||
(for/list ([c clauses] #:when (clause:with? c))
|
||||
(clause:with-pattern c))]
|
||||
[attrs (append-attrs
|
||||
(cons (pattern-attrs pattern)
|
||||
(map pattern-attrs with-patterns)))]
|
||||
[sattrs (iattrs->sattrs attrs remap)])
|
||||
(make rhs:pattern stx sattrs pattern decls remap clauses))))]))
|
||||
|
||||
;; parse-whole-pattern : stx DeclEnv -> Pattern
|
||||
(define (parse-whole-pattern stx decls)
|
||||
(define pattern (parse-pattern stx decls 0))
|
||||
(define pvars (map attr-name (pattern-attrs pattern)))
|
||||
(define excess-domain (declenv-domain-difference decls pvars))
|
||||
(when (pair? excess-domain)
|
||||
(wrong-syntax #f "declared pattern variables do not appear in pattern"
|
||||
#:extra excess-domain))
|
||||
pattern)
|
||||
|
||||
;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
|
||||
(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)
|
||||
[(list 'literal internal-id literal-id)
|
||||
(make pat:literal stx null depth literal-id)]
|
||||
[(list 'stxclass declared-id scname args)
|
||||
(let* ([sc (get-stxclass/check-arg-count scname (length args))]
|
||||
[attrs (id-pattern-attrs #'id sc depth)])
|
||||
(make pat:id stx attrs depth #'id sc args))]
|
||||
[#f
|
||||
(let-values ([(name sc args) (split-id/get-stxclass #'id decls)])
|
||||
(let ([attrs (id-pattern-attrs name sc depth)]
|
||||
[name (if (epsilon? name) #f name)])
|
||||
(make pat:id stx attrs depth name sc args)))])]
|
||||
[datum
|
||||
(atomic-datum? #'datum)
|
||||
(make pat:datum stx null depth (syntax->datum #'datum))]
|
||||
[(~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)
|
||||
#:allow-orseq-pattern? #t)]
|
||||
[heads
|
||||
(if (pat:orseq? headp)
|
||||
(pat:orseq-heads headp)
|
||||
(list (pattern->head headp)))]
|
||||
[tail (parse-pattern #'tail decls depth)]
|
||||
[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)])
|
||||
(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]
|
||||
[(and (epsilon? name) sc)
|
||||
(for/list ([a (sc-attrs sc)])
|
||||
(make attr (datum->syntax name (attr-name a))
|
||||
(+ depth (attr-depth a))
|
||||
(attr-inner a)))]
|
||||
[sc
|
||||
(list (make attr name depth (sc-attrs sc)))]
|
||||
[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 (ostx iattrs depth))
|
||||
(make head ostx iattrs depth (list p) #f #f #t)]))
|
||||
|
||||
(define (parse-heads stx decls enclosing-depth)
|
||||
(syntax-case stx ()
|
||||
[({} . more)
|
||||
(wrong-syntax (stx-car stx)
|
||||
"empty head sequence not allowed")]
|
||||
[({p ...} . more)
|
||||
(let()
|
||||
(define-values (chunks rest)
|
||||
(chunk-kw-seq/no-dups #'more head-directive-table))
|
||||
(define-values (chunks2 rest2)
|
||||
(chunk-kw-seq rest head-directive-table2))
|
||||
;; FIXME FIXME: handle chunks2 !!!!
|
||||
(cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
|
||||
(parse-heads rest2 decls enclosing-depth)))]
|
||||
[()
|
||||
null]
|
||||
[_
|
||||
(wrong-syntax (cond [(pair? stx) (car stx)]
|
||||
[(syntax? stx) stx]
|
||||
[else #f])
|
||||
"expected sequence of patterns or sequence directive")]))
|
||||
|
||||
(define (parse-head/chunks pstx decls depth chunks)
|
||||
(let* ([min-row (assq '#:min chunks)]
|
||||
[max-row (assq '#:max chunks)]
|
||||
[opt-row (assq '#:opt chunks)]
|
||||
[mand-row (assq '#:mand chunks)]
|
||||
[min-stx (and min-row (caddr min-row))]
|
||||
[max-stx (and max-row (caddr max-row))]
|
||||
[min (if min-stx (syntax-e min-stx) #f)]
|
||||
[max (if max-stx (syntax-e max-stx) #f)])
|
||||
(unless (<= (or min 0) (or max +inf.0))
|
||||
(wrong-syntax (or min-stx max-stx)
|
||||
"min-constraint must be less than max-constraint"))
|
||||
(when (and opt-row mand-row)
|
||||
(wrong-syntax (cadr opt-row)
|
||||
"opt and mand directives are incompatible"))
|
||||
(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"))
|
||||
(parse-head/options pstx
|
||||
decls
|
||||
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)))))
|
||||
|
||||
(define (parse-head/options pstx decls depth min max as-list?)
|
||||
(let* ([effective-depth (if as-list? depth (sub1 depth))]
|
||||
[heads
|
||||
(for/list ([p (stx->list pstx)])
|
||||
(parse-pattern p decls effective-depth))]
|
||||
[heads-attrs
|
||||
(append-attrs (map pattern-attrs heads))])
|
||||
(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)
|
||||
(define (parse-pattern-directives stx
|
||||
#:sc? [sc? #f]
|
||||
#:literals [literals null])
|
||||
(define remap (new-remapenv))
|
||||
(define-values (chunks rest)
|
||||
(chunk-kw-seq stx pattern-directive-table))
|
||||
(define (process-renames chunks)
|
||||
(match chunks
|
||||
[(cons (list '#:rename rename-stx internal-id sym-id) rest)
|
||||
(unless sc?
|
||||
(wrong-syntax rename-stx
|
||||
"only allowed within syntax-class definition"))
|
||||
(remapenv-put remap internal-id (syntax-e sym-id))
|
||||
(process-renames rest)]
|
||||
[(cons decl rest)
|
||||
(cons decl (process-renames rest))]
|
||||
['()
|
||||
'()]))
|
||||
(define chunks2 (process-renames chunks))
|
||||
(define-values (decls chunks3)
|
||||
(grab-decls chunks2 literals))
|
||||
(values rest decls remap
|
||||
(parse-pattern-sides chunks3 literals)))
|
||||
|
||||
;; grab-decls : (listof chunk) (listof id+id)
|
||||
;; -> (values DeclEnv/c (listof chunk))
|
||||
(define (grab-decls chunks literals)
|
||||
(define decls (new-declenv literals))
|
||||
(define (loop chunks)
|
||||
(match chunks
|
||||
[(cons (cons '#:declare decl-stx) rest)
|
||||
(add-decl decl-stx)
|
||||
(loop rest)]
|
||||
[else chunks]))
|
||||
(define (add-decl stx)
|
||||
(syntax-case stx ()
|
||||
[(#:declare name sc)
|
||||
(identifier? #'sc)
|
||||
(add-decl #'(#:declare name (sc)))]
|
||||
[(#:declare name (sc expr ...))
|
||||
(declenv-put-stxclass decls #'name #'sc (syntax->list #'(expr ...)))]
|
||||
[(#:declare name bad-sc)
|
||||
(wrong-syntax #'bad-sc
|
||||
"expected syntax class name (possibly with parameters)")]))
|
||||
(let ([rest (loop chunks)])
|
||||
(values decls rest)))
|
||||
|
||||
;; parse-pattern-sides : (listof chunk) (listof id+id)
|
||||
;; -> (listof SideClause/c)
|
||||
(define (parse-pattern-sides chunks literals)
|
||||
(match chunks
|
||||
[(cons (list '#:declare declare-stx _ _) rest)
|
||||
(wrong-syntax declare-stx
|
||||
"#:declare can only follow pattern or #:with clause")]
|
||||
[(cons (list '#:when when-stx expr) rest)
|
||||
(cons (make clause:when expr)
|
||||
(parse-pattern-sides rest literals))]
|
||||
[(cons (list '#:with with-stx pattern expr) rest)
|
||||
(let-values ([(decls rest) (grab-decls rest literals)])
|
||||
(cons (make clause:with (parse-whole-pattern pattern decls) expr)
|
||||
(parse-pattern-sides rest literals)))]
|
||||
['()
|
||||
'()]))
|
||||
|
||||
|
||||
;; 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)
|
||||
(wrong-syntax stx "expected list of attribute declarations"))
|
||||
(let ([iattrs (map check-attr-arity (stx->list stx))])
|
||||
(iattrs->sattrs (append-attrs (map list iattrs)) trivial-remap)))
|
||||
|
||||
;; check-attr-arity : stx -> IAttr
|
||||
(define (check-attr-arity stx)
|
||||
(syntax-case stx ()
|
||||
[attr
|
||||
(identifier? #'attr)
|
||||
(make-attr #'attr 0 null)]
|
||||
[(attr depth)
|
||||
(check-attr-arity #'(attr depth ()))]
|
||||
[(attr depth inners)
|
||||
(begin (unless (identifier? #'attr)
|
||||
(wrong-syntax #'attr "expected attribute name"))
|
||||
(unless (exact-nonnegative-integer? (syntax-e #'depth))
|
||||
(wrong-syntax #'depth "expected depth (nonnegative integer)"))
|
||||
(make-attr #'attr (syntax-e #'depth) (check-attr-arity-list #'inners)))]
|
||||
[_
|
||||
(wrong-syntax stx "expected attribute arity declaration")]))
|
||||
|
||||
|
||||
;; check-literals-list : syntax -> (listof id)
|
||||
(define (check-literals-list stx)
|
||||
(unless (stx-list? stx)
|
||||
(wrong-syntax stx "expected literals list"))
|
||||
(let ([lits (map check-literal-entry (stx->list stx))])
|
||||
(let ([dup (check-duplicate-identifier (map car lits))])
|
||||
(when dup (wrong-syntax dup "duplicate literal identifier")))
|
||||
lits))
|
||||
|
||||
(define (check-literal-entry stx)
|
||||
(syntax-case stx ()
|
||||
[(internal external)
|
||||
(and (identifier? #'internal) (identifier? #'external))
|
||||
(list #'internal #'external)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(list #'id #'id)]
|
||||
[_
|
||||
(wrong-syntax stx
|
||||
"expected literal (identifier or pair of identifiers)")]))
|
||||
|
||||
;; rhs-directive-table
|
||||
(define rhs-directive-table
|
||||
(list (list '#:literals check-literals-list)
|
||||
(list '#:description values)
|
||||
(list '#:transparent)
|
||||
(list '#:attributes check-attr-arity-list)))
|
||||
|
||||
;; pattern-directive-table
|
||||
(define pattern-directive-table
|
||||
(list (list '#:declare check-id values)
|
||||
(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)))
|
||||
|
||||
(define head-directive-table
|
||||
(list (list '#:min check-nat/f)
|
||||
(list '#:max check-nat/f)
|
||||
(list '#:opt)
|
||||
(list '#:mand)))
|
||||
|
||||
(define head-directive-table2
|
||||
(list (list '#:with values values)
|
||||
(list '#:declare check-id values)))
|
||||
|
|
@ -1,310 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
scheme/match
|
||||
scheme/stxparam
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax syntax/stx)
|
||||
(for-syntax scheme/private/sc)
|
||||
(for-syntax "rep-data.ss")
|
||||
(for-syntax "../util/error.ss"))
|
||||
(provide pattern
|
||||
~and
|
||||
~or
|
||||
...*
|
||||
|
||||
with-enclosing-fail
|
||||
enclosing-fail
|
||||
|
||||
ok?
|
||||
(struct-out failed)
|
||||
|
||||
current-expression
|
||||
current-macro-name
|
||||
|
||||
this-syntax
|
||||
|
||||
(for-syntax expectation-of-stxclass
|
||||
expectation-of-constants
|
||||
expectation-of/message)
|
||||
|
||||
try
|
||||
expectation/c
|
||||
expectation-of-null?
|
||||
expectation->string
|
||||
|
||||
let-attributes
|
||||
attribute)
|
||||
|
||||
;; Keywords
|
||||
|
||||
(define-syntax-rule (define-keyword name)
|
||||
(define-syntax name
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword used out of context" stx))))
|
||||
|
||||
(define-keyword pattern)
|
||||
(define-keyword ~and)
|
||||
(define-keyword ~or)
|
||||
(define-keyword ...*)
|
||||
|
||||
;; Parameters & Syntax Parameters
|
||||
|
||||
(define-syntax-parameter enclosing-fail
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "used out of context: not parsing pattern")))
|
||||
|
||||
(define-syntax-rule (with-enclosing-fail failvar expr)
|
||||
(syntax-parameterize ((enclosing-fail
|
||||
(make-rename-transformer (quote-syntax failvar))))
|
||||
expr))
|
||||
|
||||
(define-syntax-parameter pattern-source
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "used out of context: not parsing pattern")))
|
||||
|
||||
;; this-syntax
|
||||
;; Bound to syntax being matched inside of syntax class
|
||||
(define-syntax-parameter this-syntax
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "used out of context: not within a syntax class")))
|
||||
|
||||
(define current-expression (make-parameter #f))
|
||||
|
||||
(define (current-macro-name)
|
||||
(let ([expr (current-expression)])
|
||||
(and expr
|
||||
(syntax-case expr (set!)
|
||||
[(set! kw . _)
|
||||
#'kw]
|
||||
[(kw . _)
|
||||
(identifier? #'kw)
|
||||
#'kw]
|
||||
[kw
|
||||
(identifier? #'kw)
|
||||
#'kw]
|
||||
[_ #f]))))
|
||||
|
||||
;; Runtime: syntax-class parser results
|
||||
|
||||
;; A PatternParseResult is one of
|
||||
;; - (listof value)
|
||||
;; - (make-failed stx expectation/c frontier/#f stx)
|
||||
|
||||
(define (ok? x) (or (pair? x) (null? x)))
|
||||
(define-struct failed (stx expectation frontier frontier-stx)
|
||||
#:transparent)
|
||||
|
||||
;; Runtime: Dynamic Frontier Contexts (DFCs)
|
||||
|
||||
;; A DFC is a list of numbers.
|
||||
|
||||
;; compare-dfcs : DFC DFC -> (one-of '< '= '>)
|
||||
;; Note A>B means A is "further along" than B.
|
||||
(define (compare-dfcs a b)
|
||||
(cond [(and (null? a) (null? b))
|
||||
'=]
|
||||
[(and (pair? a) (null? b))
|
||||
'>]
|
||||
[(and (null? a) (pair? b))
|
||||
'<]
|
||||
[(and (pair? a) (pair? b))
|
||||
(cond [(> (car a) (car b)) '>]
|
||||
[(< (car a) (car b)) '<]
|
||||
[else (compare-dfcs (cdr a) (cdr b))])]))
|
||||
|
||||
;; Runtime: parsing failures/expectations
|
||||
|
||||
;; An Expectation is
|
||||
;; (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)
|
||||
#:transparent)
|
||||
|
||||
(define expectation/c (or/c expc?))
|
||||
|
||||
(define (make-stxclass-expc scdyn)
|
||||
(make-expc (list scdyn) null null null))
|
||||
|
||||
(begin-for-syntax
|
||||
(define certify (syntax-local-certifier))
|
||||
(define (expectation-of-stxclass stxclass args result-var)
|
||||
(unless (sc? stxclass)
|
||||
(raise-type-error 'expectation-of-stxclass "stxclass" stxclass))
|
||||
(with-syntax ([name (sc-name stxclass)]
|
||||
[desc-var (sc-description stxclass)]
|
||||
[(arg ...) args])
|
||||
(certify #`(begin
|
||||
(make-stxclass-expc
|
||||
(make-scdyn 'name (desc-var arg ...)
|
||||
(if (failed? #,result-var) #,result-var #f)))))))
|
||||
|
||||
(define (expectation-of-constants pairs? data literals description)
|
||||
(with-syntax ([(datum ...) data]
|
||||
[(literal ...) literals]
|
||||
[pairs? pairs?]
|
||||
[description
|
||||
(if pairs?
|
||||
(list (or description #t))
|
||||
null)])
|
||||
(certify
|
||||
#'(make-expc null 'description (list 'datum ...)
|
||||
(list (quote-syntax literal) ...)))))
|
||||
|
||||
(define (expectation-of/message msg)
|
||||
(with-syntax ([msg msg])
|
||||
(certify
|
||||
#'(make-expc '() '() '((msg)) '())))))
|
||||
|
||||
(define-syntax (try stx)
|
||||
(syntax-case stx ()
|
||||
[(try failvar (expr ...) previous-fail)
|
||||
(when (stx-null? #'(expr ...))
|
||||
(raise-syntax-error #f "must have at least one attempt" stx))
|
||||
#'(try* (list (lambda (failvar) expr) ...) previous-fail)]))
|
||||
|
||||
;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result
|
||||
;; FailFunction = (stx expectation/c ?? DynamicFrontier) -> Result
|
||||
(define (try* attempts fail)
|
||||
(let ([first-attempt (car attempts)]
|
||||
[rest-attempts (cdr attempts)])
|
||||
(if (null? rest-attempts)
|
||||
(first-attempt fail)
|
||||
(let ([next-fail
|
||||
(lambda (x1 p1 f1 fs1)
|
||||
(let ([combining-fail
|
||||
(lambda (x2 p2 f2 fs2)
|
||||
(choose-error fail x1 x2 p1 p2 f1 f2 fs1 fs2))])
|
||||
(try* rest-attempts combining-fail)))])
|
||||
(first-attempt next-fail)))))
|
||||
|
||||
(define (choose-error k x1 x2 p1 p2 frontier1 frontier2 fs1 fs2)
|
||||
(case (compare-dfcs frontier1 frontier2)
|
||||
[(>) (k x1 p1 frontier1 fs1)]
|
||||
[(<) (k x2 p2 frontier2 fs2)]
|
||||
[(=) (k x1 (merge-expectations p1 p2) frontier1 fs1)]))
|
||||
|
||||
(define (merge-expectations e1 e2)
|
||||
(make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
|
||||
(union (expc-compound e1) (expc-compound e2))
|
||||
(union (expc-data e1) (expc-data e2))
|
||||
(union (expc-literals e1) (expc-literals e2))))
|
||||
|
||||
(define (union a b)
|
||||
(append a (for/list ([x b] #:when (not (member x a))) x)))
|
||||
|
||||
(define (expectation-of-null? e)
|
||||
(match e
|
||||
[(struct expc (scs compound data literals))
|
||||
(and (null? scs)
|
||||
(null? compound)
|
||||
(null? literals)
|
||||
(and (pair? data) (null? (cdr data)))
|
||||
(equal? (car data) '()))]
|
||||
[#f #f]))
|
||||
|
||||
(define (expectation->string e)
|
||||
(match e
|
||||
[(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)))
|
||||
|
||||
(define (string-of-stxclass scdyn)
|
||||
(define expected (or (scdyn-desc scdyn) (scdyn-name scdyn)))
|
||||
(if (scdyn-failure scdyn)
|
||||
(let ([inner (expectation->string (failed-expectation (scdyn-failure scdyn)))])
|
||||
(or inner (format "~a" expected)))
|
||||
(format "~a" expected)))
|
||||
|
||||
(define (string-of-literals literals0)
|
||||
(define literals
|
||||
(sort (map syntax-e literals0)
|
||||
string<?
|
||||
#:key symbol->string
|
||||
#:cache-keys? #t))
|
||||
(case (length literals)
|
||||
[(1) (format "the literal identifier ~s" (car literals))]
|
||||
[else (format "one of the following literal identifiers: ~a"
|
||||
(comma-list (map ->string literals)))]))
|
||||
|
||||
(define (string-of-data data)
|
||||
(case (length data)
|
||||
[(1) (format "the literal ~s" (car data))]
|
||||
[else (format "one of the following literals: ~a"
|
||||
(comma-list (map ->string data)))]))
|
||||
|
||||
(define (->string x) (format "~s" x))
|
||||
|
||||
(define string-of-pairs?
|
||||
"structured syntax")
|
||||
|
||||
(define (comma-list items)
|
||||
(join-sep items "," "or"))
|
||||
|
||||
(define (join-sep items sep0 ult0)
|
||||
(define sep (string-append sep0 " "))
|
||||
(define ult (string-append ult0 " "))
|
||||
(define (loop items)
|
||||
(cond [(null? items)
|
||||
null]
|
||||
[(null? (cdr items))
|
||||
(list sep ult (car items))]
|
||||
[else
|
||||
(list* sep (car items) (loop (cdr items)))]))
|
||||
(case (length items)
|
||||
[(2) (format "~a ~a~a" (car items) ult (cadr items))]
|
||||
[else (let ([strings (list* (car items) (loop (cdr items)))])
|
||||
(apply string-append strings))]))
|
||||
|
||||
|
||||
;; Attributes
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct attribute-mapping (var)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure
|
||||
(lambda (self stx)
|
||||
#`(#%expression #,(attribute-mapping-var self)))))
|
||||
|
||||
(define-syntax (let-attributes stx)
|
||||
(syntax-case stx ()
|
||||
[(let-attributes ([attr depth value] ...) . body)
|
||||
(with-syntax ([(vtmp ...) (generate-temporaries #'(attr ...))]
|
||||
[(stmp ...) (generate-temporaries #'(attr ...))])
|
||||
#'(letrec-syntaxes+values
|
||||
([(stmp) (make-attribute-mapping (quote-syntax vtmp))]
|
||||
...)
|
||||
([(vtmp) value] ...)
|
||||
(letrec-syntaxes+values
|
||||
([(attr) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
|
||||
()
|
||||
. body)))]))
|
||||
|
||||
(define-syntax (attribute stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(attribute name)
|
||||
(identifier? #'name)
|
||||
(let ([mapping (syntax-local-value #'name (lambda () #f))])
|
||||
(unless (syntax-pattern-variable? mapping)
|
||||
(wrong-syntax #'name "not bound as a pattern variable"))
|
||||
(let ([var (syntax-mapping-valvar mapping)])
|
||||
(let ([attr (syntax-local-value var (lambda () #f))])
|
||||
(unless (attribute-mapping? attr)
|
||||
(wrong-syntax #'name "not bound as an attribute"))
|
||||
(syntax-property (attribute-mapping-var attr)
|
||||
'disappeared-use
|
||||
#'name))))])))
|
||||
|
|
@ -1,242 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
scheme/match
|
||||
scheme/private/sc
|
||||
"rep-data.ss"
|
||||
"rep.ss"
|
||||
"codegen.ss"
|
||||
"../util.ss")
|
||||
scheme/list
|
||||
scheme/match
|
||||
syntax/stx
|
||||
"runtime.ss")
|
||||
|
||||
(provide define-syntax-class
|
||||
parse-sc
|
||||
attrs-of
|
||||
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
with-patterns
|
||||
|
||||
pattern
|
||||
~and
|
||||
~or
|
||||
...*
|
||||
|
||||
attribute
|
||||
|
||||
(struct-out failed)
|
||||
|
||||
this-syntax
|
||||
|
||||
current-expression
|
||||
current-macro-name)
|
||||
|
||||
;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
|
||||
;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
|
||||
|
||||
;; A SCDirective is one of
|
||||
;; #:description String
|
||||
;; #:transparent
|
||||
|
||||
;; A SyntaxClassRHS is
|
||||
;; (pattern Pattern PatternDirective ...)
|
||||
|
||||
;; A Pattern is one of
|
||||
;; name:syntaxclass
|
||||
;; (Pattern . Pattern)
|
||||
;; (Pattern ... . Pattern)
|
||||
;; (((Pattern*) HeadDirective* *) ...* . Pattern)
|
||||
;; datum, including ()
|
||||
|
||||
;; A PatternDirective is one of
|
||||
;; #:declare name SyntaxClassName
|
||||
;; #:declare name (SyntaxClassName expr ...)
|
||||
;; #:rename internal-id external-id
|
||||
;; #:with pattern expr
|
||||
;; #:with clauses are let*-scoped
|
||||
;; #:when expr
|
||||
|
||||
;; A HeadDirective is one of
|
||||
;; #:min nat/#f
|
||||
;; #:max nat/#f
|
||||
;; #:opt
|
||||
;; #:mand
|
||||
;; -- For optional heads only:
|
||||
;; #:occurs id
|
||||
;; 'id' is bound to #t is the pattern occurs, #f otherwise
|
||||
;; #:default form
|
||||
;; Preceding head must have a single pvar
|
||||
;; If the head is not present, the pvar is bound to 'form' instead
|
||||
|
||||
(define-syntax (define-syntax-class stx)
|
||||
(syntax-case stx ()
|
||||
[(define-syntax-class (name arg ...) . rhss)
|
||||
#`(begin (define-syntax name
|
||||
(let ([the-rhs
|
||||
(parameterize ((current-syntax-context
|
||||
(quote-syntax #,stx)))
|
||||
(parse-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))])
|
||||
(make sc 'name
|
||||
'(arg ...)
|
||||
(rhs-attrs the-rhs)
|
||||
((syntax-local-certifier) #'parser)
|
||||
#'description)))
|
||||
(define-values (parser description)
|
||||
(rhs->parser+description name rhss (arg ...) #,stx)))]
|
||||
[(define-syntax-class name . rhss)
|
||||
(syntax/loc stx
|
||||
(define-syntax-class (name) . rhss))]))
|
||||
|
||||
(define-syntax (rhs->parser+description stx)
|
||||
(syntax-case stx ()
|
||||
[(rhs->parser+description name rhss (arg ...) ctx)
|
||||
(with-disappeared-uses
|
||||
(parameterize ((current-syntax-context #'ctx))
|
||||
(let ([rhs (parse-rhs #'rhss #f #'ctx)]
|
||||
[sc (syntax-local-value #'name)])
|
||||
#`(values #,(parse:rhs rhs
|
||||
(sc-attrs sc)
|
||||
(syntax->list #'(arg ...)))
|
||||
(lambda (arg ...)
|
||||
#,(or (rhs-description rhs)
|
||||
#'(symbol->string 'name)))))))]))
|
||||
|
||||
(define-syntax (parse-sc stx)
|
||||
(syntax-case stx ()
|
||||
[(parse s x arg ...)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let* ([arg-count (length (syntax->list #'(arg ...)))]
|
||||
[stxclass (get-stxclass/check-arg-count #'s arg-count)]
|
||||
[attrs (flatten-sattrs (sc-attrs stxclass))])
|
||||
(with-syntax ([parser (sc-parser-name stxclass)]
|
||||
[(name ...) (map attr-name attrs)]
|
||||
[(depth ...) (map attr-depth attrs)])
|
||||
#'(let ([raw (parser x arg ...)])
|
||||
(if (ok? raw)
|
||||
(map vector '(name ...) '(depth ...) (cdr raw))
|
||||
raw)))))]))
|
||||
|
||||
(define-syntax (attrs-of stx)
|
||||
(syntax-case stx ()
|
||||
[(attrs-of s)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let ([attrs (flatten-sattrs (sc-attrs (get-stxclass #'s)))])
|
||||
(with-syntax ([(a ...) (map attr-name attrs)]
|
||||
[(depth ...) (map attr-depth attrs)])
|
||||
#'(quote ((a depth) ...)))))]))
|
||||
|
||||
(define-syntax (debug-rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(debug-rhs rhs)
|
||||
(let ([rhs (parse-rhs #'rhs #f stx)])
|
||||
#`(quote #,rhs))]))
|
||||
|
||||
(define-syntax-rule (syntax-parse stx-expr . clauses)
|
||||
(let ([x stx-expr])
|
||||
(syntax-parse* syntax-parse x . clauses)))
|
||||
|
||||
(define-syntax-rule (syntax-parser . clauses)
|
||||
(lambda (x) (syntax-parse* syntax-parser x . clauses)))
|
||||
|
||||
(define-syntax (syntax-parse* stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parse report-as expr . clauses)
|
||||
(with-disappeared-uses
|
||||
(parameterize ((current-syntax-context
|
||||
(syntax-property stx
|
||||
'report-errors-as
|
||||
(syntax-e #'report-as))))
|
||||
#`(let ([x expr])
|
||||
(let ([fail (syntax-patterns-fail x)])
|
||||
(parameterize ((current-expression (or (current-expression) x)))
|
||||
#,(parse:clauses #'clauses #'x #'fail))))))]))
|
||||
|
||||
(define-syntax with-patterns
|
||||
(syntax-rules ()
|
||||
[(with-patterns () . b)
|
||||
(let () . b)]
|
||||
[(with-patterns ([p x] . more) . b)
|
||||
(syntax-parse x [p (with-patterns more . b)])]))
|
||||
|
||||
(define ((syntax-patterns-fail stx0) x expected frontier frontier-stx)
|
||||
(define (err msg stx)
|
||||
(raise (make-exn:fail:syntax
|
||||
(if msg
|
||||
(string->immutable-string (string-append "bad syntax: " msg))
|
||||
(string->immutable-string "bad syntax"))
|
||||
(current-continuation-marks)
|
||||
(list stx))))
|
||||
(define n (last frontier))
|
||||
(cond [(expectation-of-null? expected)
|
||||
;; FIXME: "extra term(s) after <pattern>"
|
||||
(syntax-case x ()
|
||||
[(one)
|
||||
(err "unexpected term" #'one)]
|
||||
[(first . more)
|
||||
(err "unexpected terms starting here" #'first)]
|
||||
[_
|
||||
(err "unexpected term" x)])]
|
||||
[(and expected (expectation->string expected))
|
||||
=>
|
||||
(lambda (msg)
|
||||
(err (format "expected ~a~a"
|
||||
msg
|
||||
(cond [(zero? n) ""]
|
||||
[(= n +inf.0) " after matching main pattern"]
|
||||
[else (format " after ~s ~a"
|
||||
n
|
||||
(if (= 1 n) "form" "forms"))]))
|
||||
frontier-stx))]
|
||||
[else
|
||||
(err #f stx0)]))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
(begin-for-syntax
|
||||
(define (check-attrlist stx)
|
||||
(syntax-case stx ()
|
||||
[(form ...)
|
||||
(let ([names (for/list ([s (syntax->list #'(form ...))])
|
||||
(check-attr s)
|
||||
(stx-car s))])
|
||||
(check-duplicate-identifier names)
|
||||
stx)]
|
||||
[_
|
||||
(raise-syntax-error 'define-syntax-class
|
||||
"expected attribute table" stx)]))
|
||||
(define stxclass-table
|
||||
`((#:description check-string)
|
||||
(#:attributes check-attrlist)))
|
||||
(define (split-rhss rhss stx)
|
||||
(define-values (chunks rest)
|
||||
(chunk-kw-seq/no-dups rhss stxclass-table #:context stx))
|
||||
(define (assq* x alist default)
|
||||
(cond [(assq x alist) => cdr]
|
||||
[else default]))
|
||||
(values (cond [(assq '#:attributes chunks) => caddr]
|
||||
[else null])
|
||||
(cond [(assq '#:description chunks) => caddr]
|
||||
[else #f])
|
||||
rest)))
|
||||
|
||||
(define-syntax (define-syntax-class stx)
|
||||
(syntax-case stx ()
|
||||
[(define-syntax-class (name arg ...) . rhss)
|
||||
(let-values ([(attrs description rhss) (split-rhss #'rhss stx)])
|
||||
#`(begin (define-syntax name
|
||||
(make sc
|
||||
'name
|
||||
'(arg ...)
|
||||
'#,attrs
|
||||
((syntax-local-value) #'parser)
|
||||
'#,description))
|
||||
(define parser
|
||||
(rhs->parser name #,rhss (arg ...) #,stx))))]
|
||||
[(define-syntax-class name . rhss)
|
||||
(syntax/loc stx
|
||||
(define-syntax-class (name) . rhss))]))
|
||||
|#
|
||||
|
||||
|
|
@ -1,103 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scribble/decode
|
||||
(for-label scheme/base
|
||||
scheme/contract
|
||||
stxclass
|
||||
stxclass/util))
|
||||
|
||||
@(define ellipses @scheme[...])
|
||||
@(define (TODO . pre-flow)
|
||||
(make-splice
|
||||
(cons (bold "TODO: ")
|
||||
(decode-content pre-flow))))
|
||||
|
||||
@title{Library syntax classes}
|
||||
@declare-exporting[stxclass]
|
||||
|
||||
@(define-syntax-rule (defstxclass name . pre-flows)
|
||||
(defidform name . pre-flows))
|
||||
|
||||
@(define-syntax-rule (defstxclass* (name arg ...) . pre-flows)
|
||||
(defform (name arg ...) . pre-flows))
|
||||
|
||||
@defstxclass[expr]{
|
||||
|
||||
Matches anything except a keyword literal (to distinguish expressions
|
||||
from the start of a keyword argument sequence). Does not expand or
|
||||
otherwise inspect the term.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defstxclass[identifier]
|
||||
@defstxclass[boolean]
|
||||
@defstxclass[str]
|
||||
@defstxclass[char]
|
||||
@defstxclass[keyword]
|
||||
@defstxclass[number]
|
||||
@defstxclass[integer]
|
||||
@defstxclass[exact-integer]
|
||||
@defstxclass[exact-nonnegative-integer]
|
||||
@defstxclass[exact-positive-integer])]{
|
||||
|
||||
Match syntax satisfying the corresponding predicates.
|
||||
|
||||
}
|
||||
|
||||
@defstxclass[id]{ Alias for @scheme[identifier]. }
|
||||
@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. }
|
||||
|
||||
The following syntax classes mirror parts of the macro API. They may
|
||||
only be used during transformation (when @scheme[syntax-transforming?]
|
||||
returns true). Otherwise they may raise an error.
|
||||
|
||||
@defstxclass[static]{
|
||||
|
||||
Matches identifiers that are bound in the syntactic environment to
|
||||
static information (see @scheme[syntax-local-value]). Attribute
|
||||
@scheme[_value] contains the value the name is bound to.
|
||||
|
||||
}
|
||||
|
||||
@defform[(static-of description predicate)]{
|
||||
|
||||
Refines @scheme[static]: matches identifiers that are bound in the
|
||||
syntactic environment to static information satisfying the given
|
||||
@scheme[predicate]. Attribute @scheme[_value] contains the value the
|
||||
name is bound to. The @scheme[description] argument is used for error
|
||||
reporting.
|
||||
|
||||
}
|
||||
|
||||
@;{
|
||||
@defstxclass[struct-name]{
|
||||
|
||||
Matches identifiers bound to static struct information. Attributes are
|
||||
@scheme[_descriptor], @scheme[_constructor], @scheme[_predicate],
|
||||
@scheme[(_accessor ...)], @scheme[_super], and @scheme[_complete?].
|
||||
|
||||
}
|
||||
}
|
||||
@;{
|
||||
@defstxclass[expr/local-expand]{
|
||||
|
||||
Matches any term and @scheme[local-expand]s it as an expression with
|
||||
an empty stop list. Attribute @scheme[_expanded] is the expanded form.
|
||||
|
||||
}
|
||||
|
||||
@defstxclass[expr/head-local-expand]
|
||||
@defstxclass[block/head-local-expand]
|
||||
@defstxclass[internal-definitions]
|
||||
}
|
||||
|
||||
@;{
|
||||
@defform[(expr/c contract-expr-stx)]{
|
||||
|
||||
Accepts any term and returns as the match that term wrapped in a
|
||||
@scheme[contract] expression enforcing @scheme[contract-expr-stx].
|
||||
|
||||
}
|
||||
}
|
||||
|
|
@ -1,258 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scribble/decode
|
||||
(for-label scheme/base
|
||||
scheme/contract
|
||||
stxclass
|
||||
stxclass/util))
|
||||
|
||||
@(define ellipses @scheme[...])
|
||||
@(define (TODO . pre-flow)
|
||||
(make-splice
|
||||
(cons (bold "TODO: ")
|
||||
(decode-content pre-flow))))
|
||||
|
||||
@title{Parsing Syntax}
|
||||
@declare-exporting[stxclass]
|
||||
|
||||
This section describes @schememodname[stxclass]'s facilities for
|
||||
parsing syntax.
|
||||
|
||||
@defform/subs[(syntax-parse stx-expr maybe-literals clause ...)
|
||||
([maybe-literals code:blank
|
||||
(code:line #:literals (literal ...))]
|
||||
[literal id
|
||||
(internal-id external-id)]
|
||||
[clause (syntax-pattern pattern-directive ... expr)])]{
|
||||
|
||||
Evaluates @scheme[stx-expr], which should produce a syntax object, and
|
||||
matches it against the patterns in order. If some pattern matches, its
|
||||
pattern variables are bound to the corresponding subterms of the
|
||||
syntax object and that clause's side conditions and @scheme[expr] is
|
||||
evaluated. The result is the result of @scheme[expr].
|
||||
|
||||
If the syntax object fails to match any of the patterns (or all
|
||||
matches fail the corresponding clauses' side conditions), a syntax
|
||||
error is raised. The syntax error indicates the first specific subterm
|
||||
for which no pattern matches.
|
||||
|
||||
A literal in the literals list has two components: the identifier used
|
||||
within the pattern to signify the positions to be matched, and the
|
||||
identifier expected to occur in those positions. If the
|
||||
single-identifier form is used, the same identifier is used for both
|
||||
purposes.
|
||||
|
||||
}
|
||||
|
||||
@defform[(syntax-parser maybe-literals clause ...)]{
|
||||
|
||||
Like @scheme[syntax-parse], but produces a matching procedure. The
|
||||
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 (_ ~or ~and)
|
||||
[syntax-pattern
|
||||
pvar-id
|
||||
pvar-id:syntax-class-id
|
||||
literal-id
|
||||
atomic-datum
|
||||
(syntax-pattern . 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]]
|
||||
|
||||
Here are the variants of @scheme[syntax-pattern]:
|
||||
|
||||
@specsubform[pvar-id]{
|
||||
|
||||
Matches anything. The pattern variable is bound to the matched
|
||||
subterm, unless the pattern variable is the wildcard (@scheme[_]), in
|
||||
which case no binding occurs.
|
||||
|
||||
}
|
||||
@specsubform[pvar-id:syntax-class-id]{
|
||||
|
||||
Matches only subterms specified by the @scheme[_syntax-class-id]. The
|
||||
syntax class's attributes are computed for the subterm and bound to
|
||||
the pattern variables formed by prefixing @scheme[_pvar-id.] to the
|
||||
name of the attribute. @scheme[_pvar-id] is typically bound to the
|
||||
matched subterm, but the syntax class can substitute a transformed
|
||||
subterm instead.
|
||||
|
||||
@;{(for example, @scheme[expr/c] wraps the matched
|
||||
subterm in a @scheme[contract] expression).}
|
||||
|
||||
If @scheme[_pvar-id] is @scheme[_], no pattern variables are bound.
|
||||
|
||||
}
|
||||
@specsubform[literal-id]{
|
||||
|
||||
An identifier that appears in the literals list is not a pattern
|
||||
variable; instead, it is a literal that matches any identifier
|
||||
@scheme[free-identifier=?] to it.
|
||||
|
||||
Specifically, if @scheme[literal-id] is the ``internal'' name of an
|
||||
entry in the literals list, then it represents a pattern that matches
|
||||
only identifiers @scheme[free-identifier=?] to the ``external''
|
||||
name. These identifiers are often the same.
|
||||
|
||||
}
|
||||
@specsubform[atomic-datum]{
|
||||
|
||||
The empty list, numbers, strings, booleans, and keywords match as
|
||||
literals.
|
||||
|
||||
}
|
||||
@specsubform[(syntax-pattern . syntax-pattern)]{
|
||||
|
||||
Matches a syntax pair whose head matches the first pattern and whose
|
||||
tail matches the second.
|
||||
|
||||
}
|
||||
|
||||
@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{
|
||||
|
||||
Matches a sequence of the first pattern ending in a tail matching the
|
||||
second pattern.
|
||||
|
||||
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.
|
||||
|
||||
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)])]{
|
||||
|
||||
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)]{
|
||||
|
||||
Requires at least @scheme[min-reps] occurrences of the preceding head
|
||||
to match. @scheme[min-reps] must be a literal exact nonnegative
|
||||
integer.
|
||||
|
||||
}
|
||||
@specsubform[(code:line #:max max-reps)]{
|
||||
|
||||
Requires that no more than @scheme[max-reps] occurrences of the
|
||||
preceeding head to match. @scheme[max-reps] must be a literal exact
|
||||
nonnegative integer, and it must be greater than or equal to
|
||||
@scheme[min-reps].
|
||||
|
||||
}
|
||||
@specsubform[#:mand]{
|
||||
|
||||
Requires that the preceding head occur exactly once. Pattern variables
|
||||
in the preceding head are not bound at a higher ellipsis nesting
|
||||
depth.
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
@specsubform/subs[#:literals (~and)
|
||||
(~and maybe-description syntax-pattern ...)
|
||||
([maybe-description
|
||||
(code:line)
|
||||
(code:line #:description string)])]{
|
||||
|
||||
Matches any syntax that matches all of the included patterns.
|
||||
|
||||
}
|
||||
|
||||
Both @scheme[syntax-parse] and @scheme[syntax-parser] support
|
||||
directives for annotating the pattern and specifying side
|
||||
conditions. The grammar for pattern directives follows:
|
||||
|
||||
@schemegrammar[pattern-directive
|
||||
(code:line #:declare pattern-id syntax-class-id)
|
||||
(code:line #:declare pattern-id (syntax-class-id expr ...))
|
||||
(code:line #:with syntax-pattern expr)
|
||||
(code:line #:when expr)]
|
||||
|
||||
@specsubform[(code:line #:declare pvar-id syntax-class-id)]
|
||||
@specsubform[(code:line #:declare pvar-id (syntax-class-id expr ...))]{
|
||||
|
||||
The first form is equivalent to using the
|
||||
@scheme[_pvar-id:syntax-class-id] form in the pattern (but it is
|
||||
illegal to use both for a single pattern variable). The
|
||||
@scheme[#:declare] form may be preferred when writing macro-defining
|
||||
macros or to avoid dealing with structured identifiers.
|
||||
|
||||
The second form allows the use of parameterized syntax classes, which
|
||||
cannot be expressed using the ``colon'' notation. The @scheme[expr]s
|
||||
are evaluated outside the scope of the pattern variable bindings.
|
||||
|
||||
}
|
||||
@specsubform[(code:line #:with syntax-pattern expr)]{
|
||||
|
||||
Evaluates the @scheme[expr] in the context of all previous pattern
|
||||
variable bindings and matches it against the pattern. If the match
|
||||
succeeds, the new pattern variables are added to the environment for
|
||||
the evaluation of subsequent side conditions. If the @scheme[#:with]
|
||||
match fails, the matching process backtracks. Since a syntax object
|
||||
may match a pattern in several ways, backtracking may cause the same
|
||||
clause to be tried multiple times before the next clause is reached.
|
||||
|
||||
}
|
||||
@specsubform[(code:line #:when expr)]{
|
||||
|
||||
Evaluates the @scheme[expr] in the context of all previous pattern
|
||||
variable bindings. If it produces a false value, the matching process
|
||||
backtracks as described above; otherwise, it continues.
|
||||
|
||||
}
|
||||
|
||||
|
||||
@defidform[~and]{
|
||||
|
||||
Keyword recognized by @scheme[syntax-parse] etc as notation for
|
||||
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.
|
||||
|
||||
}
|
||||
|
||||
@defform[(attribute attr-id)]{
|
||||
|
||||
Returns the value associated with the attribute named
|
||||
@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an
|
||||
error is raised. If @scheme[attr-id] is an attribute with a nonzero
|
||||
ellipsis depth, then the result has the corresponding level of list
|
||||
nesting.
|
||||
|
||||
The values returned by @scheme[attribute] never undergo additional
|
||||
wrapping as syntax objects, unlike values produced by some uses of
|
||||
@scheme[syntax], @scheme[quasisyntax], etc. Consequently, the
|
||||
@scheme[attribute] form is preferred when the attribute value is used
|
||||
as data, not placed in a syntax object.
|
||||
|
||||
}
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scribble/decode
|
||||
(for-label scheme/base
|
||||
scheme/contract
|
||||
stxclass
|
||||
stxclass/util))
|
||||
|
||||
@(define ellipses @scheme[...])
|
||||
@(define (TODO . pre-flow)
|
||||
(make-splice
|
||||
(cons (bold "TODO: ")
|
||||
(decode-content pre-flow))))
|
||||
|
||||
@title{Parsing Syntax and Syntax Classes}
|
||||
|
||||
@bold{Warning: This library is still very volatile! Its interface and
|
||||
behavior are subject to frequent change. I highly recommend that you
|
||||
avoid creating PLaneT packages that depend on this library.}
|
||||
|
||||
The @schememodname[stxclass] library provides a framework for
|
||||
describing and parsing syntax. Using @schememodname[stxclass], macro
|
||||
writers can define new syntactic categories, specify their legal
|
||||
syntax, and use them to write clear, concise, and robust macros.
|
||||
|
||||
To load the library:
|
||||
@defmodule[stxclass]
|
||||
|
||||
@;{The first section is an overview with examples that illustrate
|
||||
@schememodname[stxclass] features.}
|
||||
|
||||
The following sections are a reference for @schememodname[stxclass]
|
||||
features.
|
||||
|
||||
@include-section["parsing-syntax.scrbl"]
|
||||
@include-section["syntax-classes.scrbl"]
|
||||
@include-section["library.scrbl"]
|
||||
@include-section["util.scrbl"]
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@;{
|
||||
|
||||
|
||||
1 How to abstract over similar patterns:
|
||||
|
||||
(syntax-parse stx #:literals (blah bleh blaz kwA kwX)
|
||||
[(blah (bleh (kwX y z)) blaz)
|
||||
___]
|
||||
[(blah (bleh (kwA (b c))) blaz)
|
||||
___])
|
||||
|
||||
=>
|
||||
|
||||
(define-syntax-class common
|
||||
#:attributes (inner)
|
||||
#:literals (blah bleh blaz)
|
||||
(pattern (blah (bleh inner) blaz)))
|
||||
(syntax-parse stx #:literals (kwA kwX)
|
||||
[c:common
|
||||
#:with (kwX y z) #'c.inner
|
||||
___]
|
||||
[c:common
|
||||
#:with (kwA (b c)) #'c.inner
|
||||
___])
|
||||
|
||||
|
||||
OR =>
|
||||
|
||||
(define-syntax-class (common expected-kw)
|
||||
#:attributes (inner)
|
||||
#:literals (blah bleh blaz)
|
||||
(pattern (blah (bleh (kw . inner)) blaz)
|
||||
#:when (free-identifier=? #'kw expected-kw)))
|
||||
(syntax-parse stx
|
||||
[c
|
||||
#:declare c (common #'kwX)
|
||||
#:with (y z) #'c.inner
|
||||
___]
|
||||
[c
|
||||
#:declare c (common #'kwA)
|
||||
#:with ((b c)) #'c.inner
|
||||
___])
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -1,225 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scribble/decode
|
||||
(for-label scheme/base
|
||||
scheme/contract
|
||||
stxclass
|
||||
stxclass/util))
|
||||
|
||||
@(define ellipses @scheme[...])
|
||||
@(define (TODO . pre-flow)
|
||||
(make-splice
|
||||
(cons (bold "TODO: ")
|
||||
(decode-content pre-flow))))
|
||||
|
||||
@title{Syntax Classes}
|
||||
@declare-exporting[stxclass]
|
||||
|
||||
Syntax classes provide an abstraction mechanism for the specification
|
||||
of syntax. Basic syntax classes include @scheme[identifier] and
|
||||
@scheme[keyword]. More generally, a programmer can define a ``basic''
|
||||
syntax from an arbitrary predicate, although syntax classes thus
|
||||
defined lose some of the benefits of declarative specification of
|
||||
syntactic structure.
|
||||
|
||||
Programmers can also compose basic syntax classes to build
|
||||
specifications of more complex syntax, such as lists of distinct
|
||||
identifiers and formal arguments with keywords. Macros that manipulate
|
||||
the same syntactic structures can share syntax class definitions. The
|
||||
structure of syntax classes and patterns also allows
|
||||
@scheme[syntax-parse] to automatically generate error messages for
|
||||
syntax errors.
|
||||
|
||||
When a syntax class accepts (matches, includes) a syntax object, it
|
||||
computes and provides attributes based on the contents of the matched
|
||||
syntax. While the values of the attributes depend on the matched
|
||||
syntax, the set of attributes and each attribute's ellipsis nesting
|
||||
depth is fixed for each syntax class.
|
||||
|
||||
@defform*/subs[#:literals (pattern basic-syntax-class)
|
||||
[(define-syntax-class name-id stxclass-option ...
|
||||
stxclass-body)
|
||||
(define-syntax-class (name-id arg-id ...) stxclass-option ...
|
||||
stxclass-body)]
|
||||
([stxclass-options
|
||||
(code:line #:attributes (attr-arity-decl ...))
|
||||
(code:line #:description description)
|
||||
(code:line #:transparent)
|
||||
(code:line #:literals (literal-entry ...))]
|
||||
[attr-arity-decl
|
||||
attr-name-id
|
||||
(attr-name-id depth)]
|
||||
[stxclass-body
|
||||
(code:line (pattern syntax-pattern stxclass-pattern-directive ...) ...+)
|
||||
(code:line (basic-syntax-class parser-expr))])]{
|
||||
|
||||
Defines @scheme[name-id] as a syntax class. When the @scheme[arg-id]s
|
||||
are present, they are bound as variables (not pattern variables) in
|
||||
the body. The body of the syntax-class definition contains either one
|
||||
@scheme[basic-syntax-class] clause or a non-empty sequence of
|
||||
@scheme[pattern] clauses.
|
||||
|
||||
@specsubform[(code:line #:attributes (attr-arity-decl ...))]{
|
||||
|
||||
Declares the attributes of the syntax class. An attribute arity
|
||||
declaration consists of the attribute name and optionally its ellipsis
|
||||
depth (zero if not explicitly specified).
|
||||
|
||||
If the attributes are not explicitly listed, they are computed using
|
||||
@techlink{attribute inference}.
|
||||
|
||||
}
|
||||
|
||||
@specsubform[(code:line #:description description)]{
|
||||
|
||||
The @scheme[description] argument is an expression (with the
|
||||
syntax-class's parameters in scope) that should evaluate to a
|
||||
string. It is used in error messages involving the syntax class. For
|
||||
example, if a term is rejected by the syntax class, an error of the
|
||||
form @scheme["expected <description>"] may be generated.
|
||||
|
||||
If absent, the name of the syntax class is used instead.
|
||||
|
||||
}
|
||||
|
||||
@specsubform[#:transparent]{
|
||||
|
||||
Indicates that errors may be reported with respect to the internal
|
||||
structure of the syntax class.
|
||||
}
|
||||
|
||||
@specsubform[(code:line #:literals (literal-entry))]{
|
||||
|
||||
Declares the literal identifiers for the syntax class's main patterns
|
||||
(immediately within @scheme[pattern] variants) and @scheme[#:with]
|
||||
clauses. The literals list does not affect patterns that occur within
|
||||
subexpressions inside the syntax class (for example, the condition of
|
||||
a @scheme[#:when] clause or the right-hand side of a @scheme[#:with]
|
||||
binding).
|
||||
|
||||
A literal can have separate internal and external names, as described
|
||||
for @scheme[syntax-parse].
|
||||
|
||||
}
|
||||
|
||||
@specsubform/subs[#:literals (pattern)
|
||||
(pattern syntax-pattern stxclass-pattern-directive ...)
|
||||
([stxclass-pattern-directive
|
||||
pattern-directive
|
||||
(code:line #:rename internal-id external-id)])]{
|
||||
|
||||
Accepts syntax matching the given pattern with the accompanying
|
||||
pattern directives as in @scheme[syntax-parse].
|
||||
|
||||
The attributes of the pattern are the pattern variables within the
|
||||
@scheme[pattern] form together with all pattern variables bound by
|
||||
@scheme[#:with] clauses, including nested attributes produced by
|
||||
syntax classes associated with the pattern variables.
|
||||
|
||||
The name of an attribute is the symbolic name of the pattern variable,
|
||||
except when the name is explicitly given via a @scheme[#:rename]
|
||||
clause.
|
||||
|
||||
@specsubform[(code:line #:rename internal-id external-id)]{
|
||||
|
||||
Exports the pattern variable binding named by @scheme[internal-id] as
|
||||
the attribute named @scheme[external-id].
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
@specsubform[#:literals (basic-syntax-class)
|
||||
(basic-syntax-class parser-expr)]{
|
||||
|
||||
The @scheme[parser-expr] must evaluate to a procedure. This procedure
|
||||
is used to parse or reject syntax objects. The arguments to the parser
|
||||
procedure consist of the syntax object to parse followed by the
|
||||
syntax-class parameterization arguments (the parameter names given at
|
||||
the @scheme[define-syntax-class] level are not bound within the
|
||||
@scheme[parser-expr]). To indicate success, the parser should return a
|
||||
list of attribute values, one for each attribute listed. (For example,
|
||||
a parser for a syntax class that defines no attributes returns the
|
||||
empty list when it succeeds.) To indicate failure, the parser
|
||||
procedure should return @scheme[#f].
|
||||
|
||||
The parser procedure should avoid side-effects, as they interfere with
|
||||
the parsing process's backtracking and error reporting.
|
||||
|
||||
@TODO{Add support for better error reporting within basic syntax
|
||||
class.}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
@defidform[pattern]{
|
||||
|
||||
Keyword recognized by @scheme[define-syntax-class]. It may not be
|
||||
used as an expression.
|
||||
}
|
||||
@defidform[basic-syntax-class]{
|
||||
|
||||
Keyword recognized by @scheme[define-syntax-class]. It may not be used
|
||||
as an expression.
|
||||
|
||||
}
|
||||
|
||||
@section{Attributes}
|
||||
|
||||
A syntax class has a set of @deftech{attribute}s. Each attribute has a
|
||||
name, an ellipsis depth, and a set of nested attributes. When an
|
||||
instance of the syntax class is parsed and bound to a pattern
|
||||
variable, additional pattern variables are bound for each of the
|
||||
syntax class's attributes. The name of these additional pattern
|
||||
variables is the dotted concatenation of the primary pattern
|
||||
variable with the name of the attribute.
|
||||
|
||||
For example, if pattern variable @scheme[p] is bound to an instance of
|
||||
a syntax class with attribute @scheme[a], then the pattern variable
|
||||
@scheme[p.a] is bound to the value of that attribute. The ellipsis
|
||||
depth of @scheme[p.a] is the sum of the depths of @scheme[p] and
|
||||
attribute @scheme[a].
|
||||
|
||||
If the attributes are not declared explicitly, they are computed via
|
||||
@deftech{attribute inference}. For ``basic'' syntax classes, the
|
||||
inferred attribute list is always empty. For compound syntax classes,
|
||||
each @scheme[pattern] form is analyzed to determine its candiate
|
||||
attributes. The attributes of the syntax class are the attributes
|
||||
common to all of the variants (that is, the intersection of the
|
||||
candidate attributes). An attribute must have the same ellipsis-depth
|
||||
in each of the variants; otherwise, an error is raised.
|
||||
|
||||
The candidate attributes of a @scheme[pattern] variant are the pattern
|
||||
variables bound by the variant's pattern (including nested attributes
|
||||
contributed by their associated syntax classes) together with the
|
||||
pattern variables (and nested attributes) from @scheme[#:with]
|
||||
clauses.
|
||||
|
||||
For the purpose of attribute inference, recursive references to the
|
||||
same syntax class and forward references to syntax classes not yet
|
||||
defined do not contribute any nested attributes. This avoids various
|
||||
problems in computing attributes, including infinitely nested
|
||||
attributes.
|
||||
|
||||
@section{Inspection tools}
|
||||
|
||||
The following special forms are for debugging syntax classes.
|
||||
|
||||
@defform[(syntax-class-attributes syntax-class-id)]{
|
||||
|
||||
Returns a list of the syntax class's attributes in flattened
|
||||
form. Each attribute is listed by its name and ellipsis depth.
|
||||
|
||||
}
|
||||
|
||||
@defform[(syntax-class-parse syntax-class-id stx-expr arg-expr ...)]{
|
||||
|
||||
Runs the parser for the syntax class (parameterized by the
|
||||
@scheme[arg-expr]s) on the syntax object produced by
|
||||
@scheme[stx-expr]. On success, the result is a list of vectors
|
||||
representing the attribute bindings of the syntax class. Each vector
|
||||
contains the attribute name, depth, and associated value. On failure,
|
||||
the result is some internal representation of the failure.
|
||||
|
||||
}
|
||||
|
|
@ -1,232 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scribble/decode
|
||||
(for-label scheme/base
|
||||
scheme/contract
|
||||
stxclass
|
||||
stxclass/util))
|
||||
|
||||
@(define ellipses @scheme[...])
|
||||
@(define (TODO . pre-flow)
|
||||
(make-splice
|
||||
(cons (bold "TODO: ")
|
||||
(decode-content pre-flow))))
|
||||
|
||||
@title{Utilities}
|
||||
|
||||
The @schememodname[stxclass] collection includes several utility
|
||||
modules. They are documented individually below.
|
||||
|
||||
As a shortcut, the @schememodname[stxclass/util] module provides all
|
||||
of the contents of the separate utility modules:
|
||||
|
||||
@defmodule[stxclass/util]
|
||||
|
||||
The contents of the utility modules are not provided by the main
|
||||
@schememodname[stxclass] module.
|
||||
|
||||
@section{Error reporting}
|
||||
|
||||
@defmodule[stxclass/util/error]
|
||||
|
||||
The @schememodname[scheme/base] and @schememodname[scheme] languages
|
||||
provide the @scheme[raise-syntax-error] procedure for reporting syntax
|
||||
errors. Using @scheme[raise-syntax-error] effectively requires passing
|
||||
around either a symbol indicating the special form that signals the
|
||||
error or else a ``contextual'' syntax object from which the special
|
||||
form's name can be extracted. This library helps manage the contextual
|
||||
syntax for reporting errors.
|
||||
|
||||
@defparam[current-syntax-context stx (or/c syntax? false/c)]{
|
||||
|
||||
The current contextual syntax object, defaulting to @scheme[#f]. It
|
||||
determines the special form name that prefixes syntax errors created
|
||||
by @scheme[wrong-syntax], as follows:
|
||||
|
||||
If it is a syntax object with a @scheme['report-error-as] syntax
|
||||
property whose value is a symbol, then that symbol is used as the
|
||||
special form name. Otherwise, the same rules apply as in
|
||||
@scheme[raise-syntax-error].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(wrong-syntax [stx syntax?] [format-string string?] [v any/c] ...)
|
||||
any]{
|
||||
|
||||
Raises a syntax error using the result of
|
||||
@scheme[(current-syntax-context)] as the ``major'' syntax object and
|
||||
the provided @scheme[stx] as the specific syntax object. (The latter,
|
||||
@scheme[stx], is usually the one highlighted by DrScheme.) The error
|
||||
message is constructed using the format string and arguments, and it
|
||||
is prefixed with the special form name as described under
|
||||
@scheme[current-syntax-context].
|
||||
|
||||
}
|
||||
|
||||
A macro using this system might set the syntax context at the very
|
||||
beginning of its transformation as follows:
|
||||
@SCHEMEBLOCK[
|
||||
(define-syntax (my-macro stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
___)))
|
||||
]
|
||||
Then any calls to @scheme[wrong-syntax] during the macro's
|
||||
transformation will refer to @scheme[my-macro] (more precisely, the name that
|
||||
referred to @scheme[my-macro] where the macro was used, which may be
|
||||
different due to renaming, prefixing, etc).
|
||||
|
||||
A macro that expands into a helper macro can insert its own name into
|
||||
syntax errors raised by the helper macro by installing a
|
||||
@scheme['report-error-as] syntax property on the helper macro
|
||||
expression. For example:
|
||||
@SCHEMEBLOCK[
|
||||
(define-syntax (public-macro stx)
|
||||
(syntax-case stx ()
|
||||
[(public-macro stuff)
|
||||
(syntax-property
|
||||
(syntax/loc stx (my-macro stuff other-internal-stuff))
|
||||
'report-error-as
|
||||
(syntax-e #'public-macro))]))
|
||||
]
|
||||
|
||||
@;{
|
||||
@section[Expand]
|
||||
|
||||
@defmodule[stxclass/util/expand]
|
||||
|
||||
TODO
|
||||
}
|
||||
|
||||
@section{Miscellaneous utilities}
|
||||
|
||||
@defmodule[stxclass/util/misc]
|
||||
|
||||
@defform[(define-pattern-variable id expr)]{
|
||||
|
||||
Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern
|
||||
variable, so @scheme[id] can be used in subsequent @scheme[syntax]
|
||||
patterns.
|
||||
|
||||
}
|
||||
|
||||
@defform[(with-temporaries (temp-id ...) . body)]{
|
||||
|
||||
Evaluates @scheme[body] with each @scheme[temp-id] bound as a pattern
|
||||
variable to a freshly generated identifier.
|
||||
|
||||
For example, the following are equivalent:
|
||||
@SCHEMEBLOCK[
|
||||
(with-temporaries (x) #'(lambda (x) x))
|
||||
(with-syntax ([(x) (generate-temporaries '(x))])
|
||||
#'(lambda (x) x))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@defproc[(generate-temporary) identifier?]{
|
||||
|
||||
Generates one fresh identifier. Singular form of
|
||||
@scheme[generate-temporaries].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(generate-n-temporaries [n exact-nonnegative-integer?])
|
||||
(listof identifier?)]{
|
||||
|
||||
Generates a list of @scheme[n] fresh identifiers.
|
||||
|
||||
}
|
||||
|
||||
@defform[(with-catching-disappeared-uses body-expr)]{
|
||||
|
||||
Evaluates the @scheme[body-expr], catching identifiers looked up using
|
||||
@scheme[syntax-local-value/catch]. Returns two values: the result of
|
||||
@scheme[body-expr] and the list of caught identifiers.
|
||||
|
||||
}
|
||||
|
||||
@defform[(with-disappeared-uses stx-expr)]{
|
||||
|
||||
Evaluates the @scheme[stx-expr], catching identifiers looked up using
|
||||
@scheme[syntax-local-value/catch]. Adds the caught identifiers to the
|
||||
@scheme['disappeared-uses] syntax property of the resulting syntax
|
||||
object.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)])
|
||||
any/c]{
|
||||
|
||||
Looks up @scheme[id] in the syntactic environment (as
|
||||
@scheme[syntax-local-value]). If the lookup succeeds and returns a
|
||||
value satisfying the predicate, the value is returned and @scheme[id]
|
||||
is recorded (``caught'') as a disappeared use. If the lookup fails or
|
||||
if the value does not satisfy the predicate, @scheme[#f] is returned
|
||||
and the identifier is not recorded as a disappeared use.
|
||||
|
||||
}
|
||||
|
||||
|
||||
@defproc[(chunk-kw-seq [stx syntax?]
|
||||
[table
|
||||
(listof (cons/c keyword?
|
||||
(listof (-> syntax? any))))]
|
||||
[context (or/c syntax? false/c) #f])
|
||||
(values (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?)))
|
||||
syntax?)]{
|
||||
|
||||
Parses a syntax list into keyword-argument ``chunks'' and a syntax
|
||||
list tail (the remainder of the syntax list). The syntax of the
|
||||
keyword arguments is specified by @scheme[table], an association list
|
||||
mapping keywords to lists of checker procedures. The length of the
|
||||
checker list is the number of ``arguments'' expected to follow the
|
||||
keyword, and each checker procedure is applied to the corresponding
|
||||
argument. The result of the checker procedure is entered into the
|
||||
chunk for that keyword sequence. The same keyword can appear multiple
|
||||
times in the result list.
|
||||
|
||||
The @scheme[context] is used to report errors.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(chunk-kw-seq/no-dups
|
||||
[stx syntax?]
|
||||
[table
|
||||
(listof (cons/c keyword?
|
||||
(listof (-> syntax? any))))]
|
||||
[context (or/c syntax? false/c) #f])
|
||||
(values (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?)))
|
||||
syntax?)]{
|
||||
|
||||
Like @scheme[chunk-kw-seq] filtered by @scheme[reject-duplicate-chunks].
|
||||
|
||||
The @scheme[context] is used to report errors.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(reject-duplicate-chunks
|
||||
[chunks (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?)))])
|
||||
void?]{
|
||||
|
||||
Raises a syntax error if it encounters the same keyword more than once
|
||||
in the @scheme[chunks] list.
|
||||
|
||||
The @scheme[context] is used to report errors.
|
||||
|
||||
}
|
||||
|
||||
|
||||
@section{Structs}
|
||||
|
||||
@defmodule[stxclass/util/struct]
|
||||
|
||||
@defform[(make struct-id v ...)]{
|
||||
|
||||
Constructs an instance of @scheme[struct-id], which must be defined
|
||||
as a struct name. If @scheme[struct-id] has a different number of
|
||||
fields than the number of @scheme[v] values provided, @scheme[make]
|
||||
raises a compile-time error.
|
||||
|
||||
}
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require "util/error.ss"
|
||||
"util/expand.ss"
|
||||
"util/misc.ss"
|
||||
"util/struct.ss")
|
||||
(provide (all-from-out "util/error.ss")
|
||||
(all-from-out "util/expand.ss")
|
||||
(all-from-out "util/misc.ss")
|
||||
(all-from-out "util/struct.ss"))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#lang scheme/base
|
||||
(provide wrong-syntax
|
||||
current-syntax-context)
|
||||
|
||||
(define current-syntax-context (make-parameter #f))
|
||||
|
||||
(define (wrong-syntax stx #:extra [extras null] format-string . args)
|
||||
(unless (or (eq? stx #f) (syntax? stx))
|
||||
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
|
||||
(let* ([ctx (current-syntax-context)]
|
||||
[blame (syntax-property ctx 'report-errors-as)])
|
||||
(raise-syntax-error (if (symbol? blame) blame #f)
|
||||
(apply format format-string args)
|
||||
ctx
|
||||
(or stx ctx)
|
||||
extras)))
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require syntax/kerncase
|
||||
syntax/stx)
|
||||
(provide head-local-expand-and-categorize-syntaxes
|
||||
categorize-expanded-syntaxes
|
||||
head-local-expand-syntaxes)
|
||||
|
||||
;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6
|
||||
;; Setting allow-def-after-expr? allows def/expr interleaving.
|
||||
(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?)
|
||||
(define estxs (head-local-expand-syntaxes x allow-def-after-expr?))
|
||||
(define-values (defs vdefs sdefs exprs)
|
||||
(categorize-expanded-syntaxes estxs))
|
||||
(values estxs estxs defs vdefs sdefs exprs))
|
||||
|
||||
;; categorize-expanded-syntaxes : (listof stx) -> stxs ^ 4
|
||||
;; Split head-expanded stxs into
|
||||
;; definitions, values-definitions, syntaxes-definitions, exprs
|
||||
;; (definitions include both values-definitions and syntaxes-definitions.)
|
||||
(define (categorize-expanded-syntaxes estxs0)
|
||||
(let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null])
|
||||
(cond [(pair? estxs)
|
||||
(let ([ee (car estxs)])
|
||||
(syntax-case ee (begin define-values define-syntaxes)
|
||||
[(define-values . _)
|
||||
(loop (cdr estxs)
|
||||
(cons ee defs)
|
||||
(cons ee vdefs)
|
||||
sdefs
|
||||
exprs)]
|
||||
[(define-syntaxes (var ...) rhs)
|
||||
(loop (cdr estxs)
|
||||
(cons ee defs)
|
||||
vdefs
|
||||
(cons ee sdefs)
|
||||
exprs)]
|
||||
[_
|
||||
(loop (cdr estxs)
|
||||
defs
|
||||
vdefs
|
||||
sdefs
|
||||
(cons ee exprs))]))]
|
||||
[(null? estxs)
|
||||
(values (reverse defs)
|
||||
(reverse vdefs)
|
||||
(reverse sdefs)
|
||||
(reverse exprs))])))
|
||||
|
||||
;; head-local-expand-syntaxes : syntax boolean -> (listof syntax)
|
||||
(define (head-local-expand-syntaxes x allow-def-after-expr?)
|
||||
(let ([intdef (syntax-local-make-definition-context)]
|
||||
[ctx '(block)])
|
||||
(let loop ([x x] [ex null] [expr? #f])
|
||||
(cond [(stx-pair? x)
|
||||
(let ([ee (local-expand (stx-car x)
|
||||
ctx
|
||||
(kernel-form-identifier-list)
|
||||
intdef)])
|
||||
(syntax-case ee (begin define-values define-syntaxes)
|
||||
[(begin e ...)
|
||||
(loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)]
|
||||
[(begin . _)
|
||||
(raise-syntax-error #f "bad begin form" ee)]
|
||||
[(define-values (var ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(var ...)))
|
||||
(begin
|
||||
(when (and expr? (not allow-def-after-expr?))
|
||||
(raise-syntax-error #f "definition after expression" ee))
|
||||
(syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef)
|
||||
(loop (stx-cdr x) (cons ee ex) expr?))]
|
||||
[(define-values . _)
|
||||
(raise-syntax-error #f "bad define-values form" ee)]
|
||||
[(define-syntaxes (var ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(var ...)))
|
||||
(begin
|
||||
(when (and expr? (not allow-def-after-expr?))
|
||||
(raise-syntax-error #f "definition after expression" ee))
|
||||
(syntax-local-bind-syntaxes (syntax->list #'(var ...))
|
||||
#'rhs
|
||||
intdef)
|
||||
(loop (stx-cdr x) (cons ee ex) expr?))]
|
||||
[(define-syntaxes . _)
|
||||
(raise-syntax-error #f "bad define-syntaxes form" ee)]
|
||||
[_
|
||||
(loop (stx-cdr x) (cons ee ex) #t)]))]
|
||||
[(stx-null? x)
|
||||
(internal-definition-context-seal intdef)
|
||||
(reverse ex)]))))
|
||||
|
|
@ -1,167 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require syntax/kerncase
|
||||
syntax/stx
|
||||
(for-syntax scheme/base
|
||||
scheme/private/sc))
|
||||
|
||||
(provide define-pattern-variable
|
||||
|
||||
with-temporaries
|
||||
generate-temporary
|
||||
generate-n-temporaries
|
||||
|
||||
current-caught-disappeared-uses
|
||||
with-catching-disappeared-uses
|
||||
with-disappeared-uses
|
||||
syntax-local-value/catch
|
||||
record-disappeared-uses
|
||||
|
||||
format-symbol
|
||||
|
||||
chunk-kw-seq/no-dups
|
||||
chunk-kw-seq
|
||||
reject-duplicate-chunks
|
||||
check-id
|
||||
check-nat/f
|
||||
check-string
|
||||
check-idlist)
|
||||
|
||||
;; Defining pattern variables
|
||||
|
||||
(define-syntax-rule (define-pattern-variable name expr)
|
||||
(begin (define var expr)
|
||||
(define-syntax name (make-syntax-mapping '0 (quote-syntax var)))))
|
||||
|
||||
;; Statics and disappeared uses
|
||||
|
||||
(define current-caught-disappeared-uses (make-parameter #f))
|
||||
|
||||
(define-syntax-rule (with-catching-disappeared-uses . body)
|
||||
(parameterize ((current-caught-disappeared-uses null))
|
||||
(let ([result (let () . body)])
|
||||
(values result (current-caught-disappeared-uses)))))
|
||||
|
||||
(define-syntax-rule (with-disappeared-uses stx-expr)
|
||||
(let-values ([(stx disappeared-uses)
|
||||
(with-catching-disappeared-uses stx-expr)])
|
||||
(syntax-property stx
|
||||
'disappeared-use
|
||||
(append (or (syntax-property stx 'disappeared-use) null)
|
||||
disappeared-uses))))
|
||||
|
||||
(define (syntax-local-value/catch id pred)
|
||||
(let ([value (syntax-local-value id (lambda () #f))])
|
||||
(and (pred value)
|
||||
(begin (record-disappeared-uses (list id))
|
||||
value))))
|
||||
|
||||
(define (record-disappeared-uses ids)
|
||||
(let ([uses (current-caught-disappeared-uses)])
|
||||
(when uses
|
||||
(current-caught-disappeared-uses (append ids uses)))))
|
||||
|
||||
;; Generating temporaries
|
||||
|
||||
;; with-temporaries
|
||||
(define-syntax-rule (with-temporaries (temp-name ...) . body)
|
||||
(with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))])
|
||||
. body))
|
||||
|
||||
;; generate-temporary : any -> identifier
|
||||
(define (generate-temporary [stx 'g])
|
||||
(car (generate-temporaries (list stx))))
|
||||
|
||||
;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier)
|
||||
(define (generate-n-temporaries n)
|
||||
(generate-temporaries
|
||||
(for/list ([i (in-range n)])
|
||||
(string->symbol (format "g~sx" i)))))
|
||||
|
||||
;; Symbol Formatting
|
||||
|
||||
(define (format-symbol fmt . args)
|
||||
(let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))])
|
||||
(string->symbol (apply format fmt args))))
|
||||
|
||||
;; Parsing keyword arguments
|
||||
|
||||
;; chunk-kw-seq/no-dups : syntax
|
||||
;; alist[keyword => (listof (stx -> any))]
|
||||
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
|
||||
(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f])
|
||||
(let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)])
|
||||
(reject-duplicate-chunks chunks)
|
||||
(values chunks rest)))
|
||||
|
||||
;; chunk-kw-seq : stx
|
||||
;; alist[keyword => (listof (stx -> any))
|
||||
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
|
||||
(define (chunk-kw-seq stx kws #:context [ctx #f])
|
||||
(define (loop stx rchunks)
|
||||
(syntax-case stx ()
|
||||
[(kw . more)
|
||||
(and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws))
|
||||
(let* ([kw-value (syntax-e #'kw)]
|
||||
[arity (cdr (assq kw-value kws))]
|
||||
[args+rest (stx-split #'more arity)])
|
||||
(if args+rest
|
||||
(loop (cdr args+rest)
|
||||
(cons (list* kw-value #'kw (car args+rest)) rchunks))
|
||||
(raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
|
||||
[(kw . more)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(raise-syntax-error #f "unexpected keyword" ctx #'kw)]
|
||||
[_
|
||||
(values (reverse rchunks) stx)]))
|
||||
(loop stx null))
|
||||
|
||||
;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void
|
||||
(define (reject-duplicate-chunks chunks #:context [ctx #f])
|
||||
(define kws (make-hasheq))
|
||||
(define (loop chunks)
|
||||
(when (pair? chunks)
|
||||
(let ([kw (caar chunks)])
|
||||
(when (hash-ref kws kw #f)
|
||||
(raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx))
|
||||
(hash-set! kws kw #t))
|
||||
(loop (cdr chunks))))
|
||||
(loop chunks))
|
||||
|
||||
;; stx-split : stx nat -> (cons (listof stx) stx)
|
||||
(define (stx-split stx procs)
|
||||
(define (loop stx procs acc)
|
||||
(cond [(null? procs)
|
||||
(cons (reverse acc) stx)]
|
||||
[(stx-pair? stx)
|
||||
(loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))]
|
||||
[else #f]))
|
||||
(loop stx procs null))
|
||||
|
||||
;; check-id : stx -> identifier
|
||||
(define (check-id stx)
|
||||
(unless (identifier? stx)
|
||||
(raise-syntax-error 'pattern "expected identifier" stx))
|
||||
stx)
|
||||
|
||||
;; check-string : stx -> stx
|
||||
(define (check-string stx)
|
||||
(unless (string? (syntax-e stx))
|
||||
(raise-syntax-error #f "expected string" stx))
|
||||
stx)
|
||||
|
||||
;; nat/f : any -> boolean
|
||||
(define (nat/f x)
|
||||
(or (not x) (exact-nonnegative-integer? x)))
|
||||
|
||||
;; check-nat/f : stx -> stx
|
||||
(define (check-nat/f stx)
|
||||
(let ([d (syntax-e stx)])
|
||||
(unless (nat/f d)
|
||||
(raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
|
||||
stx))
|
||||
|
||||
;; check-idlist : stx -> (listof identifier)
|
||||
(define (check-idlist stx)
|
||||
(unless (and (stx-list? stx) (andmap identifier? (stx->list stx)))
|
||||
(raise-syntax-error #f "expected list of identifiers" stx))
|
||||
(stx->list stx))
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
scheme/struct-info))
|
||||
|
||||
(provide make)
|
||||
|
||||
;; (make struct-name field-expr ...)
|
||||
;; Checks that correct number of fields given.
|
||||
(define-syntax (make stx)
|
||||
(define (bad-struct-name x)
|
||||
(raise-syntax-error #f "expected struct name" stx x))
|
||||
(define (get-struct-info id)
|
||||
(unless (identifier? id)
|
||||
(bad-struct-name id))
|
||||
(let ([value (syntax-local-value id (lambda () #f))])
|
||||
(unless (struct-info? value)
|
||||
(bad-struct-name id))
|
||||
(extract-struct-info value)))
|
||||
(syntax-case stx ()
|
||||
[(make S expr ...)
|
||||
(let ()
|
||||
(define info (get-struct-info #'S))
|
||||
(define constructor (list-ref info 1))
|
||||
(define accessors (list-ref info 3))
|
||||
(unless (identifier? #'constructor)
|
||||
(raise-syntax-error #f "constructor not available for struct" stx #'S))
|
||||
(unless (andmap identifier? accessors)
|
||||
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
|
||||
(let ([num-slots (length accessors)]
|
||||
[num-provided (length (syntax->list #'(expr ...)))])
|
||||
(unless (= num-provided num-slots)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "wrong number of arguments for struct ~s (expected ~s)"
|
||||
(syntax-e #'S)
|
||||
num-slots)
|
||||
stx)))
|
||||
(with-syntax ([constructor constructor])
|
||||
#'(constructor expr ...)))]))
|
||||
|
|
@ -36,4 +36,6 @@
|
|||
num-slots)
|
||||
stx)))
|
||||
(with-syntax ([constructor constructor])
|
||||
#'(constructor expr ...)))]))
|
||||
(syntax-property #'(constructor expr ...)
|
||||
'disappeared-use
|
||||
#'S)))]))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
(rename-in (types convenience union utils) [make-arr* make-arr])
|
||||
(utils tc-utils stxclass-util)
|
||||
syntax/stx (prefix-in c: scheme/contract)
|
||||
syntax/parse stxclass/util
|
||||
syntax/parse
|
||||
(env type-environments type-name-env type-alias-env lexical-env)
|
||||
(prefix-in t: (combine-in "base-types-extra.ss" "base-types.ss")) (only-in "colon.ss" :)
|
||||
scheme/match
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
(require (except-in "../utils/utils.ss" extend))
|
||||
(require (for-syntax
|
||||
syntax/parse
|
||||
stxclass/util
|
||||
syntax/private/util
|
||||
scheme/base
|
||||
(rep type-rep)
|
||||
mzlib/match
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
scheme/contract
|
||||
(for-syntax
|
||||
scheme/list
|
||||
stxclass/util
|
||||
(only-in syntax/private/util/misc generate-temporary)
|
||||
scheme/match
|
||||
(except-in syntax/parse id identifier keyword)
|
||||
scheme/base
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@
|
|||
"rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss"
|
||||
mzlib/trace scheme/match
|
||||
scheme/contract
|
||||
stxclass/util
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(define name-table (make-weak-hasheq))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(types resolve)
|
||||
(only-in (env type-environments lexical-env) env? update-type/lexical env-map)
|
||||
scheme/contract scheme/match
|
||||
stxclass/util mzlib/trace
|
||||
mzlib/trace
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide env+)
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
"tc-metafunctions.ss"
|
||||
mzlib/trace
|
||||
scheme/list
|
||||
stxclass/util syntax/stx
|
||||
syntax/private/util syntax/stx
|
||||
(rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c])
|
||||
(except-in (rep type-rep) make-arr)
|
||||
(rename-in (types convenience utils union)
|
||||
|
|
|
|||
|
|
@ -7,7 +7,6 @@
|
|||
[one-of/c -one-of/c])
|
||||
(rep type-rep)
|
||||
scheme/contract scheme/match
|
||||
stxclass/util
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide combine-filter apply-filter abstract-filter abstract-filters
|
||||
|
|
|
|||
|
|
@ -1,6 +1,9 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (except-in syntax/parse id keyword) (for-syntax syntax/parse scheme/base stxclass/util))
|
||||
(require (except-in syntax/parse id keyword)
|
||||
(for-syntax syntax/parse
|
||||
scheme/base
|
||||
(only-in syntax/private/util/misc generate-temporary)))
|
||||
|
||||
(provide (except-out (all-defined-out) id keyword)
|
||||
(rename-out [id id*] [keyword keyword*]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user