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

gen-match.ss: kill dead code, remove pointless argument

Browse Source 
match-internal-func.ss:
- use match-define to implement match-letrec
- clean up match-letrec using with-syntax
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-01 17:27:47 -04:00
parent 9e17a6d993
commit c702686b01
2 changed files with 58 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
collects/mzlib/private/match/gen-match.ss
View File

@ -10,6 +10,7 @@
"update-counts.scm"
"update-binding-counts.scm"
"render-test-list.scm"
"render-helpers.ss"
"reorder-tests.scm"
"tag-negate-tests.scm"
"convert-pat.ss")
@ -53,18 +54,9 @@
[pat (match:syntax-err #'pat
"syntax error in clause")]))
;;!(function test-list-with-success-func
;; (form (test-list-with-success-func exp car-patlist
;; stx success-func)
;; ->
;; (test-list success-func))
;; (contract (syntax-object pair syntax-object
;; (list list -> syntax-object))
;; ->
;; (list ((list list -> syntax) list ->
;; (list list -> syntax)))))
;; test-list-with-success-func : syntax (cons syntax boolean) syntax success-func -> (cons test-list success-func)
;; This function takes an exp which is to be matched, a marked
;; clause, and a syntax-object that is fro reporting errors. It
;; clause, and a syntax-object that is for reporting errors. It
;; returns a pair the car of which is a list of test structs which
;; are in essense partially evaluated tests. The cdr of the
;; result is a function which takes a failure function and a list
@ -100,48 +92,8 @@
(define test-list (render-test-list pat exp (lambda (x) x) stx))
(cons test-list success))
;;!(function gen
;; (form (gen exp tsf patlist stx failure-func opt success-func)
;; ->
;; syntax)
;; (contract (syntax list list syntax
;; (() -> void) bool (list list -> syntax))
;; ->
;; syntax))
;; This function is primarily called by gen-help and takes the the
;; newly marked clauses and the failure-func which is really a
;; variable-name which will bound to the failure in the runtime
;; code. This function then This function
;; then takes these lists of partially compiled tests and reorders
;; them in an attempt to reduce the size of the final compiled
;; match expression. Binding counts are also updated to help
;; determind which supexpressions of the expression to be matched
;; need to be bound by let expressions. After all of this the
;; tests are "coupled" together for final compilation.
#;(define (gen exp tsf patlist stx failure-func opt success-func)
;; iterate through list and render each pattern to a list of tests
;; and success functions
(define rendered-list
(map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
patlist))
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list)
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))
;; gen-match : syntax list list syntax success-func -> syntax
;;!(function gen-match
;; (form (gen-match exp tsf patlist stx [success-func])
;; ->
;; compiled-pattern)
;; (contract (syntax-object list list syntax-object
;; (list list -> syntax-object))
;; ->
;; syntax-object))
;; <p>gen-match is the gateway through which match accesses the match
;; pattern compiler.
;;
@ -156,7 +108,7 @@
;;
;; <p>patlist - is a list of the pattern clauses of the match expr
;; these can be of either form (pat body ...) or
;; (pat (=> fail) body ...)x
;; (pat (=> fail) body ...)
;;
;; <p>stx is the original syntax of the match expression.
;; This is only used for error reporting.
@ -168,46 +120,38 @@
;; about a match (namely the bound match variables) is at the bottom
;; of the recursion tree. The success function must take two arguments
;; and it should return a syntax object.
(define gen-match
(opt-lambda (exp tsf patlist stx [success-func #f])
(initer)
(when (stx-null? patlist)
(match:syntax-err stx "null clause list"))
(print-time "entering gen-match")
(let* (;; We set up the list of
;; clauses so that one can mark that they have been "reached".
[marked-clauses (mark-patlist patlist)]
[failure-func #'(match-failure)]
;; iterate through list and render each pattern to a list of partially compiled tests
;; and success functions.
;; These are partially compiled
;; because the test structures containa a function that needs to
;; be coupled with the other functions of the other test
;; structures before actual compilation results.
[rendered-list (map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
marked-clauses)]
[_ (begin
(print-time "finished render-list")
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list))]
;; couple the partially compiled tests together into the final result.
[compiled-exp
(begin
(print-time "starting coupling")
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '()))]
;; Also wrap the final compilation in syntax which binds the
;; match-failure function.
[compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp)])
(print-time "finished coupling")
(unreachable marked-clauses stx)
(print-time "done")
compiled-match)))
(define/opt (gen-match exp patlist stx [success-func #f])
(when (stx-null? patlist)
(match:syntax-err stx "null clause list"))
(let* (;; We set up the list of
;; clauses so that one can mark that they have been "reached".
[marked-clauses (mark-patlist patlist)]
[failure-func #'(match-failure)]
;; iterate through list and render each pattern to a list of partially compiled tests
;; and success functions.
;; These are partially compiled
;; because the test structures containa a function that needs to
;; be coupled with the other functions of the other test
;; structures before actual compilation results.
[rendered-list (map (lambda (clause) (test-list-with-success-func
exp clause stx success-func))
marked-clauses)]
[_ (begin
(update-counts rendered-list)
(tag-negate-tests rendered-list)
(update-binding-counts rendered-list))]
;; couple the partially compiled tests together into the final result.
[compiled-exp
((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func)
'()
'())
'() '())]
;; Also wrap the final compilation in syntax which binds the
;; match-failure function.
[compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp)])
(unreachable marked-clauses stx)
compiled-match))
)

55
collects/mzlib/private/match/match-internal-func.ss
View File

@ -15,7 +15,7 @@
(define-syntax (match stx)
(syntax-case stx ()
[(_ exp . clauses)
(with-syntax ([body (gen-match #'x '() #'clauses stx)])
(with-syntax ([body (gen-match #'x #'clauses stx)])
#`(let ([x exp]) body))]))
(define-syntax (match-lambda stx)
@ -76,24 +76,10 @@
(andmap pattern-var?
(syntax->list #'(pat ...)))
#'(letrec ([pat exp] ...) . body)]
[(_ ([pat exp] ...) . body)
(let* ((**match-bound-vars** '())
(compiled-match
(gen-match #'the-exp
'()
#'(((list pat ...) never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
#`(begin
#,@(map (lambda (x) #`(set! #,(car x) #,(cdr x)))
(reverse bv))
. body )))))
#`(letrec (#,@(map
(lambda (x) #`(#,(car x) #f))
(reverse **match-bound-vars**))
(the-exp (list exp ...)))
#,compiled-match))]))
[(_ ([pat exp] ...) . body)
#'(let ()
(match-define (list pat ...) (list exp ...))
. body)]))
(define-syntax (match-define stx)
(syntax-case stx ()
@ -101,21 +87,18 @@
(identifier? #'pat)
#'(define pat exp)]
[(_ pat exp)
(let* ([**match-bound-vars** '()]
[compiled-match
(gen-match #'the-exp
'()
#'((pat never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
#`(begin
#,@(map (lambda (x)
#`(set! #,(car x) #,(cdr x)))
(reverse bv)))))])
#`(begin #,@(map
(lambda (x) #`(define #,(car x) #f))
(reverse **match-bound-vars**))
(let ((the-exp exp))
#,compiled-match)))]))
(let ([**match-bound-vars** '()])
(with-syntax ([compiled-match
(gen-match #'the-exp
#'((pat never-used))
stx
(lambda (sf bv)
(set! **match-bound-vars** bv)
(with-syntax ([((vars . vals) ...) (reverse bv)])
#'(begin (set! vars vals) ...))))]
[(vars ...) (reverse **match-bound-vars**)])
#'(begin
(define vars #f) ...
(let ([the-exp exp])
compiled-match))))]))
)