Add a loop macro.

3 files changed, 313 insertions, 12 deletions

diff --git a/csc/list.csc b/csc/list.csc
index f425146..dcc1766 100644
--- a/csc/list.csc
+++ b/csc/list.csc
@@ -7,27 +7,26 @@
     split-at
     take)
   (import (scheme base)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match)
             match))
   (begin
 
 
     (define (take n xs)
-      (let loop ((n n)
-                 (xs xs)
-                 (acc '()))
-        (if (or (not (positive? n)) (null? xs))
-            (reverse acc)
-          (loop (- n 1) (cdr xs) (cons (car xs) acc)))))
+      (loop for x in xs
+            for i from 1 to n
+            collect x))
 
 
     (define (split-at n xs)
-      (let loop ((n n)
-                 (xs xs)
-                 (acc '()))
-        (if (or (not (positive? n)) (null? xs))
-            (values (reverse acc) xs)
-          (loop (- n 1) (cdr xs) (cons (car xs) acc)))))
+      (loop for i from 1 to n
+            for x in xs
+            collect x into first-half
+            for second-half = xs then (cdr second-half)
+            finally (return (values first-half second-half))))
 
 
     (define (revappend a b)
diff --git a/csc/loop-test.csc b/csc/loop-test.csc
new file mode 100644
index 0000000..df2c970
--- /dev/null
+++ b/csc/loop-test.csc
@@ -0,0 +1,108 @@
+(import (scheme base)
+        (only (csc format) printf)
+        (only (csc testing)
+          assert-equal
+          test)
+        (csc loop))
+
+
+(test for-collect
+  (assert-equal
+    '(1 2 3 4 5)
+    (loop for x in '(1 2 3 4 5)
+          collect x)))
+
+
+(test 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
+  (assert-equal
+    '(1 2 3 4 5)
+    (loop for x from 1 to 5
+          collect x)))
+
+
+(test for-arithmetic-step
+  (assert-equal
+    '(1 3 5 7 9)
+    (loop for x from 1 to 10 by 2
+          collect x)))
+
+
+(test finally-noop
+  (assert-equal
+    '(1 2 3)
+    (loop for x from 1 to 3
+          finally #t
+          collect x)))
+
+
+(test collect-into
+  (assert-equal
+    '((1 2 3) (1 2 3) (1 2 3))
+    (loop for x from 1 to 3
+          collect x into l
+          collect l)))
+
+
+(test finally-set
+  (assert-equal
+    '(1 2 3)
+    (let ((res #f))
+      (loop for x from 1 to 3
+            collect x into l
+            finally (set! res l))
+      res)))
+
+
+(test loop-do
+  (assert-equal
+    '(3 2 1)
+    (let ((res '()))
+      (loop for x from 1 to 3
+            do (set! res (cons x res)))
+      res)))
+
+
+(test return
+  (assert-equal
+    '(1 2 3)
+    (loop do (return '(1 2 3)))))
+
+
+(test finally-return
+  (assert-equal
+    '(1 2 3)
+    (loop for x from 1 to 3
+          collect x into l
+          finally (return l))))
+
+
+(test for-as-equals-then
+  (assert-equal
+    '((1 2 3) (2 3) (3))
+    (loop for i from 1 to 3
+          for tail = '(1 2 3) then (cdr tail)
+          collect tail)))
+
+
+(test return-multiple-values
+  (let-values (((x1 x2) (loop do (return (values 1 2)))))
+    (assert-equal
+      1
+      x1)
+    (assert-equal
+      2
+      x2)))
+
+
+(test nested-loops
+  (assert-equal
+    '(1 2 3)
+    (loop do (define x (loop do (return '(1 2 3))))
+             (return x))))
diff --git a/csc/loop.csc b/csc/loop.csc
new file mode 100644
index 0000000..c7331fe
--- /dev/null
+++ b/csc/loop.csc
@@ -0,0 +1,194 @@
+(define-library (csc loop)
+  (export loop return)
+  (import (scheme base))
+  (begin
+
+
+    (define-syntax initial-values
+      (syntax-rules (=
+                     by
+                     collect
+                     do
+                     for
+                     from
+                     in
+                     into
+                     then
+                     to)
+        ((initial-values loop-name (acc* ...) ((for _ in l temp-name) clause clause* ...) body)
+          (initial-values loop-name (acc* ... (temp-name l)) (clause clause* ...) body))
+        ((initial-values loop-name (acc* ...) ((for x from start to _ by _) clause clause* ...) body)
+          (initial-values loop-name (acc* ... (x start)) (clause clause* ...) body))
+        ((initial-values loop-name (acc* ...) ((for x = init then consequent) clause clause* ...) body)
+          (initial-values loop-name (acc* ... (x init)) (clause clause* ...) body))
+        ((initial-values loop-name (acc* ...) ((collect _ into l last) clause clause* ...) body)
+          (initial-values loop-name (acc* ... (l '()) (last #f)) (clause clause* ...) body))
+        ((initial-values loop-name (acc* ...) ((collect _ l last)) body)
+          (let loop-name (acc* ... (l '()) (last #f))
+            body))
+        ((initial-values loop-name (acc* ...) ((do _)) body)
+          (let loop-name (acc* ...)
+            body))))
+
+
+    (define-syntax subsequent-values
+      (syntax-rules (=
+                     by
+                     collect
+                     do
+                     for
+                     from
+                     in
+                     into
+                     then
+                     to)
+        ((subsequent-values loop-name (acc* ...) (for _ in _ l) clause clause* ...)
+          (subsequent-values loop-name (acc* ... (cdr l)) clause clause* ...))
+        ((subsequent-values loop-name (acc* ...) (for x from _ to _ by inc) clause clause* ...)
+          (subsequent-values loop-name (acc* ... (+ x inc)) clause clause* ...))
+        ((subsequent-values loop-name (acc* ...) (for x = _ then consequent) clause clause* ...)
+          (subsequent-values loop-name (acc* ... consequent) clause clause* ...))
+        ((subsequent-values loop-name (acc* ...) (collect expr into l last) clause clause* ...)
+          (if last
+            (begin
+              (set-cdr! last (list expr))
+              (subsequent-values loop-name (acc* ... l (cdr last)) clause clause* ...))
+            (begin
+              (set! l (list expr))
+              (subsequent-values loop-name (acc* ... l l) clause clause* ...))))
+        ((subsequent-values loop-name (acc* ...) (collect expr l last))
+          (if last
+            (begin
+              (set-cdr! last (list expr))
+              (loop-name acc* ... l (cdr last)))
+            (begin
+              (set! l (list expr))
+              (loop-name acc* ... l l))))
+        ((subsequent-values loop-name (acc* ...) (do expr))
+          (begin
+            expr
+            (loop-name acc* ...)))))
+
+
+    (define-syntax condition
+      (syntax-rules (=
+                     by
+                     collect
+                     for
+                     from
+                     in
+                     into
+                     then
+                     to)
+        ((condition)
+          #t)
+        ((condition (for _ in _ l) clause* ...)
+          (and (pair? l) (condition clause* ...)))
+        ((condition (for x from _ to limit by _) clause* ...)
+          (and (<= x limit) (condition clause* ...)))
+        ((condition (for _ = _ then _) clause* ...)
+          (condition clause* ...))
+        ((condition (collect _ into _ _) clause* ...)
+          (condition clause* ...))))
+
+
+    (define-syntax result
+      (syntax-rules (collect)
+        ((result (collect _ l _))
+          l)
+        ((result (do _))
+          (if #f #f))))
+
+
+    (define-syntax bindings
+      (syntax-rules (=
+                     by
+                     collect
+                     for
+                     from
+                     in
+                     into
+                     then
+                     to)
+        ((bindings () body)
+          body)
+        ((bindings ((for x in _ l) clause* ...) body)
+          (let ((x (car l)))
+            (bindings (clause* ...)
+              body)))
+        ((bindings ((for _ from _ to _ by _) clause* ...) body)
+          (bindings (clause* ...) body))
+        ((bindings ((for _ = _ then _) clause* ...) body)
+          (bindings (clause* ...) body))
+        ((bindings ((collect _ into _ _) clause* ...) body)
+          (bindings (clause* ...) body))))
+
+
+    (define (*current-loop-continuation* . args)
+      (error "Can't use return outside of a loop"))
+
+
+    (define-syntax loop-clauses
+      (syntax-rules ()
+        ((loop-clauses (clause* ...) fin body)
+          (call/cc
+            (lambda (k)
+              (define prev-loop-continuation *current-loop-continuation*)
+              (dynamic-wind
+                (lambda ()
+                  (set! *current-loop-continuation* k))
+                (lambda ()
+                  (initial-values loop-name () (clause* ... body)
+                    (if (condition clause* ...)
+                      (bindings (clause* ...)
+                        (subsequent-values loop-name () clause* ... body))
+                      (begin
+                        fin
+                        (result body)))))
+                (lambda ()
+                  (set! *current-loop-continuation* prev-loop-continuation))))))))
+
+
+    (define-syntax clause-collector
+      (syntax-rules (=
+                     by
+                     collect
+                     do
+                     finally
+                     for
+                     from
+                     in
+                     into
+                     then
+                     to)
+        ((clause-collector (acc ...) fin for x in l clause clause* ...)
+          (clause-collector (acc ... (for x in l temp-name)) fin clause clause* ...))
+        ((clause-collector (acc ...) fin for x from start to limit by step clause clause* ...)
+          (clause-collector (acc ... (for x from start to limit by step)) fin clause clause* ...))
+        ((clause-collector (acc ...) fin for x from start to limit clause clause* ...)
+          (clause-collector (acc ... (for x from start to limit by 1)) fin clause clause* ...))
+        ((clause-collector (acc ...) fin for x = init then subsequent clause clause* ...)
+          (clause-collector (acc ... (for x = init then subsequent)) fin clause clause* ...))
+        ((clause-collector (acc ...) fin collect x into l clause clause* ...)
+          (clause-collector (acc ... (collect x into l temp-name)) fin clause clause* ...))
+        ((clause-collector (acc ...) #f finally expr)
+          (loop-clauses (acc ...) expr (do (if #f #f))))
+        ((clause-collector (acc ...) #f finally expr clause clause* ...)
+          (clause-collector (acc ...) expr clause clause* ...))
+        ((clause-collector (acc ...) fin collect expr)
+          (loop-clauses (acc ...) fin (collect expr temp1 temp2)))
+        ((clause-collector (acc ...) fin do body body* ...)
+          (loop-clauses (acc ...) fin (do (let () body body* ...))))))
+
+
+    ; loop is a general purpose looping construct cribbed from CL.
+    (define-syntax loop
+      (syntax-rules ()
+        ((loop clause clause* ...)
+          (clause-collector () #f clause clause* ...))))
+
+
+    (define-syntax return
+      (syntax-rules ()
+        ((return expr)
+          (call-with-values (lambda () expr) *current-loop-continuation*))))))