;;;; 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
;;;;       Jul 14, 2011



(require 'contracts)

(module loops *

(import scheme chicken contracts)

(doclist '((do-forever (forms: (do-forever . body)
                               "executes body until exit is called"))))

(define-syntax-with-contract do-times
  "do xpr ... for i in [0 upto["
  (syntax-rules ()
    ((_ i upto xpr0 xpr1 ...)
     (let ((n upto))
         (let loop ((i 0))
           (unless (>= i n)
             xpr0 xpr1 ...
             (loop (+ i 1))))))))
  
(define-syntax-with-contract do-list
  "do xpr ... for i in a list lst"
  (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-with-contract do-for
  "do xpr ... for var in [start stop[ with steps (default 1)"
  (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-with-contract do-while
  "do xpr ... while test? is true"
  (syntax-rules ()
    ((_ test? xpr xpr1 ...)
     (let loop ()
       (if test?
         (begin
           xpr xpr1 ...
           (loop)))))))

(define-syntax-with-contract do-until
  "do xpr ... while test? is false"
  (syntax-rules ()
    ((_ test? xpr xpr1 ...)
     (let loop ()
       (if (not test?)
         (begin
           xpr xpr1 ...
           (loop)))))))

(import-for-syntax (only matchable match))

;;; 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 ((body (cdr form)))
        `(call/cc (lambda (,(inject 'exit))
                    (let loop ()
                      ,@body
                      (loop))))))))

(define loops (doclist->dispatcher (doclist)))

) ; module loops