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

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

remove "primitives"

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