chibi-scheme/lib/chibi/loop/loop.scm

;;;; loop.scm - the chibi loop (aka foof-loop)
;;
;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;> The loop API is mostly compatible with Taylor Campbell's
;;> @hyperlink["http://mumble.net/~campbell/scheme/foof-loop.txt"]{foof-loop},
;;> but the iterator API is different and subject to change.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (assoc-pred equal elt ls)
  (and (pair? ls)
       (if (equal elt (car (car ls)))
           (car ls)
           (assoc-pred equal elt (cdr ls)))))

(define-syntax let-keyword-form
  (syntax-rules ()
    ((let-keyword-form
      ((labeled-arg-macro-name (positional-name . params)))
      . body)
     (let-syntax
         ((labeled-arg-macro-name
           (er-macro-transformer
            (lambda (expr rename compare)
              (let lp ((ls (cdr expr)) (named '()) (posns '()))
                (cond
                 ((pair? ls)
                  (if (and (list? (car ls)) (compare (caar ls) (rename '=>)))
                      (lp (cdr ls) (cons (cdar ls) named) posns)
                      (lp (cdr ls) named (cons (car ls) posns))))
                 (else
                  (let lp ((ls (syntax-quote params))
                           (posns (reverse posns))
                           (args '()))
                    (cond
                     ((null? ls)
                      (if (pair? posns)
                          (error "let-keyword-form: too many args" expr)
                          (cons (syntax-quote positional-name) (reverse args))))
                     ((assoc-pred compare (caar ls) named)
                      => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args))))
                     ((pair? posns)
                      (lp (cdr ls) (cdr posns) (cons (car posns) args)))
                     (else
                      (lp (cdr ls) posns (cons (cadar ls) args))))))))))))
       . body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;> @subsubsubsection{@scheme{(loop [name] (vars ...) [=> result] body ...)}}

(define-syntax loop
  (syntax-rules ()
    ;; unnamed, implicit recursion
    ((loop (vars ...) body ...)
     (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
    ;; named, explicit recursion
    ((loop name (vars ...) body ...)
     (%loop name () () () () () (vars ...) body ...))))

;; Main LOOP macro. Separate the variables from the iterator and
;; parameters, then walk through each parameter expanding the
;; bindings, and build the final form.

(define-syntax %loop
  (syntax-rules (=> for with let while until)
    ;; automatic iteration
    ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
     (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
    ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
     (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
    ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
     (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
    ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
     (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
    ;; do equivalents, with optional guards
    ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
     (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
    ((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
     (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
    ((_ name l (vars ...) c r f ((with var init) rest ...) . body)
     (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
    ;; user-specified terminators
    ((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
     (%loop name l vars (checks ... expr) r f (rest ...) . body))
    ((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
     (%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
    ;; specify a default done?
    ((_ name l v c r f ())
     (%loop name l v c r f () (#f #f)))
    ((_ name l v c r f () () . body)
     (%loop name l v c r f () (#f #f) . body))
    ;; final expansion
    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
        => result
        . body)
     (let* (lets ...)
       (letrec ((tmp (lambda (var ...)
                       (if (or checks ...)
                           (let-keyword-form ((name (tmp (var step) ...)))
                             (let (finals ...) result))
                           (let (refs ...)
                             (let-keyword-form ((name (tmp (var step) ...)))
                               (if #f #f)
                               . body))))))
         (tmp init ...))))
    ;; unspecified return value case
    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
        . body)
     (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
            => (if #f #f) . body))
    ))

(define-syntax %loop-next
  (syntax-rules ()
    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
        name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
        . rest)
     (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
                 (checks ... new-checks ...) (refs ... new-refs ...)
                 (finals ... new-finals ...)
        . rest))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> @subsubsection{Iterators}

;; Each gets passed two lists, those items left of the macro and those to
;; the right, followed by a NEXT and REST continuation.
;;
;; Should finish with
;;
;; @schemeblock{
;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
;;        (loop-vars ...) (final-vars ...) . rest)
;; }
;;
;; @itemlist[
;; @item{@var{outer-vars} - bound once outside the loop in a LET*}
;; @item{@var{cursor-vars} - DO-style bindings of the form (name init update)}
;; @item{@var{done?-tests} - possibly empty list of forms that terminate the loop on #t}
;; @item{@var{loop-vars} - inner variables, updated in parallel after the cursors}
;; @item{@var{final-vars} - final variables, bound only in the => result}
;; ]

;;> @subsubsubsection{@scheme{(for var [pair] (in-list ls [cdr]))}}

;;> Basic list iterator.

(define-syntax in-list                  ; called just "IN" in ITER
  (syntax-rules ()
    ((in-list ((var) source) next . rest)
     (in-list ((var cursor) source) next . rest))
    ((in-list ((var cursor) source) next . rest)
     (in-list ((var cursor succ) source) next . rest))
    ((in-list ((var cursor succ) (source)) next . rest)
     (next ()                         ; outer let bindings
           ((cursor source succ))     ; iterator, init, step
           ((not (pair? cursor)))     ; finish tests for iterator vars
           ;; step variables and values
           ((var (car cursor))
            (succ (cdr cursor)))
           ()                           ; final result bindings
           . rest))
    ((in-list ((var cursor succ) (source step)) next . rest)
     (next ()
           ((cursor source succ))
           ((not (pair? cursor)))
           ((var (car cursor))
            (succ (step cursor)))
           ()
           . rest))))

;;> @subsubsubsection{@scheme{(for elts [pairs] (in-lists lol [cdr [done?]]))}}

;;> Iterator from Taylor R. Campbell.  If you know the number of lists
;;> ahead of time it's much more efficient to iterate over each one
;;> separately.

(define-syntax in-lists
  (syntax-rules ()
    ((in-lists ((elts) lol) next . rest)
     (in-lists ((elts pairs) lol) next . rest))
    ((in-lists ((elts pairs) lol) next . rest)
     (in-lists ((elts pairs succ) lol) next . rest))
    ((in-lists ((elts pairs succ) (lol)) next . rest)
     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists ((elts pairs succ) (lol)) next . rest)
     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists ((elts pairs succ) (lol step)) next . rest)
     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
    ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
     (next ()
           ((pairs lol succ))
           ((let lp ((ls pairs)) ; an in-lined ANY
              (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
           ((elts (map car pairs))
            (succ (map step pairs)))
           ()
           . rest))
    ))

(define-syntax define-in-indexed
  (syntax-rules ()
    ((define-in-indexed in-type in-type-reverse length ref)
     (begin
       (define-syntax in-type
         (syntax-rules ()
           ((in-type seq next . rest)
            (%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
       (define-syntax in-type-reverse
         (syntax-rules ()
           ((in-type-reverse seq next . rest)
            (%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
       ))))

;;> @subsubsubsection{@scheme{(for var [index] (in-vector vec))}}
;;> @subsubsubsection{@scheme{(for var [index] (in-vector-reverse vec))}}

(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)

;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string str))}}

(define-syntax in-string
  (syntax-rules ()
    ((in-string s next . rest)
     (%in-idx string-cursor>=? string-cursor-next
              string-cursor-start string-cursor-end string-cursor-ref
              tmp s next . rest))))

;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string-reverse str))}}

(define-syntax in-string-reverse
  (syntax-rules ()
    ((in-string-reverse s next . rest)
     (%in-idx string-cursor<? string-cursor-prev
              (lambda (x) (string-cursor-prev x (string-cursor-end x)))
              string-cursor-start string-cursor-ref
              tmp s next . rest))))

;; helper for the above string and vector iterators
(define-syntax %in-idx
  (syntax-rules ()
    ;;   cmp inc start end ref
    ((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
     (%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
     (%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
     (%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
     (next ((tmp seq) (end to))
           ((index from (+ tmp index)))
           ((ge index end))
           ((var (r tmp index)))
           ()
       . rest))
    ))

;;> @subsubsubsection{@scheme{(for ch (in-port [input-port [reader [eof?]]]))}}

(define-syntax in-port
  (syntax-rules ()
    ((in-port ((var) source) next . rest)
     (in-port ((var p) source) next . rest))
    ((in-port ((var p) ()) next . rest)
     (in-port ((var p) ((current-input-port))) next . rest))
    ((in-port ((var p) (port)) next . rest)
     (in-port ((var p) (port read-char)) next . rest))
    ((in-port ((var p) (port read-char)) next . rest)
     (in-port ((var p) (port read-char eof-object?)) next . rest))
    ((in-port ((var p) (port reader eof?)) next . rest)
     (next ((p port) (r reader) (e? eof?))
           ((var (r p) (r p)))
           ((e? var))
           ()
           ()
       . rest))))

;;> @subsubsubsection{@scheme{(for ch (in-file [input-port [reader [eof?]]]))}}

(define-syntax in-file
  (syntax-rules ()
    ((in-file ((var) source) next . rest)
     (in-file ((var p) source) next . rest))
    ((in-file ((var p) (file)) next . rest)
     (in-file ((var p) (file read-char)) next . rest))
    ((in-file ((var p) (file reader)) next . rest)
     (in-file ((var p) (file reader eof-object?)) next . rest))
    ((in-file ((var p) (file reader eof?)) next . rest)
     (next ((p (open-input-file file)) (r reader) (e? eof?))
           ((var (r p) (r p)))
           ((e? var))
           ()
           ((dummy (close-input-port p)))
       . rest))))

;;> @subsubsubsection{@scheme{(for x (up-from [start] [(to limit)] [(by step)]))}}

(define-syntax up-from
  (syntax-rules (to by)
    ((up-from (() . args) next . rest)
     (up-from ((var) . args) next . rest))
    ((up-from ((var) (start (to limit) (by step))) next . rest)
     (next ((s start) (l limit) (e step))
           ((var s (+ var e)))
           ((>= var l))
           ()
           ()
           . rest))
    ((up-from ((var) (start (to limit))) next . rest)
     (next ((s start) (l limit))
           ((var s (+ var 1)))
           ((>= var l))
           ()
           ()
           . rest))
    ((up-from ((var) (start (by step))) next . rest)
     (next ((s start) (e step)) ((var s (+ var e))) () () () . rest))
    ((up-from ((var) (start)) next . rest)
     (next ((s start)) ((var s (+ var 1))) () () () . rest))
    ))

;;> @subsubsubsection{@scheme{(for x (down-from [start] [(to limit)] [(by step)]))}}

(define-syntax down-from
  (syntax-rules (to by)
    ((down-from (() . args) next . rest)
     (down-from ((var) . args) next . rest))
    ((down-from ((var) (start (to limit) (by step))) next . rest)
     (next ((s start) (l limit) (e step))
           ((var (- s e) (- var e)))
           ((< var l))
           ()
           ()
           . rest))
    ((down-from ((var) (start (to limit))) next . rest)
     (next ((s start) (l limit))
           ((var (- s 1) (- var 1)))
           ((< var l))
           ()
           ()
           . rest))
    ((down-from ((var) (start (by step))) next . rest)
     (next ((s start) (e step)) ((var (- s e) (- var e))) () () ()
           . rest))
    ((down-from ((var) (start)) next . rest)
     (next ((s start)) ((var (- s 1) (- var 1))) () () ()
           . rest))
    ))

(define-syntax accumulating
  (syntax-rules (initial if)
    ((accumulating (kons final init) ((var) . x) next . rest)
     (accumulating (kons final init) ((var cursor) . x) next . rest))
    ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
     (accumulating (kons final i) ((var cursor) x) n . rest))
    ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
     (n ((tmp-kons kons))
        ((cursor '() (if check (tmp-kons expr cursor) cursor)))
        ()
        ()
        ((var (final cursor)))
        . rest))
    ((accumulating (kons final init) ((var cursor) (expr)) n . rest)
     (n ((tmp-kons kons))
        ((cursor '() (tmp-kons expr cursor)))
        ()
        ()
        ((var (final cursor)))
        . rest))))

;;> @subsubsubsection{@scheme{(for x [pair] (listing expr))}}

(define-syntax listing
  (syntax-rules ()
    ((listing args next . rest)
     (accumulating (cons reverse '()) args next . rest))))

;;> @subsubsubsection{@scheme{(for x [pair] (listing-reverse expr))}}

(define-syntax listing-reverse
  (syntax-rules ()
    ((listing-reverse args next . rest)
     (accumulating (cons (lambda (x) x) '()) args next . rest))))

(define (append-reverse rev tail)
  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))

;;> @subsubsubsection{@scheme{(for x [pair] (appending expr))}}

(define-syntax appending
  (syntax-rules ()
    ((appending args next . rest)
     (accumulating (append-reverse reverse '()) args next . rest))))

;;> @subsubsubsection{@scheme{(for x [pair] (appending-reverse expr))}}

(define-syntax appending-reverse
  (syntax-rules ()
    ((appending-reverse args next . rest)
     (accumulating (append-reverse (lambda (x) x) '()) args next . rest))))

;;> @subsubsubsection{@scheme{(for x (summing expr))}}

(define-syntax summing
  (syntax-rules ()
    ((summing args next . rest)
     (accumulating (+ (lambda (x) x) 0) args next . rest))))

;;> @subsubsubsection{@scheme{(for x (multiplying expr))}}

(define-syntax multiplying
  (syntax-rules ()
    ((multiplying args next . rest)
     (accumulating (* (lambda (x) x) 1) args next . rest))))