: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
-M: memory-stream stream-peek
- [ index>> ] [ alien>> ] bi <displaced-alien>
- swap memory>byte-array ;
-
M: memory-stream stream-read
- [ stream-peek ]
- [ [ + ] change-index drop ] 2bi ;
+ [
+ [ index>> ] [ alien>> ] bi <displaced-alien>
+ swap memory>byte-array
+ ] [ [ + ] change-index drop ] 2bi ;
M: value-type c-type-rep drop int-rep ;
delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: input-stream-protocol
-stream-peek1 stream-peek stream-read1 stream-read
-stream-read-partial stream-readln
+stream-read1 stream-read stream-read-partial stream-readln
stream-read-until ;
PROTOCOL: output-stream-protocol
}
"Reading from the buffer:"
{ $subsections
- buffer-peek1
+ buffer-peek
buffer-pop
buffer-read
}
{ $description "Advances the fill pointer by " { $snippet "n" } " bytes." }
{ $warning "This word will leave the buffer in an invalid state if it does not have " { $snippet "n" } " bytes available." } ;
-HELP: buffer-peek1
+HELP: buffer-peek
{ $values { "buffer" buffer } { "byte" "a byte" } }
{ $description "Outputs the byte at the buffer position." } ;
dup [ pos>> ] [ fill>> ] bi <
[ 0 >>pos 0 >>fill ] unless drop ; inline
-: buffer-peek1 ( buffer -- byte )
+: buffer-peek ( buffer -- byte )
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
- [ buffer-peek1 ] [ 1 swap buffer-consume ] bi ; inline
+ [ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
] unit-test
[ ] [ "test.txt" temp-file delete-file ] unit-test
-
-[ t ]
-[
- "resource:license.txt" binary [ 10 peek 10 peek ] with-file-reader =
-] unit-test
dup (wait-to-read) buffer>> buffer-empty?
] [ drop f ] if ; inline
-M: input-port stream-peek1
- dup check-disposed dup wait-to-read
- [ drop f ] [ buffer>> buffer-peek1 ] if ; inline
-
M: input-port stream-read1
dup check-disposed
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
] [ 2nip ] if
] [ 2nip ] if ;
-M: input-port stream-peek [ stream-read ] with-input-rewind ;
-
: read-until-step ( separators port -- string/f separator/f )
dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
M: null-reader stream-read1 drop f ;
M: null-reader stream-read-until 2drop f f ;
M: null-reader stream-read 2drop f ;
-M: null-reader stream-peek1 drop f ;
-M: null-reader stream-peek 2drop f ;
M: null-writer stream-element-type drop +byte+ ;
M: null-writer stream-write1 2drop ;
M: string-reader stream-read-partial stream-read ;
M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ;
-M: string-reader stream-peek sequence-peek ;
-M: string-reader stream-peek1 sequence-peek1 ;
M: string-reader stream-read-until sequence-read-until ;
M: string-reader stream-tell i>> ;
M: string-reader stream-seek (stream-seek) ;
stream stream>> stream-read1
[ 1 stream \ read1 stream-exhausted ] unless* ;
-M:: throws-on-eof-stream stream-peek1 ( stream -- obj )
- stream stream>> stream-peek1
- [ 1 stream \ peek1 stream-exhausted ] unless* ;
-
M:: throws-on-eof-stream stream-read ( n stream -- seq )
n stream stream>> stream-read
dup length n = [ n stream \ read stream-exhausted ] unless ;
-M:: throws-on-eof-stream stream-peek ( n stream -- seq )
- n stream stream>> stream-peek
- dup length n = [ n stream \ peek stream-exhausted ] unless ;
-
M:: throws-on-eof-stream stream-read-partial ( n stream -- seq )
n stream stream>> stream-read-partial
[ n stream \ read-partial stream-exhausted ] unless* ;
output-stream get code>>
] with-byte-writer drop
] unit-test
-
-[ t ] [
- "vocab:io/test/mac-os-eol.txt"
- ascii [ 10 peek 10 peek = ] with-file-reader
-] unit-test
-
-[ t ] [
- "vocab:io/test/mac-os-eol.txt"
- ascii [ peek1 peek1 = ] with-file-reader
-] unit-test
M: decoder stream-read1
dup >decoder< decode-char fix-read1 ;
-M: decoder stream-peek1 [ stream-read1 ] with-input-rewind ;
-M: decoder stream-peek [ stream-read ] with-input-rewind ;
-
: fix-read ( stream string -- string )
over cr>> [
over cr-
{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
-HELP: peek
-{ $values
- { "n" integer }
- { "seq/f" "a sequence or f" }
-}
-{ $description "Reads the next " { $snippet "n" } " elements from the stream and seeks the stream to before the read." } ;
-
-HELP: peek1
-{ $values
- { "elt" "an element or f" }
-}
-{ $description "Reads the next object from a stream and seeks the stream to before the read." } ;
-
-HELP: stream-peek
-{ $values
- { "n" integer } { "stream" "an input stream" }
- { "seq/f" "a sequence or f" }
-}
-{ $contract "Peeks " { $snippet "n" } " elements from the stream. Outputs " { $link f } " on stream exhaustion." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link peek } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: stream-peek1
-{ $values
- { "stream" "an input stream" }
- { "elt/f" "an element or f" }
-}
-{ $contract "Peeks an element from the stream. Outputs " { $link f } " on stream exhaustion." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link peek1 } "; see " { $link "stdio" } "." }
-$io-error ;
-
HELP: tell-input
{ $values
{ "n" integer }
}
{ $description "Returns the index of the stream stored in " { $link output-stream } "." } ;
-HELP: with-input-rewind
-{ $values
- { "quot" quotation }
-}
-{ $description "Records the current seek position of the stream and calls the quotation. The position is then reset after the call." } ;
-
-HELP: with-input-seek
-{ $values
- { "n" integer } { "seek-type" "a seek singleton" } { "quot" quotation }
-}
-{ $description "Seeks the stream to a location, calls " { $snippet "quot" } ", and resets the input stream to where it was before the quotation was called." } ;
-
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
{ $subsections "stream-types" }
"These words are required for binary and string input streams:"
{ $subsections
- stream-peek1
- stream-peek
stream-read1
stream-read
stream-read-until
$nl
"Words reading from the default input stream:"
{ $subsections
- peek1
- peek
read1
read
read-until
}
"Seeking on the default output stream:"
{ $subsections seek-output }
-"Seeking descriptors:"
-{ $subsections
- seek-absolute
- seek-relative
- seek-end
-}
-"Seeking combinators:"
-{ $subsections
- with-input-seek
- with-input-rewind
-}
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsections
with-output-stream
GENERIC: stream-element-type ( stream -- type )
-GENERIC: stream-peek1 ( stream -- elt/f )
-GENERIC: stream-peek ( n stream -- seq/f )
GENERIC: stream-read1 ( stream -- elt )
GENERIC: stream-read ( n stream -- seq )
GENERIC: stream-read-until ( seps stream -- seq sep/f )
SYMBOL: output-stream
SYMBOL: error-stream
-: peek1 ( -- elt ) input-stream get stream-peek1 ;
-: peek ( n -- seq/f ) input-stream get stream-peek ;
: readln ( -- str/f ) input-stream get stream-readln ;
: read1 ( -- elt ) input-stream get stream-read1 ;
: read ( n -- seq ) input-stream get stream-read ;
#! buffer before closing the FD.
swapd [ with-output-stream ] curry with-input-stream ; inline
-: with-input-seek ( n seek-type quot -- )
- tell-input [
- [ seek-input ] dip call
- ] dip seek-absolute seek-input ; inline
-
-: with-input-rewind ( quot -- )
- [ 0 seek-absolute ] dip with-input-seek ; inline
-
: print ( str -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 4 5 6 } ] [ binary [ B{ 1 2 3 } write B{ 4 5 6 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
-[ B{ 1 2 } ] [ B{ 1 2 3 4 } binary [ 2 peek ] with-byte-reader ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
M: byte-reader stream-element-type drop +byte+ ;
-M: byte-reader stream-peek1 sequence-peek1 ;
-M: byte-reader stream-peek sequence-peek ;
M: byte-reader stream-read-partial stream-read ;
M: byte-reader stream-read sequence-read ;
M: byte-reader stream-read1 sequence-read1 ;
int-array-cast
] unit-test
-[ t ] [
- "test.txt" temp-file "rb" fopen <c-reader> [
- 3 4 * [ peek ] [ peek ] bi =
- ] with-input-stream
-] unit-test
-
-[ t ] [
- "test.txt" temp-file "rb" fopen <c-reader> [
- peek1 peek1 =
- ] with-input-stream
-] unit-test
-
! Writing strings to binary streams should fail
[
"test.txt" temp-file "wb" fopen <c-writer> [
M: c-reader stream-read dup check-disposed handle>> fread ;
-M: c-reader stream-peek [ stream-read ] with-input-rewind ;
-
M: c-reader stream-read-partial stream-read ;
M: c-reader stream-read1 dup check-disposed handle>> fgetc ;
-M: c-reader stream-peek1 [ stream-read1 ] with-input-rewind ;
-
: read-until-loop ( stream delim -- ch )
over stream-read1 dup [
dup pick member-eq? [ 2nip ] [ , read-until-loop ] if
M: memory-stream stream-element-type drop +byte+ ;
-M: memory-stream stream-peek1
- [ alien>> ] [ index>> ] bi alien-unsigned-1 ;
-
M: memory-stream stream-read1
- [ stream-peek1 ]
+ [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1 + ] change-index drop ] bi ;
: next ( stream -- )
[ 1 + ] change-i drop ; inline
-: sequence-peek1 ( seq -- elt/f )
- [ i>> ] [ underlying>> ] bi ?nth ;
-
-: sequence-peek ( n seq -- elt/f )
- [ nip i>> dup ] [ [ + ] [ underlying>> ] bi* ] 2bi ?subseq ;
-
: sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ] [ next ] bi ; inline
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
[ V{ 3 4 } ] [ 2 4 1 10 dup iota <slice> subseq >vector ] unit-test
[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup iota <slice> <slice> subseq >vector ] unit-test
-
-[ "abc" ] [ 0 3 "abc" ?subseq ] unit-test
-[ "abc" ] [ 0 5 "abc" ?subseq ] unit-test
-[ "bc" ] [ 1 5 "abc" ?subseq ] unit-test
-[ "abc" ] [ -1 3 "abc" ?subseq ] unit-test
[ 0 10 "hello" <slice> ] must-fail
[ -10 3 "hello" <slice> ] must-fail
[ 2 1 "hello" <slice> ] must-fail
: subseq ( from to seq -- subseq )
[ check-slice subseq>copy (copy) ] keep like ;
-: ?subseq ( from to seq -- subseq )
- [
- [ 0 ] dip length [ clamp ] 2curry bi@
- 2dup > [ nip dup ] when
- ] keep subseq f like ;
-
: head ( seq n -- headseq ) (head) subseq ;
: tail ( seq n -- tailseq ) (tail) subseq ;
slots.syntax splitting system vectors vocabs.loader ;
IN: dns
+: with-temporary-input-seek ( n seek-type quot -- )
+ tell-input [
+ [ seek-input ] dip call
+ ] dip seek-absolute seek-input ; inline
+
ENUM: dns-type
{ A 1 } { NS 2 } { MD 3 } { MF 4 }
{ CNAME 5 } { SOA 6 } { MB 7 } { MG 8 }
CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
: ipv6>arpa ( string -- string )
- ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
+ ipv6>byte-array
+ [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
B{ } concat-as reverse
[ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
] B{ } map-as byte-array>ipv6 ;
-: parse-length-bytes ( -- sequence ) read1 read utf8 decode ;
+: parse-length-bytes ( byte -- sequence ) read utf8 decode ;
: (parse-name) ( -- )
- peek1 [
- read1 drop
- ] [
- HEX: C0 mask? [
- 2 read be> HEX: 3fff bitand
- seek-absolute [ parse-length-bytes , (parse-name) ] with-input-seek
+ read1 [
+ dup HEX: C0 mask? [
+ 8 shift read1 bitor HEX: 3fff bitand
+ seek-absolute [
+ read1 parse-length-bytes , (parse-name)
+ ] with-temporary-input-seek
] [
parse-length-bytes , (parse-name)
] if
- ] if-zero ;
+ ] unless-zero ;
: parse-name ( -- sequence )
[ (parse-name) ] { } make "." join ;
USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
io.binary io.buffers io.encodings.string io.encodings.utf8
-io.ports kernel make math math.bitwise namespaces sequences ;
+kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image