mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
417 lines
16 KiB
Scheme
417 lines
16 KiB
Scheme
;;;; loop.scm - the chibi loop (aka foof-loop)
|
|
;;
|
|
;; Copyright (c) 2009-2012 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 (car (cdar 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))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;> \section{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))))
|
|
|
|
;;> \macro{(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))))
|
|
))))
|
|
|
|
;;> \macro{(for var [index] (in-vector vec))}
|
|
;;> \macro{(for var [index] (in-vector-reverse vec))}
|
|
|
|
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(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))
|
|
))
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(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))
|
|
))
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(for x [pair] (listing expr))}
|
|
|
|
(define-syntax listing
|
|
(syntax-rules ()
|
|
((listing args next . rest)
|
|
(accumulating (cons reverse '()) args next . rest))))
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(for x [pair] (appending expr))}
|
|
|
|
(define-syntax appending
|
|
(syntax-rules ()
|
|
((appending args next . rest)
|
|
(accumulating (append-reverse reverse '()) args next . rest))))
|
|
|
|
;;> \macro{(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))))
|
|
|
|
;;> \macro{(for x (summing expr))}
|
|
|
|
(define-syntax summing
|
|
(syntax-rules ()
|
|
((summing args next . rest)
|
|
(accumulating (+ (lambda (x) x) 0) args next . rest))))
|
|
|
|
;;> \macro{(for x (multiplying expr))}
|
|
|
|
(define-syntax multiplying
|
|
(syntax-rules ()
|
|
((multiplying args next . rest)
|
|
(accumulating (* (lambda (x) x) 1) args next . rest))))
|