From 32e8e721751d7e2971f89cbd7e03293d77741d57 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Sep 2006 18:42:58 -0400 Subject: [PATCH] gen-match: - use begin-with-definitions for code clarity - rename some variables - better contracts (comments) test-structure: - delete unused field update-counts: - general reformatting - delete dead code - refactoring to eliminate duplication --- collects/mzlib/private/match/gen-match.ss | 78 ++++--- .../mzlib/private/match/test-structure.scm | 8 +- .../mzlib/private/match/update-counts.scm | 206 +++++++----------- 3 files changed, 115 insertions(+), 177 deletions(-) diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index fd1d0ba54b..cbb13ae19d 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -19,11 +19,7 @@ (lib "etc.ss") "match-error.ss") - - - ;;!(function mark-patlist - ;; (form (mark-patlist clauses) -> marked-clause-list) - ;; (contract list -> list)) + ;; mark-patlist : listof[x] -> listof[(cons x #f)] ;; This function takes each clause from the match expression and ;; pairs it with the dummy value #f. This value will be set! when ;; the pattern matcher compiles a possible successful match for @@ -61,13 +57,13 @@ ;; are in essense partially evaluated tests. The cdr of the ;; result is a function which takes a failure function and a list ;; of let-bound expressions and returns a success-function. - (define (test-list-with-success-func exp car-patlist stx success-func) - (define-values (pat body fail-sym) (parse-clause (car car-patlist))) + (define (test-list-with-success-func exp pat/mark stx success-func) + (define-values (pat body fail-sym) (parse-clause (car pat/mark))) (define (success fail let-bound) (if (not success-func) (lambda (sf bv) ;; mark this pattern as reached - (set-cdr! car-patlist #t) + (set-cdr! pat/mark #t) (with-syntax ([fail-var fail-sym] [(bound-vars ...) (map car bv)] [(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)] @@ -80,7 +76,7 @@ #'(let ([bound-vars args] ...) . body)))) (lambda (sf bv) ;; mark this pattern as reached - (set-cdr! car-patlist #t) + (set-cdr! pat/mark #t) (let ((bv (map (lambda (bind) (cons (car bind) @@ -120,38 +116,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/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)]) + (define/opt (gen-match exp patlist stx [success-func #f]) + (begin-with-definitions + (when (stx-null? patlist) + (match:syntax-err stx "null clause list")) + ;; We set up the list of + ;; clauses so that one can mark that they have been "reached". + (define marked-clauses (mark-patlist patlist)) + (define 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. + (define rendered-list (map (lambda (clause) (test-list-with-success-func + exp clause stx success-func)) + marked-clauses)) + (update-counts rendered-list) + (tag-negate-tests rendered-list) + (update-binding-counts rendered-list) + ;; couple the partially compiled tests together into the final result. + (define 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. + (define 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/test-structure.scm b/collects/mzlib/private/match/test-structure.scm index 0d43994575..12a29a99a7 100644 --- a/collects/mzlib/private/match/test-structure.scm +++ b/collects/mzlib/private/match/test-structure.scm @@ -31,7 +31,6 @@ ;; of bind-exp-stx ;; bind-count - is the number of times in the bind-exp is found in the ;; test list in which this test is a member - ;; times-used-neg - ??? (this appears to never be used) ;; used-set-neg - ??? ;; closest-shape-tst - ??? ;; equal-set - ??? @@ -43,7 +42,6 @@ bind-exp-stx bind-exp bind-count - times-used-neg used-set-neg closest-shape-tst equal-set) @@ -65,7 +63,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-shape-test test exp comp) - (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 0 '() #f '())) + (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function make-reg-test ;; (form (make-shape-test test exp comp) -> test-struct) @@ -81,7 +79,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-reg-test test exp comp) - (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 0 '() #f '())) + (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function make-act-test ;; (form (make-shape-test test exp comp) -> test-struct) @@ -99,7 +97,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-act act-name exp comp) - (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 -1 '() #f '())) + (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function action-test? ;; (form (action-test? test) -> bool) diff --git a/collects/mzlib/private/match/update-counts.scm b/collects/mzlib/private/match/update-counts.scm index ce1b72fb26..e8f4ebe90f 100644 --- a/collects/mzlib/private/match/update-counts.scm +++ b/collects/mzlib/private/match/update-counts.scm @@ -6,6 +6,7 @@ (require "test-structure.scm" "match-helper.ss" + (lib "etc.ss") (lib "list.ss")) ;;!(function test-filter @@ -17,14 +18,6 @@ (define (test-filter tlist) (filter (lambda (t) (not (= -1 (test-times-used t)))) tlist)) - #;(define test-filter - (lambda (tlist) - (if (null? tlist) - '() - (if (= -1 (test-times-used (car tlist))) - (test-filter (cdr tlist)) - (cons (car tlist) - (test-filter (cdr tlist))))))) ;; !(function inverse-in @@ -33,30 +26,26 @@ ;; This function checks to see if any of the members of the test-list ;; would be eliminated by the function if the test was in the test so far ;; list. This is the opposite of what the in function does. - (define inverse-in - (lambda (test test-list) - (or (pos-inverse-in test test-list) - (neg-inverse-in test test-list)))) + (define (inverse-in test test-list) + (or (pos-inverse-in test test-list) + (neg-inverse-in test test-list))) - (define pos-inverse-in - (lambda (test test-list) - (let ((test-with-implied (cons test (implied test)))) - (ormap (lambda (t) (in t test-with-implied)) - test-list) - ))) + (define (pos-inverse-in test test-list) + (let ([test-with-implied (cons test (implied test))]) + (ormap (lambda (t) (in t test-with-implied)) + test-list))) + - (define neg-inverse-in - (lambda (test test-list) - (let ((test-with-implied (cons test (implied test)))) - (ormap (lambda (t) (in `(not ,t) test-with-implied)) - test-list) - ))) + (define (neg-inverse-in test test-list) + (let ([test-with-implied (cons test (implied test))]) + (ormap (lambda (t) (in `(not ,t) test-with-implied)) + test-list))) + - (define logical-member - (lambda (item lst) - (ormap (lambda (cur) - (logical-equal? item cur)) - lst))) + (define (logical-member item lst) + (ormap (lambda (cur) + (logical-equal? item cur)) + lst)) (define (logical-equal? a b) (or (equal? a b) #t @@ -72,132 +61,87 @@ (eq? (car a) 'list?) (eq? (car b) 'null?) (equal? (cadr a) (cadr b))))) - ;; this implements the above code - #;(define logical-equal? - (lambda x - (if (pair? x) - (let ((exp8163 (cdr x))) - (if (and (pair? exp8163) (null? (cdr exp8163))) - (if (equal? (car exp8163) (car x)) - #t - (let ((exp8164 (car x))) - (if (and (pair? exp8164) (equal? (car exp8164) 'list?)) - (let ((exp8165 (cdr exp8164))) - (if (and (pair? exp8165) (null? (cdr exp8165))) - (let ((exp8166 (car exp8163))) - (if (and (pair? exp8166) (equal? (car exp8166) 'null?)) - (let ((exp8167 (cdr exp8166))) - (if (and (pair? exp8167) - (null? (cdr exp8167)) - (equal? (car exp8167) (car exp8165))) - ((lambda (x) #t) (car exp8165)) - ((lambda (else) #f) x))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x)))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x)))) - - (define truncate-list - (lambda (pos used-set-neg) - (cond ((null? used-set-neg) - '()) - ((>= pos (car used-set-neg)) - (list pos)) - (else - (cons (car used-set-neg) - (truncate-list pos (cdr used-set-neg))))))) - - (define truncate-list-neg - (lambda (pos used-set-neg) - (cond ((null? used-set-neg) - '()) - ((>= pos (car used-set-neg)) - '()) - (else - (cons (car used-set-neg) - (truncate-list-neg pos (cdr used-set-neg))))))) + ;; truncate-list : int listof[int] -> listof[int] + ;; truncate-list-neg : int listof[int] -> listof[int] + ;; truncate-list removes all elements of a list after the element at least as large as p + ;; truncate-list-neg removes the found element as well + (define-values (truncate-list truncate-list-neg) + (let ([mk (lambda (pos-f) + (define (f p l) + (cond [(null? l) + '()] + [(>= p (car l)) + (pos-f p)] + [else + (cons (car l) + (f p (cdr l)))])) + f)]) + (values (mk list) (mk (lambda (x) '()))))) - ;;!(function update-count - ;; (form (update-count test tests-rest pos) -> void) - ;; (contract (test-struct list integer) -> void)) + ;; update-count : test listof[test] int -> void ;; This function updates the test-times-used and test-used-set ;; fields of the test structs. These fields are essential to ;; determining the order of the tests. - (define update-count - (lambda (test tests-rest pos mem-table) - (let loop ((l tests-rest) - (p (add1 pos))) + (define (update-count test tests-rest pos mem-table) + (let loop ([l tests-rest] + [p (add1 pos)]) (if (null? l) - (begin - ;; memoize - (hash-table-get mem-table (test-tst test) - (lambda () - (hash-table-put! - mem-table - (test-tst test) (list (test-used-set test) - (test-used-set-neg test))))) - ) - (let ((entry-pair + (hash-table-get mem-table (test-tst test) + (lambda () + (hash-table-put! + mem-table + (test-tst test) + (list (test-used-set test) + (test-used-set-neg test))))) + (let ([entry-pair (hash-table-get mem-table (test-tst test) (lambda () - (when ( - ;member - logical-member - ;inverse-in - (test-tst test) (car l)) + (when (logical-member (test-tst test) (car l)) (set-test-times-used! test (add1 (test-times-used test))) (set-test-used-set! test (cons p (test-used-set test))) - (set-test-equal-set! test (cons p (test-equal-set test))) - ) + (set-test-equal-set! test (cons p (test-equal-set test)))) (when (neg-inverse-in (test-tst test) (car l)) (set-test-used-set-neg! test (cons p (test-used-set-neg test)))) - (loop (cdr l) (add1 p)) - )))) + (loop (cdr l) (add1 p))))]) (when (and (list? entry-pair) (not (null? entry-pair))) - (let ((trun-used (truncate-list pos (car entry-pair)))) + (let ([trun-used (truncate-list pos (car entry-pair))]) (set-test-used-set! test trun-used) (set-test-equal-set! test trun-used) (set-test-times-used! test (length trun-used)) - (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair))))) - ))))) + (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair))))))))) + - ;;!(function update-counts - ;; (form (update-counts render-list) -> void) - ;; (contract list -> void)) + ;; update-counts : listof[(cons test any)] -> void ;; This function essentially calls update-count on every test in ;; all of the test lists. - (define update-counts - (lambda (render-list) - (let* ((mem-table (make-hash-table 'equal)) - (test-master-list (map test-filter - (map car render-list))) - (test-so-far-lists ;; horrible name + (define (update-counts render-list) + (let* ([mem-table (make-hash-table 'equal)] + [test-master-list (map (compose test-filter car) render-list)] + [test-so-far-lists ;; horrible name (map - (lambda (tl) - (let ((f (map test-tst (test-filter tl)))) - f)) - test-master-list))) - (let loop ((tml test-master-list) - (tsf test-so-far-lists) - (pos 1)) + (lambda (tl) (map test-tst (test-filter tl))) + test-master-list)]) + (let loop ([tml test-master-list] + [tsf test-so-far-lists] + [pos 1]) (if (null? tml) - '() + (void) (begin - (for-each (lambda (t) - (set-test-times-used! t 1) - (set-test-used-set! - t - (cons pos (test-used-set t))) - (set-test-equal-set! - t - (cons pos (test-equal-set t))) - (update-count t (cdr tsf) pos mem-table)) - (car tml)) - (loop (cdr tml) (cdr tsf) (add1 pos)))))))) + (for-each + (lambda (t) + (set-test-times-used! t 1) + (set-test-used-set! + t + (cons pos (test-used-set t))) + (set-test-equal-set! + t + (cons pos (test-equal-set t))) + (update-count t (cdr tsf) pos mem-table)) + (car tml)) + (loop (cdr tml) (cdr tsf) (add1 pos))))))) )