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

Last change on this file since 14192 was 14192, checked in by Kon Lovett, 11 years ago

Update.

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