Update SRFI 42 to latest reference implementation.

svn: r8128

collects/srfi/42/comprehensions.ss

@@ -1,4 +1,6 @@
 ; SRFI 42 as a module in PLT -----------------------------------------------
+; sebastian_egner@yahoo.com, 26-Dec-2007, PLT 371.
+;   + bugs found by sunnan and jens axel soegaard fixed
 ; Sebastian.Egner@philips.com, 15-May-2003, PLT 204.
 ; For running demos: (require (lib "examples.ss" "srfi" "42"))
 ; For anything else: http://srfi.schemers.org/srfi-42/
@@ -305,7 +307,7 @@
   (syntax-rules ()
     ((:while cc (g arg1 arg ...) test)
      (g (:while-1 cc test) arg1 arg ...) )))
-  
+
 (define-syntax :while-1
   (syntax-rules (:do let)
     ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
@@ -313,27 +315,27 @@
 
 (define-syntax :while-2
   (syntax-rules (:do let)
-    ((:while-2 cc
-               test
+    ((:while-2 cc 
+               test 
                (ib-let     ...)
                (ib-save    ...)
                (ib-restore ...)
-               (:do olet
-                    lbs
-                    ne1?
+               (:do olet 
+                    lbs 
+                    ne1? 
                     (let ((ib-var ib-rhs) ib ...) ic ...)
-                    ne2?
+                    ne2? 
                     lss))
-     (:while-2 cc
-               test
+     (: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?
+               (:do olet 
+                    lbs 
+                    ne1? 
+                    (let (ib ...) ic ... (set! ib-tmp ib-var)) 
+                    ne2? 
                     lss)))
     ((:while-2 cc
                test
@@ -345,9 +347,10 @@
           (let (ob ... ib-let ...) oc ...)
           lbs
           (let ((ne1?-value ne1?))
-            (let (ib-save ...)
-                ic ...
-                (and ne1?-value test)))
+	    (and ne1?-value
+		 (let (ib-save ...)
+		   ic ...
+		   test)))
           (let (ib-restore ...))
           ne2?
           lss))))

collects/srfi/42/examples-42.ss

@@ -1,4 +1,6 @@
 ; Examples for SRFI 42 as a module to PLT 204 ------------------------------
+; sebastian_egner@yahoo.com, 26-Dec-2007, PLT 371.
+;   + check fix for bugs found by sunnan and jens axel soegaard
 ; Sebastian.Egner@philips.com, 7-July-2003, PLT 204.
 ; For running the demos: (require (lib "examples-42.ss" "srfi" "42"))
 ; For anything else: http://srfi.schemers.org/srfi-42/
@@ -349,6 +351,7 @@
  (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x))
  => '((1 a) (2 b) (3 c)) )
 
+
 (my-check 
  (list-ec (:while (:range i 1 10) (< i 5)) i)
  => '(1 2 3 4) )
@@ -357,6 +360,78 @@
  (list-ec (:until (:range i 1 10) (>= i 5)) i)
  => '(1 2 3 4 5) )
 
+; with generator that might use inner bindings
+
+(my-check
+ (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i)
+ => '(1 2 3 4) )
+; Was broken in original reference implementation as pointed
+; out by sunnan@handgranat.org on 24-Apr-2005 comp.lang.scheme.
+; Refer to http://groups-beta.google.com/group/comp.lang.scheme/
+; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038
+
+(my-check 
+ (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+(my-check
+ (list-ec (:while (:vector x (index i) '#(1 2 3 4 5))
+		  (< x 10))
+	  x)
+ => '(1 2 3 4 5))
+; Was broken in reference implementation, even after fix for the
+; bug reported by Sunnan, as reported by Jens-Axel Soegaard on
+; 4-Jun-2007.
+
+; combine :while/:until and :parallel
+
+(my-check
+ (list-ec (:while (:parallel (:range i 1 10)
+                             (:list j '(1 2 3 4 5 6 7 8 9)))
+                  (< i 5))
+          (list i j))
+ => '((1 1) (2 2) (3 3) (4 4)))
+
+(my-check
+ (list-ec (:until (:parallel (:range i 1 10)
+                             (:list j '(1 2 3 4 5 6 7 8 9)))
+                  (>= i 5))
+          (list i j))
+ => '((1 1) (2 2) (3 3) (4 4) (5 5)))
+
+; check that :while/:until really stop the generator
+
+(my-check
+ (let ((n 0))
+   (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5)))
+          (if #f #f))
+   n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+   (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5)))
+          (if #f #f))
+   n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+   (do-ec (:while (:parallel (:range i 1 10)
+                             (:do () (begin (set! n (+ n 1)) #t) ()))
+                  (< i 5))
+          (if #f #f))
+   n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+   (do-ec (:until (:parallel (:range i 1 10)
+                             (:do () (begin (set! n (+ n 1)) #t) ()))
+                  (>= i 5))
+          (if #f #f))
+   n)
+ => 5)
 
 ; ==========================================================================
 ; The dispatching generator
@@ -472,11 +547,7 @@
           (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
 ; ==========================================================================