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
This commit is contained in:
Sam Tobin-Hochstadt
parent
c702686b01
commit
32e8e72175
|
|
@ -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))
|
||||
)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user