From c53a08c7693da6e1326ed07ff21fe166e8afa09e Mon Sep 17 00:00:00 2001
From: Linus <bjornstam.linus@fastmail.se>
Date: Tue, 1 Dec 2020 20:53:25 +0100
Subject: [PATCH] Made simple loops better. Now with correct syntax
 proliferation.w

---
 goof.scm | 149 +++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 101 insertions(+), 48 deletions(-)

diff --git a/goof.scm b/goof.scm
index caa8877..4838f3d 100644
--- a/goof.scm
+++ b/goof.scm
@@ -32,6 +32,7 @@
 ;; name, and the fact that I goofed in the chibi issue tracker when
 ;; trying to understand the iterator protocol.
 
+;; TODO add :let and :let* to forify
 
 (use-modules (helpers)
              ((srfi srfi-1) #:select (circular-list))
@@ -43,7 +44,12 @@
   ;; Auxiliary syntax for the loop clauses
   :when :unless :break :final :let :let* :subloop :for :acc
   ;; Auxiliary syntax for the iterators.
-  :gen)
+  :gen
+  ;; 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 "iterators.scm")
@@ -61,17 +67,25 @@
     ((loop name () body ...)
      (if #f #f))
     ((loop (clauses ...)  body ...)
-     (cl (loop (clauses ...) body ...)
-         loop-name
-         (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
-         (clauses ...)
-         body ... (loop-name)))
+     (ensure-for-clause (loop (clauses ...) body ...)
+                        loop-name (clauses ...)
+                        body ... (loop-name)))
     ((loop name (clauses ...) . body)
-     (cl (loop name (clauses ...) . body)
-         name
+     (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
          (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
-         (clauses ...)
-         . body))))
+         ((:for for-rest ...) clauses ...) . body))
+    ((_ orig rest ...)
+     (syntax-error "First clause must be a :for clause" orig))))
+     
 
 (define-syntax push-new-subloop
   (syntax-rules ()
@@ -114,11 +128,11 @@
     ;; 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))
+     (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))
+     (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)
@@ -136,13 +150,9 @@
     ((_ 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))
 
-    ;; no :acc or :for: imlplicit for!
-    ((_ orig name l a v c r f ff ul uw ub uf ((id ids ... (iterator source ...)) clauses ...) . body)
-     (cl orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) 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))
+     (syntax-error "Invalid clause in loop" clause orig))
 
     ))
 
@@ -474,67 +484,110 @@
                                 (loop (cdr lst) (update-name params #'name #'val)))
                                (_ (error "Malformed looping clause in macro")))))))))
        . body))))
-                       
-                       
+
+
+
+(define-syntax forify
+  (syntax-rules (:for :acc :when :unless :break :final :subloop %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 ...) ((%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 ...)
-     (loop loop-name (clauses ...)
+     (forify (loop/list (clauses ...) body ...)
+             loop-name () (clauses ...)
        => '()
        (cons (let () body ...) (loop-name))))))
 
 (define-syntax loop/sum
   (syntax-rules ()
     ((_ (clauses ...) body ...)
-     (loop (clauses ... (:acc acc (summing (let () body ...)))) => acc))))
+     (forify (loop-sum (clauses ...) body ...)
+             loop-name
+             () (clauses ... (%acc acc (summing (let () body ...))))
+       => acc
+       (loop-name)))))
 
 (define-syntax loop/product
   (syntax-rules ()
-    ((_ (clauses ...) body ...)
-     (loop (clauses ... (:acc acc (multiplying (let () body ...)))) => acc))))
+    ((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 ()
-    ((_ (clauses ...) body ...)
-     (loop loop-name (clauses ... (:acc acc (folding sentinel)) :break (not (eq? sentinel acc)))
-           => (if (eq? sentinel acc) #f acc)
-           (let ((result (let () body ...)))
-             (loop-name (=> acc result)))))))
+    ((n (clauses ...) body ...)
+     (forify (n (clauses ...) body ...)
+             loop/first
+             () (clauses ... :final #t)
+             => #f
+             body ...))))
+
 
 (define-syntax loop/last
   (syntax-rules ()
-    ((_ (clauses ...) body ...)
-     (loop loop-name (clauses ... (:acc acc (folding sentinel))) => (if (eq? sentinel acc) #f acc)
-           (let ((result (let () body ...)))
-             (loop-name (=> acc result)))))))
+    ((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 ()
-    ((_ (clauses ...) body ...)
-     (loop loop-name (clauses ... (:acc acc (folding #t)))
-           => acc
-           (let ((res (let () body ...)))
-             (if res
-                 (loop-name (=> acc res))
-                 #f))))))
+    ((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 ()
-    ((_ (clauses ...) body ...)
-     (loop loop-name (clauses ...)
-           => #f
-           (or (let () body ...) (loop-name))))))
+    ((n (clauses ...) body ...)
+     (forify (n (clauses ...) body ...)
+             or-loop
+             () (clauses ...)
+       => #f
+       (or (let () body ...) (or-loop))))))
 
 (define-syntax loop/list/parallel
   (syntax-rules ()
-    ((_ (clauses ...) body ...)
-     (loop (clauses ... (:acc futures (listing-reverse (future (let () body ...)))))
-       => (loop ((:for future (in-list futures))
-                 (:acc futures2 (listing-reverse (touch future))))
-            => futures2)))))
+    ((n (clauses ...) body ...)
+     (forify (n (clauses ...) body ...)
+             parallel-list-loop
+             () (clauses ... (%acc futures (listing-reverse (future (let () body ...)))))
+      => (loop ((:for future (in-list futures))
+                (:acc futures2 (listing-reverse (touch future))))
+               => futures2)
+      (parallel-list-loop)))))