From c702686b0127731692154065816b0766f58ae8a1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Sep 2006 17:27:47 -0400 Subject: [PATCH] gen-match.ss: kill dead code, remove pointless argument match-internal-func.ss: - use match-define to implement match-letrec - clean up match-letrec using with-syntax --- collects/mzlib/private/match/gen-match.ss | 134 +++++------------- .../private/match/match-internal-func.ss | 55 +++---- 2 files changed, 58 insertions(+), 131 deletions(-) diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index 25a22a12c1..fd1d0ba54b 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -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)) ;;

gen-match is the gateway through which match accesses the match ;; pattern compiler. ;; @@ -156,7 +108,7 @@ ;; ;;

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 ...) ;; ;;

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)) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/match-internal-func.ss b/collects/mzlib/private/match/match-internal-func.ss index 2f671c9347..133961f8c7 100644 --- a/collects/mzlib/private/match/match-internal-func.ss +++ b/collects/mzlib/private/match/match-internal-func.ss @@ -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))))])) ) \ No newline at end of file