Modularized the code

Everything in goof-impl.scm is portable (r7rs) syntax-rules. The non-portable parts
, most notably the let-kw-form macro is in the module definition goof.scm.

goof-impl.scm

@@ -0,0 +1,534 @@
+;; 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 :let :let* :subloop :for :acc
+  ;; Auxiliary syntax for the iterators.
+  :gen
+  ;; auxiliary auxiliary syntax
+  ;; for vectoring
+  :length :fill 
+  ;; 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
+  )
+
+
+(include "goof/iterators.scm")
+
+
+
+(define-syntax loop
+  (syntax-rules (=>)
+    ((loop () => expr body ...)
+     (loop ((:for ensure-once (up-from 0 1))) => expr body ...))
+    ((loop () body ...)
+     (loop ((:for ensure-once (up-from 0 1))) body ...))
+    ((loop name () => expr body ...)
+     (loop name ((:for ensure-once (up-from 0 1))) => expr body ...))
+    ((loop name () body ...)
+     (loop name ((:for ensure-once (up-from 0 1))) body ...))
+    ((loop (clauses ...)  body ...)
+     (ensure-for-clause (loop (clauses ...) body ...)
+                        loop-name (clauses ...)
+                        body ... (loop-name)))
+    ((loop name (clauses ...) . body)
+     (ensure-for-clause (loop name (clauses ...) . body)
+                        name
+                        (clauses ...)
+                        . body))))
+
+;; Should this check for more?
+(define-syntax ensure-for-clause
+  (syntax-rules (:for :acc :break :subloop :when :unless :final :let :let*)
+    ((_ orig name ((:for for-rest ...) clauses ...) . body)
+     (cl orig name
+         (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
+         ((:for for-rest ...) clauses ...) . body))
+    ((_ orig rest ...)
+     (syntax-error "First clause must be a :for clause" orig))))
+     
+
+(define-syntax push-new-subloop
+  (syntax-rules ()
+    ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
+        (ul ...) (uw ...) (ub ...) uf 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)
+         (() ul ...)
+         (() uw ...)
+         (() ub ...)
+         uf
+         clauses . body))))
+
+
+;; Clauses sorts all the clauses into subloops and positions everything where it should be.
+(define-syntax cl
+  (syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop)
+    ((_ orig name l a v c r f ff ul uw ub uf () => expr . body)
+     (emit orig name l a v c r f ff ul uw ub uf expr . body))
+    ((_ orig name l a v c r f ff ul uw ub uf () . body)
+     (emit orig name l a v c r f ff ul uw ub uf (if #f #f) . body))
+
+    ;; USER LETS
+    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let (id id* ... expr) clauses ...) . body)
+     (cl orig name l a v c r f ff ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
+    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let* (id id* ... expr) clauses ...) . body)
+     (cl orig name l a v c r f ff ((cur-ul ... (:let* id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
+    ;; user-whens
+    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:when test clauses ...) . body)
+     (cl orig name l a v c r f ff ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body))
+    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:unless test clauses ...) . body)
+     (cl orig name l a v c r f ff ul ((cur-uw ... (not test)) . uw-rest) ub uf (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 ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) uf (:break expr clauses ...) . body)
+     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
+    ;; user final
+    ;; 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 ul ((cur-uw ...) . uw-rest) ub (cur-uf ...) (:final expr clauses ...) . body)
+     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
+    
+    ;; Explicit subloop. Shorthand for (:when #t)
+    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:subloop clauses ...) . body)
+     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub uf  (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 ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body)
+     (push-new-subloop orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body))
+
+    ;; For clause with a sequence creator.
+    ((_ orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body)
+     (iterator ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body))
+
+    ;; accumulator clause
+    ((_ orig name l a v c r f ff ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
+     (accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body))
+
+    ;; ERROR HANDLING?
+    ((_ orig name l a v c r f ff ul uw ub uf (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 ul uw ub uf clauses . body)
+      (cl orig name
+          ((lets ... new-lets ...))
+          ((accs ... (accvar accinit accupdate) ...))
+          vars
+          ((checks ... new-checks ...))
+          ((refs ... new-refs ...))
+          (finals ... new-finals ...)
+          ff ul uw ub uf 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 ...) . checks-rest)
+        ((refs ...) . refs-rest)
+        (finals ...)
+        ff ul uw ub uf clauses . body)
+      (cl orig name
+          (lets ... (outermost-lets ... new-lets ...))
+          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
+          vars
+          ((checks ... new-checks ...) . checks-rest)
+          ((refs ... new-refs ...) . refs-rest)
+          (finals ... new-finals ...)
+          ff ul uw ub uf 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 ...) . checks-rest)
+        ((refs ...) . refs-rest)
+        (finals ...)
+        ff ul uw ub uf clauses . body)
+     (cl orig name
+          (lets ... (outermost-lets ... new-lets ...))
+          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
+           ((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
+          vars
+          ((checks ... new-checks ...) . checks-rest)
+          ((refs ... new-refs ...) . refs-rest)
+          (finals ... new-finals ...)
+          ff ul uw ub uf 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)
+        ul uw ub uf 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)
+         ul uw ub uf clauses . body))
+    ((cl err ...)
+     '(cl err ...))))
+
+(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) ...)
+        (((ff-cur ...) (ff-above ...)))
+        ((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf
+        final-expr . body)
+     (let* (lets ...)
+       (define (final-fun final-binding ...)
+         final-expr)
+       (define (loopy-loop accvar ... var ...)
+         (if (or checks ...)
+             (begin
+               ff-cur ...
+               (final-fun final-value ...))
+             (ref-let (refs ...)
+               (user-let () () (user-lets ...)
+                 (if (and user-whens ...)
+                     (let-kw-form name
+                                  (final-fun final-value ...)
+                                  uf
+                                  (loopy-loop (accvar accstep) ... (var step) ...)
+                       (cond
+                        ((or user-breaks ...)
+                         ff-above ... ff-cur ...
+                         (final-fun final-value ...))
+                        (else
+                         (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) ...)
+        (ff-next ... ((ff-cur ...) ()))
+        (ul-next ... (user-lets ...))
+        (uw-next ... (user-whens ...))
+        (ub-next ... (user-breaks ...))
+        uf
+        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-let () () (user-lets ...)
+                 (if (and user-whens ...)
+                     (cond
+                      ((or user-breaks ...)
+                       ff-cur ...
+                       (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 ...)
+                                             (ff-next ...)
+                                             (ul-next ...)
+                                             (uw-next ...)
+                                             (ub-next ...)
+                                             uf
+                                             . body)))
+                     (outer-loop accvar ... step ...))))))))))
+
+(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 ...)))
+        ((user-lets ...))
+        ((user-whens ...))
+        ((user-breaks ...))
+        uf
+        . body)
+     (let* (lets ...)
+       (let innermost-loop ((accvar accinit) ...
+                            (var init) ...)
+         (if (or checks ...)
+             (begin
+               ff-cur ...
+               outer)
+             (ref-let (refs ...)
+               (user-let () () (user-lets ...)
+                 (if (and user-whens ...)         
+                     (cond
+                      ((or user-breaks ...)
+                       ff-above ... ff-cur ...
+                       final)
+                      (else
+                       (let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
+                         . body)))
+                     (innermost-loop accvar ... step ...))))))))
+
+    ;; 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 ...)))
+        (ul-next ... (user-lets ...))
+        (uw-next ... (user-whens ...))
+        (ub-next ... (user-breaks ...))
+        uf
+        . body)
+     (let* (lets ...)
+       (let intermediate-loop ((accvar accinit) ...
+                               (var init) ...)
+         (if (or checks ...)
+             (begin
+               ff-cur ...
+               outer)
+             (ref-let (refs ...)
+               (user-let () () (user-lets ...)
+                 (if (and user-whens ...)
+                     (cond
+                      ((or user-breaks ...)
+                       ff-above ... ff-cur ...
+                       final)
+                      (else (emit-many/rest orig
+                                            name
+                                            (intermediate-loop accstep ... step ...)
+                                            (next-lets ...)
+                                            (next-accs ...)
+                                            (next-vars ...)
+                                            (next-checks ...)
+                                            (next-refs ...)
+                                            final
+                                            (next-ff ...)
+                                            (ul-next ...)
+                                            (uw-next ...)
+                                            (ub-next ...)
+                                            uf
+                                            . body)))
+                     (intermediate-loop accvar ... step ...))))))))))
+
+
+(define-syntax forify
+  (syntax-rules (:for :acc :when :unless :break :final :subloop :let :let* %acc)
+    ((forify o n done-clauses () . body)
+     (cl 1 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 ... :when 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 ...) (:subloop clauses ...) . body)
+     (forify o n (s ... :subloop) (clauses ...) . body))
+    ((_      o n (s ...) ((:let id id* ... expr) clauses ...) . body)
+     (forify o n (s ... (:let id id* ... expr)) (clauses ...) . body))
+    ((_      o n (s ...) ((:let* id id* ... expr) clauses ...) . body)
+     (forify o n (s ... (:let* id id* ... expr)) (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))))))

goof.scm

@@ -1,8 +1,6 @@
 ;; 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.
+;; Copyright 2020, 2021 Linus Björnstam
 ;;
 ;; Redistribution and use in source and binary forms, with or without
 ;; modification, are permitted provided that the following conditions
@@ -26,7 +24,6 @@
 ;; (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
@@ -82,417 +79,8 @@
             in-indexed
             ))
 
-(define-aux-syntaxes
-  ;; Auxiliary syntax for the loop clauses
-  :when :unless :break :final :let :let* :subloop :for :acc
-  ;; Auxiliary syntax for the iterators.
-  :gen
-  ;; auxiliary auxiliary syntax
-  ;; for vectoring
-  :length :fill 
-  ;; 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
-  )
-
-
-(include "goof/iterators.scm")
-
-
-
-(define-syntax loop
-  (syntax-rules (=>)
-    ((loop () => expr body ...)
-     (loop ((:for ensure-once (up-from 0 1))) => expr body ...))
-    ((loop () body ...)
-     (loop ((:for ensure-once (up-from 0 1))) body ...))
-    ((loop name () => expr body ...)
-     (loop name ((:for ensure-once (up-from 0 1))) => expr body ...))
-    ((loop name () body ...)
-     (loop name ((:for ensure-once (up-from 0 1))) body ...))
-    ((loop (clauses ...)  body ...)
-     (ensure-for-clause (loop (clauses ...) body ...)
-                        loop-name (clauses ...)
-                        body ... (loop-name)))
-    ((loop name (clauses ...) . body)
-     (ensure-for-clause (loop name (clauses ...) . body)
-                        name
-                        (clauses ...)
-                        . body))))
-
-;; Should this check for more?
-(define-syntax ensure-for-clause
-  (syntax-rules (:for :acc :break :subloop :when :unless :final :let :let*)
-    ((_ orig name ((:for for-rest ...) clauses ...) . body)
-     (cl orig name
-         (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
-         ((:for for-rest ...) clauses ...) . body))
-    ((_ orig rest ...)
-     (syntax-error "First clause must be a :for clause" orig))))
-     
-
-(define-syntax push-new-subloop
-  (syntax-rules ()
-    ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
-        (ul ...) (uw ...) (ub ...) uf 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)
-         (() ul ...)
-         (() uw ...)
-         (() ub ...)
-         uf
-         clauses . body))))
-
-
-;; Clauses sorts all the clauses into subloops and positions everything where it should be.
-(define-syntax cl
-  (syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop)
-    ((_ orig name l a v c r f ff ul uw ub uf () => expr . body)
-     (emit orig name l a v c r f ff ul uw ub uf expr . body))
-    ((_ orig name l a v c r f ff ul uw ub uf () . body)
-     (emit orig name l a v c r f ff ul uw ub uf (if #f #f) . body))
-
-    ;; USER LETS
-    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let (id id* ... expr) clauses ...) . body)
-     (cl orig name l a v c r f ff ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
-    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let* (id id* ... expr) clauses ...) . body)
-     (cl orig name l a v c r f ff ((cur-ul ... (:let* id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
-    ;; user-whens
-    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:when test clauses ...) . body)
-     (cl orig name l a v c r f ff ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body))
-    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:unless test clauses ...) . body)
-     (cl orig name l a v c r f ff ul ((cur-uw ... (not test)) . uw-rest) ub uf (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 ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) uf (:break expr clauses ...) . body)
-     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
-    ;; user final
-    ;; 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 ul ((cur-uw ...) . uw-rest) ub (cur-uf ...) (:final expr clauses ...) . body)
-     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
-    
-    ;; Explicit subloop. Shorthand for (:when #t)
-    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:subloop clauses ...) . body)
-     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub uf  (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 ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body)
-     (push-new-subloop orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body))
-
-    ;; For clause with a sequence creator.
-    ((_ orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body)
-     (iterator ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body))
-
-    ;; accumulator clause
-    ((_ orig name l a v c r f ff ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
-     (accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body))
-
-    ;; ERROR HANDLING?
-    ((_ orig name l a v c r f ff ul uw ub uf (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 ul uw ub uf clauses . body)
-      (cl orig name
-          ((lets ... new-lets ...))
-          ((accs ... (accvar accinit accupdate) ...))
-          vars
-          ((checks ... new-checks ...))
-          ((refs ... new-refs ...))
-          (finals ... new-finals ...)
-          ff ul uw ub uf 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 ...) . checks-rest)
-        ((refs ...) . refs-rest)
-        (finals ...)
-        ff ul uw ub uf clauses . body)
-      (cl orig name
-          (lets ... (outermost-lets ... new-lets ...))
-          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
-          vars
-          ((checks ... new-checks ...) . checks-rest)
-          ((refs ... new-refs ...) . refs-rest)
-          (finals ... new-finals ...)
-          ff ul uw ub uf 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 ...) . checks-rest)
-        ((refs ...) . refs-rest)
-        (finals ...)
-        ff ul uw ub uf clauses . body)
-     (cl orig name
-          (lets ... (outermost-lets ... new-lets ...))
-          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
-           ((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
-          vars
-          ((checks ... new-checks ...) . checks-rest)
-          ((refs ... new-refs ...) . refs-rest)
-          (finals ... new-finals ...)
-          ff ul uw ub uf 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)
-        ul uw ub uf 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)
-         ul uw ub uf clauses . body))
-    ((cl err ...)
-     '(cl err ...))))
-
-(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) ...)
-        (((ff-cur ...) (ff-above ...)))
-        ((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf
-        final-expr . body)
-     (let* (lets ...)
-       (define (final-fun final-binding ...)
-         final-expr)
-       (define (loopy-loop accvar ... var ...)
-         (if (or checks ...)
-             (begin
-               ff-cur ...
-               (final-fun final-value ...))
-             (ref-let (refs ...)
-               (user-let () () (user-lets ...)
-                 (if (and user-whens ...)
-                     (let-kw-form name
-                                  (final-fun final-value ...)
-                                  uf
-                                  (loopy-loop (accvar accstep) ... (var step) ...)
-                       (cond
-                        ((or user-breaks ...)
-                         ff-above ... ff-cur ...
-                         (final-fun final-value ...))
-                        (else
-                         (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) ...)
-        (ff-next ... ((ff-cur ...) ()))
-        (ul-next ... (user-lets ...))
-        (uw-next ... (user-whens ...))
-        (ub-next ... (user-breaks ...))
-        uf
-        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-let () () (user-lets ...)
-                 (if (and user-whens ...)
-                     (cond
-                      ((or user-breaks ...)
-                       ff-cur ...
-                       (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 ...)
-                                             (ff-next ...)
-                                             (ul-next ...)
-                                             (uw-next ...)
-                                             (ub-next ...)
-                                             uf
-                                             . body)))
-                     (outer-loop accvar ... step ...))))))))))
-
-(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 ...)))
-        ((user-lets ...))
-        ((user-whens ...))
-        ((user-breaks ...))
-        uf
-        . body)
-     (let* (lets ...)
-       (let innermost-loop ((accvar accinit) ...
-                            (var init) ...)
-         (if (or checks ...)
-             (begin
-               ff-cur ...
-               outer)
-             (ref-let (refs ...)
-               (user-let () () (user-lets ...)
-                 (if (and user-whens ...)         
-                     (cond
-                      ((or user-breaks ...)
-                       ff-above ... ff-cur ...
-                       final)
-                      (else
-                       (let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
-                         . body)))
-                     (innermost-loop accvar ... step ...))))))))
-
-    ;; 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 ...)))
-        (ul-next ... (user-lets ...))
-        (uw-next ... (user-whens ...))
-        (ub-next ... (user-breaks ...))
-        uf
-        . body)
-     (let* (lets ...)
-       (let intermediate-loop ((accvar accinit) ...
-                               (var init) ...)
-         (if (or checks ...)
-             (begin
-               ff-cur ...
-               outer)
-             (ref-let (refs ...)
-               (user-let () () (user-lets ...)
-                 (if (and user-whens ...)
-                     (cond
-                      ((or user-breaks ...)
-                       ff-above ... ff-cur ...
-                       final)
-                      (else (emit-many/rest orig
-                                            name
-                                            (intermediate-loop accstep ... step ...)
-                                            (next-lets ...)
-                                            (next-accs ...)
-                                            (next-vars ...)
-                                            (next-checks ...)
-                                            (next-refs ...)
-                                            final
-                                            (next-ff ...)
-                                            (ul-next ...)
-                                            (uw-next ...)
-                                            (ub-next ...)
-                                            uf
-                                            . body)))
-                     (intermediate-loop accvar ... step ...))))))))))
-             
-
+;; This contains the portable parts of goof-loop.
+(include "goof-impl.scm")
 
 ;; Helper procedures for let-kw-form
 (define (syntax= s1 s2)
@@ -506,9 +94,6 @@
    (else
     (cons (car params) (update-name (cdr params) name val)))))
 
-(define (syntax->list stx)
-  (syntax-case stx ()
-    ((a ...) #'(a ...))))
 
 (define-syntax inner-recur
   (syntax-rules ()
@@ -519,7 +104,12 @@
        (if (or user-finals ...)
            final-fun
            (loop-name v ...))))))
-         
+
+     
+(define (syntax->list stx)
+  (syntax-case stx ()
+    ((a ...) #'(a ...))))
+
 
 (define-syntax let-kw-form
   (syntax-rules ()
@@ -542,101 +132,6 @@
 
 
 
-(define-syntax forify
-  (syntax-rules (:for :acc :when :unless :break :final :subloop :let :let* %acc)
-    ((forify o n done-clauses () . body)
-     (cl 1 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 ... :when 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 ...) (:subloop clauses ...) . body)
-     (forify o n (s ... :subloop) (clauses ...) . body))
-    ((_      o n (s ...) ((:let id id* ... expr) clauses ...) . body)
-     (forify o n (s ... (:let id id* ... expr)) (clauses ...) . body))
-    ((_      o n (s ...) ((:let* id id* ... expr) clauses ...) . body)
-     (forify o n (s ... (:let* id id* ... expr)) (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))))))
-
 (define-syntax loop/list/parallel
   (syntax-rules ()
     ((n (clauses ...) body ...)
@@ -647,6 +142,3 @@
                 (:acc futures2 (listing-reverse (touch future))))
                => futures2)
       (parallel-list-loop)))))
-
-
-