;;;; 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 ;;;; Mar 06, 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