From 4be6482bf972aa03fe02bbdb859a6c431b256578 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 2 Nov 2009 21:33:42 +0000 Subject: [PATCH] Fixed bug with repeated binders inside ellipses. svn: r16504 --- collects/redex/private/matcher-test.ss | 46 ++++++++++++++---- collects/redex/private/matcher.ss | 65 +++++++++++--------------- 2 files changed, 66 insertions(+), 45 deletions(-) diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss index a2be3fbf12..0381752a57 100644 --- a/collects/redex/private/matcher-test.ss +++ b/collects/redex/private/matcher-test.ss @@ -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 diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index c66afd4814..96bd946974 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -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)