From d74810a08bf4b326c6b1ba8204cc6ee093f9adc7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 May 2011 14:42:37 -0500 Subject: [PATCH] fix broken earlier commit --- .../redex/private/reduction-semantics.rkt | 27 +++++++++++-------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 23c0257653..771b331e9b 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1120,19 +1120,24 @@ (define-struct match (bindings) #:inspector #f) -(define (do-test-match lang pat binders name) +(define (do-test-match lang pat binders context-name) (unless (compiled-lang? lang) (error 'redex-match "expected first argument to be a language, got ~e" lang)) - (let ([cpat (compile-pattern lang pat #t)]) - (procedure-rename - (λ (exp) - (let ([ans (match-pattern cpat exp)]) - (and ans - (map (λ (m) (make-match (sort-bindings - (filter (λ (x) (memq (bind-name x) binders)) - (bindings-table (mtch-bindings m)))))) - ans)))) - name))) + (define name (or context-name + (and (symbol? pat) + pat))) + (define cpat (compile-pattern lang pat #t)) + (define redex-match-proc + (λ (exp) + (let ([ans (match-pattern cpat exp)]) + (and ans + (map (λ (m) (make-match (sort-bindings + (filter (λ (x) (memq (bind-name x) binders)) + (bindings-table (mtch-bindings m)))))) + ans))))) + (if name + (procedure-rename redex-match-proc name) + redex-match-proc)) (define (sort-bindings bnds) (sort