~ chicken-core (chicken-5) /tests/ec.scm
Trap1(module ec (do-ec do-ec:do :do :let :parallel2 :parallel-1 :while :while-1 :while-23 :until :until-1 :list :string4 (:vector ec-:vector-filter)5 :integers :range6 :real-range :char-range :port :dispatched7 :generator-proc dispatch-union8 make-initial-:-dispatch9 (: :-dispatch)10 :-dispatch-ref :-dispatch-set!11 fold3-ec fold-ec list-ec append-ec12 string-ec string-append-ec vector-ec13 vector-of-length-ec sum-ec product-ec14 min-ec max-ec last-ec first-ec15 ec-guarded-do-ec any?-ec every?-ec)1617(import scheme chicken.base)1819; <PLAINTEXT>20; Eager Comprehensions in [outer..inner|expr]-Convention21; ======================================================22;23; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-200724; Scheme R5RS (incl. macros), SRFI-23 (error).25;26; Loading the implementation into Scheme48 0.57:27; ,open srfi-2328; ,load ec.scm29;30; Loading the implementation into PLT/DrScheme 317:31; ; File > Open ... "ec.scm", click Execute32;33; Loading the implementation into SCM 5d7:34; (require 'macro) (require 'record)35; (load "ec.scm")36;37; Implementation comments:38; * All local (not exported) identifiers are named ec-<something>.39; * This implementation focuses on portability, performance,40; readability, and simplicity roughly in this order. Design41; decisions related to performance are taken for Scheme48.42; * Alternative implementations, Comments and Warnings are43; mentioned after the definition with a heading.444546; ==========================================================================47; The fundamental comprehension do-ec48; ==========================================================================49;50; All eager comprehensions are reduced into do-ec and51; all generators are reduced to :do.52;53; We use the following short names for syntactic variables54; q - qualifier55; cc - current continuation, thing to call at the end;56; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)57; cmd - an expression being evaluated for its side-effects58; expr - an expression59; gen - a generator of an eager comprehension60; ob - outer binding61; oc - outer command62; lb - loop binding63; ne1? - not-end1? (before the payload)64; ib - inner binding65; ic - inner command66; ne2? - not-end2? (after the payload)67; ls - loop step68; etc - more arguments of mixed type697071; (do-ec q ... cmd)72; handles nested, if/not/and/or, begin, :let, and calls generator73; macros in CPS to transform them into fully decorated :do.74; The code generation for a :do is delegated to do-ec:do.7576(define-syntax do-ec77 (syntax-rules (nested if not and or begin :do let)7879 ; explicit nesting -> implicit nesting80 ((do-ec (nested q ...) etc ...)81 (do-ec q ... etc ...) )8283 ; implicit nesting -> fold do-ec84 ((do-ec q1 q2 etc1 etc ...)85 (do-ec q1 (do-ec q2 etc1 etc ...)) )8687 ; no qualifiers at all -> evaluate cmd once88 ((do-ec cmd)89 (begin cmd (if #f #f)) )9091; now (do-ec q cmd) remains9293 ; filter -> make conditional94 ((do-ec (if test) cmd)95 (if test (do-ec cmd)) )96 ((do-ec (not test) cmd)97 (if (not test) (do-ec cmd)) )98 ((do-ec (and test ...) cmd)99 (if (and test ...) (do-ec cmd)) )100 ((do-ec (or test ...) cmd)101 (if (or test ...) (do-ec cmd)) )102103 ; begin -> make a sequence104 ((do-ec (begin etc ...) cmd)105 (begin etc ... (do-ec cmd)) )106107 ; fully decorated :do-generator -> delegate to do-ec:do108 ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)109 (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )110111; anything else -> call generator-macro in CPS; reentry at (*)112113 ((do-ec (g arg1 arg ...) cmd)114 (g (do-ec:do cmd) arg1 arg ...) )))115116117; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))118; generates code for a single fully decorated :do-generator119; with cmd as payload, taking care of special cases.120121(define-syntax do-ec:do122 (syntax-rules (:do let)123124 ; reentry point (*) -> generate code125 ((do-ec:do cmd126 (:do (let obs oc ...)127 lbs128 ne1?129 (let ibs ic ...)130 ne2?131 (ls ...) ))132 (ec-simplify133 (let obs134 oc ...135 (let loop lbs136 (ec-simplify137 (if ne1?138 (ec-simplify139 (let ibs140 ic ...141 cmd142 (ec-simplify143 (if ne2?144 (loop ls ...) )))))))))) ))145146147; (ec-simplify <expression>)148; generates potentially more efficient code for <expression>.149; The macro handles if, (begin <command>*), and (let () <command>*)150; and takes care of special cases.151152(define-syntax ec-simplify153 (syntax-rules (if not let begin)154155; one- and two-sided if156157 ; literal <test>158 ((ec-simplify (if #t consequent))159 consequent )160 ((ec-simplify (if #f consequent))161 (if #f #f) )162 ((ec-simplify (if #t consequent alternate))163 consequent )164 ((ec-simplify (if #f consequent alternate))165 alternate )166167 ; (not (not <test>))168 ((ec-simplify (if (not (not test)) consequent))169 (ec-simplify (if test consequent)) )170 ((ec-simplify (if (not (not test)) consequent alternate))171 (ec-simplify (if test consequent alternate)) )172173; (let () <command>*)174175 ; empty <binding spec>*176 ((ec-simplify (let () command ...))177 (ec-simplify (begin command ...)) )178179; begin180181 ; flatten use helper (ec-simplify 1 done to-do)182 ((ec-simplify (begin command ...))183 (ec-simplify 1 () (command ...)) )184 ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))185 (ec-simplify 1 done (to-do1 ... to-do2 ...)) )186 ((ec-simplify 1 (done ...) (to-do1 to-do ...))187 (ec-simplify 1 (done ... to-do1) (to-do ...)) )188189 ; exit helper190 ((ec-simplify 1 () ())191 (if #f #f) )192 ((ec-simplify 1 (command) ())193 command )194 ((ec-simplify 1 (command1 command ...) ())195 (begin command1 command ...) )196197; anything else198199 ((ec-simplify expression)200 expression )))201202203; ==========================================================================204; The special generators :do, :let, :parallel, :while, and :until205; ==========================================================================206207(define-syntax :do208 (syntax-rules ()209210 ; full decorated -> continue with cc, reentry at (*)211 ((:do (cc ...) olet lbs ne1? ilet ne2? lss)212 (cc ... (:do olet lbs ne1? ilet ne2? lss)) )213214 ; short form -> fill in default values215 ((:do cc lbs ne1? lss)216 (:do cc (let ()) lbs ne1? (let ()) #t lss) )))217218219(define-syntax :let220 (syntax-rules (index)221 ((:let cc var (index i) expression)222 (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )223 ((:let cc var expression)224 (:do cc (let ((var expression))) () #t (let ()) #f ()) )))225226227(define-syntax :parallel228 (syntax-rules (:do)229 ((:parallel cc)230 cc )231 ((:parallel cc (g arg1 arg ...) gen ...)232 (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))233234; (:parallel-1 cc (to-do ...) result [ next ] )235; iterates over to-do by converting the first generator into236; the :do-generator next and merging next into result.237238(define-syntax :parallel-1 ; used as239 (syntax-rules (:do let)240241 ; process next element of to-do, reentry at (**)242 ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)243 (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )244245 ; reentry point (**) -> merge next into result246 ((:parallel-1247 cc248 gens249 (:do (let (ob1 ...) oc1 ...)250 (lb1 ...)251 ne1?1252 (let (ib1 ...) ic1 ...)253 ne2?1254 (ls1 ...) )255 (:do (let (ob2 ...) oc2 ...)256 (lb2 ...)257 ne1?2258 (let (ib2 ...) ic2 ...)259 ne2?2260 (ls2 ...) ))261 (:parallel-1262 cc263 gens264 (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)265 (lb1 ... lb2 ...)266 (and ne1?1 ne1?2)267 (let (ib1 ... ib2 ...) ic1 ... ic2 ...)268 (and ne2?1 ne2?2)269 (ls1 ... ls2 ...) )))270271 ; no more gens -> continue with cc, reentry at (*)272 ((:parallel-1 (cc ...) () result)273 (cc ... result) )))274275(define-syntax :while276 (syntax-rules ()277 ((:while cc (g arg1 arg ...) test)278 (g (:while-1 cc test) arg1 arg ...) )))279280; (:while-1 cc test (:do ...))281; modifies the fully decorated :do-generator such that it282; runs while test is a true value.283; The original implementation just replaced ne1? by284; (and ne1? test) as follows:285;286; (define-syntax :while-1287; (syntax-rules (:do)288; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))289; (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))290;291; Bug #1:292; Unfortunately, this code is wrong because ne1? may depend293; in the inner bindings introduced in ilet, but ne1? is evaluated294; outside of the inner bindings. (Refer to the specification of295; :do to see the structure.)296; The problem manifests itself (as sunnan@handgranat.org297; observed, 25-Apr-2005) when the :list-generator is modified:298;299; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).300;301; In order to generate proper code, we introduce temporary302; variables saving the values of the inner bindings. The inner303; bindings are executed in a new ne1?, which also evaluates ne1?304; outside the scope of the inner bindings, then the inner commands305; are executed (possibly changing the variables), and then the306; values of the inner bindings are saved and (and ne1? test) is307; returned. In the new ilet, the inner variables are bound and308; initialized and their values are restored. So we construct:309;310; (let (ob .. (ib-tmp #f) ...)311; oc ...312; (let loop (lb ...)313; (if (let (ne1?-value ne1?)314; (let ((ib-var ib-rhs) ...)315; ic ...316; (set! ib-tmp ib-var) ...)317; (and ne1?-value test))318; (let ((ib-var ib-tmp) ...)319; /payload/320; (if ne2?321; (loop ls ...) )))))322;323; Bug #2:324; Unfortunately, the above expansion is still incorrect (as Jens-Axel325; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even326; if ne1?-value is #f, indicating that the loop has ended.327; The problem manifests itself in the following example:328;329; (do-ec (:while (:list x '(1)) #t) (display x))330;331; Which iterates :list beyond exhausting the list '(1).332;333; For the fix, we follow Jens-Axel's approach of guarding the evaluation334; of ib-rhs with a check on ne1?-value.335336(define-syntax :while-1337 (syntax-rules (:do let)338 ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))339 (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss)))))340341(define-syntax :while-2342 (syntax-rules (:do let)343 ((:while-2 cc344 test345 (ib-let ...)346 (ib-save ...)347 (ib-restore ...)348 (:do olet349 lbs350 ne1?351 (let ((ib-var ib-rhs) ib ...) ic ...)352 ne2?353 lss))354 (:while-2 cc355 test356 (ib-let ... (ib-tmp #f))357 (ib-save ... (ib-var ib-rhs))358 (ib-restore ... (ib-var ib-tmp))359 (:do olet360 lbs361 ne1?362 (let (ib ...) ic ... (set! ib-tmp ib-var))363 ne2?364 lss)))365 ((:while-2 cc366 test367 (ib-let ...)368 (ib-save ...)369 (ib-restore ...)370 (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))371 (:do cc372 (let (ob ... ib-let ...) oc ...)373 lbs374 (let ((ne1?-value ne1?))375 (and ne1?-value376 (let (ib-save ...)377 ic ...378 test)))379 (let (ib-restore ...))380 ne2?381 lss))))382383384(define-syntax :until385 (syntax-rules ()386 ((:until cc (g arg1 arg ...) test)387 (g (:until-1 cc test) arg1 arg ...) )))388389(define-syntax :until-1390 (syntax-rules (:do)391 ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))392 (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))393394395; ==========================================================================396; The typed generators :list :string :vector etc.397; ==========================================================================398399(define-syntax :list400 (syntax-rules (index)401 ((:list cc var (index i) arg ...)402 (:parallel cc (:list var arg ...) (:integers i)) )403 ((:list cc var arg1 arg2 arg ...)404 (:list cc var (append arg1 arg2 arg ...)) )405 ((:list cc var arg)406 (:do cc407 (let ())408 ((t arg))409 (not (null? t))410 (let ((var (car t))))411 #t412 ((cdr t)) ))))413414415(define-syntax :string416 (syntax-rules (index)417 ((:string cc var (index i) arg)418 (:do cc419 (let ((str arg) (len 0))420 (set! len (string-length str)))421 ((i 0))422 (< i len)423 (let ((var (string-ref str i))))424 #t425 ((+ i 1)) ))426 ((:string cc var (index i) arg1 arg2 arg ...)427 (:string cc var (index i) (string-append arg1 arg2 arg ...)) )428 ((:string cc var arg1 arg ...)429 (:string cc var (index i) arg1 arg ...) )))430431; Alternative: An implementation in the style of :vector can also432; be used for :string. However, it is less interesting as the433; overhead of string-append is much less than for 'vector-append'.434435436(define-syntax :vector437 (syntax-rules (index)438 ((:vector cc var arg)439 (:vector cc var (index i) arg) )440 ((:vector cc var (index i) arg)441 (:do cc442 (let ((vec arg) (len 0))443 (set! len (vector-length vec)))444 ((i 0))445 (< i len)446 (let ((var (vector-ref vec i))))447 #t448 ((+ i 1)) ))449450 ((:vector cc var (index i) arg1 arg2 arg ...)451 (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )452 ((:vector cc var arg1 arg2 arg ...)453 (:do cc454 (let ((vec #f)455 (len 0)456 (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))457 ((k 0))458 (if (< k len)459 #t460 (if (null? vecs)461 #f462 (begin (set! vec (car vecs))463 (set! vecs (cdr vecs))464 (set! len (vector-length vec))465 (set! k 0)466 #t )))467 (let ((var (vector-ref vec k))))468 #t469 ((+ k 1)) ))))470471(define (ec-:vector-filter vecs)472 (if (null? vecs)473 '()474 (if (zero? (vector-length (car vecs)))475 (ec-:vector-filter (cdr vecs))476 (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))477478; Alternative: A simpler implementation for :vector uses vector->list479; append and :list in the multi-argument case. Please refer to the480; 'design.scm' for more details.481482483(define-syntax :integers484 (syntax-rules (index)485 ((:integers cc var (index i))486 (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )487 ((:integers cc var)488 (:do cc ((var 0)) #t ((+ var 1))) )))489490491(define-syntax :range492 (syntax-rules (index)493494 ; handle index variable and add optional args495 ((:range cc var (index i) arg1 arg ...)496 (:parallel cc (:range var arg1 arg ...) (:integers i)) )497 ((:range cc var arg1)498 (:range cc var 0 arg1 1) )499 ((:range cc var arg1 arg2)500 (:range cc var arg1 arg2 1) )501502; special cases (partially evaluated by hand from general case)503504 ((:range cc var 0 arg2 1)505 (:do cc506 (let ((b arg2))507 (if (not (and (integer? b) (exact? b)))508 (error509 "arguments of :range are not exact integer "510 "(use :real-range?)" 0 b 1 )))511 ((var 0))512 (< var b)513 (let ())514 #t515 ((+ var 1)) ))516517 ((:range cc var 0 arg2 -1)518 (:do cc519 (let ((b arg2))520 (if (not (and (integer? b) (exact? b)))521 (error522 "arguments of :range are not exact integer "523 "(use :real-range?)" 0 b 1 )))524 ((var 0))525 (> var b)526 (let ())527 #t528 ((- var 1)) ))529530 ((:range cc var arg1 arg2 1)531 (:do cc532 (let ((a arg1) (b arg2))533 (if (not (and (integer? a) (exact? a)534 (integer? b) (exact? b) ))535 (error536 "arguments of :range are not exact integer "537 "(use :real-range?)" a b 1 )) )538 ((var a))539 (< var b)540 (let ())541 #t542 ((+ var 1)) ))543544 ((:range cc var arg1 arg2 -1)545 (:do cc546 (let ((a arg1) (b arg2) (s -1) (stop 0))547 (if (not (and (integer? a) (exact? a)548 (integer? b) (exact? b) ))549 (error550 "arguments of :range are not exact integer "551 "(use :real-range?)" a b -1 )) )552 ((var a))553 (> var b)554 (let ())555 #t556 ((- var 1)) ))557558; the general case559560 ((:range cc var arg1 arg2 arg3)561 (:do cc562 (let ((a arg1) (b arg2) (s arg3) (stop 0))563 (if (not (and (integer? a) (exact? a)564 (integer? b) (exact? b)565 (integer? s) (exact? s) ))566 (error567 "arguments of :range are not exact integer "568 "(use :real-range?)" a b s ))569 (if (zero? s)570 (error "step size must not be zero in :range") )571 (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )572 ((var a))573 (not (= var stop))574 (let ())575 #t576 ((+ var s)) ))))577578; Comment: The macro :range inserts some code to make sure the values579; are exact integers. This overhead has proven very helpful for580; saving users from themselves.581582583(define-syntax :real-range584 (syntax-rules (index)585586 ; add optional args and index variable587 ((:real-range cc var arg1)588 (:real-range cc var (index i) 0 arg1 1) )589 ((:real-range cc var (index i) arg1)590 (:real-range cc var (index i) 0 arg1 1) )591 ((:real-range cc var arg1 arg2)592 (:real-range cc var (index i) arg1 arg2 1) )593 ((:real-range cc var (index i) arg1 arg2)594 (:real-range cc var (index i) arg1 arg2 1) )595 ((:real-range cc var arg1 arg2 arg3)596 (:real-range cc var (index i) arg1 arg2 arg3) )597598 ; the fully qualified case599 ((:real-range cc var (index i) arg1 arg2 arg3)600 (:do cc601 (let ((a arg1) (b arg2) (s arg3) (istop 0))602 (if (not (and (real? a) (real? b) (real? s)))603 (error "arguments of :real-range are not real" a b s) )604 (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))605 (set! a (exact->inexact a)) )606 (set! istop (/ (- b a) s)) )607 ((i 0))608 (< i istop)609 (let ((var (+ a (* s i)))))610 #t611 ((+ i 1)) ))))612613; Comment: The macro :real-range adapts the exactness of the start614; value in case any of the other values is inexact. This is a615; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).616617618(define-syntax :char-range619 (syntax-rules (index)620 ((:char-range cc var (index i) arg1 arg2)621 (:parallel cc (:char-range var arg1 arg2) (:integers i)) )622 ((:char-range cc var arg1 arg2)623 (:do cc624 (let ((imax (char->integer arg2))))625 ((i (char->integer arg1)))626 (<= i imax)627 (let ((var (integer->char i))))628 #t629 ((+ i 1)) ))))630631; Warning: There is no R5RS-way to implement the :char-range generator632; because the integers obtained by char->integer are not necessarily633; consecutive. We simply assume this anyhow for illustration.634635636(define-syntax :port637 (syntax-rules (index)638 ((:port cc var (index i) arg1 arg ...)639 (:parallel cc (:port var arg1 arg ...) (:integers i)) )640 ((:port cc var arg)641 (:port cc var arg read) )642 ((:port cc var arg1 arg2)643 (:do cc644 (let ((port arg1) (read-proc arg2)))645 ((var (read-proc port)))646 (not (eof-object? var))647 (let ())648 #t649 ((read-proc port)) ))))650651652; ==========================================================================653; The typed generator :dispatched and utilities for constructing dispatchers654; ==========================================================================655656(define-syntax :dispatched657 (syntax-rules (index)658 ((:dispatched cc var (index i) dispatch arg1 arg ...)659 (:parallel cc660 (:integers i)661 (:dispatched var dispatch arg1 arg ...) ))662 ((:dispatched cc var dispatch arg1 arg ...)663 (:do cc664 (let ((d dispatch)665 (args (list arg1 arg ...))666 (g #f)667 (empty (list #f)) )668 (set! g (d args))669 (if (not (procedure? g))670 (error "unrecognized arguments in dispatching"671 args672 (d '()) )))673 ((var (g empty)))674 (not (eq? var empty))675 (let ())676 #t677 ((g empty)) ))))678679; Comment: The unique object empty is created as a newly allocated680; non-empty list. It is compared using eq? which distinguishes681; the object from any other object, according to R5RS 6.1.682683684(define-syntax :generator-proc685 (syntax-rules (:do let)686687 ; call g with a variable, reentry at (**)688 ((:generator-proc (g arg ...))689 (g (:generator-proc var) var arg ...) )690691 ; reentry point (**) -> make the code from a single :do692 ((:generator-proc693 var694 (:do (let obs oc ...)695 ((lv li) ...)696 ne1?697 (let ((i v) ...) ic ...)698 ne2?699 (ls ...)) )700 (ec-simplify701 (let obs702 oc ...703 (let ((lv li) ... (ne2 #t))704 (ec-simplify705 (let ((i #f) ...) ; v not yet valid706 (lambda (empty)707 (if (and ne1? ne2)708 (ec-simplify709 (begin710 (set! i v) ...711 ic ...712 (let ((value var))713 (ec-simplify714 (if ne2?715 (ec-simplify716 (begin (set! lv ls) ...) )717 (set! ne2 #f) ))718 value )))719 empty ))))))))720721 ; silence warnings of some macro expanders722 ((:generator-proc var)723 (error "illegal macro call") )))724725726(define (dispatch-union d1 d2)727 (lambda (args)728 (let ((g1 (d1 args)) (g2 (d2 args)))729 (if g1730 (if g2731 (if (null? args)732 (append (if (list? g1) g1 (list g1))733 (if (list? g2) g2 (list g2)) )734 (error "dispatching conflict" args (d1 '()) (d2 '())) )735 g1 )736 (if g2 g2 #f) ))))737738739; ==========================================================================740; The dispatching generator :741; ==========================================================================742743(define (make-initial-:-dispatch)744 (lambda (args)745 (case (length args)746 ((0) 'SRFI42)747 ((1) (let ((a1 (car args)))748 (cond749 ((list? a1)750 (:generator-proc (:list a1)) )751 ((string? a1)752 (:generator-proc (:string a1)) )753 ((vector? a1)754 (:generator-proc (:vector a1)) )755 ((and (integer? a1) (exact? a1))756 (:generator-proc (:range a1)) )757 ((real? a1)758 (:generator-proc (:real-range a1)) )759 ((input-port? a1)760 (:generator-proc (:port a1)) )761 (else762 #f ))))763 ((2) (let ((a1 (car args)) (a2 (cadr args)))764 (cond765 ((and (list? a1) (list? a2))766 (:generator-proc (:list a1 a2)) )767 ((and (string? a1) (string? a1))768 (:generator-proc (:string a1 a2)) )769 ((and (vector? a1) (vector? a2))770 (:generator-proc (:vector a1 a2)) )771 ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))772 (:generator-proc (:range a1 a2)) )773 ((and (real? a1) (real? a2))774 (:generator-proc (:real-range a1 a2)) )775 ((and (char? a1) (char? a2))776 (:generator-proc (:char-range a1 a2)) )777 ((and (input-port? a1) (procedure? a2))778 (:generator-proc (:port a1 a2)) )779 (else780 #f ))))781 ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))782 (cond783 ((and (list? a1) (list? a2) (list? a3))784 (:generator-proc (:list a1 a2 a3)) )785 ((and (string? a1) (string? a1) (string? a3))786 (:generator-proc (:string a1 a2 a3)) )787 ((and (vector? a1) (vector? a2) (vector? a3))788 (:generator-proc (:vector a1 a2 a3)) )789 ((and (integer? a1) (exact? a1)790 (integer? a2) (exact? a2)791 (integer? a3) (exact? a3))792 (:generator-proc (:range a1 a2 a3)) )793 ((and (real? a1) (real? a2) (real? a3))794 (:generator-proc (:real-range a1 a2 a3)) )795 (else796 #f ))))797 (else798 (letrec ((every?799 (lambda (pred args)800 (if (null? args)801 #t802 (and (pred (car args))803 (every? pred (cdr args)) )))))804 (cond805 ((every? list? args)806 (:generator-proc (:list (apply append args))) )807 ((every? string? args)808 (:generator-proc (:string (apply string-append args))) )809 ((every? vector? args)810 (:generator-proc (:list (apply append (map vector->list args)))) )811 (else812 #f )))))))813814(define :-dispatch815 (make-initial-:-dispatch) )816817(define (:-dispatch-ref)818 :-dispatch )819820(define (:-dispatch-set! dispatch)821 (if (not (procedure? dispatch))822 (error "not a procedure" dispatch) )823 (set! :-dispatch dispatch) )824825(define-syntax :826 (syntax-rules (index)827 ((: cc var (index i) arg1 arg ...)828 (:dispatched cc var (index i) :-dispatch arg1 arg ...) )829 ((: cc var arg1 arg ...)830 (:dispatched cc var :-dispatch arg1 arg ...) )))831832833; ==========================================================================834; The utility comprehensions fold-ec, fold3-ec835; ==========================================================================836837(define-syntax fold3-ec838 (syntax-rules (nested)839 ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)840 (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )841 ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)842 (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )843 ((fold3-ec x0 expression f1 f2)844 (fold3-ec x0 (nested) expression f1 f2) )845846 ((fold3-ec x0 qualifier expression f1 f2)847 (let ((result #f) (empty #t))848 (do-ec qualifier849 (let ((value expression)) ; don't duplicate850 (if empty851 (begin (set! result (f1 value))852 (set! empty #f) )853 (set! result (f2 value result)) )))854 (if empty x0 result) ))))855856857(define-syntax fold-ec858 (syntax-rules (nested)859 ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)860 (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )861 ((fold-ec x0 q1 q2 etc1 etc2 etc ...)862 (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )863 ((fold-ec x0 expression f2)864 (fold-ec x0 (nested) expression f2) )865866 ((fold-ec x0 qualifier expression f2)867 (let ((result x0))868 (do-ec qualifier (set! result (f2 expression result)))869 result ))))870871872; ==========================================================================873; The comprehensions list-ec string-ec vector-ec etc.874; ==========================================================================875876(define-syntax list-ec877 (syntax-rules ()878 ((list-ec etc1 etc ...)879 (reverse (fold-ec '() etc1 etc ... cons)) )))880881; Alternative: Reverse can safely be replaced by reverse! if you have it.882;883; Alternative: It is possible to construct the result in the correct order884; using set-cdr! to add at the tail. This removes the overhead of copying885; at the end, at the cost of more book-keeping.886887888(define-syntax append-ec889 (syntax-rules ()890 ((append-ec etc1 etc ...)891 (apply append (list-ec etc1 etc ...)) )))892893(define-syntax string-ec894 (syntax-rules ()895 ((string-ec etc1 etc ...)896 (list->string (list-ec etc1 etc ...)) )))897898; Alternative: For very long strings, the intermediate list may be a899; problem. A more space-aware implementation collect the characters900; in an intermediate list and when this list becomes too large it is901; converted into an intermediate string. At the end, the intermediate902; strings are concatenated with string-append.903904905(define-syntax string-append-ec906 (syntax-rules ()907 ((string-append-ec etc1 etc ...)908 (apply string-append (list-ec etc1 etc ...)) )))909910(define-syntax vector-ec911 (syntax-rules ()912 ((vector-ec etc1 etc ...)913 (list->vector (list-ec etc1 etc ...)) )))914915; Comment: A similar approach as for string-ec can be used for vector-ec.916; However, the space overhead for the intermediate list is much lower917; than for string-ec and as there is no vector-append, the intermediate918; vectors must be copied explicitly.919920(define-syntax vector-of-length-ec921 (syntax-rules (nested)922 ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)923 (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )924 ((vector-of-length-ec k q1 q2 etc1 etc ...)925 (vector-of-length-ec k (nested q1 q2) etc1 etc ...) )926 ((vector-of-length-ec k expression)927 (vector-of-length-ec k (nested) expression) )928929 ((vector-of-length-ec k qualifier expression)930 (let ((len k))931 (let ((vec (make-vector len))932 (i 0) )933 (do-ec qualifier934 (if (< i len)935 (begin (vector-set! vec i expression)936 (set! i (+ i 1)) )937 (error "vector is too short for the comprehension") ))938 (if (= i len)939 vec940 (error "vector is too long for the comprehension") ))))))941942943(define-syntax sum-ec944 (syntax-rules ()945 ((sum-ec etc1 etc ...)946 (fold-ec (+) etc1 etc ... +) )))947948(define-syntax product-ec949 (syntax-rules ()950 ((product-ec etc1 etc ...)951 (fold-ec (*) etc1 etc ... *) )))952953(define-syntax min-ec954 (syntax-rules ()955 ((min-ec etc1 etc ...)956 (fold3-ec (min) etc1 etc ... min min) )))957958(define-syntax max-ec959 (syntax-rules ()960 ((max-ec etc1 etc ...)961 (fold3-ec (max) etc1 etc ... max max) )))962963(define-syntax last-ec964 (syntax-rules (nested)965 ((last-ec default (nested q1 ...) q etc1 etc ...)966 (last-ec default (nested q1 ... q) etc1 etc ...) )967 ((last-ec default q1 q2 etc1 etc ...)968 (last-ec default (nested q1 q2) etc1 etc ...) )969 ((last-ec default expression)970 (last-ec default (nested) expression) )971972 ((last-ec default qualifier expression)973 (let ((result default))974 (do-ec qualifier (set! result expression))975 result ))))976977978; ==========================================================================979; The fundamental early-stopping comprehension first-ec980; ==========================================================================981982(define-syntax first-ec983 (syntax-rules (nested)984 ((first-ec default (nested q1 ...) q etc1 etc ...)985 (first-ec default (nested q1 ... q) etc1 etc ...) )986 ((first-ec default q1 q2 etc1 etc ...)987 (first-ec default (nested q1 q2) etc1 etc ...) )988 ((first-ec default expression)989 (first-ec default (nested) expression) )990991 ((first-ec default qualifier expression)992 (let ((result default) (stop #f))993 (ec-guarded-do-ec994 stop995 (nested qualifier)996 (begin (set! result expression)997 (set! stop #t) ))998 result ))))9991000; (ec-guarded-do-ec stop (nested q ...) cmd)1001; constructs (do-ec q ... cmd) where the generators gen in q ... are1002; replaced by (:until gen stop).10031004(define-syntax ec-guarded-do-ec1005 (syntax-rules (nested if not and or begin)10061007 ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)1008 (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )10091010 ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)1011 (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )1012 ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)1013 (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )1014 ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)1015 (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )1016 ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)1017 (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )10181019 ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)1020 (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )10211022 ((ec-guarded-do-ec stop (nested gen q ...) cmd)1023 (do-ec1024 (:until gen stop)1025 (ec-guarded-do-ec stop (nested q ...) cmd) ))10261027 ((ec-guarded-do-ec stop (nested) cmd)1028 (do-ec cmd) )))10291030; Alternative: Instead of modifying the generator with :until, it is1031; possible to use call-with-current-continuation:1032;1033; (define-synatx first-ec1034; ...same as above...1035; ((first-ec default qualifier expression)1036; (call-with-current-continuation1037; (lambda (cc)1038; (do-ec qualifier (cc expression))1039; default ))) ))1040;1041; This is much simpler but not necessarily as efficient.104210431044; ==========================================================================1045; The early-stopping comprehensions any?-ec every?-ec1046; ==========================================================================10471048(define-syntax any?-ec1049 (syntax-rules (nested)1050 ((any?-ec (nested q1 ...) q etc1 etc ...)1051 (any?-ec (nested q1 ... q) etc1 etc ...) )1052 ((any?-ec q1 q2 etc1 etc ...)1053 (any?-ec (nested q1 q2) etc1 etc ...) )1054 ((any?-ec expression)1055 (any?-ec (nested) expression) )10561057 ((any?-ec qualifier expression)1058 (first-ec #f qualifier (if expression) #t) )))10591060(define-syntax every?-ec1061 (syntax-rules (nested)1062 ((every?-ec (nested q1 ...) q etc1 etc ...)1063 (every?-ec (nested q1 ... q) etc1 etc ...) )1064 ((every?-ec q1 q2 etc1 etc ...)1065 (every?-ec (nested q1 q2) etc1 etc ...) )1066 ((every?-ec expression)1067 (every?-ec (nested) expression) )10681069 ((every?-ec qualifier expression)1070 (first-ec #t qualifier (if (not expression)) #f) )))107110721073)