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

Fixed bug with repeated binders inside ellipses.

Browse Source 
svn: r16504
This commit is contained in:
Casey Klein 2009-11-02 21:33:42 +00:00
parent 32041b2fd5
commit 4be6482bf9
2 changed files with 66 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/redex/private/matcher-test.ss
View File

@ -101,6 +101,11 @@
(test-empty '((number_!_1 ...) (number_!_1 ...))
'((17 2 3 1 5) (1 2 3 1 5))
(list (make-test-mtch (make-bindings (list)) '((17 2 3 1 5) (1 2 3 1 5)) none)))
(test-empty '((number_!_1 number_!_1) ... number_!_1 ...) '((1 1) (2 2) 1 3) #f)
(test-empty '((number_!_1 number_!_1) ... number_!_1 ...) '((1 1) (2 3) 1 2) #f)
(test-empty '((number_!_1 number_!_1) ... number_!_1 ...)
'((1 1) (2 3) 1 4)
(list (make-test-mtch (make-bindings (list)) '((1 1) (2 3) 1 4) none)))
(test-ellipses '(a) '(a))
(test-ellipses '(a ...) `(,(make-repeat 'a '() #f #f)))
@ -114,21 +119,21 @@
(test-ellipses '((1 (name x a)) ...)
`(,(make-repeat '(1 (name x a)) (list (make-bind 'x '())) #f #f)))
(test-ellipses '((any (name x a)) ...)
`(,(make-repeat '(any (name x a)) (list (make-bind 'x '())
(make-bind 'any '()))
`(,(make-repeat '(any (name x a)) (list (make-bind 'any '())
(make-bind 'x '()))
#f #f)))
(test-ellipses '((number (name x a)) ...)
`(,(make-repeat '(number (name x a)) (list (make-bind 'x '())
(make-bind 'number '()))
`(,(make-repeat '(number (name x a)) (list (make-bind 'number '())
(make-bind 'x '()))
#f #f)))
(test-ellipses '((variable (name x a)) ...)
`(,(make-repeat '(variable (name x a)) (list (make-bind 'x '())
(make-bind 'variable '()))
`(,(make-repeat '(variable (name x a)) (list (make-bind 'variable '())
(make-bind 'x '()))
#f #f)))
(test-ellipses '(((name x a) (name y b)) ...)
`(,(make-repeat '((name x a) (name y b)) (list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
`(,(make-repeat '((name x a) (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
(test-ellipses '((name x (name y b)) ...)
`(,(make-repeat '(name x (name y b)) (list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
`(,(make-repeat '(name x (name y b)) (list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
(test-ellipses '((in-hole (name x a) (name y b)) ...)
`(,(make-repeat '(in-hole (name x a) (name y b))
(list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
@ -620,6 +625,10 @@
"compile-pattern"
equal?)
(test-ellipsis-binding '((number_1 number_2) ...) '((1 2)))
(test-ellipsis-binding '((name x number_1) ...) '(1 2))
(test-ellipsis-binding '(((number_1 ...) (number_2 ...)) ...) '(((1) (2))))
(cond
[(= failures 0)
(fprintf (current-error-port) "matcher-test.ss: all ~a tests passed.\n" test-count)]
@ -741,6 +750,27 @@
(define (test-suite:non-underscore-binder? x)
(memq x '(number any variable string)))
;; test-ellipsis-binding: sexp sexp -> boolean
;; Checks that `extract-empty-bindings' produces bindings in the same order
;; as the matcher, as required by `collapse-single-multiples'
(define (test-ellipsis-binding pat exp)
(define (binding-names bindings)
(map (λ (b)
(cond [(bind? b) (bind-name b)]
[(mismatch-bind? b) (mismatch-bind-name b)]))
bindings))
(run-test
`(test-ellipsis-binding ,pat)
(binding-names
(bindings-table-unchecked
(mtch-bindings
(car
((compiled-pattern-cp
(compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t))
exp
#t)))))
(binding-names (extract-empty-bindings test-suite:non-underscore-binder? pat))))
;; run-test/cmp : sexp any any (any any -> boolean)
;; compares ans with expected. If failure,
;; prints info about the test and increments failures

63
collects/redex/private/matcher.ss
View File

@ -1321,35 +1321,23 @@ before the pattern compiler is invoked.
(map
(lambda (single-match)
(let ([single-bindings (mtch-bindings single-match)])
(let ([rib-ht (make-hash)]
[mismatch-rib-ht (make-hash)])
(for-each
(lambda (multiple-rib)
(cond
[(bind? multiple-rib)
(hash-set! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))]
[(mismatch-bind? multiple-rib)
(hash-set! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))]))
(bindings-table multiple-bindings))
(for-each
(lambda (single-rib)
(cond
[(bind? single-rib)
(let* ([key (bind-name single-rib)]
[rst (hash-ref rib-ht key '())])
(hash-set! rib-ht key (cons (bind-exp single-rib) rst)))]
[(mismatch-bind? single-rib)
(let* ([key (mismatch-bind-name single-rib)]
[rst (hash-ref mismatch-rib-ht key '())])
(hash-set! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))]))
(bindings-table single-bindings))
(make-mtch (make-bindings (append (hash-map rib-ht make-bind)
(hash-map mismatch-rib-ht make-mismatch-bind)))
(build-cons-context
(mtch-context single-match)
(mtch-context multiple-match))
(pick-hole (mtch-hole single-match)
(mtch-hole multiple-match))))))
(make-mtch (make-bindings
(map (match-lambda*
[`(,(struct bind (name sing-exp)) ,(struct bind (name mult-exp)))
(make-bind name (cons sing-exp mult-exp))]
[`(,(struct mismatch-bind (name sing-exp)) ,(struct mismatch-bind (name mult-exp)))
(make-mismatch-bind name (cons sing-exp mult-exp))]
[else
(error 'collapse-single-multiples "expected matches' bindings in same order; got ~e ~e"
single-bindings
multiple-bindings)])
(bindings-table single-bindings)
(bindings-table multiple-bindings)))
(build-cons-context
(mtch-context single-match)
(mtch-context multiple-match))
(pick-hole (mtch-hole single-match)
(mtch-hole multiple-match)))))
bindingss)))
multiple-bindingss)))
@ -1480,9 +1468,10 @@ before the pattern compiler is invoked.
(cons (make-bind pattern '()) ribs)]
[else ribs])]
[`(name ,name ,pat)
(if (regexp-match #rx"_!_" (symbol->string name))
(loop pat (cons (make-mismatch-bind name '()) ribs))
(loop pat (cons (make-bind name '()) ribs)))]
(cons (if (regexp-match #rx"_!_" (symbol->string name))
(make-mismatch-bind name '())
(make-bind name '()))
(loop pat ribs))]
[`(in-hole ,context ,contractum) (loop context (loop contractum ribs))]
[`(hide-hole ,p) (loop p ribs)]
[`(side-condition ,pat ,test ,expr) (loop pat ribs)]
@ -1499,9 +1488,7 @@ before the pattern compiler is invoked.
(cdr r-exps)
(append (repeat-empty-bindings r-exp) ribs))]
[else
(i-loop
(cdr r-exps)
(loop (car r-exps) ribs))]))])))]
(loop (car r-exps) (i-loop (cdr r-exps) ribs))]))])))]
[else ribs])))
;; combine-matches : (listof (listof mtch)) -> (listof mtch)
@ -1636,7 +1623,11 @@ before the pattern compiler is invoked.
;; for test suite
(provide build-cons-context
build-flat-context
context?)
context?
extract-empty-bindings
(rename-out [bindings-table bindings-table-unchecked])
(struct-out mismatch-bind)
(struct-out compiled-pattern))
(provide (struct-out nt)
(struct-out rhs)