source: project/chicken/trunk/tests/ec.scm @ 12559

Last change on this file since 12559 was 12559, checked in by felix winkelmann, 12 years ago
  • put non-std macros into own unit (chicken-syntax) which makes chicken-more-macros.scm obsolete;
  • renamed chicken-ffi-macros.scm to chicken-ffi-syntax.scm
  • added missing entries to distribution/manifest
  • ec tests use only required exports now (and work)
  • bumped version to 4.0.0x2
  • various fixes in the manual
File size: 34.4 KB
Line 
1(module ec (do-ec do-ec:do :do :let :parallel
2                     :parallel-1 :while :while-1 :while-2
3                     :until :until-1 :list :string 
4                     (:vector ec-:vector-filter)
5                     :integers :range
6                     :real-range :char-range :port :dispatched
7                     :generator-proc dispatch-union
8                     make-initial-:-dispatch 
9                     (: :-dispatch)
10                     :-dispatch-ref :-dispatch-set!
11                     fold3-ec fold-ec list-ec append-ec
12                     string-ec string-append-ec vector-ec
13                     vector-of-length-ec sum-ec product-ec
14                     min-ec max-ec last-ec first-ec
15                     ec-guarded-do-ec any?-ec every?-ec)
16
17(import scheme chicken)
18
19; <PLAINTEXT>
20; Eager Comprehensions in [outer..inner|expr]-Convention
21; ======================================================
22;
23; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
24; Scheme R5RS (incl. macros), SRFI-23 (error).
25;
26; Loading the implementation into Scheme48 0.57:
27;   ,open srfi-23
28;   ,load ec.scm
29;
30; Loading the implementation into PLT/DrScheme 317:
31;   ; File > Open ... "ec.scm", click Execute
32;
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. Design
41;     decisions related to performance are taken for Scheme48.
42;   * Alternative implementations, Comments and Warnings are
43;     mentioned after the definition with a heading.
44
45
46; ==========================================================================
47; The fundamental comprehension do-ec
48; ==========================================================================
49;
50; All eager comprehensions are reduced into do-ec and
51; all generators are reduced to :do.
52;
53; We use the following short names for syntactic variables
54;   q    - qualifier
55;   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-effects
58;   expr - an expression
59;   gen  - a generator of an eager comprehension
60;   ob   - outer binding
61;   oc   - outer command
62;   lb   - loop binding
63;   ne1? - not-end1? (before the payload)
64;   ib   - inner binding
65;   ic   - inner command
66;   ne2? - not-end2? (after the payload)
67;   ls   - loop step
68;   etc  - more arguments of mixed type
69
70
71; (do-ec q ... cmd)
72;   handles nested, if/not/and/or, begin, :let, and calls generator
73;   macros in CPS to transform them into fully decorated :do.
74;   The code generation for a :do is delegated to do-ec:do.
75
76(define-syntax do-ec
77  (syntax-rules (nested if not and or begin :do let)
78
79    ; explicit nesting -> implicit nesting
80    ((do-ec (nested q ...) etc ...)
81     (do-ec q ... etc ...) )
82
83    ; implicit nesting -> fold do-ec
84    ((do-ec q1 q2 etc1 etc ...)
85     (do-ec q1 (do-ec q2 etc1 etc ...)) )
86
87    ; no qualifiers at all -> evaluate cmd once
88    ((do-ec cmd)
89     (begin cmd (if #f #f)) )
90
91; now (do-ec q cmd) remains
92
93    ; filter -> make conditional
94    ((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)) )
102
103    ; begin -> make a sequence
104    ((do-ec (begin etc ...) cmd)
105     (begin etc ... (do-ec cmd)) )
106
107    ; fully decorated :do-generator -> delegate to do-ec:do
108    ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
109     (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
110
111; anything else -> call generator-macro in CPS; reentry at (*)
112
113    ((do-ec (g arg1 arg ...) cmd)
114     (g (do-ec:do cmd) arg1 arg ...) )))
115
116
117; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))
118;   generates code for a single fully decorated :do-generator
119;   with cmd as payload, taking care of special cases.
120
121(define-syntax do-ec:do
122  (syntax-rules (:do let)
123
124    ; reentry point (*) -> generate code
125    ((do-ec:do cmd 
126               (:do (let obs oc ...) 
127                    lbs 
128                    ne1? 
129                    (let ibs ic ...) 
130                    ne2? 
131                    (ls ...) ))
132     (ec-simplify
133       (let obs
134         oc ...
135         (let loop lbs
136           (ec-simplify
137             (if ne1?
138                 (ec-simplify
139                   (let ibs
140                      ic ...
141                      cmd
142                      (ec-simplify
143                        (if ne2?
144                            (loop ls ...) )))))))))) ))
145
146   
147; (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.
151
152(define-syntax ec-simplify
153  (syntax-rules (if not let begin)
154
155; one- and two-sided if
156
157    ; 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 )
166
167    ; (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)) )
172
173; (let () <command>*)
174
175    ; empty <binding spec>*
176    ((ec-simplify (let () command ...))
177     (ec-simplify (begin command ...)) )
178
179; begin
180
181    ; 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 ...)) )
188
189    ; exit helper
190    ((ec-simplify 1 () ())
191     (if #f #f) )
192    ((ec-simplify 1 (command) ())
193     command )
194    ((ec-simplify 1 (command1 command ...) ())
195     (begin command1 command ...) )
196
197; anything else
198
199    ((ec-simplify expression)
200     expression )))
201
202
203; ==========================================================================
204; The special generators :do, :let, :parallel, :while, and :until
205; ==========================================================================
206
207(define-syntax :do
208  (syntax-rules ()
209
210    ; 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)) )
213
214    ; short form -> fill in default values
215    ((:do cc lbs ne1? lss)
216     (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
217   
218
219(define-syntax :let
220  (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 ()) )))
225
226
227(define-syntax :parallel
228  (syntax-rules (:do)
229    ((:parallel cc)
230     cc )
231    ((:parallel cc (g arg1 arg ...) gen ...)
232     (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
233
234; (:parallel-1 cc (to-do ...) result [ next ] )
235;    iterates over to-do by converting the first generator into
236;    the :do-generator next and merging next into result.
237
238(define-syntax :parallel-1  ; used as
239  (syntax-rules (:do let)
240
241    ; 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 ...) )
244
245    ; reentry point (**) -> merge next into result
246    ((:parallel-1 
247       cc 
248       gens 
249       (:do (let (ob1 ...) oc1 ...) 
250            (lb1 ...) 
251            ne1?1 
252            (let (ib1 ...) ic1 ...) 
253            ne2?1 
254            (ls1 ...) )
255       (:do (let (ob2 ...) oc2 ...) 
256            (lb2 ...) 
257            ne1?2 
258            (let (ib2 ...) ic2 ...) 
259            ne2?2 
260            (ls2 ...) ))
261     (:parallel-1 
262       cc 
263       gens 
264       (: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 ...) )))
270
271    ; no more gens -> continue with cc, reentry at (*)
272    ((:parallel-1 (cc ...) () result)
273     (cc ... result) )))
274
275(define-syntax :while
276  (syntax-rules ()
277    ((:while cc (g arg1 arg ...) test)
278     (g (:while-1 cc test) arg1 arg ...) )))
279
280; (:while-1 cc test (:do ...))
281;    modifies the fully decorated :do-generator such that it
282;    runs while test is a true value.
283;       The original implementation just replaced ne1? by
284;    (and ne1? test) as follows:
285;
286;      (define-syntax :while-1
287;        (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 depend
293;    in the inner bindings introduced in ilet, but ne1? is evaluated
294;    outside of the inner bindings. (Refer to the specification of
295;    :do to see the structure.)
296;       The problem manifests itself (as sunnan@handgranat.org
297;    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 temporary
302;    variables saving the values of the inner bindings. The inner
303;    bindings are executed in a new ne1?, which also evaluates ne1?
304;    outside the scope of the inner bindings, then the inner commands
305;    are executed (possibly changing the variables), and then the
306;    values of the inner bindings are saved and (and ne1? test) is
307;    returned. In the new ilet, the inner variables are bound and
308;    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-Axel
325;    Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
326;    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 evaluation
334;    of ib-rhs with a check on ne1?-value.
335
336(define-syntax :while-1
337  (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)))))
340
341(define-syntax :while-2
342  (syntax-rules (:do let)
343    ((:while-2 cc 
344               test 
345               (ib-let     ...)
346               (ib-save    ...)
347               (ib-restore ...)
348               (:do olet 
349                    lbs 
350                    ne1? 
351                    (let ((ib-var ib-rhs) ib ...) ic ...)
352                    ne2? 
353                    lss))
354     (:while-2 cc 
355               test 
356               (ib-let     ... (ib-tmp #f))
357               (ib-save    ... (ib-var ib-rhs))
358               (ib-restore ... (ib-var ib-tmp))
359               (:do olet 
360                    lbs 
361                    ne1? 
362                    (let (ib ...) ic ... (set! ib-tmp ib-var)) 
363                    ne2? 
364                    lss)))
365    ((:while-2 cc
366               test
367               (ib-let     ...)
368               (ib-save    ...)
369               (ib-restore ...)
370               (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
371     (:do cc
372          (let (ob ... ib-let ...) oc ...)
373          lbs
374          (let ((ne1?-value ne1?))
375            (and ne1?-value
376                 (let (ib-save ...)
377                   ic ...
378                   test)))
379          (let (ib-restore ...))
380          ne2?
381          lss))))
382
383
384(define-syntax :until
385  (syntax-rules ()
386    ((:until cc (g arg1 arg ...) test)
387     (g (:until-1 cc test) arg1 arg ...) )))
388
389(define-syntax :until-1
390  (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) )))
393
394
395; ==========================================================================
396; The typed generators :list :string :vector etc.
397; ==========================================================================
398
399(define-syntax :list
400  (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 cc
407          (let ())
408          ((t arg))
409          (not (null? t))
410          (let ((var (car t))))
411          #t
412          ((cdr t)) ))))
413
414
415(define-syntax :string
416  (syntax-rules (index)
417    ((:string cc var (index i) arg)
418     (:do cc
419          (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          #t
425          ((+ 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 ...) )))
430
431; Alternative: An implementation in the style of :vector can also
432;   be used for :string. However, it is less interesting as the
433;   overhead of string-append is much less than for 'vector-append'.
434
435
436(define-syntax :vector
437  (syntax-rules (index)
438    ((:vector cc var arg)
439     (:vector cc var (index i) arg) )
440    ((:vector cc var (index i) arg)
441     (:do cc
442          (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          #t
448          ((+ i 1)) ))
449
450    ((: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 cc
454          (let ((vec #f)
455                (len 0)
456                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
457          ((k 0))
458          (if (< k len)
459              #t
460              (if (null? vecs)
461                  #f
462                  (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          #t
469          ((+ k 1)) ))))
470
471(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))) )))
477
478; Alternative: A simpler implementation for :vector uses vector->list
479;   append and :list in the multi-argument case. Please refer to the
480;   'design.scm' for more details.
481
482
483(define-syntax :integers
484  (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))) )))
489
490
491(define-syntax :range
492  (syntax-rules (index)
493
494    ; handle index variable and add optional args
495    ((: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) )
501
502; special cases (partially evaluated by hand from general case)
503
504    ((:range cc var 0 arg2 1)
505     (:do cc
506          (let ((b arg2))
507            (if (not (and (integer? b) (exact? b)))
508                (error 
509                   "arguments of :range are not exact integer "
510                   "(use :real-range?)" 0 b 1 )))
511          ((var 0))
512          (< var b)
513          (let ())
514          #t
515          ((+ var 1)) ))
516
517    ((:range cc var 0 arg2 -1)
518     (:do cc
519          (let ((b arg2))
520            (if (not (and (integer? b) (exact? b)))
521                (error 
522                   "arguments of :range are not exact integer "
523                   "(use :real-range?)" 0 b 1 )))
524          ((var 0))
525          (> var b)
526          (let ())
527          #t
528          ((- var 1)) ))
529
530    ((:range cc var arg1 arg2 1)
531     (:do cc
532          (let ((a arg1) (b arg2))
533            (if (not (and (integer? a) (exact? a)
534                          (integer? b) (exact? b) ))
535                (error 
536                   "arguments of :range are not exact integer "
537                   "(use :real-range?)" a b 1 )) )
538          ((var a))
539          (< var b)
540          (let ())
541          #t
542          ((+ var 1)) ))
543
544    ((:range cc var arg1 arg2 -1)
545     (:do cc
546          (let ((a arg1) (b arg2) (s -1) (stop 0))
547            (if (not (and (integer? a) (exact? a)
548                          (integer? b) (exact? b) ))
549                (error 
550                   "arguments of :range are not exact integer "
551                   "(use :real-range?)" a b -1 )) )
552          ((var a))
553          (> var b)
554          (let ())
555          #t
556          ((- var 1)) ))
557
558; the general case
559
560    ((:range cc var arg1 arg2 arg3)
561     (:do cc
562          (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                (error 
567                   "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          #t
576          ((+ var s)) ))))
577
578; Comment: The macro :range inserts some code to make sure the values
579;   are exact integers. This overhead has proven very helpful for
580;   saving users from themselves.
581
582
583(define-syntax :real-range
584  (syntax-rules (index)
585
586    ; add optional args and index variable
587    ((: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) )
597
598    ; the fully qualified case
599    ((:real-range cc var (index i) arg1 arg2 arg3)
600     (:do cc
601          (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          #t
611          ((+ i 1)) ))))
612
613; Comment: The macro :real-range adapts the exactness of the start
614;   value in case any of the other values is inexact. This is a
615;   precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
616
617   
618(define-syntax :char-range
619  (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 cc
624          (let ((imax (char->integer arg2))))
625          ((i (char->integer arg1)))
626          (<= i imax)
627          (let ((var (integer->char i))))
628          #t
629          ((+ i 1)) ))))
630
631; Warning: There is no R5RS-way to implement the :char-range generator
632;   because the integers obtained by char->integer are not necessarily
633;   consecutive. We simply assume this anyhow for illustration.
634
635
636(define-syntax :port
637  (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 cc
644          (let ((port arg1) (read-proc arg2)))
645          ((var (read-proc port)))
646          (not (eof-object? var))
647          (let ())
648          #t
649          ((read-proc port)) ))))
650
651
652; ==========================================================================
653; The typed generator :dispatched and utilities for constructing dispatchers
654; ==========================================================================
655
656(define-syntax :dispatched
657  (syntax-rules (index)
658    ((:dispatched cc var (index i) dispatch arg1 arg ...)
659     (:parallel cc 
660                (:integers i)
661                (:dispatched var dispatch arg1 arg ...) ))
662    ((:dispatched cc var dispatch arg1 arg ...)
663     (:do cc
664          (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                       args 
672                       (d '()) )))
673          ((var (g empty)))
674          (not (eq? var empty))
675          (let ())
676          #t
677          ((g empty)) ))))
678
679; Comment: The unique object empty is created as a newly allocated
680;   non-empty list. It is compared using eq? which distinguishes
681;   the object from any other object, according to R5RS 6.1.
682
683
684(define-syntax :generator-proc
685  (syntax-rules (:do let)
686
687    ; call g with a variable, reentry at (**)
688    ((:generator-proc (g arg ...))
689     (g (:generator-proc var) var arg ...) )
690
691    ; reentry point (**) -> make the code from a single :do
692    ((:generator-proc
693       var 
694       (:do (let obs oc ...) 
695            ((lv li) ...) 
696            ne1? 
697            (let ((i v) ...) ic ...) 
698            ne2? 
699            (ls ...)) )
700     (ec-simplify 
701      (let obs
702          oc ...
703          (let ((lv li) ... (ne2 #t))
704            (ec-simplify
705             (let ((i #f) ...) ; v not yet valid
706               (lambda (empty)
707                 (if (and ne1? ne2)
708                     (ec-simplify
709                      (begin
710                        (set! i v) ...
711                        ic ...
712                        (let ((value var))
713                          (ec-simplify
714                           (if ne2?
715                               (ec-simplify 
716                                (begin (set! lv ls) ...) )
717                               (set! ne2 #f) ))
718                          value )))
719                     empty ))))))))
720
721    ; silence warnings of some macro expanders
722    ((:generator-proc var)
723     (error "illegal macro call") )))
724
725
726(define (dispatch-union d1 d2)
727  (lambda (args)
728    (let ((g1 (d1 args)) (g2 (d2 args)))
729      (if g1
730          (if g2 
731              (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) ))))
737
738
739; ==========================================================================
740; The dispatching generator :
741; ==========================================================================
742
743(define (make-initial-:-dispatch)
744  (lambda (args)
745    (case (length args)
746      ((0) 'SRFI42)
747      ((1) (let ((a1 (car args)))
748             (cond
749              ((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              (else
762               #f ))))
763      ((2) (let ((a1 (car args)) (a2 (cadr args)))
764             (cond
765              ((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              (else
780               #f ))))
781      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
782             (cond
783              ((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              (else
796               #f ))))
797      (else
798       (letrec ((every? 
799                 (lambda (pred args)
800                   (if (null? args)
801                       #t
802                       (and (pred (car args))
803                            (every? pred (cdr args)) )))))
804         (cond
805          ((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          (else
812           #f )))))))
813
814(define :-dispatch
815  (make-initial-:-dispatch) )
816
817(define (:-dispatch-ref)
818  :-dispatch )
819
820(define (:-dispatch-set! dispatch)
821  (if (not (procedure? dispatch))
822      (error "not a procedure" dispatch) )
823  (set! :-dispatch dispatch) )
824
825(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 ...) )))
831
832
833; ==========================================================================
834; The utility comprehensions fold-ec, fold3-ec
835; ==========================================================================
836
837(define-syntax fold3-ec
838  (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) )
845
846    ((fold3-ec x0 qualifier expression f1 f2)
847     (let ((result #f) (empty #t))
848       (do-ec qualifier
849              (let ((value expression)) ; don't duplicate
850                (if empty
851                    (begin (set! result (f1 value))
852                           (set! empty #f) )
853                    (set! result (f2 value result)) )))
854       (if empty x0 result) ))))
855
856
857(define-syntax fold-ec
858  (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) )
865
866    ((fold-ec x0 qualifier expression f2)
867     (let ((result x0))
868       (do-ec qualifier (set! result (f2 expression result)))
869       result ))))
870
871
872; ==========================================================================
873; The comprehensions list-ec string-ec vector-ec etc.
874; ==========================================================================
875
876(define-syntax list-ec
877  (syntax-rules ()
878    ((list-ec etc1 etc ...)
879     (reverse (fold-ec '() etc1 etc ... cons)) )))
880
881; 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 order
884;   using set-cdr! to add at the tail. This removes the overhead of copying
885;   at the end, at the cost of more book-keeping.
886
887
888(define-syntax append-ec
889  (syntax-rules ()
890    ((append-ec etc1 etc ...)
891     (apply append (list-ec etc1 etc ...)) )))
892
893(define-syntax string-ec
894  (syntax-rules ()
895    ((string-ec etc1 etc ...)
896     (list->string (list-ec etc1 etc ...)) )))
897
898; Alternative: For very long strings, the intermediate list may be a
899;   problem. A more space-aware implementation collect the characters
900;   in an intermediate list and when this list becomes too large it is
901;   converted into an intermediate string. At the end, the intermediate
902;   strings are concatenated with string-append.
903
904
905(define-syntax string-append-ec
906  (syntax-rules ()
907    ((string-append-ec etc1 etc ...)
908     (apply string-append (list-ec etc1 etc ...)) )))
909
910(define-syntax vector-ec
911  (syntax-rules ()
912    ((vector-ec etc1 etc ...)
913     (list->vector (list-ec etc1 etc ...)) )))
914
915; 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 lower
917;   than for string-ec and as there is no vector-append, the intermediate
918;   vectors must be copied explicitly.
919
920(define-syntax vector-of-length-ec
921  (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) )
928
929    ((vector-of-length-ec k qualifier expression)
930     (let ((len k))
931       (let ((vec (make-vector len))
932             (i 0) )
933         (do-ec qualifier
934                (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             vec
940             (error "vector is too long for the comprehension") ))))))
941
942
943(define-syntax sum-ec
944  (syntax-rules ()
945    ((sum-ec etc1 etc ...)
946     (fold-ec (+) etc1 etc ... +) )))
947
948(define-syntax product-ec
949  (syntax-rules ()
950    ((product-ec etc1 etc ...)
951     (fold-ec (*) etc1 etc ... *) )))
952
953(define-syntax min-ec
954  (syntax-rules ()
955    ((min-ec etc1 etc ...)
956     (fold3-ec (min) etc1 etc ... min min) )))
957
958(define-syntax max-ec
959  (syntax-rules ()
960    ((max-ec etc1 etc ...)
961     (fold3-ec (max) etc1 etc ... max max) )))
962
963(define-syntax last-ec
964  (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) )
971
972    ((last-ec default qualifier expression)
973     (let ((result default))
974       (do-ec qualifier (set! result expression))
975       result ))))
976
977
978; ==========================================================================
979; The fundamental early-stopping comprehension first-ec
980; ==========================================================================
981
982(define-syntax first-ec
983  (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) )
990
991    ((first-ec default qualifier expression)
992     (let ((result default) (stop #f))
993       (ec-guarded-do-ec 
994         stop 
995         (nested qualifier)
996         (begin (set! result expression)
997                (set! stop #t) ))
998       result ))))
999
1000; (ec-guarded-do-ec stop (nested q ...) cmd)
1001;   constructs (do-ec q ... cmd) where the generators gen in q ... are
1002;   replaced by (:until gen stop).
1003
1004(define-syntax ec-guarded-do-ec
1005  (syntax-rules (nested if not and or begin)
1006
1007    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
1008     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
1009
1010    ((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)) )
1018
1019    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
1020     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
1021
1022    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
1023     (do-ec 
1024       (:until gen stop) 
1025       (ec-guarded-do-ec stop (nested q ...) cmd) ))
1026
1027    ((ec-guarded-do-ec stop (nested) cmd)
1028     (do-ec cmd) )))
1029
1030; Alternative: Instead of modifying the generator with :until, it is
1031;   possible to use call-with-current-continuation:
1032;
1033;   (define-synatx first-ec
1034;     ...same as above...
1035;     ((first-ec default qualifier expression)
1036;      (call-with-current-continuation
1037;       (lambda (cc)
1038;        (do-ec qualifier (cc expression))
1039;        default ))) ))
1040;
1041;   This is much simpler but not necessarily as efficient.
1042
1043
1044; ==========================================================================
1045; The early-stopping comprehensions any?-ec every?-ec
1046; ==========================================================================
1047
1048(define-syntax any?-ec
1049  (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) )
1056
1057    ((any?-ec qualifier expression)
1058     (first-ec #f qualifier (if expression) #t) )))
1059
1060(define-syntax every?-ec
1061  (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) )
1068
1069    ((every?-ec qualifier expression)
1070     (first-ec #t qualifier (if (not expression)) #f) )))
1071
1072
1073)
Note: See TracBrowser for help on using the repository browser.