1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054 |
- (define-syntax do-ec
- (syntax-rules (nested if not and or begin :do let)
-
- ((do-ec (nested q ...) etc ...)
- (do-ec q ... etc ...) )
-
- ((do-ec q1 q2 etc1 etc ...)
- (do-ec q1 (do-ec q2 etc1 etc ...)) )
-
- ((do-ec cmd)
- (begin cmd (if #f #f)) )
-
- ((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)) )
-
- ((do-ec (begin etc ...) cmd)
- (begin etc ... (do-ec cmd)) )
-
- ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
- (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
- ((do-ec (g arg1 arg ...) cmd)
- (g (do-ec:do cmd) arg1 arg ...) )))
- (define-syntax do-ec:do
- (syntax-rules (:do let)
-
- ((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 ...) )))))))))) ))
-
- (define-syntax ec-simplify
- (syntax-rules (if not let begin)
-
- ((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 )
-
- ((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)) )
-
- ((ec-simplify (let () command ...))
- (ec-simplify (begin command ...)) )
-
- ((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 ...)) )
-
- ((ec-simplify 1 () ())
- (if #f #f) )
- ((ec-simplify 1 (command) ())
- command )
- ((ec-simplify 1 (command1 command ...) ())
- (begin command1 command ...) )
- ((ec-simplify expression)
- expression )))
- (define-syntax :do
- (syntax-rules ()
-
- ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
- (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
-
- ((: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 ...) )))
- (define-syntax :parallel-1
- (syntax-rules (:do let)
-
- ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
- (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
-
- ((: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 ...) )))
-
- ((:parallel-1 (cc ...) () result)
- (cc ... result) )))
- (define-syntax :while
- (syntax-rules ()
- ((:while cc (g arg1 arg ...) test)
- (g (:while-1 cc test) arg1 arg ...) )))
- (define-syntax :while-1
- (syntax-rules (:do let)
- ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
- (: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) )))
- (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 ...) )))
- (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))) )))
- (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)
-
- ((: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) )
- ((: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)) ))
- ((: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)) ))))
- (define-syntax :real-range
- (syntax-rules (index)
-
- ((: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) )
-
- ((: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)) ))))
-
- (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)) ))))
- (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)) ))))
- (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)) ))))
- (define-syntax :generator-proc
- (syntax-rules (:do let)
-
- ((:generator-proc (g arg ...))
- (g (:generator-proc var) var arg ...) )
-
- ((: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) ...)
- (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 ))))))))
-
- ((: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) ))))
- (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 ...) )))
- (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))
- (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 ))))
- (define-syntax list-ec
- (syntax-rules ()
- ((list-ec etc1 etc ...)
- (reverse (fold-ec '() etc1 etc ... cons)) )))
- (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 ...)) )))
- (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 ...)) )))
- (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 ))))
- (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 ))))
- (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) )))
- (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) )))
|