Fixed bug with repeated binders inside ellipses.
svn: r16504
This commit is contained in:
Casey Klein
parent
32041b2fd5
commit
4be6482bf9
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
@ -1494,14 +1483,12 @@ before the pattern compiler is invoked.
|
|||
[(null? r-exps) ribs]
|
||||
[else (let ([r-exp (car r-exps)])
|
||||
(cond
|
||||
[(repeat? r-exp)
|
||||
[(repeat? r-exp)
|
||||
(i-loop
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user