path: root/csc/loop.csc

(define-library (csc loop)
  (export loop return)
  (import (scheme base))
  (begin


    ; Once more, from the top!


    (define (*current-loop-continuation* . args)
      (error "Can't use return outside of a loop"))


    (define-record-type <loop-termination>
      (make-loop-termination)
      loop-termination?)


    (define-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 (make-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)
                 (next x))
            (loop-aux "variable-clause-collector"
                      ((body ... (set! x next)
                                 (unless (pair? x)
                                   (raise (make-loop-termination)))
                                 (set! next (cdr x)))
                       fin)
                      clause* ...)))
        ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init then subseq clause* ...)
          (let ((first #t)
                (x #f))
            (loop-aux "variable-clause-collector"
                      ((body ... (if first
                                   (begin
                                     (set! first #f)
                                     (set! x init))
                                   (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 (make-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)
                 (next x))
            (loop-aux "variable-clause-collector"
                      ((body ... (set! x next)
                                 (unless (<= x last*)
                                   (raise (make-loop-termination)))
                                 (set! next (+ x inc*)))
                       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)
                 (next x))
            (loop-aux "variable-clause-collector"
                      ((body ... (set! x next)
                                 (unless (>= x last*)
                                   (raise (make-loop-termination)))
                                 (set! next (+ x inc*)))
                       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)
                 (next x))
            (loop-aux "variable-clause-collector"
                      ((body ... (set! x next)
                                 (unless (< x last*)
                                   (raise (make-loop-termination)))
                                 (set! next (+ x inc*)))
                       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)
                 (next x))
            (loop-aux "variable-clause-collector"
                      ((body ... (set! x next)
                                 (unless (> x last*)
                                   (raise (make-loop-termination)))
                                 (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 #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)
                 (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* ...)
          (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 (make-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 ...
              (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 "accumulation" continuation compound collect x into l finally (return l) clause* ...))
        ((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)
                                          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* ...))
        ((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 "accumulation" continuation compound count x into n finally (return n) clause* ...))
        ((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 "accumulation" continuation compound sum x into n finally (return n) clause* ...))
        ((loop-aux "accumulation" (continuation ...) (compound ...) maximize x into n clause* ...)
          (let ((n #f))
            (loop-aux continuation ...
                      (compound ... (let ((temp x))
                                      (if n
                                        (set! n (max temp n))
                                        (set! n temp))))
                      clause* ...)))
        ((loop-aux "accumulation" continuation compound maximize x clause* ...)
          (loop-aux "accumulation" continuation compound maximize x into n finally (return n) clause* ...))
        ((loop-aux "accumulation" (continuation ...) (compound ...) minimize x into n clause* ...)
          (let ((n #f))
            (loop-aux continuation ...
                      (compound ... (let ((temp x))
                                      (if n
                                        (set! n (min temp n))
                                        (set! n temp))))
                      clause* ...)))
        ((loop-aux "accumulation" continuation compound minimize x clause* ...)
          (loop-aux "accumulation" continuation compound minimize x into n finally (return n) clause* ...))
        ((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* ...))))


    ; loop is a general purpose looping construct cribbed from CL.
    (define-syntax loop
      (syntax-rules ()
        ((loop clause* ...)
          (call/cc
            (lambda (k)
              (define prev-loop-continuation *current-loop-continuation*)
              (dynamic-wind
                (lambda ()
                  (set! *current-loop-continuation* k))
                (lambda ()
                  (loop-aux "variable-clause-collector" (() ()) clause* ...))
                (lambda ()
                  (set! *current-loop-continuation* prev-loop-continuation))))))))


    (define-syntax return
      (syntax-rules ()
        ((return expr)
          (call-with-values (lambda () expr) *current-loop-continuation*))))))