suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add streams to `racket'

Browse Source 
- rename old `racket/stream' to `racket/sequence', and adjust
   to avoid stateful iterations
 - add a new `racket/stream' library with a `strean-cons' that is based
   on SRFI 41
 - adjust `for' and some sequence constructors like `in-range' to
   work more directly with streams
This commit is contained in:
Matthew Flatt 2011-03-18 18:45:31 -06:00
parent ae8b326522
commit e652546bf5
15 changed files with 1501 additions and 867 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/main.rkt
View File

@ -26,6 +26,7 @@
racket/promise
racket/bool
racket/stream
racket/sequence
racket/local
racket/system
(for-syntax racket/base))
@ -56,6 +57,7 @@
racket/promise
racket/bool
racket/stream
racket/sequence
racket/local
racket/system)
(for-syntax (all-from-out racket/base)))

301
collects/racket/private/for.rkt
View File

@ -34,6 +34,7 @@
(rename *in-vector in-vector)
(rename *in-string in-string)
(rename *in-bytes in-bytes)
(rename *in-stream in-stream)
(rename *in-input-port-bytes in-input-port-bytes)
(rename *in-input-port-chars in-input-port-chars)
(rename *in-port in-port)
@ -48,12 +49,22 @@
in-sequences
in-cycle
in-parallel
in-values-sequence
in-values*-sequence
stop-before
stop-after
(rename *in-producer in-producer)
(rename *in-indexed in-indexed)
(rename *in-value in-value)
stream?
stream-empty?
stream-first
stream-rest
prop:stream
sequence->stream
empty-stream make-do-stream
sequence?
sequence-generate
prop:sequence
@ -293,8 +304,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sequences
;; streams & sequences
;; structure type for generic sequences:
(define-values (struct:do-sequence
make-do-sequence
do-sequence?
@ -302,6 +314,40 @@
do-sequence-set!)
(make-struct-type 'sequence #f 1 0 #f))
;; property for generic streams
(define-values (prop:stream stream-via-prop? stream-ref)
(make-struct-type-property
'stream
(lambda (v si)
(unless (and (vector? v)
(= 3 (vector-length v))
(procedure? (vector-ref v 0))
(procedure-arity-includes? (vector-ref v 0) 1)
(procedure? (vector-ref v 1))
(procedure-arity-includes? (vector-ref v 1) 1)
(procedure? (vector-ref v 2))
(procedure-arity-includes? (vector-ref v 2) 1))
(raise-type-error 'guard-for-prop:stream
"vector of three procedures (arity 1)"
v))
(vector->immutable-vector v))))
;; new-style sequence property, where the property value is a procedure
;; to get the sequence-driving value and procedures;
;; this property is not currently exported
(define-values (prop:gen-sequence sequence-via-prop? sequence-ref)
(make-struct-type-property
'sequence
(lambda (v si)
(unless (and (procedure? v)
(procedure-arity-includes? v 1))
(raise-type-error 'guard-for-prop:sequence
"procedure (arity 1)"
v))
v)))
;; exported sequence property, where the property value
;; is a procedure to get a sequence
(define-values (prop:sequence :sequence? :sequence-ref)
(make-struct-type-property
'sequence
@ -325,9 +371,61 @@
clause-transformer-expr
(syntax-local-certifier #f)))]))
(define (stream? v)
(or (list? v)
(stream-via-prop? v)))
(define (unsafe-stream-not-empty? v)
(if (null? v)
#f
(or (pair? v)
(not ((unsafe-vector-ref (stream-ref v) 0) v)))))
(define (stream-empty? v)
(or (null? v)
(if (stream? v)
(if (pair? v)
#f
((unsafe-vector-ref (stream-ref v) 0) v))
(raise-type-error 'stream-empty?
"stream"
v))))
(define (unsafe-stream-first v)
(cond
[(pair? v) (car v)]
[else ((unsafe-vector-ref (stream-ref v) 1) v)]))
(define (stream-first v)
(if (and (stream? v)
(not (stream-empty? v)))
(unsafe-stream-first v)
(raise-type-error 'stream-first
"non-empty stream"
v)))
(define (unsafe-stream-rest v)
(cond
[(pair? v) (cdr v)]
[else (let ([r ((unsafe-vector-ref (stream-ref v) 2) v)])
(unless (stream? r)
(raise-mismatch-error 'stream-rest-guard
"result is not a stream: "
r))
r)]))
(define (stream-rest v)
(if (and (stream? v)
(not (stream-empty? v)))
(unsafe-stream-rest v)
(raise-type-error 'stream-rest
"non-empty stream"
v)))
(define (sequence? v)
(or (do-sequence? v)
(list? v)
(sequence-via-prop? v)
(stream? v)
(mpair? v)
(vector? v)
(string? v)
@ -339,14 +437,16 @@
(define (make-sequence who v)
(cond
[(do-sequence? v) ((do-sequence-ref v 0))]
[(list? v) (:list-gen v)]
[(mpair? v) (:mlist-gen v)]
[(list? v) (:list-gen v)]
[(vector? v) (:vector-gen v 0 (vector-length v) 1)]
[(string? v) (:string-gen v 0 (string-length v) 1)]
[(bytes? v) (:bytes-gen v 0 (bytes-length v) 1)]
[(input-port? v) (:input-port-gen v)]
[(hash? v) (:hash-key+val-gen v)]
[(sequence-via-prop? v) ((sequence-ref v) v)]
[(:sequence? v) (make-sequence who ((:sequence-ref v) v))]
[(stream? v) (:stream-gen v)]
[else (raise
(exn:fail:contract
(format "for: expected a sequence for ~a, got something else: ~v"
@ -355,7 +455,34 @@
who)
v)
(current-continuation-marks)))]))
(define-values (struct:range
make-range
range?
range-ref
range-set!)
(make-struct-type 'stream #f 3 0 #f
(list (cons prop:stream
(vector
(lambda (v)
(let ([cont? (range-ref v 2)])
(and cont?
(not (cont? (range-ref v 0))))))
(lambda (v) (range-ref v 0))
(lambda (v) (make-range
((range-ref v 1) (range-ref v 0))
(range-ref v 1)
(range-ref v 2)))))
(cons prop:gen-sequence
(lambda (v)
(values
values
(range-ref v 1)
(range-ref v 0)
(range-ref v 2)
#f
#f))))))
(define in-range
(case-lambda
[(b) (in-range 0 b 1)]
@ -364,16 +491,11 @@
(unless (real? a) (raise-type-error 'in-range "real-number" a))
(unless (real? b) (raise-type-error 'in-range "real-number" b))
(unless (real? step) (raise-type-error 'in-range "real-number" step))
(make-do-sequence (lambda ()
(values
(lambda (x) x)
(lambda (x) (+ x step))
a
(if (step . >= . 0)
(lambda (x) (< x b))
(lambda (x) (> x b)))
void
void)))]))
(let* ([cont? (if (step . >= . 0)
(lambda (x) (< x b))
(lambda (x) (> x b)))]
[inc (lambda (x) (+ x step))])
(make-range a inc cont?))]))
(define in-naturals
(case-lambda
@ -385,11 +507,32 @@
(raise-type-error 'in-naturals
"exact non-negative integer"
n))
(make-do-sequence (lambda () (values values add1 n void void void)))]))
(make-range n add1 #f)]))
(define-values (struct:list-stream
make-list-stream
list-stream?
list-stream-ref
list-stream-set!)
(make-struct-type 'stream #f 1 0 #f
(list (cons prop:stream
(vector
(lambda (v) (not (pair? (list-stream-ref v 0))))
(lambda (v) (car (list-stream-ref v 0)))
(lambda (v) (make-list-stream (cdr (list-stream-ref v 0))))))
(cons prop:gen-sequence
(lambda (v)
(values
car
cdr
(list-stream-ref v 0)
pair?
#f
#f))))))
(define (in-list l)
;; (unless (list? l) (raise-type-error 'in-list "list" l))
(make-do-sequence (lambda () (:list-gen l))))
(make-list-stream l))
(define (:list-gen l)
(values car cdr l pair? #f #f))
@ -481,6 +624,13 @@
#f
#f))
(define (in-stream l)
(unless (stream? l) (raise-type-error 'in-stream "stream" l))
(make-do-sequence (lambda () (:stream-gen l))))
(define (:stream-gen l)
(values unsafe-stream-first unsafe-stream-rest l unsafe-stream-not-empty? #f #f))
;; Vector-like sequences --------------------------------------------------
;; (: check-ranges (Symbol Natural Integer Integer Natural -> Void))
@ -741,6 +891,44 @@
void
void))))
(define (in-values-sequence g)
(unless (sequence? g) (raise-type-error 'in-values-sequence "sequence" g))
(make-do-sequence (lambda ()
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-sequence #f g)])
(values (lambda (pos) (call-with-values (lambda () (pos->val pos))
list))
pos-next
init
pos-cont?
(and pre-cont?
(lambda (vals) (apply pre-cont? vals)))
(and post-cont?
(lambda (pos vals) (apply post-cont? pos vals))))))))
(define (in-values*-sequence g)
(unless (sequence? g) (raise-type-error 'in-values-sequence "sequence" g))
(make-do-sequence (lambda ()
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-sequence #f g)])
(values (lambda (pos) (call-with-values (lambda () (pos->val pos))
(case-lambda
[(v) (if (list? v) (list v) v)]
[vs vs])))
pos-next
init
pos-cont?
(and pre-cont?
(lambda (vals)
(if (list? vals)
(apply pre-cont? vals)
(pre-cont? vals))))
(and post-cont?
(lambda (pos vals)
(if (list? vals)
(apply post-cont? pos vals)
(post-cont? pos vals)))))))))
;; ----------------------------------------
(define (append-sequences sequences cyclic?)
@ -830,6 +1018,56 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; running sequences outside of a loop:
(define-values (struct:do-stream
make-do-stream
do-stream?
do-stream-ref
do-stream-set!)
(make-struct-type 'stream #f 3 0 #f
(list (cons prop:stream
(vector
(lambda (v) ((do-stream-ref v 0)))
(lambda (v) ((do-stream-ref v 1)))
(lambda (v) ((do-stream-ref v 2))))))))
(define empty-stream (make-do-stream (lambda () #t) void void))
(define (sequence->stream s)
(unless (sequence? s)
(raise-type-error 'sequence-generate "sequence" s))
(cond
[(stream? s) s]
[else
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-sequence #f s)])
(define (gen-stream pos)
(let ([done? #f]
[vals #f]
[empty? #f]
[next #f])
(define (force!)
(unless done?
(if (if pos-cont? (pos-cont? pos) #t)
(begin
(set! vals (call-with-values (lambda () (pos->val pos)) list))
(unless (if pre-cont? (apply pre-cont? vals) #t)
(set! vals #f)
(set! empty? #f)))
(set! empty? #t))
(set! done? #t)))
(make-do-stream (lambda () (force!) empty?)
(lambda () (force!) (apply values vals))
(lambda ()
(force!)
(if next
next
(begin
(if (if post-cont? (apply post-cont? pos vals) #t)
(set! next (gen-stream (pos-next pos)))
(set! next empty-stream))
next))))))
(gen-stream init))]))
(define (sequence-generate g)
(unless (sequence? g)
(raise-type-error 'sequence-generate "sequence" g))
@ -1249,14 +1487,14 @@
;; loop bindings
([lst lst])
;; pos check
(not (null? lst))
(pair? lst)
;; inner bindings
([(id) (car lst)])
([(id) (unsafe-car lst)])
;; pre guard
#t
;; post guard
#t
;; loop args -- ok to use unsafe-cdr, since car passed
;; loop args
((unsafe-cdr lst)))]]
[_ #f])))
@ -1285,6 +1523,31 @@
((mcdr lst)))]]
[_ #f])))
(define-sequence-syntax *in-stream
(lambda () #'in-stream)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ lst-expr)]
#'[(id)
(:do-in
;;outer bindings
([(lst) lst-expr])
;; outer check
(unless (stream? lst) (in-stream lst))
;; loop bindings
([lst lst])
;; pos check
(unsafe-stream-not-empty? lst)
;; inner bindings
([(id) (unsafe-stream-first lst)])
;; pre guard
#t
;; post guard
#t
;; loop args
((unsafe-stream-rest lst)))]]
[_ #f])))
(define-sequence-syntax *in-indexed
(lambda () #'in-indexed)
(lambda (stx)

4
collects/racket/private/pre-base.rkt
View File

@ -139,7 +139,9 @@
define-in-vector-like
define-:vector-like-gen
make-in-vector-like
normalise-inputs)
normalise-inputs
stream? stream-empty? stream-first stream-rest
prop:stream in-stream empty-stream make-do-stream)
(all-from "kernstruct.rkt")
#%top-interaction

54
collects/racket/private/sequence.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang racket/base
;; Simple sequence functions that are also good enough
;; for streams
(require "for.rkt")
(provide sequence-andmap
sequence-ormap
sequence-for-each
sequence-fold
sequence-count)
(define (sequence-andmap f s)
(unless (procedure? f) (raise-type-error 'sequence-andmap "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-andmap "sequence" s))
(for/and ([vs (in-values*-sequence s)])
(if (list? vs)
(apply f vs)
(f vs))))
(define (sequence-ormap f s)
(unless (procedure? f) (raise-type-error 'sequence-ormap "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-ormap "sequence" s))
(for/or ([vs (in-values*-sequence s)])
(if (list? vs)
(apply f vs)
(f vs))))
(define (sequence-for-each f s)
(unless (procedure? f) (raise-type-error 'sequence-for-each "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-for-each "sequence" s))
(for ([vs (in-values*-sequence s)])
(if (list? vs)
(apply f vs)
(f vs))))
(define (sequence-fold f i s)
(unless (procedure? f) (raise-type-error 'sequence-fold "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-fold "sequence" s))
(for/fold ([i i]) ([vs (in-values*-sequence s)])
(if (list? vs)
(apply f i vs)
(f i vs))))
(define (sequence-count f s)
(unless (procedure? f) (raise-type-error 'sequence-count "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-count "sequence" s))
(for/fold ([i 0]) ([vs (in-values*-sequence s)])
(if (if (list? vs)
(apply f vs)
(f vs))
(add1 i)
i)))

113
collects/racket/private/stream-cons.rkt Normal file
View File

@ -0,0 +1,113 @@
; Library streams/primitive
; Adapted for PLT Scheme by Jacob J. A. Koot
; from original version of Philip L. Bewig.
; Further adapted by Matthew to allow any kind
; of Racket stream as the rest of a lazy stream.
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. 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.
#lang racket/base
(require (prefix-in for: racket/private/for))
(provide stream-null stream-cons stream? stream-null? stream-pair?
stream-car stream-cdr stream-lambda)
(define-syntax stream-lazy
(syntax-rules ()
((stream-lazy expr)
(make-stream
(mcons 'lazy (lambda () expr))))))
(define (stream-eager expr)
(make-stream
(mcons '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 (mcar content)
((eager) (mcdr content))
((lazy) (let* ((promise* ((mcdr content))))
;; check mcar again, it can it was set in the
;; process of evaluating `(mcdr content)':
(if (eq? (mcar content) 'eager)
;; yes, it was set
(mcdr content)
;; normal case: no, it wasn't set:
(if (stream? promise*)
;; Flatten the result lazy stream and try again:
(let ([new-content (stream-promise promise*)])
(set-mcar! content (mcar new-content))
(set-mcdr! content (mcdr new-content))
(set-stream-promise! promise* content)
(stream-force promise))
;; Forced result is not a lazy stream:
(begin
(unless (for:stream? promise*)
(raise-mismatch-error
'stream-cons
"rest expression produced a non-stream: "
promise*))
(set-mcdr! content promise*)
(set-mcar! content 'eager)
promise*))))))))
(define-syntax stream-lambda
(syntax-rules ()
((stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (let () body0 body1 ...))))))
(define-struct stream-pare (kar kdr))
(define (stream-null? obj)
(let ([v (stream-force obj)])
(if (stream-pare? v)
#f
(or (eqv? v (stream-force stream-null))
(for:stream-empty? v)))))
(define (stream-pair? obj)
(and (stream? obj) (stream-pare? (stream-force obj))))
(define-syntax stream-cons
(syntax-rules ()
((stream-cons obj strm)
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
(define (stream-car strm)
(let ([v (stream-force strm)])
(if (stream-pare? v)
(stream-force (stream-pare-kar v))
(for:stream-first v))))
(define (stream-cdr strm)
(let ([v (stream-force strm)])
(if (stream-pare? v)
(stream-pare-kdr v)
(for:stream-rest v))))
(define-struct stream (promise)
#:mutable
#:property for:prop:stream (vector
stream-null?
stream-car
stream-cdr))
(define stream-null (stream-delay (cons 'stream 'null)))

99
collects/racket/sequence.rkt Normal file
View File

@ -0,0 +1,99 @@
#lang racket/base
(require "stream.rkt"
"private/sequence.rkt")
(provide empty-sequence
sequence->list
sequence-length
sequence-ref
sequence-tail
sequence-append
sequence-map
sequence-andmap
sequence-ormap
sequence-for-each
sequence-fold
sequence-filter
sequence-add-between
sequence-count)
(define empty-sequence
(make-do-sequence
(λ ()
(values
void
void
#f
(λ (pos) #f)
#f
#f))))
(define (sequence->list s)
(for/list ([v s]) v))
(define (sequence-length s)
(unless (sequence? s) (raise-type-error 'sequence-length "sequence" s))
(for/fold ([c 0]) ([i (in-values*-sequence s)])
(add1 c)))
(define (sequence-ref s i)
(unless (sequence? s) (raise-type-error 'sequence-ref "sequence" s))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'sequence-ref "nonnegative exact integer" i))
(let ([v (for/fold ([c #f]) ([v (in-values-sequence s)]
[i (in-range (add1 i))])
v)])
(if (list? v)
(apply values v)
(raise-mismatch-error
'sequence-ref
(format "sequence ended before element ~e: "
(add1 i))
s))))
(define (sequence-tail seq i)
(unless (sequence? seq) (raise-type-error 'sequence-tail "sequence" seq))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'sequence-tail "nonnegative exact integer" i))
(cond
[(zero? i) seq]
[else (let loop ([s (sequence->stream seq)] [n i])
(cond
[(zero? n) (in-stream s)]
[(stream-empty? s)
(raise-mismatch-error
'sequence-ref
(format "sequence ended before ~e element~a: "
i
(if (= i 1) "" "s"))
seq)]
[else (loop (stream-rest s)
(sub1 n))]))]))
(define (sequence-append . l)
(if (null? l)
empty-stream
(if (andmap stream? l)
(apply stream-append l)
(apply in-sequences l))))
(define (sequence-map f s)
(unless (procedure? f)
(raise-type-error 'sequence-map "expects a procedure as the first argument, given ~e" f))
(if (stream? s)
(stream-map f s)
(in-stream (stream-map f (sequence->stream s)))))
(define (sequence-filter f s)
(unless (procedure? f) (raise-type-error 'sequence-filter "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-filter "sequence" s))
(if (stream? s)
(stream-filter f s)
(in-stream (stream-filter f (sequence->stream s)))))
(define (sequence-add-between s e)
(unless (sequence? s) (raise-type-error 'sequence-ad-between "sequence" s))
(if (stream? s)
(stream-add-between s e)
(in-stream (stream-add-between (sequence->stream s) e))))

387
collects/racket/stream.rkt
View File

@ -1,252 +1,155 @@
(module stream "private/pre-base.rkt"
(require "private/list.rkt")
#lang racket/base
(require "private/for.rkt"
"private/sequence.rkt"
(only-in "private/stream-cons.rkt"
stream-cons))
(provide empty-stream
stream-cons
stream?
stream-empty?
stream-first
stream-rest
prop:stream
in-stream
stream->list
stream-length
stream-ref
stream-tail
stream-append
stream-map
stream-andmap
stream-ormap
stream-for-each
stream-fold
stream-filter
stream-add-between
stream-count)
(define empty-stream
(make-do-sequence
(λ ()
(values
void
void
void
(λ (pos) #f)
(λ (val) #t)
(λ (pos val) #t)))))
(define (stream->list s)
(for/list ([v (in-stream s)]) v))
(define (stream->list s)
(for/list ([v s]) v))
(define (stream-length s)
(unless (stream? s) (raise-type-error 'stream-length "stream" s))
(let loop ([s s] [len 0])
(if (stream-empty? s)
len
(loop (stream-rest s) (add1 len)))))
(define (stream-ref st i)
(unless (stream? st) (raise-type-error 'stream-ref "stream" st))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'stream-ref "nonnegative exact integer" i))
(let loop ([n i] [s st])
(cond
[(stream-empty? s)
(raise-mismatch-error 'stream-ref
(format "sequence ended before element ~e: "
(add1 i))
st)]
[(zero? n)
(stream-first s)]
[else
(loop (sub1 n) (stream-rest s))])))
(define-syntax-rule (-stream-cons vs s)
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(values
(λ (pos)
(if (zero? pos)
vs
(next)))
(λ (pos) (if (zero? pos) 1 pos))
0
(λ (pos)
(or (zero? pos) (more?)))
(λ _ #t)
(λ _ #t)))))
(define stream-cons
(case-lambda
[()
(error 'stream-cons "expects a sequence to extend, but received no arguments")]
[(s)
(-stream-cons (values) s)]
[(v s)
(-stream-cons (values v) s)]
[vs*s
; XXX double reverse is bad but moving split-at causes a problem I can't figure
(define s*vs (reverse vs*s))
(-stream-cons (apply values (reverse (cdr s*vs))) (car s*vs))]))
(define (stream-tail st i)
(unless (stream? st) (raise-type-error 'stream-tail "stream" st))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'stream-tail "nonnegative exact integer" i))
(let loop ([n i] [s st])
(cond
[(zero? n) s]
[(stream-empty? s)
(raise-mismatch-error
'stream-tail
(format "sequence ended before ~e element~a: "
i
(if (= i 1) "" "s"))
st)]
[else
(loop (sub1 n) (stream-rest s))])))
(define (stream-append . l)
(for ([s (in-list l)])
(unless (stream? s) (raise-type-error 'stream-append "stream" s)))
(streams-append l))
(define (streams-append l)
(cond
[(null? l) empty-stream]
[(stream-empty? (car l)) (streams-append (cdr l))]
[else
(make-do-stream (lambda () #f)
(lambda () (stream-first (car l)))
(lambda () (streams-append (cons (stream-rest (car l)) (cdr l)))))]))
(define (stream-first s)
(define-values (more? next) (sequence-generate s))
(unless (more?)
(error 'stream-first "expects a sequence with at least one element"))
(next))
(define (stream-map f s)
(unless (procedure? f) (raise-type-error 'stream-map "procedure" f))
(unless (stream? s) (raise-type-error 'stream-map "stream" s))
(let loop ([s s])
(cond
[(stream-empty? s) empty-stream]
[else (stream-cons (call-with-values (lambda () (stream-first s)) f)
(loop (stream-rest s)))])))
(define (stream-rest s)
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(unless (more?)
(error 'stream-rest "expects a sequence with at least one element"))
(next)
(values
(λ (pos) (next))
(λ (x) x)
0
(λ (pos) (more?))
(λ _ #t)
(λ _ #t)))))
(define (stream-andmap f s)
(unless (procedure? f) (raise-type-error 'stream-andmap "procedure" f))
(unless (stream? s) (raise-type-error 'stream-andmap "stream" s))
(sequence-andmap f s))
(define (stream-length s)
(define-values (more? next) (sequence-generate s))
(let loop ([i 0])
(if (more?)
(begin (next) (loop (add1 i)))
i)))
(define (stream-ormap f s)
(unless (procedure? f) (raise-type-error 'stream-ormap "procedure" f))
(unless (stream? s) (raise-type-error 'stream-ormap "stream" s))
(sequence-ormap f s))
(define (stream-ref s i)
(unless (and (exact-integer? i) (i . >= . 0))
(error 'stream-ref "expects an exact non-negative index, but got ~e" i))
(define-values (more? next) (sequence-generate s))
(let loop ([n i])
(cond
[(zero? n)
(next)]
[(more?)
(next)
(loop (sub1 n))]
[else
(error 'stream-ref "expects a sequence with at least ~e element(s)" i)])))
(define (stream-for-each f s)
(unless (procedure? f) (raise-type-error 'stream-for-each "procedure" f))
(unless (stream? s) (raise-type-error 'stream-for-each "stream" s))
(sequence-for-each f s))
(define (stream-tail s i)
(unless (and (exact-integer? i) (i . >= . 0))
(error 'stream-tail "expects an exact non-negative index, but got ~e" i))
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(let loop ([n i])
(unless (zero? n)
(unless (more?)
(error 'stream-tail "expects a sequence with at least ~e element(s)" i))
(next)
(loop (sub1 n))))
(values
(λ (pos) (next))
(λ (x) x)
0
(λ (pos) (more?))
(λ _ #t)
(λ _ #t)))))
(define (stream-fold f i s)
(unless (procedure? f) (raise-type-error 'stream-fold "procedure" f))
(unless (stream? s) (raise-type-error 'stream-fold "stream" s))
(sequence-fold f i s))
(define (stream-count f s)
(unless (procedure? f) (raise-type-error 'stream-count "procedure" f))
(unless (stream? s) (raise-type-error 'stream-count "stream" s))
(sequence-count f s))
(define (-stream-append s0 l)
(if (null? l)
s0
(make-do-sequence
(λ ()
(define remaining l)
(define (next-pos pos)
(cond
[(more?)
#t]
[(null? remaining)
#f]
[else
(let*-values ([(s1) (car remaining)]
[(next-more? next-next) (sequence-generate s1)])
(set! more? next-more?)
(set! next next-next)
(set! remaining (cdr remaining))
(next-pos pos))]))
(define-values (more? next) (sequence-generate s0))
(values
(λ (pos) (next))
(λ (x) x)
0
next-pos
(λ _ #t)
(λ _ #t))))))
(define (stream-filter f s)
(unless (procedure? f) (raise-type-error 'stream-filter "procedure" f))
(unless (stream? s) (raise-type-error 'stream-filter "stream" s))
(cond
[(stream-empty? s) empty-stream]
[else
(let ([done? #f]
[empty? #f]
[fst #f]
[rst #f])
(define (force!)
(unless done?
(let loop ([s s])
(cond
[(stream-empty? s)
(set! done? #t)
(set! empty? #t)]
[(f (stream-first s))
(set! fst (stream-first s))
(set! rst (stream-filter f (stream-rest s)))]
[else (loop (stream-rest s))]))
(set! done? #t)))
(make-do-stream (lambda () (force!) empty?)
(lambda () (force!) fst)
(lambda () (force!) rst)))]))
(define (stream-append . l)
(unless (andmap sequence? l)
(error 'stream-append "expects only sequence arguments, given ~e" l))
(-stream-append empty-stream l))
(define (stream-map f s)
(unless (procedure? f)
(error 'stream-map "expects a procedure as the first argument, given ~e" f))
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(values
(λ (pos) (call-with-values next f))
(λ (x) x)
0
(λ (pos) (more?))
(λ _ #t)
(λ _ #t)))))
(define (stream-andmap f s)
(define-values (more? next) (sequence-generate s))
(let loop ()
(if (more?)
(and (call-with-values next f) (loop))
#t)))
(define (stream-ormap f s)
(define-values (more? next) (sequence-generate s))
(let loop ()
(if (more?)
(or (call-with-values next f) (loop))
#f)))
(define (stream-for-each f s)
(define-values (more? next) (sequence-generate s))
(let loop ()
(when (more?)
(call-with-values next f)
(loop))))
(define (stream-fold f i s)
(define-values (more? next) (sequence-generate s))
(let loop ([i i])
(if (more?)
(loop (call-with-values next (λ e (apply f i e))))
i)))
(define (stream-filter f s)
(unless (procedure? f)
(error 'stream-filter "expects a procedure as the first argument, given ~e" f))
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(define next-vs #f)
(define (next-pos pos)
(if (more?)
(call-with-values next
(λ vs
(if (apply f vs)
(begin (set! next-vs vs)
#t)
(next-pos pos))))
#f))
(values
(λ (pos) (apply values next-vs))
(λ (x) x)
0
next-pos
(λ _ #t)
(λ _ #t)))))
(define (stream-add-between s e)
(make-do-sequence
(λ ()
(define-values (more? next) (sequence-generate s))
(values
(λ (pos)
(if pos
(next)
e))
not
#t
(λ (pos)
(if pos
(more?)
#t))
(λ _ #t)
(λ _ #t)))))
(define (stream-count f s)
(unless (procedure? f)
(error 'stream-count "expects a procedure as the first argument, given ~e" f))
(define-values (more? next) (sequence-generate s))
(let loop ([n 0])
(if (more?)
(if (call-with-values next f)
(loop (add1 n))
(loop n))
n)))
(provide empty-stream
stream->list
stream-cons
stream-first
stream-rest
stream-length
stream-ref
stream-tail
stream-append
stream-map
stream-andmap
stream-ormap
stream-for-each
stream-fold
stream-filter
stream-add-between
stream-count))
(define (stream-add-between s e)
(unless (stream? s)
(raise-type-error 'stream-add-between "stream" s))
(let loop ([s s])
(cond
[(stream-empty? s) empty-stream]
[else (stream-cons (stream-first s)
(stream-cons e (loop (stream-rest s))))])))

352
collects/scribblings/reference/sequences.scrbl
View File

@ -9,14 +9,26 @@
@margin-note{See @secref[where] for information on using @|what| as
sequences.})
@title[#:tag "sequences"]{Sequences}
@title[#:style 'toc #:tag "sequences+streams"]{Sequences and Streams}
@tech{Sequences} and @tech{streams} abstract over iteration of
elements in a collection. Streams are functional sequences that can be
used either in a generic way or a stream-specific
way. @tech{Generators} are closely related stateful objects that can
be converted to a sequence and vice-versa.
@local-table-of-contents[]
@; ======================================================================
@section[#:tag "sequences"]{Sequences}
@guideintro["sequences"]{sequences}
A @deftech{sequence} encapsulates an ordered stream of values. The
elements of a sequence can be extracted with one of the @scheme[for]
syntactic forms or with the procedures returned by
@scheme[sequence-generate].
A @deftech{sequence} encapsulates an ordered collection of values.
The elements of a sequence can be extracted with one of the
@scheme[for] syntactic forms, with the procedures returned by
@scheme[sequence-generate], or by converting the sequence into a
@tech{stream}.
The sequence datatype overlaps with many other datatypes. Among
built-in datatypes, the sequence datatype includes the following:
@ -45,9 +57,10 @@ built-in datatypes, the sequence datatype includes the following:
]
In addition, @scheme[make-do-sequence] creates a sequence given a thunk
that returns procedures to implement a sequence, and the
@scheme[prop:sequence] property can be associated with a structure type.
The @scheme[make-do-sequence] function creates a sequence given a
thunk that returns procedures to implement a sequence, and the
@scheme[prop:sequence] property can be associated with a structure
type to implement its implicit conversion to a sequence.
For most sequence types, extracting elements from a sequence has no
side-effect on the original sequence value; for example, extracting the
@ -62,15 +75,15 @@ hash table generates two values---a key and its value---for each element
in the sequence.
@; ----------------------------------------------------------------------
@section{Sequence Predicate and Constructors}
@subsection{Sequence Predicate and Constructors}
@defproc[(sequence? [v any/c]) boolean?]{
Return @scheme[#t] if @scheme[v] can be used as a sequence,
Returns @scheme[#t] if @scheme[v] can be used as a @tech{sequence},
@scheme[#f] otherwise.}
@defproc*[([(in-range [end number?]) sequence?]
[(in-range [start number?] [end number?] [step number? 1]) sequence?])]{
Returns a sequence whose elements are numbers. The single-argument
@defproc*[([(in-range [end number?]) stream?]
[(in-range [start number?] [end number?] [step number? 1]) stream?])]{
Returns a sequence (that is also a @tech{stream}) whose elements are numbers. The single-argument
case @scheme[(in-range end)] is equivalent to @scheme[(in-range 0 end
1)]. The first number in the sequence is @scheme[start], and each
successive element is generated by adding @scheme[step] to the
@ -79,13 +92,14 @@ in the sequence.
less or equal to @scheme[end] if @scheme[step] is negative.
@speed[in-range "number"]}
@defproc[(in-naturals [start exact-nonnegative-integer? 0]) sequence?]{
Returns an infinite sequence of exact integers starting with
@defproc[(in-naturals [start exact-nonnegative-integer? 0]) stream?]{
Returns an infinite sequence (that is also a @tech{stream}) of exact integers starting with
@scheme[start], where each element is one more than the preceding
element. @speed[in-naturals "integer"]}
@defproc[(in-list [lst list?]) sequence?]{
Returns a sequence equivalent to @scheme[lst].
@defproc[(in-list [lst list?]) stream?]{
Returns a sequence (that is also a @tech{stream}) that is equivalent
to using @scheme[lst] directly as a sequence.
@info-on-seq["pairs" "lists"]
@speed[in-list "list"]}
@ -273,6 +287,19 @@ in the sequence.
each @scheme[seq]. The elements of each @scheme[seq] must be
single-valued.}
@defproc[(in-values-sequence [seq sequence?]) sequence?]{
Returns a sequence that is like @racket[seq], but it combines
multiple values for each element from @racket[seq] as a list of
elements.}
@defproc[(in-values*-sequence [seq sequence?]) sequence?]{
Returns a sequence that is like @racket[seq], but when an element of
@racket[seq] has multiple values or a single list value, then the
values are combined in a list. In other words,
@racket[in-values*-sequence] is like @racket[in-values-sequence],
except that non-list, single-valued elements are not wrapped in a
list.}
@defproc[(stop-before [seq sequence?] [pred (any/c . -> . any)])
sequence?]{
Returns a sequence that contains the elements of @scheme[seq] (which
@ -363,7 +390,19 @@ in the sequence.
c)]]}
@; ----------------------------------------------------------------------
@section{Sequence Generators}
@subsection{Sequence Conversion}
@defproc[(sequence->stream [seq sequence?]) stream?]{
Coverts a sequence to a @tech{stream}, which supports the
@racket[stream-first] and @racket[stream-rest] operations. The
stream lazily draws elements from the sequence, caching each element
so that @racket[stream-first] produces the same result each time
is applied to a stream.
In extracting an element from @racket[seq] involves a side-effect,
then the effect is performed each time that either
@racket[stream-first] or @racket[stream-rest] is first used to
access or skip an element.}
@defproc[(sequence-generate [seq sequence?])
(values (-> boolean?) (-> any))]{
@ -374,121 +413,262 @@ in the sequence.
@exnraise[exn:fail:contract].}
@; ----------------------------------------------------------------------
@section[#:tag "streams"]{Streams}
@subsection[#:tag "more-sequences"]{Sequence Combinations}
@note-lib[racket/stream]
@note-lib[racket/sequence]
Warning: the interface that this library implements is dealing with
sequences, not with lazy lists. (In the future, lazy lists will become
a valid kind of sequence, hence the naming of these functions.) Note
also that some of these operations can result in serious efficiency
penalties, for example, each use of @racket[stream-rest] adds a constant
overhead for accessing the resulting sequence.
@defthing[empty-stream sequence?]{
@defthing[empty-sequence sequence?]{
A sequence with no elements.}
@defproc[(stream->list [s sequence?]) list?]{
Returns a list whose elements are the elements of the @scheme[s],
which must be a one-valued sequence. If @scheme[s] is infinite, this
@defproc[(sequence->list [s sequence?]) list?]{
Returns a list whose elements are the elements of @scheme[s],
each of which must be a single value. If @scheme[s] is infinite, this
function does not terminate.}
@defproc[(stream-cons [v any/c]
...
[s sequence?])
sequence?]{
Returns a sequence whose first element is @scheme[(values v ...)] and whose
remaining elements are the same as @scheme[s].}
@defproc[(stream-first [s sequence?])
(values any/c ...)]{
Returns the first element of @scheme[s].}
@defproc[(stream-rest [s sequence?])
sequence?]{
Returns a sequence equivalent to @scheme[s], except the first element
is omitted.}
@defproc[(stream-length [s sequence?])
@defproc[(sequence-length [s sequence?])
exact-nonnegative-integer?]{
Returns the number of elements of @scheme[s]. If @scheme[s] is
infinite, this function does not terminate.}
Returns the number of elements of @scheme[s] by extracting and
discarding all of them. If @scheme[s] is infinite, this function
does not terminate.}
@defproc[(stream-ref [s sequence?] [i exact-nonnegative-integer?])
(values any/c ...)]{
Returns the @scheme[i]th element of @scheme[s].}
@defproc[(sequence-ref [s sequence?] [i exact-nonnegative-integer?])
any]{
Returns the @scheme[i]th element of @scheme[s] (which may be
multiple values).}
@defproc[(stream-tail [s sequence?] [i exact-nonnegative-integer?])
@defproc[(sequence-tail [s sequence?] [i exact-nonnegative-integer?])
sequence?]{
Returns a sequence equivalent to @scheme[s], except the first
@scheme[i] elements are omitted.}
Returns a sequence equivalent to @scheme[s], except that the first
@scheme[i] elements are omitted.
@defproc[(stream-append [s sequence?] ...)
In case extracting elements from @racket[s] involves a side effect,
they will not be extracted until the first element is extracted from
the resulting sequence.}
@defproc[(sequence-append [s sequence?] ...)
sequence?]{
Returns a sequence that contains all elements of each sequence in the
order they appear in the original sequences. The new sequence is
constructed lazily.
If all given @racket[s]s are @tech{streams}, the result is also a
@tech{stream}.}
@defproc[(sequence-map [f procedure?]
[s sequence?])
sequence?]{
Returns a sequence that contains @scheme[f] applied to each element of
@scheme[s]. The new sequence is constructed lazily.
If @racket[s] is a @tech{stream}, then the result is also a
@tech{stream}.}
@defproc[(sequence-andmap [f (-> any/c ... boolean?)]
[s sequence?])
boolean?]{
Returns @scheme[#t] if @scheme[f] returns a true result on every
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
returns a false result, this function does not terminate.}
@defproc[(sequence-ormap [f (-> any/c ... boolean?)]
[s sequence?])
boolean?]{
Returns @scheme[#t] if @scheme[f] returns a true result on some
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
returns a true result, this function does not terminate.}
@defproc[(sequence-for-each [f (-> any/c ... any)]
[s sequence?])
(void)]{
Applies @scheme[f] to each element of @scheme[s]. If @scheme[s] is
infinite, this function does not terminate.}
@defproc[(sequence-fold [f (-> any/c any/c ... any/c)]
[i any/c]
[s sequence?])
(void)]{
Folds @scheme[f] over each element of @scheme[s] with @scheme[i] as
the initial accumulator. If @scheme[s] is infinite, this function
does not terminate.}
@defproc[(sequence-count [f procedure?] [s sequence?])
exact-nonnegative-integer?]{
Returns the number of elements in @scheme[s] for which @scheme[f]
returns a true result. If @scheme[s] is infinite, this function does
not terminate.}
@defproc[(sequence-filter [f (-> any/c ... boolean?)]
[s sequence?])
sequence?]{
Returns a sequence whose elements are the elements of @scheme[s] for
which @scheme[f] returns a true result. Although the new sequence is
constructed lazily, if @scheme[s] has an infinite number of elements
where @scheme[f] returns a false result in between two elements where
@scheme[f] returns a true result, then operations on this sequence will
not terminate during the infinite sub-sequence.
If @racket[s] is a @tech{stream}, then the result is also a
@tech{stream}.}
@defproc[(sequence-add-between [s sequence?] [e any/c])
sequence?]{
Returns a sequence whose elements are the elements of @scheme[s],
but with @scheme[e] between each pair of elements in @racket[s].
The new sequence is constructed lazily.
If @racket[s] is a @tech{stream}, then the result is also a
@tech{stream}.}
@; ======================================================================
@section[#:tag "streams"]{Streams}
A @deftech{stream} is a kind of sequence that supports functional
iteration via @racket[stream-first] and @racket[stream-rest]. The
@racket[stream-cons] form constructs a lazy stream, but plain lists
can be used as stream, and functions such as @racket[in-range] and
@racket[in-naturals] also create streams.
@note-lib[racket/stream]
@defproc[(stream? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] can be used as a @tech{stream},
@scheme[#f] otherwise.}
@defproc[(stream-empty? [s stream?]) boolean?]{
Returns @racket[#f] if @racket[s] has no elements, @racket[#f]
otherwise.
}
@defproc[(stream-first [s (and/c stream? (not/c stream-empty?))]) any]{
Returns the value(s) of the first element in @racket[s].
}
@defproc[(stream-rest [s (and/c stream? (not/c stream-empty?))]) stream?]{
Returns a stream that is equivalent to @racket[s] without its
first element.
}
@defform[(stream-cons first-expr rest-expr)]{
Produces a lazy stream for which @racket[stream-first] forces the
evaluation of @racket[first-expr] to produce the first element of the
stream, and @racket[stream-rest] forces the evaluation of
@racket[rest-expr] to produce a stream for the rest of the returned
stream.
The first element of the stream as produced by @racket[first-expr]
must be a single value. The @racket[rest-expr] must produce a stream
when it is evaluated, otherwise the @exnraise[exn:fail:contract?].}
@defproc[(in-stream [s stream?]) sequence?]{
Returns a sequence that is equivalent to @racket[s].
@speed[in-stream "streams"]}
@defthing[empty-stream stream?]{
A stream with no elements.}
@defproc[(stream->list [s stream?]) list?]{
Returns a list whose elements are the elements of @scheme[s],
each of which must be a single value. If @scheme[s] is infinite, this
function does not terminate.}
@defproc[(stream-length [s stream?])
exact-nonnegative-integer?]{
Returns the number of elements of @scheme[s]. If @scheme[s] is
infinite, this function does not terminate.
In the case of lazy streams, this function forces evaluation only of
the sub-streams, and not the stream's elements.}
@defproc[(stream-ref [s stream?] [i exact-nonnegative-integer?])
any]{
Returns the @scheme[i]th element of @scheme[s] (which may be
multiple values).}
@defproc[(stream-tail [s stream?] [i exact-nonnegative-integer?])
stream?]{
Returns a stream equivalent to @scheme[s], except that the first
@scheme[i] elements are omitted.
In case extracting elements from @racket[s] involves a side effect,
they will not be extracted until the first element is extracted from
the resulting stream.}
@defproc[(stream-append [s stream?] ...)
stream?]{
Returns a stream that contains all elements of each stream in the
order they appear in the original streams. The new stream is
constructed lazily.}
@defproc[(stream-map [f procedure?]
[s sequence?])
sequence?]{
Returns a sequence that contains @scheme[f] applied to each element of
@scheme[s]. The new sequence is constructed lazily.}
[s stream?])
stream?]{
Returns a stream that contains @scheme[f] applied to each element of
@scheme[s]. The new stream is constructed lazily.}
@defproc[(stream-andmap [f (-> any/c ... boolean?)]
[s sequence?])
[s stream?])
boolean?]{
Returns @scheme[#t] if @scheme[f] returns a true result on every
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
returns a false result, this function does not terminate.}
@defproc[(stream-ormap [f (-> any/c ... boolean?)]
[s sequence?])
[s stream?])
boolean?]{
Returns @scheme[#t] if @scheme[f] returns a true result on some
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
returns a true result, this function does not terminate.}
@defproc[(stream-for-each [f (-> any/c ... any)]
[s sequence?])
[s stream?])
(void)]{
Applies @scheme[f] to each element of @scheme[s]. If @scheme[s] is
infinite, this function does not terminate.}
@defproc[(stream-fold [f (-> any/c any/c ... any/c)]
[i any/c]
[s sequence?])
[s stream?])
(void)]{
Folds @scheme[f] over each element of @scheme[s] with @scheme[i] as
the initial accumulator. If @scheme[s] is infinite, this function
does not terminate.}
@defproc[(stream-filter [f (-> any/c ... boolean?)]
[s sequence?])
sequence?]{
Returns a sequence whose elements are the elements of @scheme[s] for
which @scheme[f] returns a true result. Although the new sequence is
constructed lazily, if @scheme[s] has an infinite number of elements
where @scheme[f] returns a false result in between two elements where
@scheme[f] returns a true result then operations on this sequence will
not terminate during that infinite sub-sequence.}
@defproc[(stream-add-between [s sequence?] [e any/c])
sequence?]{
Returns a sequence whose elements are the elements of @scheme[s],
but with @scheme[e] between each pair of elements in @racket[s].
The new sequence is constructed lazily.}
@defproc[(stream-count [f procedure?] [s sequence?])
@defproc[(stream-count [f procedure?] [s stream?])
exact-nonnegative-integer?]{
Returns the number of elements in @scheme[s] for which @scheme[f]
returns a true result. If @scheme[s] is infinite, this function does
not terminate.}
@; ----------------------------------------------------------------------
@section{Iterator Generators}
@defproc[(stream-filter [f (-> any/c ... boolean?)]
[s stream?])
stream?]{
Returns a stream whose elements are the elements of @scheme[s] for
which @scheme[f] returns a true result. Although the new stream is
constructed lazily, if @scheme[s] has an infinite number of elements
where @scheme[f] returns a false result in between two elements where
@scheme[f] returns a true result, then operations on this stream will
not terminate during the infinite sub-stream.}
@defmodule[racket/generator]
@defproc[(stream-add-between [s stream?] [e any/c])
stream?]{
Returns a stream whose elements are the elements of @scheme[s],
but with @scheme[e] between each pair of elements in @racket[s].
The new stream is constructed lazily.}
@defthing[prop:stream struct-type-property?]{
Associates three procedures to a structure type to implement stream
operations for instances of the structure type.
The property value must be a vector of three procedures: a
@racket[stream-empty?] implementation, a @racket[stream-first]
implementation, and a @racket[stream-rest] implementation. The
procedures are applied only to instances of the structure type that
has the property value.}
@; ======================================================================
@section{Generators}
A @deftech{generator} is a procedure that returns a sequence of
values, incrementing the sequence each time that the generator is
@ -496,6 +676,8 @@ called. In particular, the @racket[generator] form implements a
generator by evaluating a body that calls @racket[yield] to return
values from the generator.
@defmodule[racket/generator]
@(define generator-eval
(let ([the-eval (make-base-eval)])
(the-eval '(require racket/generator))

85
collects/srfi/41/primitive.rkt
View File

@ -1,83 +1,4 @@
; Library streams/primitive
; Adapted for PLT Scheme by Jacob J. A. Koot
; from original version of Philip L. Bewig.
#lang racket/base
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. 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.
#lang scheme
(provide stream-null stream-cons stream? stream-null? stream-pair?
stream-car stream-cdr stream-lambda)
(define-struct stream (promise) #:mutable)
(define-syntax stream-lazy
(syntax-rules ()
((stream-lazy expr)
(make-stream
(mcons 'lazy (lambda () expr))))))
(define (stream-eager expr)
(make-stream
(mcons '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 (mcar content)
((eager) (mcdr content))
((lazy) (let* ((promise* ((mcdr content)))
(content (stream-promise promise)))
(when (not (eqv? (mcar content) 'eager))
(begin (set-mcar! content (mcar (stream-promise promise*)))
(set-mcdr! content (mcdr (stream-promise promise*)))
(set-stream-promise! promise* content)))
(stream-force promise))))))
(define stream-null (stream-delay (cons 'stream 'null)))
(define-struct stream-pare (kar 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-eager (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-pare-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-pare-kdr (stream-force strm)))))
(define-syntax stream-lambda
(syntax-rules ()
((stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (let () body0 body1 ...))))))
(require racket/private/stream-cons)
(provide (all-from-out racket/private/stream-cons))

6
collects/srfi/srfi.scrbl
View File

@ -1,7 +1,8 @@
#lang scribble/doc
@(require scribble/manual
(for-syntax scheme/base)
(for-label scheme/base))
(for-label scheme/base
racket/stream))
@(define-syntax (srfi stx)
(syntax-case stx ()
@ -722,6 +723,9 @@ Superceded by @schememodname[srfi/41].
@srfi[41 #:subdir #t]{Streams}
The @racket[stream-cons] operation from @racketmodname[srfi/41] is the
same as from @racketmodname[racket/stream].
@redirect[41 #:subdir #t '(
(stream-null #f "stream-null")
(stream-cons #t "stream-cons")

110
collects/tests/racket/for.rktl
View File

@ -228,114 +228,4 @@
(test 13 next)
(test #f more?))
;; New operators
(require racket/stream)
(test '(0 1 2) 'stream->list (stream->list (in-range 3)))
(arity-test stream->list 1 1)
(err/rt-test (stream->list 1))
(test '() 'empty-stream (stream->list empty-stream))
; XXX How do I check rest arity?
(test '(0 1 2) 'stream-cons (stream->list (stream-cons 0 (in-range 1 3))))
(test '((0 1)) 'stream-cons
(for/list ([(a b) (stream-cons 0 1 empty-stream)])
(list a b)))
(arity-test stream-first 1 1)
(err/rt-test (stream-first 1))
(test 0 'stream-first (stream-first (in-naturals)))
(test #t
'stream-first
(equal? (list 0 1)
(call-with-values
(λ ()
(stream-first (stream-cons 0 1 empty-stream)))
(λ args args))))
(arity-test stream-rest 1 1)
(test '(1 2) 'stream-rest (stream->list (stream-rest (in-range 3))))
(arity-test stream-length 1 1)
(err/rt-test (stream-length 1))
(test 3 'stream-length (stream-length (in-range 3)))
(test 3 'stream-length (stream-length #hasheq((1 . 'a) (2 . 'b) (3 . 'c))))
(arity-test stream-ref 2 2)
(err/rt-test (stream-ref 2 0))
(err/rt-test (stream-ref (in-naturals) -1) exn:fail?)
(err/rt-test (stream-ref (in-naturals) 1.0) exn:fail?)
(test 0 'stream-ref (stream-ref (in-naturals) 0))
(test 1 'stream-ref (stream-ref (in-naturals) 1))
(test 25 'stream-ref (stream-ref (in-naturals) 25))
(arity-test stream-tail 2 2)
(err/rt-test (stream-tail (in-naturals) -1) exn:fail?)
(err/rt-test (stream-tail (in-naturals) 1.0) exn:fail?)
(test 4 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 0))
(test 5 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 1))
(test 29 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 25))
; XXX Check for rest
(err/rt-test (stream-append 1) exn:fail?)
(err/rt-test (stream-append (in-naturals) 1) exn:fail?)
(test '() 'stream-append (stream->list (stream-append)))
(test 5 'stream-append (stream-ref (stream-append (in-naturals)) 5))
(test 5 'stream-append
(stream-ref (stream-append (in-range 3) (in-range 3 10)) 5))
(arity-test stream-map 2 2)
(err/rt-test (stream-map 2 (in-naturals)) exn:fail?)
(test '(1 2 3) 'stream-map (stream->list (stream-map add1 (in-range 3))))
(test 3 'stream-map (stream-ref (stream-map add1 (in-naturals)) 2))
(arity-test stream-andmap 2 2)
(err/rt-test (stream-andmap 2 (in-naturals)))
(test #t 'stream-andmap (stream-andmap even? (stream-cons 2 empty-stream)))
(test #f 'stream-andmap (stream-andmap even? (in-naturals)))
(arity-test stream-ormap 2 2)
(err/rt-test (stream-ormap 2 (in-naturals)))
(test #t 'stream-ormap (stream-ormap even? (stream-cons 2 empty-stream)))
(test #f 'stream-ormap (stream-ormap even? (stream-cons 1 empty-stream)))
(test #t 'stream-ormap (stream-ormap even? (in-naturals)))
(arity-test stream-for-each 2 2)
(err/rt-test (stream-for-each 2 (in-naturals)))
(test (vector 0 1 2)
'stream-for-each
(let ([v (vector #f #f #f)])
(stream-for-each (λ (i) (vector-set! v i i)) (in-range 3))
v))
(arity-test stream-fold 3 3)
(err/rt-test (stream-fold 2 (in-naturals) 0))
(test 6 'stream-fold (stream-fold + 0 (in-range 4)))
(arity-test stream-filter 2 2)
(err/rt-test (stream-filter 2 (in-naturals)) exn:fail?)
(test 4 'stream-filter (stream-ref (stream-filter even? (in-naturals)) 2))
(arity-test stream-add-between 2 2)
(test 0 'stream-add-between
(stream-ref (stream-add-between (in-naturals) #t) 0))
(test #t 'stream-add-between
(stream-ref (stream-add-between (in-naturals) #t) 1))
(test 1 'stream-add-between
(stream-ref (stream-add-between (in-naturals) #t) 2))
(test #t 'stream-add-between
(stream-ref (stream-add-between (in-naturals) #t) 3))
(arity-test stream-count 2 2)
(test 0 'stream-count (stream-count even? empty-stream))
(test 1 'stream-count (stream-count even? (in-range 1)))
(test 5 'stream-count (stream-count even? (in-range 10)))
(let* ([r (random 100)]
[a (if (even? r)
(/ r 2)
(ceiling (/ r 2)))])
(test a 'stream-count (stream-count even? (in-range r))))
(report-errs)

337
collects/tests/racket/iostream.rktl Normal file
View File

@ -0,0 +1,337 @@
(printf "Stream Tests (current dir must be startup dir)\n")
(require scheme/system)
(define (log . args)
'(begin
(apply printf args)
(newline)))
(define cs-prog
'(define (copy-stream in out)
(lambda ()
(let ([s (make-bytes 4096)])
(let loop ()
(let ([l (read-bytes-avail! s in)])
(log "in: ~a" l)
(unless (eof-object? l)
(let loop ([p 0][l l])
(let ([r (write-bytes-avail s out p (+ p l))])
(log "out: ~a" r)
(when (< r l)
(loop (+ p r) (- l r)))))
(loop))))))))
(eval cs-prog)
(define test-file (find-executable-path (find-system-path 'exec-file) #f))
(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ"))
(define (feed-file out)
(let ([p (open-input-file test-file)])
(let loop ()
(let ([c (read-byte p)])
(unless (eof-object? c)
(write-byte c out)
(loop))))))
(define (feed-file/fast out)
(let ([p (open-input-file test-file)])
((copy-stream p out))
(close-input-port p)))
(define (check-file in)
(let ([p (open-input-file test-file)])
(let loop ([badc 0])
(let ([c (read-byte p)]
[c2 (read-byte in)])
(unless (eq? c c2)
(if (= badc 30)
(error "check-failed" (file-position p) c c2)
(begin
(fprintf (current-error-port)
"fail: ~a ~s=~s ~s=~s\n"
(file-position p) c (integer->char c) c2 (integer->char c2))
(loop (add1 badc)))))
(unless (eof-object? c)
(loop badc))))
(close-input-port p)))
(define (check-file/fast in)
(let ([p (open-input-file test-file)])
(let loop ()
(let* ([s (read-bytes 5000 p)]
[s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)])
(unless (equal? s s2)
(error "fast check failed"))
(unless (eof-object? s)
(loop))))
(close-input-port p)))
(define (check-file/fastest in)
(let ([p (open-input-file test-file)]
[s1 (make-bytes 5000)]
[s2 (make-bytes 5000)])
(let loop ([leftover 0][startpos 0][pos 0])
(let* ([n1 (if (zero? leftover)
(read-bytes-avail! s1 p)
leftover)]
[n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
1
n1))])
(unless (if (or (eof-object? n1)
(eof-object? n2))
(and (eof-object? n1)
(eof-object? n2))
(if (= n2 n1 5000)
(bytes=? s1 s2)
(bytes=? (subbytes s1 startpos (+ startpos n2))
(subbytes s2 0 n2))))
(error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
(unless (eof-object? n1)
(loop (- n1 n2)
(if (= n1 n2)
0
(+ startpos n2))
(+ pos n2)))))
(close-input-port p)))
(define portno 40010)
(define (setup-mzscheme-echo tcp?)
(define p (process* test-file "-q" "-b"))
(define s (make-bytes 256))
(define r #f)
(define w #f)
(define r2 #f)
(define w2 #f)
(thread (copy-stream (cadddr p) (current-error-port)))
(fprintf (cadr p) "(define log void)\n")
(fprintf (cadr p) "~s\n" cs-prog)
(if tcp?
(let ([t
(thread (lambda ()
(define-values (rr ww) (tcp-accept l1))
(define-values (rr2 ww2) (tcp-accept l2))
(set! r rr)
(set! w ww)
(set! r2 rr2)
(set! w2 ww2)))])
(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))\n" portno)
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
(flush-output (cadr p))
(thread-wait t)
(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))\n"))
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
(flush-output (cadr p))
(unless tcp?
;; Flush initial output from other process:
(let loop ()
(sleep 0.3)
(unless (zero? (read-bytes-avail!* s (car p)))
(loop))))
(if tcp?
(values r w r2 w2)
p))
(define start-ms 0)
(define start-ps-ms 0)
(define start-gc-ms 0)
(define (start s)
(printf s)
(set! start-ms (current-milliseconds))
(set! start-gc-ms (current-gc-milliseconds))
(set! start-ps-ms (current-process-milliseconds)))
(define (end)
(let ([ps-ms (current-process-milliseconds)]
[gc-ms (current-gc-milliseconds)]
[ms (current-milliseconds)])
(printf "cpu: ~a real: ~a gc ~a\n"
(- ps-ms start-ps-ms)
(- ms start-ms)
(- gc-ms start-gc-ms))))
'(thread (lambda ()
(let loop ()
(printf "alive\n")
(sleep 1)
(loop))))
(start "Quick check:\n")
(define p (open-input-file test-file))
(check-file/fast p)
(close-input-port p)
(end)
(start "Quicker check:\n")
(define p (open-input-file test-file))
(check-file/fastest p)
(close-input-port p)
(end)
(start "Plain pipe...\n")
(define-values (r w) (make-pipe))
(feed-file w)
(close-output-port w)
(check-file r)
(end)
(start "Plain pipe, faster...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fast r)
(end)
(start "Plain pipe, fastest...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fastest r)
(end)
(start "Limited pipe...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file w)
(close-output-port w)))
(check-file r)
(end)
(start "Limited pipe, faster...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fast r)
(end)
(start "Limited pipe, fastest...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fastest r)
(end)
(start "To file and back:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
(feed-file w)
(close-output-port w)
(thread-wait t)
(close-output-port p)
(end)
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file r)
(end)
(start "To file and back, faster:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
(feed-file/fast w)
(close-output-port w)
(thread-wait t)
(close-output-port p)
(end)
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file/fast r)
(end)
(start "File back, fastest:\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file/fastest r)
(end)
(start "Echo...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file (cadr p))
(close-output-port (cadr p))))
(check-file (car p))
(end)
(start "Echo, faster...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file/fast (cadr p))
(close-output-port (cadr p))))
(check-file/fast (car p))
(end)
(start "Echo, indirect...\n")
(define p (setup-mzscheme-echo #f))
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p))))
(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2)))
(thread (lambda ()
(feed-file/fast wp1)
(close-output-port wp1)))
(check-file/fast rp2)
(end)
(define l1 (tcp-listen portno 5 #t))
(define l2 (tcp-listen (add1 portno) 5 #t))
(start "TCP Echo...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda ()
(feed-file w)
(close-output-port w)))
(check-file r2)
(close-input-port r2)
(end)
(start "TCP Echo, faster...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fast r2)
(close-input-port r2)
(end)
(start "TCP Echo, indirect...\n")
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda () ((copy-stream rp1 w)) (close-output-port w)))
(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2)))
(thread (lambda ()
(feed-file/fast wp1)
(close-output-port wp1)))
(check-file/fast rp2)
(end)
(tcp-close l1)
(tcp-close l2)

2
collects/tests/racket/mzlib-tests.rktl
View File

@ -17,6 +17,8 @@
(load-in-sandbox "date.rktl")
(load-in-sandbox "compat.rktl")
(load-in-sandbox "cmdline.rktl")
(load-in-sandbox "stream.rktl")
(load-in-sandbox "sequence.rktl")
(load-in-sandbox "generator.rktl")
(load-in-sandbox "pconvert.rktl")
(load-in-sandbox "pretty.rktl")

175
collects/tests/racket/sequence.rktl Normal file
View File

@ -0,0 +1,175 @@
(load-relative "loadtest.rktl")
(Section 'sequence)
(require racket/sequence
racket/stream)
(define (try-basic-sequence-ops sequence?
empty-sequence
sequence->list
sequence-length
sequence-ref
sequence-tail
sequence-append
sequence-map
sequence-andmap
sequence-ormap
sequence-for-each
sequence-fold
sequence-filter
sequence-add-between
sequence-count)
(test #t sequence? empty-sequence)
(test #t sequence? (in-range 10))
(test #t sequence? '(1 2 3))
(test #f sequence? 'symbol)
(test '(0 1 2) 'sequence->list (sequence->list (in-range 3)))
(arity-test sequence->list 1 1)
(err/rt-test (sequence->list 1))
(test '() 'empty-sequence (sequence->list empty-sequence))
(arity-test sequence-length 1 1)
(err/rt-test (sequence-length 1))
(test 3 'sequence-length (sequence-length (in-range 3)))
(arity-test sequence-ref 2 2)
(err/rt-test (sequence-ref 2 0))
(err/rt-test (sequence-ref (in-naturals) -1) exn:fail?)
(err/rt-test (sequence-ref (in-naturals) 1.0) exn:fail?)
(test 0 'sequence-ref (sequence-ref (in-naturals) 0))
(test 1 'sequence-ref (sequence-ref (in-naturals) 1))
(test 25 'sequence-ref (sequence-ref (in-naturals) 25))
(arity-test sequence-tail 2 2)
(err/rt-test (sequence-tail (in-naturals) -1) exn:fail?)
(err/rt-test (sequence-tail (in-naturals) 1.0) exn:fail?)
(test 4 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 0))
(test 5 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 1))
(test 29 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 25))
;; XXX Check for rest
(err/rt-test (sequence-append 1) exn:fail?)
(err/rt-test (sequence-append (in-naturals) 1) exn:fail?)
(test '() 'sequence-append (sequence->list (sequence-append)))
(test 5 'sequence-append (sequence-ref (sequence-append (in-naturals)) 5))
(test 5 'sequence-append
(sequence-ref (sequence-append (in-range 3) (in-range 3 10)) 5))
(arity-test sequence-map 2 2)
(err/rt-test (sequence-map 2 (in-naturals)) exn:fail?)
(test '(1 2 3) 'sequence-map (sequence->list (sequence-map add1 (in-range 3))))
(test 3 'sequence-map (sequence-ref (sequence-map add1 (in-naturals)) 2))
(arity-test sequence-andmap 2 2)
(err/rt-test (sequence-andmap 2 (in-naturals)))
(test #t 'sequence-andmap (sequence-andmap even? '(2)))
(test #f 'sequence-andmap (sequence-andmap even? (in-naturals)))
(arity-test sequence-ormap 2 2)
(err/rt-test (sequence-ormap 2 (in-naturals)))
(test #t 'sequence-ormap (sequence-ormap even? '(2)))
(test #f 'sequence-ormap (sequence-ormap even? '(1)))
(test #t 'sequence-ormap (sequence-ormap even? (in-naturals)))
(arity-test sequence-for-each 2 2)
(err/rt-test (sequence-for-each 2 (in-naturals)))
(test (vector 0 1 2)
'sequence-for-each
(let ([v (vector #f #f #f)])
(sequence-for-each (λ (i) (vector-set! v i i)) (in-range 3))
v))
(arity-test sequence-fold 3 3)
(err/rt-test (sequence-fold 2 (in-naturals) 0))
(test 6 'sequence-fold (sequence-fold + 0 (in-range 4)))
(arity-test sequence-filter 2 2)
(err/rt-test (sequence-filter 2 (in-naturals)) exn:fail?)
(test 4 'sequence-filter (sequence-ref (sequence-filter even? (in-naturals)) 2))
(arity-test sequence-add-between 2 2)
(test 0 'sequence-add-between
(sequence-ref (sequence-add-between (in-naturals) #t) 0))
(test #t 'sequence-add-between
(sequence-ref (sequence-add-between (in-naturals) #t) 1))
(test 1 'sequence-add-between
(sequence-ref (sequence-add-between (in-naturals) #t) 2))
(test #t 'sequence-add-between
(sequence-ref (sequence-add-between (in-naturals) #t) 3))
(arity-test sequence-count 2 2)
(test 0 'sequence-count (sequence-count even? empty-sequence))
(test 1 'sequence-count (sequence-count even? (in-range 1)))
(test 5 'sequence-count (sequence-count even? (in-range 10)))
(let* ([r (random 100)]
[a (if (even? r)
(/ r 2)
(ceiling (/ r 2)))])
(test a 'sequence-count (sequence-count even? (in-range r))))
(test '(0 1 2 5 6 5 6)
'no-state-in-iter-over-append
(let ([k #f]
[l null])
(call-with-continuation-prompt
(lambda ()
(for ([i (stream-append (in-range 3) (in-range 5 7))])
(set! l (cons i l))
(when (= i 2) (let/cc _k (set! k _k))))))
(call-with-continuation-prompt
(lambda ()
(k #f)))
(reverse l))))
(try-basic-sequence-ops sequence?
empty-sequence
sequence->list
sequence-length
sequence-ref
sequence-tail
sequence-append
sequence-map
sequence-andmap
sequence-ormap
sequence-for-each
sequence-fold
sequence-filter
sequence-add-between
sequence-count)
(try-basic-sequence-ops stream?
empty-stream
stream->list
stream-length
stream-ref
stream-tail
stream-append
stream-map
stream-andmap
stream-ormap
stream-for-each
stream-fold
stream-filter
stream-add-between
stream-count)
(test 3 'sequence-length (sequence-length #hasheq((1 . 'a) (2 . 'b) (3 . 'c))))
(test-values '(2 3) (lambda () (sequence-ref (in-parallel '(2) '(3)) 0)))
(test-values '(8 12) (lambda () (sequence-ref (in-parallel '(2 5 8 -1) '(3 9 12 0)) 2)))
(test #t stream? (sequence-append))
(test #t stream? (sequence-append (in-range 10) '(1 2 3)))
(test #f stream? (sequence-append (in-range 10) (vector 1 2 3) '(1 2 3)))
(test #t stream? (sequence-map add1 (in-range 3)))
(test #f stream? (sequence-map add1 (vector 1 2 3)))
(test #t stream? (sequence-filter odd? (in-range 3)))
(test #f stream? (sequence-filter odd? (vector 1 2 3)))
(report-errs)

341
collects/tests/racket/stream.rktl
View File

@ -1,337 +1,24 @@
(printf "Stream Tests (current dir must be startup dir)\n")
(load-relative "loadtest.rktl")
(require scheme/system)
(Section 'stream)
(define (log . args)
'(begin
(apply printf args)
(newline)))
(require racket/stream)
(define cs-prog
'(define (copy-stream in out)
(lambda ()
(let ([s (make-bytes 4096)])
(let loop ()
(let ([l (read-bytes-avail! s in)])
(log "in: ~a" l)
(unless (eof-object? l)
(let loop ([p 0][l l])
(let ([r (write-bytes-avail s out p (+ p l))])
(log "out: ~a" r)
(when (< r l)
(loop (+ p r) (- l r)))))
(loop))))))))
;; >>> Many basic stream tests are in "sequence.rktl" <<<
(eval cs-prog)
(test #f stream? '#(1 2))
(define test-file (find-executable-path (find-system-path 'exec-file) #f))
(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ"))
(test 1 'stream-length (stream-length (stream-cons 1 empty-stream)))
(define (feed-file out)
(let ([p (open-input-file test-file)])
(let loop ()
(let ([c (read-byte p)])
(unless (eof-object? c)
(write-byte c out)
(loop))))))
(define (feed-file/fast out)
(let ([p (open-input-file test-file)])
((copy-stream p out))
(close-input-port p)))
(define (check-file in)
(let ([p (open-input-file test-file)])
(let loop ([badc 0])
(let ([c (read-byte p)]
[c2 (read-byte in)])
(unless (eq? c c2)
(if (= badc 30)
(error "check-failed" (file-position p) c c2)
(begin
(fprintf (current-error-port)
"fail: ~a ~s=~s ~s=~s\n"
(file-position p) c (integer->char c) c2 (integer->char c2))
(loop (add1 badc)))))
(unless (eof-object? c)
(loop badc))))
(close-input-port p)))
(define infinite-ones (stream-cons 1 infinite-ones))
(define (check-file/fast in)
(let ([p (open-input-file test-file)])
(let loop ()
(let* ([s (read-bytes 5000 p)]
[s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)])
(unless (equal? s s2)
(error "fast check failed"))
(unless (eof-object? s)
(loop))))
(close-input-port p)))
(test 1 stream-first infinite-ones)
(test 1 stream-ref infinite-ones 100)
(define (check-file/fastest in)
(let ([p (open-input-file test-file)]
[s1 (make-bytes 5000)]
[s2 (make-bytes 5000)])
(let loop ([leftover 0][startpos 0][pos 0])
(let* ([n1 (if (zero? leftover)
(read-bytes-avail! s1 p)
leftover)]
[n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
1
n1))])
(unless (if (or (eof-object? n1)
(eof-object? n2))
(and (eof-object? n1)
(eof-object? n2))
(if (= n2 n1 5000)
(bytes=? s1 s2)
(bytes=? (subbytes s1 startpos (+ startpos n2))
(subbytes s2 0 n2))))
(error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
(unless (eof-object? n1)
(loop (- n1 n2)
(if (= n1 n2)
0
(+ startpos n2))
(+ pos n2)))))
(close-input-port p)))
(test 1 stream-first (stream-cons 1 (let loop () (loop))))
(test 2 stream-length (stream-cons (let loop () (loop))
(stream-cons (let loop () (loop))
empty)))
(define portno 40010)
(define (setup-mzscheme-echo tcp?)
(define p (process* test-file "-q" "-b"))
(define s (make-bytes 256))
(define r #f)
(define w #f)
(define r2 #f)
(define w2 #f)
(thread (copy-stream (cadddr p) (current-error-port)))
(fprintf (cadr p) "(define log void)\n")
(fprintf (cadr p) "~s\n" cs-prog)
(if tcp?
(let ([t
(thread (lambda ()
(define-values (rr ww) (tcp-accept l1))
(define-values (rr2 ww2) (tcp-accept l2))
(set! r rr)
(set! w ww)
(set! r2 rr2)
(set! w2 ww2)))])
(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))\n" portno)
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
(flush-output (cadr p))
(thread-wait t)
(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))\n"))
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
(flush-output (cadr p))
(unless tcp?
;; Flush initial output from other process:
(let loop ()
(sleep 0.3)
(unless (zero? (read-bytes-avail!* s (car p)))
(loop))))
(if tcp?
(values r w r2 w2)
p))
(define start-ms 0)
(define start-ps-ms 0)
(define start-gc-ms 0)
(define (start s)
(printf s)
(set! start-ms (current-milliseconds))
(set! start-gc-ms (current-gc-milliseconds))
(set! start-ps-ms (current-process-milliseconds)))
(define (end)
(let ([ps-ms (current-process-milliseconds)]
[gc-ms (current-gc-milliseconds)]
[ms (current-milliseconds)])
(printf "cpu: ~a real: ~a gc ~a\n"
(- ps-ms start-ps-ms)
(- ms start-ms)
(- gc-ms start-gc-ms))))
'(thread (lambda ()
(let loop ()
(printf "alive\n")
(sleep 1)
(loop))))
(start "Quick check:\n")
(define p (open-input-file test-file))
(check-file/fast p)
(close-input-port p)
(end)
(start "Quicker check:\n")
(define p (open-input-file test-file))
(check-file/fastest p)
(close-input-port p)
(end)
(start "Plain pipe...\n")
(define-values (r w) (make-pipe))
(feed-file w)
(close-output-port w)
(check-file r)
(end)
(start "Plain pipe, faster...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fast r)
(end)
(start "Plain pipe, fastest...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fastest r)
(end)
(start "Limited pipe...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file w)
(close-output-port w)))
(check-file r)
(end)
(start "Limited pipe, faster...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fast r)
(end)
(start "Limited pipe, fastest...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fastest r)
(end)
(start "To file and back:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
(feed-file w)
(close-output-port w)
(thread-wait t)
(close-output-port p)
(end)
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file r)
(end)
(start "To file and back, faster:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
(feed-file/fast w)
(close-output-port w)
(thread-wait t)
(close-output-port p)
(end)
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file/fast r)
(end)
(start "File back, fastest:\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
(thread-wait t)
(close-output-port w)
(close-input-port p)
(check-file/fastest r)
(end)
(start "Echo...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file (cadr p))
(close-output-port (cadr p))))
(check-file (car p))
(end)
(start "Echo, faster...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file/fast (cadr p))
(close-output-port (cadr p))))
(check-file/fast (car p))
(end)
(start "Echo, indirect...\n")
(define p (setup-mzscheme-echo #f))
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p))))
(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2)))
(thread (lambda ()
(feed-file/fast wp1)
(close-output-port wp1)))
(check-file/fast rp2)
(end)
(define l1 (tcp-listen portno 5 #t))
(define l2 (tcp-listen (add1 portno) 5 #t))
(start "TCP Echo...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda ()
(feed-file w)
(close-output-port w)))
(check-file r2)
(close-input-port r2)
(end)
(start "TCP Echo, faster...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda ()
(feed-file/fast w)
(close-output-port w)))
(check-file/fast r2)
(close-input-port r2)
(end)
(start "TCP Echo, indirect...\n")
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda () ((copy-stream rp1 w)) (close-output-port w)))
(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2)))
(thread (lambda ()
(feed-file/fast wp1)
(close-output-port wp1)))
(check-file/fast rp2)
(end)
(tcp-close l1)
(tcp-close l2)
(report-errs)