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 <PRIVATE
 107
 108 : stream-exemplar ( stream -- exemplar )
 109     stream-element-type +byte+ = B{ } "" ? ; inline
 110
 111 : stream-exemplar-growable ( stream -- exemplar )
 112     stream-element-type +byte+ = BV{ } SBUF" " ? ; inline
 113
 114 : (new-sequence-for-stream) ( n stream -- seq )
 115     stream-exemplar new-sequence ; inline
 116
 117 : resize-if-necessary ( wanted-n got-n seq -- seq' )
 118     2over = [ 2nip ] [ resize nip ] if ; inline
 119
 120 : (read-into-new) ( n stream quot -- seq/f )
 121     [ dup ] 2dip
 122     [ 2dup (new-sequence-for-stream) swap ] dip keepd
 123     over 0 = [ 3drop f ] [ resize-if-necessary ] if ; inline
 124
 125 : (read-into) ( buf stream quot -- buf-slice/f )
 126     [ dup length over ] 2dip call
 127     [ (head) <slice-unsafe> ] [ zero? not ] bi ; inline
 128
 129 PRIVATE>
 130
 131 : stream-read ( n stream -- seq/f )
 132     [ stream-read-unsafe ] (read-into-new) ; inline
 133
 134 : stream-read-partial ( n stream -- seq/f )
 135     [ stream-read-partial-unsafe ] (read-into-new) ; inline
 136
 137 ERROR: invalid-read-buffer buf stream ;
 138
 139 : stream-read-into ( buf stream -- buf-slice more? )
 140     [ stream-read-unsafe { fixnum } declare ] (read-into) ; inline
 141
 142 : stream-read-partial-into ( buf stream -- buf-slice more? )
 143     [ stream-read-partial-unsafe { fixnum } declare ] (read-into) ; inline
 144
 145 : read ( n -- seq ) input-stream get stream-read ; inline
 146
 147 : read-partial ( n -- seq ) input-stream get stream-read-partial ; inline
 148
 149 : read-into ( buf -- buf-slice more? )
 150     input-stream get stream-read-into ; inline
 151
 152 : read-partial-into ( buf -- buf-slice more? )
 153     input-stream get stream-read-partial-into ; inline
 154
 155 : each-stream-line ( ... stream quot: ( ... line -- ... ) -- ... )
 156     [ [ stream-readln ] curry ] dip while* ; inline
 157
 158 : each-line ( ... quot: ( ... line -- ... ) -- ... )
 159     input-stream get swap each-stream-line ; inline
 160
 161 : stream-lines ( stream -- seq )
 162     [
 163         [ ] collector [ each-stream-line ] dip { } like
 164     ] with-disposal ; inline
 165
 166 : lines ( -- seq )
 167     input-stream get stream-lines ; inline
 168
 169 CONSTANT: each-block-size 65536
 170
 171 : (each-stream-block-slice) ( ... stream quot: ( ... block-slice -- ... ) block-size -- ... )
 172     -rot [
 173         [ (new-sequence-for-stream) ] keep
 174         [ stream-read-partial-into ] 2curry
 175     ] dip while drop ; inline
 176
 177 : each-stream-block-slice ( ... stream quot: ( ... block-slice -- ... ) -- ... )
 178     each-block-size (each-stream-block-slice) ; inline
 179
 180 : (each-stream-block) ( ... stream quot: ( ... block -- ... ) block-size -- ... )
 181     -rot [ [ stream-read-partial ] 2curry ] dip while* ; inline
 182
 183 : each-stream-block ( ... stream quot: ( ... block -- ... ) -- ... )
 184     each-block-size (each-stream-block) ; inline
 185
 186 : each-block-slice ( ... quot: ( ... block -- ... ) -- ... )
 187     input-stream get swap each-stream-block-slice ; inline
 188
 189 : each-block ( ... quot: ( ... block -- ... ) -- ... )
 190     input-stream get swap each-stream-block ; inline
 191
 192 : (stream-contents-by-length) ( stream len -- seq )
 193     dup rot
 194     [ (new-sequence-for-stream) ]
 195     [ [ stream-read-unsafe ] keepd resize ] bi ; inline
 196
 197 : (stream-contents-by-block) ( stream -- seq )
 198     [ [ ] collector [ each-stream-block ] dip { } like ]
 199     [ stream-exemplar concat-as ] bi ; inline
 200
 201 : (stream-contents-by-length-or-block) ( stream -- seq )
 202     dup stream-length
 203     [ (stream-contents-by-length) ]
 204     [ (stream-contents-by-block)  ] if* ; inline
 205
 206 : (stream-contents-by-element) ( stream -- seq )
 207     [
 208         [ [ stream-read1 dup ] curry [ ] ]
 209         [ stream-exemplar produce-as nip ] bi
 210     ] with-disposal ; inline
 211
 212 : contents ( -- seq )
 213     input-stream get stream-contents ; inline
 214
 215 : stream-copy* ( in out -- )
 216     [ stream-write ] curry each-stream-block ; inline
 217
 218 : stream-copy ( in out -- )
 219     [ [ stream-copy* ] with-disposal ] curry with-disposal ; inline
 220
 221 ! Default implementations of stream operations in terms of read1/write1
 222
 223 <PRIVATE
 224
 225 : read-loop ( buf stream n i -- count )
 226      2dup = [ 3nip ] [
 227         pick stream-read1 [
 228             over [ pick set-nth-unsafe ] 2curry 3dip
 229             1 + read-loop
 230         ] [ 3nip ] if*
 231      ] if ; inline recursive
 232
 233 : finalize-read-until ( seq sep/f -- seq/f sep/f )
 234     2dup [ empty? ] [ not ] bi* and [ 2drop f f ] when ; inline
 235
 236 : read-until-loop ( seps stream -- seq sep/f )
 237     [ [ stream-read1 dup [ rot member? not ] [ nip f ] if* ] 2curry [ ] ]
 238     [ stream-exemplar ] bi produce-as swap finalize-read-until ; inline
 239
 240 PRIVATE>
 241
 242 M: input-stream stream-read-unsafe rot 0 read-loop ; inline
 243 M: input-stream stream-read-partial-unsafe stream-read-unsafe ; inline
 244 M: input-stream stream-read-until read-until-loop ; inline
 245 M: input-stream stream-readln "\n" swap stream-read-until drop ; inline
 246 M: input-stream stream-contents* (stream-contents-by-length-or-block) ; inline
 247 M: input-stream stream-seekable? drop f ; inline
 248 M: input-stream stream-length drop f ; inline
 249
 250 M: output-stream stream-write [ stream-write1 ] curry each ; inline
 251 M: output-stream stream-flush drop ; inline
 252 M: output-stream stream-nl CHAR: \n swap stream-write1 ; inline
 253 M: output-stream stream-seekable? drop f ; inline
 254 M: output-stream stream-length drop f ; inline
 255
 256 M: f stream-read1 drop f ; inline
 257 M: f stream-read-unsafe 3drop 0 ; inline
 258 M: f stream-read-until 2drop f f ; inline
 259 M: f stream-read-partial-unsafe 3drop 0 ; inline
 260 M: f stream-readln drop f ; inline
 261 M: f stream-contents* drop f ; inline
 262
 263 M: f stream-write1 2drop ; inline
 264 M: f stream-write 2drop ; inline
 265 M: f stream-flush drop ; inline
 266 M: f stream-nl drop ; inline