source: project/release/5/srfi-41/trunk/streams-primitive.scm @ 37261

Last change on this file since 37261 was 37261, checked in by Kon Lovett, 9 months ago

rename, extract, redundant inline

File size: 6.1 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(module streams-primitive
19
20(;export
21  ;;SRFI 41 primitive
22  stream?
23  stream-null stream-null?
24  (stream-cons $$make-stream-pair) ;($$stream-eager $$stream-lazy $$stream-delay)
25  stream-pair? stream-car stream-cdr
26  stream-lambda ;($$stream-lazy)
27  ;;Extras
28  stream-occupied?
29  ;;Common errors
30  check-stream error-stream
31  check-stream-occupied error-stream-occupied
32  ;;WTF
33  ($$stream-lazy $$make-stream-lazy)
34  ($$stream-eager $$make-stream-eager)
35  $$stream-delay ;($$stream-lazy $$stream-eager)
36  $$make-stream-lazy
37  $$make-stream-eager
38  $$make-stream-pair)
39
40(import scheme
41  (chicken base)
42  type-checks type-errors
43  record-variants)
44
45(include "chicken-primitive-object-inlines")
46(include "streams-inlines")
47
48;;;
49
50(define-record-type-variant stream (unsafe unchecked inline)
51  (%make-stream prom)
52  $stream?  ;ignore since %stream? conflicts with predefined inline
53  (prom %stream-promise %stream-promise-set!) )
54
55(define-check+error-type stream %stream?)
56
57(define-inline (stream-tagged-pair? obj)
58  (and
59    (%pair? obj)
60    (let ((tag (%car obj)))
61      (or (%eq? 'lazy tag) (%eq? 'eager tag)) ) ) )
62
63(define-inline (make-stream-box tag obj) (%cons tag obj))
64(define-inline (stream-box-tag box) (%car box))
65(define-inline (stream-box-value box) (%cdr box))
66(define-inline (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
67(define-inline (stream-box-value-set! box val) (%set-cdr! box val))
68(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
69(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
70(define-inline (check-stream-box loc obj)
71  (unless (stream-tagged-pair? obj)
72    (error-argument-type loc obj "stream-box") )
73  obj )
74
75;;;
76
77(define ($$make-stream-lazy thunk) (%make-stream (make-stream-lazy-box thunk)))
78(define ($$make-stream-eager obj) (%make-stream (make-stream-eager-box obj)))
79
80(define-syntax $$stream-lazy
81  (syntax-rules ()
82    (($$stream-lazy ?expr)
83      ($$make-stream-lazy (lambda () ?expr)) ) ) )
84
85(define-syntax $$stream-eager
86  (syntax-rules ()
87    (($$stream-eager ?expr)
88      ($$make-stream-eager ?expr) ) ) )
89
90(define-syntax $$stream-delay
91  (syntax-rules ()
92    (($stream-delay ?expr)
93      ($$stream-lazy ($$stream-eager ?expr)) ) ) )
94
95(define (stream-force prom)
96  (let* (
97    (content (%stream-promise (check-stream #f prom)))
98    (promise-box-value (stream-box-value content)) )
99    ;better be there! (check-stream-box #f content)
100    (case (stream-box-tag content)
101      ((eager)
102        promise-box-value )
103      ((lazy)
104        (let* (
105          (prom* (promise-box-value))
106          ;re-fetch promise in case changed by recursion via above call.
107          (content (%stream-promise prom)) )
108          ;re-establish bona-fides
109          (check-stream #f prom*)
110          ;better be there! (check-stream-box #f content)
111          (unless (eq? 'eager (stream-box-tag content))
112            (let (
113              (content* (%stream-promise prom*)) )
114              (stream-box-tag-set! content (stream-box-tag content*))
115              (stream-box-value-set! content (stream-box-value content*)) )
116            (%stream-promise-set! prom* content) )
117          (stream-force prom) ) ) ) ) )
118
119;;;
120
121(define (stream? obj) (%stream? obj))
122
123(define stream-null ($$stream-delay (%cons 'stream 'null)))
124
125(define-inline (*stream-null? strm)
126  (eq? (stream-force strm) (stream-force stream-null)) )
127
128(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
129(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))
130
131(define-check+error-type stream-occupied)
132
133(define-syntax stream-lambda
134  (syntax-rules ()
135    ((stream-lambda ?formals ?body0 ?body1 ...)
136     (lambda ?formals ($$stream-lazy (let () ?body0 ?body1 ...))) ) ) )
137
138;;
139
140(define-record-type-variant stream-pair (unsafe unchecked inline)
141  (%make-stream-pair car cdr)
142  %stream-pair?
143  (car %stream-car)
144  (cdr %stream-cdr) )
145
146;want inline car/cdr but need exportable procedure for make.
147(define ($$make-stream-pair car cdr)
148  (%make-stream-pair car cdr) )
149
150(define-error-type stream-pair)
151
152(define-inline (checked-stream-pair loc obj)
153  (cond
154    ((not (%stream? obj))
155      (error-stream loc obj 'stream) )
156    ((*stream-null? obj)
157      (error-stream-occupied loc obj 'stream) )
158    (else
159      (let ((val (stream-force obj)))
160        (if (%stream-pair? val)
161          val
162          (error-stream-pair loc val 'stream)) ) ) ) )
163
164(define-syntax stream-cons
165  (syntax-rules ()
166    ((_ ?expr ?strm)
167      ($$stream-eager
168        ($$make-stream-pair ($$stream-delay ?expr) ($$stream-lazy ?strm))) ) ) )
169
170(define (stream-pair? obj)
171  (and (%stream? obj) (%stream-pair? (stream-force obj))) )
172
173(define (stream-car strm)
174  (stream-force (%stream-car (checked-stream-pair 'stream-car strm))) )
175
176(define (stream-cdr strm)
177  (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )
178
179) ;module streams-primitive
Note: See TracBrowser for help on using the repository browser.