* [PATCH] Add SRFI-41
@ 2013-03-21 0:38 Mark H Weaver
2013-03-21 8:55 ` Andy Wingo
0 siblings, 1 reply; 6+ messages in thread
From: Mark H Weaver @ 2013-03-21 0:38 UTC (permalink / raw)
To: guile-devel; +Cc: Chris K. Jester-Young
[-- Attachment #1: Type: text/plain, Size: 396 bytes --]
Hello all,
Chris K. Jester-Young has been hard at work getting his SRFI-41
implementation ready in time for Guile 2.0.8, and I think it might be
ready to push. What do you think?
Reviews solicited.
Mark
PS: Although I put cky's name on this commit (he's certainly the primary
author), I made some tweaks to it since he last looked at it which
he may or may not approve of :)
[-- Attachment #2: [PATCH] Add SRFI-41 --]
[-- Type: text/x-diff, Size: 54125 bytes --]
From 6d05076bdc88e6d5be479a9446120c6c62fe6f60 Mon Sep 17 00:00:00 2001
From: "Chris K. Jester-Young" <cky944@gmail.com>
Date: Wed, 20 Mar 2013 20:14:18 -0400
Subject: [PATCH] Add SRFI-41.
Incorporates suggestions from Mark H Weaver <mhw@netris.org>
and Ian Price <ianprice90@googlemail.com>.
* module/srfi/srfi-41.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-41.scm.
* test-suite/tests/srfi-41.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-41.test.
---
module/Makefile.am | 1 +
module/srfi/srfi-41.scm | 478 ++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-41.test | 657 +++++++++++++++++++++++++++++++++++++++++
4 files changed, 1137 insertions(+)
create mode 100644 module/srfi/srfi-41.scm
create mode 100644 test-suite/tests/srfi-41.test
diff --git a/module/Makefile.am b/module/Makefile.am
index c47d0b4..416ad22 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -282,6 +282,7 @@ SRFI_SOURCES = \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
+ srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm
new file mode 100644
index 0000000..16596ce
--- /dev/null
+++ b/module/srfi/srfi-41.scm
@@ -0,0 +1,478 @@
+;;; srfi-41.scm -- SRFI 41 streams
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (stream-null stream-cons stream? stream-null? stream-pair?
+ stream-car stream-cdr stream-lambda define-stream
+ list->stream port->stream stream stream->list stream-append
+ stream-concat stream-constant stream-drop stream-drop-while
+ stream-filter stream-fold stream-for-each stream-from
+ stream-iterate stream-length stream-let stream-map
+ stream-match stream-of stream-range stream-ref stream-reverse
+ stream-scan stream-take stream-take-while stream-unfold
+ stream-unfolds stream-zip))
+
+;;; Private supporting functions and macros.
+
+(define-syntax-rule (must pred obj func msg args ...)
+ (let ((item obj))
+ (unless (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-not pred obj func msg args ...)
+ (let ((item obj))
+ (when (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-every pred objs func msg args ...)
+ (let ((flunk (remove pred objs)))
+ (unless (null? flunk)
+ (throw 'wrong-type-arg func msg (list args ...) flunk))))
+
+(define-syntax-rule (first-value expr)
+ (receive (first . _) expr
+ first))
+
+(define-syntax-rule (second-value expr)
+ (receive (first second . _) expr
+ second))
+
+(define-syntax-rule (third-value expr)
+ (receive (first second third . _) expr
+ third))
+
+(define-syntax define-syntax*
+ (syntax-rules ()
+ ((_ (name . args) body ...)
+ (define-syntax name (lambda* args body ...)))
+ ((_ name syntax)
+ (define-syntax name syntax))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Here we include a copy of the code of srfi-45.scm (but with renamed
+;; identifiers), in order to create a new promise type that's disjoint
+;; from the promises created by srfi-45. Ideally this should be done
+;; using a 'make-promise-type' macro that instantiates a copy of this
+;; code, but a psyntax bug in Guile 2.0 prevents this from working
+;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the
+;; code.
+
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-record-type stream-promise (make-stream-promise val) stream-promise?
+ (val stream-promise-val stream-promise-val-set!))
+
+(define-record-type stream-value (make-stream-value tag proc) stream-value?
+ (tag stream-value-tag stream-value-tag-set!)
+ (proc stream-value-proc stream-value-proc-set!))
+
+(define-syntax-rule (stream-lazy exp)
+ (make-stream-promise (make-stream-value 'lazy (lambda () exp))))
+
+(define (stream-eager . xs)
+ (make-stream-promise (make-stream-value 'eager xs)))
+
+(define-syntax-rule (stream-delay exp)
+ (stream-lazy (call-with-values
+ (lambda () exp)
+ stream-eager)))
+
+(define (stream-force promise)
+ (let ((content (stream-promise-val promise)))
+ (case (stream-value-tag content)
+ ((eager) (apply values (stream-value-proc content)))
+ ((lazy) (let* ((promise* ((stream-value-proc content)))
+ (content (stream-promise-val promise)))
+ (if (not (eqv? (stream-value-tag content) 'eager))
+ (begin (stream-value-tag-set! content
+ (stream-value-tag (stream-promise-val promise*)))
+ (stream-value-proc-set! content
+ (stream-value-proc (stream-promise-val promise*)))
+ (stream-promise-val-set! promise* content)))
+ (stream-force promise))))))
+
+;;
+;; End of the copy of the code from srfi-45.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Primitive stream functions and macros: (streams primitive)
+
+(define stream? stream-promise?)
+
+(define %stream-null '(stream . null))
+(define stream-null (stream-eager %stream-null))
+
+(define (stream-null? obj)
+ (and (stream-promise? obj)
+ (eqv? (stream-force obj) %stream-null)))
+
+(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
+ (kar stream-kar)
+ (kdr stream-kdr))
+
+(define (stream-pair? obj)
+ (and (stream-promise? obj) (stream-pare? (stream-force obj))))
+
+(define-syntax-rule (stream-cons obj strm)
+ (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
+
+(define (stream-car strm)
+ (must stream? strm 'stream-car "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-car "null stream")
+ (stream-force (stream-kar pare))))
+
+(define (stream-cdr strm)
+ (must stream? strm 'stream-cdr "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-cdr "null stream")
+ (stream-kdr pare)))
+
+(define-syntax-rule (stream-lambda formals body0 body1 ...)
+ (lambda formals (stream-lazy (begin body0 body1 ...))))
+
+;;; Derived stream functions and macros: (streams derived)
+
+(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
+ (define name (stream-lambda formal body0 body1 ...)))
+
+(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
+
+(define (list->stream objs)
+ (define (list? x)
+ (or (proper-list? x) (circular-list? x)))
+ (must list? objs 'list->stream "non-list argument")
+ (stream-let recur ((objs objs))
+ (if (null? objs) stream-null
+ (stream-cons (car objs) (recur (cdr objs))))))
+
+(define* (port->stream #:optional (port (current-input-port)))
+ (must input-port? port 'port->stream "non-input-port argument")
+ (stream-let recur ()
+ (let ((c (read-char port)))
+ (if (eof-object? c) stream-null
+ (stream-cons c (recur))))))
+
+(define-syntax stream
+ (syntax-rules ()
+ ((_) stream-null)
+ ((_ x y ...) (stream-cons x (stream y ...)))))
+
+;; Common helper for the various eager-folding functions, such as
+;; stream-fold, stream-drop, stream->list, stream-length, etc.
+(define-inlinable (stream-fold-aux proc base strm limit)
+ (do ((val base (and proc (proc val (stream-car strm))))
+ (strm strm (stream-cdr strm))
+ (limit limit (and limit (1- limit))))
+ ((or (and limit (zero? limit)) (stream-null? strm))
+ (values val strm limit))))
+
+(define stream->list
+ (case-lambda
+ ((strm) (stream->list #f strm))
+ ((n strm)
+ (must stream? strm 'stream->list "non-stream argument")
+ (when n
+ (must integer? n 'stream->list "non-integer count")
+ (must-not negative? n 'stream->list "negative count"))
+ (reverse! (first-value (stream-fold-aux xcons '() strm n))))))
+
+(define (stream-append . strms)
+ (must-every stream? strms 'stream-append "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (null? strms) stream-null
+ (let ((strm (car strms)))
+ (if (stream-null? strm) (recur (cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (cons (stream-cdr strm) (cdr strms)))))))))
+
+(define (stream-concat strms)
+ (must stream? strms 'stream-concat "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (stream-null? strms) stream-null
+ (let ((strm (stream-car strms)))
+ (must stream? strm 'stream-concat "non-stream object in input stream")
+ (if (stream-null? strm) (recur (stream-cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (stream-cons (stream-cdr strm)
+ (stream-cdr strms)))))))))
+
+(define stream-constant
+ (case-lambda
+ (() stream-null)
+ (objs (list->stream (apply circular-list objs)))))
+
+(define-syntax* (stream-do x)
+ (define (end x)
+ (syntax-case x ()
+ (() #'(if #f #f))
+ ((result) #'result)
+ ((result ...) #'(begin result ...))))
+ (define (var-step v s)
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation 'stream-do "bad step expression" x s))))
+
+ (syntax-case x ()
+ ((_ ((var init . step) ...)
+ (test result ...)
+ expr ...)
+ (with-syntax ((result (end #'(result ...)))
+ ((step ...) (map var-step #'(var ...) #'(step ...))))
+ #'(stream-let loop ((var init) ...)
+ (if test result
+ (begin
+ expr ...
+ (loop step ...))))))))
+
+(define (stream-drop n strm)
+ (must integer? n 'stream-drop "non-integer argument")
+ (must-not negative? n 'stream-drop "negative argument")
+ (must stream? strm 'stream-drop "non-stream argument")
+ (second-value (stream-fold-aux #f #f strm n)))
+
+(define (stream-drop-while pred? strm)
+ (must procedure? pred? 'stream-drop-while "non-procedural argument")
+ (must stream? strm 'stream-drop-while "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm)))
+ ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
+
+(define (stream-filter pred? strm)
+ (must procedure? pred? 'stream-filter "non-procedural argument")
+ (must stream? strm 'stream-filter "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else (recur (stream-cdr strm))))))
+
+(define (stream-fold proc base strm)
+ (must procedure? proc 'stream-fold "non-procedural argument")
+ (must stream? strm 'stream-fold "non-stream argument")
+ (first-value (stream-fold-aux proc base strm #f)))
+
+(define stream-for-each
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must stream? strm 'stream-for-each "non-stream argument")
+ (do ((strm strm (stream-cdr strm)))
+ ((stream-null? strm))
+ (proc (stream-car strm))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must-every stream? strms 'stream-for-each "non-stream argument")
+ (do ((strms strms (map stream-cdr strms)))
+ ((any stream-null? strms))
+ (apply proc (map stream-car strms)))))))
+
+(define* (stream-from first #:optional (step 1))
+ (must number? first 'stream-from "non-numeric starting number")
+ (must number? step 'stream-from "non-numeric step size")
+ (stream-let recur ((first first))
+ (stream-cons first (recur (+ first step)))))
+
+(define (stream-iterate proc base)
+ (must procedure? proc 'stream-iterate "non-procedural argument")
+ (stream-let recur ((base base))
+ (stream-cons base (recur (proc base)))))
+
+(define (stream-length strm)
+ (must stream? strm 'stream-length "non-stream argument")
+ (- -1 (third-value (stream-fold-aux #f #f strm -1))))
+
+(define stream-map
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must stream? strm 'stream-map "non-stream argument")
+ (stream-let recur ((strm strm))
+ (if (stream-null? strm) stream-null
+ (stream-cons (proc (stream-car strm))
+ (recur (stream-cdr strm))))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must-every stream? strms 'stream-map "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (apply proc (map stream-car strms))
+ (recur (map stream-cdr strms)))))))))
+
+(define-syntax* (stream-match x)
+ (define (make-matcher x)
+ (syntax-case x ()
+ (() #'(? stream-null?))
+ (rest (identifier? #'rest) #'rest)
+ ((var . rest) (identifier? #'var)
+ (with-syntax ((next (make-matcher #'rest)))
+ #'(? (negate stream-null?)
+ (= stream-car var)
+ (= stream-cdr next))))))
+ (define (make-guarded x fail)
+ (syntax-case (list x fail) ()
+ (((expr) _) #'expr)
+ (((guard expr) fail) #'(if guard expr (fail)))))
+
+ (syntax-case x ()
+ ((_ strm-expr (pat . expr) ...)
+ (with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
+ (with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
+ ((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
+ #'(let ((strm strm-expr))
+ (must stream? strm 'stream-match "non-stream argument")
+ (match strm (matcher (=> fail) expr) ...)))))))
+
+(define-syntax-rule (stream-of expr rest ...)
+ (stream-of-aux expr stream-null rest ...))
+
+(define-syntax stream-of-aux
+ (syntax-rules (in is)
+ ((_ expr base)
+ (stream-cons expr base))
+ ((_ expr base (var in stream) rest ...)
+ (stream-let recur ((strm stream))
+ (if (stream-null? strm) base
+ (let ((var (stream-car strm)))
+ (stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
+ ((_ expr base (var is exp) rest ...)
+ (let ((var exp)) (stream-of-aux expr base rest ...)))
+ ((_ expr base pred? rest ...)
+ (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define* (stream-range first past #:optional step)
+ (must number? first 'stream-range "non-numeric starting number")
+ (must number? past 'stream-range "non-numeric ending number")
+ (when step
+ (must number? step 'stream-range "non-numeric step size"))
+ (let* ((step (or step (if (< first past) 1 -1)))
+ (lt? (if (< 0 step) < >)))
+ (stream-let recur ((first first))
+ (if (lt? first past)
+ (stream-cons first (recur (+ first step)))
+ stream-null))))
+
+(define (stream-ref strm n)
+ (must stream? strm 'stream-ref "non-stream argument")
+ (must integer? n 'stream-ref "non-integer argument")
+ (must-not negative? n 'stream-ref "negative argument")
+ (let ((res (stream-drop n strm)))
+ (must-not stream-null? res 'stream-ref "beyond end of stream")
+ (stream-car res)))
+
+(define (stream-reverse strm)
+ (must stream? strm 'stream-reverse "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm))
+ (rev stream-null (stream-cons (stream-car strm) rev)))
+ ((stream-null? strm) rev)))
+
+(define (stream-scan proc base strm)
+ (must procedure? proc 'stream-scan "non-procedural argument")
+ (must stream? strm 'stream-scan "non-stream argument")
+ (stream-let recur ((base base) (strm strm))
+ (if (stream-null? strm) (stream base)
+ (stream-cons base (recur (proc base (stream-car strm))
+ (stream-cdr strm))))))
+
+(define (stream-take n strm)
+ (must stream? strm 'stream-take "non-stream argument")
+ (must integer? n 'stream-take "non-integer argument")
+ (must-not negative? n 'stream-take "negative argument")
+ (stream-let recur ((n n) (strm strm))
+ (if (or (zero? n) (stream-null? strm)) stream-null
+ (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
+
+(define (stream-take-while pred? strm)
+ (must procedure? pred? 'stream-take-while "non-procedural argument")
+ (must stream? strm 'stream-take-while "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else stream-null))))
+
+(define (stream-unfold mapper pred? generator base)
+ (must procedure? mapper 'stream-unfold "non-procedural mapper")
+ (must procedure? pred? 'stream-unfold "non-procedural pred?")
+ (must procedure? generator 'stream-unfold "non-procedural generator")
+ (stream-let recur ((base base))
+ (if (pred? base)
+ (stream-cons (mapper base) (recur (generator base)))
+ stream-null)))
+
+(define (stream-unfolds gen seed)
+ (define-stream (generator-stream seed)
+ (receive (next . items) (gen seed)
+ (stream-cons (list->vector items) (generator-stream next))))
+ (define-stream (make-result-stream genstrm index)
+ (define head (vector-ref (stream-car genstrm) index))
+ (define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
+ (match head
+ (() stream-null)
+ (#f (tail))
+ ((item) (stream-cons item (tail)))
+ ((? list? items) (stream-append (list->stream items) (tail)))))
+
+ (must procedure? gen 'stream-unfolds "non-procedural argument")
+ (let ((genstrm (generator-stream seed)))
+ (apply values (list-tabulate (vector-length (stream-car genstrm))
+ (cut make-result-stream genstrm <>)))))
+
+(define (stream-zip strm . rest)
+ (let ((strms (cons strm rest)))
+ (must-every stream? strms 'stream-zip "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (map stream-car strms) (recur (map stream-cdr strms)))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index e7c8c41..01ffd1c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -131,6 +131,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-37.test \
tests/srfi-38.test \
tests/srfi-39.test \
+ tests/srfi-41.test \
tests/srfi-42.test \
tests/srfi-45.test \
tests/srfi-60.test \
diff --git a/test-suite/tests/srfi-41.test b/test-suite/tests/srfi-41.test
new file mode 100644
index 0000000..f7420a9
--- /dev/null
+++ b/test-suite/tests/srfi-41.test
@@ -0,0 +1,657 @@
+;;; srfi-41.test -- test suite for SRFI 41
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (test-srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-31)
+ #:use-module (srfi srfi-41)
+ #:use-module (test-suite lib))
+
+(define-stream (qsort lt? strm)
+ (if (stream-null? strm) stream-null
+ (let ((x (stream-car strm))
+ (xs (stream-cdr strm)))
+ (stream-append
+ (qsort lt? (stream-filter (cut lt? <> x) xs))
+ (stream x)
+ (qsort lt? (stream-filter (cut (negate lt?) <> x) xs))))))
+
+(define-stream (isort lt? strm)
+ (define-stream (insert strm x)
+ (stream-match strm
+ (() (stream x))
+ ((y . ys) (if (lt? y x)
+ (stream-cons y (insert ys x))
+ (stream-cons x strm)))))
+ (stream-fold insert stream-null strm))
+
+(define-stream (stream-merge lt? . strms)
+ (stream-let loop ((strms strms))
+ (cond ((null? strms) stream-null)
+ ((null? (cdr strms)) (car strms))
+ (else (stream-let merge ((xx (car strms))
+ (yy (loop (cdr strms))))
+ (stream-match xx
+ (() yy)
+ ((x . xs)
+ (stream-match yy
+ (() xx)
+ ((y . ys)
+ (if (lt? y x)
+ (stream-cons y (merge xx ys))
+ (stream-cons x (merge xs yy))))))))))))
+
+(define-stream (msort lt? strm)
+ (let* ((n (quotient (stream-length strm) 2))
+ (ts (stream-take n strm))
+ (ds (stream-drop n strm)))
+ (if (zero? n) strm
+ (stream-merge lt? (msort < ts) (msort < ds)))))
+
+(define-stream (stream-unique eql? strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (stream-car strm)
+ (stream-unique eql?
+ (stream-drop-while (cut eql? (stream-car strm) <>) strm)))))
+
+(define nats
+ (stream-cons 1
+ (stream-map 1+ nats)))
+
+(define hamming
+ (stream-unique =
+ (stream-cons 1
+ (stream-merge <
+ (stream-map (cut * 2 <>) hamming)
+ (stream-merge <
+ (stream-map (cut * 3 <>) hamming)
+ (stream-map (cut * 5 <>) hamming))))))
+
+(define primes (let ()
+ (define-stream (next base mult strm)
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (cond ((< first mult)
+ (stream-cons first
+ (next base mult rest)))
+ ((< mult first)
+ (next base (+ base mult) strm))
+ (else (next base
+ (+ base mult) rest)))))
+ (define-stream (sift base strm)
+ (next base (+ base base) strm))
+ (stream-let sieve ((strm (stream-from 2)))
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (stream-cons first (sieve (sift first rest)))))))
+
+(define strm123 (stream 1 2 3))
+
+(define (stream-equal? s1 s2)
+ (cond ((and (stream-null? s1) (stream-null? s2)) #t)
+ ((or (stream-null? s1) (stream-null? s2)) #f)
+ ((equal? (stream-car s1) (stream-car s2))
+ (stream-equal? (stream-cdr s1) (stream-cdr s2)))
+ (else #f)))
+
+(with-test-prefix "stream-null"
+ (pass-if "is a stream" (stream? stream-null))
+ (pass-if "is a null stream" (stream-null? stream-null))
+ (pass-if "is not a stream pair" (not (stream-pair? stream-null))))
+
+(with-test-prefix "stream-cons"
+ (pass-if "is a stream" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is not a null stream" (not (stream-null? (stream-cons 1 stream-null))))
+ (pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null))))
+
+(with-test-prefix "stream?"
+ (pass-if "is true for null stream" (stream? stream-null))
+ (pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is false for non-stream" (not (stream? "four"))))
+
+(with-test-prefix "stream-null?"
+ (pass-if "is true for null stream" (stream-null? stream-null))
+ (pass-if "is false for stream pair" (not (stream-null? (stream-cons 1 stream-null))))
+ (pass-if "is false for non-stream" (not (stream-null? "four"))))
+
+(with-test-prefix "stream-pair?"
+ (pass-if "is false for null stream" (not (stream-pair? stream-null)))
+ (pass-if "is true for stream pair" (stream-pair? (stream-cons 1 stream-null)))
+ (pass-if "is false for non-stream" (not (stream-pair? "four"))))
+
+(with-test-prefix "stream-car"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-car "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-car stream-null))
+ (pass-if "returns first of stream" (eqv? (stream-car strm123) 1)))
+
+(with-test-prefix "stream-cdr"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-cdr "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-cdr stream-null))
+ (pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123)) 2)))
+
+(with-test-prefix "stream-lambda"
+ (pass-if "returns correct result"
+ (stream-equal?
+ ((rec double (stream-lambda (strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm))))))
+ strm123)
+ (stream 2 4 6))))
+
+(with-test-prefix "define-stream"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (let ()
+ (define-stream (double strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm)))))
+ (double strm123))
+ (stream 2 4 6))))
+
+(with-test-prefix "list->stream"
+ (pass-if-exception "throws for non-list"
+ '(wrong-type-arg . "non-list argument")
+ (list->stream "four"))
+ (pass-if "returns empty stream for empty list"
+ (stream-null? (list->stream '())))
+ (pass-if "returns stream with same content as given list"
+ (stream-equal? (list->stream '(1 2 3)) strm123)))
+
+(with-test-prefix "port->stream"
+ (pass-if-exception "throws for non-input-port"
+ '(wrong-type-arg . "non-input-port argument")
+ (port->stream "four"))
+ (call-with-input-string "Hello, world!"
+ (lambda (p)
+ (pass-if "reads input string correctly"
+ (equal? (list->string (stream->list (port->stream p)))
+ "Hello, world!")))))
+
+(with-test-prefix "stream"
+ (pass-if "with empty stream"
+ (equal? (stream->list (stream)) '()))
+ (pass-if "with one-element stream"
+ (equal? (stream->list (stream 1)) '(1)))
+ (pass-if "with three-element stream"
+ (equal? (stream->list (stream 1 2 3)) '(1 2 3))))
+
+(with-test-prefix "stream->list"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream->list '()))
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer count")
+ (stream->list "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative count")
+ (stream->list -1 strm123))
+ (pass-if "returns empty list for empty stream"
+ (eq? (stream->list (stream)) '()))
+ (pass-if "without count"
+ (equal? (stream->list strm123) '(1 2 3)))
+ (pass-if "with count longer than stream"
+ (equal? (stream->list 5 strm123) '(1 2 3)))
+ (pass-if "with count shorter than stream"
+ (equal? (stream->list 3 (stream-from 1)) '(1 2 3))))
+
+(with-test-prefix "stream-append"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-append "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-append strm123) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2 3)))
+ (pass-if "with three streams"
+ (stream-equal? (stream-append strm123 strm123 strm123)
+ (stream 1 2 3 1 2 3 1 2 3)))
+ (pass-if "append with null is noop"
+ (stream-equal? (stream-append strm123 stream-null) strm123))
+ (pass-if "prepend with null is noop"
+ (stream-equal? (stream-append stream-null strm123) strm123)))
+
+(with-test-prefix "stream-concat"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-concat "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-concat (stream strm123)) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-concat (stream strm123 strm123))
+ (stream 1 2 3 1 2 3))))
+
+(with-test-prefix "stream-constant"
+ (pass-if "circular stream of 1 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1) 100) 1))
+ (pass-if "circular stream of 2 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1 2) 100) 1))
+ (pass-if "circular stream of 3 repeats after 3"
+ (eqv? (stream-ref (stream-constant 1 2 3) 3) 1))
+ (pass-if "circular stream of 1 repeats at 1"
+ (stream-equal? (stream-take 8 (stream-constant 1))
+ (stream 1 1 1 1 1 1 1 1)))
+ (pass-if "circular stream of 2 repeats at 2"
+ (stream-equal? (stream-take 8 (stream-constant 1 2))
+ (stream 1 2 1 2 1 2 1 2)))
+ (pass-if "circular stream of 3 repeats at 3"
+ (stream-equal? (stream-take 8 (stream-constant 1 2 3))
+ (stream 1 2 3 1 2 3 1 2))))
+
+(with-test-prefix "stream-drop"
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-drop "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative argument")
+ (stream-drop -1 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop 2 "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop 0 stream-null)))
+ (pass-if "returns same stream when count is zero"
+ (eq? (stream-drop 0 strm123) strm123))
+ (pass-if "returns dropped-by-one stream when count is one"
+ (stream-equal? (stream-drop 1 strm123) (stream 2 3)))
+ (pass-if "returns null if count is longer than stream"
+ (stream-null? (stream-drop 5 strm123))))
+
+(with-test-prefix "stream-drop-while"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-drop-while "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop-while odd? "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop-while odd? stream-null)))
+ (pass-if "returns dropped stream when first element matches"
+ (stream-equal? (stream-drop-while odd? strm123) (stream 2 3)))
+ (pass-if "returns whole stream when first element doesn't match"
+ (stream-equal? (stream-drop-while even? strm123) strm123))
+ (pass-if "returns empty stream if all elements match"
+ (stream-null? (stream-drop-while positive? strm123)))
+ (pass-if "return whole stream if no elements match"
+ (stream-equal? (stream-drop-while negative? strm123) strm123)))
+
+(with-test-prefix "stream-filter"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-filter "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-filter odd? '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-filter odd? (stream))))
+ (pass-if "filters out even numbers"
+ (stream-equal? (stream-filter odd? strm123) (stream 1 3)))
+ (pass-if "filters out odd numbers"
+ (stream-equal? (stream-filter even? strm123) (stream 2)))
+ (pass-if "returns all elements if predicate matches all"
+ (stream-equal? (stream-filter positive? strm123) strm123))
+ (pass-if "returns null if predicate matches none"
+ (stream-null? (stream-filter negative? strm123)))
+ (pass-if "all elements of an odd-filtered stream are odd"
+ (every odd? (stream->list 10 (stream-filter odd? (stream-from 0)))))
+ (pass-if "no elements of an odd-filtered stream are even"
+ (not (any even? (stream->list 10 (stream-filter odd? (stream-from 0)))))))
+
+(with-test-prefix "stream-fold"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-fold "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-fold + 0 '()))
+ (pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6)))
+
+(with-test-prefix "stream-for-each"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-for-each "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-for-each display))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-for-each display "four"))
+ (pass-if "function is called for stream elements"
+ (eqv? (let ((sum 0))
+ (stream-for-each (lambda (x)
+ (set! sum (+ sum x)))
+ strm123)
+ sum)
+ 6)))
+
+(with-test-prefix "stream-from"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-from "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-from 1 "four"))
+ (pass-if "works for default values"
+ (eqv? (stream-ref (stream-from 0) 100) 100))
+ (pass-if "works for non-default start and step"
+ (eqv? (stream-ref (stream-from 1 2) 100) 201))
+ (pass-if "works for negative step"
+ (eqv? (stream-ref (stream-from 0 -1) 100) -100)))
+
+(with-test-prefix "stream-iterate"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-iterate "four" 0))
+ (pass-if "returns correct iterated stream with 1+"
+ (stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123))
+ (pass-if "returns correct iterated stream with exact-integer-sqrt"
+ (stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt 65536))
+ (stream 65536 256 16 4 2))))
+
+(with-test-prefix "stream-length"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-length "four"))
+ (pass-if "returns 0 for empty stream" (zero? (stream-length (stream))))
+ (pass-if "returns correct stream length" (eqv? (stream-length strm123) 3)))
+
+(with-test-prefix "stream-let"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (stream-let loop ((strm strm123))
+ (if (stream-null? strm)
+ stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (loop (stream-cdr strm)))))
+ (stream 2 4 6))))
+
+(with-test-prefix "stream-map"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-map "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-map odd?))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-map odd? "four"))
+ (pass-if "works for one stream"
+ (stream-equal? (stream-map - strm123) (stream -1 -2 -3)))
+ (pass-if "works for two streams"
+ (stream-equal? (stream-map + strm123 strm123) (stream 2 4 6)))
+ (pass-if "returns finite stream for finite first stream"
+ (stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4 6)))
+ (pass-if "returns finite stream for finite last stream"
+ (stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4 6)))
+ (pass-if "works for three streams"
+ (stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6 9))))
+
+(with-test-prefix "stream-match"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-match '(1 2 3) (_ 'ok)))
+ (pass-if-exception "throws when no pattern matches"
+ '(match-error . "no matching pattern")
+ (stream-match strm123 (() 42)))
+ (pass-if "matches empty stream correctly"
+ (eq? (stream-match stream-null (() 'ok)) 'ok))
+ (pass-if "matches non-empty stream correctly"
+ (eq? (stream-match strm123 (() 'no) (else 'ok)) 'ok))
+ (pass-if "matches stream of one element"
+ (eqv? (stream-match (stream 1) (() 'no) ((a) a)) 1))
+ (pass-if "matches wildcard"
+ (eq? (stream-match (stream 1) (() 'no) ((_) 'ok)) 'ok))
+ (pass-if "matches stream of three elements"
+ (equal? (stream-match strm123 ((a b c) (list a b c))) '(1 2 3)))
+ (pass-if "matches first element with wildcard rest"
+ (eqv? (stream-match strm123 ((a . _) a)) 1))
+ (pass-if "matches first two elements with wildcard rest"
+ (equal? (stream-match strm123 ((a b . _) (list a b))) '(1 2)))
+ (pass-if "rest variable matches as stream"
+ (equal? (stream-match strm123 ((a b . c) (list a b (stream-car c))))
+ '(1 2 3)))
+ (pass-if "rest variable can match whole stream"
+ (equal? (stream-match strm123 (s (stream->list s))) '(1 2 3)))
+ (pass-if "successful guard match"
+ (eq? (stream-match strm123 ((a . _) (= a 1) 'ok)) 'ok))
+ (pass-if "unsuccessful guard match"
+ (eq? (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)) 'no))
+ (pass-if "unsuccessful guard match with two variables"
+ (eq? (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)) 'no))
+ (pass-if "successful guard match with two variables"
+ (eq? (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)) 'yes)))
+
+(with-test-prefix "stream-of"
+ (pass-if "all 3 clause types work"
+ (stream-equal? (stream-of (+ y 6)
+ (x in (stream-range 1 6))
+ (odd? x)
+ (y is (* x x)))
+ (stream 7 15 31)))
+ (pass-if "using two streams creates cartesian product"
+ (stream-equal? (stream-of (* x y)
+ (x in (stream-range 1 4))
+ (y in (stream-range 1 5)))
+ (stream 1 2 3 4 2 4 6 8 3 6 9 12)))
+ (pass-if "using no clauses returns just the expression"
+ (stream-equal? (stream-of 1) (stream 1))))
+
+(with-test-prefix "stream-range"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-range "four" 0))
+ (pass-if-exception "throws for non-numeric end"
+ '(wrong-type-arg . "non-numeric ending number")
+ (stream-range 0 "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-range 1 2 "three"))
+ (pass-if "returns increasing range if start < end"
+ (stream-equal? (stream-range 0 5) (stream 0 1 2 3 4)))
+ (pass-if "returns decreasing range if start > end"
+ (stream-equal? (stream-range 5 0) (stream 5 4 3 2 1)))
+ (pass-if "returns increasing range of step 2"
+ (stream-equal? (stream-range 0 5 2) (stream 0 2 4)))
+ (pass-if "returns decreasing range of step 2"
+ (stream-equal? (stream-range 5 0 -2) (stream 5 3 1)))
+ (pass-if "returns empty range if start is past end value"
+ (stream-null? (stream-range 0 1 -1))))
+
+(with-test-prefix "stream-ref"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-ref '() 4))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-ref nats 3.5))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-ref nats -3))
+ (pass-if-exception "throws if index goes past end of stream"
+ '(wrong-type-arg . "beyond end of stream")
+ (stream-ref strm123 5))
+ (pass-if "returns first element when index = 0"
+ (eqv? (stream-ref nats 0) 1))
+ (pass-if "returns second element when index = 1"
+ (eqv? (stream-ref nats 1) 2))
+ (pass-if "returns third element when index = 2"
+ (eqv? (stream-ref nats 2) 3)))
+
+(with-test-prefix "stream-reverse"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-reverse '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-reverse (stream))))
+ (pass-if "returns (3 2 1) for (1 2 3)"
+ (stream-equal? (stream-reverse strm123) (stream 3 2 1))))
+
+(with-test-prefix "stream-scan"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-scan "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-scan + 0 '()))
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6))))
+
+(with-test-prefix "stream-take"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take 5 "four"))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-take "four" strm123))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-take -4 strm123))
+ (pass-if "returns null for empty stream"
+ (stream-null? (stream-take 5 stream-null)))
+ (pass-if "using 0 index returns null for empty stream"
+ (stream-null? (stream-take 0 stream-null)))
+ (pass-if "using 0 index returns null for non-empty stream"
+ (stream-null? (stream-take 0 strm123)))
+ (pass-if "returns first 2 elements of stream"
+ (stream-equal? (stream-take 2 strm123) (stream 1 2)))
+ (pass-if "returns whole stream when index is same as length"
+ (stream-equal? (stream-take 3 strm123) strm123))
+ (pass-if "returns whole stream when index exceeds length"
+ (stream-equal? (stream-take 5 strm123) strm123)))
+
+(with-test-prefix "stream-take-while"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take-while odd? "four"))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-take-while "four" strm123))
+ (pass-if "returns stream up to first non-matching item"
+ (stream-equal? (stream-take-while odd? strm123) (stream 1)))
+ (pass-if "returns empty stream if first item doesn't match"
+ (stream-null? (stream-take-while even? strm123)))
+ (pass-if "returns whole stream if every item matches"
+ (stream-equal? (stream-take-while positive? strm123) strm123))
+ (pass-if "return empty stream if no item matches"
+ (stream-null? (stream-take-while negative? strm123))))
+
+(with-test-prefix "stream-unfold"
+ (pass-if-exception "throws for invalid mapper"
+ '(wrong-type-arg . "non-procedural mapper")
+ (stream-unfold "four" odd? + 0))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural pred?")
+ (stream-unfold + "four" + 0))
+ (pass-if-exception "throws for invalid generator"
+ '(wrong-type-arg . "non-procedural generator")
+ (stream-unfold + odd? "four" 0))
+
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0)
+ (stream 0 1 4 9 16 25 36 49 64 81))))
+
+(with-test-prefix "stream-unfolds"
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfolds
+ (lambda (x)
+ (receive (n s) (car+cdr x)
+ (if (zero? n)
+ (values 'dummy '())
+ (values
+ (cons (- n 1) (stream-cdr s))
+ (list (stream-car s))))))
+ (cons 5 (stream-from 0)))
+ (stream 0 1 2 3 4)))
+ (pass-if "handles returns of multiple elements correctly"
+ (stream-equal? (stream-take 16 (stream-unfolds
+ (lambda (n)
+ (values (1+ n) (iota n)))
+ 1))
+ (stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0)))
+ (receive (p np)
+ (stream-unfolds (lambda (x)
+ (receive (n p) (car+cdr x)
+ (if (= n (stream-car p))
+ (values (cons (1+ n) (stream-cdr p))
+ (list n) #f)
+ (values (cons (1+ n) p)
+ #f (list n)))))
+ (cons 1 primes))
+ (pass-if "returns first stream correctly"
+ (stream-equal? (stream-take 15 p)
+ (stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)))
+ (pass-if "returns second stream correctly"
+ (stream-equal? (stream-take 15 np)
+ (stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22 24)))))
+
+(with-test-prefix "stream-zip"
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-zip))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip "four"))
+ (pass-if-exception "throws if any argument is non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip strm123 "four"))
+ (pass-if "returns null when given null as any argument"
+ (stream-null? (stream-zip strm123 stream-null)))
+ (pass-if "returns single-element lists when given one stream"
+ (stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3))))
+ (pass-if "returns double-element lists when given two streams"
+ (stream-equal? (stream-zip strm123 strm123)
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns finite stream if at least one given stream is"
+ (stream-equal? (stream-zip strm123 (stream-from 1))
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns triple-element lists when given three streams"
+ (stream-equal? (stream-zip strm123 strm123 strm123)
+ (stream '(1 1 1) '(2 2 2) '(3 3 3)))))
+
+(with-test-prefix "other tests"
+ (pass-if "returns biggest prime under 1000"
+ (eqv? (stream-car
+ (stream-reverse (stream-take-while (cut < <> 1000) primes)))
+ 997))
+
+ (pass-if "quicksort returns same result as insertion sort"
+ (stream-equal? (qsort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ (pass-if "merge sort returns same result as insertion sort"
+ (stream-equal? (msort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ ;; http://www.research.att.com/~njas/sequences/A051037
+ (pass-if "returns 1000th Hamming number"
+ (eqv? (stream-ref hamming 999) 51200000)))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 6+ messages in thread
* Re: [PATCH] Add SRFI-41
2013-03-21 0:38 [PATCH] Add SRFI-41 Mark H Weaver
@ 2013-03-21 8:55 ` Andy Wingo
2013-03-27 2:53 ` Mark H Weaver
0 siblings, 1 reply; 6+ messages in thread
From: Andy Wingo @ 2013-03-21 8:55 UTC (permalink / raw)
To: Mark H Weaver; +Cc: Chris K. Jester-Young, guile-devel
On Thu 21 Mar 2013 01:38, Mark H Weaver <mhw@netris.org> writes:
> Chris K. Jester-Young has been hard at work getting his SRFI-41
> implementation ready in time for Guile 2.0.8, and I think it might be
> ready to push. What do you think?
Needs documentation.
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [PATCH] Add SRFI-41
2013-03-21 8:55 ` Andy Wingo
@ 2013-03-27 2:53 ` Mark H Weaver
2013-03-27 3:00 ` Mark H Weaver
0 siblings, 1 reply; 6+ messages in thread
From: Mark H Weaver @ 2013-03-27 2:53 UTC (permalink / raw)
To: Andy Wingo; +Cc: Chris K. Jester-Young, guile-devel
Andy Wingo <wingo@pobox.com> writes:
> On Thu 21 Mar 2013 01:38, Mark H Weaver <mhw@netris.org> writes:
>
>> Chris K. Jester-Young has been hard at work getting his SRFI-41
>> implementation ready in time for Guile 2.0.8, and I think it might be
>> ready to push. What do you think?
>
> Needs documentation.
Good point :)
Here's an updated version of the SRFI-41 patch set. The first patch
includes the actual code along with stub docs (and is credited to cky,
although again I've made some tweaks since he last looked), and the
second patch includes a full set of documentation.
I'd especially appreciate a review of my texinfo code (if someone has
time to do so) but I looked at both the info and pdf output, and I
didn't see any glaring problems.
If anyone wants to see the incremental evolution of this patch set, the
history is on the srfi-41 branch.
I'd like to push this in the next couple of days if possible, since we
hope to release 2.0.8 soon. I think it's ready. What do you think?
Mark
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [PATCH] Add SRFI-41
2013-03-27 2:53 ` Mark H Weaver
@ 2013-03-27 3:00 ` Mark H Weaver
2013-03-27 17:43 ` Mark H Weaver
2013-03-27 20:58 ` Ludovic Courtès
0 siblings, 2 replies; 6+ messages in thread
From: Mark H Weaver @ 2013-03-27 3:00 UTC (permalink / raw)
To: Andy Wingo; +Cc: Chris K. Jester-Young, guile-devel
[-- Attachment #1: Type: text/plain, Size: 48 bytes --]
and here are the actual patches :)
Mark
[-- Attachment #2: [PATCH 1/2] Add SRFI-41 --]
[-- Type: text/x-diff, Size: 56105 bytes --]
From 3d58c8cfbab13bf96e1c1d6dd81be2f8f259eaf2 Mon Sep 17 00:00:00 2001
From: "Chris K. Jester-Young" <cky944@gmail.com>
Date: Tue, 26 Mar 2013 22:15:31 -0400
Subject: [PATCH 1/2] Add SRFI-41.
Incorporates suggestions from Mark H Weaver <mhw@netris.org>
and Ian Price <ianprice90@googlemail.com>.
* module/srfi/srfi-41.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-41.scm.
* test-suite/tests/srfi-41.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-41.test.
* doc/ref/srfi-modules.texi (SRFI Support): Add SRFI-41.
(SRFI-41): New node which refers the reader to
<http://srfi.schemers.org/srfi-41/srfi-41.html>.
---
doc/ref/srfi-modules.texi | 8 +
module/Makefile.am | 1 +
module/srfi/srfi-41.scm | 482 +++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-41.test | 680 +++++++++++++++++++++++++++++++++++++++++
5 files changed, 1172 insertions(+)
create mode 100644 module/srfi/srfi-41.scm
create mode 100644 test-suite/tests/srfi-41.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 513bb59..5a89209 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -45,6 +45,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-37:: args-fold program argument processor
* SRFI-38:: External Representation for Data With Shared Structure
* SRFI-39:: Parameter objects
+* SRFI-41:: Streams.
* SRFI-42:: Eager comprehensions
* SRFI-45:: Primitives for expressing iterative lazy algorithms
* SRFI-55:: Requiring Features.
@@ -3788,6 +3789,13 @@ scope and the result from that @var{thunk} is the return from
@code{with-parameters*}.
@end defun
+@node SRFI-41
+@subsection SRFI-41 - Streams
+@cindex SRFI-41
+
+See @uref{http://srfi.schemers.org/srfi-41/srfi-41.html, the
+specification of SRFI-41}.
+
@node SRFI-42
@subsection SRFI-42 - Eager Comprehensions
@cindex SRFI-42
diff --git a/module/Makefile.am b/module/Makefile.am
index c47d0b4..416ad22 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -282,6 +282,7 @@ SRFI_SOURCES = \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
+ srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm
new file mode 100644
index 0000000..edf95d7
--- /dev/null
+++ b/module/srfi/srfi-41.scm
@@ -0,0 +1,482 @@
+;;; srfi-41.scm -- SRFI 41 streams
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (stream-null stream-cons stream? stream-null? stream-pair?
+ stream-car stream-cdr stream-lambda define-stream
+ list->stream port->stream stream stream->list stream-append
+ stream-concat stream-constant stream-drop stream-drop-while
+ stream-filter stream-fold stream-for-each stream-from
+ stream-iterate stream-length stream-let stream-map
+ stream-match stream-of stream-range stream-ref stream-reverse
+ stream-scan stream-take stream-take-while stream-unfold
+ stream-unfolds stream-zip))
+
+(cond-expand-provide (current-module) '(srfi-41))
+
+;;; Private supporting functions and macros.
+
+(define-syntax-rule (must pred obj func msg args ...)
+ (let ((item obj))
+ (unless (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-not pred obj func msg args ...)
+ (let ((item obj))
+ (when (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-every pred objs func msg args ...)
+ (let ((flunk (remove pred objs)))
+ (unless (null? flunk)
+ (throw 'wrong-type-arg func msg (list args ...) flunk))))
+
+(define-syntax-rule (first-value expr)
+ (receive (first . _) expr
+ first))
+
+(define-syntax-rule (second-value expr)
+ (receive (first second . _) expr
+ second))
+
+(define-syntax-rule (third-value expr)
+ (receive (first second third . _) expr
+ third))
+
+(define-syntax define-syntax*
+ (syntax-rules ()
+ ((_ (name . args) body ...)
+ (define-syntax name (lambda* args body ...)))
+ ((_ name syntax)
+ (define-syntax name syntax))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Here we include a copy of the code of srfi-45.scm (but with renamed
+;; identifiers), in order to create a new promise type that's disjoint
+;; from the promises created by srfi-45. Ideally this should be done
+;; using a 'make-promise-type' macro that instantiates a copy of this
+;; code, but a psyntax bug in Guile 2.0 prevents this from working
+;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the
+;; code.
+
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-record-type stream-promise (make-stream-promise val) stream-promise?
+ (val stream-promise-val stream-promise-val-set!))
+
+(define-record-type stream-value (make-stream-value tag proc) stream-value?
+ (tag stream-value-tag stream-value-tag-set!)
+ (proc stream-value-proc stream-value-proc-set!))
+
+(define-syntax-rule (stream-lazy exp)
+ (make-stream-promise (make-stream-value 'lazy (lambda () exp))))
+
+(define (stream-eager x)
+ (make-stream-promise (make-stream-value 'eager x)))
+
+(define-syntax-rule (stream-delay exp)
+ (stream-lazy (stream-eager exp)))
+
+(define (stream-force promise)
+ (let ((content (stream-promise-val promise)))
+ (case (stream-value-tag content)
+ ((eager) (stream-value-proc content))
+ ((lazy) (let* ((promise* ((stream-value-proc content)))
+ (content (stream-promise-val promise)))
+ (if (not (eqv? (stream-value-tag content) 'eager))
+ (begin (stream-value-tag-set! content
+ (stream-value-tag (stream-promise-val promise*)))
+ (stream-value-proc-set! content
+ (stream-value-proc (stream-promise-val promise*)))
+ (stream-promise-val-set! promise* content)))
+ (stream-force promise))))))
+
+;;
+;; End of the copy of the code from srfi-45.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Primitive stream functions and macros: (streams primitive)
+
+(define stream? stream-promise?)
+
+(define %stream-null '(stream . null))
+(define stream-null (stream-eager %stream-null))
+
+(define (stream-null? obj)
+ (and (stream-promise? obj)
+ (eqv? (stream-force obj) %stream-null)))
+
+(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
+ (kar stream-kar)
+ (kdr stream-kdr))
+
+(define (stream-pair? obj)
+ (and (stream-promise? obj) (stream-pare? (stream-force obj))))
+
+(define-syntax-rule (stream-cons obj strm)
+ (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
+
+(define (stream-car strm)
+ (must stream? strm 'stream-car "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-car "null stream")
+ (stream-force (stream-kar pare))))
+
+(define (stream-cdr strm)
+ (must stream? strm 'stream-cdr "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-cdr "null stream")
+ (stream-kdr pare)))
+
+(define-syntax-rule (stream-lambda formals body0 body1 ...)
+ (lambda formals (stream-lazy (begin body0 body1 ...))))
+
+;;; Derived stream functions and macros: (streams derived)
+
+(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
+ (define name (stream-lambda formal body0 body1 ...)))
+
+(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
+
+(define (list->stream objs)
+ (define (list? x)
+ (or (proper-list? x) (circular-list? x)))
+ (must list? objs 'list->stream "non-list argument")
+ (stream-let recur ((objs objs))
+ (if (null? objs) stream-null
+ (stream-cons (car objs) (recur (cdr objs))))))
+
+(define* (port->stream #:optional (port (current-input-port)))
+ (must input-port? port 'port->stream "non-input-port argument")
+ (stream-let recur ()
+ (let ((c (read-char port)))
+ (if (eof-object? c) stream-null
+ (stream-cons c (recur))))))
+
+(define-syntax stream
+ (syntax-rules ()
+ ((_) stream-null)
+ ((_ x y ...) (stream-cons x (stream y ...)))))
+
+;; Common helper for the various eager-folding functions, such as
+;; stream-fold, stream-drop, stream->list, stream-length, etc.
+(define-inlinable (stream-fold-aux proc base strm limit)
+ (do ((val base (and proc (proc val (stream-car strm))))
+ (strm strm (stream-cdr strm))
+ (limit limit (and limit (1- limit))))
+ ((or (and limit (zero? limit)) (stream-null? strm))
+ (values val strm limit))))
+
+(define stream->list
+ (case-lambda
+ ((strm) (stream->list #f strm))
+ ((n strm)
+ (must stream? strm 'stream->list "non-stream argument")
+ (when n
+ (must integer? n 'stream->list "non-integer count")
+ (must exact? n 'stream->list "inexact count")
+ (must-not negative? n 'stream->list "negative count"))
+ (reverse! (first-value (stream-fold-aux xcons '() strm n))))))
+
+(define (stream-append . strms)
+ (must-every stream? strms 'stream-append "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (null? strms) stream-null
+ (let ((strm (car strms)))
+ (if (stream-null? strm) (recur (cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (cons (stream-cdr strm) (cdr strms)))))))))
+
+(define (stream-concat strms)
+ (must stream? strms 'stream-concat "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (stream-null? strms) stream-null
+ (let ((strm (stream-car strms)))
+ (must stream? strm 'stream-concat "non-stream object in input stream")
+ (if (stream-null? strm) (recur (stream-cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (stream-cons (stream-cdr strm)
+ (stream-cdr strms)))))))))
+
+(define stream-constant
+ (case-lambda
+ (() stream-null)
+ (objs (list->stream (apply circular-list objs)))))
+
+(define-syntax* (stream-do x)
+ (define (end x)
+ (syntax-case x ()
+ (() #'(if #f #f))
+ ((result) #'result)
+ ((result ...) #'(begin result ...))))
+ (define (var-step v s)
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation 'stream-do "bad step expression" x s))))
+
+ (syntax-case x ()
+ ((_ ((var init . step) ...)
+ (test result ...)
+ expr ...)
+ (with-syntax ((result (end #'(result ...)))
+ ((step ...) (map var-step #'(var ...) #'(step ...))))
+ #'(stream-let loop ((var init) ...)
+ (if test result
+ (begin
+ expr ...
+ (loop step ...))))))))
+
+(define (stream-drop n strm)
+ (must integer? n 'stream-drop "non-integer argument")
+ (must exact? n 'stream-drop "inexact argument")
+ (must-not negative? n 'stream-drop "negative argument")
+ (must stream? strm 'stream-drop "non-stream argument")
+ (second-value (stream-fold-aux #f #f strm n)))
+
+(define (stream-drop-while pred? strm)
+ (must procedure? pred? 'stream-drop-while "non-procedural argument")
+ (must stream? strm 'stream-drop-while "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm)))
+ ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
+
+(define (stream-filter pred? strm)
+ (must procedure? pred? 'stream-filter "non-procedural argument")
+ (must stream? strm 'stream-filter "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else (recur (stream-cdr strm))))))
+
+(define (stream-fold proc base strm)
+ (must procedure? proc 'stream-fold "non-procedural argument")
+ (must stream? strm 'stream-fold "non-stream argument")
+ (first-value (stream-fold-aux proc base strm #f)))
+
+(define stream-for-each
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must stream? strm 'stream-for-each "non-stream argument")
+ (do ((strm strm (stream-cdr strm)))
+ ((stream-null? strm))
+ (proc (stream-car strm))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must-every stream? strms 'stream-for-each "non-stream argument")
+ (do ((strms strms (map stream-cdr strms)))
+ ((any stream-null? strms))
+ (apply proc (map stream-car strms)))))))
+
+(define* (stream-from first #:optional (step 1))
+ (must number? first 'stream-from "non-numeric starting number")
+ (must number? step 'stream-from "non-numeric step size")
+ (stream-let recur ((first first))
+ (stream-cons first (recur (+ first step)))))
+
+(define (stream-iterate proc base)
+ (must procedure? proc 'stream-iterate "non-procedural argument")
+ (stream-let recur ((base base))
+ (stream-cons base (recur (proc base)))))
+
+(define (stream-length strm)
+ (must stream? strm 'stream-length "non-stream argument")
+ (- -1 (third-value (stream-fold-aux #f #f strm -1))))
+
+(define stream-map
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must stream? strm 'stream-map "non-stream argument")
+ (stream-let recur ((strm strm))
+ (if (stream-null? strm) stream-null
+ (stream-cons (proc (stream-car strm))
+ (recur (stream-cdr strm))))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must-every stream? strms 'stream-map "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (apply proc (map stream-car strms))
+ (recur (map stream-cdr strms)))))))))
+
+(define-syntax* (stream-match x)
+ (define (make-matcher x)
+ (syntax-case x ()
+ (() #'(? stream-null?))
+ (rest (identifier? #'rest) #'rest)
+ ((var . rest) (identifier? #'var)
+ (with-syntax ((next (make-matcher #'rest)))
+ #'(? (negate stream-null?)
+ (= stream-car var)
+ (= stream-cdr next))))))
+ (define (make-guarded x fail)
+ (syntax-case (list x fail) ()
+ (((expr) _) #'expr)
+ (((guard expr) fail) #'(if guard expr (fail)))))
+
+ (syntax-case x ()
+ ((_ strm-expr (pat . expr) ...)
+ (with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
+ (with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
+ ((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
+ #'(let ((strm strm-expr))
+ (must stream? strm 'stream-match "non-stream argument")
+ (match strm (matcher (=> fail) expr) ...)))))))
+
+(define-syntax-rule (stream-of expr rest ...)
+ (stream-of-aux expr stream-null rest ...))
+
+(define-syntax stream-of-aux
+ (syntax-rules (in is)
+ ((_ expr base)
+ (stream-cons expr base))
+ ((_ expr base (var in stream) rest ...)
+ (stream-let recur ((strm stream))
+ (if (stream-null? strm) base
+ (let ((var (stream-car strm)))
+ (stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
+ ((_ expr base (var is exp) rest ...)
+ (let ((var exp)) (stream-of-aux expr base rest ...)))
+ ((_ expr base pred? rest ...)
+ (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define* (stream-range first past #:optional step)
+ (must number? first 'stream-range "non-numeric starting number")
+ (must number? past 'stream-range "non-numeric ending number")
+ (when step
+ (must number? step 'stream-range "non-numeric step size"))
+ (let* ((step (or step (if (< first past) 1 -1)))
+ (lt? (if (< 0 step) < >)))
+ (stream-let recur ((first first))
+ (if (lt? first past)
+ (stream-cons first (recur (+ first step)))
+ stream-null))))
+
+(define (stream-ref strm n)
+ (must stream? strm 'stream-ref "non-stream argument")
+ (must integer? n 'stream-ref "non-integer argument")
+ (must exact? n 'stream-ref "inexact argument")
+ (must-not negative? n 'stream-ref "negative argument")
+ (let ((res (stream-drop n strm)))
+ (must-not stream-null? res 'stream-ref "beyond end of stream")
+ (stream-car res)))
+
+(define (stream-reverse strm)
+ (must stream? strm 'stream-reverse "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm))
+ (rev stream-null (stream-cons (stream-car strm) rev)))
+ ((stream-null? strm) rev)))
+
+(define (stream-scan proc base strm)
+ (must procedure? proc 'stream-scan "non-procedural argument")
+ (must stream? strm 'stream-scan "non-stream argument")
+ (stream-let recur ((base base) (strm strm))
+ (if (stream-null? strm) (stream base)
+ (stream-cons base (recur (proc base (stream-car strm))
+ (stream-cdr strm))))))
+
+(define (stream-take n strm)
+ (must stream? strm 'stream-take "non-stream argument")
+ (must integer? n 'stream-take "non-integer argument")
+ (must exact? n 'stream-take "inexact argument")
+ (must-not negative? n 'stream-take "negative argument")
+ (stream-let recur ((n n) (strm strm))
+ (if (or (zero? n) (stream-null? strm)) stream-null
+ (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
+
+(define (stream-take-while pred? strm)
+ (must procedure? pred? 'stream-take-while "non-procedural argument")
+ (must stream? strm 'stream-take-while "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else stream-null))))
+
+(define (stream-unfold mapper pred? generator base)
+ (must procedure? mapper 'stream-unfold "non-procedural mapper")
+ (must procedure? pred? 'stream-unfold "non-procedural pred?")
+ (must procedure? generator 'stream-unfold "non-procedural generator")
+ (stream-let recur ((base base))
+ (if (pred? base)
+ (stream-cons (mapper base) (recur (generator base)))
+ stream-null)))
+
+(define (stream-unfolds gen seed)
+ (define-stream (generator-stream seed)
+ (receive (next . items) (gen seed)
+ (stream-cons (list->vector items) (generator-stream next))))
+ (define-stream (make-result-stream genstrm index)
+ (define head (vector-ref (stream-car genstrm) index))
+ (define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
+ (match head
+ (() stream-null)
+ (#f (tail))
+ ((item) (stream-cons item (tail)))
+ ((? list? items) (stream-append (list->stream items) (tail)))))
+
+ (must procedure? gen 'stream-unfolds "non-procedural argument")
+ (let ((genstrm (generator-stream seed)))
+ (apply values (list-tabulate (vector-length (stream-car genstrm))
+ (cut make-result-stream genstrm <>)))))
+
+(define (stream-zip strm . rest)
+ (let ((strms (cons strm rest)))
+ (must-every stream? strms 'stream-zip "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (map stream-car strms) (recur (map stream-cdr strms)))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index e7c8c41..01ffd1c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -131,6 +131,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-37.test \
tests/srfi-38.test \
tests/srfi-39.test \
+ tests/srfi-41.test \
tests/srfi-42.test \
tests/srfi-45.test \
tests/srfi-60.test \
diff --git a/test-suite/tests/srfi-41.test b/test-suite/tests/srfi-41.test
new file mode 100644
index 0000000..f2e0864
--- /dev/null
+++ b/test-suite/tests/srfi-41.test
@@ -0,0 +1,680 @@
+;;; srfi-41.test -- test suite for SRFI 41
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (test-srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-31)
+ #:use-module (srfi srfi-41)
+ #:use-module (test-suite lib))
+
+(define-stream (qsort lt? strm)
+ (if (stream-null? strm) stream-null
+ (let ((x (stream-car strm))
+ (xs (stream-cdr strm)))
+ (stream-append
+ (qsort lt? (stream-filter (cut lt? <> x) xs))
+ (stream x)
+ (qsort lt? (stream-filter (cut (negate lt?) <> x) xs))))))
+
+(define-stream (isort lt? strm)
+ (define-stream (insert strm x)
+ (stream-match strm
+ (() (stream x))
+ ((y . ys) (if (lt? y x)
+ (stream-cons y (insert ys x))
+ (stream-cons x strm)))))
+ (stream-fold insert stream-null strm))
+
+(define-stream (stream-merge lt? . strms)
+ (stream-let loop ((strms strms))
+ (cond ((null? strms) stream-null)
+ ((null? (cdr strms)) (car strms))
+ (else (stream-let merge ((xx (car strms))
+ (yy (loop (cdr strms))))
+ (stream-match xx
+ (() yy)
+ ((x . xs)
+ (stream-match yy
+ (() xx)
+ ((y . ys)
+ (if (lt? y x)
+ (stream-cons y (merge xx ys))
+ (stream-cons x (merge xs yy))))))))))))
+
+(define-stream (msort lt? strm)
+ (let* ((n (quotient (stream-length strm) 2))
+ (ts (stream-take n strm))
+ (ds (stream-drop n strm)))
+ (if (zero? n) strm
+ (stream-merge lt? (msort < ts) (msort < ds)))))
+
+(define-stream (stream-unique eql? strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (stream-car strm)
+ (stream-unique eql?
+ (stream-drop-while (cut eql? (stream-car strm) <>) strm)))))
+
+(define nats
+ (stream-cons 1
+ (stream-map 1+ nats)))
+
+(define hamming
+ (stream-unique =
+ (stream-cons 1
+ (stream-merge <
+ (stream-map (cut * 2 <>) hamming)
+ (stream-merge <
+ (stream-map (cut * 3 <>) hamming)
+ (stream-map (cut * 5 <>) hamming))))))
+
+(define primes (let ()
+ (define-stream (next base mult strm)
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (cond ((< first mult)
+ (stream-cons first
+ (next base mult rest)))
+ ((< mult first)
+ (next base (+ base mult) strm))
+ (else (next base
+ (+ base mult) rest)))))
+ (define-stream (sift base strm)
+ (next base (+ base base) strm))
+ (stream-let sieve ((strm (stream-from 2)))
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (stream-cons first (sieve (sift first rest)))))))
+
+(define strm123 (stream 1 2 3))
+
+(define (stream-equal? s1 s2)
+ (cond ((and (stream-null? s1) (stream-null? s2)) #t)
+ ((or (stream-null? s1) (stream-null? s2)) #f)
+ ((equal? (stream-car s1) (stream-car s2))
+ (stream-equal? (stream-cdr s1) (stream-cdr s2)))
+ (else #f)))
+
+(with-test-prefix "stream-null"
+ (pass-if "is a stream" (stream? stream-null))
+ (pass-if "is a null stream" (stream-null? stream-null))
+ (pass-if "is not a stream pair" (not (stream-pair? stream-null))))
+
+(with-test-prefix "stream-cons"
+ (pass-if "is a stream" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is not a null stream" (not (stream-null? (stream-cons 1 stream-null))))
+ (pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null))))
+
+(with-test-prefix "stream?"
+ (pass-if "is true for null stream" (stream? stream-null))
+ (pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is false for non-stream" (not (stream? "four"))))
+
+(with-test-prefix "stream-null?"
+ (pass-if "is true for null stream" (stream-null? stream-null))
+ (pass-if "is false for stream pair" (not (stream-null? (stream-cons 1 stream-null))))
+ (pass-if "is false for non-stream" (not (stream-null? "four"))))
+
+(with-test-prefix "stream-pair?"
+ (pass-if "is false for null stream" (not (stream-pair? stream-null)))
+ (pass-if "is true for stream pair" (stream-pair? (stream-cons 1 stream-null)))
+ (pass-if "is false for non-stream" (not (stream-pair? "four"))))
+
+(with-test-prefix "stream-car"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-car "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-car stream-null))
+ (pass-if "returns first of stream" (eqv? (stream-car strm123) 1)))
+
+(with-test-prefix "stream-cdr"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-cdr "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-cdr stream-null))
+ (pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123)) 2)))
+
+(with-test-prefix "stream-lambda"
+ (pass-if "returns correct result"
+ (stream-equal?
+ ((rec double (stream-lambda (strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm))))))
+ strm123)
+ (stream 2 4 6))))
+
+(with-test-prefix "define-stream"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (let ()
+ (define-stream (double strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm)))))
+ (double strm123))
+ (stream 2 4 6))))
+
+(with-test-prefix "list->stream"
+ (pass-if-exception "throws for non-list"
+ '(wrong-type-arg . "non-list argument")
+ (list->stream "four"))
+ (pass-if "returns empty stream for empty list"
+ (stream-null? (list->stream '())))
+ (pass-if "returns stream with same content as given list"
+ (stream-equal? (list->stream '(1 2 3)) strm123)))
+
+(with-test-prefix "port->stream"
+ (pass-if-exception "throws for non-input-port"
+ '(wrong-type-arg . "non-input-port argument")
+ (port->stream "four"))
+ (call-with-input-string "Hello, world!"
+ (lambda (p)
+ (pass-if-equal "reads input string correctly"
+ "Hello, world!"
+ (list->string (stream->list (port->stream p)))))))
+
+(with-test-prefix "stream"
+ (pass-if-equal "with empty stream"
+ '()
+ (stream->list (stream)))
+ (pass-if-equal "with one-element stream"
+ '(1)
+ (stream->list (stream 1)))
+ (pass-if-equal "with three-element stream"
+ '(1 2 3)
+ (stream->list strm123)))
+
+(with-test-prefix "stream->list"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream->list '()))
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer count")
+ (stream->list "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative count")
+ (stream->list -1 strm123))
+ (pass-if-equal "returns empty list for empty stream"
+ '()
+ (stream->list (stream)))
+ (pass-if-equal "without count"
+ '(1 2 3)
+ (stream->list strm123))
+ (pass-if-equal "with count longer than stream"
+ '(1 2 3)
+ (stream->list 5 strm123))
+ (pass-if-equal "with count shorter than stream"
+ '(1 2 3)
+ (stream->list 3 (stream-from 1))))
+
+(with-test-prefix "stream-append"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-append "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-append strm123) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2 3)))
+ (pass-if "with three streams"
+ (stream-equal? (stream-append strm123 strm123 strm123)
+ (stream 1 2 3 1 2 3 1 2 3)))
+ (pass-if "append with null is noop"
+ (stream-equal? (stream-append strm123 stream-null) strm123))
+ (pass-if "prepend with null is noop"
+ (stream-equal? (stream-append stream-null strm123) strm123)))
+
+(with-test-prefix "stream-concat"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-concat "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-concat (stream strm123)) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-concat (stream strm123 strm123))
+ (stream 1 2 3 1 2 3))))
+
+(with-test-prefix "stream-constant"
+ (pass-if "circular stream of 1 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1) 100) 1))
+ (pass-if "circular stream of 2 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1 2) 100) 1))
+ (pass-if "circular stream of 3 repeats after 3"
+ (eqv? (stream-ref (stream-constant 1 2 3) 3) 1))
+ (pass-if "circular stream of 1 repeats at 1"
+ (stream-equal? (stream-take 8 (stream-constant 1))
+ (stream 1 1 1 1 1 1 1 1)))
+ (pass-if "circular stream of 2 repeats at 2"
+ (stream-equal? (stream-take 8 (stream-constant 1 2))
+ (stream 1 2 1 2 1 2 1 2)))
+ (pass-if "circular stream of 3 repeats at 3"
+ (stream-equal? (stream-take 8 (stream-constant 1 2 3))
+ (stream 1 2 3 1 2 3 1 2))))
+
+(with-test-prefix "stream-drop"
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-drop "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative argument")
+ (stream-drop -1 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop 2 "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop 0 stream-null)))
+ (pass-if "returns same stream when count is zero"
+ (eq? (stream-drop 0 strm123) strm123))
+ (pass-if "returns dropped-by-one stream when count is one"
+ (stream-equal? (stream-drop 1 strm123) (stream 2 3)))
+ (pass-if "returns null if count is longer than stream"
+ (stream-null? (stream-drop 5 strm123))))
+
+(with-test-prefix "stream-drop-while"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-drop-while "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop-while odd? "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop-while odd? stream-null)))
+ (pass-if "returns dropped stream when first element matches"
+ (stream-equal? (stream-drop-while odd? strm123) (stream 2 3)))
+ (pass-if "returns whole stream when first element doesn't match"
+ (stream-equal? (stream-drop-while even? strm123) strm123))
+ (pass-if "returns empty stream if all elements match"
+ (stream-null? (stream-drop-while positive? strm123)))
+ (pass-if "return whole stream if no elements match"
+ (stream-equal? (stream-drop-while negative? strm123) strm123)))
+
+(with-test-prefix "stream-filter"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-filter "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-filter odd? '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-filter odd? (stream))))
+ (pass-if "filters out even numbers"
+ (stream-equal? (stream-filter odd? strm123) (stream 1 3)))
+ (pass-if "filters out odd numbers"
+ (stream-equal? (stream-filter even? strm123) (stream 2)))
+ (pass-if "returns all elements if predicate matches all"
+ (stream-equal? (stream-filter positive? strm123) strm123))
+ (pass-if "returns null if predicate matches none"
+ (stream-null? (stream-filter negative? strm123)))
+ (pass-if "all elements of an odd-filtered stream are odd"
+ (every odd? (stream->list 10 (stream-filter odd? (stream-from 0)))))
+ (pass-if "no elements of an odd-filtered stream are even"
+ (not (any even? (stream->list 10 (stream-filter odd? (stream-from 0)))))))
+
+(with-test-prefix "stream-fold"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-fold "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-fold + 0 '()))
+ (pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6)))
+
+(with-test-prefix "stream-for-each"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-for-each "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-for-each display))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-for-each display "four"))
+ (pass-if "function is called for stream elements"
+ (eqv? (let ((sum 0))
+ (stream-for-each (lambda (x)
+ (set! sum (+ sum x)))
+ strm123)
+ sum)
+ 6)))
+
+(with-test-prefix "stream-from"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-from "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-from 1 "four"))
+ (pass-if "works for default values"
+ (eqv? (stream-ref (stream-from 0) 100) 100))
+ (pass-if "works for non-default start and step"
+ (eqv? (stream-ref (stream-from 1 2) 100) 201))
+ (pass-if "works for negative step"
+ (eqv? (stream-ref (stream-from 0 -1) 100) -100)))
+
+(with-test-prefix "stream-iterate"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-iterate "four" 0))
+ (pass-if "returns correct iterated stream with 1+"
+ (stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123))
+ (pass-if "returns correct iterated stream with exact-integer-sqrt"
+ (stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt 65536))
+ (stream 65536 256 16 4 2))))
+
+(with-test-prefix "stream-length"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-length "four"))
+ (pass-if "returns 0 for empty stream" (zero? (stream-length (stream))))
+ (pass-if "returns correct stream length" (eqv? (stream-length strm123) 3)))
+
+(with-test-prefix "stream-let"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (stream-let loop ((strm strm123))
+ (if (stream-null? strm)
+ stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (loop (stream-cdr strm)))))
+ (stream 2 4 6))))
+
+(with-test-prefix "stream-map"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-map "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-map odd?))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-map odd? "four"))
+ (pass-if "works for one stream"
+ (stream-equal? (stream-map - strm123) (stream -1 -2 -3)))
+ (pass-if "works for two streams"
+ (stream-equal? (stream-map + strm123 strm123) (stream 2 4 6)))
+ (pass-if "returns finite stream for finite first stream"
+ (stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4 6)))
+ (pass-if "returns finite stream for finite last stream"
+ (stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4 6)))
+ (pass-if "works for three streams"
+ (stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6 9))))
+
+(with-test-prefix "stream-match"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-match '(1 2 3) (_ 'ok)))
+ (pass-if-exception "throws when no pattern matches"
+ '(match-error . "no matching pattern")
+ (stream-match strm123 (() 42)))
+ (pass-if-equal "matches empty stream correctly"
+ 'ok
+ (stream-match stream-null (() 'ok)))
+ (pass-if-equal "matches non-empty stream correctly"
+ 'ok
+ (stream-match strm123 (() 'no) (else 'ok)))
+ (pass-if-equal "matches stream of one element"
+ 1
+ (stream-match (stream 1) (() 'no) ((a) a)))
+ (pass-if-equal "matches wildcard"
+ 'ok
+ (stream-match (stream 1) (() 'no) ((_) 'ok)))
+ (pass-if-equal "matches stream of three elements"
+ '(1 2 3)
+ (stream-match strm123 ((a b c) (list a b c))))
+ (pass-if-equal "matches first element with wildcard rest"
+ 1
+ (stream-match strm123 ((a . _) a)))
+ (pass-if-equal "matches first two elements with wildcard rest"
+ '(1 2)
+ (stream-match strm123 ((a b . _) (list a b))))
+ (pass-if-equal "rest variable matches as stream"
+ '(1 2 3)
+ (stream-match strm123 ((a b . c) (list a b (stream-car c)))))
+ (pass-if-equal "rest variable can match whole stream"
+ '(1 2 3)
+ (stream-match strm123 (s (stream->list s))))
+ (pass-if-equal "successful guard match"
+ 'ok
+ (stream-match strm123 ((a . _) (= a 1) 'ok)))
+ (pass-if-equal "unsuccessful guard match"
+ 'no
+ (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)))
+ (pass-if-equal "unsuccessful guard match with two variables"
+ 'no
+ (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)))
+ (pass-if-equal "successful guard match with two variables"
+ 'yes
+ (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))))
+
+(with-test-prefix "stream-of"
+ (pass-if "all 3 clause types work"
+ (stream-equal? (stream-of (+ y 6)
+ (x in (stream-range 1 6))
+ (odd? x)
+ (y is (* x x)))
+ (stream 7 15 31)))
+ (pass-if "using two streams creates cartesian product"
+ (stream-equal? (stream-of (* x y)
+ (x in (stream-range 1 4))
+ (y in (stream-range 1 5)))
+ (stream 1 2 3 4 2 4 6 8 3 6 9 12)))
+ (pass-if "using no clauses returns just the expression"
+ (stream-equal? (stream-of 1) (stream 1))))
+
+(with-test-prefix "stream-range"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-range "four" 0))
+ (pass-if-exception "throws for non-numeric end"
+ '(wrong-type-arg . "non-numeric ending number")
+ (stream-range 0 "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-range 1 2 "three"))
+ (pass-if "returns increasing range if start < end"
+ (stream-equal? (stream-range 0 5) (stream 0 1 2 3 4)))
+ (pass-if "returns decreasing range if start > end"
+ (stream-equal? (stream-range 5 0) (stream 5 4 3 2 1)))
+ (pass-if "returns increasing range of step 2"
+ (stream-equal? (stream-range 0 5 2) (stream 0 2 4)))
+ (pass-if "returns decreasing range of step 2"
+ (stream-equal? (stream-range 5 0 -2) (stream 5 3 1)))
+ (pass-if "returns empty range if start is past end value"
+ (stream-null? (stream-range 0 1 -1))))
+
+(with-test-prefix "stream-ref"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-ref '() 4))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-ref nats 3.5))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-ref nats -3))
+ (pass-if-exception "throws if index goes past end of stream"
+ '(wrong-type-arg . "beyond end of stream")
+ (stream-ref strm123 5))
+ (pass-if-equal "returns first element when index = 0"
+ 1
+ (stream-ref nats 0))
+ (pass-if-equal "returns second element when index = 1"
+ 2
+ (stream-ref nats 1))
+ (pass-if-equal "returns third element when index = 2"
+ 3
+ (stream-ref nats 2)))
+
+(with-test-prefix "stream-reverse"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-reverse '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-reverse (stream))))
+ (pass-if "returns (3 2 1) for (1 2 3)"
+ (stream-equal? (stream-reverse strm123) (stream 3 2 1))))
+
+(with-test-prefix "stream-scan"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-scan "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-scan + 0 '()))
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6))))
+
+(with-test-prefix "stream-take"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take 5 "four"))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-take "four" strm123))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-take -4 strm123))
+ (pass-if "returns null for empty stream"
+ (stream-null? (stream-take 5 stream-null)))
+ (pass-if "using 0 index returns null for empty stream"
+ (stream-null? (stream-take 0 stream-null)))
+ (pass-if "using 0 index returns null for non-empty stream"
+ (stream-null? (stream-take 0 strm123)))
+ (pass-if "returns first 2 elements of stream"
+ (stream-equal? (stream-take 2 strm123) (stream 1 2)))
+ (pass-if "returns whole stream when index is same as length"
+ (stream-equal? (stream-take 3 strm123) strm123))
+ (pass-if "returns whole stream when index exceeds length"
+ (stream-equal? (stream-take 5 strm123) strm123)))
+
+(with-test-prefix "stream-take-while"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take-while odd? "four"))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-take-while "four" strm123))
+ (pass-if "returns stream up to first non-matching item"
+ (stream-equal? (stream-take-while odd? strm123) (stream 1)))
+ (pass-if "returns empty stream if first item doesn't match"
+ (stream-null? (stream-take-while even? strm123)))
+ (pass-if "returns whole stream if every item matches"
+ (stream-equal? (stream-take-while positive? strm123) strm123))
+ (pass-if "return empty stream if no item matches"
+ (stream-null? (stream-take-while negative? strm123))))
+
+(with-test-prefix "stream-unfold"
+ (pass-if-exception "throws for invalid mapper"
+ '(wrong-type-arg . "non-procedural mapper")
+ (stream-unfold "four" odd? + 0))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural pred?")
+ (stream-unfold + "four" + 0))
+ (pass-if-exception "throws for invalid generator"
+ '(wrong-type-arg . "non-procedural generator")
+ (stream-unfold + odd? "four" 0))
+
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0)
+ (stream 0 1 4 9 16 25 36 49 64 81))))
+
+(with-test-prefix "stream-unfolds"
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfolds
+ (lambda (x)
+ (receive (n s) (car+cdr x)
+ (if (zero? n)
+ (values 'dummy '())
+ (values
+ (cons (- n 1) (stream-cdr s))
+ (list (stream-car s))))))
+ (cons 5 (stream-from 0)))
+ (stream 0 1 2 3 4)))
+ (pass-if "handles returns of multiple elements correctly"
+ (stream-equal? (stream-take 16 (stream-unfolds
+ (lambda (n)
+ (values (1+ n) (iota n)))
+ 1))
+ (stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0)))
+ (receive (p np)
+ (stream-unfolds (lambda (x)
+ (receive (n p) (car+cdr x)
+ (if (= n (stream-car p))
+ (values (cons (1+ n) (stream-cdr p))
+ (list n) #f)
+ (values (cons (1+ n) p)
+ #f (list n)))))
+ (cons 1 primes))
+ (pass-if "returns first stream correctly"
+ (stream-equal? (stream-take 15 p)
+ (stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)))
+ (pass-if "returns second stream correctly"
+ (stream-equal? (stream-take 15 np)
+ (stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22 24)))))
+
+(with-test-prefix "stream-zip"
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-zip))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip "four"))
+ (pass-if-exception "throws if any argument is non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip strm123 "four"))
+ (pass-if "returns null when given null as any argument"
+ (stream-null? (stream-zip strm123 stream-null)))
+ (pass-if "returns single-element lists when given one stream"
+ (stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3))))
+ (pass-if "returns double-element lists when given two streams"
+ (stream-equal? (stream-zip strm123 strm123)
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns finite stream if at least one given stream is"
+ (stream-equal? (stream-zip strm123 (stream-from 1))
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns triple-element lists when given three streams"
+ (stream-equal? (stream-zip strm123 strm123 strm123)
+ (stream '(1 1 1) '(2 2 2) '(3 3 3)))))
+
+(with-test-prefix "other tests"
+ (pass-if-equal "returns biggest prime under 1000"
+ 997
+ (stream-car
+ (stream-reverse (stream-take-while (cut < <> 1000) primes))))
+
+ (pass-if "quicksort returns same result as insertion sort"
+ (stream-equal? (qsort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ (pass-if "merge sort returns same result as insertion sort"
+ (stream-equal? (msort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ ;; http://www.research.att.com/~njas/sequences/A051037
+ (pass-if-equal "returns 1000th Hamming number"
+ 51200000
+ (stream-ref hamming 999)))
--
1.7.10.4
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: [PATCH 2/2] Add full documentation for SRFI-41 --]
[-- Type: text/x-diff, Size: 29206 bytes --]
From 409abb6f5c607cd1d61f7b3350e77fb92ead0e5c Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 26 Mar 2013 21:03:42 -0400
Subject: [PATCH 2/2] Add full documentation for SRFI-41.
* doc/ref/misc-modules.texi (Streams): Add cross-reference to SRFI-41.
* doc/ref/srfi-modules.texi (SRFI-41): Replace stub with full
documentation.
(SRFI-41 Stream Fundamentals, SRFI-41 Stream Primitives,
SRFI-41 Stream Library): New subsubsections.
---
doc/ref/misc-modules.texi | 3 +
doc/ref/srfi-modules.texi | 703 ++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 704 insertions(+), 2 deletions(-)
diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index cf1e0e4..c1e65d7 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.texi
@@ -1573,6 +1573,9 @@ modifies the queue @var{list} then it must either maintain
@section Streams
@cindex streams
+This section documents Guile's legacy stream module. For a more
+complete and portable stream library, @pxref{SRFI-41}.
+
A stream represents a sequence of values, each of which is calculated
only when required. This allows large or even infinite sequences to
be represented and manipulated with familiar operations like ``car'',
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 5a89209..5b02aec 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -3793,8 +3793,707 @@ scope and the result from that @var{thunk} is the return from
@subsection SRFI-41 - Streams
@cindex SRFI-41
-See @uref{http://srfi.schemers.org/srfi-41/srfi-41.html, the
-specification of SRFI-41}.
+This subsection is based on the
+@uref{http://srfi.schemers.org/srfi-41/srfi-41.html, specification of
+SRFI-41} by Philip L.@: Bewig.
+
+@c The copyright notice and license text of the SRFI-41 specification is
+@c reproduced below:
+
+@c Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
+@c Permission is hereby granted, free of charge, to any person obtaining a
+@c copy of this software and associated documentation files (the
+@c "Software"), to deal in the Software without restriction, including
+@c without limitation the rights to use, copy, modify, merge, publish,
+@c distribute, sublicense, and/or sell copies of the Software, and to
+@c permit persons to whom the Software is furnished to do so, subject to
+@c the following conditions:
+
+@c The above copyright notice and this permission notice shall be included
+@c in all copies or substantial portions of the Software.
+
+@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+@noindent
+This SRFI implements streams, sometimes called lazy lists, a sequential
+data structure containing elements computed only on demand. A stream is
+either null or is a pair with a stream in its cdr. Since elements of a
+stream are computed only when accessed, streams can be infinite. Once
+computed, the value of a stream element is cached in case it is needed
+again. SRFI-41 can be made available with:
+
+@example
+(use-modules (srfi srfi-41))
+@end example
+
+@menu
+* SRFI-41 Stream Fundamentals::
+* SRFI-41 Stream Primitives::
+* SRFI-41 Stream Library::
+@end menu
+
+@node SRFI-41 Stream Fundamentals
+@subsubsection SRFI-41 Stream Fundamentals
+
+SRFI-41 Streams are based on two mutually-recursive abstract data types:
+An object of the @code{stream} abstract data type is a promise that,
+when forced, is either @code{stream-null} or is an object of type
+@code{stream-pair}. An object of the @code{stream-pair} abstract data
+type contains a @code{stream-car} and a @code{stream-cdr}, which must be
+a @code{stream}. The essential feature of streams is the systematic
+suspensions of the recursive promises between the two data types.
+
+The object stored in the @code{stream-car} of a @code{stream-pair} is a
+promise that is forced the first time the @code{stream-car} is accessed;
+its value is cached in case it is needed again. The object may have any
+type, and different stream elements may have different types. If the
+@code{stream-car} is never accessed, the object stored there is never
+evaluated. Likewise, the @code{stream-cdr} is a promise to return a
+stream, and is only forced on demand.
+
+@node SRFI-41 Stream Primitives
+@subsubsection SRFI-41 Stream Primitives
+
+This library provides eight operators: constructors for
+@code{stream-null} and @code{stream-pair}s, type predicates for streams
+and the two kinds of streams, accessors for both fields of a
+@code{stream-pair}, and a lambda that creates procedures that return
+streams.
+
+@deffn {Constant} stream-null
+A promise that, when forced, is a single object, distinguishable from
+all other objects, that represents the null stream. @code{stream-null}
+is immutable and unique.
+@end deffn
+
+@deffn {Scheme Syntax} stream-cons object-expr stream-expr
+Creates a newly-allocated stream containing a promise that, when forced,
+is a @code{stream-pair} with @var{object-expr} in its @code{stream-car}
+and @var{stream-expr} in its @code{stream-cdr}. Neither
+@var{object-expr} nor @var{stream-expr} is evaluated when
+@code{stream-cons} is called.
+
+Once created, a @code{stream-pair} is immutable; there is no
+@code{stream-set-car!} or @code{stream-set-cdr!} that modifies an
+existing stream-pair. There is no dotted-pair or improper stream as
+with lists.
+@end deffn
+
+@deffn {Scheme Procedure} stream? object
+Returns true if @var{object} is a stream, otherwise returns false. If
+@var{object} is a stream, its promise will not be forced. If
+@code{(stream? obj)} returns true, then one of @code{(stream-null? obj)}
+or @code{(stream-pair? obj)} will return true and the other will return
+false.
+@end deffn
+
+@deffn {Scheme Procedure} stream-null? object
+Returns true if @var{object} is the distinguished null stream, otherwise
+returns false. If @var{object} is a stream, its promise will be forced.
+@end deffn
+
+@deffn {Scheme Procedure} stream-pair? object
+Returns true if @var{object} is a @code{stream-pair} constructed by
+@code{stream-cons}, otherwise returns false. If @var{object} is a
+stream, its promise will be forced.
+@end deffn
+
+@deffn {Scheme Procedure} stream-car stream
+Returns the object stored in the @code{stream-car} of @var{stream}. An
+error is signalled if the argument is not a @code{stream-pair}. This
+causes the @var{object-expr} passed to @code{stream-cons} to be
+evaluated if it had not yet been; the value is cached in case it is
+needed again.
+@end deffn
+
+@deffn {Scheme Procedure} stream-cdr stream
+Returns the stream stored in the @code{stream-cdr} of @var{stream}. An
+error is signalled if the argument is not a @code{stream-pair}.
+@end deffn
+
+@deffn {Scheme Syntax} stream-lambda formals body @dots{}
+Creates a procedure that returns a promise to evaluate the @var{body} of
+the procedure. The last @var{body} expression to be evaluated must
+yield a stream. As with normal @code{lambda}, @var{formals} may be a
+single variable name, in which case all the formal arguments are
+collected into a single list, or a list of variable names, which may be
+null if there are no arguments, proper if there are an exact number of
+arguments, or dotted if a fixed number of arguments is to be followed by
+zero or more arguments collected into a list. @var{Body} must contain
+at least one expression, and may contain internal definitions preceding
+any expressions to be evaluated.
+@end deffn
+
+@example
+(define strm123
+ (stream-cons 1
+ (stream-cons 2
+ (stream-cons 3
+ stream-null))))
+
+(stream-car strm123) @result{} 1
+(stream-car (stream-cdr strm123) @result{} 2
+
+(stream-pair?
+ (stream-cdr
+ (stream-cons (/ 1 0) stream-null))) @result{} #f
+
+(stream? (list 1 2 3)) @result{} #f
+
+(define iter
+ (stream-lambda (f x)
+ (stream-cons x (iter f (f x)))))
+
+(define nats (iter (lambda (x) (+ x 1)) 0))
+
+(stream-car (stream-cdr nats)) @result{} 1
+
+(define stream-add
+ (stream-lambda (s1 s2)
+ (stream-cons
+ (+ (stream-car s1) (stream-car s2))
+ (stream-add (stream-cdr s1)
+ (stream-cdr s2)))))
+
+(define evens (stream-add nats nats))
+
+(stream-car evens) @result{} 0
+(stream-car (stream-cdr evens)) @result{} 2
+(stream-car (stream-cdr (stream-cdr evens))) @result{} 4
+@end example
+
+@node SRFI-41 Stream Library
+@subsubsection SRFI-41 Stream Library
+
+@deffn {Scheme Syntax} define-stream (name args @dots{}) body @dots{}
+Creates a procedure that returns a stream, and may appear anywhere a
+normal @code{define} may appear, including as an internal definition.
+It may contain internal definitions of its own. The defined procedure
+takes arguments in the same way as @code{stream-lambda}.
+@code{define-stream} is syntactic sugar on @code{stream-lambda}; see
+also @code{stream-let}, which is also a sugaring of
+@code{stream-lambda}.
+
+A simple version of @code{stream-map} that takes only a single input
+stream calls itself recursively:
+
+@example
+(define-stream (stream-map proc strm)
+ (if (stream-null? strm)
+ stream-null
+ (stream-cons
+ (proc (stream-car strm))
+ (stream-map proc (stream-cdr strm))))))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} list->stream list
+Returns a newly-allocated stream containing the elements from
+@var{list}.
+@end deffn
+
+@deffn {Scheme Procedure} port->stream [port]
+Returns a newly-allocated stream containing in its elements the
+characters on the port. If @var{port} is not given it defaults to the
+current input port. The returned stream has finite length and is
+terminated by @code{stream-null}.
+
+It looks like one use of @code{port->stream} would be this:
+
+@example
+(define s ;wrong!
+ (with-input-from-file filename
+ (lambda () (port->stream))))
+@end example
+
+But that fails, because @code{with-input-from-file} is eager, and closes
+the input port prematurely, before the first character is read. To read
+a file into a stream, say:
+
+@example
+(define-stream (file->stream filename)
+ (let ((p (open-input-file filename)))
+ (stream-let loop ((c (read-char p)))
+ (if (eof-object? c)
+ (begin (close-input-port p)
+ stream-null)
+ (stream-cons c
+ (loop (read-char p)))))))
+@end example
+@end deffn
+
+@deffn {Scheme Syntax} stream object-expr @dots{}
+Creates a newly-allocated stream containing in its elements the objects,
+in order. The @var{object-expr}s are evaluated when they are accessed,
+not when the stream is created. If no objects are given, as in
+(stream), the null stream is returned. See also @code{list->stream}.
+
+@example
+(define strm123 (stream 1 2 3))
+
+; (/ 1 0) not evaluated when stream is created
+(define s (stream 1 (/ 1 0) -1))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream->list [n] stream
+Returns a newly-allocated list containing in its elements the first
+@var{n} items in @var{stream}. If @var{stream} has less than @var{n}
+items, all the items in the stream will be included in the returned
+list. If @var{n} is not given it defaults to infinity, which means that
+unless @var{stream} is finite @code{stream->list} will never return.
+
+@example
+(stream->list 10
+ (stream-map (lambda (x) (* x x))
+ (stream-from 0)))
+ @result{} (0 1 4 9 16 25 36 49 64 81)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-append stream @dots{}
+Returns a newly-allocated stream containing in its elements those
+elements contained in its input @var{stream}s, in order of input. If
+any of the input streams is infinite, no elements of any of the
+succeeding input streams will appear in the output stream. See also
+@code{stream-concat}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-concat stream
+Takes a @var{stream} consisting of one or more streams and returns a
+newly-allocated stream containing all the elements of the input streams.
+If any of the streams in the input @var{stream} is infinite, any
+remaining streams in the input stream will never appear in the output
+stream. See also @code{stream-append}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-constant object @dots{}
+Returns a newly-allocated stream containing in its elements the
+@var{object}s, repeating in succession forever.
+
+@example
+(stream-constant 1) @result{} 1 1 1 @dots{}
+(stream-constant #t #f) @result{} #t #f #t #f #t #f @dots{}
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-drop n stream
+Returns the suffix of the input @var{stream} that starts at the next
+element after the first @var{n} elements. The output stream shares
+structure with the input @var{stream}; thus, promises forced in one
+instance of the stream are also forced in the other instance of the
+stream. If the input @var{stream} has less than @var{n} elements,
+@code{stream-drop} returns the null stream. See also
+@code{stream-take}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-drop-while pred stream
+Returns the suffix of the input @var{stream} that starts at the first
+element @var{x} for which @code{(pred x)} returns false. The output
+stream shares structure with the input @var{stream}. See also
+@code{stream-take-while}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-filter pred stream
+Returns a newly-allocated stream that contains only those elements
+@var{x} of the input @var{stream} which satisfy the predicate
+@code{pred}.
+
+@example
+(stream-filter odd? (stream-from 0))
+ @result{} 1 3 5 7 9 @dots{}
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-fold proc base stream
+Applies a binary procedure @var{proc} to @var{base} and the first
+element of @var{stream} to compute a new @var{base}, then applies the
+procedure to the new @var{base} and the next element of @var{stream} to
+compute a succeeding @var{base}, and so on, accumulating a value that is
+finally returned as the value of @code{stream-fold} when the end of the
+stream is reached. @var{stream} must be finite, or @code{stream-fold}
+will enter an infinite loop. See also @code{stream-scan}, which is
+similar to @code{stream-fold}, but useful for infinite streams. For
+readers familiar with other functional languages, this is a left-fold;
+there is no corresponding right-fold, since right-fold relies on finite
+streams that are fully-evaluated, in which case they may as well be
+converted to a list.
+@end deffn
+
+@deffn {Scheme Procedure} stream-for-each proc stream @dots{}
+Applies @var{proc} element-wise to corresponding elements of the input
+@var{stream}s for side-effects; it returns nothing.
+@code{stream-for-each} stops as soon as any of its input streams is
+exhausted.
+@end deffn
+
+@deffn {Scheme Procedure} stream-from first [step]
+Creates a newly-allocated stream that contains @var{first} as its first
+element and increments each succeeding element by @var{step}. If
+@var{step} is not given it defaults to 1. @var{first} and @var{step}
+may be of any numeric type. @code{stream-from} is frequently useful as
+a generator in @code{stream-of} expressions. See also
+@code{stream-range} for a similar procedure that creates finite streams.
+@end deffn
+
+@deffn {Scheme Procedure} stream-iterate proc base
+Creates a newly-allocated stream containing @var{base} in its first
+element and applies @var{proc} to each element in turn to determine the
+succeeding element. See also @code{stream-unfold} and
+@code{stream-unfolds}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-length stream
+Returns the number of elements in the @var{stream}; it does not evaluate
+its elements. @code{stream-length} may only be used on finite streams;
+it enters an infinite loop with infinite streams.
+@end deffn
+
+@deffn {Scheme Syntax} stream-let tag ((var expr) @dots{}) body @dots{}
+Creates a local scope that binds each variable to the value of its
+corresponding expression. It additionally binds @var{tag} to a
+procedure which takes the bound variables as arguments and @var{body} as
+its defining expressions, binding the @var{tag} with
+@code{stream-lambda}. @var{tag} is in scope within body, and may be
+called recursively. When the expanded expression defined by the
+@code{stream-let} is evaluated, @code{stream-let} evaluates the
+expressions in its @var{body} in an environment containing the
+newly-bound variables, returning the value of the last expression
+evaluated, which must yield a stream.
+
+@code{stream-let} provides syntactic sugar on @code{stream-lambda}, in
+the same manner as normal @code{let} provides syntactic sugar on normal
+@code{lambda}. However, unlike normal @code{let}, the @var{tag} is
+required, not optional, because unnamed @code{stream-let} is
+meaningless.
+
+For example, @code{stream-member} returns the first @code{stream-pair}
+of the input @var{strm} with a @code{stream-car} @var{x} that satisfies
+@code{(eql? obj x)}, or the null stream if @var{x} is not present in
+@var{strm}.
+
+@example
+(define-stream (stream-member eql? obj strm)
+ (stream-let loop ((strm strm))
+ (cond ((stream-null? strm) strm)
+ ((eql? obj (stream-car strm)) strm)
+ (else (loop (stream-cdr strm))))))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-map proc stream @dots{}
+Applies @var{proc} element-wise to corresponding elements of the input
+@var{stream}s, returning a newly-allocated stream containing elements
+that are the results of those procedure applications. The output stream
+has as many elements as the minimum-length input stream, and may be
+infinite.
+@end deffn
+
+@deffn {Scheme Syntax} stream-match stream clause @dots{}
+Provides pattern-matching for streams. The input @var{stream} is an
+expression that evaluates to a stream. Clauses are of the form
+@code{(pattern [fender] expression)}, consisting of a @var{pattern} that
+matches a stream of a particular shape, an optional @var{fender} that
+must succeed if the pattern is to match, and an @var{expression} that is
+evaluated if the pattern matches. There are four types of patterns:
+
+@itemize @bullet
+@item
+() matches the null stream.
+
+@item
+(@var{pat0} @var{pat1} @dots{}) matches a finite stream with length
+exactly equal to the number of pattern elements.
+
+@item
+(@var{pat0} @var{pat1} @dots{} @code{.} @var{pat-rest}) matches an
+infinite stream, or a finite stream with length at least as great as the
+number of pattern elements before the literal dot.
+
+@item
+@var{pat} matches an entire stream. Should always appear last in the
+list of clauses; it's not an error to appear elsewhere, but subsequent
+clauses could never match.
+@end itemize
+
+Each pattern element may be either:
+
+@itemize @bullet
+@item
+An identifier, which matches any stream element. Additionally, the
+value of the stream element is bound to the variable named by the
+identifier, which is in scope in the @var{fender} and @var{expression}
+of the corresponding @var{clause}. Each identifier in a single pattern
+must be unique.
+
+@item
+A literal underscore (@code{_}), which matches any stream element but
+creates no bindings.
+@end itemize
+
+The @var{pattern}s are tested in order, left-to-right, until a matching
+pattern is found; if @var{fender} is present, it must evaluate to a true
+value for the match to be successful. Pattern variables are bound in
+the corresponding @var{fender} and @var{expression}. Once the matching
+@var{pattern} is found, the corresponding @var{expression} is evaluated
+and returned as the result of the match. An error is signaled if no
+pattern matches the input @var{stream}.
+
+@code{stream-match} is often used to distinguish null streams from
+non-null streams, binding @var{head} and @var{tail}:
+
+@example
+(define (len strm)
+ (stream-match strm
+ (() 0)
+ ((head . tail) (+ 1 (len tail)))))
+@end example
+
+Fenders can test the common case where two stream elements must be
+identical; the @code{else} pattern is an identifier bound to the entire
+stream, not a keyword as in @code{cond}.
+
+@example
+(stream-match strm
+ ((x y . _) (equal? x y) 'ok)
+ (else 'error))
+@end example
+
+A more complex example uses two nested matchers to match two different
+stream arguments; @code{(stream-merge lt? . strms)} stably merges two or
+more streams ordered by the @code{lt?} predicate:
+
+@example
+(define-stream (stream-merge lt? . strms)
+ (define-stream (merge xx yy)
+ (stream-match xx (() yy) ((x . xs)
+ (stream-match yy (() xx) ((y . ys)
+ (if (lt? y x)
+ (stream-cons y (merge xx ys))
+ (stream-cons x (merge xs yy))))))))
+ (stream-let loop ((strms strms))
+ (cond ((null? strms) stream-null)
+ ((null? (cdr strms)) (car strms))
+ (else (merge (car strms)
+ (apply stream-merge lt?
+ (cdr strms)))))))
+@end example
+@end deffn
+
+@deffn {Scheme Syntax} stream-of expr clause @dots{}
+Provides the syntax of stream comprehensions, which generate streams by
+means of looping expressions. The result is a stream of objects of the
+type returned by @var{expr}. There are four types of clauses:
+
+@itemize @bullet
+@item
+(@var{var} @code{in} @var{stream-expr}) loops over the elements of
+@var{stream-expr}, in order from the start of the stream, binding each
+element of the stream in turn to @var{var}. @code{stream-from} and
+@code{stream-range} are frequently useful as generators for
+@var{stream-expr}.
+
+@item
+(@var{var} @code{is} @var{expr}) binds @var{var} to the value obtained
+by evaluating @var{expr}.
+
+@item
+(@var{pred} @var{expr}) includes in the output stream only those
+elements @var{x} which satisfy the predicate @var{pred}.
+@end itemize
+
+The scope of variables bound in the stream comprehension is the clauses
+to the right of the binding clause (but not the binding clause itself)
+plus the result expression.
+
+When two or more generators are present, the loops are processed as if
+they are nested from left to right; that is, the rightmost generator
+varies fastest. A consequence of this is that only the first generator
+may be infinite and all subsequent generators must be finite. If no
+generators are present, the result of a stream comprehension is a stream
+containing the result expression; thus, @samp{(stream-of 1)} produces a
+finite stream containing only the element 1.
+
+@example
+(stream-of (* x x)
+ (x in (stream-range 0 10))
+ (even? x))
+ @result{} 0 4 16 36 64
+
+(stream-of (list a b)
+ (a in (stream-range 1 4))
+ (b in (stream-range 1 3)))
+ @result{} (1 1) (1 2) (2 1) (2 2) (3 1) (3 2)
+
+(stream-of (list i j)
+ (i in (stream-range 1 5))
+ (j in (stream-range (+ i 1) 5)))
+ @result{} (1 2) (1 3) (1 4) (2 3) (2 4) (3 4)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-range first past [step]
+Creates a newly-allocated stream that contains @var{first} as its first
+element and increments each succeeding element by @var{step}. The
+stream is finite and ends before @var{past}, which is not an element of
+the stream. If @var{step} is not given it defaults to 1 if @var{first}
+is less than past and -1 otherwise. @var{first}, @var{past} and
+@var{step} may be of any real numeric type. @code{stream-range} is
+frequently useful as a generator in @code{stream-of} expressions. See
+also @code{stream-from} for a similar procedure that creates infinite
+streams.
+
+@example
+(stream-range 0 10) @result{} 0 1 2 3 4 5 6 7 8 9
+(stream-range 0 10 2) @result{} 0 2 4 6 8
+@end example
+
+Successive elements of the stream are calculated by adding @var{step} to
+@var{first}, so if any of @var{first}, @var{past} or @var{step} are
+inexact, the length of the output stream may differ from
+@code{(ceiling (- (/ (- past first) step) 1)}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-ref stream n
+Returns the @var{n}th element of stream, counting from zero. An error
+is signaled if @var{n} is greater than or equal to the length of stream.
+
+@example
+(define (fact n)
+ (stream-ref
+ (stream-scan * 1 (stream-from 1))
+ n))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-reverse stream
+Returns a newly-allocated stream containing the elements of the input
+@var{stream} but in reverse order. @code{stream-reverse} may only be
+used with finite streams; it enters an infinite loop with infinite
+streams. @code{stream-reverse} does not force evaluation of the
+elements of the stream.
+@end deffn
+
+@deffn {Scheme Procedure} stream-scan proc base stream
+Accumulates the partial folds of an input @var{stream} into a
+newly-allocated output stream. The output stream is the @var{base}
+followed by @code{(stream-fold proc base (stream-take i stream))} for
+each of the first @var{i} elements of @var{stream}.
+
+@example
+(stream-scan + 0 (stream-from 1))
+ @result{} (stream 0 1 3 6 10 15 @dots{})
+
+(stream-scan * 1 (stream-from 1))
+ @result{} (stream 1 1 2 6 24 120 @dots{})
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-take n stream
+Returns a newly-allocated stream containing the first @var{n} elements
+of the input @var{stream}. If the input @var{stream} has less than
+@var{n} elements, so does the output stream. See also
+@code{stream-drop}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-take-while pred stream
+Takes a predicate and a @code{stream} and returns a newly-allocated
+stream containing those elements @code{x} that form the maximal prefix
+of the input stream which satisfy @var{pred}. See also
+@code{stream-drop-while}.
+@end deffn
+
+@deffn {Scheme Procedure} stream-unfold map pred gen base
+The fundamental recursive stream constructor. It constructs a stream by
+repeatedly applying @var{gen} to successive values of @var{base}, in the
+manner of @code{stream-iterate}, then applying @var{map} to each of the
+values so generated, appending each of the mapped values to the output
+stream as long as @code{(pred? base)} returns a true value. See also
+@code{stream-iterate} and @code{stream-unfolds}.
+
+The expression below creates the finite stream @samp{0 1 4 9 16 25 36 49
+64 81}. Initially the @var{base} is 0, which is less than 10, so
+@var{map} squares the @var{base} and the mapped value becomes the first
+element of the output stream. Then @var{gen} increments the @var{base}
+by 1, so it becomes 1; this is less than 10, so @var{map} squares the
+new @var{base} and 1 becomes the second element of the output stream.
+And so on, until the base becomes 10, when @var{pred} stops the
+recursion and stream-null ends the output stream.
+
+@example
+(stream-unfold
+ (lambda (x) (expt x 2)) ; map
+ (lambda (x) (< x 10)) ; pred?
+ (lambda (x) (+ x 1)) ; gen
+ 0) ; base
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-unfolds proc seed
+Returns @var{n} newly-allocated streams containing those elements
+produced by successive calls to the generator @var{proc}, which takes
+the current @var{seed} as its argument and returns @var{n}+1 values
+
+(@var{proc} @var{seed}) @result{} @var{seed} @var{result_0} @dots{} @var{result_n-1}
+
+where the returned @var{seed} is the input @var{seed} to the next call
+to the generator and @var{result_i} indicates how to produce the next
+element of the @var{i}th result stream:
+
+@itemize @bullet
+@item
+(@var{value}): @var{value} is the next car of the result stream.
+
+@item
+@code{#f}: no value produced by this iteration of the generator
+@var{proc} for the result stream.
+
+@item
+(): the end of the result stream.
+@end itemize
+
+It may require multiple calls of @var{proc} to produce the next element
+of any particular result stream. See also @code{stream-iterate} and
+@code{stream-unfold}.
+
+@example
+(define (stream-partition pred? strm)
+ (stream-unfolds
+ (lambda (s)
+ (if (stream-null? s)
+ (values s '() '())
+ (let ((a (stream-car s))
+ (d (stream-cdr s)))
+ (if (pred? a)
+ (values d (list a) #f)
+ (values d #f (list a))))))
+ strm))
+
+(call-with-values
+ (lambda ()
+ (stream-partition odd?
+ (stream-range 1 6)))
+ (lambda (odds evens)
+ (list (stream->list odds)
+ (stream->list evens))))
+ @result{} ((1 3 5) (2 4))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} stream-zip stream @dots{}
+Returns a newly-allocated stream in which each element is a list (not a
+stream) of the corresponding elements of the input @var{stream}s. The
+output stream is as long as the shortest input @var{stream}, if any of
+the input @var{stream}s is finite, or is infinite if all the input
+@var{stream}s are infinite.
+@end deffn
@node SRFI-42
@subsection SRFI-42 - Eager Comprehensions
--
1.7.10.4
^ permalink raw reply related [flat|nested] 6+ messages in thread
* Re: [PATCH] Add SRFI-41
2013-03-27 3:00 ` Mark H Weaver
@ 2013-03-27 17:43 ` Mark H Weaver
2013-03-27 20:58 ` Ludovic Courtès
1 sibling, 0 replies; 6+ messages in thread
From: Mark H Weaver @ 2013-03-27 17:43 UTC (permalink / raw)
To: Andy Wingo; +Cc: Chris K. Jester-Young, guile-devel
I went ahead and pushed this to stable-2.0. Thanks, cky! :)
Mark
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [PATCH] Add SRFI-41
2013-03-27 3:00 ` Mark H Weaver
2013-03-27 17:43 ` Mark H Weaver
@ 2013-03-27 20:58 ` Ludovic Courtès
1 sibling, 0 replies; 6+ messages in thread
From: Ludovic Courtès @ 2013-03-27 20:58 UTC (permalink / raw)
To: guile-devel
This looks great, thanks to both of you!
Ludo’.
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2013-03-27 20:58 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2013-03-21 0:38 [PATCH] Add SRFI-41 Mark H Weaver
2013-03-21 8:55 ` Andy Wingo
2013-03-27 2:53 ` Mark H Weaver
2013-03-27 3:00 ` Mark H Weaver
2013-03-27 17:43 ` Mark H Weaver
2013-03-27 20:58 ` Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).