source: project/release/4/srfi-41/trunk/streams-primitive.scm @ 14176

Last change on this file since 14176 was 14176, checked in by Kon Lovett, 11 years ago

SRFI 45 use rqrd extra level of indirection so dropped in favor of direct impl.

File size: 4.9 KB
Line 
1;;;; streams-primitive.scm
2;;;; Kon Lovett, Apr '09
3
4; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  All rights
5; reserved.  Permission is hereby granted, free of charge, to any person obtaining a copy of
6; this software and associated documentation files (the "Software"), to deal in the Software
7; without restriction, including without limitation the rights to use, copy, modify, merge,
8; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
9; whom the Software is furnished to do so, subject to the following conditions: The above
10; copyright notice and this permission notice shall be included in all copies or substantial
11; portions of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
12; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
13; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
14; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
15; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
16; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
17
18(declare
19  (usual-integrations)
20  (fixnum)
21  (inline)
22  (local)
23  (no-procedure-checks))
24
25(include "chicken-primitive-object-inlines")
26
27;;;
28
29(define-inline (%make-stream prm) (%make-structure 'stream prm))
30(define-inline (%stream? obj) (%structure-instance? obj 'stream))
31(define-inline (%stream-promise strm) (%structure-ref strm 1))
32(define-inline (%stream-promise-set! strm obj) (%structure-set! strm 1 obj))
33
34(define-inline (%make-stream-pare kar kdr) (%make-structure 'stream-pare kar kdr))
35(define-inline (%stream-pare? obj) (%structure-instance? obj 'stream-pare))
36(define-inline (%stream-kar pare) (%structure-ref pare 1))
37(define-inline (%stream-kdr pare) (%structure-ref pare 2))
38
39(define-inline (%stream-null? strm) (%eq? (stream-force strm) (stream-force stream-null)))
40
41(define-inline (%checked-stream-pair loc obj)
42  (cond
43    ((not (%stream? obj)) (error-stream loc obj 'stream) )
44    ((%stream-null? obj) (error-stream-occupied loc obj 'stream) )
45    (else
46      (let ((val (stream-force obj)))
47        (if (%stream-pare? val) val
48            (error-stream-pair loc val 'stream)) ) ) ) )
49
50(module streams-primitive (;export
51  ;; SRFI 41 primitive
52  stream?
53  stream-null stream-null?
54  (stream-cons $$stream-eager $$make-stream-pare)
55  stream-pair? stream-car stream-cdr
56  stream-lambda
57  ;; Extras
58  stream-occupied?
59  ;; Common errors
60  check-stream error-stream
61  check-stream-occupied error-stream-occupied
62  ;; WTF
63  ($$stream-lazy $$make-lazy-stream)
64  ($$stream-delay $$stream-eager)
65  $$make-stream
66  $$make-lazy-stream
67  $$stream-eager
68  $$make-stream-pare)
69
70(import scheme chicken
71  (only type-checks define-check+error-type)
72  (only type-errors define-error-type))
73
74(require-library type-checks type-errors)
75
76;;;
77
78(define ($$make-stream prm) (%make-stream prm))
79(define (stream? obj) (%stream? obj))
80
81(define-check+error-type stream)
82
83(define ($$make-lazy-stream thunk) (%make-stream (%cons 'lazy thunk)))
84
85(define-syntax $$stream-lazy
86  (syntax-rules ()
87    ((_ EXPR) ($$make-lazy-stream (lambda () EXPR)) ) ) )
88
89(define ($$stream-eager obj) (%make-stream (%cons 'eager obj)))
90
91(define-syntax $$stream-delay
92  (syntax-rules ()
93    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )
94
95(define (stream-force promise)
96  (let ((content (%stream-promise promise)))
97    (case (%car content)
98      ((eager)
99        (%cdr content) )
100      ((lazy)
101        (let* ((promise* ((%cdr content)))
102               (content  (%stream-promise promise)))
103          (unless (%eq? 'eager (%car content))
104            (let ((prm (%stream-promise promise*)))
105              (%set-car!/immediate content (%car prm))
106              (%set-cdr! content (%cdr prm)) )
107            (%stream-promise-set! promise* content) )
108         (stream-force promise) ) ) ) ) )
109
110(define stream-null ($$stream-delay (%cons 'stream 'null)))
111
112(define (stream-null? obj) (and (%stream? obj) (%stream-null? obj)))
113(define (stream-occupied? obj) (and (%stream? obj) (not (%stream-null? obj))))
114
115(define-check+error-type stream-occupied)
116
117(define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))
118
119(define-syntax stream-cons
120  (syntax-rules ()
121    ((_ EXPR STRM)
122     ($$stream-eager ($$make-stream-pare ($$stream-delay EXPR) ($$stream-lazy STRM))) ) ) )
123
124(define (stream-pair? obj) (and (%stream? obj) (%stream-pare? (stream-force obj))))
125
126(define-error-type stream-pair)
127
128(define (stream-car streem)
129  (stream-force (%stream-kar (%checked-stream-pair 'stream-car streem))) )
130
131(define (stream-cdr streem)
132  (%stream-kdr (%checked-stream-pair 'stream-cdr streem)) )
133
134(define-syntax stream-lambda
135  (syntax-rules ()
136    ((_ FORMALS BODY0 BODY1 ...)
137     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )
138
139) ;module streams-primitive
Note: See TracBrowser for help on using the repository browser.