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

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

@ -531,6 +531,18 @@
(test (term (g 11 17)) 11) (test (term (g 11 17)) 11)
(test (term (h 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 () (let ()
(define-metafunction empty-language (define-metafunction empty-language
[(f any) 1]) [(f any) 1])