;;;; 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



(require 'contracts 'macros 'bindings)
                  ; 'er-macros 'matchable)

(module loops *

(import scheme chicken contracts macros)
                                ; er-macros)
(import-for-syntax ;(only matchable match)
                   (only bindings bind-case)
                   (only scheme cddr)
                   (only macros explicit-renaming))
                   ;(only er-macros explicit-renaming))

(doclist '())

;(define-syntax-with-contract (do-times i upto xpr xpr1 ...) ; ok
;  "do xpr ... for i in [0 upto["
;  (let ((n upto)) ; ok
;    (let loop ((i 0))
;      (unless (>= i n)
;        xpr xpr1 ...
;        (loop (+ i 1))))))
(define-syntax-with-contract do-times ; ok
  "do xpr ... for i in [0 upto["
  (explicit-renaming (%n %let %loop %>= %unless %+)
    ((_ i upto xpr . xprs)
     (lambda (compare?)
      `(,%let ((,%n ,upto))
         (,%let ,%loop ((,i 0))
           (,%unless (,%>= ,i ,%n)
             ,xpr ,@xprs
             (,%loop (,%+ ,i 1)))))))))
;(define-macro-with-contract (do-times i upto xpr . xprs) ; ok
;  "do xpr ... for i in [0 upto["
;  (lambda (compare? %n %let %loop %>= %unless %+)
;    `(,%let ((,%n ,upto))
;       (,%let ,%loop ((,i 0))
;         (,%unless (,%>= ,i ,%n)
;           ,xpr ,@xprs
;           (,%loop (,%+ ,i 1)))))))
  
(define-syntax-with-contract
  (do-list i lst xpr xpr1 ...)
  "do xpr ... for i in a list lst"
  (let loop ((sublst lst))
    (if (not (null? sublst))
      (let ((i (car sublst)))
        xpr xpr1 ...
        (loop (cdr sublst))))))
;(define-macro-with-contract
;  (do-list i lst xpr . xprs)
;  "do xpr ... for i in lst"
;  (lambda (compare? %loop %sublst %let %if %not %cdr %car %null?)
;    `(,%let ,%loop ((,%sublst ,lst))
;       (,%if (,%not (,%null? ,%sublst))
;           (,%let ((,i (,%car ,%sublst)))
;             ,xpr ,@xprs
;             (,%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-macro-with-contract
;  (do-for var (start stop . steps) xpr . xprs)
;  "do xpr ... for var in [start stop[ with steps (default 1)"
;  (lambda (compare? %let %loop %unless %+ %>= %stop)
;    (let ((step (if (null? steps) 1 (car steps))))
;      `(,%let ((,%stop ,stop))
;         (,%let ,%loop ((,var ,start))
;           (,%unless (,%>= ,var ,%stop)
;             ,xpr ,@xprs
;             (,%loop (,%+ ,step ,var))))))))

(define-syntax-with-contract 
  (do-while test? xpr xpr1 ...)
  "do xpr ... while test? is true"
  (let loop ()
    (if test?
      (begin
        xpr xpr1 ...
        (loop)))))
;(define-macro-with-contract
;  (do-while test? xpr . xprs)
;  "do xpr ... while test? is true"
;  (lambda (compare? %if %let %loop %begin)
;    `(,%let ,%loop ()
;       (,%if ,test?
;         (,%begin
;           ,xpr ,@xprs
;           (,%loop))))))

(define-syntax-with-contract
  (do-until test? xpr xpr1 ...)
  "do xpr ... while test? is false"
  (let loop ()
    (if (not test?)
      (begin
        xpr xpr1 ...
        (loop)))))
;(define-macro-with-contract
;  (do-until test? xpr . xprs)
;  "do xpr ... while test? is false"
;  (lambda (compare? %loop %let %if %begin %not)
;    `(,%let ,%loop ()
;       (,%if (,%not ,test?)
;         (,%begin
;           ,xpr ,@xprs
;           (,%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-with-contract do-forever
  "do xpr ... until exit is called"
  (explicit-renaming (%loop %call/cc %let %lambda)
    ((_ xpr . xprs)
     (lambda (compare?)
       `(,%call/cc (,%lambda (exit)
          (,%let ,%loop ()
            ,xpr ,@xprs (,%loop))))))))
;(define-macro-with-contract ; ok
;  (do-forever xpr . xprs)
;  "do xpr ... until exit is called"
;  (lambda (compare? %loop %call-with-current-continuation %let %lambda)
;    `(,%call-with-current-continuation (,%lambda (exit)
;       (,%let ,%loop ()
;         ,xpr ,@xprs (,%loop))))))

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

) ; module loops