601 lines
20 KiB
Scheme
601 lines
20 KiB
Scheme
;; iterators.scm - iterators for goof-loop.
|
|
;;
|
|
;; Copyright 2020-2021 Linus Björnstam
|
|
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
|
|
;; All rights reserved.
|
|
;;
|
|
;; Redistribution and use in source and binary forms, with or without
|
|
;; modification, are permitted provided that the following conditions
|
|
;; are met:
|
|
;; 1. Redistributions of source code must retain the above copyright
|
|
;; notice, this list of conditions and the following disclaimer.
|
|
;; 2. Redistributions in binary form must reproduce the above copyright
|
|
;; notice, this list of conditions and the following disclaimer in the
|
|
;; documentation and/or other materials provided with the distribution.
|
|
;; 3. The name of the author(s) may not be used to endorse or promote products
|
|
;; derived from this software without specific prior written permission.
|
|
;;
|
|
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
|
|
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
;; TODO iterators
|
|
;; in-stream
|
|
|
|
(define-syntax in
|
|
(syntax-rules ()
|
|
((in :for ((var) (init)) n . rest)
|
|
(n () ((var init var)) () () () . rest))
|
|
((in :for ((var) (init step)) n . rest)
|
|
(n () ((var init step)) () () () . rest))
|
|
((in :for ((var) (init step stop)) n . rest)
|
|
(n () ((var init step)) (stop) () () . rest))))
|
|
|
|
(define-syntax in-list
|
|
(syntax-rules (:for)
|
|
((in-list :for ((var) source) next . rest)
|
|
(in-list :for ((var cursor) source) next . rest))
|
|
((in-list :for ((var cursor) source) next . rest)
|
|
(in-list :for ((var cursor succ) source) next . rest))
|
|
((in-list :for ((var cursor succ) (source)) next . rest)
|
|
(in-list :for ((var cursor succ) (source cdr)) next . rest))
|
|
((in-list :for ((var cursor succ) (source step)) next . rest)
|
|
(next
|
|
;; outer let bindings, bound outside the loop, unchanged during the loop
|
|
()
|
|
;; iterator, init, step
|
|
((cursor source succ))
|
|
;; tests to check whether the iterator is exhausted.
|
|
((not (pair? cursor)))
|
|
;; loop variables (called refs) and updates.
|
|
((var (car cursor))
|
|
(succ (step cursor)))
|
|
;; final bindings: things bound in the final function.
|
|
()
|
|
;; the continuation.
|
|
. rest))
|
|
|
|
;; Generator-clauses
|
|
((in-list lst)
|
|
(gen-list lst))
|
|
((in-list (var) (expr step))
|
|
(gen-list lst step))))
|
|
|
|
(define gen-list
|
|
(case-lambda
|
|
((lst)
|
|
(gen-list lst cdr))
|
|
((lst by)
|
|
(lambda ()
|
|
(if (null? lst)
|
|
(eof-object)
|
|
(let ((res (car lst)))
|
|
(set! lst (by lst))
|
|
res))))))
|
|
|
|
|
|
(define-syntax in-lists
|
|
(syntax-rules (:for)
|
|
((in-lists :for ((elts) lol) next . rest)
|
|
(in-lists :for ((elts pairs) lol) next . rest))
|
|
((in-lists :for ((elts pairs) lol) next . rest)
|
|
(in-lists :for ((elts pairs succ) lol) next . rest))
|
|
((in-lists :for ((elts pairs succ) (lol)) next . rest)
|
|
(in-lists :for ((elts pairs succ) (lol cdr)) next . rest))
|
|
((in-lists :for ((elts pairs succ) (lol)) next . rest)
|
|
(in-lists :for ((elts pairs succ) (lol cdr)) next . rest))
|
|
((in-lists :for ((elts pairs succ) (lol step)) next . rest)
|
|
(in-lists :for ((elts pairs succ) (lol step null?)) next . rest))
|
|
((in-lists :for ((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))
|
|
;; Generator clause
|
|
((in-lists lists ...)
|
|
(gen-lists lists ...))))
|
|
|
|
|
|
;; TODO: make this not slow.
|
|
(define (gen-lists . lists)
|
|
(lambda ()
|
|
(if (any null? lists)
|
|
(eof-object)
|
|
(let ((cars (map car lists))
|
|
(cdrs (map cdr lists)))
|
|
(set! lists cdrs)
|
|
(values cars)))))
|
|
|
|
|
|
|
|
(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 :for seq next . rest)
|
|
(%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))
|
|
((in-type coll)
|
|
(in-indexed-generator coll length ref))))
|
|
(define-syntax in-type-reverse
|
|
(syntax-rules ()
|
|
((in-type-reverse :for seq next . rest)
|
|
(%in-idx <
|
|
(lambda (x i) (- i 1))
|
|
(lambda (x) (- (length x) 1))
|
|
(lambda (x) 0) ref tmp seq next . rest))
|
|
((in-type coll)
|
|
(in-indexed-generator-reverse coll length ref))))))))
|
|
|
|
(define (in-indexed-generator coll len ref)
|
|
(let ((index -1)
|
|
(length (len coll)))
|
|
(lambda ()
|
|
(set! index (+ index 1))
|
|
(if (>= index length)
|
|
(eof-object)
|
|
(ref coll index)))))
|
|
|
|
(define (in-indexed-generator-reverse coll len ref)
|
|
(let ((index (len coll)))
|
|
(lambda ()
|
|
(set! index (- index 1))
|
|
(if (< index 0)
|
|
(eof-object)
|
|
(ref coll index)))))
|
|
|
|
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
|
|
|
|
(define-in-indexed in-string in-string-reverse string-length string-ref)
|
|
|
|
;; 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))))
|
|
|
|
|
|
(define-syntax in-port
|
|
(syntax-rules ()
|
|
((in-port :for ((var) source) next . rest)
|
|
(in-port :for ((var p) source) next . rest))
|
|
((in-port :for ((var p) ()) next . rest)
|
|
(in-port :for ((var p) ((current-input-port))) next . rest))
|
|
((in-port :for ((var p) (port)) next . rest)
|
|
(in-port :for ((var p) (port read-char)) next . rest))
|
|
((in-port :for ((var p) (port read-char)) next . rest)
|
|
(in-port :for ((var p) (port read-char eof-object?)) next . rest))
|
|
((in-port :for ((var p) (port reader eof?)) next . rest)
|
|
(next ((p port))
|
|
((var (reader p) (reader p)))
|
|
((eof? var))
|
|
()
|
|
()
|
|
. rest))
|
|
;; generator clauses
|
|
((in-port port)
|
|
(gen-port port read-char eof-object?))
|
|
((in-port port reader)
|
|
(gen-port port reader eof-object?))
|
|
((in-port port reader eof?)
|
|
(gen-port port reader eof?))))
|
|
|
|
(define (gen-port port read eof?)
|
|
(lambda ()
|
|
(let ((res (read port)))
|
|
(if (eof? res)
|
|
(eof-object)
|
|
res))))
|
|
|
|
(define-syntax in-file
|
|
(syntax-rules ()
|
|
((in-file :for ((var) source) next . rest)
|
|
(in-file :for ((var p) source) next . rest))
|
|
((in-file :for ((var p) (file)) next . rest)
|
|
(in-file :for ((var p) (file read-char)) next . rest))
|
|
((in-file :for ((var p) (file reader)) next . rest)
|
|
(in-file :for ((var p) (file reader eof-object?)) next . rest))
|
|
((in-file :for ((var p) (file reader eof?)) next . rest)
|
|
(next ((p (open-input-file file)) (r reader) (e? eof?))
|
|
((var (r p) (r p)))
|
|
((e? var))
|
|
()
|
|
((close-input-port p)) . rest))
|
|
;; generator clauses
|
|
((in-file path)
|
|
(gen-file path read-char eof-object?))
|
|
((in-file path read)
|
|
(gen-file path read eof-object?))
|
|
((in-file path read eof?)
|
|
(gen-file path read eof?))))
|
|
|
|
(define (gen-file path read eof?)
|
|
(let ((file (open-input-file path)))
|
|
(lambda ()
|
|
(let ((res (read file)))
|
|
(cond ((eof? res)
|
|
(close-port file)
|
|
(eof-object))
|
|
(else res))))))
|
|
|
|
(define-syntax in-generator
|
|
(syntax-rules ()
|
|
((_ :for ((var) source) next . rest)
|
|
(next ((gen source))
|
|
((var (gen) (gen)))
|
|
((eof-object? var))
|
|
()
|
|
()
|
|
. rest))
|
|
;; yes, generator clause
|
|
((in-generator gen)
|
|
(let ((g gen))
|
|
(lambda ()
|
|
(g))))))
|
|
|
|
(define (make-up-from-generator/bounded start limit step)
|
|
(lambda ()
|
|
(if (>= start limit)
|
|
(eof-object)
|
|
(let ((res start))
|
|
(set! start (+ start step))
|
|
res))))
|
|
|
|
(define (make-up-from-generator/unbounded start step)
|
|
(lambda ()
|
|
(let ((res start))
|
|
(set! start (+ start step))
|
|
res)))
|
|
|
|
|
|
(define-syntax up-from
|
|
(syntax-rules (:to :by)
|
|
((up-from :for (() . args) next . rest)
|
|
(up-from :for ((var) . args) next . rest))
|
|
((up-from :for ((var) (start (:to limit) (:by step))) next . rest)
|
|
(next ((s start) (l limit) (e step))
|
|
((var s (+ var e)))
|
|
((>= var l))
|
|
() () . rest))
|
|
((up-from :for ((var) (start (:to limit))) next . rest)
|
|
(next ((s start) (l limit)) ((var s (+ var 1)))
|
|
((>= var l)) () () . rest))
|
|
((up-from :for ((var) (start (:by step))) next . rest)
|
|
(next ((s start) (e step))
|
|
((var s (+ var e))) () () () . rest))
|
|
((up-from :for ((var) (start)) next . rest)
|
|
(next ((s start)) ((var s (+ var 1)))
|
|
() () () . rest))
|
|
;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
|
|
((up-from :for ((var) (start limit step)) next . rest)
|
|
(next ((s start) (l limit) (e step)) ((var s (+ var e))) ((>= var l)) () () . rest))
|
|
((up-from :for ((var) (start limit)) next . rest)
|
|
(up-from :for ((var) (start limit 1)) next . rest))
|
|
;; Generator clauses
|
|
((up-from start (:to limit) (:by step))
|
|
(make-up-from-generator/bounded start limit step))
|
|
((up-from start (:to limit))
|
|
(make-up-from-generator/bounded start limit 1))
|
|
((up-from start (:by step))
|
|
(make-up-from-generator/unbounded start step))
|
|
((up-from start)
|
|
(make-up-from-generator/unbounded start 1))
|
|
((up-from start limit step)
|
|
(make-up-from-generator/bounded start limit step))
|
|
((up-from start limit) (make-up-from-generator/bounded start limit 1))))
|
|
|
|
|
|
(define (make-down-from-generator/bounded start end step)
|
|
(lambda ()
|
|
(if (< start end)
|
|
(eof-object)
|
|
(let ((res start))
|
|
(set! start (- start step))
|
|
res))))
|
|
|
|
(define (make-down-from-generator/unbounded start step)
|
|
(lambda ()
|
|
(let ((res start))
|
|
(set! start (- start step))
|
|
res)))
|
|
|
|
(define-syntax down-from
|
|
(syntax-rules (:to :by)
|
|
((down-from :for (() . args) next . rest)
|
|
(down-from :for ((var) . args) next . rest))
|
|
((down-from :for ((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 :for ((var) (start (:to limit))) next . rest)
|
|
(next ((s start) (l limit)) ((var (- s 1) (- var 1)))
|
|
((< var l)) () () . rest))
|
|
((down-from :for ((var) (start (:by step))) next . rest)
|
|
(next ((s start) (e step)) ((var (- s e) (- var e)))
|
|
() () () . rest))
|
|
((down-from :for ((var) (start)) next . rest)
|
|
(next ((s start)) ((var (- s 1) (- var 1)))
|
|
() () () . rest))
|
|
((down-from :for ((var) (start limit step)) next . rest)
|
|
(next ((s start) (l limit) (e step)) ((var (- s e) (- var e))) ((< var l)) () () . rest))
|
|
((down-from :for ((var) (start limit)) next . rest)
|
|
(down-from :for ((var) (start limit 1)) next . rest))
|
|
;;generator clauses
|
|
((down-from start (:to limit) (:by step))
|
|
(make-down-from-generator/bounded start limit step))
|
|
((down-from start (:to limit))
|
|
(make-down-from-generator/bounded start limit 1))
|
|
((down-from start (:by step))
|
|
(make-down-from-generator/unbounded start step))
|
|
((down-from start limit step)
|
|
(make-down-from-generator/bounded start limit step))
|
|
((down-from start limit) (make-down-from-generator/bounded start limit 1))
|
|
((down-from start) (make-down-from-generator/unbounded start 1))))
|
|
|
|
|
|
(define-syntax in-hash
|
|
(syntax-rules ()
|
|
((in-hash :for ((bindings) expr) n . rest)
|
|
(n
|
|
()
|
|
((cursor (hash-map->list cons expr) (cdr cursor)))
|
|
((not (pair? cursor)))
|
|
((bindings (car cursor)))
|
|
()
|
|
. rest))
|
|
((in-hash hash-expr)
|
|
(in-list (hash-map->list cons hash-expr)))))
|
|
|
|
|
|
(define-syntax accumulating
|
|
(syntax-rules (:initial :if :acc)
|
|
((accumulating :acc (kons final init) ((var) . x) next . rest)
|
|
(accumulating :acc (kons final init) ((var cursor) . x) next . rest))
|
|
((accumulating :acc (kons final init) ((var cursor) ((:initial i) . x)) n . rest)
|
|
(accumulating :acc (kons final i) ((var cursor) x) n . rest))
|
|
((accumulating :acc (kons final init) ((var cursor) (expr (:if check))) n . rest)
|
|
(n ((tmp-kons kons))
|
|
((cursor init (if check (tmp-kons expr cursor) cursor)))
|
|
()
|
|
()
|
|
((var (final cursor)))
|
|
. rest))
|
|
((accumulating :acc (kons final init) ((var cursor) (expr)) n . rest)
|
|
(n ((tmp-kons kons))
|
|
((cursor init (tmp-kons expr cursor)))
|
|
()
|
|
()
|
|
((var (final cursor)))
|
|
. rest))))
|
|
|
|
(define-syntax folding
|
|
(syntax-rules (if :acc)
|
|
((_ :acc ((var) (init update (if guard))) n . rest)
|
|
(n ()
|
|
((var init (if guard update var)))
|
|
() ()
|
|
((var var))
|
|
. rest))
|
|
((_ :acc ((var) (init update)) n . rest)
|
|
(folding :acc ((var) (init update (if #t))) n . rest))
|
|
((_ :acc ((var) (init)) n . rest)
|
|
(folding :acc ((var) (init var (if #t))) n . rest))))
|
|
|
|
(define-syntax listing
|
|
(syntax-rules (:acc)
|
|
((listing :acc args next . rest)
|
|
(accumulating :acc (cons reverse '()) args next . rest))))
|
|
|
|
(define-syntax listing-reverse
|
|
(syntax-rules (:acc)
|
|
((listing-reverse :acc args next . rest)
|
|
(accumulating :acc (cons (lambda (x) x) '()) args next . rest))))
|
|
|
|
(define (append-reverse rev tail)
|
|
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
|
|
|
(define-syntax appending
|
|
(syntax-rules (:acc)
|
|
((appending :acc args next . rest)
|
|
(accumulating :acc (append-reverse reverse '()) args next . rest))))
|
|
|
|
(define-syntax appending-reverse
|
|
(syntax-rules (:acc)
|
|
((appending-reverse :acc args next . rest)
|
|
(accumulating :acc (append-reverse (lambda (x) x) '()) args next . rest))))
|
|
|
|
(define-syntax summing
|
|
(syntax-rules (:acc)
|
|
((summing :acc args next . rest)
|
|
(accumulating :acc (+ (lambda (x) x) 0) args next . rest))))
|
|
|
|
(define-syntax multiplying
|
|
(syntax-rules (:acc)
|
|
((multiplying :acc args next . rest)
|
|
(accumulating :acc (* (lambda (x) x) 1) args next . rest))))
|
|
|
|
(define-syntax define-hashing
|
|
(syntax-rules ()
|
|
((_ name default-make setter)
|
|
(define-syntax name
|
|
(syntax-rules (:acc :if :initial)
|
|
((_ :acc ((var) (key value)) n . rest)
|
|
(name :acc ((var) (key value (:if #t) (:initial default-make))) n . rest))
|
|
;; either init or if
|
|
((_ :acc ((var) (key value (:if guard))) n . rest)
|
|
(name :acc ((var) (key value (:if guard) (:initial default-make))) n . rest))
|
|
((_ :acc ((var) (key value (initial init))) n . rest)
|
|
(name :acc ((var) (key value (:if #t) (:initial init))) n . rest))
|
|
;; both init and if
|
|
((_ :acc ((var) (key value (:initial init) (:if guard))) n . rest)
|
|
(name ((var) (key value (:if guard) (:initial init))) n . rest))
|
|
((_ :acc ((var) (key value (:if guard) (:initial init))) n . rest)
|
|
(n
|
|
((var init))
|
|
((dummy (if #f #f) (if guard (setter var key value) (if #f #f))))
|
|
()
|
|
()
|
|
((var var))
|
|
. rest)))))))
|
|
|
|
(define-hashing hashing (make-hash-table) hash-set!)
|
|
(define-hashing hashving (make-hash-table) hashv-set!)
|
|
(define-hashing hashqing (make-hash-table) hashq-set!)
|
|
|
|
(define (vector-grow v factor len)
|
|
(define newlen (* len factor))
|
|
(define new (make-vector newlen))
|
|
(vector-copy! new 0 v 0 len)
|
|
new)
|
|
|
|
(define (vector-set!? vec index value)
|
|
(cond ((= index (vector-length vec))
|
|
(let ((newvec (vector-grow vec 2 (vector-length vec))))
|
|
(vector-set! newvec index value)
|
|
newvec))
|
|
(else
|
|
(vector-set! vec index value)
|
|
vec)))
|
|
|
|
(define (vector-shrink? vec index)
|
|
(if (= index (vector-length vec))
|
|
vec
|
|
(vector-copy vec 0 index)))
|
|
|
|
(define-syntax vectoring
|
|
(syntax-rules (:acc :length :fill)
|
|
((_ :acc ((var) expr) n . rest)
|
|
(vectoring :acc ((var index) expr) n . rest))
|
|
((_ :acc ((var index) (expr)) n . rest)
|
|
(n ()
|
|
((index 0 (+ index 1)) (var (make-vector 32) (vector-set!? var index expr)))
|
|
()
|
|
()
|
|
((var (vector-shrink? var index)))
|
|
. rest))
|
|
((_ :acc ((var index) (expr (:length len))) n . rest)
|
|
(vectoring :acc ((var index) (expr (:length len) (:fill (if #f #f)))) n . rest))
|
|
((_ :acc ((var index) (expr (:length len) (:fill f))) next . rest)
|
|
(next ((var (make-vector len f)))
|
|
((index 0 (begin (vector-set! var index expr) (+ index 1))))
|
|
((= index len))
|
|
()
|
|
((var var))
|
|
. rest))))
|
|
|
|
|
|
;; this is an internal "accumulator". It is used for final tests
|
|
;; :final in goof differs from in racket. It is lexical, meaning it
|
|
;; is tested where it is placed in the clauses, and any subloop is
|
|
;; executed until exhaustion.
|
|
(define-syntax final
|
|
(syntax-rules (:acc)
|
|
((_ :acc ((var) (test)) n . rest)
|
|
(n ()
|
|
((var #f test))
|
|
()
|
|
()
|
|
()
|
|
. rest))))
|
|
|
|
;;; Here starts generator clauses.
|
|
|
|
(define (generator->list gen)
|
|
(let ((res (gen)))
|
|
(if (eof-object? res)
|
|
'()
|
|
(cons res (generator->list gen)))))
|
|
|
|
(define (generator-cycle gen)
|
|
(let ((circle (apply circular-list (generator->list gen))))
|
|
(lambda ()
|
|
(let ((res (car circle)))
|
|
(set! circle (cdr circle))
|
|
res))))
|
|
|
|
(define-syntax in-cycle
|
|
(syntax-rules ()
|
|
((_ :for ((id) (source)) n . rest)
|
|
(n ((gen (generator-cycle source)))
|
|
()
|
|
()
|
|
((id (gen)))
|
|
()
|
|
. rest))))
|
|
|
|
|
|
(define (generator-indexed gen)
|
|
(let ((i 0))
|
|
(lambda ()
|
|
(let ((res (gen)) (index i))
|
|
(if (eof-object? res)
|
|
(values res res)
|
|
(begin
|
|
(set! i (+ i 1))
|
|
(cons index res)))))))
|
|
|
|
(define-syntax in-indexed
|
|
(syntax-rules (:for)
|
|
((_ :for ((binding) (source)) n . rest)
|
|
(n ((gen (generator-indexed source)))
|
|
((i (gen) (gen)))
|
|
((eof-object? i))
|
|
((binding i))
|
|
()
|
|
. rest))))
|
|
|
|
(define (stop-before-generator gen pred)
|
|
(lambda ()
|
|
(let ((v (gen)))
|
|
(if (pred v)
|
|
(eof-object)
|
|
v))))
|
|
|
|
(define (stop-after-generator gen pred)
|
|
(let ((done? #f))
|
|
(lambda ()
|
|
(if done?
|
|
(eof-object)
|
|
(let ((v (gen)))
|
|
(when (pred v)
|
|
(set! done? #t))
|
|
v)))))
|
|
|
|
|
|
(define-syntax stop-before
|
|
(syntax-rules (:for)
|
|
((_ :for ((binding) (source pred)) n . rest)
|
|
(in-generator :for ((binding) (stop-before-generator source pred)) n . rest))
|
|
((_ expr pred)
|
|
(stop-before-generator expr pred))))
|
|
|
|
(define-syntax stop-after
|
|
(syntax-rules (:for)
|
|
((_ :for ((binding) (source pred)) n . rest)
|
|
(in-generator :for ((binding) (stop-after-generator source pred)) n . rest))
|
|
((_ expr pred) (stop-after-generator expr pred))))
|