diff --git a/collects/srfi/42/comprehensions.ss b/collects/srfi/42/comprehensions.ss index 54d38f0a5c..1618a7c297 100644 --- a/collects/srfi/42/comprehensions.ss +++ b/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)))) diff --git a/collects/srfi/42/examples-42.ss b/collects/srfi/42/examples-42.ss index eb8ee7936b..6e85af87e6 100644 --- a/collects/srfi/42/examples-42.ss +++ b/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 ; ==========================================================================