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

Fixes a bug in the Redex term generator

Browse Source
This commit is contained in:
Casey Klein 2010-12-10 09:50:34 -06:00
parent d55cdb7785
commit 7243029786
2 changed files with 37 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/redex/private/rg.rkt
View File

@ -354,12 +354,12 @@
(let ([cross? (not (symbol? pat))])
(λ (r s a e f)
(values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))]
[(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p)))
(let ([g (recur p)])
[(? binder?)
(let ([g (recur (binder-pattern pat))])
(λ (r s a e f)
(generate/prior pat e (λ () (g r s a e f)))))]
[(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p)))
(let ([g (recur p)])
[(? mismatch?)
(let ([g (recur (mismatch-pattern pat))])
(set! mismatches? #t)
(λ (r s a e f)
(let-values ([(ts e) (g r s a e f)])
@ -451,13 +451,18 @@
(let ([nts '()])
(let loop ([pat pat])
(match pat
[(? symbol? pat)
(when ((is-nt? lang) (symbol->nt pat))
(set! nts (cons (cons #f (symbol->nt pat)) nts)))]
[(? binder?)
(set! nts (cons (cons #f (binder-pattern pat)) nts))]
[(? mismatch?)
(set! nts (cons (cons #f (mismatch-pattern pat)) nts))]
[(? symbol?)
(when ((is-nt? lang) pat)
(set! nts (cons (cons #f pat) nts)))]
[`(cross ,(? symbol? x-nt))
(set! nts (cons (cons #t x-nt) nts))]
[`(variable-except ,s ...) (void)]
[`(variable-prefix ,p) (void)]
[`(name ,_ ,p) (loop p)]
[`() (void)]
[(struct ellipsis (_ p _ _))
(loop p)]
@ -535,8 +540,20 @@
(and match (cadr match) (string->symbol (cadr match))))))
(define-struct class (id) #:inspector (make-inspector))
(define-struct mismatch (id group) #:inspector (make-inspector))
(define mismatch-pattern
(match-lambda
[(struct mismatch (_ name))
((symbol-match mismatch-nt-rx) name)]))
(define-struct binder (name) #:inspector (make-inspector))
(define binder-pattern
(match-lambda
[(struct binder (name))
(match ((symbol-match named-nt-rx) name)
[#f name]
[p p])]))
;; name: (or/c symbol? mismatch?)
;; The generator records `name' in the environment when generating an ellipsis,

21
collects/redex/tests/rg-test.rkt
View File

@ -42,11 +42,14 @@
(begin (output (λ () expr)) 'no-violation))
expected))]))
(define find-base-cases/unparsed
(compose find-base-cases parse-language))
(let ()
(define-language lc
(e x (e e) (λ (x) e))
(x variable))
(let ([bc (find-base-cases lc)])
(let ([bc (find-base-cases/unparsed lc)])
(test (to-table (base-cases-non-cross bc))
'((e . (1 2 2)) (x . (0))))
(test (to-table (base-cases-cross bc))
@ -55,7 +58,7 @@
(let ()
(define-language lang
(e (e e)))
(let ([bc (find-base-cases lang)])
(let ([bc (find-base-cases/unparsed lang)])
(test (to-table (base-cases-non-cross bc)) '((e . (inf))))
(test (to-table (base-cases-cross bc)) '((e-e . (0 inf inf))))))
@ -63,7 +66,7 @@
(define-language lang
(a 1 2 3)
(b a (a_1 b_!_1)))
(let ([bc (find-base-cases lang)])
(let ([bc (find-base-cases/unparsed lang)])
(test (to-table (base-cases-non-cross bc))
'((a . (0 0 0)) (b . (1 2))))
(test (to-table (base-cases-cross bc))
@ -78,7 +81,7 @@
(v (λ (x) e)
number)
(x variable))
(let ([bc (find-base-cases lc)])
(let ([bc (find-base-cases/unparsed lc)])
(test (to-table (base-cases-non-cross bc))
'((e . (2 2 1 1)) (v . (2 0)) (x . (0))))
(test (to-table (base-cases-cross bc))
@ -88,10 +91,12 @@
(let ()
(define-language L
(x (variable-prefix x)
(variable-except y))
(variable-except y)
(name x 1)
(name y 1))
(y y))
(test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x)
'(0 0)))
(test (hash-ref (base-cases-non-cross (find-base-cases/unparsed L)) 'x)
'(0 0 0 0)))
(define (make-random . nums)
(let ([nums (box nums)])
@ -542,7 +547,7 @@
(decisions #:nt (patterns first)))
47)
(test (hash-ref (base-cases-non-cross (find-base-cases name-collision)) 'e-e)
(test (hash-ref (base-cases-non-cross (find-base-cases/unparsed name-collision)) 'e-e)
'(0)))
(let ()