core/io/io.factor

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