@node SRFI 158, SRFI 219, SRFI 143, Standards Support
@section SRFI 158: Generators and Accumulators
@findex bytevector->generator
+@findex bytevector-accumulator
+@findex bytevector-accumulator!
@findex circular-generator
+@findex count-accumulator
@findex gappend
+@findex gcombine
@findex gcons*
@findex gdelete
+@findex gdelete-neighbor-dups
@findex gdrop
@findex gdrop-while
@findex generator
@findex generator->reverse-list
@findex generator->string
@findex generator->vector
+@findex generator->vector!
@findex generator-any
@findex generator-count
@findex generator-every
@findex generator-find
@findex generator-fold
-@findex generator-fold-right
@findex generator-for-each
@findex generator-map->list
@findex generator-unfold
@findex gfilter
@findex gflatten
+@findex ggroup
+@findex gindex
@findex gmap
+@findex gmerge
@findex gremove
+@findex gselect
+@findex gstate-filter
@findex gtake
@findex gtake-while
@findex list->generator
+@findex list-accumulator
+@findex make-accumulator
+@findex make-coroutine-generator
+@findex make-for-each-generator
@findex make-iota-generator
@findex make-range-generator
+@findex make-unfold-generator
+@findex product-accumulator
+@findex reverse-list-accumulator
@findex reverse-vector->generator
+@findex reverse-vector-accumulator
@findex string->generator
+@findex string-accumulator
+@findex sum-accumulator
@findex vector->generator
+@findex vector-accumulator
+@findex vector-accumulator!
@cartouche
@table @b
@item URL
@srfiurl{158}
@item Support
-Partially supported.
+Fully supported.
@item Libraries
-No libraries.
+@nicode{(srfi 158)}
@item Global
All names are bound in the @mitgnu{} global environment.
@end table
@multitable @columnfractions .5 .5
@item @nicode{bytevector->generator}
+@tab @nicode{bytevector-accumulator}
+@item @nicode{bytevector-accumulator!}
@tab @nicode{circular-generator}
-@item @nicode{gappend}
+@item @nicode{count-accumulator}
+@tab @nicode{gappend}
+@item @nicode{gcombine}
@tab @nicode{gcons*}
@item @nicode{gdelete}
-@tab @nicode{gdrop}
-@item @nicode{gdrop-while}
-@tab @nicode{generator}
-@item @nicode{generator->list}
-@tab @nicode{generator->reverse-list}
-@item @nicode{generator->string}
-@tab @nicode{generator->vector}
+@tab @nicode{gdelete-neighbor-dups}
+@item @nicode{gdrop}
+@tab @nicode{gdrop-while}
+@item @nicode{generator}
+@tab @nicode{generator->list}
+@item @nicode{generator->reverse-list}
+@tab @nicode{generator->string}
+@item @nicode{generator->vector}
+@tab @nicode{generator->vector!}
@item @nicode{generator-any}
@tab @nicode{generator-count}
@item @nicode{generator-every}
@tab @nicode{generator-find}
@item @nicode{generator-fold}
-@tab @nicode{generator-fold-right}
-@item @nicode{generator-for-each}
-@tab @nicode{generator-map->list}
-@item @nicode{generator-unfold}
-@tab @nicode{gfilter}
-@item @nicode{gflatten}
-@tab @nicode{gmap}
+@tab @nicode{generator-for-each}
+@item @nicode{generator-map->list}
+@tab @nicode{generator-unfold}
+@item @nicode{gfilter}
+@tab @nicode{gflatten}
+@item @nicode{ggroup}
+@tab @nicode{gindex}
+@item @nicode{gmap}
+@tab @nicode{gmerge}
@item @nicode{gremove}
+@tab @nicode{gselect}
+@item @nicode{gstate-filter}
@tab @nicode{gtake}
@item @nicode{gtake-while}
@tab @nicode{list->generator}
+@item @nicode{list-accumulator}
+@tab @nicode{make-accumulator}
+@item @nicode{make-coroutine-generator}
+@tab @nicode{make-for-each-generator}
@item @nicode{make-iota-generator}
@tab @nicode{make-range-generator}
-@item @nicode{reverse-vector->generator}
+@item @nicode{make-unfold-generator}
+@tab @nicode{product-accumulator}
+@item @nicode{reverse-list-accumulator}
+@tab @nicode{reverse-vector->generator}
+@item @nicode{reverse-vector-accumulator}
@tab @nicode{string->generator}
+@item @nicode{string-accumulator}
+@tab @nicode{sum-accumulator}
@item @nicode{vector->generator}
+@tab @nicode{vector-accumulator}
+@item @nicode{vector-accumulator!}
@end multitable
@node SRFI 219, , SRFI 158, Standards Support
(declare (usual-integrations))
\f
+;;;; Generator Constructors
+
(define (generator . args)
(lambda ()
(if (pair? args)
(set! start (+ start step))
v)
(eof-object)))))))
-\f
+
(define (list->generator items)
(lambda ()
(if (null-list? items 'list->generator)
(set! index (fix:+ index 1))
next)
(eof-object)))))
-
+\f
(define (reverse-vector->generator v #!optional start end)
(let* ((end (fix:end-index end (vector-length v) 'reverse-vector->generator))
(start (fix:start-index start end 'reverse-vector->generator))
(index start))
(lambda ()
(if (fix:< index end)
- (let ((next (bytevector-u8-ref string index)))
+ (let ((next (bytevector-u8-ref bv index)))
(set! index (fix:+ index 1))
next)
(eof-object)))))
+
+(define (make-coroutine-generator proc)
+ (let ((return #f)
+ (resume #f))
+
+ (define (yield v)
+ (call/cc
+ (lambda (k)
+ (set! resume k)
+ (return v))))
+
+ (lambda ()
+ (call/cc
+ (lambda (cc)
+ (set! return cc)
+ (if resume
+ (resume unspecific)
+ (begin
+ (proc yield)
+ (set! resume
+ (lambda (v)
+ (declare (ignore v))
+ (return (eof-object))))
+ (return (eof-object)))))))))
+
+(define (make-for-each-generator for-each object)
+ (make-coroutine-generator
+ (lambda (yield)
+ (for-each yield object))))
+
+(define (make-unfold-generator stop? mapper successor seed)
+ (make-coroutine-generator
+ (lambda (yield)
+ (let loop ((s seed))
+ (if (not (stop? s))
+ (begin
+ (yield (mapper s))
+ (loop (successor s))))))))
\f
+;;;; Generator Operations
+
(define (gcons* . args)
(if (pair? args)
(let ((first (car args))
(set! state (cdr state))
next))))
gflatten-generator))
+
+(define (ggroup gen k #!optional padding)
+ (guarantee exact-nonnegative-integer? k 'ggroup)
+ (named-lambda (ggroup-generator)
+ (let loop ((i 0) (result '()))
+ (if (< i k)
+ (let ((item (gen)))
+ (if (eof-object? item)
+ (if (> i 0)
+ (let ((result (reverse result)))
+ (if (default-object? padding)
+ result
+ (append result (make-list (- k i) padding))))
+ item)
+ (loop (+ i 1) (cons item result))))
+ (reverse result)))))
+\f
+(define (gmerge < gen . gens)
+
+ (define (restart gens)
+ (cond ((null? (cdr gens)) (car gens))
+ ((null? (cddr gens)) (case-2 (car gens) (cadr gens)))
+ (else (case-n gens))))
+
+
+ (define (case-2 gen-left gen-right)
+ (let ((left (gen-left))
+ (right (gen-right)))
+ (lambda ()
+ (cond ((and (eof-object? left)
+ (eof-object? right))
+ left)
+ ((eof-object? left)
+ (let ((obj right))
+ (set! right (gen-right))
+ obj))
+ ((eof-object? right)
+ (let ((obj left))
+ (set! left (gen-left))
+ obj))
+ ((< right left)
+ (let ((obj right))
+ (set! right (gen-right))
+ obj))
+ (else
+ (let ((obj left))
+ (set! left (gen-left))
+ obj))))))
+
+ (define (case-n gens)
+ (restart
+ (let loop ((gens gens) (paired '()))
+ (cond ((null? gens)
+ (reverse paired))
+ ((null? (cdr gens))
+ (reverse (cons (car gens) paired)))
+ (else
+ (loop (cddr gens)
+ (cons (case-2 (car gens) (cadr gens))
+ paired)))))))
+
+ (restart (cons gen gens)))
+
+(define (gmap procedure gen . gens)
+ (cond ((null? gens)
+ (named-lambda (gmap-generator-1)
+ (let ((v (gen)))
+ (if (eof-object? v)
+ v
+ (procedure v)))))
+ ((null? (cdr gens))
+ (let ((gen2 (car gens)))
+ (named-lambda (gmap-generator-2)
+ (let ((v1 (gen))
+ (v2 (gen2)))
+ (if (or (eof-object? v1) (eof-object? v2))
+ (eof-object)
+ (procedure v1 v2))))))
+ (else
+ (let ((gens (cons gen gens)))
+ (named-lambda (gmap-generator-n)
+ (let ((vs (map (lambda (gen) (gen)) gens)))
+ (if (any eof-object? vs)
+ (eof-object)
+ (apply procedure vs))))))))
+
+(define (gcombine procedure seed gen . gens)
+ (define (gcombine-generator)
+ (let ((items (map (lambda (x) (x)) (cons gen gens))))
+ (if (any eof-object? items)
+ (eof-object)
+ (let-values (((value newseed)
+ (apply procedure (append items (list seed)))))
+ (set! seed newseed)
+ value))))
+ gcombine-generator)
+\f
+(define (gfilter predicate gen)
+ (define (gfilter-generator)
+ (let ((v (gen)))
+ (if (or (eof-object? v)
+ (predicate v))
+ v
+ (gfilter-generator))))
+ gfilter-generator)
+
+(define (gremove predicate gen)
+ (define (gremove-generator)
+ (let ((v (gen)))
+ (if (or (eof-object? v)
+ (not (predicate v)))
+ v
+ (gremove-generator))))
+ gremove-generator)
+
+(define (gstate-filter procedure seed gen)
+ (let ((state seed))
+ (define (gstate-filter-generator)
+ (let ((item (gen)))
+ (if (eof-object? item)
+ item
+ (let-values (((yes newstate) (procedure item state)))
+ (set! state newstate)
+ (if yes
+ item
+ (gstate-filter-generator))))))
+ gstate-filter-generator))
+
+(define (gtake gen k #!optional padding)
+ (guarantee exact-nonnegative-integer? k 'gtake)
+ (if (default-object? padding)
+ (named-lambda (gtake-generator)
+ (if (> k 0)
+ (begin
+ (set! k (- k 1))
+ (gen))
+ (eof-object)))
+ (named-lambda (gtake-with-padding-generator)
+ (if (> k 0)
+ (begin
+ (set! k (- k 1))
+ (let ((v (gen)))
+ (if (eof-object? v)
+ padding
+ v)))
+ (eof-object)))))
+
+(define (gdrop gen k)
+ (guarantee exact-nonnegative-integer? k 'gdrop)
+ (define (gdrop-generator)
+ (if (> k 0)
+ (begin
+ (set! k (- k 1))
+ (gen)
+ (gdrop-generator))
+ (gen)))
+ gdrop-generator)
\f
+(define (gtake-while predicate gen)
+ (let ((found #f))
+ (define (gtake-while-generator)
+ (if found
+ (eof-object)
+ (let ((v (gen)))
+ (if (or (eof-object? v)
+ (not (predicate v)))
+ (begin
+ (set! found #t)
+ (eof-object))
+ v))))
+ gtake-while-generator))
+
+(define (gdrop-while predicate gen)
+ (let ((found #f))
+ (define (gdrop-while-generator)
+ (if found
+ (gen)
+ (let loop ()
+ (let ((v (gen)))
+ (if (or (eof-object? v)
+ (not (predicate v)))
+ (begin
+ (set! found #t)
+ v)
+ (loop))))))
+ gdrop-while-generator))
+
+(define (gdelete item gen #!optional =)
+ (gremove (let ((= (if (default-object? =) equal? =)))
+ (lambda (val)
+ (= item val)))
+ gen))
+
+(define (gdelete-neighbor-dups gen #!optional =)
+ (let ((first-time? #t)
+ (prev #f)
+ (= (if (default-object? =) equal? =)))
+ (define (gdelete-neighbor-dups-generator)
+ (if first-time?
+ (begin
+ (set! first-time? #f)
+ (set! prev (gen))
+ prev)
+ (let loop ((v (gen)))
+ (cond ((eof-object? v)
+ v)
+ ((= prev v)
+ (loop (gen)))
+ (else
+ (set! prev v)
+ v)))))
+ gdelete-neighbor-dups-generator))
+\f
+(define (gindex value-gen index-gen)
+ (let ((done? #f)
+ (count 0))
+ (define (gindex-generator)
+ (if done?
+ (eof-object)
+ (let loop
+ ((value (value-gen))
+ (index (index-gen)))
+ (cond ((or (eof-object? value) (eof-object? index))
+ (set! done? #t)
+ (eof-object))
+ ((= index count)
+ (set! count (+ count 1))
+ value)
+ (else
+ (set! count (+ count 1))
+ (loop (value-gen) index))))))
+ gindex-generator))
+
+(define (gselect value-gen truth-gen)
+ (let ((done? #f))
+ (define (gselect-generator)
+ (if done?
+ (eof-object)
+ (let loop
+ ((value (value-gen))
+ (truth (truth-gen)))
+ (cond ((or (eof-object? value) (eof-object? truth))
+ (set! done? #t)
+ (eof-object))
+ (truth value)
+ (else (loop (value-gen) (truth-gen)))))))
+ gselect-generator))
+
+(define (gpeeker gen)
+ (let ((next #f))
+
+ (define (object-ready?)
+ (if (not next)
+ (set! next (gen)))
+ (not (eof-object? next)))
+
+ ;; Assumes that (object-ready?) is #t.
+ (define (peek-object)
+ next)
+
+ ;; Assumes that (object-ready?) is #t.
+ (define (read-object)
+ (let ((object next))
+ (set! next #f)
+ object))
+
+ (values object-ready? peek-object read-object)))
+\f
+;;;; Consuming Generator Values
+
(define (generator->list gen #!optional n)
(generator-fold-right cons '()
(if (default-object? n)
(define (generator->vector gen #!optional n)
(list->vector (generator->list gen n)))
+(define (generator->vector! vector at gen)
+ (let* ((end (vector-length vector))
+ (start (fix:start-index at end 'generator->vector!))
+ (n (fix:- end start)))
+ (let loop ((value (gen)) (i 0))
+ (if (or (eof-object? value)
+ (not (fix:< i n)))
+ i
+ (begin
+ (vector-set! vector (fix:+ start i) value)
+ (loop (gen) (fix:+ i 1)))))))
+
(define (generator->string gen #!optional n)
(list->string (generator->list gen n)))
-\f
+
(define (generator-fold kons knil gen . gens)
(cond ((null? gens)
(let loop ((acc knil))
(if (any eof-object? vs)
knil
(kons (apply procedure vs) (loop)))))))))
-
-(define (generator-unfold gen unfold . args)
- (apply unfold
- eof-object?
- (lambda (x) x)
- (lambda (x) (declare (ignore x)) (gen))
- (gen)
- args))
\f
-(define (gmap procedure gen . gens)
- (cond ((null? gens)
- (named-lambda (gmap-generator-1)
- (let ((v (gen)))
- (if (eof-object? v)
- v
- (procedure v)))))
- ((null? (cdr gens))
- (let ((gen2 (car gens)))
- (named-lambda (gmap-generator-2)
- (let ((v1 (gen))
- (v2 (gen2)))
- (if (or (eof-object? v1) (eof-object? v2))
- (eof-object)
- (procedure v1 v2))))))
- (else
- (let ((gens (cons gen gens)))
- (named-lambda (gmap-generator-n)
- (let ((vs (map (lambda (gen) (gen)) gens)))
- (if (any eof-object? vs)
- (eof-object)
- (apply procedure vs))))))))
-
-(define (generator-map->list procedure gen . gens)
- (apply generator-fold-right-map cons '() procedure gen gens))
-
(define (generator-for-each procedure gen . gens)
(cond ((null? gens)
(let loop ()
(begin
(apply procedure vs)
(loop)))))))))
-\f
+
+(define (generator-map->list procedure gen . gens)
+ (apply generator-fold-right-map cons '() procedure gen gens))
+
(define (generator-find predicate gen)
(let loop ()
(let ((v (gen)))
- (if (or (eof-object? v) (predicate v))
- v
- (loop)))))
+ (cond ((eof-object? v) #f)
+ ((predicate v) v)
+ (else (loop))))))
(define (generator-count predicate gen)
(let loop ((n 0))
(and this
(loop this)))))))
-(define (gfilter predicate gen)
- (define (gfilter-generator)
- (let ((v (gen)))
- (if (or (eof-object? v)
- (predicate v))
- v
- (gfilter-generator))))
- gfilter-generator)
-
-(define (gremove predicate gen)
- (define (gremove-generator)
- (let ((v (gen)))
- (if (or (eof-object? v)
- (not (predicate v)))
- v
- (gremove-generator))))
- gremove-generator)
-\f
-(define (gtake gen k #!optional padding)
- (guarantee exact-nonnegative-integer? k 'gtake)
- (if (eof-object? padding)
- (named-lambda (gtake-generator)
- (if (> k 0)
- (begin
- (set! k (- k 1))
- (gen))
- (eof-object)))
- (named-lambda (gtake-with-padding-generator)
- (if (> k 0)
- (begin
- (set! k (- k 1))
- (let ((v (gen)))
- (if (eof-object? v)
- padding
- v)))
- (eof-object)))))
-
-(define (gdrop gen k)
- (guarantee exact-nonnegative-integer? k 'gdrop)
- (define (gdrop-generator)
- (if (> k 0)
- (begin
- (set! k (- k 1))
- (gen)
- (gdrop-generator))
- (gen)))
- gdrop-generator)
-
-(define (gtake-while predicate gen)
- (let ((found #f))
- (lambda ()
- (if found
- (eof-object)
- (let ((v (gen)))
- (if (or (eof-object? v)
- (not (predicate v)))
- (begin
- (set! found #t)
- (eof-object))
- v))))))
-
-(define (gdrop-while predicate gen)
- (let ((found #f))
- (lambda ()
- (if found
- (gen)
- (let loop ()
- (let ((v (gen)))
- (if (or (eof-object? v)
- (not (predicate v)))
- (begin
- (set! found #t)
- v)
- (loop))))))))
-
-(define (gdelete item gen #!optional =)
- (gremove (let ((= (if (default-object? =) equal? =)))
- (lambda (val)
- (= item val)))
- gen))
+(define (generator-unfold gen unfold . args)
+ (apply unfold
+ eof-object?
+ (lambda (x) x)
+ (lambda (x) (declare (ignore x)) (gen))
+ (gen)
+ args))
\f
-(define (gpeeker gen)
- (let ((next #f))
-
- (define (object-ready?)
- (if (not next)
- (set! next (gen)))
- (not (eof-object? next)))
-
- ;; Assumes that (object-ready?) is #t.
- (define (peek-object)
- next)
-
- ;; Assumes that (object-ready?) is #t.
- (define (read-object)
- (let ((object next))
- (set! next #f)
- object))
-
- (values object-ready? peek-object read-object)))
\ No newline at end of file
+;;;; Accumulator Constructors
+
+(define (make-accumulator kons knil finalize)
+ (let ((state knil))
+ (define (accumulator-proc obj)
+ (if (eof-object? obj)
+ (finalize state)
+ (begin
+ (set! state (kons obj state))
+ unspecific)))
+ accumulator-proc))
+
+(define (count-accumulator)
+ (make-accumulator (lambda (obj state)
+ (declare (ignore obj))
+ (+ state 1))
+ 0
+ (lambda (x) x)))
+
+(define (list-accumulator)
+ (make-accumulator cons '() reverse))
+
+(define (reverse-list-accumulator)
+ (make-accumulator cons '() (lambda (x) x)))
+
+(define (vector-accumulator)
+ (make-accumulator cons '()
+ (lambda (x) (list->vector (reverse x)))))
+
+(define (reverse-vector-accumulator)
+ (make-accumulator cons '() list->vector))
+
+(define (vector-accumulator! vector at)
+ (let* ((end (vector-length vector))
+ (i (fix:start-index at end 'vector-accumulator!)))
+ (define (vector-accumulator!-proc obj)
+ (if (eof-object? obj)
+ vector
+ (begin
+ (if (not (fix:< i end))
+ (error "Trying to accumulate past end of vector"))
+ (vector-set! vector i obj)
+ (set! i (fix:+ i 1))
+ unspecific)))
+ vector-accumulator!-proc))
+
+(define (string-accumulator)
+ (make-accumulator cons '() (lambda (x) (list->string (reverse x)))))
+
+(define (bytevector-accumulator)
+ (make-accumulator cons '() (lambda (x) (list->bytevector (reverse x)))))
+
+(define (bytevector-accumulator! bytes at)
+ (let* ((end (bytevector-length bytes))
+ (i (fix:start-index at end 'bytevector-accumulator!)))
+ (define (bytevector-accumulator!-proc obj)
+ (if (eof-object? obj)
+ bytes
+ (begin
+ (if (not (fix:< i end))
+ (error "Trying to accumulate past end of bytevector"))
+ (bytevector-u8-set! bytes i obj)
+ (set! i (fix:+ i 1))
+ unspecific)))
+ bytevector-accumulator!-proc))
+
+(define (sum-accumulator)
+ (make-accumulator + 0 (lambda (x) x)))
+
+(define (product-accumulator)
+ (make-accumulator * 1 (lambda (x) x)))
\ No newline at end of file
fxxor
fxzero?))
\f
+(define-standard-library '(srfi 158)
+ '(bytevector->generator
+ bytevector-accumulator
+ bytevector-accumulator!
+ circular-generator
+ count-accumulator
+ gappend
+ gcombine
+ gcons*
+ gdelete
+ gdelete-neighbor-dups
+ gdrop
+ gdrop-while
+ generator
+ generator->list
+ generator->reverse-list
+ generator->string
+ generator->vector
+ generator->vector!
+ generator-any
+ generator-count
+ generator-every
+ generator-find
+ generator-fold
+ generator-for-each
+ generator-map->list
+ generator-unfold
+ gfilter
+ gflatten
+ ggroup
+ gindex
+ gmap
+ gmerge
+ gremove
+ gselect
+ gstate-filter
+ gtake
+ gtake-while
+ list->generator
+ list-accumulator
+ make-accumulator
+ make-coroutine-generator
+ make-for-each-generator
+ make-iota-generator
+ make-range-generator
+ make-unfold-generator
+ product-accumulator
+ reverse-list-accumulator
+ reverse-vector->generator
+ reverse-vector-accumulator
+ string->generator
+ string-accumulator
+ sum-accumulator
+ vector->generator
+ vector-accumulator
+ vector-accumulator!))
+\f
;;;; Synthetic libraries
;;; A synthetic library is one that's derived from legacy packages, much like a
(parent (runtime))
(export ()
bytevector->generator ;(srfi 158)
+ bytevector-accumulator ;(srfi 158)
+ bytevector-accumulator! ;(srfi 158)
circular-generator ;(srfi 158)
+ count-accumulator ;(srfi 158)
gappend ;(srfi 158)
+ gcombine ;(srfi 158)
gcons* ;(srfi 158)
gdelete ;(srfi 158)
+ gdelete-neighbor-dups ;(srfi 158)
gdrop ;(srfi 158)
gdrop-while ;(srfi 158)
generator ;(srfi 158)
generator->reverse-list ;(srfi 158)
generator->string ;(srfi 158)
generator->vector ;(srfi 158)
+ generator->vector! ;(srfi 158)
generator-any ;(srfi 158)
generator-count ;(srfi 158)
generator-every ;(srfi 158)
generator-find ;(srfi 158)
generator-fold ;(srfi 158)
generator-fold-map
- generator-fold-right ;(srfi 158)
+ generator-fold-right
generator-fold-right-map
generator-for-each ;(srfi 158)
generator-map->list ;(srfi 158)
generator-unfold ;(srfi 158)
gfilter ;(srfi 158)
gflatten ;(srfi 158)
+ ggroup ;(srfi 158)
+ gindex ;(srfi 158)
gmap ;(srfi 158)
+ gmerge ;(srfi 158)
gpeeker
gremove ;(srfi 158)
+ gselect ;(srfi 158)
+ gstate-filter ;(srfi 158)
gtake ;(srfi 158)
gtake-while ;(srfi 158)
list->generator ;(srfi 158)
+ list-accumulator ;(srfi 158)
+ make-accumulator ;(srfi 158)
+ make-coroutine-generator ;(srfi 158)
+ make-for-each-generator ;(srfi 158)
make-iota-generator ;(srfi 158)
make-range-generator ;(srfi 158)
+ make-unfold-generator ;(srfi 158)
+ product-accumulator ;(srfi 158)
+ reverse-list-accumulator ;(srfi 158)
reverse-vector->generator ;(srfi 158)
+ reverse-vector-accumulator ;(srfi 158)
string->generator ;(srfi 158)
+ string-accumulator ;(srfi 158)
+ sum-accumulator ;(srfi 158)
vector->generator ;(srfi 158)
+ vector-accumulator ;(srfi 158)
+ vector-accumulator! ;(srfi 158)
))
(define-package (runtime weak-pair)
"runtime/test-flonum"
"runtime/test-flonum.bin"
"runtime/test-flonum.com"
+ "runtime/test-generator"
"runtime/test-hash-table"
"runtime/test-ieee754"
"runtime/test-integer-bits"
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019, 2020, 2021, 2022 Massachusetts Institute of
+ Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of generators
+
+(declare (usual-integrations))
+\f
+(define (for-each-digit proc n)
+ (when (> n 0)
+ (let-values (((div rem) (truncate/ n 10)))
+ (proc rem)
+ (for-each-digit proc div))))
+
+(define (small? x)
+ (< x 3))
+
+(define-test 'constructors
+ (lambda ()
+ (assert-equal (generator->list (generator))
+ '())
+ (assert-equal (generator->list (generator 1 2 3))
+ '(1 2 3))
+ (assert-equal (generator->list (circular-generator 1 2 3) 5)
+ '(1 2 3 1 2))
+ (assert-equal (generator->list (make-iota-generator 3 8))
+ '(8 9 10))
+ (assert-equal (generator->list (make-iota-generator 3 8 2))
+ '(8 10 12))
+ (assert-equal (generator->list (make-range-generator 3) 4)
+ '(3 4 5 6))
+ (assert-equal (generator->list (make-range-generator 3 8))
+ '(3 4 5 6 7))
+ (assert-equal (generator->list (make-range-generator 3 8 2))
+ '(3 5 7))
+
+ (let ((g
+ (make-coroutine-generator
+ (lambda (yield)
+ (let loop ((i 0))
+ (when (< i 3)
+ (yield i)
+ (loop (+ i 1))))))))
+ (assert-equal (generator->list g)
+ '(0 1 2)))
+
+ (assert-equal (generator->list (list->generator '(1 2 3 4 5)))
+ '(1 2 3 4 5))
+ (assert-equal (generator->list (vector->generator '#(1 2 3 4 5)))
+ '(1 2 3 4 5))
+ (assert-equal (let ((v (make-vector 5 0)))
+ (generator->vector! v 2 (generator 1 2 4))
+ v)
+ '#(0 0 1 2 4))
+ (assert-equal (generator->list (reverse-vector->generator '#(1 2 3 4 5)))
+ '(5 4 3 2 1))
+ (assert-equal (generator->list (string->generator "abcde"))
+ '(#\a #\b #\c #\d #\e))
+ (assert-equal (generator->list
+ (bytevector->generator (bytevector 10 20 30)))
+ '(10 20 30))
+
+ (assert-equal (generator->list
+ (make-for-each-generator for-each-digit 12345))
+ '(5 4 3 2 1))
+ (assert-equal (generator->list
+ (make-unfold-generator
+ (lambda (s) (> s 5))
+ (lambda (s) (* s 2))
+ (lambda (s) (+ s 1))
+ 0))
+ '(0 2 4 6 8 10))))
+\f
+(define-test 'operators
+ (lambda ()
+ (assert-equal (generator->list (gcons* 'a 'b (make-range-generator 0 2)))
+ '(a b 0 1))
+ (assert-equal (generator->list (gappend (make-range-generator 0 3)
+ (make-range-generator 0 2)))
+ '(0 1 2 0 1))
+ (assert-equal (generator->list (gappend))
+ '())
+
+ (assert-equal (generator->list
+ (gcombine (lambda args
+ (values (apply + args) (apply + args)))
+ 10
+ (generator 1 2 3)
+ (generator 4 5 6 7)))
+ '(15 22 31))
+
+ (assert-equal (generator->list (gfilter odd? (make-range-generator 1 11)))
+ '(1 3 5 7 9))
+ (assert-equal (generator->list (gremove odd? (make-range-generator 1 11)))
+ '(2 4 6 8 10))
+
+ (let ((g (make-range-generator 1 5)))
+ (assert-equal (generator->list (gtake g 3))
+ '(1 2 3))
+ (assert-equal (generator->list g)
+ '(4)))
+
+ (assert-equal (generator->list (gtake (make-range-generator 1 3) 3))
+ '(1 2))
+ (assert-equal (generator->list (gtake (make-range-generator 1 3) 3 0))
+ '(1 2 0))
+ (assert-equal (generator->list (gdrop (make-range-generator 1 5) 2))
+ '(3 4))
+
+ (assert-equal (generator->list
+ (gtake-while small? (make-range-generator 1 5)))
+ '(1 2))
+ (assert-equal (generator->list
+ (gdrop-while small? (make-range-generator 1 5)))
+ '(3 4))
+
+ (assert-equal (generator->list
+ (gdrop-while (lambda args (declare (ignore args)) #t)
+ (generator 1 2 3)))
+ '())
+ (assert-equal (generator->list
+ (gdelete 1
+ (generator 0.0 1.0 0 1 2)))
+ '(0.0 1.0 0 2))
+ (assert-equal (generator->list
+ (gdelete 1
+ (generator 0.0 1.0 0 1 2)
+ =))
+ '(0.0 0 2))
+ (assert-equal (generator->list
+ (gindex (list->generator '(a b c d e f))
+ (list->generator '(0 2 4))))
+ '(a c e))
+ (assert-equal (generator->list
+ (gselect (list->generator '(a b c d e f))
+ (list->generator '(#t #f #f #t #t #f))))
+ '(a d e))
+ (assert-equal (generator->list
+ (gdelete-neighbor-dups (generator 1 1 2 3 3 3)
+ =))
+ '(1 2 3))
+ (assert-equal (generator->list
+ (gdelete-neighbor-dups (generator 1 2 3)
+ (lambda args
+ (declare (ignore args))
+ #t)))
+ '(1))
+ (assert-equal (generator->list
+ (gflatten (generator '(1 2 3) '(a b c))))
+ '(1 2 3 a b c))
+ (assert-equal (generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3))
+ '((1 2 3) (4 5 6) (7 8)))
+ (assert-equal (generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3 0))
+ '((1 2 3) (4 5 6) (7 8 0)))
+ (assert-equal (generator->list (gmerge < (generator 1 2 3)))
+ '(1 2 3))
+ (assert-equal (generator->list
+ (gmerge < (generator 1 2 3) (generator 4 5 6)))
+ '(1 2 3 4 5 6))
+ (assert-equal (generator->list (gmerge <
+ (generator 1 2 4 6)
+ (generator)
+ (generator 3 4 5)))
+ '(1 2 3 4 4 5 6))
+ (assert-equal (generator->list (gmerge <
+ (generator 1 10 11)
+ (generator 2 9 12)
+ (generator 3 8 13)
+ (generator 4 7 14)
+ (generator 5 6 15)))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))
+ ;; check the tie-break rule
+ (assert-equal (generator->list (gmerge (lambda (x y) (< (car x) (car y)))
+ (generator '(1 a) '(1 e))
+ (generator '(1 b))
+ (generator '(1 c) '(1 d))))
+ '((1 a) (1 e) (1 b) (1 c) (1 d)))
+
+ (assert-equal (generator->list (gmap - (generator 1 2 3 4 5)))
+ '(-1 -2 -3 -4 -5))
+ (assert-equal (generator->list (gmap +
+ (generator 1 2 3 4 5)
+ (generator 6 7 8 9)))
+ '(7 9 11 13))
+ (assert-equal (generator->list (gmap *
+ (generator 1 2 3 4 5)
+ (generator 6 7 8)
+ (generator 9 10 11 12 13)))
+ '(54 140 264))
+ (assert-equal (generator->list
+ (gstate-filter
+ (lambda (item state)
+ (declare (ignore item))
+ (values (even? state) (+ 1 state)))
+ 0
+ (generator 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j)))
+ '(a c e g i))))
+\f
+(define-test 'consumers
+ (lambda ()
+ ;; no test for plain generator->list (used throughout)
+ (assert-equal (generator->list (generator 1 2 3 4 5) 3)
+ '(1 2 3))
+ (assert-equal (generator->reverse-list (generator 1 2 3 4 5))
+ '(5 4 3 2 1))
+ (assert-equal (generator->vector (generator 1 2 3 4 5))
+ '#(1 2 3 4 5))
+ (assert-equal (generator->vector (generator 1 2 3 4 5) 3)
+ '#(1 2 3))
+ (assert-equal (generator->string (generator #\a #\b #\c))
+ "abc")
+ (assert-equal (call-with-input-string "a b c d e"
+ (lambda (port)
+ (generator-fold cons 'z (lambda () (read port)))))
+ '(e d c b a . z))
+
+ (let ((n))
+ (generator-for-each (lambda values
+ (set! n (apply + values))
+ unspecific)
+ (generator 1)
+ (generator 2)
+ (generator 3))
+ (assert-equal n 6))
+
+ (assert-equal (generator-map->list (lambda values (apply + values))
+ (generator 1 4)
+ (generator 2 5)
+ (generator 3 6))
+ '(6 15))
+ (assert-equal (generator-find (lambda (x) (> x 2))
+ (make-range-generator 1 5))
+ 3)
+ (assert-equal (generator-find (lambda (x) (> x 10))
+ (make-range-generator 1 5))
+ #f)
+ (assert-equal (generator-count odd? (make-range-generator 1 5))
+ 2)
+ (let ((g (make-range-generator 2 5)))
+ (assert-equal (generator-any odd? g)
+ #t)
+ (assert-equal (generator->list g)
+ '(4)))
+ (assert-equal (generator-any (lambda (x) (and (odd? x) x))
+ (make-range-generator 2 5))
+ 3)
+ (let ((g (make-range-generator 2 5)))
+ (assert-equal (generator-every odd? g)
+ #f)
+ (assert-equal (generator->list g)
+ '(3 4)))
+ (let ((g (make-range-generator 2 5)))
+ (assert-equal (generator-every (lambda (x) (and (> x 1) x)) g)
+ 4)
+ (assert-equal (generator->list g)
+ '()))
+ (assert-equal (generator-unfold
+ (make-for-each-generator string-for-each "abc")
+ unfold)
+ '(#\a #\b #\c))))
+\f
+(define-test 'accumulators
+ (lambda ()
+
+ (define (run-accum a . vals)
+ (for-each a vals)
+ (a (eof-object)))
+
+ (define (accum-test a expected)
+ (assert-equal (run-accum a 1 2 4)
+ expected))
+
+ (accum-test (make-accumulator * 1 -) -8)
+
+ (accum-test (count-accumulator)
+ 3)
+
+ (accum-test (list-accumulator)
+ '(1 2 4))
+
+ (accum-test (reverse-list-accumulator)
+ '(4 2 1))
+
+ (accum-test (vector-accumulator)
+ '#(1 2 4))
+
+ (accum-test (vector-accumulator! (vector 0 0 0 0 0) 2)
+ '#(0 0 1 2 4))
+
+ (accum-test (bytevector-accumulator! (bytevector 0 0 0 0 0) 2)
+ '#u8(0 0 1 2 4))
+
+ (accum-test (reverse-vector-accumulator)
+ '#(4 2 1))
+
+ (assert-equal (run-accum (string-accumulator) #\a #\b #\c)
+ "abc")
+
+ (accum-test (bytevector-accumulator)
+ '#u8(1 2 4))
+
+ (accum-test (sum-accumulator)
+ 7)
+
+ (accum-test (product-accumulator)
+ 8)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff