This page is part of the web mail archives of SRFI 40 from before July 7th, 2015. The new archives for SRFI 40 contain all messages, not just those from before July 7th, 2015.
I'm attaching a reference implementation that works. This solves the following problems (in order of importance) with the past reference implementation: 1. Problems with (force (lazy (delay expr))). See my mail with Message-Id 20040611070831.GA29954@xxxxxxxxxx for details. 2. Fixes stream-filter. The previous version wouldn't work when passed stream-null (as in (stream-filter even? stream-null)). 3. Changes the name make-stream to ##srfi-40#make-stream as it is a rather low-level operation and it /might/ be desirable to define make-stream with an interface similar to make-list. I hope it helps. Alejo. http://bachue.com/alejo ---=( Comunidad de Usuarios de Software Libre en Colombia )=--- ---=( http://bachue.com/colibri )=--=( colibri@xxxxxxxxxx )=---
;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS
;;; A stream is a new data type, disjoint from all other data types, that
;;; contains a promise that, when forced, is either nil (a single object
;;; distinguishable from all other objects) or consists of an object (the
;;; stream element) followed by a stream. Each stream element is evaluated
;;; exactly once, when it is first retrieved (not when it is created); once
;;; evaluated its value is saved to be returned by subsequent retrievals
;;; without being evaluated again.
;; STREAM-TYPE -- type of streams
;; STREAM? object -- #t if object is a stream, #f otherwise
; Use ##srfi-40#make-stream instead of make-stream, as this is a rather
; low-level operation and it /might/ be desirable to define make-stream
; with an interface similar to make-list. -- AFC
(define-record-type stream-type
(##srfi-40#make-stream promise)
stream?
(promise stream-promise stream-promise-set!))
;;; UTILITY FUNCTIONS
;; STREAM-ERROR message -- print message then abort execution
; replace this with a call to the native error handler
; if stream-error returns, so will the stream library function that called it
(define (stream-error message) (display message) (newline) (car '()))
;; ANY pred? list -- first non-#f (pred? list-item), else #f
(define (any pred? lst)
(cond ((null? lst) #f)
((null? (cdr lst)) (pred? (car lst)))
(else (or (pred? (car lst)) (any pred? (cdr lst))))))
;; ALL pred? list -- #f if any (pred? list-item) is #f, or last pred?
(define (all pred? lst)
(cond ((null? lst) #t)
((null? (cdr lst)) (pred? (car lst)))
(else (and (pred? (car lst)) (all pred? (cdr lst))))))
;;; LOW-LEVEL STREAM FUNCTIONS by Andre von Tonder (private e-mail 13-SEP-2003)
; Corrected by Alejandro Forero Cuervo, according to mail from 12 Jun 2004,
; Message-ID: Pine.GSO.4.60.0406112149190.11369@xxxxxxxxxxxxxxxxx
(define box vector)
(define (unbox b) (vector-ref b 0))
(define (set-box! b v) (vector-set! b 0 v))
;; STREAM-LOW-LEVEL-LAZY -- an "atomic" (delay (force ...))
(define-syntax stream-low-level-lazy
(syntax-rules ()
((stream-low-level-lazy exp)
(box (cons 'suspension (lambda () exp))))))
;; STREAM-LOW-LEVEL-STRICT -- make a value into a low-level promise
(define (stream-low-level-strict x)
(##srfi-40#make-stream (box (cons 'value x))))
;; STREAM-LOW-LEVEL-DELAY -- make an expression into a low-level promise
(define-syntax stream-low-level-delay
(syntax-rules ()
((stream-low-level-delay exp)
(stream-low-level-lazy (stream-low-level-strict exp)))))
;; STREAM-LOW-LEVEL-FORCE -- force the value from a low-level promise
(define (stream-low-level-force promise)
(let ((content (unbox (stream-promise promise))))
(case (car content)
((value) (cdr content))
((suspension) (let ((promise* ((cdr content)))
(content (unbox (stream-promise promise))))
(when (not (eqv? (car content) 'value))
(set-box! (stream-promise promise) (unbox (stream-promise promise*)))
(stream-promise-set! promise* (stream-promise promise)))
(stream-low-level-force promise))))))
;;; STREAM SYNTAX AND FUNCTIONS
;; STREAM-NULL -- the distinguished nil stream
(define stream-null (##srfi-40#make-stream (stream-low-level-delay '())))
;; STREAM-CONS object stream -- primitive constructor of streams
(define-syntax stream-cons
(syntax-rules ()
((stream-cons obj strm)
(##srfi-40#make-stream
(stream-low-level-delay
(if (not (stream? strm))
(stream-error "attempt to stream-cons onto non-stream")
(cons obj strm)))))))
;; STREAM-NULL? object -- #t if object is the null stream, #f otherwise
(define (stream-null? obj)
(and (stream? obj) (null? (stream-low-level-force obj))))
;; STREAM-PAIR? object -- #t if object is a non-null stream, #f otherwise
(define (stream-pair? obj)
(and (stream? obj) (not (null? (stream-low-level-force obj)))))
;; STREAM-CAR stream -- first element of stream
(define (stream-car strm)
(cond ((not (stream? strm)) (stream-error "attempt to take stream-car of non-stream"))
((stream-null? strm) (stream-error "attempt to take stream-car of null stream"))
(else (car (stream-low-level-force strm)))))
;; STREAM-CDR stream -- remaining elements of stream after first
(define (stream-cdr strm)
(cond ((not (stream? strm)) (stream-error "attempt to take stream-cdr of non-stream"))
((stream-null? strm) (stream-error "attempt to take stream-cdr of null stream"))
(else (cdr (stream-low-level-force strm)))))
;; STREAM-DELAY object -- the essential stream mechanism
(define-syntax stream-delay
(syntax-rules ()
((stream-delay expr)
(##srfi-40#make-stream
(stream-low-level-lazy expr)))))
;; STREAM object ... -- new stream whose elements are object ...
(define (stream . objs)
(let loop ((objs objs))
(stream-delay
(if (null? objs)
stream-null
(stream-cons (car objs) (loop (cdr objs)))))))
;; STREAM-UNFOLDN generator seed n -- n+1 streams from (generator seed)
(define (stream-unfoldn gen seed n)
(define (unfold-result-stream gen seed)
(let loop ((seed seed))
(stream-delay
(call-with-values
(lambda () (gen seed))
(lambda (next . results)
(stream-cons results (loop next)))))))
(define (result-stream->output-stream result-stream i)
(stream-delay
(let ((result (list-ref (stream-car result-stream) i)))
(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 (stream-error "can't happen"))))))
(define (result-stream->output-streams result-stream n)
(let loop ((i 0) (outputs '()))
(if (= i n)
(apply values (reverse outputs))
(loop (+ i 1)
(cons (result-stream->output-stream result-stream i)
outputs)))))
(result-stream->output-streams (unfold-result-stream gen seed) n))
;; STREAM-MAP func stream ... -- stream produced by applying func element-wise
(define (stream-map func . strms)
(cond ((not (procedure? func)) (stream-error "non-functional argument to stream-map"))
((null? strms) (stream-error "no stream arguments to stream-map"))
((not (all stream? strms)) (stream-error "non-stream argument to stream-map"))
(else (let loop ((strms strms))
(stream-delay
(if (any stream-null? strms)
stream-null
(stream-cons (apply func (map stream-car strms))
(loop (map stream-cdr strms)))))))))
;; STREAM-FOR-EACH proc stream ... -- apply proc element-wise for side-effects
(define (stream-for-each proc . strms)
(cond ((not (procedure? proc)) (stream-error "non-functional argument to stream-for-each"))
((null? strms) (stream-error "no stream arguments to stream-for-each"))
((not (all stream? strms)) (stream-error "non-stream argument to stream-for-each"))
(else (let loop ((strms strms))
(if (not (any stream-null? strms))
(begin (apply proc (map stream-car strms))
(loop (map stream-cdr strms))))))))
;; STREAM-FILTER pred? stream -- new stream including only items passing pred?
; Corrected by Alejandro Forero Cuervo in 15 Jul 2004 to work in stream-null
(define (stream-filter pred? strm)
(cond ((not (procedure? pred?)) (stream-error "non-functional argument to stream-filter"))
((not (stream? strm)) (stream-error "attempt to apply stream-filter to non-stream"))
(else (stream-unfoldn
(lambda (s)
(if (stream-null? s)
(values #f '())
(values
(stream-cdr s)
(and (pred? (stream-car s)) (list (stream-car s))))))
strm
1))))
Attachment:
signature.asc
Description: Digital signature