From 61fe1ce0070bffac0276a4967c53ac47fda53c67 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sun, 18 Nov 2007 20:58:25 -0500 Subject: [PATCH] Added an extras directory containing SRFI-41:streams implementation. --- Makefile.am | 2 +- Makefile.in | 2 +- configure | 3 +- configure.ac | 2 +- extras/Makefile.am | 5 + extras/Makefile.in | 364 +++++++++++++++++++++++++++++++++ extras/streams.ss | 38 ++++ extras/streams/derived.ss | 387 ++++++++++++++++++++++++++++++++++++ extras/streams/primitive.ss | 96 +++++++++ 9 files changed, 895 insertions(+), 4 deletions(-) create mode 100644 extras/Makefile.am create mode 100644 extras/Makefile.in create mode 100644 extras/streams.ss create mode 100644 extras/streams/derived.ss create mode 100644 extras/streams/primitive.ss diff --git a/Makefile.am b/Makefile.am index 450af5c..c3a62a7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,4 +1,4 @@ AUTOMAKE_OPTIONS = foreign -SUBDIRS = src scheme doc +SUBDIRS = src scheme doc extras EXTRA_DIST = README COPYING GPL-3 dist_doc_DATA=README COPYING GPL-3 diff --git a/Makefile.in b/Makefile.in index e6c87bb..8302d6a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -183,7 +183,7 @@ target_vendor = @target_vendor@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ AUTOMAKE_OPTIONS = foreign -SUBDIRS = src scheme doc +SUBDIRS = src scheme doc extras EXTRA_DIST = README COPYING GPL-3 dist_doc_DATA = README COPYING GPL-3 all: config.h diff --git a/configure b/configure index 840254c..d17c0c0 100755 --- a/configure +++ b/configure @@ -8293,7 +8293,7 @@ done ac_config_headers="$ac_config_headers config.h" -ac_config_files="$ac_config_files Makefile src/Makefile scheme/Makefile doc/Makefile" +ac_config_files="$ac_config_files Makefile src/Makefile scheme/Makefile doc/Makefile extras/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure @@ -8892,6 +8892,7 @@ do "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; "scheme/Makefile") CONFIG_FILES="$CONFIG_FILES scheme/Makefile" ;; "doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;; + "extras/Makefile") CONFIG_FILES="$CONFIG_FILES extras/Makefile" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} diff --git a/configure.ac b/configure.ac index 8917f0a..a8e6c1e 100644 --- a/configure.ac +++ b/configure.ac @@ -85,6 +85,6 @@ AC_FUNC_STRFTIME AC_FUNC_STRTOD AC_CHECK_FUNCS([bzero gettimeofday memmove memset munmap setenv sqrt strerror]) AC_CONFIG_HEADERS([config.h]) -AC_CONFIG_FILES(Makefile src/Makefile scheme/Makefile doc/Makefile) +AC_CONFIG_FILES(Makefile src/Makefile scheme/Makefile doc/Makefile extras/Makefile) AC_OUTPUT #(Makefile src/Makefile scheme/Makefile doc/Makefile) diff --git a/extras/Makefile.am b/extras/Makefile.am new file mode 100644 index 0000000..4dbdb78 --- /dev/null +++ b/extras/Makefile.am @@ -0,0 +1,5 @@ +libstreamsdir=$(pkglibdir)/streams +dist_libstreams_DATA=streams/primitive.ss streams/derived.ss + +dist_pkglib_DATA=streams.ss + diff --git a/extras/Makefile.in b/extras/Makefile.in new file mode 100644 index 0000000..35a0c68 --- /dev/null +++ b/extras/Makefile.in @@ -0,0 +1,364 @@ +# Makefile.in generated by automake 1.10 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +target_triplet = @target@ +subdir = extras +DIST_COMMON = $(dist_libstreams_DATA) $(dist_pkglib_DATA) \ + $(srcdir)/Makefile.am $(srcdir)/Makefile.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs +CONFIG_HEADER = $(top_builddir)/config.h +CONFIG_CLEAN_FILES = +SOURCES = +DIST_SOURCES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; +am__installdirs = "$(DESTDIR)$(libstreamsdir)" \ + "$(DESTDIR)$(pkglibdir)" +dist_libstreamsDATA_INSTALL = $(INSTALL_DATA) +dist_pkglibDATA_INSTALL = $(INSTALL_DATA) +DATA = $(dist_libstreams_DATA) $(dist_pkglib_DATA) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CC = @CC@ +CCAS = @CCAS@ +CCASDEPMODE = @CCASDEPMODE@ +CCASFLAGS = @CCASFLAGS@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +EXEEXT = @EXEEXT@ +GREP = @GREP@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LDFLAGS = @LDFLAGS@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LTLIBOBJS = @LTLIBOBJS@ +MAKEINFO = @MAKEINFO@ +MKDIR_P = @MKDIR_P@ +OBJEXT = @OBJEXT@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +POW_LIB = @POW_LIB@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +STRIP = @STRIP@ +VERSION = @VERSION@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_CC = @ac_ct_CC@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target = @target@ +target_alias = @target_alias@ +target_cpu = @target_cpu@ +target_os = @target_os@ +target_vendor = @target_vendor@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ +libstreamsdir = $(pkglibdir)/streams +dist_libstreams_DATA = streams/primitive.ss streams/derived.ss +dist_pkglib_DATA = streams.ss +all: all-am + +.SUFFIXES: +$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign extras/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --foreign extras/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +install-dist_libstreamsDATA: $(dist_libstreams_DATA) + @$(NORMAL_INSTALL) + test -z "$(libstreamsdir)" || $(MKDIR_P) "$(DESTDIR)$(libstreamsdir)" + @list='$(dist_libstreams_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(dist_libstreamsDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(libstreamsdir)/$$f'"; \ + $(dist_libstreamsDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(libstreamsdir)/$$f"; \ + done + +uninstall-dist_libstreamsDATA: + @$(NORMAL_UNINSTALL) + @list='$(dist_libstreams_DATA)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(libstreamsdir)/$$f'"; \ + rm -f "$(DESTDIR)$(libstreamsdir)/$$f"; \ + done +install-dist_pkglibDATA: $(dist_pkglib_DATA) + @$(NORMAL_INSTALL) + test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)" + @list='$(dist_pkglib_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(dist_pkglibDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(pkglibdir)/$$f'"; \ + $(dist_pkglibDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(pkglibdir)/$$f"; \ + done + +uninstall-dist_pkglibDATA: + @$(NORMAL_UNINSTALL) + @list='$(dist_pkglib_DATA)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(pkglibdir)/$$f'"; \ + rm -f "$(DESTDIR)$(pkglibdir)/$$f"; \ + done +tags: TAGS +TAGS: + +ctags: CTAGS +CTAGS: + + +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile $(DATA) +installdirs: + for dir in "$(DESTDIR)$(libstreamsdir)" "$(DESTDIR)$(pkglibdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-generic + +dvi: dvi-am + +dvi-am: + +html: html-am + +info: info-am + +info-am: + +install-data-am: install-dist_libstreamsDATA + +install-dvi: install-dvi-am + +install-exec-am: install-dist_pkglibDATA + +install-html: install-html-am + +install-info: install-info-am + +install-man: + +install-pdf: install-pdf-am + +install-ps: install-ps-am + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-dist_libstreamsDATA uninstall-dist_pkglibDATA + +.MAKE: install-am install-strip + +.PHONY: all all-am check check-am clean clean-generic distclean \ + distclean-generic distdir dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am \ + install-dist_libstreamsDATA install-dist_pkglibDATA \ + install-dvi install-dvi-am install-exec install-exec-am \ + install-html install-html-am install-info install-info-am \ + install-man install-pdf install-pdf-am install-ps \ + install-ps-am install-strip installcheck installcheck-am \ + installdirs maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \ + uninstall-am uninstall-dist_libstreamsDATA \ + uninstall-dist_pkglibDATA + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/extras/streams.ss b/extras/streams.ss new file mode 100644 index 0000000..751851e --- /dev/null +++ b/extras/streams.ss @@ -0,0 +1,38 @@ +#!r6rs +;;; This file is part of SRFI-41: streams +;;; It is included in Ikarus for your convenience. +;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for +;;; details. +;;; +;;; Copyright (C) Philip L. Bewig (2007). 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. + +(library (streams) + + (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) + + (import (streams primitive) (streams derived))) diff --git a/extras/streams/derived.ss b/extras/streams/derived.ss new file mode 100644 index 0000000..85ba0aa --- /dev/null +++ b/extras/streams/derived.ss @@ -0,0 +1,387 @@ +#!r6rs +;;; This file is part of SRFI-41: streams +;;; It is included in Ikarus for your convenience. +;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for +;;; details. +;;; +;;; Copyright (C) Philip L. Bewig (2007). 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. + +(library (streams derived) + + (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) + + (import (rnrs) (streams primitive)) + + (define-syntax define-stream + (syntax-rules () + ((define-stream (name . formal) body0 body1 ...) + (define name (stream-lambda formal body0 body1 ...))))) + + (define (list->stream objs) + (define list->stream + (stream-lambda (objs) + (if (null? objs) + stream-null + (stream-cons (car objs) (list->stream (cdr objs)))))) + (if (not (list? objs)) + (error 'list->stream "non-list argument") + (list->stream objs))) + + (define (port->stream . port) + (define port->stream + (stream-lambda (p) + (let ((c (read-char p))) + (if (eof-object? c) + stream-null + (stream-cons c (port->stream p)))))) + (let ((p (if (null? port) (current-input-port) (car port)))) + (if (not (input-port? p)) + (error 'port->stream "non-input-port argument") + (port->stream p)))) + + (define-syntax stream + (syntax-rules () + ((stream) stream-null) + ((stream x y ...) (stream-cons x (stream y ...))))) + + (define (stream->list . args) + (let ((n (if (= 1 (length args)) #f (car args))) + (strm (if (= 1 (length args)) (car args) (cadr args)))) + (cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) + ((and n (not (integer? n))) (error 'stream->list "non-integer count")) + ((and n (negative? n)) (error 'stream->list "negative count")) + (else (let loop ((n (if n n -1)) (strm strm)) + (if (or (zero? n) (stream-null? strm)) + '() + (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) + + (define (stream-append . strms) + (define stream-append + (stream-lambda (strms) + (cond ((null? (cdr strms)) (car strms)) + ((stream-null? (car strms)) (stream-append (cdr strms))) + (else (stream-cons (stream-car (car strms)) + (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) + (cond ((null? strms) stream-null) + ((exists (lambda (x) (not (stream? x))) strms) + (error 'stream-append "non-stream argument")) + (else (stream-append strms)))) + + (define (stream-concat strms) + (define stream-concat + (stream-lambda (strms) + (cond ((stream-null? strms) stream-null) + ((not (stream? (stream-car strms))) + (error 'stream-concat "non-stream object in input stream")) + ((stream-null? (stream-car strms)) + (stream-concat (stream-cdr strms))) + (else (stream-cons + (stream-car (stream-car strms)) + (stream-concat + (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) + (if (not (stream? strms)) + (error 'stream-concat "non-stream argument") + (stream-concat strms))) + + (define stream-constant + (stream-lambda objs + (cond ((null? objs) stream-null) + ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) + (else (stream-cons (car objs) + (apply stream-constant (append (cdr objs) (list (car objs))))))))) + + (define (stream-drop n strm) + (define stream-drop + (stream-lambda (n strm) + (if (or (zero? n) (stream-null? strm)) + strm + (stream-drop (- n 1) (stream-cdr strm))))) + (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) + ((negative? n) (error 'stream-drop "negative argument")) + ((not (stream? strm)) (error 'stream-drop "non-stream argument")) + (else (stream-drop n strm)))) + + (define (stream-drop-while pred? strm) + (define stream-drop-while + (stream-lambda (strm) + (if (and (stream-pair? strm) (pred? (stream-car strm))) + (stream-drop-while (stream-cdr strm)) + strm))) + (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) + ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) + (else (stream-drop-while strm)))) + + (define (stream-filter pred? strm) + (define stream-filter + (stream-lambda (strm) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) + (else (stream-filter (stream-cdr strm)))))) + (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) + ((not (stream? strm)) (error 'stream-filter "non-stream argument")) + (else (stream-filter strm)))) + + (define (stream-fold proc base strm) + (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) + ((not (stream? strm)) (error 'stream-fold "non-stream argument")) + (else (let loop ((base base) (strm strm)) + (if (stream-null? strm) + base + (loop (proc base (stream-car strm)) (stream-cdr strm))))))) + + (define (stream-for-each proc . strms) + (define (stream-for-each strms) + (if (not (exists stream-null? strms)) + (begin (apply proc (map stream-car strms)) + (stream-for-each (map stream-cdr strms))))) + (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) + ((null? strms) (error 'stream-for-each "no stream arguments")) + ((exists (lambda (x) (not (stream? x))) strms) + (error 'stream-for-each "non-stream argument")) + (else (stream-for-each strms)))) + + (define (stream-from first . step) + (define stream-from + (stream-lambda (first delta) + (stream-cons first (stream-from (+ first delta) delta)))) + (let ((delta (if (null? step) 1 (car step)))) + (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) + ((not (number? delta)) (error 'stream-from "non-numeric step size")) + (else (stream-from first delta))))) + + (define (stream-iterate proc base) + (define stream-iterate + (stream-lambda (base) + (stream-cons base (stream-iterate (proc base))))) + (if (not (procedure? proc)) + (error 'stream-iterate "non-procedural argument") + (stream-iterate base))) + + (define (stream-length strm) + (if (not (stream? strm)) + (error 'stream-length "non-stream argument") + (let loop ((len 0) (strm strm)) + (if (stream-null? strm) + len + (loop (+ len 1) (stream-cdr strm)))))) + + (define-syntax stream-let + (syntax-rules () + ((stream-let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)))) + + (define (stream-map proc . strms) + (define stream-map + (stream-lambda (strms) + (if (exists stream-null? strms) + stream-null + (stream-cons (apply proc (map stream-car strms)) + (stream-map (map stream-cdr strms)))))) + (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) + ((null? strms) (error 'stream-map "no stream arguments")) + ((exists (lambda (x) (not (stream? x))) strms) + (error 'stream-map "non-stream argument")) + (else (stream-map strms)))) + + (define-syntax stream-match + (syntax-rules () + ((stream-match strm-expr clause ...) + (let ((strm strm-expr)) + (cond + ((not (stream? strm)) (error 'stream-match "non-stream argument")) + ((stream-match-test strm clause) => car) ... + (else (error 'stream-match "pattern failure"))))))) + + (define-syntax stream-match-test + (syntax-rules () + ((stream-match-test strm (pattern fender expr)) + (stream-match-pattern strm pattern () (and fender (list expr)))) + ((stream-match-test strm (pattern expr)) + (stream-match-pattern strm pattern () (list expr))))) + + (define-syntax stream-match-pattern + (lambda (x) + (define (wildcard? x) + (and (identifier? x) + (free-identifier=? x (syntax _)))) + (syntax-case x () + ((stream-match-pattern strm () (binding ...) body) + (syntax (and (stream-null? strm) (let (binding ...) body)))) + ((stream-match-pattern strm (w? . rest) (binding ...) body) + (wildcard? #'w?) + (syntax (and (stream-pair? strm) + (let ((strm (stream-cdr strm))) + (stream-match-pattern strm rest (binding ...) body))))) + ((stream-match-pattern strm (var . rest) (binding ...) body) + (syntax (and (stream-pair? strm) + (let ((temp (stream-car strm)) (strm (stream-cdr strm))) + (stream-match-pattern strm rest ((var temp) binding ...) body))))) + ((stream-match-pattern strm w? (binding ...) body) + (wildcard? #'w?) + (syntax (let (binding ...) body))) + ((stream-match-pattern strm var (binding ...) body) + (syntax (let ((var strm) binding ...) body)))))) + + (define-syntax stream-of + (syntax-rules () + ((_ expr rest ...) + (stream-of-aux expr stream-null rest ...)))) + + (define-syntax stream-of-aux + (syntax-rules (in is) + ((stream-of-aux expr base) + (stream-cons expr base)) + ((stream-of-aux expr base (var in stream) rest ...) + (stream-let loop ((strm stream)) + (if (stream-null? strm) + base + (let ((var (stream-car strm))) + (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) + ((stream-of-aux expr base (var is exp) rest ...) + (let ((var exp)) (stream-of-aux expr base rest ...))) + ((stream-of-aux expr base pred? rest ...) + (if pred? (stream-of-aux expr base rest ...) base)))) + + (define (stream-range first past . step) + (define stream-range + (stream-lambda (first past delta lt?) + (if (lt? first past) + (stream-cons first (stream-range (+ first delta) past delta lt?)) + stream-null))) + (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) + ((not (number? past)) (error 'stream-range "non-numeric ending number")) + (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) + (if (not (number? delta)) + (error 'stream-range "non-numeric step size") + (let ((lt? (if (< 0 delta) < >))) + (stream-range first past delta lt?))))))) + + (define (stream-ref strm n) + (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) + ((not (integer? n)) (error 'stream-ref "non-integer argument")) + ((negative? n) (error 'stream-ref "negative argument")) + (else (let loop ((strm strm) (n n)) + (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) + ((zero? n) (stream-car strm)) + (else (loop (stream-cdr strm) (- n 1)))))))) + + (define (stream-reverse strm) + (define stream-reverse + (stream-lambda (strm rev) + (if (stream-null? strm) + rev + (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev))))) + (if (not (stream? strm)) + (error 'stream-reverse "non-stream argument") + (stream-reverse strm stream-null))) + + (define (stream-scan proc base strm) + (define stream-scan + (stream-lambda (base strm) + (if (stream-null? strm) + (stream base) + (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) + (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) + ((not (stream? strm)) (error 'stream-scan "non-stream argument")) + (else (stream-scan base strm)))) + + (define (stream-take n strm) + (define stream-take + (stream-lambda (n strm) + (if (or (stream-null? strm) (zero? n)) + stream-null + (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) + (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) + ((not (integer? n)) (error 'stream-take "non-integer argument")) + ((negative? n) (error 'stream-take "negative argument")) + (else (stream-take n strm)))) + + (define (stream-take-while pred? strm) + (define stream-take-while + (stream-lambda (strm) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) + (else stream-null)))) + (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) + ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) + (else (stream-take-while strm)))) + + (define (stream-unfold mapper pred? generator base) + (define stream-unfold + (stream-lambda (base) + (if (pred? base) + (stream-cons (mapper base) (stream-unfold (generator base))) + stream-null))) + (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) + ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) + ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) + (else (stream-unfold base)))) + + (define (stream-unfolds gen seed) + (define (len-values gen seed) + (call-with-values + (lambda () (gen seed)) + (lambda vs (- (length vs) 1)))) + (define unfold-result-stream + (stream-lambda (gen seed) + (call-with-values + (lambda () (gen seed)) + (lambda (next . results) + (stream-cons results (unfold-result-stream gen next)))))) + (define result-stream->output-stream + (stream-lambda (result-stream i) + (let ((result (list-ref (stream-car result-stream) (- i 1)))) + (cond ((pair? result) + (stream-cons + (car result) + (result-stream->output-stream (stream-cdr result-stream) i))) + ((not result) + (result-stream->output-stream (stream-cdr result-stream) i)) + ((null? result) stream-null) + (else (error 'stream-unfolds "can't happen")))))) + (define (result-stream->output-streams result-stream) + (let loop ((i (len-values gen seed)) (outputs '())) + (if (zero? i) + (apply values outputs) + (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs))))) + (if (not (procedure? gen)) + (error 'stream-unfolds "non-procedural argument") + (result-stream->output-streams (unfold-result-stream gen seed)))) + + (define (stream-zip . strms) + (define stream-zip + (stream-lambda (strms) + (if (exists stream-null? strms) + stream-null + (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) + (cond ((null? strms) (error 'stream-zip "no stream arguments")) + ((exists (lambda (x) (not (stream? x))) strms) + (error 'stream-zip "non-stream argument")) + (else (stream-zip strms))))) diff --git a/extras/streams/primitive.ss b/extras/streams/primitive.ss new file mode 100644 index 0000000..57d7491 --- /dev/null +++ b/extras/streams/primitive.ss @@ -0,0 +1,96 @@ +#!r6rs +;;; This file is part of SRFI-41: streams +;;; It is included in Ikarus for your convenience. +;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for +;;; details. +;;; +;;; Copyright (C) Philip L. Bewig (2007). 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. + +(library (streams primitive) + + (export stream-null stream-cons stream? stream-null? stream-pair? + stream-car stream-cdr stream-lambda) + + (import (rnrs) (rnrs mutable-pairs)) + + (define-record-type (stream-type make-stream stream?) + (fields (mutable box stream-promise stream-promise!))) + + (define-syntax stream-lazy + (syntax-rules () + ((lazy expr) + (make-stream + (cons 'lazy (lambda () expr)))))) + + (define (stream-eager expr) + (make-stream + (cons 'eager expr))) + + (define-syntax stream-delay + (syntax-rules () + ((stream-delay expr) + (stream-lazy (stream-eager expr))))) + + (define (stream-force promise) + (let ((content (stream-promise promise))) + (case (car content) + ((eager) (cdr content)) + ((lazy) (let* ((promise* ((cdr content))) + (content (stream-promise promise))) + (if (not (eqv? (car content) 'eager)) + (begin (set-car! content (car (stream-promise promise*))) + (set-cdr! content (cdr (stream-promise promise*))) + (stream-promise! promise* content))) + (stream-force promise)))))) + + (define stream-null (stream-delay (cons 'stream 'null))) + + (define-record-type (stream-pare-type make-stream-pare stream-pare?) + (fields (immutable kar stream-kar) (immutable kdr stream-kdr))) + + (define (stream-pair? obj) + (and (stream? obj) (stream-pare? (stream-force obj)))) + + (define (stream-null? obj) + (and (stream? obj) + (eqv? (stream-force obj) + (stream-force stream-null)))) + + (define-syntax stream-cons + (syntax-rules () + ((stream-cons obj strm) + (stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) + + (define (stream-car strm) + (cond ((not (stream? strm)) (error 'stream-car "non-stream")) + ((stream-null? strm) (error 'stream-car "null stream")) + (else (stream-force (stream-kar (stream-force strm)))))) + + (define (stream-cdr strm) + (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) + ((stream-null? strm) (error 'stream-cdr "null stream")) + (else (stream-kdr (stream-force strm))))) + + (define-syntax stream-lambda + (syntax-rules () + ((stream-lambda formals body0 body1 ...) + (lambda formals (stream-lazy (let () body0 body1 ...)))))))