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

gen-match:

Browse Source 
- 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
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-01 18:42:58 -04:00
parent c702686b01
commit 32e8e72175
3 changed files with 115 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -19,11 +19,7 @@
(lib "etc.ss") (lib "etc.ss")
"match-error.ss") "match-error.ss")
;; mark-patlist : listof[x] -> listof[(cons x #f)]
;;!(function mark-patlist
;; (form (mark-patlist clauses) -> marked-clause-list)
;; (contract list -> list))
;; This function takes each clause from the match expression and ;; This function takes each clause from the match expression and
;; pairs it with the dummy value #f. This value will be set! when ;; pairs it with the dummy value #f. This value will be set! when
;; the pattern matcher compiles a possible successful match for ;; the pattern matcher compiles a possible successful match for
@ -61,13 +57,13 @@
;; are in essense partially evaluated tests. The cdr of the ;; are in essense partially evaluated tests. The cdr of the
;; result is a function which takes a failure function and a list ;; result is a function which takes a failure function and a list
;; of let-bound expressions and returns a success-function. ;; of let-bound expressions and returns a success-function.
(define (test-list-with-success-func exp car-patlist stx success-func) (define (test-list-with-success-func exp pat/mark stx success-func)
(define-values (pat body fail-sym) (parse-clause (car car-patlist))) (define-values (pat body fail-sym) (parse-clause (car pat/mark)))
(define (success fail let-bound) (define (success fail let-bound)
(if (not success-func) (if (not success-func)
(lambda (sf bv) (lambda (sf bv)
;; mark this pattern as reached ;; mark this pattern as reached
(set-cdr! car-patlist #t) (set-cdr! pat/mark #t)
(with-syntax ([fail-var fail-sym] (with-syntax ([fail-var fail-sym]
[(bound-vars ...) (map car bv)] [(bound-vars ...) (map car bv)]
[(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)] [(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)]
@ -80,7 +76,7 @@
#'(let ([bound-vars args] ...) . body)))) #'(let ([bound-vars args] ...) . body))))
(lambda (sf bv) (lambda (sf bv)
;; mark this pattern as reached ;; mark this pattern as reached
(set-cdr! car-patlist #t) (set-cdr! pat/mark #t)
(let ((bv (map (let ((bv (map
(lambda (bind) (lambda (bind)
(cons (car bind) (cons (car bind)
@ -120,38 +116,38 @@
;; about a match (namely the bound match variables) is at the bottom ;; about a match (namely the bound match variables) is at the bottom
;; of the recursion tree. The success function must take two arguments ;; of the recursion tree. The success function must take two arguments
;; and it should return a syntax object. ;; and it should return a syntax object.
(define/opt (gen-match exp patlist stx [success-func #f]) (define/opt (gen-match exp patlist stx [success-func #f])
(when (stx-null? patlist) (begin-with-definitions
(match:syntax-err stx "null clause list")) (when (stx-null? patlist)
(let* (;; We set up the list of (match:syntax-err stx "null clause list"))
;; clauses so that one can mark that they have been "reached". ;; We set up the list of
[marked-clauses (mark-patlist patlist)] ;; clauses so that one can mark that they have been "reached".
[failure-func #'(match-failure)] (define marked-clauses (mark-patlist patlist))
;; iterate through list and render each pattern to a list of partially compiled tests (define failure-func #'(match-failure))
;; and success functions. ;; iterate through list and render each pattern to a list of partially compiled tests
;; These are partially compiled ;; and success functions.
;; because the test structures containa a function that needs to ;; These are partially compiled
;; be coupled with the other functions of the other test ;; because the test structures containa a function that needs to
;; structures before actual compilation results. ;; be coupled with the other functions of the other test
[rendered-list (map (lambda (clause) (test-list-with-success-func ;; structures before actual compilation results.
exp clause stx success-func)) (define rendered-list (map (lambda (clause) (test-list-with-success-func
marked-clauses)] exp clause stx success-func))
[_ (begin marked-clauses))
(update-counts rendered-list) (update-counts rendered-list)
(tag-negate-tests rendered-list) (tag-negate-tests rendered-list)
(update-binding-counts rendered-list))] (update-binding-counts rendered-list)
;; couple the partially compiled tests together into the final result. ;; couple the partially compiled tests together into the final result.
[compiled-exp (define compiled-exp
((meta-couple (reorder-all-lists rendered-list) ((meta-couple (reorder-all-lists rendered-list)
(lambda (sf bv) failure-func) (lambda (sf bv) failure-func)
'() '()
'()) '())
'() '())] '() '()))
;; Also wrap the final compilation in syntax which binds the ;; Also wrap the final compilation in syntax which binds the
;; match-failure function. ;; match-failure function.
[compiled-match (define compiled-match
#`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))])
#,compiled-exp)]) #,compiled-exp))
(unreachable marked-clauses stx) (unreachable marked-clauses stx)
compiled-match)) compiled-match))
) )

8
collects/mzlib/private/match/test-structure.scm
View File

@ -31,7 +31,6 @@
;; of bind-exp-stx ;; of bind-exp-stx
;; bind-count - is the number of times in the bind-exp is found in the ;; bind-count - is the number of times in the bind-exp is found in the
;; test list in which this test is a member ;; test list in which this test is a member
;; times-used-neg - ??? (this appears to never be used)
;; used-set-neg - ??? ;; used-set-neg - ???
;; closest-shape-tst - ??? ;; closest-shape-tst - ???
;; equal-set - ??? ;; equal-set - ???
@ -43,7 +42,6 @@
bind-exp-stx bind-exp-stx
bind-exp bind-exp
bind-count bind-count
times-used-neg
used-set-neg used-set-neg
closest-shape-tst closest-shape-tst
equal-set) equal-set)
@ -65,7 +63,7 @@
;; comp - the compilation function which will finish the compilation ;; comp - the compilation function which will finish the compilation
;; after tests have been reordered ;; after tests have been reordered
(define (make-shape-test test exp comp) (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 ;;!(function make-reg-test
;; (form (make-shape-test test exp comp) -> test-struct) ;; (form (make-shape-test test exp comp) -> test-struct)
@ -81,7 +79,7 @@
;; comp - the compilation function which will finish the compilation ;; comp - the compilation function which will finish the compilation
;; after tests have been reordered ;; after tests have been reordered
(define (make-reg-test test exp comp) (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 ;;!(function make-act-test
;; (form (make-shape-test test exp comp) -> test-struct) ;; (form (make-shape-test test exp comp) -> test-struct)
@ -99,7 +97,7 @@
;; comp - the compilation function which will finish the compilation ;; comp - the compilation function which will finish the compilation
;; after tests have been reordered ;; after tests have been reordered
(define (make-act act-name exp comp) (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? ;;!(function action-test?
;; (form (action-test? test) -> bool) ;; (form (action-test? test) -> bool)

206
collects/mzlib/private/match/update-counts.scm
View File

@ -6,6 +6,7 @@
(require "test-structure.scm" (require "test-structure.scm"
"match-helper.ss" "match-helper.ss"
(lib "etc.ss")
(lib "list.ss")) (lib "list.ss"))
;;!(function test-filter ;;!(function test-filter
@ -17,14 +18,6 @@
(define (test-filter tlist) (define (test-filter tlist)
(filter (lambda (t) (not (= -1 (test-times-used t)))) 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 ;; !(function inverse-in
@ -33,30 +26,26 @@
;; This function checks to see if any of the members of the test-list ;; 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 ;; 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. ;; list. This is the opposite of what the in function does.
(define inverse-in (define (inverse-in test test-list)
(lambda (test test-list) (or (pos-inverse-in test test-list)
(or (pos-inverse-in test test-list) (neg-inverse-in test test-list)))
(neg-inverse-in test test-list))))
(define pos-inverse-in (define (pos-inverse-in test test-list)
(lambda (test test-list) (let ([test-with-implied (cons test (implied test))])
(let ((test-with-implied (cons test (implied test)))) (ormap (lambda (t) (in t test-with-implied))
(ormap (lambda (t) (in t test-with-implied)) test-list)))
test-list)
)))
(define neg-inverse-in (define (neg-inverse-in test test-list)
(lambda (test test-list) (let ([test-with-implied (cons test (implied test))])
(let ((test-with-implied (cons test (implied test)))) (ormap (lambda (t) (in `(not ,t) test-with-implied))
(ormap (lambda (t) (in `(not ,t) test-with-implied)) test-list)))
test-list)
)))
(define logical-member (define (logical-member item lst)
(lambda (item lst) (ormap (lambda (cur)
(ormap (lambda (cur) (logical-equal? item cur))
(logical-equal? item cur)) lst))
lst)))
(define (logical-equal? a b) (define (logical-equal? a b)
(or (equal? a b) #t (or (equal? a b) #t
@ -72,132 +61,87 @@
(eq? (car a) 'list?) (eq? (car a) 'list?)
(eq? (car b) 'null?) (eq? (car b) 'null?)
(equal? (cadr a) (cadr b))))) (equal? (cadr a) (cadr b)))))
;; this implements the above code
#;(define logical-equal? ;; truncate-list : int listof[int] -> listof[int]
(lambda x ;; truncate-list-neg : int listof[int] -> listof[int]
(if (pair? x) ;; truncate-list removes all elements of a list after the element at least as large as p
(let ((exp8163 (cdr x))) ;; truncate-list-neg removes the found element as well
(if (and (pair? exp8163) (null? (cdr exp8163))) (define-values (truncate-list truncate-list-neg)
(if (equal? (car exp8163) (car x)) (let ([mk (lambda (pos-f)
#t (define (f p l)
(let ((exp8164 (car x))) (cond [(null? l)
(if (and (pair? exp8164) (equal? (car exp8164) 'list?)) '()]
(let ((exp8165 (cdr exp8164))) [(>= p (car l))
(if (and (pair? exp8165) (null? (cdr exp8165))) (pos-f p)]
(let ((exp8166 (car exp8163))) [else
(if (and (pair? exp8166) (equal? (car exp8166) 'null?)) (cons (car l)
(let ((exp8167 (cdr exp8166))) (f p (cdr l)))]))
(if (and (pair? exp8167) f)])
(null? (cdr exp8167)) (values (mk list) (mk (lambda (x) '())))))
(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)))))))
;;!(function update-count ;; update-count : test listof[test] int -> void
;; (form (update-count test tests-rest pos) -> void)
;; (contract (test-struct list integer) -> void))
;; This function updates the test-times-used and test-used-set ;; This function updates the test-times-used and test-used-set
;; fields of the test structs. These fields are essential to ;; fields of the test structs. These fields are essential to
;; determining the order of the tests. ;; determining the order of the tests.
(define update-count (define (update-count test tests-rest pos mem-table)
(lambda (test tests-rest pos mem-table) (let loop ([l tests-rest]
(let loop ((l tests-rest) [p (add1 pos)])
(p (add1 pos)))
(if (null? l) (if (null? l)
(begin (hash-table-get mem-table (test-tst test)
;; memoize (lambda ()
(hash-table-get mem-table (test-tst test) (hash-table-put!
(lambda () mem-table
(hash-table-put! (test-tst test)
mem-table (list (test-used-set test)
(test-tst test) (list (test-used-set test) (test-used-set-neg test)))))
(test-used-set-neg test))))) (let ([entry-pair
)
(let ((entry-pair
(hash-table-get mem-table (test-tst test) (hash-table-get mem-table (test-tst test)
(lambda () (lambda ()
(when ( (when (logical-member (test-tst test) (car l))
;member
logical-member
;inverse-in
(test-tst test) (car l))
(set-test-times-used! test (add1 (test-times-used test))) (set-test-times-used! test (add1 (test-times-used test)))
(set-test-used-set! test (cons p (test-used-set 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)) (when (neg-inverse-in (test-tst test) (car l))
(set-test-used-set-neg! test (cons p (test-used-set-neg test)))) (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))) (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-used-set! test trun-used)
(set-test-equal-set! test trun-used) (set-test-equal-set! test trun-used)
(set-test-times-used! test (length 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 ;; update-counts : listof[(cons test any)] -> void
;; (form (update-counts render-list) -> void)
;; (contract list -> void))
;; This function essentially calls update-count on every test in ;; This function essentially calls update-count on every test in
;; all of the test lists. ;; all of the test lists.
(define update-counts (define (update-counts render-list)
(lambda (render-list) (let* ([mem-table (make-hash-table 'equal)]
(let* ((mem-table (make-hash-table 'equal)) [test-master-list (map (compose test-filter car) render-list)]
(test-master-list (map test-filter [test-so-far-lists ;; horrible name
(map car render-list)))
(test-so-far-lists ;; horrible name
(map (map
(lambda (tl) (lambda (tl) (map test-tst (test-filter tl)))
(let ((f (map test-tst (test-filter tl)))) test-master-list)])
f)) (let loop ([tml test-master-list]
test-master-list))) [tsf test-so-far-lists]
(let loop ((tml test-master-list) [pos 1])
(tsf test-so-far-lists)
(pos 1))
(if (null? tml) (if (null? tml)
'() (void)
(begin (begin
(for-each (lambda (t) (for-each
(set-test-times-used! t 1) (lambda (t)
(set-test-used-set! (set-test-times-used! t 1)
t (set-test-used-set!
(cons pos (test-used-set t))) t
(set-test-equal-set! (cons pos (test-used-set t)))
t (set-test-equal-set!
(cons pos (test-equal-set t))) t
(update-count t (cdr tsf) pos mem-table)) (cons pos (test-equal-set t)))
(car tml)) (update-count t (cdr tsf) pos mem-table))
(loop (cdr tml) (cdr tsf) (add1 pos)))))))) (car tml))
(loop (cdr tml) (cdr tsf) (add1 pos)))))))
) )