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

58
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,10 +79,11 @@
;; 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)])]
[with-syntax
([(clauses ...) ([(clauses ...)
(hash-table-map (hash-table-map
ht ht
@ -102,10 +105,10 @@
[(n ...) ns]) [(n ...) ns])
#`[(#,arity) #`[(#,arity)
(let ([tmps (vector-ref #,x n)] ...) (let ([tmps (vector-ref #,x n)] ...)
body)]))))]) body)]))))])])
#`[(vector? #,x) #`[(vector? #,x)
(case (vector-length #,x) (case (vector-length #,x)
clauses ...)]))] 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,7 +301,8 @@
#`(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
([let* ([headss (GSeq-headss first)]
[mins (GSeq-mins first)] [mins (GSeq-mins first)]
[maxs (GSeq-maxs first)] [maxs (GSeq-maxs first)]
[onces? (GSeq-onces? first)] [onces? (GSeq-onces? first)]
@ -318,8 +325,9 @@
[hid-argss (map generate-temporaries head-idss)] [hid-argss (map generate-temporaries head-idss)]
[head-idss* (map generate-temporaries head-idss)] [head-idss* (map generate-temporaries head-idss)]
[hid-args (apply append hid-argss)] [hid-args (apply append hid-argss)]
[reps (generate-temporaries (for/list ([head heads]) 'rep))]) [reps (generate-temporaries (for/list ([head heads]) 'rep))])]
(with-syntax ([x xvar] [with-syntax
([x xvar]
[var0 (car vars)] [var0 (car vars)]
[((hid ...) ...) head-idss] [((hid ...) ...) head-idss]
[((hid* ...) ...) head-idss*] [((hid* ...) ...) head-idss*]
@ -339,8 +347,8 @@
#`(car (reverse #,hid-arg)) #`(car (reverse #,hid-arg))
#`(reverse #,hid-arg))))] #`(reverse #,hid-arg))))]
[(parse-loop failkv fail-tail) [(parse-loop failkv fail-tail)
(generate-temporaries #'(parse-loop failkv fail-tail))]) (generate-temporaries #'(parse-loop failkv fail-tail))])]
(with-syntax ([(rhs ...) [with-syntax ([(rhs ...)
#`[(let ([hid-arg (cons hid* hid-arg)] ...) #`[(let ([hid-arg (cons hid* hid-arg)] ...)
(if maxrepconstraint (if maxrepconstraint
(let ([rep (add1 rep)]) (let ([rep (add1 rep)])
@ -358,8 +366,8 @@
(Row-unmatch (car block)) (Row-unmatch (car block))
(Row-vars-seen (Row-vars-seen
(car block)))) (car block))))
#'fail-tail))])]) #'fail-tail))])])]
(parameterize ([current-renaming [parameterize ([current-renaming
(for/fold ([ht (copy-mapping (current-renaming))]) (for/fold ([ht (copy-mapping (current-renaming))])
([id (apply append head-idss)] ([id (apply append head-idss)]
[id* (apply append head-idss*)]) [id* (apply append head-idss*)])
@ -369,7 +377,7 @@
(lambda (k v) (lambda (k v)
(when (free-identifier=? v id) (when (free-identifier=? v id)
(free-identifier-mapping-put! ht k id*)))) (free-identifier-mapping-put! ht k id*))))
ht)]) ht)])])
#`(let parse-loop ([x var0] #`(let parse-loop ([x var0]
[hid-arg null] ... ... [hid-arg null] ... ...
[rep 0] ... [rep 0] ...
@ -387,7 +395,7 @@
#`tail-rhs #`tail-rhs
(Row-unmatch (car block)) (Row-unmatch (car block))
null))) null)))
#'failkv))))))] #'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,7 +432,9 @@
;; 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
([(rows vars) (reorder-columns rows vars)]
[(fns)
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null]) (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
(if (null? blocks) (if (null? blocks)
;; if we're done, return the blocks ;; if we're done, return the blocks

65
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] ...)
(let ([len (length (syntax->list exprs))]) (nest
(with-syntax ([(xs ...) (generate-temporaries exprs)] ([parameterize ([orig-stx stx])]
[let ([len (length (syntax->list exprs))])]
[with-syntax ([(xs ...) (generate-temporaries exprs)]
[(exprs ...) exprs] [(exprs ...) exprs]
[(fail) (generate-temporaries #'(fail))]) [(fail) (generate-temporaries #'(fail))])]
(with-syntax ([body (compile* [with-syntax
([body
(compile*
(syntax->list #'(xs ...)) (syntax->list #'(xs ...))
(map (lambda (pats rhs) (for/list ([pats (syntax->list #'(pats ...))]
(unless (= len [rhs (syntax->list #'(rhs ...))])
(length (syntax->list pats))) (let ([lp (length (syntax->list pats))])
(unless (= len lp)
(raise-syntax-error (raise-syntax-error
'match 'match
(format "~a, expected ~a and got ~a" (format
"wrong number of match clauses" "wrong number of match clauses, expected ~a and got ~a"
len len lp)
(length (syntax->list pats)))
pats)) pats))
(let ([mk (lambda (unm rhs)
(make-Row (for/list ([p (syntax->list pats)])
(parse/cert p cert))
#`(begin . #,rhs) unm null))])
(syntax-case* rhs (=>) (syntax-case* rhs (=>)
(lambda (x y) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
(eq? (syntax-e x) [((=> unm) . rhs) (mk #'unm #'rhs)]
(syntax-e y))) [_ (mk #f rhs)]))))
[((=> 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)] #'fail)]
[orig-expr (if (= 1 len) [orig-expr
(stx-car #'(xs ...)) (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))])])
#'(list xs ...))])
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([xs exprs] (let ([xs exprs] ...)
...)
(let ([fail (lambda () (let ([fail (lambda ()
#,(syntax/loc stx (match:error orig-expr)))]) #,(syntax/loc stx (match:error orig-expr)))])
body))))))]))) 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*)))