From 72b98b77fb5c7138e3a92d244259afa08f354f38 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 19 Jul 2010 09:20:56 -0500 Subject: [PATCH] Fixes a bug with `where' clauses --- collects/redex/private/reduction-semantics.rkt | 4 +++- collects/redex/tests/tl-test.rkt | 14 +++++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index f96699e6bb..c554052a4d 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -266,7 +266,9 @@ #, (case where-mode [(flatten) - #`(apply append (map result mtchs))] + #`(for/fold ([r '()]) ([m mtchs]) + (let ([s (result m)]) + (if s (append s r) r)))] [(predicate) #`(ormap result mtchs)] [else (error 'unknown-where-mode "~s" where-mode)]) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 4578319b37..40fcf655b0 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -886,6 +886,18 @@ '(x 4))) '(x)) + ; test multiply matching `where' with failing `where' inside + (test (apply-reduction-relation + (reduction-relation + empty-language + (--> () + () + (where (number_1 ... number_i number_i+1 ...) + (1 2 3)) + (where number_i 2))) + '()) + '(())) + (test (apply-reduction-relation/tag-with-names (reduction-relation grammar @@ -1703,7 +1715,7 @@ (where (y ... w z ...) (x ...))))) (test (apply-reduction-relation red (term (a b c))) - (list (term (a b)) (term (a c)) (term (b c))))) + (list (term (b c)) (term (a c)) (term (a b))))) (let ([r (reduction-relation