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

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

Rmvd unused. Math streams are "constants".

File size: 5.5 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-lazy
76  $$stream-eager
77  $$make-stream-pare)
78
79(import scheme chicken
80  (only type-checks define-check+error-type)
81  (only type-errors define-error-type))
82
83(require-library type-checks type-errors)
84
85;;;
86
87(define-check+error-type stream)
88(define-check+error-type stream-occupied)
89(define-error-type stream-pair)
90
91;;;
92
93(define (stream? obj) (%stream? obj))
94
95(define ($$make-stream-lazy thunk) (%make-stream-lazy thunk))
96
97(define-syntax $$stream-lazy
98  (syntax-rules ()
99    ((_ EXPR) ($$make-stream-lazy (lambda () EXPR)) ) ) )
100
101(define ($$stream-eager obj) (%make-stream-eager obj))
102
103(define-syntax $$stream-delay
104  (syntax-rules ()
105    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )
106
107(define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))
108
109;;;
110
111(define (stream-force promise)
112  (let ((content (%stream-promise promise)))
113    (case (%stream-box-tag content)
114      ((eager)
115        (%stream-box-value content) )
116      ((lazy)
117        (let* ((promise* ((%stream-box-value content)))
118               (content  (%stream-promise promise)))
119          (unless (%eq? 'eager (%stream-box-tag content))
120            (let ((prm (%stream-promise promise*)))
121              (%stream-box-tag-set! content (%stream-box-tag prm))
122              (%stream-box-value-set! content (%stream-box-value prm)) )
123            (%stream-promise-set! promise* content) )
124         (stream-force promise) ) ) ) ) )
125
126(define stream-null ($$stream-delay (%cons 'stream 'null)))
127
128(define (stream-null? obj) (and (%stream? obj) (%stream-null? obj)))
129(define (stream-occupied? obj) (and (%stream? obj) (not (%stream-null? obj))))
130
131(define-syntax stream-cons
132  (syntax-rules ()
133    ((_ EXPR STRM)
134     ($$stream-eager ($$make-stream-pare ($$stream-delay EXPR) ($$stream-lazy STRM))) ) ) )
135
136(define (stream-pair? obj) (and (%stream? obj) (%stream-pare? (stream-force obj))))
137
138(define (stream-car streem)
139  (stream-force (%stream-kar (%checked-stream-pair 'stream-car streem))) )
140
141(define (stream-cdr streem)
142  (%stream-kdr (%checked-stream-pair 'stream-cdr streem)) )
143
144(define-syntax stream-lambda
145  (syntax-rules ()
146    ((_ FORMALS BODY0 BODY1 ...)
147     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )
148
149) ;module streams-primitive
Note: See TracBrowser for help on using the repository browser.