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 ...)) (test-empty '((number_!_1 ...) (number_!_1 ...))
'((17 2 3 1 5) (1 2 3 1 5)) '((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))) (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) '(a))
(test-ellipses '(a ...) `(,(make-repeat 'a '() #f #f))) (test-ellipses '(a ...) `(,(make-repeat 'a '() #f #f)))
@ -114,21 +119,21 @@
(test-ellipses '((1 (name x a)) ...) (test-ellipses '((1 (name x a)) ...)
`(,(make-repeat '(1 (name x a)) (list (make-bind 'x '())) #f #f))) `(,(make-repeat '(1 (name x a)) (list (make-bind 'x '())) #f #f)))
(test-ellipses '((any (name x a)) ...) (test-ellipses '((any (name x a)) ...)
`(,(make-repeat '(any (name x a)) (list (make-bind 'x '()) `(,(make-repeat '(any (name x a)) (list (make-bind 'any '())
(make-bind 'any '())) (make-bind 'x '()))
#f #f))) #f #f)))
(test-ellipses '((number (name x a)) ...) (test-ellipses '((number (name x a)) ...)
`(,(make-repeat '(number (name x a)) (list (make-bind 'x '()) `(,(make-repeat '(number (name x a)) (list (make-bind 'number '())
(make-bind 'number '())) (make-bind 'x '()))
#f #f))) #f #f)))
(test-ellipses '((variable (name x a)) ...) (test-ellipses '((variable (name x a)) ...)
`(,(make-repeat '(variable (name x a)) (list (make-bind 'x '()) `(,(make-repeat '(variable (name x a)) (list (make-bind 'variable '())
(make-bind 'variable '())) (make-bind 'x '()))
#f #f))) #f #f)))
(test-ellipses '(((name x a) (name y b)) ...) (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)) ...) (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)) ...) (test-ellipses '((in-hole (name x a) (name y b)) ...)
`(,(make-repeat '(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))) (list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
@ -620,6 +625,10 @@
"compile-pattern" "compile-pattern"
equal?) 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 (cond
[(= failures 0) [(= failures 0)
(fprintf (current-error-port) "matcher-test.ss: all ~a tests passed.\n" test-count)] (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) (define (test-suite:non-underscore-binder? x)
(memq x '(number any variable string))) (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) ;; run-test/cmp : sexp any any (any any -> boolean)
;; compares ans with expected. If failure, ;; compares ans with expected. If failure,
;; prints info about the test and increments failures ;; prints info about the test and increments failures

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

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