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)

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

@ -500,22 +500,28 @@ 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)]
[record-binder
(λ (pat under assignments)
(if (null? under)
assignments
(let ([last (hash-ref last-contexts pat #f)])
(if last
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)
(begin
(hash-set! last-contexts pat under)
assignments)))))]
[assignments [assignments
(let recur ([pat pattern] [under null] [assignments #hasheq()]) (let recur ([pat pattern] [under null] [assignments #hasheq()])
(match pat (match pat
;; `(name ,id ,sub-pat) not considered, since bindings introduced ;; `(name ,id ,sub-pat) not considered, since bindings introduced
;; by name must be unique. ;; by name must be unique.
[(and (? symbol?) (app symbol->string (regexp named-nt-rx))) [(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
(if (null? under) (record-binder pat under assignments)]
assignments [(struct ellipsis (name sub-pat (struct class (cls)) _))
(let ([last (hash-ref last-contexts pat #f)]) (recur sub-pat (cons cls under)
(if last (if (and (symbol? name) (regexp-match named-ellipsis-rx (symbol->string name)))
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last) (record-binder name under assignments)
(begin assignments))]
(hash-set! last-contexts pat under)
assignments))))]
[(struct ellipsis (_ sub-pat (struct class (cls)) _))
(recur sub-pat (cons cls under) assignments)]
[(? list?) [(? list?)
(foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)] (foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)]
[_ assignments]))]) [_ assignments]))])