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

Reverts most of push #21257.

Browse Source 
That push recompiles a clause of an extended metafunction by
replacing the LHS with a recompiled form of the `lhs-pat' field of the
`metafunc-case' struct. But that field (used by the test generator)
also incorporates the clause's `where' and `side-condition' clauses,
causing them to executed twice when applying the recompiled clause (once
while matching its LHS, and once while evaluating its RHS).
This commit is contained in:
Casey Klein 2010-10-18 21:10:49 -05:00
parent d18f43a488
commit 42687d26d1
2 changed files with 8 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/redex/private/reduction-semantics.rkt
View File

@ -1521,16 +1521,8 @@
(syntax->list stuffs)))
(syntax->list extras))))
(define (build-metafunction lang cases parent-cases/wrong-lang wrap dom-contract-pat codom-contract-pat name relation?)
(let ([parent-cases (map (λ (parent-case)
(make-metafunc-case
(compile-pattern lang (metafunc-case-lhs-pat parent-case) #t)
(metafunc-case-rhs parent-case)
(metafunc-case-lhs-pat parent-case)
(metafunc-case-src-loc parent-case)
(metafunc-case-id parent-case)))
parent-cases/wrong-lang)]
[dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
(define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?)
(let ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values
(wrap
@ -1554,7 +1546,6 @@
(metafunc-proc-cases r)))
(cover-case id c))))
(relation-coverage))))]
[all-cases (append cases parent-cases)]
[metafunc
(λ (exp)
(let ([cache-ref (hash-ref cache exp not-in-cache)])
@ -1565,7 +1556,7 @@
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([cases all-cases]
(let loop ([cases (append cases parent-cases)]
[num (- (length parent-cases))])
(cond
[(null? cases)

6
collects/redex/tests/tl-test.rkt
View File

@ -530,7 +530,9 @@
[(h number_1) number_1])
(test (term (g 11 17)) 11)
(test (term (h 11 17)) 11))
; We'd like this expression not to raise an error.
#;
(let ()
(define-language L
(v 1))
@ -550,6 +552,8 @@
[(g any) 2])
(test (term (g 0)) 2))
; We'd like this expression not to raise an error.
#;
(let ()
(define-language L
(v 1 (v)))