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