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

Fixed bug in generation of ellipses.

Browse Source 
svn: r11794
This commit is contained in:
Casey Klein 2008-09-18 04:51:02 +00:00
parent 432a1424ef
commit 189ef12cd0
2 changed files with 20 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/redex/private/rg-test.ss
View File

@ -546,6 +546,9 @@
'((..._1 . ..._3) (..._2 . ..._3) (..._4 . ..._3))) '((..._1 . ..._3) (..._2 . ..._3) (..._4 . ..._3)))
(test (hash-map (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1))) (test (hash-map (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1)))
(λ (_ cls) cls)) (λ (_ cls) cls))
'(..._1 ..._1))) '(..._1 ..._1))
(test-class-reassignments
'((3 ..._1) ..._2 (4 ..._1) ..._3)
'((..._2 . ..._3))))
(print-tests-passed 'rg-test.ss) (print-tests-passed 'rg-test.ss)

24
collects/redex/private/rg.ss
View File

@ -500,12 +500,8 @@ To do a better job of not generating programs with free variables,
(if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd))) (if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd)))
(let* ([last-contexts (make-hasheq)] (let* ([last-contexts (make-hasheq)]
[assignments [record-binder
(let recur ([pat pattern] [under null] [assignments #hasheq()]) (λ (pat under assignments)
(match pat
;; `(name ,id ,sub-pat) not considered, since bindings introduced
;; by name must be unique.
[(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
(if (null? under) (if (null? under)
assignments assignments
(let ([last (hash-ref last-contexts pat #f)]) (let ([last (hash-ref last-contexts pat #f)])
@ -513,9 +509,19 @@ To do a better job of not generating programs with free variables,
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last) (foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)
(begin (begin
(hash-set! last-contexts pat under) (hash-set! last-contexts pat under)
assignments))))] assignments)))))]
[(struct ellipsis (_ sub-pat (struct class (cls)) _)) [assignments
(recur sub-pat (cons cls under) assignments)] (let recur ([pat pattern] [under null] [assignments #hasheq()])
(match pat
;; `(name ,id ,sub-pat) not considered, since bindings introduced
;; by name must be unique.
[(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
(record-binder pat under assignments)]
[(struct ellipsis (name sub-pat (struct class (cls)) _))
(recur sub-pat (cons cls under)
(if (and (symbol? name) (regexp-match named-ellipsis-rx (symbol->string name)))
(record-binder name under assignments)
assignments))]
[(? list?) [(? list?)
(foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)] (foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)]
[_ assignments]))]) [_ assignments]))])