minor
svn: r9127
This commit is contained in:
Eli Barzilay
parent
75ceb53bf7
commit
fac8cf7328
|
|
@ -1,8 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base "patterns.ss" scheme/stxparam)
|
||||
mzlib/trace
|
||||
mzlib/etc
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
"patterns.ss"
|
||||
|
|
@ -19,11 +17,11 @@
|
|||
(define (hash-on f elems #:equal? [eql #t])
|
||||
(define ht (apply make-hash-table (if eql (list 'equal) null)))
|
||||
;; put all the elements e in the ht, indexed by (f e)
|
||||
(for-each (lambda (r)
|
||||
(define k (f r))
|
||||
(hash-table-put! ht k (cons r (hash-table-get ht k (lambda () null)))))
|
||||
;; they need to be in the original order when they come out
|
||||
(reverse elems))
|
||||
(for ([r
|
||||
;; they need to be in the original order when they come out
|
||||
(reverse elems)])
|
||||
(define k (f r))
|
||||
(hash-table-put! ht k (cons r (hash-table-get ht k (lambda () null)))))
|
||||
ht)
|
||||
|
||||
;; generate a clause of kind k
|
||||
|
|
@ -31,15 +29,17 @@
|
|||
;; escaping to esc
|
||||
(define (gen-clause k rows x xs esc)
|
||||
(define-syntax-rule (constant-pat predicate-stx)
|
||||
(with-syntax
|
||||
([rhs
|
||||
(compile* (cons x xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p ps) (Row-split-pats row))
|
||||
(define p* (Atom-p p))
|
||||
(make-Row (cons p* ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
rows)
|
||||
esc)])
|
||||
(with-syntax ([rhs (compile* (cons x xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p ps)
|
||||
(Row-split-pats row))
|
||||
(define p* (Atom-p p))
|
||||
(make-Row (cons p* ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)])
|
||||
#`[(#,predicate-stx #,x) rhs]))
|
||||
(define (compile-con-pat accs pred pat-acc)
|
||||
(with-syntax ([(tmps ...) (generate-temporaries accs)])
|
||||
|
|
@ -49,20 +49,21 @@
|
|||
(append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps) (Row-split-pats row))
|
||||
(make-Row (append (pat-acc p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
(make-Row (append (pat-acc p1) ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)])
|
||||
#`[(pred #,x)
|
||||
(let ([tmps (accs #,x)] ...)
|
||||
body)])))
|
||||
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)])))
|
||||
(cond
|
||||
[(eq? 'box k)
|
||||
[(eq? 'box k)
|
||||
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
|
||||
[(eq? 'pair k)
|
||||
(compile-con-pat (list #'car #'cdr) #'pair?
|
||||
(compile-con-pat (list #'car #'cdr) #'pair?
|
||||
(lambda (p) (list (Pair-a p) (Pair-d p))))]
|
||||
[(eq? 'mpair k)
|
||||
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
|
||||
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
|
||||
(lambda (p) (list (MPair-a p) (MPair-d p))))]
|
||||
[(eq? 'string k) (constant-pat #'string?)]
|
||||
[(eq? 'number k) (constant-pat #'number?)]
|
||||
|
|
@ -77,32 +78,36 @@
|
|||
;; because each arity is like a different constructor
|
||||
[(eq? 'vector k)
|
||||
(let ()
|
||||
(define ht (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
|
||||
(with-syntax ([(clauses ...)
|
||||
(hash-table-map
|
||||
ht
|
||||
(lambda (arity rows)
|
||||
(define ns (build-list arity values))
|
||||
(with-syntax ([(tmps ...) (generate-temporaries ns)])
|
||||
(with-syntax
|
||||
([body (compile* (append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps) (Row-split-pats row))
|
||||
(make-Row (append (Vector-ps p1) ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)]
|
||||
(define ht
|
||||
(hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
|
||||
(with-syntax
|
||||
([(clauses ...)
|
||||
(hash-table-map
|
||||
ht
|
||||
(lambda (arity rows)
|
||||
(define ns (build-list arity values))
|
||||
(with-syntax ([(tmps ...) (generate-temporaries ns)])
|
||||
(with-syntax ([body
|
||||
(compile*
|
||||
(append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps)
|
||||
(Row-split-pats row))
|
||||
(make-Row (append (Vector-ps p1) ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)]
|
||||
[(n ...) ns])
|
||||
#`[(#,arity)
|
||||
(let ([tmps (vector-ref #,x n)] ...)
|
||||
body)]))))])
|
||||
#`[(#,arity)
|
||||
(let ([tmps (vector-ref #,x n)] ...)
|
||||
body)]))))])
|
||||
#`[(vector? #,x)
|
||||
(case (vector-length #,x)
|
||||
clauses ...)]))]
|
||||
clauses ...)]))]
|
||||
;; it's a structure
|
||||
[(box? k)
|
||||
[(box? k)
|
||||
;; all the rows are structures with the same predicate
|
||||
(let* ([s (Row-first-pat (car rows))]
|
||||
[accs (Struct-accessors s)]
|
||||
|
|
@ -110,94 +115,115 @@
|
|||
(compile-con-pat accs pred Struct-ps))]
|
||||
[else (error 'compile "bad key: ~a" k)]))
|
||||
|
||||
|
||||
;; produces the syntax for a let clause
|
||||
(define (compile-one vars block esc)
|
||||
(define-values (first rest-pats) (Row-split-pats (car block)))
|
||||
(define x (car vars))
|
||||
(define xs (cdr vars))
|
||||
(cond
|
||||
(cond
|
||||
;; the Exact rule
|
||||
[(Exact? first)
|
||||
(let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)])
|
||||
(with-syntax ([(clauses ...) (hash-table-map
|
||||
ht
|
||||
(lambda (k v)
|
||||
#`[(equal? #,x '#,k)
|
||||
#,(compile* xs
|
||||
(map (lambda (row)
|
||||
(make-Row (cdr (Row-pats row))
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
v)
|
||||
esc)]))])
|
||||
(with-syntax ([(clauses ...)
|
||||
(hash-table-map
|
||||
ht
|
||||
(lambda (k v)
|
||||
#`[(equal? #,x '#,k)
|
||||
#,(compile* xs
|
||||
(map (lambda (row)
|
||||
(make-Row (cdr (Row-pats row))
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
v)
|
||||
esc)]))])
|
||||
#`(cond clauses ... [else (#,esc)])))]
|
||||
;; the Var rule
|
||||
[(Var? first)
|
||||
(let ([transform (lambda (row)
|
||||
(define-values (p ps) (Row-split-pats row))
|
||||
(define v (Var-v p))
|
||||
(define seen (Row-vars-seen row))
|
||||
;; a new row with the rest of the patterns
|
||||
(cond
|
||||
;; if this was a wild-card variable, don't bind
|
||||
[(Dummy? p) (make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))]
|
||||
;; if we've seen this variable before, check that it's equal to the one we saw
|
||||
[(ormap (lambda (e)
|
||||
(let ([v* (car e)]
|
||||
[id (cdr e)])
|
||||
(and (bound-identifier=? v v*) id)))
|
||||
seen)
|
||||
=>
|
||||
(lambda (id)
|
||||
(make-Row ps
|
||||
#`(if ((match-equality-test) #,x #,id)
|
||||
#,(Row-rhs row)
|
||||
(fail))
|
||||
(Row-unmatch row)
|
||||
seen))]
|
||||
;;otherwise, bind the matched variable to x, and add it to the list of vars we've seen
|
||||
[else (let ([v* (free-identifier-mapping-get (current-renaming) v (lambda () v))])
|
||||
(make-Row ps
|
||||
#`(let ([#,v* #,x]) #,(Row-rhs row))
|
||||
(Row-unmatch row)
|
||||
(cons (cons v x) (Row-vars-seen row))))]))])
|
||||
(let ([transform
|
||||
(lambda (row)
|
||||
(define-values (p ps) (Row-split-pats row))
|
||||
(define v (Var-v p))
|
||||
(define seen (Row-vars-seen row))
|
||||
;; a new row with the rest of the patterns
|
||||
(cond
|
||||
;; if this was a wild-card variable, don't bind
|
||||
[(Dummy? p) (make-Row ps
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row))]
|
||||
;; if we've seen this variable before, check that it's equal to
|
||||
;; the one we saw
|
||||
[(ormap (lambda (e)
|
||||
(let ([v* (car e)] [id (cdr e)])
|
||||
(and (bound-identifier=? v v*) id)))
|
||||
seen)
|
||||
=>
|
||||
(lambda (id)
|
||||
(make-Row ps
|
||||
#`(if ((match-equality-test) #,x #,id)
|
||||
#,(Row-rhs row)
|
||||
(fail))
|
||||
(Row-unmatch row)
|
||||
seen))]
|
||||
;; otherwise, bind the matched variable to x, and add it to the
|
||||
;; list of vars we've seen
|
||||
[else (let ([v* (free-identifier-mapping-get
|
||||
(current-renaming) v (lambda () v))])
|
||||
(make-Row ps
|
||||
#`(let ([#,v* #,x]) #,(Row-rhs row))
|
||||
(Row-unmatch row)
|
||||
(cons (cons v x) (Row-vars-seen row))))]))])
|
||||
;; compile the transformed block
|
||||
(compile* xs (map transform block) esc))]
|
||||
;; the Constructor rule
|
||||
[(CPat? first)
|
||||
(let ;; put all the rows in the hash-table, indexed by their constructor
|
||||
([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
|
||||
(with-syntax ([(clauses ...) (hash-table-map ht (lambda (k v) (gen-clause k v x xs esc)))])
|
||||
(with-syntax ([(clauses ...)
|
||||
(hash-table-map
|
||||
ht (lambda (k v) (gen-clause k v x xs esc)))])
|
||||
#`(cond clauses ... [else (#,esc)])))]
|
||||
;; the Or rule
|
||||
[(Or? first)
|
||||
;; we only handle 1-row Ors atm - this is all the mixture rule should give us
|
||||
;; we only handle 1-row Ors atm - this is all the mixture rule should give
|
||||
;; us
|
||||
(unless (null? (cdr block))
|
||||
(error 'compile-one "Or block with multiple rows: ~a" block))
|
||||
(let* ([row (car block)]
|
||||
[pats (Row-pats row)]
|
||||
;; all the pattern alternatives
|
||||
[qs (Or-ps (car pats))]
|
||||
;; the variables bound by this pattern - they're the same for the whole list
|
||||
;; the variables bound by this pattern - they're the same for the
|
||||
;; whole list
|
||||
[vars (bound-vars (car qs))])
|
||||
(with-syntax ([vars vars])
|
||||
;; do the or matching, and bind the results to the appropriate variables
|
||||
;; do the or matching, and bind the results to the appropriate
|
||||
;; variables
|
||||
#`(let/ec exit
|
||||
(let ([esc* (lambda () (exit (#,esc)))])
|
||||
(let-values ([vars #,(compile* (list x) (map (lambda (q) (make-Row (list q) #'(values . vars) #f (Row-vars-seen row)))
|
||||
qs)
|
||||
#'esc*)])
|
||||
(let-values ([vars
|
||||
#,(compile* (list x)
|
||||
(map (lambda (q)
|
||||
(make-Row (list q)
|
||||
#'(values . vars)
|
||||
#f
|
||||
(Row-vars-seen row)))
|
||||
qs)
|
||||
#'esc*)])
|
||||
;; then compile the rest of the row
|
||||
#,(compile* xs
|
||||
(list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row)
|
||||
#,(compile* xs
|
||||
(list (make-Row (cdr pats)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(let ([vs (syntax->list #'vars)])
|
||||
(append (map cons vs vs) (Row-vars-seen row)))))
|
||||
(append (map cons vs vs)
|
||||
(Row-vars-seen row)))))
|
||||
esc))))))]
|
||||
;; the App rule
|
||||
[(App? first)
|
||||
;; we only handle 1-row Apps atm - this is all the mixture rule should give us
|
||||
;; we only handle 1-row Apps atm - this is all the mixture rule should
|
||||
;; give us
|
||||
(unless (null? (cdr block))
|
||||
(error 'compile-one "App block with multiple rows: ~a" block))
|
||||
(let* ([row (car block)]
|
||||
|
|
@ -205,11 +231,15 @@
|
|||
(with-syntax ([(t) (generate-temporaries #'(t))])
|
||||
#`(let ([t (#,(App-expr first) #,x)])
|
||||
#,(compile* (cons #'t xs)
|
||||
(list (make-Row (cons (App-p first) (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
(list (make-Row (cons (App-p first) (cdr pats))
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
esc))))]
|
||||
;; the And rule
|
||||
[(And? first)
|
||||
;; we only handle 1-row Ands atm - this is all the mixture rule should give us
|
||||
;; we only handle 1-row Ands atm - this is all the mixture rule should
|
||||
;; give us
|
||||
(unless (null? (cdr block))
|
||||
(error 'compile-one "And block with multiple rows: ~a" block))
|
||||
(let* ([row (car block)]
|
||||
|
|
@ -217,11 +247,15 @@
|
|||
;; all the patterns
|
||||
[qs (And-ps (car pats))])
|
||||
(compile* (append (map (lambda _ x) qs) xs)
|
||||
(list (make-Row (append qs (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
(list (make-Row (append qs (cdr pats))
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
esc))]
|
||||
;; the Not rule
|
||||
[(Not? first)
|
||||
;; we only handle 1-row Nots atm - this is all the mixture rule should give us
|
||||
;; we only handle 1-row Nots atm - this is all the mixture rule should
|
||||
;; give us
|
||||
(unless (null? (cdr block))
|
||||
(error 'compile-one "Not block with multiple rows: ~a" block))
|
||||
(let* ([row (car block)]
|
||||
|
|
@ -229,23 +263,33 @@
|
|||
;; the single pattern
|
||||
[q (Not-p (car pats))])
|
||||
(with-syntax ([(f) (generate-temporaries #'(f))])
|
||||
#`(let
|
||||
;; if q fails, we jump to here
|
||||
([f (lambda ()
|
||||
#,(compile* xs
|
||||
(list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
esc))])
|
||||
#`(let ;; if q fails, we jump to here
|
||||
([f (lambda ()
|
||||
#,(compile* xs
|
||||
(list (make-Row (cdr pats)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
esc))])
|
||||
#,(compile* (list x)
|
||||
;; if q doesn't fail, we jump to esc and fail the not pattern
|
||||
(list (make-Row (list q) #`(#,esc) (Row-unmatch row) (Row-vars-seen row)))
|
||||
;; if q doesn't fail, we jump to esc and fail the not
|
||||
;; pattern
|
||||
(list (make-Row (list q)
|
||||
#`(#,esc)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
#'f))))]
|
||||
[(Pred? first)
|
||||
;; multiple preds iff they have the identical predicate
|
||||
[(Pred? first)
|
||||
;; multiple preds iff they have the identical predicate
|
||||
(with-syntax ([pred? (Pred-pred first)]
|
||||
[body (compile* xs
|
||||
(map (lambda (row)
|
||||
(define-values (_1 ps) (Row-split-pats row))
|
||||
(make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
(define-values (_1 ps)
|
||||
(Row-split-pats row))
|
||||
(make-Row ps
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
block)
|
||||
esc)])
|
||||
#`(cond [(pred? #,x) body] [else (#,esc)]))]
|
||||
|
|
@ -262,9 +306,8 @@
|
|||
(lambda (ps)
|
||||
(define (loop ps pat)
|
||||
(if (pair? ps)
|
||||
(make-Pair (car ps)
|
||||
(loop (cdr ps) pat))
|
||||
pat))
|
||||
(make-Pair (car ps) (loop (cdr ps) pat))
|
||||
pat))
|
||||
(loop ps (make-Var xvar)))]
|
||||
[heads
|
||||
(for/list ([ps headss])
|
||||
|
|
@ -285,106 +328,116 @@
|
|||
[(maxrepconstraint ...)
|
||||
;; FIXME: move to side condition to appropriate pattern
|
||||
(for/list ([repvar reps] [maxrep maxs])
|
||||
(if maxrep
|
||||
#`(< #,repvar #,maxrep)
|
||||
#`#t))]
|
||||
(if maxrep #`(< #,repvar #,maxrep) #`#t))]
|
||||
[(minrepclause ...)
|
||||
(for/list ([repvar reps] [minrep mins] #:when minrep)
|
||||
#`[(< #,repvar #,minrep)
|
||||
(fail)])]
|
||||
#`[(< #,repvar #,minrep) (fail)])]
|
||||
[((hid-rhs ...) ...)
|
||||
(for/list ([hid-args hid-argss] [once? onces?])
|
||||
(for/list ([hid-arg hid-args])
|
||||
(if once?
|
||||
#`(car (reverse #,hid-arg))
|
||||
#`(reverse #,hid-arg))))]
|
||||
[(parse-loop failkv fail-tail) (generate-temporaries #'(parse-loop failkv fail-tail))])
|
||||
(for/list ([hid-arg hid-args])
|
||||
(if once?
|
||||
#`(car (reverse #,hid-arg))
|
||||
#`(reverse #,hid-arg))))]
|
||||
[(parse-loop failkv fail-tail)
|
||||
(generate-temporaries #'(parse-loop failkv fail-tail))])
|
||||
(with-syntax ([(rhs ...)
|
||||
#`[(let ([hid-arg (cons hid* hid-arg)] ...)
|
||||
(if maxrepconstraint
|
||||
(let ([rep (add1 rep)])
|
||||
(parse-loop x #,@hid-args #,@reps fail))
|
||||
(begin
|
||||
(fail))))
|
||||
(let ([rep (add1 rep)])
|
||||
(parse-loop x #,@hid-args #,@reps fail))
|
||||
(begin (fail))))
|
||||
...]]
|
||||
[tail-rhs
|
||||
#`(cond minrepclause ...
|
||||
[else
|
||||
(let ([hid hid-rhs] ... ...
|
||||
[fail-tail fail])
|
||||
#,(compile* (cdr vars)
|
||||
(list (make-Row rest-pats k (Row-unmatch (car block)) (Row-vars-seen (car block))))
|
||||
#'fail-tail))])])
|
||||
(parameterize ([current-renaming
|
||||
(for/fold ([ht (copy-mapping (current-renaming))])
|
||||
([id (apply append head-idss)]
|
||||
[id* (apply append head-idss*)])
|
||||
(free-identifier-mapping-put! ht id id*)
|
||||
(free-identifier-mapping-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (free-identifier=? v id)
|
||||
(free-identifier-mapping-put! ht k id*))))
|
||||
ht)])
|
||||
#`(let parse-loop ([x var0] [hid-arg null] ... ... [rep 0] ... [failkv #,esc])
|
||||
#,(compile* (list #'x)
|
||||
#,(compile*
|
||||
(cdr vars)
|
||||
(list (make-Row rest-pats k
|
||||
(Row-unmatch (car block))
|
||||
(Row-vars-seen
|
||||
(car block))))
|
||||
#'fail-tail))])])
|
||||
(parameterize ([current-renaming
|
||||
(for/fold ([ht (copy-mapping (current-renaming))])
|
||||
([id (apply append head-idss)]
|
||||
[id* (apply append head-idss*)])
|
||||
(free-identifier-mapping-put! ht id id*)
|
||||
(free-identifier-mapping-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (free-identifier=? v id)
|
||||
(free-identifier-mapping-put! ht k id*))))
|
||||
ht)])
|
||||
#`(let parse-loop ([x var0]
|
||||
[hid-arg null] ... ...
|
||||
[rep 0] ...
|
||||
[failkv #,esc])
|
||||
#,(compile* (list #'x)
|
||||
(append
|
||||
(map (lambda (pats rhs) (make-Row pats rhs (Row-unmatch (car block)) null))
|
||||
(map (lambda (pats rhs)
|
||||
(make-Row pats
|
||||
rhs
|
||||
(Row-unmatch (car block))
|
||||
null))
|
||||
(map list heads)
|
||||
(syntax->list #'(rhs ...)))
|
||||
(list (make-Row (list tail) #`tail-rhs (Row-unmatch (car block)) null)))
|
||||
(list (make-Row (list tail)
|
||||
#`tail-rhs
|
||||
(Row-unmatch (car block))
|
||||
null)))
|
||||
#'failkv))))))]
|
||||
[else (error 'compile "unsupported pattern: ~a~n" first)]))
|
||||
[else (error 'compile "unsupported pattern: ~a~n" first)]))
|
||||
|
||||
(define (compile* vars rows esc)
|
||||
(define (let/wrap clauses body)
|
||||
(if (stx-null? clauses)
|
||||
body
|
||||
(quasisyntax (let* #,clauses #,body))))
|
||||
(if (stx-null? clauses)
|
||||
body
|
||||
(quasisyntax (let* #,clauses #,body))))
|
||||
(if (null? vars)
|
||||
;; if we have no variables, there are no more patterns to match
|
||||
;; so we just pick the first RHS
|
||||
(let ([fns
|
||||
(let loop ([blocks (reverse rows)] [esc esc] [acc null])
|
||||
(cond
|
||||
;; if we're done, return the blocks
|
||||
[(null? blocks) (reverse acc)]
|
||||
[else (with-syntax (;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous esc
|
||||
[c (with-syntax ([rhs #`(syntax-parameterize ([fail (make-rename-transformer (quote-syntax #,esc))])
|
||||
#,(Row-rhs (car blocks)))])
|
||||
(if
|
||||
(Row-unmatch (car blocks))
|
||||
#`(let/ec k
|
||||
(let ([#,(Row-unmatch (car blocks)) (lambda () (k (#,esc)))])
|
||||
rhs))
|
||||
#'rhs))])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))
|
||||
|
||||
;; otherwise, we split the matrix into blocks
|
||||
;; and compile each block with a reference to its continuation
|
||||
(let ([fns
|
||||
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
|
||||
(cond
|
||||
;; if we're done, return the blocks
|
||||
[(null? blocks) (reverse acc)]
|
||||
[else (with-syntax (;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous esc
|
||||
[c (compile-one vars (car blocks) esc)])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))])
|
||||
;; if we have no variables, there are no more patterns to match
|
||||
;; so we just pick the first RHS
|
||||
(let ([fns
|
||||
(let loop ([blocks (reverse rows)] [esc esc] [acc null])
|
||||
(if (null? blocks)
|
||||
;; if we're done, return the blocks
|
||||
(reverse acc)
|
||||
(with-syntax
|
||||
(;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous esc
|
||||
[c (with-syntax ([rhs #`(syntax-parameterize
|
||||
([fail (make-rename-transformer
|
||||
(quote-syntax #,esc))])
|
||||
#,(Row-rhs (car blocks)))])
|
||||
(if (Row-unmatch (car blocks))
|
||||
#`(let/ec k
|
||||
(let ([#,(Row-unmatch (car blocks))
|
||||
(lambda () (k (#,esc)))])
|
||||
rhs))
|
||||
#'rhs))])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))
|
||||
|
||||
;; otherwise, we split the matrix into blocks
|
||||
;; and compile each block with a reference to its continuation
|
||||
(let ([fns
|
||||
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
|
||||
(if (null? blocks)
|
||||
;; if we're done, return the blocks
|
||||
(reverse acc)
|
||||
(with-syntax (;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous
|
||||
;; esc
|
||||
[c (compile-one vars (car blocks) esc)])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;(trace compile* compile-one)
|
||||
;; (require mzlib/trace)
|
||||
;; (trace compile* compile-one)
|
||||
|
|
|
|||
|
|
@ -8,32 +8,29 @@
|
|||
|
||||
(provide define-forms)
|
||||
|
||||
(define-syntax-rule (define-forms parse-id
|
||||
match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
|
||||
(define-syntax-rule (define-forms parse-id
|
||||
match match* match-lambda match-lambda* match-let
|
||||
match-let* match-define match-letrec)
|
||||
(...
|
||||
(begin
|
||||
(provide match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
|
||||
(provide match match* match-lambda match-lambda* match-let match-let*
|
||||
match-define match-letrec)
|
||||
(define-syntax (match* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ es . clauses)
|
||||
(go parse-id stx #'es #'clauses (syntax-local-certifier))]))
|
||||
|
||||
|
||||
(define-syntax-rule (match arg [p . es] ...)
|
||||
(match* (arg)
|
||||
[(p) . es]
|
||||
...))
|
||||
|
||||
|
||||
(match* (arg) [(p) . es] ...))
|
||||
|
||||
(define-syntax (match-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(k . clauses)
|
||||
(syntax/loc stx (lambda (exp) (match exp . clauses)))]))
|
||||
|
||||
[(k . clauses) (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
|
||||
|
||||
(define-syntax (match-lambda* stx)
|
||||
(syntax-case stx ()
|
||||
[(k . clauses)
|
||||
(syntax/loc stx (lambda exp (match exp . clauses)))]))
|
||||
|
||||
[(k . clauses) (syntax/loc stx (lambda exp (match exp . clauses)))]))
|
||||
|
||||
(define-syntax (match-lambda** stx)
|
||||
(syntax-case stx ()
|
||||
[(k [pats . rhs] ...)
|
||||
|
|
@ -41,13 +38,14 @@
|
|||
[ps1 (car pss)]
|
||||
[len (length (syntax->list ps1))])
|
||||
(for/list ([ps pss])
|
||||
(unless (= (length (syntax->list ps)) len)
|
||||
(raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps ps1)))
|
||||
(unless (= (length (syntax->list ps)) len)
|
||||
(raise-syntax-error
|
||||
'match "unequal number of patterns in match clauses"
|
||||
stx ps ps1)))
|
||||
(with-syntax ([(vars ...) (generate-temporaries (car pss))])
|
||||
(syntax/loc stx (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
|
||||
|
||||
|
||||
|
||||
(syntax/loc stx
|
||||
(lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
|
||||
|
||||
;; there's lots of duplication here to handle named let
|
||||
;; some factoring out would do a lot of good
|
||||
(define-syntax (match-let stx)
|
||||
|
|
@ -58,36 +56,33 @@
|
|||
(match:syntax-err stx "bad syntax (empty body)")]
|
||||
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
||||
;; with no bindings, there's nothing to do
|
||||
[(_ name () body ...)
|
||||
[(_ name () body ...)
|
||||
(identifier? #'name)
|
||||
(syntax/loc stx (let name () body ...))]
|
||||
[(_ () body ...) (syntax/loc stx (let () body ...))]
|
||||
;; optimize the all-variable case
|
||||
;; optimize the all-variable case
|
||||
[(_ ([pat exp]...) body ...)
|
||||
(andmap pattern-var? (syntax->list #'(pat ...)))
|
||||
(syntax/loc stx (let name ([pat exp] ...) body ...))]
|
||||
(syntax/loc stx (let name ([pat exp] ...) body ...))]
|
||||
[(_ name ([pat exp]...) body ...)
|
||||
(and (identifier? (syntax name))
|
||||
(andmap pattern-var? (syntax->list #'(pat ...))))
|
||||
(syntax/loc stx (let name ([pat exp] ...) body ...))]
|
||||
;; now the real cases
|
||||
[(_ name ([pat exp] ...) . body)
|
||||
(syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))])
|
||||
(syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))])
|
||||
(name exp ...)))]
|
||||
[(_ ([pat exp] ...) . body)
|
||||
(syntax/loc stx (match* (exp ...) [(pat ...) . body]))]))
|
||||
|
||||
|
||||
(define-syntax (match-let* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
||||
((_ () body ...)
|
||||
(syntax/loc stx (let* () body ...)))
|
||||
((_ ([pat exp] rest ...) body ...)
|
||||
(syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)])))
|
||||
))
|
||||
|
||||
|
||||
|
||||
[(_ () body ...)
|
||||
(syntax/loc stx (let* () body ...))]
|
||||
[(_ ([pat exp] rest ...) body ...)
|
||||
(syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))]))
|
||||
|
||||
(define-syntax (match-letrec stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
||||
|
|
@ -96,12 +91,8 @@
|
|||
(syntax->list #'(pat ...)))
|
||||
(syntax/loc stx (letrec ([pat exp] ...) . body))]
|
||||
[(_ ([pat exp] ...) . body)
|
||||
(syntax/loc stx (let ()
|
||||
(match-define pat exp) ...
|
||||
. body))]))
|
||||
|
||||
|
||||
|
||||
(syntax/loc stx (let () (match-define pat exp) ... . body))]))
|
||||
|
||||
(define-syntax (match-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
|
|
@ -112,6 +103,4 @@
|
|||
(let ([p (parse-id #'pat (syntax-local-certifier))])
|
||||
(with-syntax ([vars (bound-vars p)])
|
||||
(syntax/loc stx
|
||||
(define-values vars
|
||||
(match rhs
|
||||
[pat (values . vars)])))))])))))
|
||||
(define-values vars (match rhs [pat (values . vars)])))))])))))
|
||||
|
|
|
|||
|
|
@ -10,37 +10,51 @@
|
|||
;; go : syntax syntax syntax certifier -> syntax
|
||||
(define (go parse/cert stx exprs clauses cert)
|
||||
(parameterize ([orig-stx stx])
|
||||
(syntax-case clauses ()
|
||||
[([pats . rhs] ...)
|
||||
(let ([len (length (syntax->list exprs))])
|
||||
(with-syntax ([(xs ...) (generate-temporaries exprs)]
|
||||
[(exprs ...) exprs]
|
||||
[(fail) (generate-temporaries #'(fail))])
|
||||
(with-syntax ([body (compile* (syntax->list #'(xs ...))
|
||||
(map (lambda (pats rhs)
|
||||
(unless (= len (length (syntax->list pats)))
|
||||
(raise-syntax-error 'match
|
||||
(format "wrong number of match clauses, expected ~a and got ~a"
|
||||
len (length (syntax->list pats)))
|
||||
pats))
|
||||
(syntax-case* rhs (=>)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[((=> unm) . rhs)
|
||||
(make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats))
|
||||
#`(begin . rhs)
|
||||
#'unm
|
||||
null)]
|
||||
[_
|
||||
(make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats))
|
||||
#`(begin . #,rhs)
|
||||
#f
|
||||
null)]))
|
||||
(syntax->list #'(pats ...))
|
||||
(syntax->list #'(rhs ...)))
|
||||
#'fail)]
|
||||
[orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))])
|
||||
(quasisyntax/loc stx
|
||||
(let ([xs exprs]
|
||||
...)
|
||||
(let ([fail (lambda () #,(syntax/loc stx (match:error orig-expr)))])
|
||||
body))))))])))
|
||||
(syntax-case clauses ()
|
||||
[([pats . rhs] ...)
|
||||
(let ([len (length (syntax->list exprs))])
|
||||
(with-syntax ([(xs ...) (generate-temporaries exprs)]
|
||||
[(exprs ...) exprs]
|
||||
[(fail) (generate-temporaries #'(fail))])
|
||||
(with-syntax ([body (compile*
|
||||
(syntax->list #'(xs ...))
|
||||
(map (lambda (pats rhs)
|
||||
(unless (= len
|
||||
(length (syntax->list pats)))
|
||||
(raise-syntax-error
|
||||
'match
|
||||
(format "~a, expected ~a and got ~a"
|
||||
"wrong number of match clauses"
|
||||
len
|
||||
(length (syntax->list pats)))
|
||||
pats))
|
||||
(syntax-case* rhs (=>)
|
||||
(lambda (x y)
|
||||
(eq? (syntax-e x)
|
||||
(syntax-e y)))
|
||||
[((=> unm) . rhs)
|
||||
(make-Row (map (lambda (s)
|
||||
(parse/cert s cert))
|
||||
(syntax->list pats))
|
||||
#`(begin . rhs)
|
||||
#'unm
|
||||
null)]
|
||||
[_
|
||||
(make-Row (map (lambda (s)
|
||||
(parse/cert s cert))
|
||||
(syntax->list pats))
|
||||
#`(begin . #,rhs)
|
||||
#f
|
||||
null)]))
|
||||
(syntax->list #'(pats ...))
|
||||
(syntax->list #'(rhs ...)))
|
||||
#'fail)]
|
||||
[orig-expr (if (= 1 len)
|
||||
(stx-car #'(xs ...))
|
||||
#'(list xs ...))])
|
||||
(quasisyntax/loc stx
|
||||
(let ([xs exprs]
|
||||
...)
|
||||
(let ([fail (lambda ()
|
||||
#,(syntax/loc stx (match:error orig-expr)))])
|
||||
body))))))])))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,22 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?)
|
||||
(only-in "match-expander.ss" define-match-expander)
|
||||
(require (only-in "patterns.ss"
|
||||
match-equality-test
|
||||
match-...-nesting
|
||||
exn:misc:match?)
|
||||
(only-in "match-expander.ss"
|
||||
define-match-expander)
|
||||
"define-forms.ss"
|
||||
(for-syntax "parse-legacy.ss" "gen-match.ss")
|
||||
(for-syntax (only-in "patterns.ss" match-...-nesting)))
|
||||
(for-syntax "parse-legacy.ss"
|
||||
"gen-match.ss"
|
||||
(only-in "patterns.ss" match-...-nesting)))
|
||||
|
||||
(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?)
|
||||
(provide (for-syntax match-...-nesting)
|
||||
match-equality-test
|
||||
match-...-nesting
|
||||
define-match-expander
|
||||
exn:misc:match?)
|
||||
|
||||
(define-forms parse/legacy/cert
|
||||
match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
|
||||
match match* match-lambda match-lambda* match-let match-let*
|
||||
match-define match-letrec)
|
||||
|
|
|
|||
|
|
@ -12,19 +12,19 @@
|
|||
(define (parse args)
|
||||
(let loop ([args args]
|
||||
[alist '()])
|
||||
(if (null? args)
|
||||
alist
|
||||
(let* ([stx-v (car args)]
|
||||
[v (syntax-e stx-v)])
|
||||
(cond
|
||||
[(not (keyword? v))
|
||||
(raise-syntax-error #f "Argument must be a keyword" stx stx-v)]
|
||||
[(not (memq v '(#:expression #:plt-match #:match)))
|
||||
(raise-syntax-error #f (format "Keyword argument ~a is not a correct keyword" v) stx stx-v)]
|
||||
[else
|
||||
(loop (cddr args)
|
||||
(cons (list v (cadr args))
|
||||
alist))])))))
|
||||
(if (null? args)
|
||||
alist
|
||||
(let* ([stx-v (car args)]
|
||||
[v (syntax-e stx-v)])
|
||||
(cond
|
||||
[(not (keyword? v))
|
||||
(raise-syntax-error #f "argument must be a keyword" stx stx-v)]
|
||||
[(not (memq v '(#:expression #:plt-match #:match)))
|
||||
(raise-syntax-error
|
||||
#f (format "keyword argument ~a is not a correct keyword" v)
|
||||
stx stx-v)]
|
||||
[else
|
||||
(loop (cddr args) (cons (list v (cadr args)) alist))])))))
|
||||
(syntax-case stx ()
|
||||
[(_ id kw . rest)
|
||||
(keyword? (syntax-e #'kw))
|
||||
|
|
@ -33,29 +33,36 @@
|
|||
(with-syntax
|
||||
([legacy-xform (lookup '#:match parsed-args)]
|
||||
[match-xform (lookup '#:plt-match parsed-args)]
|
||||
[macro-xform (or (lookup '#:expression parsed-args)
|
||||
#'(lambda (stx)
|
||||
(raise-syntax-error #f "This match expander must be used inside match" stx)))])
|
||||
[macro-xform
|
||||
(or (lookup '#:expression parsed-args)
|
||||
#'(lambda (stx)
|
||||
(raise-syntax-error
|
||||
#f "this match expander must be used inside match"
|
||||
stx)))])
|
||||
(if (identifier? #'macro-xform)
|
||||
(syntax/loc stx
|
||||
(define-syntax id (make-match-expander match-xform
|
||||
legacy-xform
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(nm args (... ...)) #'(macro-xform args (... ...))]
|
||||
[nm #'macro-xform]))
|
||||
(syntax-local-certifier))))
|
||||
(syntax/loc stx
|
||||
(define-syntax id (make-match-expander match-xform legacy-xform macro-xform (syntax-local-certifier)))))))]
|
||||
|
||||
(syntax/loc stx
|
||||
(define-syntax id
|
||||
(make-match-expander
|
||||
match-xform
|
||||
legacy-xform
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(nm args (... ...)) #'(macro-xform args (... ...))]
|
||||
[nm #'macro-xform]))
|
||||
(syntax-local-certifier))))
|
||||
(syntax/loc stx
|
||||
(define-syntax id
|
||||
(make-match-expander match-xform legacy-xform macro-xform
|
||||
(syntax-local-certifier)))))))]
|
||||
;; implement legacy syntax
|
||||
[(_ id plt-match-xform match-xform std-xform)
|
||||
#'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)]
|
||||
#'(define-match-expander id #:plt-match plt-match-xform
|
||||
#:match match-xform
|
||||
#:expression std-xform)]
|
||||
[(_ id plt-match-xform std-xform)
|
||||
#'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)]
|
||||
[(_ id plt-match-xform)
|
||||
#'(define-match-expander id #:plt-match plt-match-xform
|
||||
#:expression std-xform)]
|
||||
[(_ id plt-match-xform)
|
||||
#'(define-match-expander id #:plt-match plt-match-xform)]
|
||||
|
||||
;; error checking
|
||||
[_ (raise-syntax-error #f "Invalid use of define-match-expander" stx)]
|
||||
))
|
||||
[_ (raise-syntax-error #f "invalid use of define-match-expander" stx)]))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,22 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?)
|
||||
(only-in "match-expander.ss" define-match-expander)
|
||||
(require (only-in "patterns.ss"
|
||||
match-equality-test
|
||||
match-...-nesting
|
||||
exn:misc:match?)
|
||||
(only-in "match-expander.ss"
|
||||
define-match-expander)
|
||||
"define-forms.ss"
|
||||
(for-syntax "parse.ss" "gen-match.ss")
|
||||
(for-syntax (only-in "patterns.ss" match-...-nesting)))
|
||||
(for-syntax "parse.ss"
|
||||
"gen-match.ss"
|
||||
(only-in "patterns.ss" match-...-nesting)))
|
||||
|
||||
(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?)
|
||||
(provide (for-syntax match-...-nesting)
|
||||
match-equality-test
|
||||
match-...-nesting
|
||||
define-match-expander
|
||||
exn:misc:match?)
|
||||
|
||||
(define-forms parse/cert
|
||||
match match* match-lambda match-lambda* match-let match-let* match-define match-letrec)
|
||||
match match* match-lambda match-lambda* match-let match-let*
|
||||
match-define match-letrec)
|
||||
|
|
|
|||
|
|
@ -8,16 +8,17 @@
|
|||
"compiler.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
|
||||
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
|
||||
match-expander-transform matchable? trans-match parse-struct
|
||||
dd-parse parse-quote parse-id)
|
||||
|
||||
;; parse x as a match variable
|
||||
;; x : identifier
|
||||
(define (parse-id x)
|
||||
(define (parse-id x)
|
||||
(cond [(eq? '_ (syntax-e x))
|
||||
(make-Dummy x)]
|
||||
[(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" #'x)]
|
||||
[(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern"
|
||||
#'x)]
|
||||
[else (make-Var x)]))
|
||||
|
||||
;; stx : syntax of pattern, starting with quote
|
||||
|
|
@ -32,15 +33,14 @@
|
|||
[(quote vec)
|
||||
(vector? (syntax-e #'vec))
|
||||
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
|
||||
(parse (quasisyntax/loc stx (quote #,e)))))]
|
||||
(parse (quasisyntax/loc stx (quote #,e)))))]
|
||||
[(quote bx)
|
||||
(vector? (syntax-e #'bx))
|
||||
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))]
|
||||
[(quote v)
|
||||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
|
||||
[_
|
||||
(raise-syntax-error 'match "syntax error in quote pattern" stx)]))
|
||||
[_ (raise-syntax-error 'match "syntax error in quote pattern" stx)]))
|
||||
|
||||
;; parse : the parse fn
|
||||
;; p : the repeated pattern
|
||||
|
|
@ -48,16 +48,15 @@
|
|||
;; rest : the syntax for the rest
|
||||
(define (dd-parse parse p dd rest)
|
||||
(let* ([count (ddk? dd)]
|
||||
[min (if (number? count) count #f)])
|
||||
(make-GSeq
|
||||
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
|
||||
(list (list (parse p))))
|
||||
(list min)
|
||||
;; no upper bound
|
||||
(list #f)
|
||||
;; patterns in p get bound to lists
|
||||
(list #f)
|
||||
(parse rest))))
|
||||
[min (and (number? count) count)])
|
||||
(make-GSeq (parameterize ([match-...-nesting (add1 (match-...-nesting))])
|
||||
(list (list (parse p))))
|
||||
(list min)
|
||||
;; no upper bound
|
||||
(list #f)
|
||||
;; patterns in p get bound to lists
|
||||
(list #f)
|
||||
(parse rest))))
|
||||
|
||||
;; stx : the syntax object for the whole pattern
|
||||
;; cert : the certifier
|
||||
|
|
@ -66,34 +65,44 @@
|
|||
;; pats : syntax representing the member patterns
|
||||
;; returns a pattern
|
||||
(define (parse-struct stx cert parse struct-name pats)
|
||||
(let* ([fail (lambda ()
|
||||
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum struct-name)) stx struct-name))]
|
||||
(let* ([fail (lambda ()
|
||||
(raise-syntax-error
|
||||
'match (format "~a does not refer to a structure definition"
|
||||
(syntax->datum struct-name))
|
||||
stx struct-name))]
|
||||
[v (syntax-local-value (cert struct-name) fail)])
|
||||
(unless (struct-info? v)
|
||||
(fail))
|
||||
(let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))])
|
||||
(unless (struct-info? v) (fail))
|
||||
(let-values ([(id _1 pred acc _2 super)
|
||||
(apply values (extract-struct-info v))])
|
||||
;; this produces a list of all the super-types of this struct
|
||||
;; ending when it reaches the top of the hierarchy, or a struct that we can't access
|
||||
;; ending when it reaches the top of the hierarchy, or a struct that we
|
||||
;; can't access
|
||||
(define (get-lineage struct-name)
|
||||
(let ([super (list-ref
|
||||
(extract-struct-info (syntax-local-value struct-name))
|
||||
5)])
|
||||
(let ([super (list-ref (extract-struct-info (syntax-local-value
|
||||
struct-name))
|
||||
5)])
|
||||
(cond [(equal? super #t) '()] ;; no super type exists
|
||||
[(equal? super #f) '()] ;; super type is unknown
|
||||
[else (cons super (get-lineage super))])))
|
||||
(let* (;; the accessors come in reverse order
|
||||
[acc (reverse acc)]
|
||||
;; remove the first element, if it's #f
|
||||
[acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])])
|
||||
(make-Struct id pred (get-lineage (cert struct-name)) acc
|
||||
[acc (cond [(null? acc) acc]
|
||||
[(not (car acc)) (cdr acc)]
|
||||
[else acc])])
|
||||
(make-Struct id pred (get-lineage (cert struct-name)) acc
|
||||
(if (eq? '_ (syntax-e pats))
|
||||
(map make-Dummy acc)
|
||||
(let* ([ps (syntax->list pats)])
|
||||
(unless (= (length ps) (length acc))
|
||||
(raise-syntax-error 'match (format "wrong number for fields for structure ~a: expected ~a but got ~a"
|
||||
(syntax->datum struct-name) (length acc) (length ps))
|
||||
stx pats))
|
||||
(map parse ps))))))))
|
||||
(map make-Dummy acc)
|
||||
(let* ([ps (syntax->list pats)])
|
||||
(unless (= (length ps) (length acc))
|
||||
(raise-syntax-error
|
||||
'match
|
||||
(format "~a structure ~a: expected ~a but got ~a"
|
||||
"wrong number for fields for"
|
||||
(syntax->datum struct-name) (length acc)
|
||||
(length ps))
|
||||
stx pats))
|
||||
(map parse ps))))))))
|
||||
|
||||
(define (trans-match pred transformer pat)
|
||||
(make-And (list (make-Pred pred) (make-App transformer pat))))
|
||||
|
|
@ -106,9 +115,10 @@
|
|||
;; accessor : match-expander -> syntax transformer/#f
|
||||
;; error-msg : string
|
||||
;; produces a parsed pattern
|
||||
(define (match-expander-transform parse/cert cert expander stx accessor error-msg)
|
||||
(define (match-expander-transform parse/cert cert expander stx accessor
|
||||
error-msg)
|
||||
(let* ([expander (syntax-local-value (cert expander))]
|
||||
[transformer (accessor expander)])
|
||||
[transformer (accessor expander)])
|
||||
(unless transformer (raise-syntax-error #f error-msg #'expander))
|
||||
(let* ([introducer (make-syntax-introducer)]
|
||||
[certifier (match-expander-certifier expander)]
|
||||
|
|
@ -122,7 +132,6 @@
|
|||
(define (matchable? e)
|
||||
(or (string? e) (bytes? e)))
|
||||
|
||||
|
||||
;; raise an error, blaming stx
|
||||
(define (match:syntax-err stx msg)
|
||||
(raise-syntax-error #f msg stx))
|
||||
|
|
@ -130,67 +139,56 @@
|
|||
;; pattern-var? : syntax -> bool
|
||||
;; is p an identifier representing a pattern variable?
|
||||
(define (pattern-var? p)
|
||||
(and (identifier? p)
|
||||
(not (ddk? p))))
|
||||
(and (identifier? p) (not (ddk? p))))
|
||||
|
||||
;; ddk? : syntax -> number or boolean
|
||||
;; if #f is returned, was not a ddk identifier
|
||||
;; if #t is returned, no minimum
|
||||
;; if a number is returned, that's the minimum
|
||||
(define (ddk? s*)
|
||||
(define (./_ c)
|
||||
(or (equal? c #\.)
|
||||
(equal? c #\_)))
|
||||
(define (./_ c) (or (equal? c #\.) (equal? c #\_)))
|
||||
(let ([s (syntax->datum s*)])
|
||||
(and (symbol? s)
|
||||
(if (memq s '(... ___)) #t
|
||||
(let* ((s (symbol->string s)))
|
||||
(and (3 . <= . (string-length s))
|
||||
(./_ (string-ref s 0))
|
||||
(./_ (string-ref s 1))
|
||||
(let ([n (string->number (substring s 2))])
|
||||
(cond
|
||||
[(not n) #f]
|
||||
[(zero? n) #t]
|
||||
[(exact-nonnegative-integer? n) n]
|
||||
[else (raise-syntax-error 'match "invalid number for ..k pattern" s*)]))))))))
|
||||
|
||||
(if (memq s '(... ___))
|
||||
#t
|
||||
(let* ([m (regexp-match #rx"^(?:\\.\\.|__)([0-9]+)$"
|
||||
(symbol->string s))]
|
||||
[n (and m (string->number (cadr m)))])
|
||||
(cond [(not n) #f]
|
||||
[(zero? n) #t]
|
||||
[(exact-nonnegative-integer? n) n]
|
||||
[else (raise-syntax-error
|
||||
'match "invalid number for ..k pattern"
|
||||
s*)]))))))
|
||||
|
||||
;; parse-literal : scheme-val -> pat option
|
||||
;; is v is a literal, return a pattern matching it
|
||||
;; otherwise, return #f
|
||||
(define (parse-literal v)
|
||||
(if (or (number? v)
|
||||
(string? v)
|
||||
(keyword? v)
|
||||
(symbol? v)
|
||||
(bytes? v)
|
||||
(regexp? v)
|
||||
(boolean? v)
|
||||
(char? v))
|
||||
(make-Exact v)
|
||||
#f))
|
||||
(if (or (number? v) (string? v) (keyword? v) (symbol? v) (bytes? v)
|
||||
(regexp? v) (boolean? v) (char? v))
|
||||
(make-Exact v)
|
||||
#f))
|
||||
|
||||
;; (listof pat) syntax -> void
|
||||
;; check that all the ps bind the same set of variables
|
||||
(define (all-vars ps stx)
|
||||
(when (null? ps)
|
||||
(error 'bad))
|
||||
(when (null? ps) (error 'bad))
|
||||
(let* ([first-vars (bound-vars (car ps))]
|
||||
[l (length ps)]
|
||||
[ht (make-free-identifier-mapping)])
|
||||
(for-each (lambda (v) (free-identifier-mapping-put! ht v 1)) first-vars)
|
||||
(for-each (lambda (p)
|
||||
(for-each (lambda (v)
|
||||
(cond [(free-identifier-mapping-get ht v (lambda () #f))
|
||||
=>
|
||||
(lambda (n)
|
||||
(free-identifier-mapping-put! ht v (add1 n)))]
|
||||
[else (raise-syntax-error 'match "variable not bound in all or patterns" stx v)]))
|
||||
(bound-vars p)))
|
||||
(cdr ps))
|
||||
(for ([v first-vars]) (free-identifier-mapping-put! ht v 1))
|
||||
(for* ([p (cdr ps)]
|
||||
[v (bound-vars p)])
|
||||
(cond [(free-identifier-mapping-get ht v (lambda () #f))
|
||||
=> (lambda (n)
|
||||
(free-identifier-mapping-put! ht v (add1 n)))]
|
||||
[else (raise-syntax-error 'match
|
||||
"variable not bound in all or patterns"
|
||||
stx v)]))
|
||||
(free-identifier-mapping-for-each
|
||||
ht
|
||||
(lambda (v n)
|
||||
(unless (= n l)
|
||||
(raise-syntax-error 'match "variable not bound in all or patterns" stx v))))))
|
||||
(raise-syntax-error 'match "variable not bound in all or patterns"
|
||||
stx v))))))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
syntax/stx
|
||||
scheme/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
"compiler.ss"
|
||||
"parse-helper.ss"
|
||||
"parse-quasi.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
|
@ -15,13 +15,14 @@
|
|||
(define (parse/legacy/cert stx cert)
|
||||
(define (parse stx) (parse/legacy/cert stx cert))
|
||||
(syntax-case* stx (not $ ? and or = quasiquote quote)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[(expander args ...)
|
||||
(and (identifier? #'expander)
|
||||
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
(match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform
|
||||
"This expander only works with the standard match syntax")]
|
||||
(match-expander?
|
||||
(syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
(match-expander-transform
|
||||
parse/legacy/cert cert #'expander stx match-expander-legacy-xform
|
||||
"This expander only works with the standard match syntax")]
|
||||
[(and p ...)
|
||||
(make-And (map parse (syntax->list #'(p ...))))]
|
||||
[(or p ...)
|
||||
|
|
@ -32,19 +33,21 @@
|
|||
;; nots are conjunctions of negations
|
||||
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
|
||||
(make-And ps))]
|
||||
[bx
|
||||
[bx
|
||||
(box? (syntax-e #'bx))
|
||||
(make-Box (parse (unbox (syntax-e #'bx))))]
|
||||
[#(es ...)
|
||||
(ormap ddk? (syntax->list #'(es ...)))
|
||||
(make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (es ...))))))]
|
||||
(make-And (list (make-Pred #'vector?)
|
||||
(make-App #'vector->list
|
||||
(parse (syntax/loc stx (es ...))))))]
|
||||
[#(es ...)
|
||||
(make-Vector (map parse (syntax->list #'(es ...))))]
|
||||
|
||||
(make-Vector (map parse (syntax->list #'(es ...))))]
|
||||
[($ s . pats)
|
||||
(parse-struct stx cert parse #'s #'pats)]
|
||||
[(? p q1 qs ...)
|
||||
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
|
||||
(make-And (cons (make-Pred (cert #'p))
|
||||
(map parse (syntax->list #'(q1 qs ...)))))]
|
||||
[(? p)
|
||||
(make-Pred (cert #'p))]
|
||||
[(= f p)
|
||||
|
|
@ -61,7 +64,7 @@
|
|||
(ddk? #'..)
|
||||
(dd-parse parse #'p #'.. #'rest)]
|
||||
[(e . es)
|
||||
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
|
||||
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
(parse-id #'x)]
|
||||
|
|
|
|||
|
|
@ -13,23 +13,19 @@
|
|||
|
||||
;; is pat a pattern representing a list?
|
||||
(define (null-terminated? pat)
|
||||
(cond [(Pair? pat)
|
||||
(null-terminated? (Pair-d pat))]
|
||||
[(GSeq? pat)
|
||||
(null-terminated? (GSeq-tail pat))]
|
||||
(cond [(Pair? pat) (null-terminated? (Pair-d pat))]
|
||||
[(GSeq? pat) (null-terminated? (GSeq-tail pat))]
|
||||
[(Null? pat) #t]
|
||||
[else #f]))
|
||||
|
||||
;; combine a null-terminated pattern with another pattern to match afterwards
|
||||
(define (append-pats p1 p2)
|
||||
(cond [(Pair? p1)
|
||||
(make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))]
|
||||
[(GSeq? p1)
|
||||
(make-GSeq (GSeq-headss p1)
|
||||
(GSeq-mins p1)
|
||||
(GSeq-maxs p1)
|
||||
(GSeq-onces? p1)
|
||||
(append-pats (GSeq-tail p1) p2))]
|
||||
(cond [(Pair? p1) (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))]
|
||||
[(GSeq? p1) (make-GSeq (GSeq-headss p1)
|
||||
(GSeq-mins p1)
|
||||
(GSeq-maxs p1)
|
||||
(GSeq-onces? p1)
|
||||
(append-pats (GSeq-tail p1) p2))]
|
||||
[(Null? p1) p2]
|
||||
[else (error 'match "illegal input to append-pats")]))
|
||||
|
||||
|
|
@ -38,19 +34,20 @@
|
|||
(define (parse-quasi stx cert parse/cert)
|
||||
(define (pq s) (parse-quasi s cert parse/cert))
|
||||
(syntax-case stx (quasiquote unquote quote unquote-splicing)
|
||||
[(unquote p) (parse/cert #'p cert)]
|
||||
[(unquote p) (parse/cert #'p cert)]
|
||||
[((unquote-splicing p) . rest)
|
||||
(let ([pat (parse/cert #'p cert)]
|
||||
[rpat (pq #'rest)])
|
||||
(if (null-terminated? pat)
|
||||
(append-pats pat rpat)
|
||||
(raise-syntax-error 'match "non-list pattern inside unquote-splicing" stx #'p)))]
|
||||
(append-pats pat rpat)
|
||||
(raise-syntax-error 'match "non-list pattern inside unquote-splicing"
|
||||
stx #'p)))]
|
||||
[(p dd)
|
||||
(ddk? #'dd)
|
||||
(let* ([count (ddk? #'..)]
|
||||
[min (if (number? count) count #f)]
|
||||
[max (if (number? count) count #f)])
|
||||
(make-GSeq
|
||||
(make-GSeq
|
||||
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
|
||||
(list (list (pq #'p))))
|
||||
(list min)
|
||||
|
|
@ -68,10 +65,9 @@
|
|||
[(unquote-splicing . _) #t]
|
||||
[_ #f])))
|
||||
(syntax->list #'(p ...)))
|
||||
(make-And (list
|
||||
(make-Pred #'vector?)
|
||||
(make-App #'vector->list
|
||||
(pq (quasisyntax/loc stx (p ...))))))]
|
||||
(make-And (list (make-Pred #'vector?)
|
||||
(make-App #'vector->list
|
||||
(pq (quasisyntax/loc stx (p ...))))))]
|
||||
[#(p ...)
|
||||
(make-Vector (map pq (syntax->list #'(p ...))))]
|
||||
[bx
|
||||
|
|
@ -81,4 +77,4 @@
|
|||
(make-Null (make-Dummy #f))]
|
||||
[v
|
||||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "syntax error in quasipattern" stx))]))
|
||||
(raise-syntax-error 'match "syntax error in quasipattern" stx))]))
|
||||
|
|
|
|||
|
|
@ -13,26 +13,26 @@
|
|||
|
||||
(provide parse/cert)
|
||||
|
||||
(define (ht-pat-transform p)
|
||||
(define (ht-pat-transform p)
|
||||
(syntax-case p ()
|
||||
[(a b) #'(list a b)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'x]))
|
||||
[x (identifier? #'x) #'x]))
|
||||
|
||||
;; parse : syntax -> Pat
|
||||
;; compile stx into a pattern, using the new syntax
|
||||
(define (parse/cert stx cert)
|
||||
(define (parse stx) (parse/cert stx cert))
|
||||
(syntax-case* stx (not var struct box cons list vector ? and or quote app regexp pregexp
|
||||
list-rest list-no-order hash-table quasiquote mcons list*)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
|
||||
(syntax-case* stx (not var struct box cons list vector ? and or quote app
|
||||
regexp pregexp list-rest list-no-order hash-table
|
||||
quasiquote mcons list*)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[(expander args ...)
|
||||
(and (identifier? #'expander)
|
||||
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
(match-expander-transform parse/cert cert #'expander stx match-expander-match-xform
|
||||
"This expander only works with the legacy match syntax")]
|
||||
(match-expander? (syntax-local-value (cert #'expander)
|
||||
(lambda () #f))))
|
||||
(match-expander-transform
|
||||
parse/cert cert #'expander stx match-expander-match-xform
|
||||
"This expander only works with the legacy match syntax")]
|
||||
[(var v)
|
||||
(identifier? #'v)
|
||||
(make-Var #'v)]
|
||||
|
|
@ -47,17 +47,27 @@
|
|||
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
|
||||
(make-And ps))]
|
||||
[(regexp r)
|
||||
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (make-Pred #'values))]
|
||||
(trans-match #'matchable?
|
||||
#'(lambda (e) (regexp-match r e))
|
||||
(make-Pred #'values))]
|
||||
[(regexp r p)
|
||||
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
|
||||
[(pregexp r)
|
||||
(trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (make-Pred #'values))]
|
||||
(trans-match #'matchable?
|
||||
#'(lambda (e)
|
||||
(regexp-match (if (pregexp? r) r (pregexp r)) e))
|
||||
(make-Pred #'values))]
|
||||
[(pregexp r p)
|
||||
(trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (parse #'p))]
|
||||
[(box e) (make-Box (parse #'e))]
|
||||
(trans-match #'matchable?
|
||||
#'(lambda (e)
|
||||
(regexp-match (if (pregexp? r) r (pregexp r)) e))
|
||||
(parse #'p))]
|
||||
[(box e) (make-Box (parse #'e))]
|
||||
[(vector es ...)
|
||||
(ormap ddk? (syntax->list #'(es ...)))
|
||||
(trans-match #'vector? #'vector->list (parse (syntax/loc stx (list es ...))))]
|
||||
(trans-match #'vector?
|
||||
#'vector->list
|
||||
(parse (syntax/loc stx (list es ...))))]
|
||||
[(vector es ...)
|
||||
(make-Vector (map parse (syntax->list #'(es ...))))]
|
||||
[(hash-table p ... dd)
|
||||
|
|
@ -65,49 +75,50 @@
|
|||
(trans-match
|
||||
#'hash-table?
|
||||
#'(lambda (e) (hash-table-map e list))
|
||||
(with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
|
||||
(with-syntax ([(elems ...)
|
||||
(map ht-pat-transform (syntax->list #'(p ...)))])
|
||||
(parse (syntax/loc stx (list-no-order elems ... dd)))))]
|
||||
[(hash-table p ...)
|
||||
(ormap ddk? (syntax->list #'(p ...)))
|
||||
(raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx
|
||||
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
||||
(ormap ddk? (syntax->list #'(p ...)))
|
||||
(raise-syntax-error
|
||||
'match "dot dot k can only appear at the end of hash-table patterns" stx
|
||||
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
||||
[(hash-table p ...)
|
||||
(trans-match
|
||||
#'hash-table?
|
||||
#'(lambda (e) (hash-table-map e list))
|
||||
(with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))])
|
||||
(parse (syntax/loc stx (list-no-order elems ...)))))]
|
||||
(trans-match #'hash-table?
|
||||
#'(lambda (e) (hash-table-map e list))
|
||||
(with-syntax ([(elems ...)
|
||||
(map ht-pat-transform
|
||||
(syntax->list #'(p ...)))])
|
||||
(parse (syntax/loc stx (list-no-order elems ...)))))]
|
||||
[(hash-table . _)
|
||||
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
|
||||
[(list-no-order p ... lp dd)
|
||||
(ddk? #'dd)
|
||||
(ddk? #'dd)
|
||||
(let* ([count (ddk? #'dd)]
|
||||
[min (if (number? count) count #f)]
|
||||
[max (if (number? count) count #f)]
|
||||
[ps (syntax->list #'(p ...))])
|
||||
(make-GSeq
|
||||
(cons (list (parse #'lp))
|
||||
(for/list ([p ps])
|
||||
(list (parse p))))
|
||||
(cons min (map (lambda _ 1) ps))
|
||||
(cons max (map (lambda _ 1) ps))
|
||||
;; vars in lp are lists, vars elsewhere are not
|
||||
(cons #f (map (lambda _ #t) ps))
|
||||
(make-Null (make-Dummy #f))))]
|
||||
(make-GSeq (cons (list (parse #'lp))
|
||||
(for/list ([p ps]) (list (parse p))))
|
||||
(cons min (map (lambda _ 1) ps))
|
||||
(cons max (map (lambda _ 1) ps))
|
||||
;; vars in lp are lists, vars elsewhere are not
|
||||
(cons #f (map (lambda _ #t) ps))
|
||||
(make-Null (make-Dummy #f))))]
|
||||
[(list-no-order p ...)
|
||||
(ormap ddk? (syntax->list #'(p ...)))
|
||||
(raise-syntax-error 'match "dot dot k can only appear at the end of unordered match patterns" stx
|
||||
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
||||
(raise-syntax-error
|
||||
'match "dot dot k can only appear at the end of unordered match patterns"
|
||||
stx
|
||||
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
|
||||
[(list-no-order p ...)
|
||||
(let ([ps (syntax->list #'(p ...))])
|
||||
(make-GSeq
|
||||
(for/list ([p ps])
|
||||
(list (parse p)))
|
||||
(map (lambda _ 1) ps)
|
||||
(map (lambda _ 1) ps)
|
||||
;; all of these patterns get bound to only one thing
|
||||
(map (lambda _ #t) ps)
|
||||
(make-Null (make-Dummy #f))))]
|
||||
(make-GSeq (for/list ([p ps]) (list (parse p)))
|
||||
(map (lambda _ 1) ps)
|
||||
(map (lambda _ 1) ps)
|
||||
;; all of these patterns get bound to only one thing
|
||||
(map (lambda _ #t) ps)
|
||||
(make-Null (make-Dummy #f))))]
|
||||
[(list) (make-Null (make-Dummy stx))]
|
||||
[(list ..)
|
||||
(ddk? #'..)
|
||||
|
|
@ -131,7 +142,8 @@
|
|||
[(struct s pats)
|
||||
(parse-struct stx cert parse #'s #'pats)]
|
||||
[(? p q1 qs ...)
|
||||
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
|
||||
(make-And (cons (make-Pred (cert #'p))
|
||||
(map parse (syntax->list #'(q1 qs ...)))))]
|
||||
[(? p)
|
||||
(make-Pred (cert #'p))]
|
||||
[(app f p)
|
||||
|
|
@ -149,8 +161,4 @@
|
|||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "syntax error in pattern" stx))]))
|
||||
|
||||
;(trace parse)
|
||||
|
||||
|
||||
|
||||
|
||||
;; (trace parse)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/boundmap
|
||||
mzlib/trace
|
||||
scheme/stxparam
|
||||
scheme/contract
|
||||
(for-syntax scheme/base))
|
||||
|
|
@ -14,10 +13,11 @@
|
|||
exn:misc:match?)
|
||||
|
||||
(define-struct (exn:misc:match exn:fail) (value))
|
||||
|
||||
(define (match:error val) (raise (make-exn:misc:match (format "match: no matching clause for ~e" val)
|
||||
(current-continuation-marks)
|
||||
val)))
|
||||
|
||||
(define (match:error val)
|
||||
(raise (make-exn:misc:match (format "match: no matching clause for ~e" val)
|
||||
(current-continuation-marks)
|
||||
val)))
|
||||
|
||||
(define orig-stx (make-parameter #f))
|
||||
|
||||
|
|
@ -31,8 +31,7 @@
|
|||
(define-struct (Dummy Var) ()
|
||||
#:transparent
|
||||
#:property
|
||||
prop:custom-write (lambda (v p w?)
|
||||
(fprintf p "_")))
|
||||
prop:custom-write (lambda (v p w?) (fprintf p "_")))
|
||||
|
||||
;; constructor patterns
|
||||
(define-struct (CPat Pat) () #:transparent)
|
||||
|
|
@ -84,7 +83,8 @@
|
|||
;; headss : listof listof pattern
|
||||
;; mins : listof option number
|
||||
;; maxs : listof option number
|
||||
;; onces? : listof boolean -- is this pattern being bound only once (take the car of the variables)
|
||||
;; onces? : listof boolean -- is this pattern being bound only once (take the
|
||||
;; car of the variables)
|
||||
;; tail : pattern
|
||||
(define-struct (GSeq Pat) (headss mins maxs onces? tail) #:transparent)
|
||||
|
||||
|
|
@ -98,14 +98,12 @@
|
|||
;; vars-seen is a listof identifiers
|
||||
(define-struct Row (pats rhs unmatch vars-seen) #:transparent
|
||||
#:property
|
||||
prop:custom-write (lambda (v p w?)
|
||||
(fprintf p "(Row ~a <expr>)" (Row-pats v))))
|
||||
|
||||
|
||||
prop:custom-write
|
||||
(lambda (v p w?) (fprintf p "(Row ~a <expr>)" (Row-pats v))))
|
||||
|
||||
(define struct-key-ht (make-free-identifier-mapping))
|
||||
(define (get-key id)
|
||||
(free-identifier-mapping-get
|
||||
(free-identifier-mapping-get
|
||||
struct-key-ht id
|
||||
(lambda ()
|
||||
(let ([k (box-immutable (syntax-e id))])
|
||||
|
|
@ -117,24 +115,24 @@
|
|||
;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor
|
||||
;; the result is #f if p is not a constructor pattern
|
||||
(define (pat-key p)
|
||||
(cond
|
||||
[(Struct? p) (get-key (Struct-id p))]
|
||||
[(Box? p) 'box]
|
||||
[(Vector? p) 'vector]
|
||||
[(Pair? p) 'pair]
|
||||
[(MPair? p) 'mpair]
|
||||
[(String? p) 'string]
|
||||
[(Symbol? p) 'symbol]
|
||||
[(Number? p) 'number]
|
||||
[(Bytes? p) 'bytes]
|
||||
[(Char? p) 'char]
|
||||
[(Regexp? p) 'regexp]
|
||||
[(Keyword? p) 'keyword]
|
||||
[(Boolean? p) 'boolean]
|
||||
[(Null? p) 'null]
|
||||
[else #f]))
|
||||
(cond [(Struct? p) (get-key (Struct-id p))]
|
||||
[(Box? p) 'box]
|
||||
[(Vector? p) 'vector]
|
||||
[(Pair? p) 'pair]
|
||||
[(MPair? p) 'mpair]
|
||||
[(String? p) 'string]
|
||||
[(Symbol? p) 'symbol]
|
||||
[(Number? p) 'number]
|
||||
[(Bytes? p) 'bytes]
|
||||
[(Char? p) 'char]
|
||||
[(Regexp? p) 'regexp]
|
||||
[(Keyword? p) 'keyword]
|
||||
[(Boolean? p) 'boolean]
|
||||
[(Null? p) 'null]
|
||||
[else #f]))
|
||||
|
||||
;(trace pat-key)
|
||||
;; (require mzlib/trace)
|
||||
;; (trace pat-key)
|
||||
|
||||
;; Row-first-pat : Row -> Pat
|
||||
;; Row must not have empty list of pats
|
||||
|
|
@ -145,29 +143,23 @@
|
|||
(define p (Row-pats r))
|
||||
(values (car p) (cdr p)))
|
||||
|
||||
|
||||
;; merge : (liftof (listof id)) -> (listof id)
|
||||
;; merges lists of identifiers, removing module-identifier=?
|
||||
;; duplicates
|
||||
;; merges lists of identifiers, removing module-identifier=? duplicates
|
||||
(define (merge l)
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(null? (cdr l)) (car l)]
|
||||
[else (let ([m (make-module-identifier-mapping)])
|
||||
(for-each (lambda (ids)
|
||||
(for-each (lambda (id)
|
||||
(module-identifier-mapping-put! m id #t))
|
||||
ids))
|
||||
l)
|
||||
(module-identifier-mapping-map m (lambda (k v) k)))]))
|
||||
(cond [(null? l) null]
|
||||
[(null? (cdr l)) (car l)]
|
||||
[else (let ([m (make-module-identifier-mapping)])
|
||||
(for* ([ids l] [id ids])
|
||||
(module-identifier-mapping-put! m id #t))
|
||||
(module-identifier-mapping-map m (lambda (k v) k)))]))
|
||||
;; bound-vars : Pat -> listof identifiers
|
||||
(define (bound-vars p)
|
||||
(cond
|
||||
[(Dummy? p) null]
|
||||
[(Pred? p) null]
|
||||
[(Var? p) (let* ([v (Var-v p)]
|
||||
[v* (free-identifier-mapping-get (current-renaming) v (lambda () v))])
|
||||
(list v*))]
|
||||
[(Var? p)
|
||||
(let ([v (Var-v p)])
|
||||
(list (free-identifier-mapping-get (current-renaming) v (lambda () v))))]
|
||||
[(Or? p)
|
||||
(bound-vars (car (Or-ps p)))]
|
||||
[(Box? p)
|
||||
|
|
@ -178,11 +170,10 @@
|
|||
[(MPair? p)
|
||||
(merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))]
|
||||
[(GSeq? p)
|
||||
(merge (cons
|
||||
(bound-vars (GSeq-tail p))
|
||||
(for/list ([pats (GSeq-headss p)])
|
||||
(merge (for/list ([pat pats])
|
||||
(bound-vars pat))))))]
|
||||
(merge (cons (bound-vars (GSeq-tail p))
|
||||
(for/list ([pats (GSeq-headss p)])
|
||||
(merge (for/list ([pat pats])
|
||||
(bound-vars pat))))))]
|
||||
[(Vector? p)
|
||||
(merge (map bound-vars (Vector-ps p)))]
|
||||
[(Struct? p)
|
||||
|
|
@ -200,15 +191,15 @@
|
|||
|
||||
(define-syntax-parameter fail
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f
|
||||
"used out of context: not in match pattern"
|
||||
stx)))
|
||||
(raise-syntax-error
|
||||
#f "used out of context: not in match pattern" stx)))
|
||||
|
||||
(define current-renaming (make-parameter (make-free-identifier-mapping)))
|
||||
|
||||
(define (copy-mapping ht)
|
||||
(define new-ht (make-free-identifier-mapping))
|
||||
(free-identifier-mapping-for-each ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
|
||||
(free-identifier-mapping-for-each
|
||||
ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
|
||||
new-ht)
|
||||
|
||||
#|
|
||||
|
|
@ -230,9 +221,10 @@
|
|||
(provide/contract (struct Row ([pats (listof Pat?)]
|
||||
[rhs syntax?]
|
||||
[unmatch (or/c identifier? false/c)]
|
||||
[vars-seen (listof (cons/c identifier? identifier?))])))
|
||||
[vars-seen (listof (cons/c identifier?
|
||||
identifier?))])))
|
||||
|
||||
(define-struct match-expander (match-xform legacy-xform macro-xform certifier)
|
||||
#:property prop:procedure (struct-field-index macro-xform))
|
||||
|
||||
(provide (struct-out match-expander))
|
||||
(provide (struct-out match-expander))
|
||||
|
|
|
|||
|
|
@ -6,80 +6,76 @@
|
|||
|
||||
;; split-rows : Listof[Row] -> Listof[Listof[Row]]
|
||||
;; takes a matrix, and returns a list of matricies
|
||||
;; each returned matrix does not require the mixture rule to do compilation of the first column.
|
||||
;; each returned matrix does not require the mixture rule to do compilation of
|
||||
;; the first column.
|
||||
(define (split-rows rows [acc null])
|
||||
(define (loop/var matched-rows prev-mats rows)
|
||||
(cond [(null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))]
|
||||
[else
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond
|
||||
[(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(Var? p)
|
||||
(loop/var (cons r matched-rows) prev-mats rs)]
|
||||
[else
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
|
||||
(if (null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond [(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(Var? p)
|
||||
(loop/var (cons r matched-rows) prev-mats rs)]
|
||||
[else
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]))))
|
||||
(define (loop/con matched-rows prev-mats struct-key rows)
|
||||
(cond [(null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))]
|
||||
[else
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond
|
||||
[(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
|
||||
;(printf "struct-keys were equal: ~a~n" struct-key)
|
||||
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
|
||||
[(and (Struct? p) (not struct-key))
|
||||
;(printf "no struct-key so far: ~a~n" struct-key)
|
||||
(loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
|
||||
[(and (CPat? p) (not (Struct? p)))
|
||||
;(printf "wasn't a struct: ~a~n" p)
|
||||
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
|
||||
[else (split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
|
||||
(if (null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond [(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
|
||||
;; (printf "struct-keys were equal: ~a~n" struct-key)
|
||||
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
|
||||
[(and (Struct? p) (not struct-key))
|
||||
;; (printf "no struct-key so far: ~a~n" struct-key)
|
||||
(loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
|
||||
[(and (CPat? p) (not (Struct? p)))
|
||||
;; (printf "wasn't a struct: ~a~n" p)
|
||||
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
|
||||
[else (split-rows rows (cons (reverse matched-rows)
|
||||
prev-mats))]))))
|
||||
(define (loop/exact matched-rows prev-mats rows)
|
||||
(cond [(null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))]
|
||||
[else
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond
|
||||
[(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(Exact? p)
|
||||
(loop/exact (cons r matched-rows) prev-mats rs)]
|
||||
[else (split-rows rows (cons (reverse matched-rows) prev-mats))]))]))
|
||||
(cond
|
||||
[(null? rows) (reverse acc)]
|
||||
[else
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond
|
||||
[(Row-unmatch r)
|
||||
(split-rows rs (cons (list r) acc))]
|
||||
[(Var? p)
|
||||
(loop/var (list r) acc rs)]
|
||||
[(Exact? p)
|
||||
(loop/exact (list r) acc rs)]
|
||||
[(CPat? p)
|
||||
(if (Struct? p)
|
||||
(begin
|
||||
;(printf "found a struct: ~a~n" (pat-key r))
|
||||
(loop/con (list r) acc (pat-key p) rs))
|
||||
(loop/con (list r) acc #f rs))]
|
||||
[else (split-rows rs (cons (list r) acc))]))]))
|
||||
(if (null? rows)
|
||||
(reverse (cons (reverse matched-rows) prev-mats))
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond
|
||||
[(Row-unmatch r)
|
||||
(split-rows rows (cons (reverse matched-rows) prev-mats))]
|
||||
[(Exact? p)
|
||||
(loop/exact (cons r matched-rows) prev-mats rs)]
|
||||
[else (split-rows rows (cons (reverse matched-rows) prev-mats))]))))
|
||||
(if (null? rows)
|
||||
(reverse acc)
|
||||
(let* ([r (car rows)]
|
||||
[p (Row-first-pat r)]
|
||||
[rs (cdr rows)])
|
||||
(cond [(Row-unmatch r)
|
||||
(split-rows rs (cons (list r) acc))]
|
||||
[(Var? p)
|
||||
(loop/var (list r) acc rs)]
|
||||
[(Exact? p)
|
||||
(loop/exact (list r) acc rs)]
|
||||
[(CPat? p)
|
||||
(if (Struct? p)
|
||||
(begin
|
||||
;; (printf "found a struct: ~a~n" (pat-key r))
|
||||
(loop/con (list r) acc (pat-key p) rs))
|
||||
(loop/con (list r) acc #f rs))]
|
||||
[else (split-rows rs (cons (list r) acc))]))))
|
||||
|
||||
(require mzlib/trace)
|
||||
;(trace split-rows)
|
||||
;; (require mzlib/trace)
|
||||
;; (trace split-rows)
|
||||
|
||||
;; EXAMPLES:
|
||||
#|
|
||||
(define mat1 (list r1 r2 r3))
|
||||
(define mat2 (list r1 r3 r2 r1))|#
|
||||
(define mat2 (list r1 r3 r2 r1))
|
||||
|#
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user