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

Last change on this file since 14571 was 14571, checked in by Kon Lovett, 10 years ago

Dropped some explicit inlines. Identifiers that are indirectly used (macros & procs) need to be explicitly exported. Ex: the stream-match macros. Also, streams needs $$make-stream-pare explicitly exported by primitives.

File size: 5.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(declare
19  (usual-integrations)
20  (fixnum)
21  (inline)
22  (inline-limit 50)
23  (local)
24  (no-procedure-checks))
25
26(include "chicken-primitive-object-inlines")
27(include "streams-inlines")
28
29(module streams-primitive (;export
30  ;; SRFI 41 primitive
31  stream?
32  stream-null stream-null?
33  (stream-cons $$make-stream-pare) ;($$stream-eager $$stream-lazy $$stream-delay)
34  stream-pair? stream-car stream-cdr
35  stream-lambda ;($$stream-lazy)
36  ;; Extras
37  stream-occupied?
38  ;; Common errors
39  check-stream error-stream
40  check-stream-occupied error-stream-occupied
41  ;; WTF
42  ($$stream-lazy $$make-stream-lazy)
43  ($$stream-eager $$make-stream-eager)
44  $$stream-delay ;($$stream-lazy $$stream-eager)
45  $$make-stream-lazy
46  $$make-stream-eager
47  $$make-stream-pare)
48
49(import scheme chicken
50  (only type-checks define-check+error-type)
51  (only type-errors define-error-type)
52  srfi-9-ext)
53
54(require-library type-checks type-errors srfi-9-ext)
55
56;;;
57
58(define-record-type/primitive stream
59  (make-stream prm)
60  stream?
61  (prm stream-promise stream-promise-set!) )
62
63(define-check+error-type stream)
64
65(define (make-stream-box tag obj) (%cons tag obj))
66(define (stream-box-tag box) (%car box))
67(define (stream-box-value box) (%cdr box))
68(define (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
69(define (stream-box-value-set! box val) (%set-cdr! box val))
70
71(define ($$make-stream-lazy thunk) (make-stream (make-stream-box 'lazy thunk)))
72(define ($$make-stream-eager obj) (make-stream (make-stream-box 'eager obj)))
73
74(define (*stream-null? strm) (eq? (stream-force strm) (stream-force stream-null)))
75
76;;;
77
78(define-syntax $$stream-lazy
79  (syntax-rules ()
80    ((_ EXPR) ($$make-stream-lazy (lambda () EXPR)) ) ) )
81
82(define-syntax $$stream-eager
83  (syntax-rules ()
84    ((_ EXPR) ($$make-stream-eager EXPR) ) ) )
85
86(define-syntax $$stream-delay
87  (syntax-rules ()
88    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )
89
90(define (stream-force promise)
91  (let ((content (stream-promise promise)))
92    (case (stream-box-tag content)
93      ((eager)
94        (stream-box-value content) )
95      ((lazy)
96        (let* ((promise* ((stream-box-value content)))
97               (content  (stream-promise promise)))
98          (unless (eq? 'eager (stream-box-tag content))
99            (let ((prm (stream-promise promise*)))
100              (stream-box-tag-set! content (stream-box-tag prm))
101              (stream-box-value-set! content (stream-box-value prm)) )
102            (stream-promise-set! promise* content) )
103         (stream-force promise) ) ) ) ) )
104
105(define stream-null ($$stream-delay (%cons 'stream 'null)))
106
107(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
108(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))
109
110(define-check+error-type stream-occupied)
111
112(define-syntax stream-lambda
113  (syntax-rules ()
114    ((_ FORMALS BODY0 BODY1 ...)
115     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )
116
117;;
118
119(define-record-type/primitive stream-pare
120  ($$make-stream-pare kar kdr)
121  stream-pare?
122  (kar stream-kar)
123  (kdr stream-kdr) )
124
125(define-error-type stream-pair)
126
127(define (checked-stream-pare loc obj)
128  (cond
129    ((not (%stream? obj)) (error-stream loc obj 'stream) )
130    ((*stream-null? obj) (error-stream-occupied loc obj 'stream) )
131    (else
132      (let ((val (stream-force obj)))
133        (if (stream-pare? val) val
134            (error-stream-pair loc val 'stream)) ) ) ) )
135
136(define-syntax stream-cons
137  (syntax-rules ()
138    ((_ EXPR STRM)
139     ($$stream-eager ($$make-stream-pare ($$stream-delay EXPR) ($$stream-lazy STRM))) ) ) )
140
141(define (stream-pair? obj) (and (%stream? obj) (stream-pare? (stream-force obj))))
142
143(define (stream-car streem)
144  (stream-force (stream-kar (checked-stream-pare 'stream-car streem))) )
145
146(define (stream-cdr streem)
147  (stream-kdr (checked-stream-pare 'stream-cdr streem)) )
148
149) ;module streams-primitive
Note: See TracBrowser for help on using the repository browser.