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

Implement column reordering.

Browse Source 
Fix ordering problems with non-linear or patterns.
Use `nest' in a few places.
Fix error message from match-expanders.

svn: r9141
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-02 19:20:56 +00:00
parent d1ed1a1e52
commit b5128a2874
5 changed files with 280 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

298
collects/scheme/match/compiler.ss
View File

@ -5,8 +5,10 @@
syntax/stx syntax/stx
"patterns.ss" "patterns.ss"
"split-rows.ss" "split-rows.ss"
"reorder.ss"
scheme/struct-info scheme/struct-info
scheme/stxparam scheme/stxparam
scheme/nest
(only-in srfi/1 delete-duplicates)) (only-in srfi/1 delete-duplicates))
(provide compile*) (provide compile*)
@ -77,35 +79,36 @@
;; vectors are handled specially ;; vectors are handled specially
;; because each arity is like a different constructor ;; because each arity is like a different constructor
[(eq? 'vector k) [(eq? 'vector k)
(let () (nest
(define ht ([let ()]
(hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows)) [let ([ht (hash-on (lambda (r)
(with-syntax (length (Vector-ps (Row-first-pat r)))) rows)])]
([(clauses ...) [with-syntax
(hash-table-map ([(clauses ...)
ht (hash-table-map
(lambda (arity rows) ht
(define ns (build-list arity values)) (lambda (arity rows)
(with-syntax ([(tmps ...) (generate-temporaries ns)]) (define ns (build-list arity values))
(with-syntax ([body (with-syntax ([(tmps ...) (generate-temporaries ns)])
(compile* (with-syntax ([body
(append (syntax->list #'(tmps ...)) xs) (compile*
(map (lambda (row) (append (syntax->list #'(tmps ...)) xs)
(define-values (p1 ps) (map (lambda (row)
(Row-split-pats row)) (define-values (p1 ps)
(make-Row (append (Vector-ps p1) ps) (Row-split-pats row))
(Row-rhs row) (make-Row (append (Vector-ps p1) ps)
(Row-unmatch row) (Row-rhs row)
(Row-vars-seen row))) (Row-unmatch row)
rows) (Row-vars-seen row)))
esc)] rows)
[(n ...) ns]) esc)]
#`[(#,arity) [(n ...) ns])
(let ([tmps (vector-ref #,x n)] ...) #`[(#,arity)
body)]))))]) (let ([tmps (vector-ref #,x n)] ...)
#`[(vector? #,x) body)]))))])])
(case (vector-length #,x) #`[(vector? #,x)
clauses ...)]))] (case (vector-length #,x)
clauses ...)])]
;; it's a structure ;; it's a structure
[(box? k) [(box? k)
;; all the rows are structures with the same predicate ;; all the rows are structures with the same predicate
@ -192,23 +195,28 @@
(error 'compile-one "Or block with multiple rows: ~a" block)) (error 'compile-one "Or block with multiple rows: ~a" block))
(let* ([row (car block)] (let* ([row (car block)]
[pats (Row-pats row)] [pats (Row-pats row)]
[seen (Row-vars-seen row)]
;; all the pattern alternatives ;; all the pattern alternatives
[qs (Or-ps (car pats))] [qs (Or-ps (car pats))]
;; the variables bound by this pattern - they're the same for the ;; the variables bound by this pattern - they're the same for the
;; whole list ;; whole list
[vars (bound-vars (car qs))]) [vars
(with-syntax ([vars vars]) (for/list ([bv (bound-vars (car qs))]
#:when (for/and ([seen-var seen])
(not (free-identifier=? bv (car seen-var)))))
bv)])
(with-syntax ([(var ...) vars])
;; do the or matching, and bind the results to the appropriate ;; do the or matching, and bind the results to the appropriate
;; variables ;; variables
#`(let/ec exit #`(let/ec exit
(let ([esc* (lambda () (exit (#,esc)))]) (let ([esc* (lambda () (exit (#,esc)))])
(let-values ([vars (let-values ([(var ...)
#,(compile* (list x) #,(compile* (list x)
(map (lambda (q) (map (lambda (q)
(make-Row (list q) (make-Row (list q)
#'(values . vars) #'(values var ...)
#f #f
(Row-vars-seen row))) seen))
qs) qs)
#'esc*)]) #'esc*)])
;; then compile the rest of the row ;; then compile the rest of the row
@ -216,9 +224,7 @@
(list (make-Row (cdr pats) (list (make-Row (cdr pats)
(Row-rhs row) (Row-rhs row)
(Row-unmatch row) (Row-unmatch row)
(let ([vs (syntax->list #'vars)]) (append (map cons vars vars) seen)))
(append (map cons vs vs)
(Row-vars-seen row)))))
esc))))))] esc))))))]
;; the App rule ;; the App rule
[(App? first) [(App? first)
@ -295,99 +301,101 @@
#`(cond [(pred? #,x) body] [else (#,esc)]))] #`(cond [(pred? #,x) body] [else (#,esc)]))]
;; Generalized sequences... slightly tested ;; Generalized sequences... slightly tested
[(GSeq? first) [(GSeq? first)
(let* ([headss (GSeq-headss first)] (nest
[mins (GSeq-mins first)] ([let* ([headss (GSeq-headss first)]
[maxs (GSeq-maxs first)] [mins (GSeq-mins first)]
[onces? (GSeq-onces? first)] [maxs (GSeq-maxs first)]
[tail (GSeq-tail first)] [onces? (GSeq-onces? first)]
[k (Row-rhs (car block))] [tail (GSeq-tail first)]
[xvar (car (generate-temporaries (list #'x)))] [k (Row-rhs (car block))]
[complete-heads-pattern [xvar (car (generate-temporaries (list #'x)))]
(lambda (ps) [complete-heads-pattern
(define (loop ps pat) (lambda (ps)
(if (pair? ps) (define (loop ps pat)
(make-Pair (car ps) (loop (cdr ps) pat)) (if (pair? ps)
pat)) (make-Pair (car ps) (loop (cdr ps) pat))
(loop ps (make-Var xvar)))] pat))
[heads (loop ps (make-Var xvar)))]
(for/list ([ps headss]) [heads
(complete-heads-pattern ps))] (for/list ([ps headss])
[head-idss (complete-heads-pattern ps))]
(for/list ([heads headss]) [head-idss
(apply append (map bound-vars heads)))] (for/list ([heads headss])
[hid-argss (map generate-temporaries head-idss)] (apply append (map bound-vars heads)))]
[head-idss* (map generate-temporaries head-idss)] [hid-argss (map generate-temporaries head-idss)]
[hid-args (apply append hid-argss)] [head-idss* (map generate-temporaries head-idss)]
[reps (generate-temporaries (for/list ([head heads]) 'rep))]) [hid-args (apply append hid-argss)]
(with-syntax ([x xvar] [reps (generate-temporaries (for/list ([head heads]) 'rep))])]
[var0 (car vars)] [with-syntax
[((hid ...) ...) head-idss] ([x xvar]
[((hid* ...) ...) head-idss*] [var0 (car vars)]
[((hid-arg ...) ...) hid-argss] [((hid ...) ...) head-idss]
[(rep ...) reps] [((hid* ...) ...) head-idss*]
[(maxrepconstraint ...) [((hid-arg ...) ...) hid-argss]
;; FIXME: move to side condition to appropriate pattern [(rep ...) reps]
(for/list ([repvar reps] [maxrep maxs]) [(maxrepconstraint ...)
(if maxrep #`(< #,repvar #,maxrep) #`#t))] ;; FIXME: move to side condition to appropriate pattern
[(minrepclause ...) (for/list ([repvar reps] [maxrep maxs])
(for/list ([repvar reps] [minrep mins] #:when minrep) (if maxrep #`(< #,repvar #,maxrep) #`#t))]
#`[(< #,repvar #,minrep) (fail)])] [(minrepclause ...)
[((hid-rhs ...) ...) (for/list ([repvar reps] [minrep mins] #:when minrep)
(for/list ([hid-args hid-argss] [once? onces?]) #`[(< #,repvar #,minrep) (fail)])]
(for/list ([hid-arg hid-args]) [((hid-rhs ...) ...)
(if once? (for/list ([hid-args hid-argss] [once? onces?])
#`(car (reverse #,hid-arg)) (for/list ([hid-arg hid-args])
#`(reverse #,hid-arg))))] (if once?
[(parse-loop failkv fail-tail) #`(car (reverse #,hid-arg))
(generate-temporaries #'(parse-loop failkv fail-tail))]) #`(reverse #,hid-arg))))]
(with-syntax ([(rhs ...) [(parse-loop failkv fail-tail)
#`[(let ([hid-arg (cons hid* hid-arg)] ...) (generate-temporaries #'(parse-loop failkv fail-tail))])]
(if maxrepconstraint [with-syntax ([(rhs ...)
(let ([rep (add1 rep)]) #`[(let ([hid-arg (cons hid* hid-arg)] ...)
(parse-loop x #,@hid-args #,@reps fail)) (if maxrepconstraint
(begin (fail)))) (let ([rep (add1 rep)])
...]] (parse-loop x #,@hid-args #,@reps fail))
[tail-rhs (begin (fail))))
#`(cond minrepclause ... ...]]
[else [tail-rhs
(let ([hid hid-rhs] ... ... #`(cond minrepclause ...
[fail-tail fail]) [else
#,(compile* (let ([hid hid-rhs] ... ...
(cdr vars) [fail-tail fail])
(list (make-Row rest-pats k #,(compile*
(Row-unmatch (car block)) (cdr vars)
(Row-vars-seen (list (make-Row rest-pats k
(car block)))) (Row-unmatch (car block))
#'fail-tail))])]) (Row-vars-seen
(parameterize ([current-renaming (car block))))
(for/fold ([ht (copy-mapping (current-renaming))]) #'fail-tail))])])]
([id (apply append head-idss)] [parameterize ([current-renaming
[id* (apply append head-idss*)]) (for/fold ([ht (copy-mapping (current-renaming))])
(free-identifier-mapping-put! ht id id*) ([id (apply append head-idss)]
(free-identifier-mapping-for-each [id* (apply append head-idss*)])
ht (free-identifier-mapping-put! ht id id*)
(lambda (k v) (free-identifier-mapping-for-each
(when (free-identifier=? v id) ht
(free-identifier-mapping-put! ht k id*)))) (lambda (k v)
ht)]) (when (free-identifier=? v id)
#`(let parse-loop ([x var0] (free-identifier-mapping-put! ht k id*))))
[hid-arg null] ... ... ht)])])
[rep 0] ... #`(let parse-loop ([x var0]
[failkv #,esc]) [hid-arg null] ... ...
#,(compile* (list #'x) [rep 0] ...
(append [failkv #,esc])
(map (lambda (pats rhs) #,(compile* (list #'x)
(make-Row pats (append
rhs (map (lambda (pats rhs)
(Row-unmatch (car block)) (make-Row pats
null)) rhs
(map list heads) (Row-unmatch (car block))
(syntax->list #'(rhs ...))) null))
(list (make-Row (list tail) (map list heads)
#`tail-rhs (syntax->list #'(rhs ...)))
(Row-unmatch (car block)) (list (make-Row (list tail)
null))) #`tail-rhs
#'failkv))))))] (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 (compile* vars rows esc)
@ -424,20 +432,22 @@
;; otherwise, we split the matrix into blocks ;; otherwise, we split the matrix into blocks
;; and compile each block with a reference to its continuation ;; and compile each block with a reference to its continuation
(let ([fns (let*-values
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null]) ([(rows vars) (reorder-columns rows vars)]
(if (null? blocks) [(fns)
;; if we're done, return the blocks (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
(reverse acc) (if (null? blocks)
(with-syntax (;; f is the name this block will have ;; if we're done, return the blocks
[(f) (generate-temporaries #'(f))] (reverse acc)
;; compile the block, with jumps to the previous (with-syntax (;; f is the name this block will have
;; esc [(f) (generate-temporaries #'(f))]
[c (compile-one vars (car blocks) esc)]) ;; compile the block, with jumps to the previous
;; then compile the rest, with our name as the esc ;; esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))]) [c (compile-one vars (car blocks) esc)])
(with-syntax ([(fns ... [_ (lambda () body)]) fns]) ;; then compile the rest, with our name as the esc
(let/wrap #'(fns ...) #'body))))) (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))))
;; (require mzlib/trace) ;; (require mzlib/trace)
;; (trace compile* compile-one) ;; (trace compile* compile-one)

89
collects/scheme/match/gen-match.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require "patterns.ss" "compiler.ss" (require "patterns.ss" "compiler.ss"
syntax/stx syntax/stx scheme/nest
(for-template scheme/base (only-in "patterns.ss" match:error))) (for-template scheme/base (only-in "patterns.ss" match:error)))
(provide go) (provide go)
@ -9,52 +9,41 @@
;; this parses the clauses using parse/cert, then compiles them ;; this parses the clauses using parse/cert, then compiles them
;; go : syntax syntax syntax certifier -> syntax ;; go : syntax syntax syntax certifier -> syntax
(define (go parse/cert stx exprs clauses cert) (define (go parse/cert stx exprs clauses cert)
(parameterize ([orig-stx stx]) (syntax-case clauses ()
(syntax-case clauses () [([pats . rhs] ...)
[([pats . rhs] ...) (nest
(let ([len (length (syntax->list exprs))]) ([parameterize ([orig-stx stx])]
(with-syntax ([(xs ...) (generate-temporaries exprs)] [let ([len (length (syntax->list exprs))])]
[(exprs ...) exprs] [with-syntax ([(xs ...) (generate-temporaries exprs)]
[(fail) (generate-temporaries #'(fail))]) [(exprs ...) exprs]
(with-syntax ([body (compile* [(fail) (generate-temporaries #'(fail))])]
(syntax->list #'(xs ...)) [with-syntax
(map (lambda (pats rhs) ([body
(unless (= len (compile*
(length (syntax->list pats))) (syntax->list #'(xs ...))
(raise-syntax-error (for/list ([pats (syntax->list #'(pats ...))]
'match [rhs (syntax->list #'(rhs ...))])
(format "~a, expected ~a and got ~a" (let ([lp (length (syntax->list pats))])
"wrong number of match clauses" (unless (= len lp)
len (raise-syntax-error
(length (syntax->list pats))) 'match
pats)) (format
(syntax-case* rhs (=>) "wrong number of match clauses, expected ~a and got ~a"
(lambda (x y) len lp)
(eq? (syntax-e x) pats))
(syntax-e y))) (let ([mk (lambda (unm rhs)
[((=> unm) . rhs) (make-Row (for/list ([p (syntax->list pats)])
(make-Row (map (lambda (s) (parse/cert p cert))
(parse/cert s cert)) #`(begin . #,rhs) unm null))])
(syntax->list pats)) (syntax-case* rhs (=>)
#`(begin . rhs) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
#'unm [((=> unm) . rhs) (mk #'unm #'rhs)]
null)] [_ (mk #f rhs)]))))
[_ #'fail)]
(make-Row (map (lambda (s) [orig-expr
(parse/cert s cert)) (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))])])
(syntax->list pats)) (quasisyntax/loc stx
#`(begin . #,rhs) (let ([xs exprs] ...)
#f (let ([fail (lambda ()
null)])) #,(syntax/loc stx (match:error orig-expr)))])
(syntax->list #'(pats ...)) body))))]))
(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))))))])))

2
collects/scheme/match/parse-helper.ss
View File

@ -119,7 +119,7 @@
error-msg) error-msg)
(let* ([expander (syntax-local-value (cert expander))] (let* ([expander (syntax-local-value (cert expander))]
[transformer (accessor expander)]) [transformer (accessor expander)])
(unless transformer (raise-syntax-error #f error-msg #'expander)) (unless transformer (raise-syntax-error #f error-msg expander))
(let* ([introducer (make-syntax-introducer)] (let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)] [certifier (match-expander-certifier expander)]
[mstx (introducer (syntax-local-introduce stx))] [mstx (introducer (syntax-local-introduce stx))]

2
collects/scheme/match/patterns.ss
View File

@ -39,8 +39,6 @@
;; start is what index to start at ;; start is what index to start at
(define-struct (Vector CPat) (ps) #:transparent) (define-struct (Vector CPat) (ps) #:transparent)
(define-struct (VectorSeq Pat) (p count start) #:transparent)
(define-struct (Pair CPat) (a d) #:transparent) (define-struct (Pair CPat) (a d) #:transparent)
(define-struct (MPair CPat) (a d) #:transparent) (define-struct (MPair CPat) (a d) #:transparent)

86
collects/scheme/match/reorder.ss Normal file
View File

@ -0,0 +1,86 @@
#lang scheme/base
(require "patterns.ss"
scheme/list
(only-in srfi/1/list take-while)
(for-syntax scheme/base))
(provide reorder-columns)
#|
(define p-x (make-Var #'x))
(define p-y (make-Var #'y))
(define p-d (make-Dummy #'_))
(define p-cons (make-Pair p-x p-y))
(define p-vec (make-Vector (list p-x p-y p-d)))
(define r1 (make-Row (list p-x) #'#f #f null))
(define r2 (make-Row (list p-y) #'#f #f null))
(define r3 (make-Row (list p-cons) #'#f #f null))
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
(define r5 (make-Row (list p-x p-y p-cons) #'1 #f null))
(define r6 (make-Row (list p-cons p-y p-vec) #'1 #f null))
|#
(define-sequence-syntax in-par
(lambda () (raise-syntax-error 'in-par "bad"))
(lambda (orig-stx stx)
(syntax-case stx ()
[((id) (_ lst-exprs))
#'[(id)
(:do-in
;;outer bindings
([(lst) lst-exprs])
;; outer check
(void) ; (unless (list? lst) (in-list lst))
;; loop bindings
([lst lst])
;; pos check
(not (ormap null? lst))
;; inner bindings
([(id) (map car lst)])
;; pre guard
#t
;; post guard
#t
;; loop args
((map cdr lst)))]]
[_ (error 'no (syntax->datum stx))])))
(define (or-all? ps l)
(ormap (lambda (p) (andmap p l)) ps))
(define (score col)
(define n (length col))
(define c (car col))
(define preds (list Var? Pair? Null?))
(cond [(or-all? preds col) (add1 n)]
[(andmap CPat? col) n]
[(Var? c) (length (take-while Var? col))]
[(Pair? c) (length (take-while Pair? col))]
[(Vector? c) (length (take-while Vector? col))]
[(Box? c) (length (take-while Box? col))]
[else 0]))
(define (reorder-by ps scores*)
(for/fold
([pats null])
([score-ref scores*])
(cons (list-ref ps score-ref) pats)))
(define (reorder-columns rows vars)
(define scores (for/list ([i (in-naturals)]
[column (in-par (map (compose Row-pats) rows))])
(cons i (score column))))
(define scores* (reverse (map car (sort scores > #:key cdr))))
(values
(for/list ([row rows])
(let ([ps (Row-pats row)])
(make-Row (reorder-by ps scores*)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))))
(reorder-by vars scores*)))