forked from factor/factor
/
io.factor
262 lines (194 loc) · 8.81 KB
/
io.factor
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators destructors kernel kernel.private math
namespaces sequences sequences.private ;
IN: io
SYMBOLS: +byte+ +character+ ;
GENERIC: stream-element-type ( stream -- type )
GENERIC: stream-read1 ( stream -- elt )
GENERIC: stream-read-unsafe ( n buf stream -- count )
GENERIC: stream-read-until ( seps stream -- seq sep/f )
GENERIC: stream-read-partial-unsafe ( n buf stream -- count )
GENERIC: stream-readln ( stream -- str/f )
GENERIC: stream-contents ( stream -- seq )
GENERIC: stream-write1 ( elt stream -- )
GENERIC: stream-write ( data stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
SINGLETONS: seek-absolute seek-relative seek-end ;
GENERIC: stream-tell ( stream -- n )
GENERIC: stream-seek ( n seek-type stream -- )
GENERIC: stream-seekable? ( stream -- ? )
GENERIC: stream-length ( stream -- n/f )
: stream-print ( str stream -- ) [ stream-write ] [ stream-nl ] bi ;
! Default streams
MIXIN: input-stream
MIXIN: output-stream
SYMBOL: error-stream
: readln ( -- str/f ) input-stream get stream-readln ; inline
: read1 ( -- elt ) input-stream get stream-read1 ; inline
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; inline
: tell-input ( -- n ) input-stream get stream-tell ; inline
: tell-output ( -- n ) output-stream get stream-tell ; inline
: seek-input ( n seek-type -- ) input-stream get stream-seek ; inline
: seek-output ( n seek-type -- ) output-stream get stream-seek ; inline
: write1 ( elt -- ) output-stream get stream-write1 ; inline
: write ( seq -- ) output-stream get stream-write ; inline
: flush ( -- ) output-stream get stream-flush ; inline
: nl ( -- ) output-stream get stream-nl ; inline
: with-input-stream* ( stream quot -- )
input-stream swap with-variable ; inline
: with-input-stream ( stream quot -- )
[ with-input-stream* ] curry with-disposal ; inline
: with-output-stream* ( stream quot -- )
output-stream swap with-variable ; inline
: with-output-stream ( stream quot -- )
[ with-output-stream* ] curry with-disposal ; inline
: with-error-stream* ( stream quot -- )
error-stream swap with-variable ; inline
: with-error-stream ( stream quot -- )
[ with-error-stream* ] curry with-disposal ; inline
: with-output+error-stream* ( stream quot -- )
[ dup ] dip [ with-error-stream* ] curry with-output-stream* ; inline
: with-output+error-stream ( stream quot -- )
[ with-output+error-stream* ] curry with-disposal ; inline
: with-output>error ( quot -- )
error-stream get swap with-output-stream* ; inline
: with-error>output ( quot -- )
output-stream get swap with-error-stream* ; inline
: with-streams* ( input output quot -- )
swapd [ with-output-stream* ] curry with-input-stream* ; inline
: with-streams ( input output quot -- )
#! We have to dispose of the output stream first, so that
#! if both streams point to the same FD, we get to flush the
#! buffer before closing the FD.
swapd [ with-output-stream ] curry with-input-stream ; inline
: with-input-output+error-streams* ( input output+error quot -- )
swapd [ with-output+error-stream* ] curry with-input-stream* ; inline
: with-input-output+error-streams ( input output+error quot -- )
swapd [ with-output+error-stream ] curry with-input-stream ; inline
: print ( str -- ) output-stream get stream-print ; inline
: bl ( -- ) " " write ;
: each-morsel ( ..a handler: ( ..a data -- ..b ) reader: ( ..b -- ..a data ) -- ..a )
[ dup ] compose swap while drop ; inline
<PRIVATE
: stream-exemplar ( stream -- exemplar )
stream-element-type {
{ +byte+ [ B{ } ] }
{ +character+ [ "" ] }
} case ; inline
: stream-exemplar-growable ( stream -- exemplar )
stream-element-type {
{ +byte+ [ BV{ } ] }
{ +character+ [ SBUF" " ] }
} case ; inline
: (new-sequence-for-stream) ( n stream -- seq )
stream-exemplar new-sequence ; inline
: resize-if-necessary ( wanted-n got-n seq -- seq' )
2over = [ [ 2drop ] dip ] [ resize nip ] if ; inline
: (read-into-new) ( n stream quot -- seq/f )
[ dup ] 2dip
[ 2dup (new-sequence-for-stream) swap ] dip curry keep
over 0 = [ 3drop f ] [ resize-if-necessary ] if ; inline
: (read-into) ( buf stream quot -- buf-slice/f )
[ dup length over ] 2dip call
[ (head) <slice-unsafe> ] [ zero? not ] bi ; inline
PRIVATE>
: stream-read ( n stream -- seq/f )
[ stream-read-unsafe ] (read-into-new) ; inline
: stream-read-partial ( n stream -- seq/f )
[ stream-read-partial-unsafe ] (read-into-new) ; inline
ERROR: invalid-read-buffer buf stream ;
: stream-read-into ( buf stream -- buf-slice more? )
[ stream-read-unsafe { fixnum } declare ] (read-into) ; inline
: stream-read-partial-into ( buf stream -- buf-slice more? )
[ stream-read-partial-unsafe { fixnum } declare ] (read-into) ; inline
: read ( n -- seq ) input-stream get stream-read ; inline
: read-partial ( n -- seq ) input-stream get stream-read-partial ; inline
: read-into ( buf -- buf-slice more? )
input-stream get stream-read-into ; inline
: read-partial-into ( buf -- buf-slice more? )
input-stream get stream-read-partial-into ; inline
: each-stream-line ( ... stream quot: ( ... line -- ... ) -- ... )
swap [ stream-readln ] curry each-morsel ; inline
: each-line ( ... quot: ( ... line -- ... ) -- ... )
input-stream get swap each-stream-line ; inline
: stream-lines ( stream -- seq )
[ [ ] collector [ each-stream-line ] dip { } like ] with-disposal ;
: lines ( -- seq )
input-stream get stream-lines ; inline
CONSTANT: each-block-size 65536
: each-stream-block-slice ( ... stream quot: ( ... block-slice -- ... ) -- ... )
[ drop ] prepose
swap [ each-block-size swap (new-sequence-for-stream) ] keep
[ stream-read-partial-into ] 2curry each-morsel drop ; inline
: each-stream-block ( ... stream quot: ( ... block -- ... ) -- ... )
swap [ each-block-size swap stream-read-partial ] curry each-morsel ; inline
: each-block-slice ( ... quot: ( ... block -- ... ) -- ... )
input-stream get swap each-stream-block-slice ; inline
: each-block ( ... quot: ( ... block -- ... ) -- ... )
input-stream get swap each-stream-block ; inline
: (stream-contents-by-length) ( stream len -- seq )
dup rot [
[ (new-sequence-for-stream) ]
[ [ stream-read-unsafe ] curry keep resize ] bi
] with-disposal ;
: (stream-contents-by-block) ( stream -- seq )
[
[ [ ] collector [ each-stream-block ] dip { } like ]
[ stream-exemplar concat-as ] bi
] with-disposal ;
: (stream-contents-by-length-or-block) ( stream -- seq )
dup stream-length
[ (stream-contents-by-length) ]
[ (stream-contents-by-block) ] if* ; inline
: (stream-contents-by-element) ( stream -- seq )
[
[ [ stream-read1 dup ] curry [ ] ]
[ stream-exemplar produce-as nip ] bi
] with-disposal ;
: contents ( -- seq )
input-stream get stream-contents ; inline
: stream-copy* ( in out -- )
[ stream-write ] curry each-stream-block ; inline
: stream-copy ( in out -- )
[ [ stream-copy* ] with-disposal ] curry with-disposal ; inline
! Default implementations of stream operations in terms of read1/write1
<PRIVATE
: read-loop ( buf stream n i -- count )
2dup = [ nip nip nip ] [
pick stream-read1 [
over [ pick set-nth-unsafe ] 2curry 3dip
1 + read-loop
] [ nip nip nip ] if*
] if ; inline recursive
: finalize-read-until ( seq sep/f -- seq/f sep/f )
2dup [ empty? ] [ not ] bi* and [ 2drop f f ] when ; inline
: read-until-loop ( seps stream -- seq sep/f )
[ [ stream-read1 dup [ rot member? not ] [ nip f ] if* ] 2curry [ ] ]
[ stream-exemplar ] bi produce-as swap finalize-read-until ; inline
PRIVATE>
M: input-stream stream-read-unsafe rot 0 read-loop ;
M: input-stream stream-read-partial-unsafe stream-read-unsafe ; inline
M: input-stream stream-read-until read-until-loop ;
M: input-stream stream-readln
"\n" swap stream-read-until drop ; inline
M: input-stream stream-contents (stream-contents-by-length-or-block) ; inline
M: input-stream stream-seekable? drop f ; inline
M: input-stream stream-length drop f ; inline
M: output-stream stream-write [ stream-write1 ] curry each ; inline
M: output-stream stream-flush drop ; inline
M: output-stream stream-nl CHAR: \n swap stream-write1 ; inline
M: output-stream stream-seekable? drop f ; inline
M: output-stream stream-length drop f ; inline
M: f stream-read1 drop f ; inline
M: f stream-read-unsafe 3drop 0 ; inline
M: f stream-read-until 2drop f f ; inline
M: f stream-read-partial-unsafe 3drop 0 ; inline
M: f stream-readln drop f ; inline
M: f stream-contents drop f ; inline
M: f stream-write1 2drop ; inline
M: f stream-write 2drop ; inline
M: f stream-flush drop ; inline
M: f stream-nl drop ; inline