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

Fixes matcher bug

Browse Source
This commit is contained in:
Casey Klein 2010-06-21 10:24:37 -05:00
parent 4504678bd7
commit daa8507e51
2 changed files with 18 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/redex/private/matcher.rkt
View File

@ -1318,7 +1318,8 @@ before the pattern compiler is invoked.
[`(,(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"
(error 'collapse-single-multiples
"internal error: expected matches' bindings in same order; got ~e ~e"
single-bindings
multiple-bindings)])
(bindings-table single-bindings)
@ -1462,7 +1463,7 @@ before the pattern compiler is invoked.
(make-mismatch-bind name '())
(make-bind name '()))
(loop pat ribs))]
[`(in-hole ,context ,contractum) (loop context (loop contractum ribs))]
[`(in-hole ,context ,contractum) (loop contractum (loop context ribs))]
[`(hide-hole ,p) (loop p ribs)]
[`(side-condition ,pat ,test ,expr) (loop pat ribs)]
[(? list?)

24
collects/redex/tests/matcher-test.rkt
View File

@ -136,7 +136,7 @@
`(,(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)))
(list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
(test-ellipses '(a ..._1)
`(,(make-repeat 'a (list) '..._1 #f)))
@ -625,10 +625,11 @@
"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))))
(test-ellipsis-binding '(number ... variable) '(1 x))
(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))))
(test-ellipsis-binding '(number ... variable) '() '(1 x))
(test-ellipsis-binding '((in-hole H_1 number_1) ...) '((H hole)) '(1 2))
(cond
[(= failures 0)
@ -660,10 +661,14 @@
exp)
ans))
;; make-nt-map : (listof nt) -> (listof (listof symbol))
(define (make-nt-map nts)
(map (λ (x) (list (nt-name x))) nts))
;; test-lang : sexp[pattern] sexp[term] answer (list/c nt) -> void
;; returns #t if pat matching exp with the language defined by the given nts
(define (test-lang pat exp ans nts)
(let ([nt-map (map (λ (x) (list (nt-name x))) nts)])
(let ([nt-map (make-nt-map nts)])
(run-match-test
`(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used ',nts ',nt-map) ',pat #t) ',exp)
(match-pattern
@ -751,10 +756,10 @@
(define (test-suite:non-underscore-binder? x)
(memq x '(number any variable string)))
;; test-ellipsis-binding: sexp sexp -> boolean
;; test-ellipsis-binding: sexp 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 (test-ellipsis-binding pat nts/sexp exp)
(define (binding-names bindings)
(map (λ (b)
(cond [(bind? b) (bind-name b)]
@ -767,7 +772,8 @@
(mtch-bindings
(car
((compiled-pattern-cp
(compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t))
(let ([nts (map (λ (nt-def) (nt (car nt-def) (map rhs (cdr nt-def)))) nts/sexp)])
(compile-pattern (compile-language 'pict-stuff-not-used nts (make-nt-map nts)) pat #t)))
exp
#t)))))
(binding-names (extract-empty-bindings test-suite:non-underscore-binder? pat))))