Modify the project structure.

Now the lib directory contains what will eventually end up on the
user's /usr/lib/csc. When I write make install, it will copy all of
the .csc files from lib into the destination lib directory. This means I
can start working on the standard library in lib/scheme.

1 files changed, 419 insertions, 0 deletions

diff --git a/lib/csc/loop.csc b/lib/csc/loop.csc
new file mode 100644
index 0000000..f07deae
--- /dev/null
+++ b/lib/csc/loop.csc
@@ -0,0 +1,419 @@
+(define-library (csc loop)
+  (export loop return)
+  (import (scheme base))
+  (begin
+
+
+    ; Once more, from the top!
+
+
+    (define-record-type <return-exception>
+      (make-return-exception thunk)
+      return-exception?
+      (thunk return-exception-values))
+
+
+    (define-syntax return
+      (syntax-rules ()
+        ((return expr)
+          (raise (make-return-exception (lambda () expr))))
+        ((return)
+          (return #f))))
+
+
+    (define-record-type <loop-termination>
+      (make-loop-termination)
+      loop-termination?)
+
+
+    (define *loop-termination* (make-loop-termination))
+
+
+    ; loop is a general purpose looping construct cribbed from CL.
+    (define-syntax loop
+      (syntax-rules ()
+        ((loop loop-clauses* ...)
+          (let ((list-acc '())
+                (number-acc 0)
+                (acc-last #f)
+                (first #t))
+            (letrec-syntax
+              ((loop-aux
+                (... (syntax-rules (= above across and append below by collect count do downfrom downto else end finally for from if in into maximize minimize on return sum then to unless until when while with)
+                       ((loop-aux "variable-clause-collector" args with x = expr and clause* ...)
+                         (loop-aux "and-collector" args ((x expr)) and clause* ...))
+                       ((loop-aux "variable-clause-collector" args with x = expr clause* ...)
+                         (let ((x expr))
+                           (loop-aux "variable-clause-collector" args clause* ...)))
+                       ((loop-aux "variable-clause-collector" (body (fin ...)) finally (form1 form1* ...) (form2 form2* ...) clause* ...)
+                         (loop-aux "variable-clause-collector" (body (fin ... (form1 form1* ...))) finally (form2 form2* ...) clause* ...))
+                       ((loop-aux "variable-clause-collector" (body (fin ...)) finally (form form* ...) clause* ...)
+                         (loop-aux "variable-clause-collector" (body (fin ... (form form* ...))) clause* ...))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x in l clause* ...)
+                         (let ((temp l)
+                               (x #f))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (when (null? temp)
+                                                  (raise *loop-termination*))
+                                                (set! x (car temp))
+                                                (set! temp (cdr temp)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x on l clause* ...)
+                         (let* ((x l))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (cdr x)))
+                                                (unless (pair? x)
+                                                  (raise *loop-termination*)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init then subseq clause* ...)
+                         (let ((init-value (lambda () init)) ; put the body of init outside the scope of x.
+                               (x #f))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (if first
+                                                  (set! x (init-value))
+                                                  (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)
+                               (x #f))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless (< i (vector-length temp))
+                                                  (raise *loop-termination*))
+                                                (set! x (vector-ref temp i))
+                                                (set! i (+ 1 i)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start to last by inc clause* ...)
+                         (let* ((last* last)
+                                (inc* inc)
+                                (x start))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (+ x inc*)))
+                                                (unless (<= x last*)
+                                                  (raise *loop-termination*)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start downto last by inc clause* ...)
+                         (let* ((last* last)
+                                (inc* inc)
+                                (x start))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (+ x inc*)))
+                                                (unless (>= x last*)
+                                                  (raise *loop-termination*)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start below last by inc clause* ...)
+                         (let* ((last* last)
+                                (inc* inc)
+                                (x start))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (+ x inc*)))
+                                                (unless (< x last*)
+                                                  (raise *loop-termination*)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start above last by inc clause* ...)
+                         (let* ((last* last)
+                                (inc* inc)
+                                (x start))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (+ x inc)))
+                                                (unless (> x last*)
+                                                  (raise *loop-termination*)))
+                                      fin)
+                                     clause* ...)))
+                       ((loop-aux "variable-clause-collector" args for x 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* ...)
+                         (loop-aux "and-collector" args (and-vars ... (x expr)) and clause* ...))
+                       ((loop-aux "and-collector" args (and-vars ...) and x = expr clause* ...)
+                         (let (and-vars ... (x expr))
+                           (loop-aux "variable-clause-collector" args clause* ...)))
+                       ((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 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 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* ...)
+                         (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))
+                           (loop-aux "variable-clause-collector"
+                                     ((body ... (unless first
+                                                  (set! x (+ 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* ...)
+                         (loop-aux "unconditional" ("unconditional-main-continuation" args) () do clause* ...))
+                       ((loop-aux "main-clause-collector" args return clause* ...)
+                         (loop-aux "unconditional" ("unconditional-main-continuation" args) () return clause* ...))
+                       ((loop-aux "main-clause-collector" args collect clause* ...)
+                         (loop-aux "accumulation" ("accumulation-main-continuation" args) () collect clause* ...))
+                       ((loop-aux "main-clause-collector" args append clause* ...)
+                         (loop-aux "accumulation" ("accumulation-main-continuation" args) () append clause* ...))
+                       ((loop-aux "main-clause-collector" args count clause* ...)
+                         (loop-aux "accumulation" ("accumulation-main-continuation" args) () count clause* ...))
+                       ((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* ...))
+                       ((loop-aux "main-clause-collector" args when clause* ...)
+                         (loop-aux "conditional" ("conditional-main-continuation" args) () if clause* ...))
+                       ((loop-aux "main-clause-collector" args unless clause* ...)
+                         (loop-aux "conditional" ("conditional-main-continuation" args) () unless clause* ...))
+                       ((loop-aux "main-clause-collector" ((body ...) fin) while expr clause* ...)
+                         (loop-aux "main-clause-collector"
+                                   ((body ... (unless expr
+                                                (raise *loop-termination*)))
+                                    fin)
+                                   clause* ...))
+                       ((loop-aux "main-clause-collector" args until expr clause* ...)
+                         (loop-aux "main-clause-collector" args while (not expr) clause* ...))
+                       ((loop-aux "main-clause-collector" (body (fin ...)) finally (form1 form1* ...) (form2 form2* ...) clause* ...)
+                         (loop-aux "main-clause-collector" (body (fin ... (form1 form1* ...))) finally (form2 form2* ...) clause* ...))
+                       ((loop-aux "main-clause-collector" (body (fin ...)) finally (form form* ...) clause* ...)
+                         (loop-aux "main-clause-collector" (body (fin ... (form form* ...))) clause* ...))
+                       ((loop-aux "main-clause-collector" ((body ...) (fin ...)))
+                         (let loop-name ()
+                           (guard (e ((loop-termination? e) fin ...))
+                             body ...
+                             (set! first #f)
+                             (loop-name))))
+                       ((loop-aux "unconditional" continuation (compound ...) do (form1 form1* ...) (form2 form2* ...) clause* ...)
+                         (loop-aux "unconditional" continuation (compound ... (form1 form1* ...)) do (form2 form2* ...) clause* ...))
+                       ((loop-aux "unconditional" (continuation ...) (compound ...) do (form form* ...) clause* ...)
+                         (loop-aux continuation ... (compound ... (form form* ...)) clause* ...))
+                       ((loop-aux "unconditional" continuation compound return expr (form ...) clause* ...)
+                         (syntax-error "unexpected form after return" (form ...)))
+                       ((loop-aux "unconditional" continuation compound return expr clause* ...)
+                         (loop-aux "unconditional" continuation compound do (return expr) clause* ...))
+                       ((loop-aux "unconditional-main-continuation" ((body ...) fin) (compound ...) clause* ...)
+                         (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) collect x into l clause* ...)
+                         (let ((l '())
+                               (last #f))
+                           (loop-aux continuation ...
+                                     (compound ... (let ((p (list x)))
+                                                     (if last
+                                                       (set-cdr! last p)
+                                                       (set! l p))
+                                                     (set! last p)))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" continuation compound collect x (form ...) clause* ...)
+                         (syntax-error "unexpected form after collect" (form ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) collect x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (let ((p (list x)))
+                                                   (if acc-last
+                                                     (set-cdr! acc-last p)
+                                                     (set! list-acc p))
+                                                   (set! acc-last p)))
+                                   clause* ... finally (return list-acc)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) append x into l clause* ...)
+                         (let ((l '())
+                               (last #f))
+                           (loop-aux continuation ...
+                                     (compound ... (loop for elem in x
+                                                         for p = (list elem)
+                                                         do (if last
+                                                              (set-cdr! last p)
+                                                              (set! l p))
+                                                            (set! last p)))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) append x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (loop for elem in x
+                                                       for p = (list elem)
+                                                       do (if acc-last
+                                                            (set-cdr! acc-last p)
+                                                            (set! list-acc p))
+                                                       (set! acc-last p)))
+                                   clause* ... finally (return list-acc)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) count x into n clause* ...)
+                         (let ((n 0))
+                           (loop-aux continuation ...
+                                     (compound ... (when x
+                                                     (set! n (+ 1 n))))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) count x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (when x
+                                                   (set! number-acc (+ 1 number-acc))))
+                                   clause* ... finally (return number-acc)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) sum x into n clause* ...)
+                         (let ((n 0))
+                           (loop-aux continuation ...
+                                     (compound ... (set! n (+ x n)))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) sum x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (set! number-acc (+ x number-acc)))
+                                   clause* ... finally (return number-acc)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) maximize x into n clause* ...)
+                         (let ((n 0)
+                               (set #f))
+                           (loop-aux continuation ...
+                                     (compound ... (let ((temp x))
+                                                     (if set
+                                                       (set! n (max temp n))
+                                                       (begin
+                                                         (set! set #t)
+                                                         (set! n temp)))))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) maximize x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (let ((temp x))
+                                                   (if acc-last
+                                                     (set! number-acc (max temp number-acc))
+                                                     (begin
+                                                       (set! acc-last #t)
+                                                       (set! number-acc temp)))))
+                                   clause* ... finally (return number-acc)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) minimize x into n clause* ...)
+                         (let ((n 0)
+                               (set #f))
+                           (loop-aux continuation ...
+                                     (compound ... (let ((temp x))
+                                                     (if set
+                                                       (set! n (min temp n))
+                                                       (begin
+                                                         (set! set #t)
+                                                         (set! n temp)))))
+                                     clause* ...)))
+                       ((loop-aux "accumulation" (continuation ...) (compound ...) minimize x clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (let ((temp x))
+                                                   (if acc-last
+                                                     (set! number-acc (min temp number-acc))
+                                                     (begin
+                                                       (set! acc-last #t)
+                                                       (set! number-acc temp)))))
+                                   clause* ... finally (return number-acc)))
+                       ((loop-aux "accumulation-main-continuation" ((body ...) fin) (compound ...) clause* ...)
+                         (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...))
+                       ((loop-aux "conditional" continuation compound if condition clause* ...)
+                         (loop-aux "selectable-clause" ("selectable-clause-if-continuation" continuation compound condition) () clause* ...))
+                       ((loop-aux "conditional" continuation compound unless condition clause* ...)
+                         (loop-aux "selectable-clause" ("selectable-clause-if-continuation" continuation compound (not condition)) () clause* ...))
+                       ((loop-aux "conditional-main-continuation" ((body ...) fin) (compound ...) clause* ...)
+                         (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound do clause* ...)
+                         (loop-aux "unconditional" continuation compound do clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound return clause* ...)
+                         (loop-aux "unconditional" continuation compound return clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound collect clause* ...)
+                         (loop-aux "accumulation" continuation compound collect clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound append clause* ...)
+                         (loop-aux "accumulation" continuation compound append clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound count clause* ...)
+                         (loop-aux "accumulation" continuation compound count clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound sum clause* ...)
+                         (loop-aux "accumulation" continuation compound sum clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound maximize clause* ...)
+                         (loop-aux "accumulation" continuation compound maximize clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound minimize clause* ...)
+                         (loop-aux "accumulation" continuation compound minimize clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound if clause* ...)
+                         (loop-aux "conditional" continuation compound if clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound when clause* ...)
+                         (loop-aux "conditional" continuation compound if clause* ...))
+                       ((loop-aux "selectable-clause" continuation compound unless clause* ...)
+                         (loop-aux "conditional" continuation compound unless clause* ...))
+                       ((loop-aux "selectable-clause-if-continuation" continuation compound condition body and clause* ...)
+                         (loop-aux "selectable-clause"
+                                   ("selectable-clause-if-continuation" continuation compound condition)
+                                   body
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-if-continuation" continuation compound condition body else clause* ...)
+                         (loop-aux "selectable-clause"
+                                   ("selectable-clause-else-continuation" continuation compound condition body)
+                                   ()
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-if-continuation" (continuation ...) (compound ...) condition (body ...) end clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (when condition
+                                                   body ...))
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-if-continuation" (continuation ...) (compound ...) condition (body ...) clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (when condition
+                                                   body ...))
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-else-continuation" continuation compound condition body1 body2 and clause* ...)
+                         (loop-aux "selectable-clause"
+                                   ("selectable-clause-else-continuation" continuation compound condition body1)
+                                   body2
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-else-continuation" (continuation ...) (compound ...) condition (body1 ...) (body2 ...) end clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (if condition
+                                                   (begin body1 ...)
+                                                   (begin body2 ...)))
+                                   clause* ...))
+                       ((loop-aux "selectable-clause-else-continuation" (continuation ...) (compound ...) condition (body1 ...) (body2 ...) clause* ...)
+                         (loop-aux continuation ...
+                                   (compound ... (if condition
+                                                   (begin body1 ...)
+                                                   (begin body2 ...)))
+                                   clause* ...))))))
+              (guard (e ((return-exception? e) ((return-exception-values e))))
+                (loop-aux "variable-clause-collector" (() ()) loop-clauses* ...)))))))))