;;;; File: loops.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Jul 25, 2008
;;;;       May 19, 2009
;;;;       Nov 06, 2009
;;;;       Nov 23, 2009
;;;;       Jan 20, 2010
;;;;       May 25, 2010
;;;;       Jul 05, 2010
;;;;       Oct 25, 2010
;;;;       Nov 04, 2010
;;;;       Jan 12, 2011
;;;;       Jan 25, 2011
;;;;       Feb 04, 2011
;;;;       Jul 13, 2011
;;;;       Sep 03, 2011



(module loops *

(import scheme (only chicken unless case-lambda print))

(define-syntax do-times
  (syntax-rules ()
    ((_ i upto xpr0 xpr1 ...)
     (let ((n upto))
         (let loop ((i 0))
           (unless (>= i n)
             xpr0 xpr1 ...
             (loop (+ i 1))))))))
  
(define-syntax do-list
  (syntax-rules ()
    ((_ i lst xpr xpr1 ...)
    (let loop ((sublst lst))
      (if (not (null? sublst))
        (let ((i (car sublst)))
          xpr xpr1 ...
          (loop (cdr sublst))))))))

(define-syntax do-for
  (syntax-rules ()
    ((_ var (start stop step) xpr xpr1 ...)
       (let ((%stop stop))
         (let loop ((var start))
           (unless (>= var %stop)
             xpr xpr1 ...
             (loop (+ step var))))))
    ((_ var (start stop) xpr . xprs)
     (do-for var (start stop 1) xpr . xprs))))

(define-syntax do-while
  (syntax-rules ()
    ((_ test? xpr xpr1 ...)
     (let loop ()
       (if test?
         (begin
           xpr xpr1 ...
           (loop)))))))

(define-syntax do-until
  (syntax-rules ()
    ((_ test? xpr xpr1 ...)
     (let loop ()
       (if (not test?)
         (begin
           xpr xpr1 ...
           (loop)))))))

;;; the following macro is unhygienic on purpose,
;;; it exports the exit symbol behind the scene.
;;; So it can not be defined with syntax-rules
(define-syntax do-forever
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((xpr (cadr form)) (xprs (cddr form)))
        `(call-with-current-continuation
           (lambda (,(inject 'exit))
             (let loop ()
               ,xpr
               ,@xprs
               (loop))))))))

;;; documentation
(define loops
  (let (
    (alist '(
      (do-forever
        "endless loop"
        (do-forever xpr . xprs)
        "executes body xpr . xprs until exit is called")
      (do-times
        "loops a fixed number of times"
        (do-times i upto xpr . xprs)
        "execute xpr . xprs for i in [0 upto[")
      (do-list
        "loop along a list"
        (do-list i lst xpr . xprs)
        "execute xpr . xprs for i in lst")
      (do-for
        "for-loop"
        (do-for var (start stop step) xpr . xprs)
        "do xpr . xprs for var in [start stop[ with steps (default 1)")
      (do-while
        "while-loop"
       (do-while test? xpr . xprs)
        "execute xpr . xprs while test? is true")
      (do-until
        "until-loop"
        (do-until test? xpr . xprs)
        "execute xpr . xprs while test? is false")
      ))
    )
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (cdr pair)
           (print "Choose one of " (map car alist))))))))

) ; module loops