538 lines
22 KiB
Scheme
538 lines
22 KiB
Scheme
;; goof-impl.scm - portable parts of goof loop..
|
|
;;
|
|
;; Copyright 2020 Linus Björnstam
|
|
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
|
|
;; All rights reserved.
|
|
;;
|
|
;; Redistribution and use in source and binary forms, with or without
|
|
;; modification, are permitted provided that the following conditions
|
|
;; are met:
|
|
;; 1. Redistributions of source code must retain the above copyright
|
|
;; notice, this list of conditions and the following disclaimer.
|
|
;; 2. Redistributions in binary form must reproduce the above copyright
|
|
;; notice, this list of conditions and the following disclaimer in the
|
|
;; documentation and/or other materials provided with the distribution.
|
|
;; 3. The name of the author(s) may not be used to endorse or promote products
|
|
;; derived from this software without specific prior written permission.
|
|
;;
|
|
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
|
|
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
|
|
(define-aux-syntaxes
|
|
;; Auxiliary syntax for the loop clauses
|
|
:when :unless :break :final :bind :do :subloop :for :acc
|
|
;; Auxiliary syntax for the iterators.
|
|
:gen
|
|
;; auxiliary auxiliary syntax
|
|
;; for vectoring
|
|
:length :fill
|
|
;;for up-from and down-to
|
|
:to :by
|
|
;; Internal syntax. %acc is turned into :acc by the forify macro
|
|
;; it is used make it possible to report an error if :acc is used in
|
|
;; one of the simple macros.
|
|
%acc
|
|
;; nop. Used by CL
|
|
:nop)
|
|
|
|
|
|
|
|
(include "goof/iterators.scm")
|
|
|
|
|
|
(define-syntax loop
|
|
(syntax-rules ()
|
|
((loop . rest)
|
|
(%loop (loop . rest) . rest))))
|
|
|
|
|
|
(define-syntax %loop
|
|
(syntax-rules ()
|
|
((%loop o () body ...)
|
|
(%loop o ((:for ensure-once (up-from 0 1))) body ...))
|
|
((%loop o name () body ...)
|
|
(%loop o name ((:for ensure-once (up-from 0 1))) body ...))
|
|
((%loop o (clauses ...) body ...)
|
|
(ensure-for-clause #f () (clauses ...) o
|
|
loop-name
|
|
body ... (loop-name)))
|
|
((%loop o name (clauses ...) . body)
|
|
(ensure-for-clause #f () (clauses ...) o name
|
|
. body))))
|
|
|
|
;; This ensures that the first subloop has at least ONE for clause. If none is found
|
|
;; we add a dummy one!
|
|
(define-syntax ensure-for-clause
|
|
(syntax-rules (:for :acc :break :subloop :when :unless :final DONE)
|
|
((_ DONE clauses () orig name . body)
|
|
(cl orig name
|
|
(()) (()) (()) (()) (()) () ((() ())) (())
|
|
clauses . body))
|
|
|
|
;; Ensure that a subloop gets run at least once
|
|
((_ #f (clauses ...) () . rest)
|
|
(ensure-for-clause DONE ((:for dummy (up-from 0 1)) clauses ...) () . rest))
|
|
((_ #f (done ...) (:subloop . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) :subloop . clauses) () . rest))
|
|
((_ #f (done ...) ((:when test) . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:when test) . clauses) () . rest))
|
|
((_ #f (done ...) ((:unless test) . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:unless test) . clauses) () . rest))
|
|
((_ #f (done ...) ((:break test) . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:break test) . clauses) () . rest))
|
|
((_ #f (done ...) ((:final test) . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for dummy (up-from 0 1)) (:final test) . clauses) () . rest))
|
|
((_ _ (done ...) ((:for . stuff) . clauses) . rest)
|
|
(ensure-for-clause DONE (done ... (:for . stuff) . clauses ) () . rest))
|
|
|
|
;; for the rest the clause type does not matter
|
|
((_ ? (done ...) (clause . clauses) . rest)
|
|
(ensure-for-clause ? (done ... clause) clauses . rest))))
|
|
|
|
|
|
(define-syntax push-new-subloop
|
|
(syntax-rules ()
|
|
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
|
|
(user ...) clauses . body)
|
|
(cl orig name
|
|
(() lets ...)
|
|
(() accs ...)
|
|
(() vars ...)
|
|
(() checks ...)
|
|
(() refs ...)
|
|
f
|
|
;; propagate :for-finalizers to subloop to be run in case of :break
|
|
((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) . ff-rest)
|
|
(() user ...)
|
|
clauses . body))))
|
|
|
|
|
|
;; cl sorts all the clauses into subloops and positions everything where it should be.
|
|
(define-syntax cl
|
|
(syntax-rules (=> :for :acc :when :unless :break :final :do :bind :subloop)
|
|
((_ orig name l a v c r f ff user () => expr . body)
|
|
(emit orig name l a v c r f ff user expr . body))
|
|
((_ orig name l a v c r () ff user () . body)
|
|
(emit orig name l a v c r () ff user (if #f #f) . body))
|
|
|
|
;; If we have no final-expr, but we have final bindings, we return those.
|
|
((_ orig name l a v c r ((final-binding expr) ...) ff user () . body)
|
|
(emit orig name l a v c r ((final-binding expr) ...) ff user (values final-binding ...) . body))
|
|
|
|
;; user bindings
|
|
((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) ((:bind (id id* ... expr) ...) clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-ul ... (:bind (id id* ... expr) ...)) . ul-rest) (clauses ...) . body))
|
|
|
|
;; user-whens
|
|
((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:when test) clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-uw ... (:when test)) . uw-rest) (clauses ...) . body))
|
|
((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:unless test) clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-uw ... (:when (not test))) . uw-rest) (clauses ...) . body))
|
|
|
|
;; USER BREAKS
|
|
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
|
|
((_ orig name l a v c r f ff ((cur-ub ...) . ub-rest) ((:break expr) clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-ub ... (:break expr)) . ub-rest) (clauses ...) . body))
|
|
;; user final
|
|
((_ orig name l a v c r f ff ((cur-user ...) . user-rest) ((:final expr) clauses ...) . body)
|
|
(final :acc ((fin) (expr)) cl-next/acc orig name l a v c r f ff ((cur-user ... (:break fin)) . user-rest) (clauses ...) . body))
|
|
|
|
;; User do - sideffecting stuff.
|
|
((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:do expr ...) clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-uw ... (:do expr ...)) . uw-rest) (clauses ...) . body))
|
|
|
|
;; Explicit subloop. Shorthand for (:when #t)
|
|
((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) (:subloop clauses ...) . body)
|
|
(cl orig name l a v c r f ff ((cur-uw ... :nop) . uw-rest) (clauses ...) . body))
|
|
;; :for-clauses
|
|
;; found a for clause when we have a :when or :unless clause. Push new subloop
|
|
((_ orig name l a v c r f ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body)
|
|
(push-new-subloop orig name l a v c r f ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body))
|
|
|
|
;; For clause with a sequence creator.
|
|
((_ orig name l a v c r f ff user((:for id ids ... (iterator source ...)) clauses ...) . body)
|
|
(valid-clause? iterator :for ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff user (clauses ...) . body))
|
|
|
|
;; accumulator clause
|
|
((_ orig name l a v c r f ff user ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
|
|
(valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff user (clauses ...) . body))
|
|
|
|
;; ERROR HANDLING?
|
|
((_ orig name l a v c r f ff user (clause . rest) . body)
|
|
(syntax-error "Invalid clause in loop" clause orig))))
|
|
|
|
|
|
|
|
|
|
;; HOLY CODE-DUPLICATION-BATMAN!
|
|
;; cl-next/acc integrates all the bindings by an :acc clause. The complexity comes from pushing :acc-clauses
|
|
;; into the outer loops. Since accumulators need to be available in the (final-fun ...), they need to be visible also
|
|
;; in the outer loops if the loop exits there.
|
|
(define-syntax cl-next/acc
|
|
(syntax-rules (:acc)
|
|
;; :acc clause without any subloops
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
((lets ...))
|
|
((accs ...))
|
|
vars
|
|
checks
|
|
((refs ...))
|
|
(finals ...)
|
|
ff ((cur-ub ...) . ub-rest) clauses . body)
|
|
(cl orig name
|
|
((lets ... new-lets ...))
|
|
((accs ... (accvar accinit accvar) ...))
|
|
vars
|
|
checks
|
|
((refs ... new-refs ...))
|
|
(finals ... new-finals ...)
|
|
ff ((cur-ub ... (:bind (accvar accupdate) ...) (:break new-checks) ... ) . ub-rest) clauses . body))
|
|
;; We have ONE subloop!
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
(lets ... (outermost-lets ...))
|
|
((accs ...) ((oldacc oldinit oldupdate) ...))
|
|
vars
|
|
checks
|
|
((refs ...) . refs-rest)
|
|
(finals ...)
|
|
ff ((cur-ub ...) . ub-rest) clauses . body)
|
|
(cl orig name
|
|
(lets ... (outermost-lets ... new-lets ...))
|
|
((accs ... (accvar accvar accvar) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
|
|
vars
|
|
checks
|
|
((refs ... new-refs ...) . refs-rest)
|
|
(finals ... new-finals ...)
|
|
ff ((cur-ub ... (:break new-checks) ... (:bind (accvar accupdate) ...)) . ub-rest) clauses . body))
|
|
;; We have several subloops!
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
(lets ... (outermost-lets ...))
|
|
((accs ...) ((oldacc oldinit oldupdate) ...) ... ((oldestacc oldestinit oldestupdate) ...))
|
|
vars
|
|
checks
|
|
((refs ...) . refs-rest)
|
|
(finals ...)
|
|
ff ((cur-ub ...) . ub-rest) clauses . body)
|
|
(cl orig name
|
|
(lets ... (outermost-lets ... new-lets ...))
|
|
((accs ... (accvar accvar accvar) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
|
|
((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
|
|
vars
|
|
checks
|
|
((refs ... new-refs ...) . refs-rest)
|
|
(finals ... new-finals ...)
|
|
ff ((cur-ub ... (:break new-checks) ... (:bind (accvar accupdate) ...)) . ub-rest) clauses . body))))
|
|
|
|
;; Integrating for clauses is not as involved, since they only want to be introduced into the current
|
|
;; loop. Any propagation of for finalizers (ff) is done by push-new-subloop
|
|
(define-syntax cl-next/for
|
|
(syntax-rules ()
|
|
((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-for-finals ...)
|
|
orig name
|
|
((lets ...) . lets-rest)
|
|
accs
|
|
((vars ...) . vars-rest)
|
|
((checks ...) . checks-rest)
|
|
((refs ...) . refs-rest)
|
|
finals
|
|
(((ff-cur ...) (ff-above ...)) . ff-rest)
|
|
user clauses . body)
|
|
(cl orig name
|
|
((lets ... new-lets ...) . lets-rest)
|
|
accs
|
|
((vars ... new-vars ...) . vars-rest)
|
|
((checks ... new-checks ...) . checks-rest)
|
|
((refs ... new-refs ...) . refs-rest)
|
|
finals
|
|
(((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest)
|
|
user clauses . body))
|
|
((cl err ...)
|
|
(cl err ...))))
|
|
|
|
|
|
(define-syntax user
|
|
(syntax-rules (:when :bind :break :do :nop)
|
|
((_ final-expr next outer () body ...)
|
|
(begin body ...))
|
|
((_ f n o (:nop . rest) . body)
|
|
(user f n o rest . body))
|
|
((_ f n o ((:bind pairs ...) . rest) . body)
|
|
(ref-let (pairs ...)
|
|
(user f n o rest . body)))
|
|
((_ f n o ((:when test) . rest) . body)
|
|
(cond
|
|
(test (user f n o rest . body))
|
|
(else n)))
|
|
((_ (final-expr ...) n o ((:break expr) . rest) . body)
|
|
(cond
|
|
(expr final-expr ...)
|
|
(else (user (final-expr ...) n o rest . body))))
|
|
((_ f n o ((:do expr ...) . rest) . body)
|
|
(begin
|
|
expr ...
|
|
(user f n o rest . body)))))
|
|
|
|
|
|
|
|
;; If there are no subloops, we emit to the simple case
|
|
(define-syntax emit
|
|
(syntax-rules ()
|
|
((_ orig name (one) . rest)
|
|
(emit-one orig name (one) . rest))
|
|
((_ orig name . rest)
|
|
(emit-many/first #f name . rest))))
|
|
|
|
(define-syntax emit-one
|
|
(syntax-rules ()
|
|
((_ orig name
|
|
((lets ...))
|
|
(((accvar accinit accstep) ...))
|
|
(((var init step) ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
((final-binding final-value) ...)
|
|
(((ff-cur ...) (ff-above ...)))
|
|
((us ...))
|
|
final-expr . body)
|
|
(let* (lets ...)
|
|
(let loop ((accvar accinit) ... (var init) ...)
|
|
(if (or checks ...)
|
|
(begin
|
|
ff-above ...
|
|
ff-cur ...
|
|
(let ((final-binding final-value) ...)
|
|
final-expr))
|
|
(ref-let (refs ...)
|
|
(user (ff-above ...
|
|
ff-cur ...
|
|
(let ((final-binding final-value) ...)
|
|
final-expr))
|
|
(loop accvar ... step ...)
|
|
#f
|
|
(us ...)
|
|
(let-kw-form name
|
|
(final-fun final-value ...)
|
|
()
|
|
(loop (accvar accstep) ... (var step) ...)
|
|
(let () (if #f #f) . body))))))))))
|
|
|
|
;; Emit-many/first emits the outermost let loop and binds the final lambda.
|
|
(define-syntax emit-many/first
|
|
(syntax-rules ()
|
|
((_ orig name
|
|
(lets-next ... (lets ...))
|
|
(accs-next ... ((accvar accinit accstep) ...))
|
|
(vars-next ... ((var init step) ...))
|
|
(checks-next ... (checks ...))
|
|
(refs-next ... (refs ...))
|
|
((final-binding final-value) ...)
|
|
(ff-next ... ((ff-cur ...) ()))
|
|
(us-next ... (us ...))
|
|
final-expr
|
|
. body)
|
|
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
|
lets ...)
|
|
(let outer-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
(begin
|
|
ff-cur ...
|
|
(final-fun final-value ...))
|
|
(ref-let (refs ...)
|
|
(user (ff-cur ... (final-fun final-value ...))
|
|
(outer-loop accvar ... step ...)
|
|
#f
|
|
(us ...)
|
|
(emit-many/rest orig
|
|
name
|
|
(outer-loop accstep ... step ...)
|
|
(lets-next ...)
|
|
(accs-next ...)
|
|
(vars-next ...)
|
|
(checks-next ...)
|
|
(refs-next ...)
|
|
;; THIS IS NOW A COMPLETE call to final
|
|
(final-fun final-value ...)
|
|
(ff-next ...)
|
|
(us-next ...)
|
|
. body)))))))))
|
|
|
|
(define-syntax emit-many/rest
|
|
(syntax-rules ()
|
|
;; match innermost loop
|
|
((_ orig
|
|
name
|
|
outer
|
|
((lets ...))
|
|
(((accvar accinit accstep) ...))
|
|
(((var init step) ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
final
|
|
(((ff-cur ...) (ff-above ...)))
|
|
((us ...))
|
|
. body)
|
|
(let* (lets ...)
|
|
(let innermost-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
(begin
|
|
ff-cur ...
|
|
outer)
|
|
(ref-let (refs ...)
|
|
(user (ff-cur ... ff-above ... final)
|
|
(innermost-loop accstep ... step ...)
|
|
#f
|
|
(us ...)
|
|
(let-kw-form name final () (innermost-loop (accvar accstep) ... (var step) ...)
|
|
. body)))))))
|
|
|
|
;; Any intermediate loops
|
|
((_ orig
|
|
name
|
|
outer
|
|
(next-lets ... (lets ...))
|
|
(next-accs ... ((accvar accinit accstep) ...))
|
|
(next-vars ... ((var init step) ...))
|
|
(next-checks ... (checks ...))
|
|
(next-refs ... (refs ...))
|
|
final
|
|
(next-ff ... ((ff-cur ...) (ff-above ...)))
|
|
(us-next ... (us ...))
|
|
. body)
|
|
(let* (lets ...)
|
|
(let intermediate-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
(begin
|
|
ff-cur ...
|
|
outer)
|
|
(ref-let (refs ...)
|
|
(user (ff-cur ... ff-above ... final)
|
|
(intermediate-loop accstep ... step ...)
|
|
#f
|
|
(us ...)
|
|
(emit-many/rest orig
|
|
name
|
|
(intermediate-loop accstep ... step ...)
|
|
(next-lets ...)
|
|
(next-accs ...)
|
|
(next-vars ...)
|
|
(next-checks ...)
|
|
(next-refs ...)
|
|
final
|
|
(next-ff ...)
|
|
(us-next ...)
|
|
. body)))))))))
|
|
|
|
(define-syntax forify
|
|
(syntax-rules (%acc)
|
|
((_ orig name () ((%acc . acc-rest) . argsrest) . body)
|
|
(forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
|
|
((_ . rest)
|
|
(forify* . rest))))
|
|
|
|
(define-syntax forify*
|
|
(syntax-rules (:for :acc :when :unless :break :final :subloop :bind :do %acc)
|
|
((_ o n done-clauses () . body)
|
|
(%loop o n done-clauses . body))
|
|
((_ o n (s ...) ((:for c-rest ...) clauses ...) . body)
|
|
(forify* o n (s ... (:for c-rest ...)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:when expr) clauses ...) . body)
|
|
(forify* o n (s ... (:when expr)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:unless expr) clauses ...) . body)
|
|
(forify* o n (s ... (:unless expr)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:break expr) clauses ...) . body)
|
|
(forify* o n (s ... (:break expr)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:final expr) clauses ...) . body)
|
|
(forify* o n (s ... (:final expr)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:do expr ...) clauses ...) . body)
|
|
(forify* o n (s ... (:do expr ...)) (clauses ...) . body))
|
|
((_ o n (s ...) (:subloop clauses ...) . body)
|
|
(forify* o n (s ... :subloop) (clauses ...) . body))
|
|
((_ o n (s ...) ((:bind pairs ...) clauses ...) . body)
|
|
(forify* o n (s ... (:bind pairs ...)) (clauses ...) . body))
|
|
((_ o n (s ...) ((%acc c-rest ...) clauses ...) . body)
|
|
(forify* o n (s ... (:acc c-rest ...)) (clauses ...) . body))
|
|
((_ o n (s ...) ((:acc c-rest ...) clauses ...) . body)
|
|
(syntax-error "Accumulating clauses are not allowed in simplified loop forms." o))
|
|
((_ o n (s ...) ((id id* ... (iterator source ...)) clauses ...) . body)
|
|
(forify* o n (s ... (:for id id* ... (iterator source ...))) (clauses ...) . body))))
|
|
|
|
(define-syntax loop/list
|
|
(syntax-rules ()
|
|
((_ (clauses ...) body ...)
|
|
(forify (loop/list (clauses ...) body ...)
|
|
loop-name () (clauses ...)
|
|
=> '()
|
|
(cons (let () body ...) (loop-name))))))
|
|
|
|
(define-syntax loop/sum
|
|
(syntax-rules ()
|
|
((_ (clauses ...) body ...)
|
|
(forify (loop-sum (clauses ...) body ...)
|
|
loop-name
|
|
() (clauses ... (%acc acc (summing (let () body ...))))
|
|
=> acc
|
|
(loop-name)))))
|
|
|
|
(define-syntax loop/product
|
|
(syntax-rules ()
|
|
((n (clauses ...) body ...)
|
|
(forify (n (clauses ...) body ...)
|
|
product-loop () (clauses ... (%acc acc (multiplying (let () body ...))))
|
|
=> acc
|
|
(product-loop)))))
|
|
|
|
(define sentinel (list 'unique))
|
|
|
|
;; TODO: maybe have a look at the expansion of this. It seems weird.
|
|
(define-syntax loop/first
|
|
(syntax-rules ()
|
|
((n (clauses ...) body ...)
|
|
(forify (n (clauses ...) body ...)
|
|
loop/first
|
|
() (clauses ... (:final #t))
|
|
=> #f
|
|
body ...))))
|
|
|
|
|
|
(define-syntax loop/last
|
|
(syntax-rules ()
|
|
((n (clauses ...) body ...)
|
|
(forify (n (clauses ...) body ...)
|
|
loop-name () (clauses ... (%acc acc (folding sentinel)))
|
|
=> (if (eq? sentinel acc) #f acc)
|
|
(let ((result (let () body ...)))
|
|
(loop-name (=> acc result)))))))
|
|
|
|
(define-syntax loop/and
|
|
(syntax-rules ()
|
|
((n (clauses ...) body ...)
|
|
(forify (n (clauses ...) body ...)
|
|
and-loop
|
|
() (clauses ... (%acc acc (folding #t)))
|
|
=> acc
|
|
(let ((res (let () body ...)))
|
|
(and res (and-loop (=> acc res))))))))
|
|
|
|
(define-syntax loop/or
|
|
(syntax-rules ()
|
|
((n (clauses ...) body ...)
|
|
(forify (n (clauses ...) body ...)
|
|
or-loop
|
|
() (clauses ...)
|
|
=> #f
|
|
(or (let () body ...) (or-loop))))))
|