Fix the bugs in loop.

It works! Sometimes it emits nested loops!

2 files changed, 230 insertions, 44 deletions

diff --git a/csc/loop-test.csc b/csc/loop-test.csc
index df2c970..eb9345b 100644
--- a/csc/loop-test.csc
+++ b/csc/loop-test.csc
@@ -6,43 +6,43 @@
         (csc loop))
 
 
-(test for-collect
+(test loop-for-collect
   (assert-equal
     '(1 2 3 4 5)
     (loop for x in '(1 2 3 4 5)
           collect x)))
 
 
-(test for-collect-add
+(test loop-for-collect-add
   (assert-equal
     '(2 3 4 5 6)
     (loop for x in '(1 2 3 4 5)
           collect (+ 1 x))))
 
 
-(test for-arithmetic
+(test loop-for-arithmetic
   (assert-equal
     '(1 2 3 4 5)
     (loop for x from 1 to 5
           collect x)))
 
 
-(test for-arithmetic-step
+(test loop-for-arithmetic-step
   (assert-equal
     '(1 3 5 7 9)
     (loop for x from 1 to 10 by 2
           collect x)))
 
 
-(test finally-noop
+(test loop-finally-noop
   (assert-equal
     '(1 2 3)
     (loop for x from 1 to 3
-          finally #t
+          finally (if #f #f)
           collect x)))
 
 
-(test collect-into
+(test loop-collect-into
   (assert-equal
     '((1 2 3) (1 2 3) (1 2 3))
     (loop for x from 1 to 3
@@ -50,7 +50,7 @@
           collect l)))
 
 
-(test finally-set
+(test loop-finally-set
   (assert-equal
     '(1 2 3)
     (let ((res #f))
@@ -69,13 +69,13 @@
       res)))
 
 
-(test return
+(test loop-return
   (assert-equal
     '(1 2 3)
     (loop do (return '(1 2 3)))))
 
 
-(test finally-return
+(test loop-finally-return
   (assert-equal
     '(1 2 3)
     (loop for x from 1 to 3
@@ -83,7 +83,7 @@
           finally (return l))))
 
 
-(test for-as-equals-then
+(test loop-for-as-equals-then
   (assert-equal
     '((1 2 3) (2 3) (3))
     (loop for i from 1 to 3
@@ -91,7 +91,15 @@
           collect tail)))
 
 
-(test return-multiple-values
+(test loop-for-as-equals
+  (assert-equal
+    '((1) (2) (3))
+    (loop for i from 1 to 3
+          for j = (list i)
+          collect j)))
+
+
+(test loop-return-multiple-values
   (let-values (((x1 x2) (loop do (return (values 1 2)))))
     (assert-equal
       1
@@ -106,3 +114,140 @@
     '(1 2 3)
     (loop do (define x (loop do (return '(1 2 3))))
              (return x))))
+
+
+(test loop-with-return
+  (assert-equal
+    5
+    (loop with x = 5
+          return x)))
+
+
+(test loop-for-x-on-l
+  (assert-equal
+    '((1 2 3) (2 3) (3))
+    (loop for x on '(1 2 3)
+          collect x)))
+
+
+(test loop-for-across
+  (assert-equal
+    '(1 2 3)
+    (loop for x across #(1 2 3)
+          collect x)))
+
+
+(test loop-for-downfrom
+  (assert-equal
+    '(3 2 1)
+    (loop for x to 1 downfrom 3
+          collect x)))
+
+
+(test loop-for-to
+  (assert-equal
+    '(0 1 2 3)
+    (loop for x to 3
+          collect x)))
+
+
+(test loop-for-downto
+  (assert-equal
+    '(3 2 1)
+    (loop for x downto 1 from 3
+          collect x)))
+
+
+(test loop-for-below
+  (assert-equal
+    '(0 1 2)
+    (loop for x below 3
+          collect x)))
+
+
+(test loop-for-above
+  (assert-equal
+    '(3 2 1)
+    (loop for x above 0 from 3
+          collect x)))
+
+
+(test loop-for-by
+  (assert-equal
+    '(0 2 4)
+    (loop for x by 2 to 4
+          collect x)))
+
+
+(test loop-append
+  (assert-equal
+    '(1 2 3 4)
+    (loop for x in '((1 2) (3 4))
+          append x)))
+
+
+(test loop-count
+  (assert-equal
+    50
+    (loop for x from 1 to 100
+          count (even? x))))
+
+
+(test loop-sum
+  (assert-equal
+    15
+    (loop for x from 1 to 5
+          sum x)))
+
+
+(test loop-maximize
+  (assert-equal
+    10
+    (loop for x in '(3 10 1 4)
+          maximize x)))
+
+
+(test loop-minimize
+  (assert-equal
+    1
+    (loop for x in '(3 10 1 4)
+          minimize x)))
+
+
+(test loop-if
+  (assert-equal
+    5
+    (loop for x from 0
+          if (>= x 5) return x)))
+
+
+(test loop-when
+  (assert-equal
+    5
+    (loop for x from 0
+          when (>= x 5) return x)))
+
+
+(test loop-else
+  (assert-equal
+    '((0 2 4) . (1 3 5))
+    (loop for x to 5
+          if (even? x) collect x into evens
+          else collect x into odds
+          finally (return (cons evens odds)))))
+
+
+(test loop-if-compound
+  (assert-equal
+    '((0 2 4) . (1 3 5))
+    (loop for x to 5
+          if (even? x) collect x into list1
+          and collect (+ 1 x) into list2
+          finally (return (cons list1 list2)))))
+
+
+(test loop-if-end
+  (assert-equal
+    5
+    (loop for x from 0
+          if (>= x 5) return x end)))
diff --git a/csc/loop.csc b/csc/loop.csc
index 9c776ca..7f59f9e 100644
--- a/csc/loop.csc
+++ b/csc/loop.csc
@@ -1,5 +1,5 @@
 (define-library (csc loop)
-  (export loop return loop-aux)
+  (export loop return)
   (import (scheme base))
   (begin
 
@@ -72,9 +72,9 @@
           (let* ((x l)
                  (next x))
             (loop-aux "variable-clause-collector"
-                      ((body ... (unless (pair? x)
+                      ((body ... (set! x next)
+                                 (unless (pair? x)
                                    (raise (make-loop-termination)))
-                                 (set! x next)
                                  (set! next (cdr x)))
                        fin)
                       clause* ...)))
@@ -89,6 +89,12 @@
                                    (set! x subseq)))
                        fin)
                       clause* ...)))
+        ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init clause* ...)
+          (let ((x #f))
+            (loop-aux "variable-clause-collector"
+                      ((body ... (set! x init))
+                       fin)
+                      clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x across v clause* ...)
           (let ((temp v)
                 (i 0)
@@ -101,47 +107,55 @@
                        fin)
                       clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start to last by inc clause* ...)
-          (let ((x start)
-                (last* last)
-                (inc* inc))
+          (let* ((last* last)
+                 (inc* inc)
+                 (x start)
+                 (next x))
             (loop-aux "variable-clause-collector"
-                      ((body ... (unless (<= x last*)
+                      ((body ... (set! x next)
+                                 (unless (<= x last*)
                                    (raise (make-loop-termination)))
-                                 (set! x (+ x inc*)))
+                                 (set! next (+ x inc*)))
                        fin)
                       clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start downto last by inc clause* ...)
-          (let ((x start)
-                (last* last)
-                (inc* inc))
+          (let* ((last* last)
+                 (inc* inc)
+                 (x start)
+                 (next x))
             (loop-aux "variable-clause-collector"
-                      ((body ... (unless (>= x last*)
+                      ((body ... (set! x next)
+                                 (unless (>= x last*)
                                    (raise (make-loop-termination)))
-                                 (set! x (+ x inc*)))
+                                 (set! next (+ x inc*)))
                        fin)
                       clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start below last by inc clause* ...)
-          (let ((x start)
-                (last* last)
-                (inc* inc))
+          (let* ((last* last)
+                 (inc* inc)
+                 (x start)
+                 (next x))
             (loop-aux "variable-clause-collector"
-                      ((body ... (unless (< x last*)
+                      ((body ... (set! x next)
+                                 (unless (< x last*)
                                    (raise (make-loop-termination)))
-                                 (set! x (+ x inc*)))
+                                 (set! next (+ x inc*)))
                        fin)
                       clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start above last by inc clause* ...)
-          (let ((x start)
-                (last* last)
-                (inc* inc))
+          (let* ((last* last)
+                 (inc* inc)
+                 (x start)
+                 (next x))
             (loop-aux "variable-clause-collector"
-                      ((body ... (unless (> x last*)
+                      ((body ... (set! x next)
+                                 (unless (> x last*)
                                    (raise (make-loop-termination)))
-                                 (set! x (+ x inc)))
+                                 (set! next (+ x inc)))
                        fin)
                       clause* ...)))
         ((loop-aux "variable-clause-collector" args for x clause* ...)
-          (loop-aux "for-reordering" args for x #f #f #f 1 clause* ...))
+          (loop-aux "for-reordering" args for x #f #f #f #f clause* ...))
         ((loop-aux "variable-clause-collector" args clause* ...)
           (loop-aux "main-clause-collector" args clause* ...))
         ((loop-aux "and-collector" args (and-vars ...) and x = expr and clause* ...)
@@ -152,28 +166,53 @@
         ((loop-aux "for-reordering" args for x #f to-clause by-clause stepping from start clause* ...)
           (let ((start* start))
             (loop-aux "for-reordering" args for x start* to-clause by-clause stepping clause* ...)))
-        ((loop-aux "for-reordering" args for x #f to-clause by-clause stepping downfrom start clause* ...)
+        ((loop-aux "for-reordering" args for x #f to-clause by-clause 1 downfrom start clause* ...)
+          (syntax-error "inconsistent stepping"))
+        ((loop-aux "for-reordering" args for x #f to-clause by-clause _ downfrom start clause* ...)
           (let ((start* start))
             (loop-aux "for-reordering" args for x start* to-clause by-clause -1 clause* ...)))
         ((loop-aux "for-reordering" args for x from-clause #f by-clause stepping to last clause* ...)
           (let ((last* last))
             (loop-aux "for-reordering" args for x from-clause (to last*) by-clause stepping clause* ...)))
-        ((loop-aux "for-reordering" args for x from-clause #f by-clause stepping downto last clause* ...)
+        ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 downto last clause* ...)
+          (syntax-error "inconsistent stepping"))
+        ((loop-aux "for-reordering" args for x from-clause #f by-clause _ downto last clause* ...)
           (let ((last* last))
             (loop-aux "for-reordering" args for x from-clause (downto last*) by-clause -1 clause* ...)))
-        ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 below last clause* ...)
+        ((loop-aux "for-reordering" args for x from-clause #f by-clause -1 below last clause* ...)
+          (syntax-error "inconsistent stepping"))
+        ((loop-aux "for-reordering" args for x from-clause #f by-clause _ below last clause* ...)
           (let ((last* last))
             (loop-aux "for-reordering" args for x from-clause (below last*) by-clause 1 clause* ...)))
+        ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 above last clause* ...)
+          (syntax-error "inconsistent stepping"))
         ((loop-aux "for-reordering" args for x from-clause #f by-clause _ above last clause* ...)
           (let ((last* last))
             (loop-aux "for-reordering" args for x from-clause (above last*) by-clause -1 clause* ...)))
         ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping by inc clause* ...)
           (let ((inc* inc))
             (loop-aux "for-reordering" args for x from-clause to-clause inc* stepping clause* ...)))
+        ((loop-aux "for-reordering" args for x #f #f #f _ clause* ...)
+          (syntax-error "need at least one for subclause"))
+        ((loop-aux "for-reordering" args for x from-clause to-clause inc #f clause* ...)
+          (loop-aux "for-reordering" args for x from-clause to-clause inc 1 clause* ...))
         ((loop-aux "for-reordering" args for x #f to-clause inc 1 clause* ...)
           (loop-aux "for-reordering" args for x 0 to-clause inc 1 clause* ...))
         ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping clause* ...)
           (loop-aux "for-reordering" args for x from-clause to-clause 1 stepping clause* ...))
+        ((loop-aux "for-reordering" ((body ...) fin) for x start #f inc stepping clause* ...)
+          (let* ((inc* inc)
+                 (x start)
+                 (next x))
+            (loop-aux "variable-clause-collector"
+                      ((body ... (set! x next)
+                                 (set! next (+ x inc*)))
+                       fin)
+                      clause* ...)))
+        ; The word `to' is ambiguous as to which stepping, so replace to with downto if stepping is -1.
+        ((loop-aux "for-reordering" args for x start (to last) inc -1 clause* ...)
+          (loop-aux "for-reordering" args for x start (downto last) inc -1 clause* ...))
+        ; Put the reordered form back into variable-clause-collector.
         ((loop-aux "for-reordering" args for x start (to-clause ...) inc stepping clause* ...)
           (loop-aux "variable-clause-collector" args for x from start to-clause ... by (* stepping inc) clause* ...))
         ((loop-aux "main-clause-collector" args do clause* ...)
@@ -189,6 +228,8 @@
         ((loop-aux "main-clause-collector" args sum clause* ...)
           (loop-aux "accumulation" ("accumulation-main-continuation" args) () sum clause* ...))
         ((loop-aux "main-clause-collector" args maximize clause* ...)
+          (loop-aux "accumulation" ("accumulation-main-continuation" args) () maximize clause* ...))
+        ((loop-aux "main-clause-collector" args minimize clause* ...)
           (loop-aux "accumulation" ("accumulation-main-continuation" args) () minimize clause* ...))
         ((loop-aux "main-clause-collector" args if clause* ...)
           (loop-aux "conditional" ("conditional-main-continuation" args) () if clause* ...))
@@ -241,11 +282,11 @@
           (let ((l '())
                 (last #f))
             (loop-aux continuation ...
-                      (compound ... (let ((p (list-copy x)))
-                                      (if last
-                                        (set-cdr! last p)
-                                        (set! l p))
-                                      (set! last p)))
+                      (compound ... (loop for elem in x
+                                          for p = (list elem)
+                                          if last do (set-cdr! last p)
+                                          else do (set! l p)
+                                          do (set! last p)))
                       clause* ...)))
         ((loop-aux "accumulation" continuation compound append x clause* ...)
           (loop-aux "accumulation" continuation compound append x into l finally (return l) clause* ...))