Add a loop macro.

1 files changed, 194 insertions, 0 deletions

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*))))))