Simplified install
This commit is contained in:
Linus
parent
2775e70fd0
commit
ec2b65612c
1 changed files with 1 additions and 1 deletions
542
goof/goof-impl.scm
Normal file
542
goof/goof-impl.scm
Normal file
|
|
@ -0,0 +1,542 @@
|
|||
;; goof-impl.scm - portable parts of goof loop..
|
||||
;;
|
||||
;; Copyright 2020-2021 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 syntax for some accumulators
|
||||
:initial :if
|
||||
;; auxiliary auxiliary syntax
|
||||
;; for vectoring
|
||||
:length :fill
|
||||
;;for up-from and down-to
|
||||
:to :by
|
||||
;; used by for/first and for/last
|
||||
:default
|
||||
;; 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 "iterators.scm")
|
||||
|
||||
;; This first step saves the original syntax.
|
||||
(define-syntax loop
|
||||
(syntax-rules ()
|
||||
((loop . rest)
|
||||
(%loop (loop . rest) . rest))))
|
||||
|
||||
|
||||
;; This second step adds a loop name and makes sure it loops
|
||||
;; A loop form without name or clauses will run forever.
|
||||
(define-syntax %loop
|
||||
(syntax-rules ()
|
||||
((%loop o (clauses ...) body ...)
|
||||
(cl o outer-loop
|
||||
(()) (()) (()) (()) (()) () ((() ())) (())
|
||||
(clauses ...) body ... (outer-loop)))
|
||||
((%loop o name clauses . body)
|
||||
(cl o name
|
||||
(()) (()) (()) (()) (()) () ((() ())) (())
|
||||
clauses . body))))
|
||||
|
||||
|
||||
;; This is only here for simplified forms with an identity. If the loop has no :for-clause in the
|
||||
;; outermost loop, we add a dummy one so that the first part is executed once.
|
||||
(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 ... (:bind (accvar accupdate) ...) (:break new-checks) ... ) . 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 ...(:bind (accvar accupdate) ...) (:break new-checks) ...) . 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 ...))))
|
||||
|
||||
;; User is responsible for all non-acc/non-for clauses.
|
||||
(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 (:for :acc :when :unless :break :final :subloop :bind :do %acc)
|
||||
((_ o n done-clauses () body ...)
|
||||
(ensure-for-clause #f () done-clauses o
|
||||
n
|
||||
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)))))
|
||||
|
||||
;; This exploits that we give the loop a name, but don't add the loop to the end of the
|
||||
;; body, thus returning whatever the last expr of body returns.
|
||||
(define-syntax loop/first
|
||||
(syntax-rules (:default)
|
||||
((n :default val (clauses ...) body ...)
|
||||
(forify (n (clauses ...) body ...)
|
||||
loop/first
|
||||
() (clauses ...)
|
||||
=> val
|
||||
body ...))
|
||||
((n (clauses ...) body ...)
|
||||
(loop/first :default #f (clauses ...) body ...))))
|
||||
|
||||
|
||||
;; unique value used for loop/last
|
||||
(define sentinel (list 'unique))
|
||||
(define-syntax loop/last
|
||||
(syntax-rules (:default)
|
||||
((n :default val (clauses ...) body ...)
|
||||
(forify (n (clauses ...) body ...)
|
||||
loop-name () (clauses ... (%acc acc (folding sentinel)))
|
||||
=> (if (eq? sentinel acc) val acc)
|
||||
(let ((result (let () body ...)))
|
||||
(loop-name (=> acc result)))))
|
||||
((n (clauses ...) body ...)
|
||||
(loop/last :default #f (clauses ...) body ...))))
|
||||
|
||||
(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))))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue