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

fix compatible-closure to deal properly with language extension

Browse Source 
Thanks to David Van Horn for spotting the problem and providing
a nice simple test case

Please include in 6.1
(cherry picked from commit 3666842cd4)
This commit is contained in:
Robby Findler 2014-07-20 07:03:24 -05:00 committed by Ryan Culpepper
parent 3ba5639e04
commit d851817d66
2 changed files with 54 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt
View File

@ -193,49 +193,49 @@
"language argument does not contain a definition of the non-terminal ~a, needed by the reduction-relation" "language argument does not contain a definition of the non-terminal ~a, needed by the reduction-relation"
red-lang-nt)))) red-lang-nt))))
(let ([cp (compile-pattern (build-reduction-relation
lang #f
`(in-hole (name ctxt ,pat) lang
(name exp any)) (map
#f)]) (λ (make-proc)
(build-reduction-relation (make-rewrite-proc
#f (λ (lang)
lang (define f (make-proc lang))
(map (define cp (compile-pattern
(λ (make-proc) lang
(make-rewrite-proc `(in-hole (name ctxt ,pat)
(λ (lang) (name exp any))
(let ([f (make-proc lang)]) #f))
(λ (main-exp exp extend acc) (λ (main-exp exp extend acc)
(let loop ([ms (or (match-pattern cp exp) '())] (let loop ([ms (or (match-pattern cp exp) '())]
[acc acc]) [acc acc])
(cond (cond
[(null? ms) acc] [(null? ms) acc]
[else [else
(let* ([mtch (car ms)] (let* ([mtch (car ms)]
[bindings (mtch-bindings mtch)]) [bindings (mtch-bindings mtch)])
(loop (cdr ms) (loop (cdr ms)
(f main-exp (f main-exp
(lookup-binding bindings 'exp) (lookup-binding bindings 'exp)
(λ (x) (extend (plug (lookup-binding bindings 'ctxt) x))) (λ (x) (extend (plug (lookup-binding bindings 'ctxt) x)))
acc)))]))))) acc)))]))))
(rewrite-proc-name make-proc) (rewrite-proc-name make-proc)
(rewrite-proc-lhs make-proc) (rewrite-proc-lhs make-proc)
(rewrite-proc-lhs-src make-proc) (rewrite-proc-lhs-src make-proc)
(rewrite-proc-id make-proc))) (rewrite-proc-id make-proc)))
(reduction-relation-make-procs red)) (reduction-relation-make-procs red))
(reduction-relation-rule-names red) (reduction-relation-rule-names red)
(reduction-relation-lws red) (reduction-relation-lws red)
(let ([orig-pat (reduction-relation-domain-pat red)]) (let ([orig-pat (reduction-relation-domain-pat red)])
(cond (cond
[(equal? orig-pat `any) [(equal? orig-pat `any)
;; special case for backwards compatibility: ;; special case for backwards compatibility:
;; if there was no #:domain argument, then we ;; if there was no #:domain argument, then we
;; probably should let the compatible closure also ;; probably should let the compatible closure also
;; not have a domain ;; not have a domain
`any] `any]
[else [else
`(in-hole ,pat ,orig-pat)]))))) `(in-hole ,pat ,orig-pat)]))))
(define (apply-reduction-relation/tagged p v) (define (apply-reduction-relation/tagged p v)
(let loop ([procs (reduction-relation-procs p)] (let loop ([procs (reduction-relation-procs p)]

11
pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt
View File

@ -3166,6 +3166,17 @@
"no error raised")) "no error raised"))
(test #t (regexp-match? #rx"^compatible-closure:.*fred" err-msg))) (test #t (regexp-match? #rx"^compatible-closure:.*fred" err-msg)))
;; this tests that context-closure (and thus compatible-closure)
;; play along properly with way extend-reduction-relation handles
;; language extensions
(let ()
(define-language L0 (K ::= number))
(define r (reduction-relation L0 (--> 5 6)))
(define r0 (context-closure r L0 (hole K)))
(define-language L1 (K ::= string))
(define r1 (extend-reduction-relation r0 L1))
(test (apply-reduction-relation r1 (term (5 "14"))) (list '(6 "14"))))
(let* ([R (reduction-relation (let* ([R (reduction-relation
empty-language empty-language