From bc90208be1a0bd6556da7fdf3a70d5f4ac2f0124 Mon Sep 17 00:00:00 2001
From: Jens Axel Soegaard <soegaard@racket-lang.org>
Date: Sat, 1 Sep 2007 10:44:13 +0000
Subject: [PATCH] Fixed PR8789.

svn: r7248
---
 collects/srfi/42/comprehensions.ss | 47 ++++++++++++++++++++++++++++--
 collects/srfi/42/examples-42.ss    |  4 +++
 2 files changed, 48 insertions(+), 3 deletions(-)

diff --git a/collects/srfi/42/comprehensions.ss b/collects/srfi/42/comprehensions.ss
index 257e3520dd..54d38f0a5c 100644
--- a/collects/srfi/42/comprehensions.ss
+++ b/collects/srfi/42/comprehensions.ss
@@ -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
diff --git a/collects/srfi/42/examples-42.ss b/collects/srfi/42/examples-42.ss
index 095e6ed880..eb8ee7936b 100644
--- a/collects/srfi/42/examples-42.ss
+++ b/collects/srfi/42/examples-42.ss
@@ -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
 ; ==========================================================================