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

adjusted define-metafunction/extension so that it recompiles the old cases in the new language

Browse Source
This commit is contained in:
Robby Findler 2010-10-16 13:17:34 -05:00
parent e875f262d9
commit 99d85159b6
2 changed files with 24 additions and 3 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,8 +1521,16 @@
(syntax->list stuffs)))
(syntax->list extras))))
(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))]
(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))]
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values
(wrap
@ -1546,6 +1554,7 @@
(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)])
@ -1556,7 +1565,7 @@
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([cases (append cases parent-cases)]
(let loop ([cases all-cases]
[num (- (length parent-cases))])
(cond
[(null? cases)

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

@ -531,6 +531,18 @@
(test (term (g 11 17)) 11)
(test (term (h 11 17)) 11))
(let ()
(define-language L
(v 1))
(define-extended-language M
L
(v .... 2))
(define-metafunction L
[(f v) v])
(define-metafunction/extension f M
[(g 17) 17])
(test (term (g 2)) 2))
(let ()
(define-metafunction empty-language
[(f any) 1])