--- /dev/null
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Loading the implementation into Scheme48 0.57:
+; ,open srfi-23
+; ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+; ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+;
+; Implementation comments:
+; * All local (not exported) identifiers are named ec-<something>.
+; * This implementation focuses on portability, performance,
+; readability, and simplicity roughly in this order. Design
+; decisions related to performance are taken for Scheme48.
+; * Alternative implementations, Comments and Warnings are
+; mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do.
+;
+; We use the following short names for syntactic variables
+; q - qualifier
+; cc - current continuation, thing to call at the end;
+; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+; cmd - an expression being evaluated for its side-effects
+; expr - an expression
+; gen - a generator of an eager comprehension
+; ob - outer binding
+; oc - outer command
+; lb - loop binding
+; ne1? - not-end1? (before the payload)
+; ib - inner binding
+; ic - inner command
+; ne2? - not-end2? (after the payload)
+; ls - loop step
+; etc - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+; handles nested, if/not/and/or, begin, :let, and calls generator
+; macros in CPS to transform them into fully decorated :do.
+; The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+ (syntax-rules (nested if not and or begin :do let)
+
+ ; explicit nesting -> implicit nesting
+ ((do-ec (nested q ...) etc ...)
+ (do-ec q ... etc ...) )
+
+ ; implicit nesting -> fold do-ec
+ ((do-ec q1 q2 etc1 etc ...)
+ (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+ ; no qualifiers at all -> evaluate cmd once
+ ((do-ec cmd)
+ (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+ ; filter -> make conditional
+ ((do-ec (if test) cmd)
+ (if test (do-ec cmd)) )
+ ((do-ec (not test) cmd)
+ (if (not test) (do-ec cmd)) )
+ ((do-ec (and test ...) cmd)
+ (if (and test ...) (do-ec cmd)) )
+ ((do-ec (or test ...) cmd)
+ (if (or test ...) (do-ec cmd)) )
+
+ ; begin -> make a sequence
+ ((do-ec (begin etc ...) cmd)
+ (begin etc ... (do-ec cmd)) )
+
+ ; fully decorated :do-generator -> delegate to do-ec:do
+ ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
+ (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+ ((do-ec (g arg1 arg ...) cmd)
+ (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))
+; generates code for a single fully decorated :do-generator
+; with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+ (syntax-rules (:do let)
+
+ ; reentry point (*) -> generate code
+ ((do-ec:do cmd
+ (:do (let obs oc ...)
+ lbs
+ ne1?
+ (let ibs ic ...)
+ ne2?
+ (ls ...) ))
+ (ec-simplify
+ (let obs
+ oc ...
+ (let loop lbs
+ (ec-simplify
+ (if ne1?
+ (ec-simplify
+ (let ibs
+ ic ...
+ cmd
+ (ec-simplify
+ (if ne2?
+ (loop ls ...) )))))))))) ))
+
+
+; (ec-simplify <expression>)
+; generates potentially more efficient code for <expression>.
+; The macro handles if, (begin <command>*), and (let () <command>*)
+; and takes care of special cases.
+
+(define-syntax ec-simplify
+ (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+ ; literal <test>
+ ((ec-simplify (if #t consequent))
+ consequent )
+ ((ec-simplify (if #f consequent))
+ (if #f #f) )
+ ((ec-simplify (if #t consequent alternate))
+ consequent )
+ ((ec-simplify (if #f consequent alternate))
+ alternate )
+
+ ; (not (not <test>))
+ ((ec-simplify (if (not (not test)) consequent))
+ (ec-simplify (if test consequent)) )
+ ((ec-simplify (if (not (not test)) consequent alternate))
+ (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*)
+
+ ; empty <binding spec>*
+ ((ec-simplify (let () command ...))
+ (ec-simplify (begin command ...)) )
+
+; begin
+
+ ; flatten use helper (ec-simplify 1 done to-do)
+ ((ec-simplify (begin command ...))
+ (ec-simplify 1 () (command ...)) )
+ ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+ (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+ ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+ (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+ ; exit helper
+ ((ec-simplify 1 () ())
+ (if #f #f) )
+ ((ec-simplify 1 (command) ())
+ command )
+ ((ec-simplify 1 (command1 command ...) ())
+ (begin command1 command ...) )
+
+; anything else
+
+ ((ec-simplify expression)
+ expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax :do
+ (syntax-rules ()
+
+ ; full decorated -> continue with cc, reentry at (*)
+ ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
+ (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
+
+ ; short form -> fill in default values
+ ((:do cc lbs ne1? lss)
+ (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+
+
+(define-syntax :let
+ (syntax-rules (index)
+ ((:let cc var (index i) expression)
+ (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+ ((:let cc var expression)
+ (:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax :parallel
+ (syntax-rules (:do)
+ ((:parallel cc)
+ cc )
+ ((:parallel cc (g arg1 arg ...) gen ...)
+ (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (:parallel-1 cc (to-do ...) result [ next ] )
+; iterates over to-do by converting the first generator into
+; the :do-generator next and merging next into result.
+
+(define-syntax :parallel-1 ; used as
+ (syntax-rules (:do let)
+
+ ; process next element of to-do, reentry at (**)
+ ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+ (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+ ; reentry point (**) -> merge next into result
+ ((:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ...) oc1 ...)
+ (lb1 ...)
+ ne1?1
+ (let (ib1 ...) ic1 ...)
+ ne2?1
+ (ls1 ...) )
+ (:do (let (ob2 ...) oc2 ...)
+ (lb2 ...)
+ ne1?2
+ (let (ib2 ...) ic2 ...)
+ ne2?2
+ (ls2 ...) ))
+ (:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)
+ (lb1 ... lb2 ...)
+ (and ne1?1 ne1?2)
+ (let (ib1 ... ib2 ...) ic1 ... ic2 ...)
+ (and ne2?1 ne2?2)
+ (ls1 ... ls2 ...) )))
+
+ ; no more gens -> continue with cc, reentry at (*)
+ ((:parallel-1 (cc ...) () result)
+ (cc ... result) )))
+
+(define-syntax :while
+ (syntax-rules ()
+ ((:while cc (g arg1 arg ...) test)
+ (g (:while-1 cc test) arg1 arg ...) )))
+
+; (:while-1 cc test (:do ...))
+; modifies the fully decorated :do-generator such that it
+; runs while test is a true value.
+; The original implementation just replaced ne1? by
+; (and ne1? test) as follows:
+;
+; (define-syntax :while-1
+; (syntax-rules (:do)
+; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+; (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+; Unfortunately, this code is wrong because ne1? may depend
+; in the inner bindings introduced in ilet, but ne1? is evaluated
+; outside of the inner bindings. (Refer to the specification of
+; :do to see the structure.)
+; The problem manifests itself (as sunnan@handgranat.org
+; observed, 25-Apr-2005) when the :list-generator is modified:
+;
+; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).
+;
+; In order to generate proper code, we introduce temporary
+; variables saving the values of the inner bindings. The inner
+; bindings are executed in a new ne1?, which also evaluates ne1?
+; outside the scope of the inner bindings, then the inner commands
+; are executed (possibly changing the variables), and then the
+; values of the inner bindings are saved and (and ne1? test) is
+; returned. In the new ilet, the inner variables are bound and
+; initialized and their values are restored. So we construct:
+;
+; (let (ob .. (ib-tmp #f) ...)
+; oc ...
+; (let loop (lb ...)
+; (if (let (ne1?-value ne1?)
+; (let ((ib-var ib-rhs) ...)
+; ic ...
+; (set! ib-tmp ib-var) ...)
+; (and ne1?-value test))
+; (let ((ib-var ib-tmp) ...)
+; /payload/
+; (if ne2?
+; (loop ls ...) )))))
+;
+; Bug #2:
+; Unfortunately, the above expansion is still incorrect (as Jens-Axel
+; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+; if ne1?-value is #f, indicating that the loop has ended.
+; The problem manifests itself in the following example:
+;
+; (do-ec (:while (:list x '(1)) #t) (display x))
+;
+; Which iterates :list beyond exhausting the list '(1).
+;
+; For the fix, we follow Jens-Axel's approach of guarding the evaluation
+; of ib-rhs with a check on ne1?-value.
+
+(define-syntax :while-1
+ (syntax-rules (:do let)
+ ((:while-1 cc test (:do olet lbs ne1? 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?))
+ (and ne1?-value
+ (let (ib-save ...)
+ ic ...
+ test)))
+ (let (ib-restore ...))
+ ne2?
+ lss))))
+
+
+(define-syntax :until
+ (syntax-rules ()
+ ((:until cc (g arg1 arg ...) test)
+ (g (:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax :until-1
+ (syntax-rules (:do)
+ ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax :list
+ (syntax-rules (index)
+ ((:list cc var (index i) arg ...)
+ (:parallel cc (:list var arg ...) (:integers i)) )
+ ((:list cc var arg1 arg2 arg ...)
+ (:list cc var (append arg1 arg2 arg ...)) )
+ ((:list cc var arg)
+ (:do cc
+ (let ())
+ ((t arg))
+ (not (null? t))
+ (let ((var (car t))))
+ #t
+ ((cdr t)) ))))
+
+
+(define-syntax :string
+ (syntax-rules (index)
+ ((:string cc var (index i) arg)
+ (:do cc
+ (let ((str arg) (len 0))
+ (set! len (string-length str)))
+ ((i 0))
+ (< i len)
+ (let ((var (string-ref str i))))
+ #t
+ ((+ i 1)) ))
+ ((:string cc var (index i) arg1 arg2 arg ...)
+ (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+ ((:string cc var arg1 arg ...)
+ (:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+; be used for :string. However, it is less interesting as the
+; overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax :vector
+ (syntax-rules (index)
+ ((:vector cc var arg)
+ (:vector cc var (index i) arg) )
+ ((:vector cc var (index i) arg)
+ (:do cc
+ (let ((vec arg) (len 0))
+ (set! len (vector-length vec)))
+ ((i 0))
+ (< i len)
+ (let ((var (vector-ref vec i))))
+ #t
+ ((+ i 1)) ))
+
+ ((:vector cc var (index i) arg1 arg2 arg ...)
+ (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
+ ((:vector cc var arg1 arg2 arg ...)
+ (:do cc
+ (let ((vec #f)
+ (len 0)
+ (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+ ((k 0))
+ (if (< k len)
+ #t
+ (if (null? vecs)
+ #f
+ (begin (set! vec (car vecs))
+ (set! vecs (cdr vecs))
+ (set! len (vector-length vec))
+ (set! k 0)
+ #t )))
+ (let ((var (vector-ref vec k))))
+ #t
+ ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+ (if (null? vecs)
+ '()
+ (if (zero? (vector-length (car vecs)))
+ (ec-:vector-filter (cdr vecs))
+ (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+; append and :list in the multi-argument case. Please refer to the
+; 'design.scm' for more details.
+
+
+(define-syntax :integers
+ (syntax-rules (index)
+ ((:integers cc var (index i))
+ (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+ ((:integers cc var)
+ (:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax :range
+ (syntax-rules (index)
+
+ ; handle index variable and add optional args
+ ((:range cc var (index i) arg1 arg ...)
+ (:parallel cc (:range var arg1 arg ...) (:integers i)) )
+ ((:range cc var arg1)
+ (:range cc var 0 arg1 1) )
+ ((:range cc var arg1 arg2)
+ (:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+ ((:range cc var 0 arg2 1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var 0 arg2 -1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+ ((:range cc var arg1 arg2 1)
+ (:do cc
+ (let ((a arg1) (b arg2))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b 1 )) )
+ ((var a))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var arg1 arg2 -1)
+ (:do cc
+ (let ((a arg1) (b arg2) (s -1) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b -1 )) )
+ ((var a))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+; the general case
+
+ ((:range cc var arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b)
+ (integer? s) (exact? s) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b s ))
+ (if (zero? s)
+ (error "step size must not be zero in :range") )
+ (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+ ((var a))
+ (not (= var stop))
+ (let ())
+ #t
+ ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+; are exact integers. This overhead has proven very helpful for
+; saving users from themselves.
+
+
+(define-syntax :real-range
+ (syntax-rules (index)
+
+ ; add optional args and index variable
+ ((:real-range cc var arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var (index i) arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var (index i) arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var arg1 arg2 arg3)
+ (:real-range cc var (index i) arg1 arg2 arg3) )
+
+ ; the fully qualified case
+ ((:real-range cc var (index i) arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (istop 0))
+ (if (not (and (real? a) (real? b) (real? s)))
+ (error "arguments of :real-range are not real" a b s) )
+ (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+ (set! a (exact->inexact a)) )
+ (set! istop (/ (- b a) s)) )
+ ((i 0))
+ (< i istop)
+ (let ((var (+ a (* s i)))))
+ #t
+ ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+; value in case any of the other values is inexact. This is a
+; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
+
+
+(define-syntax :char-range
+ (syntax-rules (index)
+ ((:char-range cc var (index i) arg1 arg2)
+ (:parallel cc (:char-range var arg1 arg2) (:integers i)) )
+ ((:char-range cc var arg1 arg2)
+ (:do cc
+ (let ((imax (char->integer arg2))))
+ ((i (char->integer arg1)))
+ (<= i imax)
+ (let ((var (integer->char i))))
+ #t
+ ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator
+; because the integers obtained by char->integer are not necessarily
+; consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax :port
+ (syntax-rules (index)
+ ((:port cc var (index i) arg1 arg ...)
+ (:parallel cc (:port var arg1 arg ...) (:integers i)) )
+ ((:port cc var arg)
+ (:port cc var arg read) )
+ ((:port cc var arg1 arg2)
+ (:do cc
+ (let ((port arg1) (read-proc arg2)))
+ ((var (read-proc port)))
+ (not (eof-object? var))
+ (let ())
+ #t
+ ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax :dispatched
+ (syntax-rules (index)
+ ((:dispatched cc var (index i) dispatch arg1 arg ...)
+ (:parallel cc
+ (:integers i)
+ (:dispatched var dispatch arg1 arg ...) ))
+ ((:dispatched cc var dispatch arg1 arg ...)
+ (:do cc
+ (let ((d dispatch)
+ (args (list arg1 arg ...))
+ (g #f)
+ (empty (list #f)) )
+ (set! g (d args))
+ (if (not (procedure? g))
+ (error "unrecognized arguments in dispatching"
+ args
+ (d '()) )))
+ ((var (g empty)))
+ (not (eq? var empty))
+ (let ())
+ #t
+ ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+; non-empty list. It is compared using eq? which distinguishes
+; the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax :generator-proc
+ (syntax-rules (:do let)
+
+ ; call g with a variable, reentry at (**)
+ ((:generator-proc (g arg ...))
+ (g (:generator-proc var) var arg ...) )
+
+ ; reentry point (**) -> make the code from a single :do
+ ((:generator-proc
+ var
+ (:do (let obs oc ...)
+ ((lv li) ...)
+ ne1?
+ (let ((i v) ...) ic ...)
+ ne2?
+ (ls ...)) )
+ (ec-simplify
+ (let obs
+ oc ...
+ (let ((lv li) ... (ne2 #t))
+ (ec-simplify
+ (let ((i #f) ...) ; v not yet valid
+ (lambda (empty)
+ (if (and ne1? ne2)
+ (ec-simplify
+ (begin
+ (set! i v) ...
+ ic ...
+ (let ((value var))
+ (ec-simplify
+ (if ne2?
+ (ec-simplify
+ (begin (set! lv ls) ...) )
+ (set! ne2 #f) ))
+ value )))
+ empty ))))))))
+
+ ; silence warnings of some macro expanders
+ ((:generator-proc var)
+ (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+ (lambda (args)
+ (let ((g1 (d1 args)) (g2 (d2 args)))
+ (if g1
+ (if g2
+ (if (null? args)
+ (append (if (list? g1) g1 (list g1))
+ (if (list? g2) g2 (list g2)) )
+ (error "dispatching conflict" args (d1 '()) (d2 '())) )
+ g1 )
+ (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+ (lambda (args)
+ (case (length args)
+ ((0) 'SRFI42)
+ ((1) (let ((a1 (car args)))
+ (cond
+ ((list? a1)
+ (:generator-proc (:list a1)) )
+ ((string? a1)
+ (:generator-proc (:string a1)) )
+ ((vector? a1)
+ (:generator-proc (:vector a1)) )
+ ((and (integer? a1) (exact? a1))
+ (:generator-proc (:range a1)) )
+ ((real? a1)
+ (:generator-proc (:real-range a1)) )
+ ((input-port? a1)
+ (:generator-proc (:port a1)) )
+ (else
+ #f ))))
+ ((2) (let ((a1 (car args)) (a2 (cadr args)))
+ (cond
+ ((and (list? a1) (list? a2))
+ (:generator-proc (:list a1 a2)) )
+ ((and (string? a1) (string? a1))
+ (:generator-proc (:string a1 a2)) )
+ ((and (vector? a1) (vector? a2))
+ (:generator-proc (:vector a1 a2)) )
+ ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+ (:generator-proc (:range a1 a2)) )
+ ((and (real? a1) (real? a2))
+ (:generator-proc (:real-range a1 a2)) )
+ ((and (char? a1) (char? a2))
+ (:generator-proc (:char-range a1 a2)) )
+ ((and (input-port? a1) (procedure? a2))
+ (:generator-proc (:port a1 a2)) )
+ (else
+ #f ))))
+ ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+ (cond
+ ((and (list? a1) (list? a2) (list? a3))
+ (:generator-proc (:list a1 a2 a3)) )
+ ((and (string? a1) (string? a1) (string? a3))
+ (:generator-proc (:string a1 a2 a3)) )
+ ((and (vector? a1) (vector? a2) (vector? a3))
+ (:generator-proc (:vector a1 a2 a3)) )
+ ((and (integer? a1) (exact? a1)
+ (integer? a2) (exact? a2)
+ (integer? a3) (exact? a3))
+ (:generator-proc (:range a1 a2 a3)) )
+ ((and (real? a1) (real? a2) (real? a3))
+ (:generator-proc (:real-range a1 a2 a3)) )
+ (else
+ #f ))))
+ (else
+ (letrec ((every?
+ (lambda (pred args)
+ (if (null? args)
+ #t
+ (and (pred (car args))
+ (every? pred (cdr args)) )))))
+ (cond
+ ((every? list? args)
+ (:generator-proc (:list (apply append args))) )
+ ((every? string? args)
+ (:generator-proc (:string (apply string-append args))) )
+ ((every? vector? args)
+ (:generator-proc (:list (apply append (map vector->list args)))) )
+ (else
+ #f )))))))
+
+(define :-dispatch
+ (make-initial-:-dispatch) )
+
+(define (:-dispatch-ref)
+ :-dispatch )
+
+(define (:-dispatch-set! dispatch)
+ (if (not (procedure? dispatch))
+ (error "not a procedure" dispatch) )
+ (set! :-dispatch dispatch) )
+
+(define-syntax :
+ (syntax-rules (index)
+ ((: cc var (index i) arg1 arg ...)
+ (:dispatched cc var (index i) :-dispatch arg1 arg ...) )
+ ((: cc var arg1 arg ...)
+ (:dispatched cc var :-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+ (syntax-rules (nested)
+ ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 expression f1 f2)
+ (fold3-ec x0 (nested) expression f1 f2) )
+
+ ((fold3-ec x0 qualifier expression f1 f2)
+ (let ((result #f) (empty #t))
+ (do-ec qualifier
+ (let ((value expression)) ; don't duplicate
+ (if empty
+ (begin (set! result (f1 value))
+ (set! empty #f) )
+ (set! result (f2 value result)) )))
+ (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+ (syntax-rules (nested)
+ ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+ ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+ ((fold-ec x0 expression f2)
+ (fold-ec x0 (nested) expression f2) )
+
+ ((fold-ec x0 qualifier expression f2)
+ (let ((result x0))
+ (do-ec qualifier (set! result (f2 expression result)))
+ result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+ (syntax-rules ()
+ ((list-ec etc1 etc ...)
+ (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+; using set-cdr! to add at the tail. This removes the overhead of copying
+; at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+ (syntax-rules ()
+ ((append-ec etc1 etc ...)
+ (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+ (syntax-rules ()
+ ((string-ec etc1 etc ...)
+ (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+; problem. A more space-aware implementation collect the characters
+; in an intermediate list and when this list becomes too large it is
+; converted into an intermediate string. At the end, the intermediate
+; strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+ (syntax-rules ()
+ ((string-append-ec etc1 etc ...)
+ (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+ (syntax-rules ()
+ ((vector-ec etc1 etc ...)
+ (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+; However, the space overhead for the intermediate list is much lower
+; than for string-ec and as there is no vector-append, the intermediate
+; vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+ (syntax-rules (nested)
+ ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+ (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+ ((vector-of-length-ec k q1 q2 etc1 etc ...)
+ (vector-of-length-ec k (nested q1 q2) etc1 etc ...) )
+ ((vector-of-length-ec k expression)
+ (vector-of-length-ec k (nested) expression) )
+
+ ((vector-of-length-ec k qualifier expression)
+ (let ((len k))
+ (let ((vec (make-vector len))
+ (i 0) )
+ (do-ec qualifier
+ (if (< i len)
+ (begin (vector-set! vec i expression)
+ (set! i (+ i 1)) )
+ (error "vector is too short for the comprehension") ))
+ (if (= i len)
+ vec
+ (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+ (syntax-rules ()
+ ((sum-ec etc1 etc ...)
+ (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+ (syntax-rules ()
+ ((product-ec etc1 etc ...)
+ (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+ (syntax-rules ()
+ ((min-ec etc1 etc ...)
+ (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+ (syntax-rules ()
+ ((max-ec etc1 etc ...)
+ (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+ (syntax-rules (nested)
+ ((last-ec default (nested q1 ...) q etc1 etc ...)
+ (last-ec default (nested q1 ... q) etc1 etc ...) )
+ ((last-ec default q1 q2 etc1 etc ...)
+ (last-ec default (nested q1 q2) etc1 etc ...) )
+ ((last-ec default expression)
+ (last-ec default (nested) expression) )
+
+ ((last-ec default qualifier expression)
+ (let ((result default))
+ (do-ec qualifier (set! result expression))
+ result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+ (syntax-rules (nested)
+ ((first-ec default (nested q1 ...) q etc1 etc ...)
+ (first-ec default (nested q1 ... q) etc1 etc ...) )
+ ((first-ec default q1 q2 etc1 etc ...)
+ (first-ec default (nested q1 q2) etc1 etc ...) )
+ ((first-ec default expression)
+ (first-ec default (nested) expression) )
+
+ ((first-ec default qualifier expression)
+ (let ((result default) (stop #f))
+ (ec-guarded-do-ec
+ stop
+ (nested qualifier)
+ (begin (set! result expression)
+ (set! stop #t) ))
+ result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+; constructs (do-ec q ... cmd) where the generators gen in q ... are
+; replaced by (:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+ (syntax-rules (nested if not and or begin)
+
+ ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+ (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+ ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+ (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+ (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+ (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+ (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+ (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+ (do-ec
+ (:until gen stop)
+ (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+ ((ec-guarded-do-ec stop (nested) cmd)
+ (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+; possible to use call-with-current-continuation:
+;
+; (define-synatx first-ec
+; ...same as above...
+; ((first-ec default qualifier expression)
+; (call-with-current-continuation
+; (lambda (cc)
+; (do-ec qualifier (cc expression))
+; default ))) ))
+;
+; This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+ (syntax-rules (nested)
+ ((any?-ec (nested q1 ...) q etc1 etc ...)
+ (any?-ec (nested q1 ... q) etc1 etc ...) )
+ ((any?-ec q1 q2 etc1 etc ...)
+ (any?-ec (nested q1 q2) etc1 etc ...) )
+ ((any?-ec expression)
+ (any?-ec (nested) expression) )
+
+ ((any?-ec qualifier expression)
+ (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+ (syntax-rules (nested)
+ ((every?-ec (nested q1 ...) q etc1 etc ...)
+ (every?-ec (nested q1 ... q) etc1 etc ...) )
+ ((every?-ec q1 q2 etc1 etc ...)
+ (every?-ec (nested q1 q2) etc1 etc ...) )
+ ((every?-ec expression)
+ (every?-ec (nested) expression) )
+
+ ((every?-ec qualifier expression)
+ (first-ec #t qualifier (if (not expression)) #f) )))
+
--- /dev/null
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
+;;; ===================================================================
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (c) 2007 Sebastian Egner
+;;;
+;;; This code is based on the file examples.scm in the reference
+;;; implementation of SRFI-42, provided under the following license:
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; ``Software''), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;;
+
+(define-module (test-srfi-42)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-42))
+
+
+; Tools for checking results
+; ==========================
+
+(define (my-equal? x y)
+ (cond
+ ((or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (char? x)
+ (input-port? x)
+ (output-port? x) )
+ (eqv? x y) )
+ ((string? x)
+ (and (string? y) (string=? x y)) )
+ ((vector? x)
+ (and (vector? y)
+ (my-equal? (vector->list x) (vector->list y)) ))
+ ((pair? x)
+ (and (pair? y)
+ (my-equal? (car x) (car y))
+ (my-equal? (cdr x) (cdr y)) ))
+ ((real? x)
+ (and (real? y)
+ (eqv? (exact? x) (exact? y))
+ (if (exact? x)
+ (= x y)
+ (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here
+ (else
+ (error "unrecognized type" x) )))
+
+(define-syntax my-check
+ (syntax-rules (=>)
+ ((my-check ec => desired-result)
+ (pass-if (my-equal? ec desired-result)))))
+
+(define my-call-with-input-file call-with-input-file)
+(define my-open-output-file open-output-file)
+
+; ==========================================================================
+; do-ec
+; ==========================================================================
+
+(my-check
+ (let ((x 0)) (do-ec (set! x (+ x 1))) x)
+ => 1)
+
+(my-check
+ (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x)
+ => 10)
+
+(my-check
+ (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x)
+ => 45)
+
+
+; ==========================================================================
+; list-ec and basic qualifiers
+; ==========================================================================
+
+(my-check (list-ec 1) => '(1))
+
+(my-check (list-ec (:range i 4) i) => '(0 1 2 3))
+
+(my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k))
+ => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) )
+
+(my-check
+ (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k))
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k))
+ => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (and (even? n) (> n 2))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (or (even? n) (> n 3))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x)
+ => 10 )
+
+(my-check
+ (list-ec (nested (:range n 3) (:range k n)) k)
+ => '(0 0 1) )
+
+
+; ==========================================================================
+; Other comprehensions
+; ==========================================================================
+
+(my-check (append-ec '(a b)) => '(a b))
+(my-check (append-ec (:range i 0) '(a b)) => '())
+(my-check (append-ec (:range i 1) '(a b)) => '(a b))
+(my-check (append-ec (:range i 2) '(a b)) => '(a b a b))
+
+(my-check (string-ec #\a) => (string #\a))
+(my-check (string-ec (:range i 0) #\a) => "")
+(my-check (string-ec (:range i 1) #\a) => "a")
+(my-check (string-ec (:range i 2) #\a) => "aa")
+
+(my-check (string-append-ec "ab") => "ab")
+(my-check (string-append-ec (:range i 0) "ab") => "")
+(my-check (string-append-ec (:range i 1) "ab") => "ab")
+(my-check (string-append-ec (:range i 2) "ab") => "abab")
+
+(my-check (vector-ec 1) => (vector 1))
+(my-check (vector-ec (:range i 0) i) => (vector))
+(my-check (vector-ec (:range i 1) i) => (vector 0))
+(my-check (vector-ec (:range i 2) i) => (vector 0 1))
+
+(my-check (vector-of-length-ec 1 1) => (vector 1))
+(my-check (vector-of-length-ec 0 (:range i 0) i) => (vector))
+(my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0))
+(my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1))
+
+(my-check (sum-ec 1) => 1)
+(my-check (sum-ec (:range i 0) i) => 0)
+(my-check (sum-ec (:range i 1) i) => 0)
+(my-check (sum-ec (:range i 2) i) => 1)
+(my-check (sum-ec (:range i 3) i) => 3)
+
+(my-check (product-ec 1) => 1)
+(my-check (product-ec (:range i 1 0) i) => 1)
+(my-check (product-ec (:range i 1 1) i) => 1)
+(my-check (product-ec (:range i 1 2) i) => 1)
+(my-check (product-ec (:range i 1 3) i) => 2)
+(my-check (product-ec (:range i 1 4) i) => 6)
+
+(my-check (min-ec 1) => 1)
+(my-check (min-ec (:range i 1) i) => 0)
+(my-check (min-ec (:range i 2) i) => 0)
+
+(my-check (max-ec 1) => 1)
+(my-check (max-ec (:range i 1) i) => 0)
+(my-check (max-ec (:range i 2) i) => 1)
+
+(my-check (first-ec #f 1) => 1)
+(my-check (first-ec #f (:range i 0) i) => #f)
+(my-check (first-ec #f (:range i 1) i) => 0)
+(my-check (first-ec #f (:range i 2) i) => 0)
+
+(my-check
+ (let ((last-i -1))
+ (first-ec #f (:range i 10) (begin (set! last-i i)) i)
+ last-i )
+ => 0 )
+
+(my-check (last-ec #f 1) => 1)
+(my-check (last-ec #f (:range i 0) i) => #f)
+(my-check (last-ec #f (:range i 1) i) => 0)
+(my-check (last-ec #f (:range i 2) i) => 1)
+
+(my-check (any?-ec #f) => #f)
+(my-check (any?-ec #t) => #t)
+(my-check (any?-ec (:range i 2 2) (even? i)) => #f)
+(my-check (any?-ec (:range i 2 3) (even? i)) => #t)
+
+(my-check (every?-ec #f) => #f)
+(my-check (every?-ec #t) => #t)
+(my-check (every?-ec (:range i 2 2) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 3) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 4) (even? i)) => #f)
+
+(my-check
+ (let ((sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold-ec 0 (:range i 10) i sum-sqr) )
+ => 285 )
+
+(my-check
+ (let ((minus-1 (lambda (x) (- x 1)))
+ (sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) )
+ => 284 )
+
+(my-check
+ (fold3-ec 'infinity (:range i 0) i min min)
+ => 'infinity )
+
+
+; ==========================================================================
+; Typed generators
+; ==========================================================================
+
+(my-check (list-ec (:list x '()) x) => '())
+(my-check (list-ec (:list x '(1)) x) => '(1))
+(my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:list x '(1) '(2)) x) => '(1 2))
+(my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3))
+
+(my-check (list-ec (:string c "") c) => '())
+(my-check (list-ec (:string c "1") c) => '(#\1))
+(my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3))
+(my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2))
+(my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3))
+
+(my-check (list-ec (:vector x (vector)) x) => '())
+(my-check (list-ec (:vector x (vector 1)) x) => '(1))
+(my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2))
+(my-check
+ (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x)
+ => '(1 2 3))
+
+(my-check (list-ec (:range x -2) x) => '())
+(my-check (list-ec (:range x -1) x) => '())
+(my-check (list-ec (:range x 0) x) => '())
+(my-check (list-ec (:range x 1) x) => '(0))
+(my-check (list-ec (:range x 2) x) => '(0 1))
+
+(my-check (list-ec (:range x 0 3) x) => '(0 1 2))
+(my-check (list-ec (:range x 1 3) x) => '(1 2))
+(my-check (list-ec (:range x -2 -1) x) => '(-2))
+(my-check (list-ec (:range x -2 -2) x) => '())
+
+(my-check (list-ec (:range x 1 5 2) x) => '(1 3))
+(my-check (list-ec (:range x 1 6 2) x) => '(1 3 5))
+(my-check (list-ec (:range x 5 1 -2) x) => '(5 3))
+(my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2))
+
+(my-check (list-ec (:real-range x 0.0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3 1.0) x) => '(0. 1. 2.))
+
+(my-check
+ (string-ec (:char-range c #\a #\z) c)
+ => "abcdefghijklmnopqrstuvwxyz" )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; The special generators :do :let :parallel :while :until
+; ==========================================================================
+
+(my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3))
+
+(my-check
+ (list-ec
+ (:do (let ((x 'x)))
+ ((i 0))
+ (< i 4)
+ (let ((j (- 10 i))))
+ #t
+ ((+ i 1)) )
+ j )
+ => '(10 9 8 7) )
+
+(my-check (list-ec (:let x 1) x) => '(1))
+(my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2))
+(my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2))
+
+(my-check
+ (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) )
+
+(my-check
+ (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
+; ==========================================================================
+
+(my-check (list-ec (: c '(a b)) c) => '(a b))
+(my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d))
+
+(my-check (list-ec (: c "ab") c) => '(#\a #\b))
+(my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d))
+
+(my-check (list-ec (: c (vector 'a 'b)) c) => '(a b))
+(my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c))
+
+(my-check (list-ec (: i 0) i) => '())
+(my-check (list-ec (: i 1) i) => '(0))
+(my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9))
+(my-check (list-ec (: i 1 2) i) => '(1))
+(my-check (list-ec (: i 1 2 3) i) => '(1))
+(my-check (list-ec (: i 1 9 3) i) => '(1 4 7))
+
+(my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8))
+
+(my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; With index variable
+; ==========================================================================
+
+(my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1)))
+(my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0)))
+(my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0)))
+
+(my-check
+ (list-ec (:range i (index j) 0 -3 -1) (list i j))
+ => '((0 0) (-1 1) (-2 2)) )
+
+(my-check
+ (list-ec (:real-range i (index j) 0 1 0.2) (list i j))
+ => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) )
+
+(my-check
+ (list-ec (:char-range c (index i) #\a #\c) (list c i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (: x (index i) '(a b c d)) (list x i))
+ => '((a 0) (b 1) (c 2) (d 3)) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x (index i) port) (list x i))) ))
+ => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) )
+
+
+; ==========================================================================
+; The examples from the SRFI document
+; ==========================================================================
+
+; from Abstract
+
+(my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16))
+
+(my-check
+ (list-ec (: n 1 4) (: i n) (list n i))
+ => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) )
+
+; from Generators
+
+(my-check
+ (list-ec (: x (index i) "abc") (list x i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (:string c (index i) "a" "b") (cons c i))
+ => '((#\a . 0) (#\b . 1)) )
+
+
+; ==========================================================================
+; Little Shop of Horrors
+; ==========================================================================
+
+(my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3))
+
+(my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4))
+
+(my-check
+ (list-ec (:parallel (:integers x)
+ (:do ((i 10)) (< x i) ((- i 1))))
+ (list x i))
+ => '((0 10) (1 9) (2 8) (3 7) (4 6)) )
+
+
+; ==========================================================================
+; Less artificial examples
+; ==========================================================================
+
+(define (factorial n) ; n * (n-1) * .. * 1 for n >= 0
+ (product-ec (:range k 2 (+ n 1)) k) )
+
+(my-check (factorial 0) => 1)
+(my-check (factorial 1) => 1)
+(my-check (factorial 3) => 6)
+(my-check (factorial 5) => 120)
+
+
+(define (eratosthenes n) ; primes in {2..n-1} for n >= 1
+ (let ((p? (make-string n #\1)))
+ (do-ec (:range k 2 n)
+ (if (char=? (string-ref p? k) #\1))
+ (:range i (* 2 k) n k)
+ (string-set! p? i #\0) )
+ (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) ))
+
+(my-check
+ (eratosthenes 50)
+ => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) )
+
+(my-check
+ (length (eratosthenes 100000))
+ => 9592 ) ; we expect 10^5/ln(10^5)
+
+
+(define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2
+ (list-ec
+ (:let sqr-n (* n n))
+ (:range a 1 (+ n 1))
+; (begin (display a) (display " "))
+ (:let sqr-a (* a a))
+ (:range b a (+ n 1))
+ (:let sqr-c (+ sqr-a (* b b)))
+ (if (<= sqr-c sqr-n))
+ (:range c b (+ n 1))
+ (if (= (* c c) sqr-c))
+ (list a b c) ))
+
+(my-check
+ (pythagoras 15)
+ => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) )
+
+(my-check
+ (length (pythagoras 200))
+ => 127 )
+
+
+(define (qsort xs) ; stable
+ (if (null? xs)
+ '()
+ (let ((pivot (car xs)) (xrest (cdr xs)))
+ (append
+ (qsort (list-ec (:list x xrest) (if (< x pivot)) x))
+ (list pivot)
+ (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) ))))
+
+(my-check
+ (qsort '(1 5 4 2 4 5 3 2 1 3))
+ => '(1 1 2 2 3 3 4 4 5 5) )
+
+
+(define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe)
+ (sum-ec
+ (:range n 0 (+ m 1))
+ (:let n8 (* 8 n))
+ (* (- (/ 4 (+ n8 1))
+ (+ (/ 2 (+ n8 4))
+ (/ 1 (+ n8 5))
+ (/ 1 (+ n8 6))))
+ (/ 1 (expt 16 n)) )))
+
+(my-check
+ (pi-BBP 5)
+ => (/ 40413742330349316707 12864093722915635200) )
+
+
+(define (read-line port) ; next line (incl. #\newline) of port
+ (let ((line
+ (string-ec
+ (:until (:port c port read-char)
+ (char=? c #\newline) )
+ c )))
+ (if (string=? line "")
+ (read-char port) ; eof-object
+ line )))
+
+(define (read-lines filename) ; list of all lines
+ (my-call-with-input-file
+ filename
+ (lambda (port)
+ (list-ec (:port line port read-line) line) )))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (read-lines "tmp1") )
+ => (list-ec (:char-range c #\0 #\9) (string c #\newline)) )
HCoop / bpt / guile.git / commitdiff