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

Fixed PR8789.

Browse Source 
svn: r7248
This commit is contained in:
Jens Axel Soegaard 2007-09-01 10:44:13 +00:00
parent 162df3d463
commit bc90208be1
2 changed files with 48 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/srfi/42/comprehensions.ss
View File

@ -305,11 +305,52 @@
(syntax-rules ()
((:while cc (g arg1 arg ...) test)
(g (:while-1 cc test) arg1 arg ...) )))
(define-syntax :while-1
(syntax-rules (:do)
(syntax-rules (:do let)
((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
(:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
(:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss)))))
(define-syntax :while-2
(syntax-rules (:do let)
((:while-2 cc
test
(ib-let ...)
(ib-save ...)
(ib-restore ...)
(:do olet
lbs
ne1?
(let ((ib-var ib-rhs) ib ...) ic ...)
ne2?
lss))
(:while-2 cc
test
(ib-let ... (ib-tmp #f))
(ib-save ... (ib-var ib-rhs))
(ib-restore ... (ib-var ib-tmp))
(:do olet
lbs
ne1?
(let (ib ...) ic ... (set! ib-tmp ib-var))
ne2?
lss)))
((:while-2 cc
test
(ib-let ...)
(ib-save ...)
(ib-restore ...)
(:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
(:do cc
(let (ob ... ib-let ...) oc ...)
lbs
(let ((ne1?-value ne1?))
(let (ib-save ...)
ic ...
(and ne1?-value test)))
(let (ib-restore ...))
ne2?
lss))))
(define-syntax :until

4
collects/srfi/42/examples-42.ss
View File

@ -472,7 +472,11 @@
(list x i))
=> '((0 10) (1 9) (2 8) (3 7) (4 6)) )
; See PR8789
(my-check (list-ec (:while (:list p '(2 3 5 7 11 13)) (> 10 p)) p)
=> '(2 3 5 7))
; ==========================================================================
; Less artificial examples
; ==========================================================================