From b93486ed697f3e32fdbd49b19db2bb2c77b2f08a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 17 Nov 2011 20:47:31 -0600 Subject: [PATCH] compile the left-hand sides of define-judgment only once, not during each time we try to check a judgment related to PR 12380 --- .../redex/private/reduction-semantics.rkt | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 3bc6ec9484..d3e08f1f8e 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1883,18 +1883,20 @@ (define outputs (if mtchs (for/fold ([outputs '()]) ([m mtchs]) - (define os - (term-let ([names/ellipses (lookup-binding (mtch-bindings m) 'names)] ...) - #,body)) - (if os (append os outputs) outputs)) + (define os + (term-let ([names/ellipses (lookup-binding (mtch-bindings m) 'names)] ...) + #,body)) + (if os (append os outputs) outputs)) '())) (for ([output outputs]) - (check-judgment-form-contract `#,name output compiled-output-ctcs 'O '#,mode)) + (check-judgment-form-contract `#,name output compiled-output-ctcs 'O '#,mode)) outputs))))])) - (with-syntax ([(clause-proc ...) (map compile-clause clauses)]) - #'(λ (input) - (for/fold ([outputs '()]) ([rule (list clause-proc ...)]) - (append (rule input) outputs))))) + (with-syntax ([(clause-proc ...) (map compile-clause clauses)] + [(clause-proc-ids ...) (generate-temporaries clauses)]) + (with-syntax ([(backwards-ids ...) (reverse (syntax->list #'(clause-proc-ids ...)))]) + #'(let ([clause-proc-ids clause-proc] ...) + (λ (input) + (append (backwards-ids input) ...)))))) (define-for-syntax (do-compile-judgment-form-lws clauses) (syntax-case clauses ()