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

Fixes `extend-reduction-relation' bug.

Browse Source 
The #:domain argument did not apply to inherited rules.
This commit is contained in:
Casey Klein 2011-01-08 16:38:02 -06:00
parent 56a548c517
commit 3c2e2fc362
3 changed files with 74 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -976,13 +976,12 @@
(set! counter (+ counter 1)))
(reduction-relation-rule-names red)))
(reverse lst)) ;; reverse here so the names get put into the hash in the proper (backwards) order
(build-reduction-relation
#f
(make-reduction-relation
first-lang
(reverse (apply append (map reduction-relation-make-procs lst)))
(map car (sort (hash-map name-ht list) < #:key cadr))
(apply append (map reduction-relation-lws lst))
`any)))
(apply append (map reduction-relation-lws lst))
(reverse (apply append (map reduction-relation-procs lst))))))
(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc rhs-from)
(define (subst from to in)

95
collects/redex/private/struct.rkt
View File

@ -8,7 +8,7 @@
reduction-relation-rule-names
reduction-relation-lws
reduction-relation-procs
build-reduction-relation
build-reduction-relation make-reduction-relation
reduction-relation?
empty-reduction-relation
make-rewrite-proc rewrite-proc? rewrite-proc-name
@ -48,59 +48,40 @@
'()
'()))
;; the domain pattern isn't actually used here.
;; I started to add it, but didn't finish. -robby
(define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws domain-pattern)
(let* ([make-procs/check-domain
(let loop ([make-procs make-procs]
[i 0])
(cond
[(null? make-procs) null]
[else
(let ([make-proc (car make-procs)])
(cons (make-rewrite-proc
(λ (lang)
(let ([compiled-domain-pat (compile-pattern lang domain-pattern #f)]
[proc (make-proc lang)])
(λ (tl-exp exp f acc)
(unless (match-pattern compiled-domain-pat tl-exp)
(error 'reduction-relation "relation not defined for ~s" tl-exp))
(let ([ress (proc tl-exp exp f acc)])
(for-each
(λ (res)
(let ([term (caddr res)])
(unless (match-pattern compiled-domain-pat term)
(error 'reduction-relation "relation reduced to ~s via ~a, which is outside its domain"
term
(let ([name (rewrite-proc-name make-proc)])
(if name
(format "the rule named ~a" name)
(format "rule #~a (counting from 0)" i)))))))
ress)
ress))))
(rewrite-proc-name make-proc)
(rewrite-proc-lhs make-proc)
(rewrite-proc-lhs-src make-proc)
(rewrite-proc-id make-proc))
(loop (cdr make-procs)
(+ i 1))))]))])
(cond
[orig-reduction-relation
(let* ([new-names (map rewrite-proc-name make-procs)]
[all-make-procs
(append
(filter (λ (x) (or (not (rewrite-proc-name x))
(not (member (rewrite-proc-name x) new-names))))
(reduction-relation-make-procs orig-reduction-relation))
make-procs/check-domain)])
(make-reduction-relation lang
all-make-procs
(remove-duplicates
(append rule-names
(reduction-relation-rule-names orig-reduction-relation)))
lws ;; only keep new lws for typesetting
(map (λ (make-proc) (make-proc lang)) all-make-procs)))]
[else
(make-reduction-relation lang make-procs/check-domain rule-names lws
(map (λ (make-proc) (make-proc lang))
make-procs/check-domain))])))
(define (build-reduction-relation original language rules rule-names lws domain)
(define combined-rules
(if original
(append
(filter (λ (rule)
(or (not (rewrite-proc-name rule))
(not (member (string->symbol (rewrite-proc-name rule)) rule-names))))
(reduction-relation-make-procs original))
rules)
rules))
(define combined-rule-names
(if original
(remove-duplicates (append rule-names (reduction-relation-rule-names original)))
rule-names))
(define compiled-domain
(compile-pattern language domain #f))
(make-reduction-relation
language combined-rules combined-rule-names lws
(map (λ (rule)
(define specialized (rule language))
(λ (tl-exp exp f acc)
(unless (match-pattern compiled-domain tl-exp)
(error 'reduction-relation "relation not defined for ~s" tl-exp))
(let ([ress (specialized tl-exp exp f acc)])
(for-each
(λ (res)
(let ([term (caddr res)])
(unless (match-pattern compiled-domain term)
(error 'reduction-relation "relation reduced to ~s via ~a, which is outside its domain"
term
(let ([name (rewrite-proc-name rule)])
(if name
(format "the rule named ~a" name)
"an unnamed rule"))))))
ress)
ress)))
combined-rules)))

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

@ -1239,7 +1239,7 @@
(with-handlers ((exn? exn-message))
(apply-reduction-relation red 1)
'no-exception-raised))
"reduction-relation: relation reduced to x via rule #0 (counting from 0), which is outside its domain")
"reduction-relation: relation reduced to x via an unnamed rule, which is outside its domain")
(let* ([red1
(reduction-relation
@ -1283,6 +1283,20 @@
(test (apply-reduction-relation r2 3)
'(3)))
(let ()
(define-language L)
(define R
(reduction-relation L #:domain 1 (--> any any)))
(define S
(extend-reduction-relation R L #:domain 2))
;; test that the new domain applies to inherited rules
(test (apply-reduction-relation S 2)
'(2))
(test (with-handlers ([exn:fail? exn-message])
(apply-reduction-relation S 1))
#rx"not defined"))
(let ()
(define-language L)
(define R
@ -1294,6 +1308,24 @@
(test (reduction-relation->rule-names S)
'(a)))
(let ()
(define-language L)
;; test that symbol-named rules replace string-named rules
(test (apply-reduction-relation
(extend-reduction-relation
(reduction-relation L (--> 1 1 "a"))
L (--> 1 2 a))
1)
'(2))
;; and vice versa
(test (apply-reduction-relation
(extend-reduction-relation
(reduction-relation L (--> 1 1 a))
L (--> 1 2 "a"))
1)
'(2)))
(let ()
(define-language l1
(D 0 1 2))