605c510b9e
http://svn.plt-scheme.org/plt/branches/samth/match2 revisions 4220:4417 Included Matthew's version of regexp-error change, not Sam's. Major changes: - simplification pass - define match-letrec in terms of match-define - show steps of match-expander in macro stepper - substantial refactoring of gen-match - removed unused times-used-neg field of test struct - added match:internal-error - general refactoring - bug fix in parsing of quasi-patterns svn: r4418
149 lines
5.7 KiB
Scheme
149 lines
5.7 KiB
Scheme
;; This library is used by match.ss
|
|
;; This requires the test data structure.
|
|
|
|
(module update-counts mzscheme
|
|
(provide update-counts)
|
|
|
|
(require "test-structure.scm"
|
|
"match-helper.ss"
|
|
(lib "etc.ss")
|
|
(lib "list.ss"))
|
|
|
|
;;!(function test-filter
|
|
;; (form (test-filter test-list) -> test-list)
|
|
;; (contract list -> list))
|
|
;; This function filters out tests that do not need to be to have
|
|
;; their counts updated for reordering purposes. These are the
|
|
;; more complex patterns such as or-patterns or ddk patterns.
|
|
|
|
(define (test-filter tlist)
|
|
(filter (lambda (t) (not (= -1 (test-times-used t)))) tlist))
|
|
|
|
|
|
;; !(function inverse-in
|
|
;; (form (inverse-in test test-list) -> bool)
|
|
;; (contract (s-exp list) -> bool))
|
|
;; 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 test test-list)
|
|
(or (pos-inverse-in test test-list)
|
|
(neg-inverse-in test 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 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 item lst)
|
|
(ormap (lambda (cur)
|
|
(logical-equal? item cur))
|
|
lst))
|
|
|
|
(define (logical-equal? a b)
|
|
(or (equal? a b)
|
|
(and
|
|
;; error checking
|
|
(list? a)
|
|
(list? b)
|
|
(list? (cdr a))
|
|
(list? (cdr b))
|
|
(null? (cddr a))
|
|
(null? (cddr b))
|
|
;; end error checking
|
|
(eq? (car a) 'list?)
|
|
(eq? (car b) 'null?)
|
|
(equal? (cadr a) (cadr b)))))
|
|
|
|
;; 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) '())))))
|
|
|
|
|
|
|
|
;; 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 test tests-rest pos mem-table)
|
|
(let loop ([l tests-rest]
|
|
[p (add1 pos)])
|
|
(if (null? l)
|
|
(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 (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))))
|
|
(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))))])
|
|
(when (and (list? entry-pair) (not (null? 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)))))))))
|
|
|
|
|
|
;; 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 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) (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)))))))
|
|
)
|
|
|
|
|
|
|