bjoli/goof-loop
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

First commit

Browse source
This commit is contained in:
Linus 2020-11-02 22:11:45 +01:00
commit ef96da9658
4 changed files with 855 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

94
README.md Normal file
View file

@ -0,0 +1,94 @@
# goof-loop - a scheme looping facility
WARNING: CURRENTLY PRE-ALPHA
goof-loops aims to be an amalgamation of the racket for loops and Alex Shinn's foof-loop. We are many that found racket's for loops a breeze of fresh air, but in the end their most general forms (for/fold and for/foldr) are kinda odd to work with. If you choose not to use those general for loops, you cannot express arbitrary transformations, like say a fibonacci sequence, since for clauses cannot reference eachother. This is understandable given how they are tied to the underlying racket sequences, but still somewhat disappointing. goof-loop tries to fix this:
```
(loop ((:for a (in 0 b))
(:for b (in 1 (+ a b)))
(:for count (up-from 0 (to 1000)))
(:for acc (listing b)))
=> acc
(display b) (newline))
```
The above example will display and accumulate the 1000 first fibonacci numbers. Doing the same thing in racket requires you to manually handle all the state in fold-variables using for/fold. It is a simple example, but proves the usefulness of goof-loop.
Compared to foof-loop, some things are added. Apart from minor syntactic changes, subloops are supported. The best way is to show:
```
(define lst '((1 2) 'dud (3 4) (5 6)))
(loop ((:for a (in-list lst))
(:when (pair? a))
(:for b (in-list a))
(:for acc (summing b)))
=> acc)
```
This will sum all the sublists of lst and produce the result 21. Any :when, :unless, or :break clause will break out a subloop if any subsequent for clauses are found.
## Differences from foof-loop
### syntactical
all keywords are prepended with a : to distinguish them from regular variables. for -> :for
while and until are removed in favour of :break.
:when and :unless are added to better control when the loop body is executed (and accumulators accumulated)
with-clauses are removed in favour of (:for var (in init [step [stop]]))
accumulators are no longer for-clauses, but should be prepended with :acc.
### Regressions
only :acc clauses are visible in the final-expression. This is due to for-clauses not being promoted through to outer loops (since they should not keep their state).
:for clauses cannot finalize, due to the above thing. The reason for distinguishing between :for and :acc is to be able to promote accumulators outwards and finalizers inwards. This is not implemented.
### changes
(with var [init [step [guard]]]) => (:for var (in init [step [stop-expr]])). guard was a procedure, but now it is an expression.
(with var 10 (- var 1) negative?) => (:for var (in 10 (- var 10) (negative? var)))
I plan to remove non-named variable updates. That is a minor inconveniance, but unnamed updates has been my largest source of bugs, so I have grown to hate them.
### similarities
You can of course still have a larger control of your loops:
```
(loop loopy-loop ((:for a (up-from 1 (to 11))))
=> '()
(if (odd? a)
(cons (* a (- a)) (loopy-loop))
(cons (* a a) (loopy-loop))))
;; => (-1 4 -9 16 -25 36 -49 64 -81 100)
```
Named updates have a bug, sadly.
## Todo
Currently, there is a bug if you have subloops more than 2 loops deep where all accumulators are reset. This should be an easy fix.
Regarding the above: fixing that bug does nothing! I can only output loops of at most 2.
Should we add finalizers for :for-clauses? I can't see the need outside of a potential (in-file ...), which can't be properly supported anyway since I won't do any dynamic-wind stuff.
Is (:for var (in init step stop)) and (:acc var (in init update)) good syntax? the :with clause of foof-loop is nice, but what should it be called for accumulators? Should we go back to calling both :acc and :for just ":for" and re-add :with and an accumulating counterpart? What should that accumulating counterpart be called? :acc?
Add racket #:final clauses.
## foof, what a guy
I have previously expressed some admiration for Alex and I will do it again. The source of chibi loop is extremely elegant, and all but the hairiest part is written in syntax-rules. Not only has he written my two favourite SRFIs, his input in all the other discussions I have seen is always on-point, pragmatic and generally fantastic. He neither knows of this project, nor embraces it in any way. Y'all should go look at the source of (chibi loop) though.
## Licence
The same BSD-styled license Alex uses for chibi-loop.

418
goof.scm Normal file
View file

@ -0,0 +1,418 @@
;; goof loop - a bastardisation of chibi 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.
;; This is a looping construct obviously based on (chibi loop) (aka:
;; foof-loop) by Alex Shinn. The name goof-loop is a play on that
;; name, and the fact that I goofed in the chibi issue tracker when
;; trying to understand the iterator protocol.
;;
;; It extends chibi loop in the following way:
;; * adds support for binding variables in the loop clauses.
;; * Adds :when, :unless, and :break clauses that controls when the loop
;; body executes and when values are collected by accumulating for clauses.
;; similar to how #:when, #:unless and #:break works in racket.
;; * Planned: add support for subloops, akin to what the starified loops of
;; racket do.
;;
;; It restricts chibi loops in the following ways:
;; * with- and for-clauses are no longer visible in the final expression, for that you
;; must use a clause for which I don't have a name yet.
(use-modules (helpers)
(srfi srfi-71))
(include "iterators.scm")
;; TODO: Add intermediate subloops. Make sure that accumulators are properly propagated.
;; TODO. fix let-kw-form. Don't use mutation. This should work:(define (partition predicate list)
;; (loop continue ((:for element (in-list list))
;; (:acc satisfied (in '()))
;; (:acc unsatisfied (in '())))
;; => (values (reverse satisfied)
;; (reverse unsatisfied))
;; (if (predicate element)
;; (continue (=> satisfied (cons element satisfied)))
;; (continue (=> unsatisfied (cons element unsatisfied))))))
(define-aux-syntaxes :for :when :unless :break :final :let :let* :acc :subloop)
(define-syntax loop
(syntax-rules ()
((loop (clauses ...) body ...)
(cl (loop (clauses ...) body ...)
loop-name
(()) (()) (()) (()) (()) () (()) (()) (())
(clauses ...)
body ... (loop-name)))
((loop name (clauses ...) . body)
(cl (loop name (clauses ...) . body)
name
(()) (()) (()) (()) (()) () (()) (()) (())
(clauses ...)
. body))))
(define-syntax push-new-subloop
(syntax-rules ()
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (ul ...) (uw ...) (ub ...) clauses . body)
(cl orig name
(() lets ...)
(() accs ...)
(() vars ...)
(() checks ...)
(() refs ...)
f
(() ul ...)
(() uw ...)
(() ub ...)
clauses . body))))
;; Clauses sorts all the clauses into subloops and positions everything where it should be.
(define-syntax cl
(syntax-rules (=> in :for :with :when :unless :break :final :let :acc)
((_ orig name l a v c r f ul uw ub () => expr . body)
(emit orig name l a v c r f ul uw ub expr . body))
((_ orig name l a v c r f ul uw ub () . body)
(emit orig name l a v c r f ul uw ub (if #f #f) . 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 ul ((uw uw* ...) . uw-rest) ub ((:for for-rest ...) clauses ...) . body)
(push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((:for for-rest ...) clauses ...) . body))
;; The four special :for var (in ...)-clauses where user specifies their own iteration
((_ orig name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body)
(push-new-subloop name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body))
((_ orig name l a ((v-cur ...) . v-rest) ((c-cur ...) . c-rest)
r f ul uw ub ((:for var (in init step guard-expr)) clauses ...) . body)
(cl orig name l a ((v-cur ... (var init step)) . v-rest) ((c-cur ... guard-expr) . c-rest)
r f ul uw ub (clauses ...) . body))
((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init step)) clauses ...) . body)
(cl orig name l a ((v-cur ... (var init step)) . v-rest) c r f ul uw ub (clauses ...) . body))
((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init)) clauses ...) . body)
(cl orig name l a ((v-cur ... (var init var)) . v-rest) c r f ul uw ub (clauses ...) . body))
;; For clause with a sequence creator.
((_ orig name l a v c r f ul uw ub ((:for id ids ... (iterator source ...)) clauses ...) . body)
(iterator ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub (clauses ...) . body))
;; Accumulating clauses
;; should I push a subloop on a when clause?
;; Currently these have no stop or if-clauses. Maybe add?
((_ orig name l a v c r f ul uw ub ((:acc var (in init update)) clauses ...) . body)
(cl-next () ((var init update)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . body))
((_ orig name l a v c r f ul uw ub ((:acc var (in init)) clauses ...) . body)
(cl-next () ((var init var)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . body))
;; user-whens
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub ((:when test) clauses ...) . body)
(cl orig name l a v c r f ul ((cur-uw ... test) . uw-rest) ub (clauses ...) . body))
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub ((:unless test) clauses ...) . body)
(cl orig name l a v c r f ul ((cur-uw ... (not test)) . uw-rest) ub (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 ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) ((:break expr) clauses ...) . body)
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) (clauses ...) . body))
;; USER LETS
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub ((:let id id* ... expr) clauses ...) . body)
(cl orig name l a v c r f ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub (clauses ...) . body))
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub ((:let* id id* ... expr) clauses ...) . body)
(cl orig name l a v c r f ((cur-ul ... (:let* id id* ... expr)) . ul-rest) (clauses ...) . body))
;; Explicit subloop. Shorthand for (:when #t)
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:subloop clauses ...) . body)
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub (clauses ...) . body))
;; ERROR HANDLING?
((_ orig name l a v c r f ul uw ub (clause . rest) . body)
(syntax-error "Invalid clause in loop" clause orig))
))
;; cl-next integrates the results
;; THIS WILL NEED TO BE UPDATED TO PROPERLY PUSH (accvar accinit accvar) ... down to the first accumulator. currently it
;; will be re-initialized for every previous loop except the innermost one.
;; THIS needs to work:
;; (loop ((:for a (in-list '((1 2) (3 4) (5 6))))
;; (:when #t)
;; (:for b (in-list a))
;; (:for acc (listing b)))
;; => acc)
;; as well as this:
;; (loop ((:for a (in-list '(((1) (2)) ((3) (4)) ((5) (6 7)))))
;; (:when #t)
;; (:for b (in-list a))
;; (:when :t)
;; (:for c (in-list b))
;; (:for acc (listing c)))
;; => acc)
(define-syntax cl-next
(syntax-rules ()
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
orig name
((lets ...))
((accs ...))
((vars ...))
((checks ...))
((refs ...))
(finals ...) ul uw ub clauses . body)
(cl orig name
((lets ... new-lets ...))
((accs ... (accvar accinit accupdate) ...))
((vars ... new-vars ...))
((checks ... new-checks ...))
((refs ... new-refs ...))
(finals ... new-finals ...)
ul uw ub clauses . body))
;; We have a subloop!
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
orig name
((lets ...) . lets-rest)
((accs ...) ((oldacc oldinit oldupdate) ...) ...)
((vars ...) . vars-rest)
((checks ...) . checks-rest)
((refs ...) . refs-rest)
(finals ...) ul uw ub clauses . body)
(cl orig name
((lets ... new-lets ...) . lets-rest)
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...) ...)
((vars ... new-vars ...) . vars-rest)
((checks ... new-checks ...) . checks-rest)
((refs ... new-refs ...) . refs-rest)
(finals ... new-finals ...)
ul uw ub clauses . body))))
(define-syntax user-let
(syntax-rules (:let :let*)
((_ () () () body ...)
(begin body ...))
((_ (lets ...) () () . body)
(let (lets ...)
. body))
((_ () (stars ...) () . body)
(let* (stars ...) . body))
;; These twe clauses handle let type changes.
((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . body)
(let* (stars ...)
(user-let (last (id id* ... expr)) () (clauses ...) . body)))
((_ (lets ...) () ((:let* id id* ... expr) clauses ...) . body)
(let (lets ...)
(user-let () ((id id* ... expr)) (clauses ...) . body)))
;; 2 clauses new of the same that already existed
((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body)
(user-let (lets ... (id id* ... expr)) () (clauses ...) . body))
((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body)
(user-let () (stars ... (id id* ... expr)) (clauses ...) . body))))
;; If there is 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) ...)
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) final-expr . body)
(let* (lets ...)
(define (final-fun final-binding ...)
final-expr)
(define (loopy-loop accvar ... var ...)
(if (or checks ...)
(final-fun final-value ...)
(let (refs ...)
(user-let () () (user-lets ...)
(if (and user-whens ...)
(let-kw-form name (loopy-loop (accvar accstep) ... (var step) ...)
(if (or user-breaks ...)
(final-fun final-value ...)
(let () (if #f #f) . body)))
(loopy-loop accvar ... step ...))))))
(loopy-loop accinit ... init ...)))))
;; 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) ...)
(ul-next ... (user-lets ...))
(uw-next ... (user-whens ...))
(ub-next ... (user-breaks ...))
final-expr
. body)
(let* ((final-fun (lambda (final-binding ...) final-expr))
lets ...)
(let outer-loop ((accvar accinit) ...
(var init) ...)
(if (or checks ...)
(final-fun final-value ...)
(let (refs ...)
(user-let () () (user-lets ...)
(if (and user-whens ...)
(cond
((or user-breaks ...) (final-fun final-value ...))
(else (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 ...)
(ul-next ...)
(uw-next ...)
(ub-next ...)
. body)))
(outer-loop accvar ... step ...))))))))))
(define-syntax emit-many/rest
(syntax-rules ()
;; match innermost loop
((_ orig
name
next
((lets ...))
(((accvar accinit accstep) ...))
(((var init step) ...))
((checks ...))
((refs ...))
final
((user-lets ...))
((user-whens ...))
((user-breaks ...))
. body)
(let innermost-loop ((accvar accinit) ...
(var init) ...)
(let* (lets ...)
(if (or checks ...)
next
(let (refs ...)
(user-let () () (user-lets ...)
(if (and user-whens ...)
(cond
((or user-breaks ...) final)
(else
(let-kw-form name (innermost-loop (accvar accstep) ... (var step) ...)
. body)))
(innermost-loop accvar ... step ...))))))))
;; Any intermediate loops
((_ orig
name
next
(next-lets ... (lets ...))
(next-accs ... ((accvar accinit accupdate) ...))
(next-vars ... ((var init update) ...))
(next-checks ... (checks ...))
(next-refs ... (refs ...))
final
(ul-next ... (user-lets ...))
(uw-next ... (user-whens ...))
(ub-next ... (user-breaks ...))
. body)
(display "not implemented"))))
;; Helper procedures for let-kw-form
(define (syntax= s1 s2)
(equal? (syntax->datum s1) (syntax->datum s2)))
(define (named-update? syn)
(syntax-case syn (=>)
((=> var update) #t)
(_ #f)))
(define (update-psn! params psn val)
(list-set! params psn
(list (car (list-ref params psn)) val)))
(define (update-name! params name val)
(let loop ((params params))
(cond
((null? params) (error "unknown loop parameter name " name (list '=> name val)))
((syntax= name (caar params))
(set-cdr! (car params) (list val))
(display (syntax->datum val))
)
(else
(loop (cdr params))))))
(define (syntax->list stx)
(syntax-case stx ()
((a ...) #'(a ...))))
(define-syntax let-kw-form
(syntax-rules ()
((_ macro-name (loop-name (var step) ...) . body)
(let-syntax ((macro-name
(lambda (stx)
;; this way of formulating params means it is an alist with syntax objects
;; as keys instead of a list of syntax objects
(define params (list #'(var step) ...))
(with-ellipsis :::
(let loop ((lst (cdr (syntax->list stx))) (pos 0))
(if (null? lst)
(with-syntax ((((v s) :::) params))
#'(loop-name s :::))
(syntax-case (car lst) (=>)
((=> name val)
(update-name! params #'name #'val)
(loop (cdr lst) #f))
(val pos
(begin
(update-psn! params psn #'val)
(loop (cdr lst) (+ pos 1))))
(_ (error "Positional arguments cannot be updated after a named argument")))))))))
. body))))

14
helpers.scm Normal file
View file

@ -0,0 +1,14 @@
(define-module (helpers)
#:export (define-aux-syntax define-aux-syntaxes define-parameters
get-proc syntax->list))
(define-syntax define-aux-syntax
(lambda (stx)
(syntax-case stx ()
((_ name)
#'(define-syntax name
(lambda (stx)
(syntax-violation 'name "Loop clause used outside of loop macro" stx)))))))
(define-syntax-rule (define-aux-syntaxes name ...)
(begin
(define-aux-syntax name) ...))

329
iterators.scm Normal file
View file

@ -0,0 +1,329 @@
;; iterators.scm - iterators for 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.
;; TODO iterators
;; in-stream
;; in-naturals
;; in-hash with variations
;; TODO: accumulators
;; vectoring
;; hashing
;; hashqing
;; hashving
(define-syntax in-list
(syntax-rules ()
((_ ((var) source) next . rest)
(in-list ((var cursor) source) next . rest))
((_ ((var cursor) source) next . rest)
(in-list ((var cursor succ) source) next . rest))
((_ ((var cursor succ) (source)) next . rest)
(in-list ((var cursor succ) (source cdr)) next . rest))
((_ ((var cursor succ) (source step)) next . rest)
(next
;; outer let bindings, bound outside the loop, unchanged during the loop
()
;; accumulators. These are the same as the bindings below, but values are
;; kept through subloops.
()
;; iterator, init, step
((cursor source succ))
;; tests to check whether the iterator is exhausted.
((not (pair? cursor)))
;; loop variables (called refs) and updates.
((var (car cursor))
(succ (step cursor)))
;; final bindings: things bound in the final function.
()
;; the continuation.
. rest))))
(define-syntax in-lists
(syntax-rules ()
((in-lists ((elts) lol) next . rest)
(in-lists ((elts pairs) lol) next . rest))
((in-lists ((elts pairs) lol) next . rest)
(in-lists ((elts pairs succ) lol) next . rest))
((in-lists ((elts pairs succ) (lol)) next . rest)
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
((in-lists ((elts pairs succ) (lol)) next . rest)
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
((in-lists ((elts pairs succ) (lol step)) next . rest)
(in-lists ((elts pairs succ) (lol step null?)) next . rest))
((in-lists ((elts pairs succ) (lol step done?)) next . rest)
(next ()
()
((pairs lol succ))
((let lp ((ls pairs)) ; an in-lined ANY
(and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
((elts (map car pairs))
(succ (map step pairs)))
()
. rest))
))
(define-syntax define-in-indexed
(syntax-rules ()
((define-in-indexed in-type in-type-reverse length ref)
(begin
(define-syntax in-type
(syntax-rules ()
((in-type seq next . rest)
(%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
(define-syntax in-type-reverse
(syntax-rules ()
((in-type-reverse seq next . rest)
(%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
))))
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
(define-in-indexed in-string in-string-reverse string-length string-ref)
;; helper for the above string and vector iterators
(define-syntax %in-idx
(syntax-rules ()
;; cmp inc start end ref
((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
(%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
(%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
(%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
(next ((tmp seq) (end to))
()
((index from (+ tmp index)))
((ge index end))
((var (r tmp index)))
()
. rest))
))
;;> \macro{(for ch (in-port [input-port [reader [eof?]]]))}
(define-syntax in-port
(syntax-rules ()
((in-port ((var) source) next . rest)
(in-port ((var p) source) next . rest))
((in-port ((var p) ()) next . rest)
(in-port ((var p) ((current-input-port))) next . rest))
((in-port ((var p) (port)) next . rest)
(in-port ((var p) (port read-char)) next . rest))
((in-port ((var p) (port read-char)) next . rest)
(in-port ((var p) (port read-char eof-object?)) next . rest))
((in-port ((var p) (port reader eof?)) next . rest)
(next ((p port) (r reader) (e? eof?))
()
((var (r p) (r p)))
((e? var))
()
()
. rest))))
;;> \macro{(for ch (in-file [input-port [reader [eof?]]]))}
(define-syntax in-file
(syntax-rules ()
((in-file ((var) source) next . rest)
(in-file ((var p) source) next . rest))
((in-file ((var p) (file)) next . rest)
(in-file ((var p) (file read-char)) next . rest))
((in-file ((var p) (file reader)) next . rest)
(in-file ((var p) (file reader eof-object?)) next . rest))
((in-file ((var p) (file reader eof?)) next . rest)
(next ((p (open-input-file file)) (r reader) (e? eof?))
()
((var (r p) (r p)))
((e? var))
()
((dummy (close-input-port p)))
. rest))))
(define-syntax in-generator
(syntax-rules ()
((_ ((var) (source)) next . rest)
(next ((gen source))
()
((var (gen) (gen)))
((eof-object? var))
()
()
. rest))))
;;> \macro{(for x (up-from [start] [(to limit)] [(by step)]))}
(define-syntax up-from
(syntax-rules (to by)
((up-from (() . args) next . rest)
(up-from ((var) . args) next . rest))
((up-from ((var) (start (to limit) (by step))) next . rest)
(next ((s start) (l limit) (e step))
()
((var s (+ var e)))
((>= var l))
()
()
. rest))
((up-from ((var) (start (to limit))) next . rest)
(next ((s start) (l limit))
()
((var s (+ var 1)))
((>= var l))
()
()
. rest))
((up-from ((var) (start (by step))) next . rest)
(next ((s start) (e step))
()
((var s (+ var e)))
()
()
()
. rest))
((up-from ((var) (start)) next . rest)
(next ((s start))
()
((var s (+ var 1)))
()
()
()
. rest))
))
;;> \macro{(for x (down-from [start] [(to limit)] [(by step)]))}
(define-syntax down-from
(syntax-rules (to by)
((down-from (() . args) next . rest)
(down-from ((var) . args) next . rest))
((down-from ((var) (start (to limit) (by step))) next . rest)
(next ((s start) (l limit) (e step))
()
((var (- s e) (- var e)))
((< var l))
()
()
. rest))
((down-from ((var) (start (to limit))) next . rest)
(next ((s start) (l limit))
()
((var (- s 1) (- var 1)))
((< var l))
()
()
. rest))
((down-from ((var) (start (by step))) next . rest)
(next ((s start) (e step))
()
((var (- s e) (- var e)))
()
()
()
. rest))
((down-from ((var) (start)) next . rest)
(next ((s start))
()
((var (- s 1) (- var 1)))
()
()
()
. rest))
))
(define-syntax accumulating
(syntax-rules (initial if)
((accumulating (kons final init) ((var) . x) next . rest)
(accumulating (kons final init) ((var cursor) . x) next . rest))
((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
(accumulating (kons final i) ((var cursor) x) n . rest))
((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
(n ((tmp-kons kons))
((cursor '() (if check (tmp-kons expr cursor) cursor)))
()
()
()
((var (final cursor)))
. rest))
((accumulating (kons final init) ((var cursor) (expr)) n . rest)
(n ((tmp-kons kons))
((cursor '() (tmp-kons expr cursor)))
()
()
()
((var (final cursor)))
. rest))))
;;> \macro{(for x [pair] (listing expr))}
(define-syntax listing
(syntax-rules ()
((listing args next . rest)
(accumulating (cons reverse '()) args next . rest))))
;;> \macro{(for x [pair] (listing-reverse expr))}
(define-syntax listing-reverse
(syntax-rules ()
((listing-reverse args next . rest)
(accumulating (cons (lambda (x) x) '()) args next . rest))))
(define (append-reverse rev tail)
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
;;> \macro{(for x [pair] (appending expr))}
(define-syntax appending
(syntax-rules ()
((appending args next . rest)
(accumulating (append-reverse reverse '()) args next . rest))))
;;> \macro{(for x [pair] (appending-reverse expr))}
(define-syntax appending-reverse
(syntax-rules ()
((appending-reverse args next . rest)
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
;;> \macro{(for x (summing expr))}
(define-syntax summing
(syntax-rules ()
((summing args next . rest)
(accumulating (+ (lambda (x) x) 0) args next . rest))))
;;> \macro{(for x (multiplying expr))}
(define-syntax multiplying
(syntax-rules ()
((multiplying args next . rest)
(accumulating (* (lambda (x) x) 1) args next . rest))))