From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: Re: [PATCH] Add SRFI-41 Date: Tue, 26 Mar 2013 23:00:45 -0400 Message-ID: <87obe57dia.fsf@tines.lan> References: <87li9hbn8m.fsf@tines.lan> <87ip4lxhc5.fsf@pobox.com> <87sj3h7dty.fsf@tines.lan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1364353329 20486 80.91.229.3 (27 Mar 2013 03:02:09 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Wed, 27 Mar 2013 03:02:09 +0000 (UTC) Cc: "Chris K. Jester-Young" , guile-devel@gnu.org To: Andy Wingo Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Wed Mar 27 04:02:32 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UKgdB-00088F-VC for guile-devel@m.gmane.org; Wed, 27 Mar 2013 04:02:30 +0100 Original-Received: from localhost ([::1]:55084 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UKgcn-0001WK-VP for guile-devel@m.gmane.org; Tue, 26 Mar 2013 23:02:06 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:44710) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UKgcc-0001VT-RY for guile-devel@gnu.org; Tue, 26 Mar 2013 23:02:02 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UKgcR-0005JO-F3 for guile-devel@gnu.org; Tue, 26 Mar 2013 23:01:54 -0400 Original-Received: from world.peace.net ([96.39.62.75]:50778) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UKgcQ-0005J6-RA for guile-devel@gnu.org; Tue, 26 Mar 2013 23:01:43 -0400 Original-Received: from 209-6-91-212.c3-0.smr-ubr1.sbo-smr.ma.cable.rcn.com ([209.6.91.212] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1UKgbd-0000c1-D8; Tue, 26 Mar 2013 23:00:56 -0400 In-Reply-To: <87sj3h7dty.fsf@tines.lan> (Mark H. Weaver's message of "Tue, 26 Mar 2013 22:53:45 -0400") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16013 Archived-At: --=-=-= Content-Type: text/plain and here are the actual patches :) Mark --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Add-SRFI-41.patch Content-Transfer-Encoding: quoted-printable Content-Description: [PATCH 1/2] Add SRFI-41 >From 3d58c8cfbab13bf96e1c1d6dd81be2f8f259eaf2 Mon Sep 17 00:00:00 2001 From: "Chris K. Jester-Young" Date: Tue, 26 Mar 2013 22:15:31 -0400 Subject: [PATCH 1/2] Add SRFI-41. Incorporates suggestions from Mark H Weaver and Ian Price . * 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 . --- 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 Shar= ed Structure * SRFI-39:: Parameter objects +* SRFI-41:: Streams. * SRFI-42:: Eager comprehensions * SRFI-45:: Primitives for expressing iterative lazy a= lgorithms * SRFI-55:: Requiring Features. @@ -3788,6 +3789,13 @@ scope and the result from that @var{thunk} is the re= turn from @code{with-parameters*}. @end defun =20 +@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 =3D \ 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: . So for now, we duplicate the +;; code. + +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2003 Andr=C3=A9 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-promis= e? + (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 (stre= am-promise-val promise*))) + (stream-value-proc-set! content + (stream-value-proc (st= ream-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 st= ream") + (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)))) str= m))) + +(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?) + (=3D stream-car var) + (=3D 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 (=3D> 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 =3D 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 =3D + (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 st= ream-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-n= ull))) + (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-fr= om 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-sqr= t 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 . _) (=3D a 1) 'ok))) + (pass-if-equal "unsuccessful guard match" + 'no + (stream-match strm123 ((a . _) (=3D a 2) 'yes) (_ 'no))) + (pass-if-equal "unsuccessful guard match with two variables" + 'no + (stream-match strm123 ((a b c) (=3D a b) 'yes) (_ 'no))) + (pass-if-equal "successful guard match with two variables" + 'yes + (stream-match (stream 1 1 2) ((a b c) (=3D 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 =3D 0" + 1 + (stream-ref nats 0)) + (pass-if-equal "returns second element when index =3D 1" + 2 + (stream-ref nats 1)) + (pass-if-equal "returns third element when index =3D 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 (=3D 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 2= 4))))) + +(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) prime= s)))) + + (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))) --=20 1.7.10.4 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0002-Add-full-documentation-for-SRFI-41.patch Content-Description: [PATCH 2/2] Add full documentation for SRFI-41 >From 409abb6f5c607cd1d61f7b3350e77fb92ead0e5c Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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 --=-=-=--