From 2c182da57048706d24880470dd315b9fd589b644 Mon Sep 17 00:00:00 2001
From: Linus <bjornstam.linus@fastmail.se>
Date: Mon, 9 Nov 2020 13:30:02 +0100
Subject: [PATCH] Racketifying goof-loop

I have racketified goof loops. No :for or :acc needed, and :when, :unless, and :break are no longer parethesised.
:acc blah (in ...) and :for blah (in ...) has been changed to
(blah (folding ...)) and (blah (in ...))
---
 goof.scm      | 87 +++++++++++++++++-------------------------------
 iterators.scm | 91 ++++++++++++++++++++++++++++++---------------------
 tests.scm     | 36 ++++++++++----------
 3 files changed, 101 insertions(+), 113 deletions(-)

diff --git a/goof.scm b/goof.scm
index 769677d..673137d 100644
--- a/goof.scm
+++ b/goof.scm
@@ -31,30 +31,22 @@
 ;; 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.
-;;
-;;   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 an accumulator clause.
-;;    * Positional update is not supported. It seems error-prone once you start
-;;      having a lot of loop variables, and because goof-loop does some re-ordering
-;;      that foof loop does not. For example:
-;;        (:for a (in 0 (+ a 1))) (:acc acc (in '() (cons a acc)))
-;;      are actually reordered in a loop, because accumulators and for loops are separated
-;;      due to having to propagate the accumulators through the loop.
+
 
 
 (use-modules (helpers)
              (srfi srfi-71))
 
+(define-aux-syntaxes
+  ;; Auxiliary syntax for the loop clauses
+  :when :unless :break :final :let :let* :subloop
+  ;; Auxiliary syntax for the iterators.
+  :gen)
+
+
 (include "iterators.scm")
 
-(define-aux-syntaxes :for :when :unless :break :final :let :let* :acc :subloop)
+
 
 (define-syntax loop
   (syntax-rules ()
@@ -89,61 +81,43 @@
 
 ;; 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)
+  (syntax-rules (=> in :when :unless :break :final :let :let* :subloop)
     ((_ 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))
-    ;; Accumulator clause with a proper accumulator.
-    ((_ orig name l a v c r f ul uw ub ((:acc 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))
 
     ;; user-whens
-    ((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub ((:when test) clauses ...) . body)
+    ((_ 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)
+    ((_ 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)
+    ((_ 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)
+    ((_ 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)
+    ((_ 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))
+
+
+    
+    ;; :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-rest ...) clauses ...) . body)
+     (push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((for-rest ...) clauses ...) . body))
+
+    ;; For clause with a sequence creator.
+    ((_ orig name l a v c r f ul uw ub ((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))
+
+
     
     ;; ERROR HANDLING?
     ((_ orig name l a v c r f ul uw ub (clause . rest) . body)
@@ -208,9 +182,8 @@
           ((checks ... new-checks ...) . checks-rest)
           ((refs ... new-refs ...) . refs-rest)
           (finals ... new-finals ...)
-          ul uw ub clauses . body))))
-        
-
+          ul uw ub clauses . body))
+    ))
 
 (define-syntax user-let
   (syntax-rules (:let :let*)
diff --git a/iterators.scm b/iterators.scm
index 1a4329e..786197c 100644
--- a/iterators.scm
+++ b/iterators.scm
@@ -37,6 +37,15 @@
 ;; hashqing
 ;; hashving
 
+(define-syntax in
+  (syntax-rules () 
+  ((_ ((var) (init)) n . rest)
+   (n () () ((var init var)) () () () . rest))
+  ((_ ((var) (init step)) n . rest)
+   (n () () ((var init step)) () () () . rest))
+  ((_ ((var) (init step stop)) n . rest)
+   (n () () ((var init step)) (stop) () () . rest))))
+
 (define-syntax in-list
   (syntax-rules ()
     ((_ ((var) source) next . rest)
@@ -150,24 +159,26 @@
            ()
            . rest))))
 
-;;> \macro{(for ch (in-file [input-port [reader [eof?]]]))}
+;; ;;> \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 (clo
+           ;;          se-input-port p)))
+           ;; . rest))))
 
-(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 ()
@@ -187,29 +198,15 @@
     ((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))
+     (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))
-           ()
+     (next ((s start) (l limit))()
            ((var s (+ var 1)))
-           ((>= var l))
-           ()
-           ()
-           . rest))
+           ((>= var l)) () () . rest))
     ((up-from ((var) (start (by step))) next . rest)
-     (next ((s start) (e step))
-           ()
-           ((var s (+ var e)))
-           ()
-           ()
-           ()
-           . rest))
+     (next ((s start) (e step))()
+           ((var s (+ var e))) () () () . rest))
     ((up-from ((var) (start)) next . rest)
      (next ((s start))
            ()
@@ -218,7 +215,11 @@
            ()
            ()
            . rest))
-    ))
+    ;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
+    ((up-from ((var) (start limit step)) next . rest)
+     (next ((s start) (l limit) (e step)) () ((var s (+ var e))) ((>= var l)) () () . rest))
+    ((up-from ((var) (start limit)) next . rest)
+     (up-from ((var) (start limit 1)) next . rest))))
 
 ;;> \macro{(for x (down-from [start] [(to limit)] [(by step)]))}
 
@@ -283,6 +284,20 @@
         ((var (final cursor)))
         . rest))))
 
+(define-syntax folding
+  (syntax-rules (if)
+    ((_ ((var) (init update (if guard))) n . rest)
+     (n ()
+        ((var init (if guard update var)))
+        () () ()
+        ((var var))
+        . rest))
+    ((_ ((var) (init update)) n . rest)
+     (folding ((var) (init update (if #t))) n . rest))
+    ((_ ((var) (init)) n . rest)
+     (folding ((var) (init var (if #t))) n . rest))))
+    
+
 ;;> \macro{(for x [pair] (listing expr))}
 
 (define-syntax listing
diff --git a/tests.scm b/tests.scm
index 8629257..ddb7447 100644
--- a/tests.scm
+++ b/tests.scm
@@ -1,25 +1,25 @@
 ;; This is just a file with things that should be written as a test. Dump file.
 
-(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)))
+(loop ((a (in-list '(((1) (2)) ((3) (4)) ((5) (6 7)))))
+       :when #t
+       (b (in-list a))
+       :subloop  
+       (c (in-list b))
+       (acc (listing c)))
   => acc)
 
 
-(loop ((:for a (in-list '((1 2) (3 4) (5 6))))
-       (:when #t)
-       (:for b (in-list a))
-       (:for acc (listing b)))
-  => acc)
-
-(loop ((:for a (in-list '(1 2 3)))
-       (:acc oa (summing a))
+(loop ((a (in-list '((1 2) (3 4) (5 6))))
        :subloop
-       (:for b (up-from a (to (+ a 2))))
-       (:acc ob (listing b)))
-  => (values oa ob))
-;; Should return 6 and (1 2 2 3 3 4
+       (b (in-list a))
+       (acc (listing b)))
+  => acc)
+
+(loop ((a (in-list '(1 2 3)))
+       (oa (summing a))
+       :subloop
+       (b (up-from a (to (+ a 2))))
+       (ob (listing b)))
+  => (values oa ob))
+;; Should return 6 and (1 2 2 3 3 4)