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

Last change on this file since 39713 was 39713, checked in by Kon Lovett, 8 weeks ago

remove "primitives", replace inline type checks

File size: 6.7 KB
Line 
1;;;; streams-primitive.scm  -*- Scheme -*-
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
24  stream-null?
25  stream-cons
26  stream-pair?
27  stream-car
28  stream-cdr
29  stream-lambda
30  ;extras
31  stream-occupied?
32  check-stream
33  error-stream
34  check-stream-occupied
35  error-stream-occupied
36  ;explicit export: compiler cannot follow syntax >-> syntax
37  $stream-lazy$
38  $stream-eager$
39  $stream-delay$
40  $make-stream-lazy$
41  $make-stream-eager$
42  $make-stream-pair$)
43
44(import scheme
45  (chicken base)
46  (chicken syntax)
47  type-checks
48  type-errors
49  record-variants)
50
51;;;
52
53;; ensure identifier defined
54(define stream 'stream)
55(define-record-type-variant stream (unsafe unchecked inline)
56  (%make-stream prom)
57  (%stream?)
58  (prom %stream-promise %stream-promise-set!) )
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! box tag))
70(define-inline (stream-box-value-set! box val) (set-cdr! box val))
71
72(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
73(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
74
75(define-inline (stream-lazy-box? obj) (eq? 'lazy (stream-box-tag obj)))
76(define-inline (stream-eager-box? obj) (eq? 'eager (stream-box-tag obj)))
77
78(define-inline (check-stream-box loc obj)
79  (unless (stream-tagged-pair? obj)
80    (error-argument-type loc obj "stream-box") )
81  obj )
82
83(define (stream-print obj out)
84  (display "#<" out)
85  (let ((promise (%stream-promise obj)))
86    (cond
87      ((stream-eager-box? promise)  (display "eager stream" out))
88      ((stream-lazy-box? promise)   (display "lazy stream" out))
89      (else
90        (display "unknown stream " out) (display promise out)) ) )
91  (display ">" out) )
92
93;;;
94
95(define ($make-stream-lazy$ thunk) (%make-stream (make-stream-lazy-box thunk)))
96(define ($make-stream-eager$ obj) (%make-stream (make-stream-eager-box obj)))
97
98(define-syntax $stream-lazy$
99  (syntax-rules ()
100    (($stream-lazy$ ?expr)
101      ($make-stream-lazy$ (lambda () ?expr)) ) ) )
102
103(define-syntax $stream-eager$
104  (syntax-rules ()
105    (($stream-eager$ ?expr)
106      ($make-stream-eager$ ?expr) ) ) )
107
108(define-syntax $stream-delay$
109  (syntax-rules ()
110    (($stream-delay$ ?expr)
111      ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )
112
113;;;
114
115(define (stream? obj) (%stream? obj))
116
117(define-check+error-type stream)
118
119(define (stream-force prom)
120  (let* (
121    (content (%stream-promise (check-stream #f prom)))
122    (promise-box-value (stream-box-value content)) )
123    ;better be there! (check-stream-box #f content)
124    (case (stream-box-tag content)
125      ((eager)
126        promise-box-value )
127      ((lazy)
128        (let* (
129          (prom* (promise-box-value))
130          ;re-fetch promise in case changed by recursion via above call.
131          (content (%stream-promise prom)) )
132          ;re-establish bona-fides
133          (check-stream #f prom*)
134          ;better be there! (check-stream-box #f content)
135          (unless (eq? 'eager (stream-box-tag content))
136            (let ((content* (%stream-promise prom*)))
137              (stream-box-tag-set! content (stream-box-tag content*))
138              (stream-box-value-set! content (stream-box-value content*)) )
139            (%stream-promise-set! prom* content) )
140          (stream-force prom) ) ) ) ) )
141
142(define stream-null ($stream-delay$ (cons 'stream 'null)))
143
144(define-inline (*stream-null? strm)
145  (eq? (stream-force strm) (stream-force stream-null)) )
146
147(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
148(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))
149
150(define-check+error-type stream-occupied)
151
152(define-syntax stream-lambda
153  (syntax-rules ()
154    ((stream-lambda ?formals ?body0 ?body1 ...)
155     (lambda ?formals ($stream-lazy$ (let () ?body0 ?body1 ...))) ) ) )
156
157;;
158
159;; ensure identifier defined
160(define stream-pair 'stream-pair)
161(define-record-type-variant stream-pair (unsafe unchecked inline)
162  (%make-stream-pair hd tl)
163  (%stream-pair?)
164  (hd %stream-car)
165  (tl %stream-cdr) )
166
167;want inline car/cdr but need exportable procedure for make.
168(define ($make-stream-pair$ hd tl) (%make-stream-pair hd tl))
169
170(define-error-type stream-pair)
171
172(define-inline (checked-stream-pair loc obj)
173  (cond
174    ((not (%stream? obj))
175      (error-stream loc obj 'stream) )
176    ((*stream-null? obj)
177      (error-stream-occupied loc obj 'stream) )
178    (else
179      (let ((val (stream-force obj)))
180        (if (%stream-pair? val)
181          val
182          (error-stream-pair loc val 'stream)) ) ) ) )
183
184(define (stream-pair-print obj out)
185  (display "#<" out)
186  (display (%stream-car obj) out)
187  (display " " out)
188  (display (%stream-cdr obj) out)
189  (display ">" out) )
190
191(define-syntax stream-cons
192  (syntax-rules ()
193    ((_ ?expr ?strm)
194      ($stream-eager$ ($make-stream-pair$ ($stream-delay$ ?expr) ($stream-lazy$ ?strm))) ) ) )
195
196(define (stream-pair? obj)
197  (and (%stream? obj) (%stream-pair? (stream-force obj))) )
198
199(define (stream-car strm)
200  (stream-force (%stream-car (checked-stream-pair 'stream-car strm))) )
201
202(define (stream-cdr strm)
203  (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )
204
205;;;
206
207(set! (record-printer stream) stream-print)
208
209(set! (record-printer stream-pair) stream-pair-print)
210
211) ;module streams-primitive
Note: See TracBrowser for help on using the repository browser.