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

fix `for' to track inlined sequence generators via 'disappeared-use

Browse Source
This commit is contained in:
Matthew Flatt 2010-05-25 19:08:53 -06:00
parent 2240e54660
commit 451961e596
1 changed files with 14 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/racket/private/for.rkt
View File

@ -175,11 +175,17 @@
[certifier (sequence-transformer-ref m 2)]) [certifier (sequence-transformer-ref m 2)])
(let ([xformed (xformer (introducer (syntax-local-introduce clause)))]) (let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
(if xformed (if xformed
(expand-clause orig-stx (certify-clause (syntax-case clause () (let ([r (expand-clause orig-stx
(certify-clause (syntax-case clause ()
[(_ rhs) #'rhs]) [(_ rhs) #'rhs])
(syntax-local-introduce (introducer xformed)) (syntax-local-introduce (introducer xformed))
certifier certifier
introducer)) introducer))])
(syntax-property r
'disappeared-use
(cons (syntax-local-introduce #'form)
(or (syntax-property r 'disappeared-use)
null))))
(eloop #f)))))] (eloop #f)))))]
[[(id ...) (:do-in . body)] [[(id ...) (:do-in . body)]
(syntax-case #'body () (syntax-case #'body ()
@ -809,8 +815,12 @@
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...) [(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...)
(clause . rest) . body) (clause . rest) . body)
(with-syntax ([bind (expand-clause #'orig-stx #'clause)]) (with-syntax ([bind (expand-clause #'orig-stx #'clause)])
#`(frm [orig-stx nested? nested? (bind . binds)] (let ([r #`(frm [orig-stx nested? nested? (bind . binds)]
([fold-var fold-init] ...) rest . body))] ([fold-var fold-init] ...) rest . body)]
[d (syntax-property #'bind 'disappeared-use)])
(if d
(syntax-property r 'disappeared-use d)
r)))]
[(_ [orig-stx . _] . _) [(_ [orig-stx . _] . _)
(raise-syntax-error #f "bad syntax" #'orig-stx)])) (raise-syntax-error #f "bad syntax" #'orig-stx)]))