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

Last change on this file since 37682 was 37682, checked in by Kon Lovett, 4 months ago

fix record-variants use w/ C5.1

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