[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail
[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 RAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 EAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 7e HEX: c8 } ] [ [ RAX XMM1 MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 7e HEX: c8 } ] [ [ EAX XMM1 MOVD ] { } make ] unit-test
+
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: ca } ] [ [ XMM1 XMM2 MOVQ ] { } make ] unit-test
+
! rm-r only sse instructions
[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
+: 2-operand-rm-mr-sse* ( dst src op12{rm,mr} -- )
+ direction-op-sse first2 [ , ] when* extended-opcode (2-operand) ;
+
: 2-operand-rm-sse ( dst src op1 op2 -- )
[ , ] when* extended-opcode (2-operand) ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
+: MOVQ ( dest src -- )
+ { { HEX: 7e HEX: f3 } { HEX: d6 HEX: 66 } } 2-operand-rm-mr-sse* ;
+
<PRIVATE
: 2shuffler ( indexes/mask -- mask )
io.encodings.binary
io.streams.limited
io.streams.string
+io.streams.throwing
io.servers.connection
io.timeouts
io.crlf
html.streams
html
mime.types
+math.order
xml.writer ;
FROM: mime.multipart => parse-multipart ;
IN: http.server
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
- unlimited-input
- upload-limit get stream-throws limit-input
- stream-eofs limit-input
+ upload-limit get min limited-input
binary decode-input
parse-multipart-form-data parse-multipart ;
-
+
: read-content ( request -- bytes )
"content-length" header string>number read ;
SYMBOL: request-limit
-64 1024 * request-limit set-global
+request-limit [ 64 1024 * ] initialize
M: http-server handle-client*
drop [
- request-limit get stream-throws limit-input
+ request-limit get limited-input
?refresh-all
[ read-request ] ?benchmark
[ do-request ] ?benchmark
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators compression.run-length endian fry grouping images
-images.loader images.normalization io io.binary
-io.encodings.8-bit.latin1 io.encodings.binary
-io.encodings.string io.files io.streams.limited kernel locals
-macros math math.bitwise math.functions namespaces sequences
-specialized-arrays summary ;
+USING: accessors alien.c-types arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader
+images.normalization io io.binary io.encodings.8-bit.latin1
+io.encodings.string kernel math math.bitwise sequences
+specialized-arrays summary io.streams.throwing ;
QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAYS: uint ushort ;
IN: images.bitmap
: load-bitmap ( stream -- loading-bitmap )
[
- \ loading-bitmap new
- parse-file-header [ >>file-header ] [ ] bi magic>> {
- { "BM" [
- dup file-header>> header-length>> parse-header >>header
- parse-color-palette
- parse-color-data
- ] }
- ! { "BA" [ parse-os2-bitmap-array ] }
- ! { "CI" [ parse-os2-color-icon ] }
- ! { "CP" [ parse-os2-color-pointer ] }
- ! { "IC" [ parse-os2-icon ] }
- ! { "PT" [ parse-os2-pointer ] }
- [ unsupported-bitmap-file ]
- } case
+ [
+ \ loading-bitmap new
+ parse-file-header [ >>file-header ] [ ] bi magic>> {
+ { "BM" [
+ dup file-header>> header-length>> parse-header >>header
+ parse-color-palette
+ parse-color-data
+ ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] throw-on-eof
] with-input-stream ;
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays byte-arrays combinators
-compression.run-length fry grouping images images.loader io
-io.binary io.encodings.binary
-io.encodings.string io.streams.limited kernel math math.bitwise
-io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images fry
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader io.streams.limited ;
-IN: images.jpeg
-
+compression.huffman fry grouping images images.loader
+images.processing io io.binary io.encodings.binary
+io.streams.byte-array io.streams.limited io.streams.throwing
+kernel locals math math.bitwise math.blas.matrices
+math.blas.vectors math.constants math.functions math.matrices
+math.order math.vectors memoize namespaces sequences
+sequences.deep ;
QUALIFIED-WITH: bitstreams bs
+IN: images.jpeg
SINGLETON: jpeg-image
] with-byte-reader ;
: decode-huff-table ( chunk -- )
- data>> [ binary <byte-reader> ] [ length ] bi
- stream-throws limit
- [
- [ input-stream get [ count>> ] [ limit>> ] bi < ]
+ data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
[
- read4/4 swap 2 * +
- 16 read
- dup [ ] [ + ] map-reduce read
- binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
- swap jpeg> huff-tables>> set-nth
- ] while
- ] with-input-stream* ;
+ [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
+ [
+ read4/4 swap 2 * +
+ 16 read
+ dup [ ] [ + ] map-reduce read
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+ swap jpeg> huff-tables>> set-nth
+ ] while
+ ] with-input-stream*
+ ] stream-throw-on-eof ;
: decode-scan ( chunk -- )
data>>
: idct-factor ( b -- b' ) dct-matrix v.m ;
-USE: math.blas.vectors
-USE: math.blas.matrices
-
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
[
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
- unlimited-input contents <loading-jpeg>
+ contents <loading-jpeg>
] with-input-stream ;
PRIVATE>
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays combinators images
-io.encodings.binary io.files io.pathnames io.streams.byte-array
-io.streams.limited kernel namespaces sequences splitting
-strings unicode.case ;
+USING: assocs byte-arrays io.encodings.binary io.files
+io.pathnames io.streams.byte-array io.streams.limited
+io.streams.throwing kernel namespaces sequences strings
+unicode.case fry ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
- binary stream-throws <limited-file-reader> ;
+ binary <limited-file-reader> ;
PRIVATE>
: load-image ( path -- image )
[ open-image-file ] [ image-class ] bi load-image* ;
-M: byte-array load-image*
- [
- [ binary <byte-reader> ]
- [ length stream-throws <limited-stream> ] bi
- ] dip stream>image ;
+M: object load-image* stream>image ;
-M: limited-stream load-image* stream>image ;
+M: byte-array load-image*
+ [ binary <byte-reader> ] dip stream>image ;
M: string load-image* [ open-image-file ] dip stream>image ;
USING: accessors arrays ascii bit-arrays byte-arrays combinators
continuations grouping images images.loader io io.encodings.ascii
io.encodings.string kernel locals make math math.functions math.parser
-sequences ;
+sequences io.streams.throwing ;
IN: images.pbm
SINGLETON: pbm-image
PRIVATE>
M: pbm-image stream>image
- drop [ read-pbm ] with-input-stream ;
+ drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
M: pbm-image image>stream
drop {
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types ascii combinators images images.loader
io io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences specialized-arrays ;
+math.parser sequences specialized-arrays io.streams.throwing ;
SPECIALIZED-ARRAY: ushort
IN: images.pgm
wide [ ushort-components ] [ ubyte-components ] if >>component-type ;
M: pgm-image stream>image
- drop [ read-pgm ] with-input-stream ;
+ drop [ [ read-pgm ] throw-on-eof ] with-input-stream ;
M: pgm-image image>stream
drop {
compression.inflate fry grouping images images.loader io
io.binary io.encodings.ascii io.encodings.string kernel locals
math math.bitwise math.ranges sequences sorting assocs
-math.functions math.order byte-arrays ;
+math.functions math.order byte-arrays io.streams.throwing ;
QUALIFIED-WITH: bitstreams bs
IN: images.png
: load-png ( stream -- loading-png )
[
- <loading-png>
- read-png-header
- read-png-chunks
- parse-ihdr-chunk
+ [
+ <loading-png>
+ read-png-header
+ read-png-chunks
+ parse-ihdr-chunk
+ ] throw-on-eof
] with-input-stream ;
M: png-image stream>image
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii combinators images images.loader io
io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences ;
+math.parser sequences io.streams.throwing ;
IN: images.ppm
SINGLETON: ppm-image
ubyte-components >>component-type ;
M: ppm-image stream>image
- drop [ read-ppm ] with-input-stream ;
+ drop [ [ read-ppm ] throw-on-eof ] with-input-stream ;
M: ppm-image image>stream
drop {
USING: accessors images images.loader io io.binary kernel
locals math sequences io.encodings.ascii io.encodings.string
calendar math.ranges math.parser colors arrays hashtables
-ui.pixel-formats combinators continuations ;
+ui.pixel-formats combinators continuations io.streams.throwing ;
IN: images.tga
SINGLETON: tga-image
ubyte-components >>component-type ;
M: tga-image stream>image
- drop [ read-tga ] with-input-stream ;
+ drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
M: tga-image image>stream
drop
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack sequences
strings math.vectors specialized-arrays locals
-images.loader ;
+images.loader io.streams.throwing ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: images.tiff
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
-: load-tiff-ifds ( stream -- loading-tiff )
- [
- <loading-tiff>
- read-header [
- dup ifd-offset>> read-ifds
- process-ifds
- ] with-tiff-endianness
- ] with-input-stream* ;
+: load-tiff-ifds ( -- loading-tiff )
+ <loading-tiff>
+ read-header [
+ dup ifd-offset>> read-ifds
+ process-ifds
+ ] with-tiff-endianness ;
: process-chunky-ifd ( ifd -- )
read-strips
: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
-: load-tiff ( stream -- loading-tiff )
- [ load-tiff-ifds dup ]
- [
- [ [ 0 seek-absolute ] dip stream-seek ]
- [
- [
- [ process-tif-ifds ] with-tiff-endianness
- ] with-input-stream
- ] bi
- ] bi ;
+: load-tiff ( -- loading-tiff )
+ load-tiff-ifds dup
+ 0 seek-absolute seek-input
+ [ process-tif-ifds ] with-tiff-endianness ;
! tiff files can store several images -- we just take the first for now
M: tiff-image stream>image ( stream tiff-image -- image )
- drop load-tiff tiff>image ;
+ drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "an input stream" }
}
-{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit-stream } " or " { $link limited-input } "." } ;
-HELP: limit
+HELP: limit-stream
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
-{ $examples "Throwing an exception:"
- { $example
- "USING: continuations io io.streams.limited io.streams.string"
- "kernel prettyprint ;"
- "["
- " \"123456\" <string-reader> 3 stream-throws limit"
- " 100 swap stream-read ."
- "] [ ] recover ."
-"""T{ limit-exceeded
- { n 1 }
- { stream
- T{ limited-stream
- { stream
- T{ string-reader
- { underlying "123456" }
- { i 3 }
- }
- }
- { mode stream-throws }
- { count 4 }
- { limit 3 }
- }
- }
-}"""
- }
- "Returning " { $link f } " on exhaustion:"
+{ $examples
+ "Limiting a longer stream to length three:"
{ $example
"USING: accessors continuations io io.streams.limited"
"io.streams.string kernel prettyprint ;"
- "\"123456\" <string-reader> 3 stream-eofs limit"
+ "\"123456\" <string-reader> 3 limit-stream"
"100 swap stream-read ."
"\"123\""
}
} ;
-HELP: unlimited
-{ $values
- { "stream" "an input stream" }
- { "stream'" "a stream" }
-}
-{ $description "Returns the underlying stream of a limited stream." } ;
-
HELP: limited-stream
{ $values
{ "value" "a limited-stream class" }
}
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
-HELP: limit-input
-{ $values
- { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
-}
+HELP: limited-input
+{ $values { "limit" integer } }
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
-HELP: unlimited-input
-{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
-
-HELP: stream-eofs
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
-
-HELP: stream-throws
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
-
-{ stream-eofs stream-throws } related-words
-
ARTICLE: "io.streams.limited" "Limited input streams"
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl
"Wrap a stream in a limited stream:"
-{ $subsections limit }
+{ $subsections limited-stream }
"Wrap the current " { $link input-stream } " in a limited stream:"
-{ $subsections limit-input }
-"Unlimits a limited stream:"
-{ $subsections unlimited }
-"Unlimits the current " { $link input-stream } ":"
-{ $subsections unlimited-input }
-"Make a limited stream throw an exception on exhaustion:"
-{ $subsections stream-throws }
-"Make a limited stream return " { $link f } " on exhaustion:"
-{ $subsections stream-eofs } ;
+{ $subsections limited-input } ;
ABOUT: "io.streams.limited"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
-[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
+[ "are you " ] [ "decoded" get stream-readln ] unit-test
+
+[ f ] [ "decoded" get stream-readln ] unit-test
+
[ ] [
"abc\ndef\nghi"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 4 <limited-stream> "limited" set ] unit-test
-[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
+[ "abc" CHAR: \n ]
+[ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+[ "" f ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "he" CHAR: l ] [
- B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
- ascii <byte-reader> [
- 5 stream-throws limit-input
- "l" read-until
- ] with-input-stream
-] unit-test
[ CHAR: a ]
-[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
+[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
[ "abc" ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 swap stream-read
] unit-test
[ f ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 over stream-read drop 10 swap stream-read
] unit-test
-[ t ]
-[
- "abc" <string-reader> 3 stream-eofs limit unlimited
- "abc" <string-reader> =
-] unit-test
-
-[ t ]
-[
- "abc" <string-reader> 3 stream-eofs limit unlimited
- "abc" <string-reader> =
-] unit-test
-
-[ t ]
-[
- [
- "resource:license.txt" utf8 <file-reader> &dispose
- 3 stream-eofs limit unlimited
- "resource:license.txt" utf8 <file-reader> &dispose
- [ decoder? ] both?
- ] with-destructors
-] unit-test
-
-[ "HELL" ] [
- "HELLO"
- [ f stream-throws limit-input 4 read ]
- with-string-reader
-] unit-test
-
-
-[ "asdf" ] [
- "asdf" <string-reader> 2 stream-eofs <limited-stream> [
- unlimited-input contents
- ] with-input-stream
-] unit-test
-
-[ 4 ] [
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input tell-input
- ] with-input-stream
-] unit-test
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- 4 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- -2 seek-relative
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- -2 seek-relative seek-input
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-absolute seek-input
- 2 stream-throws limit-input
- 2 seek-absolute seek-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-! stream-throws, pipes are duplex and not seekable
-[ "as" ] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 2 swap stream-read
-] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 3 swap stream-read
-] [
- limit-exceeded?
-] must-fail-with
-
-! stream-eofs, pipes are duplex and not seekable
+! pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
! test seeking on limited unseekable streams
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- 2 seek-absolute rot in>> stream-seek
-] must-fail
-
-[
- "as"
-] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover
- 2 swap stream-read
-] unit-test
-
-[ 7 ] [
- image binary stream-throws <limited-file-reader> [
- 7 read drop
- tell-input
- ] with-input-stream
-] unit-test
-
-[ 70000 ] [
- image binary stream-throws <limited-file-reader> [
- 70000 read drop
- tell-input
- ] with-input-stream
-] unit-test
namespaces sequences ;
IN: io.streams.limited
-TUPLE: limited-stream
- stream mode
- count limit
- current start stop ;
+TUPLE: limited-stream stream count limit current start stop ;
-SINGLETONS: stream-throws stream-eofs ;
-
-: <limited-stream> ( stream limit mode -- stream' )
+: <limited-stream> ( stream limit -- stream' )
limited-stream new
- swap >>mode
swap >>limit
swap >>stream
0 >>count ;
-: <limited-file-reader> ( path encoding mode -- stream' )
- [
- [ <file-reader> ]
- [ drop file-info size>> ] 2bi
- ] dip <limited-stream> ;
-
-GENERIC# limit 2 ( stream limit mode -- stream' )
-
-M: decoder limit ( stream limit mode -- stream' )
- [ clone ] 2dip '[ _ _ limit ] change-stream ;
-
-M: object limit ( stream limit mode -- stream' )
- over [ <limited-stream> ] [ 2drop ] if ;
+: <limited-file-reader> ( path encoding -- stream' )
+ [ <file-reader> ]
+ [ drop file-info size>> ] 2bi
+ <limited-stream> ;
-GENERIC: unlimited ( stream -- stream' )
+GENERIC# limit-stream 1 ( stream limit -- stream' )
-M: decoder unlimited ( stream -- stream' )
- [ stream>> ] change-stream ;
+M: decoder limit-stream ( stream limit -- stream' )
+ [ clone ] dip '[ _ limit-stream ] change-stream ;
-M: object unlimited ( stream -- stream' )
- stream>> ;
+M: object limit-stream ( stream limit -- stream' )
+ <limited-stream> ;
-: limit-input ( limit mode -- )
- [ input-stream ] 2dip '[ _ _ limit ] change ;
+: limited-input ( limit -- )
+ [ input-stream ] dip '[ _ limit-stream ] change ;
-: unlimited-input ( -- )
- input-stream [ unlimited ] change ;
-
-: with-unlimited-stream ( stream quot -- )
- [ clone unlimited ] dip call ; inline
-
-: with-limited-stream ( stream limit mode quot -- )
- [ limit ] dip call ; inline
+: with-limited-stream ( stream limit quot -- )
+ [ limit-stream ] dip call ; inline
ERROR: limit-exceeded n stream ;
-ERROR: bad-stream-mode mode ;
-
<PRIVATE
: adjust-current-limit ( n stream -- n' stream )
2dup [ + ] change-current
[ current>> ] [ stop>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ current>> ] [ stop>> ] bi -
- '[ _ - ] dip
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ current>> ] [ stop>> ] bi -
+ '[ _ - ] dip
] when ; inline
: adjust-count-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ count>> ] [ limit>> ] bi -
- '[ _ - ] dip
- dup limit>> >>count
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ count>> ] [ limit>> ] bi -
+ '[ _ - ] dip
+ dup limit>> >>count
] when ; inline
: check-count-bounds ( n stream -- n stream )
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip member-eq? ] dip
- swap [ drop ] [ push (read-until) ] if ;
+ swap [
+ drop
+ ] [
+ over [ push (read-until) ] [ drop ] if
+ ] if ;
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.encodings.utf8 io.files io.streams.string
+io.streams.throwing kernel tools.test destructors ;
+IN: io.streams.throwing.tests
+
+[ "asdf" ]
+[
+ "asdf" [ [ 6 read-partial ] throw-on-eof ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ 4 read read1 ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[
+ [
+ "asdf" <string-reader> &dispose [
+ [ 4 swap stream-read ]
+ [ stream-read1 ] bi
+ ] stream-throw-on-eof
+ ] with-destructors
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" [ [ 5 read ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" [ [ 4 read 4 read ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ "as" "df" ] [
+ "asdf" [ [ 2 read ] throw-on-eof 3 read ] with-string-reader
+] unit-test
+
+[ "as" "df\n" ] [
+ "vocab:io/streams/throwing/asdf.txt" utf8 [
+ [ 2 read ] throw-on-eof 20 read
+ ] with-file-reader
+] unit-test
+
+[ "asdf" "asdf" ] [
+ "asdf" [
+ [ 4 read 0 seek-absolute seek-input 4 read ] throw-on-eof
+ ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ 1 seek-absolute seek-input 4 read drop ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ "asd" CHAR: f ] [
+ "asdf" [ [ "f" read-until ] throw-on-eof ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ "g" read-until ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ 1 ] [
+ "asdf" [ [ 1 seek-absolute seek-input tell-input ] throw-on-eof ] with-string-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors io kernel locals namespaces
+sequences fry ;
+IN: io.streams.throwing
+
+ERROR: stream-exhausted n stream word ;
+
+<PRIVATE
+
+TUPLE: throws-on-eof-stream stream ;
+
+C: <throws-on-eof-stream> throws-on-eof-stream
+
+M: throws-on-eof-stream stream-element-type stream>> stream-element-type ;
+
+M: throws-on-eof-stream dispose stream>> dispose ;
+
+M:: throws-on-eof-stream stream-read1 ( stream -- obj )
+ stream stream>> stream-read1
+ [ 1 stream \ read1 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-read-partial ( n stream -- seq )
+ n stream stream>> stream-read-partial
+ [ n stream \ read-partial stream-exhausted ] unless* ;
+
+M: throws-on-eof-stream stream-tell
+ stream>> stream-tell ;
+
+M: throws-on-eof-stream stream-seek
+ stream>> stream-seek ;
+
+M: throws-on-eof-stream stream-read-until
+ [ stream>> stream-read-until ]
+ [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ;
+
+PRIVATE>
+
+: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b )
+ [ <throws-on-eof-stream> ] dip call ; inline
+
+: throw-on-eof ( ..a quot: ( ..a -- ..b ) -- ..b )
+ [ input-stream get <throws-on-eof-stream> ] dip with-input-stream* ; inline
: start-timer ( timer -- )
[
- '[ _ timer-loop ] "Alarm execution" spawn
+ '[ _ timer-loop ] "Timer execution" spawn
] keep thread<< ;
: stop-timer ( timer -- )
-USING: io.files io.streams.string io io.streams.byte-array
-tools.test kernel io.encodings.ascii io.encodings.utf8
-namespaces accessors io.encodings io.streams.limited ;
-IN: io.streams.encodings.tests
+USING: accessors io io.encodings io.encodings.ascii
+io.encodings.utf8 io.files io.streams.byte-array
+io.streams.string kernel namespaces tools.test ;
+IN: io.encodings.tests
[ { } ]
[ "vocab:io/test/empty-file.txt" ascii file-lines ]
: stream-element-exemplar ( stream -- exemplar )
stream-element-type (stream-element-exemplar) ; inline
-: element-exemplar ( -- exemplar )
- input-stream get stream-element-exemplar ; inline
-
PRIVATE>
: each-stream-line ( stream quot -- )
! parse-tokens should do the right thing on EOF
[ "USING: kernel" eval( -- ) ]
-[ error>> T{ unexpected { want ";" } } = ] must-fail-with
+[ error>> T{ unexpected { want "token" } } = ] must-fail-with
! Test smudging
! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators compression.lzw
+USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
-io.binary io.buffers io.encodings.binary io.encodings.string
-io.encodings.utf8 io.files io.files.info io.ports
-io.streams.limited kernel make math math.bitwise math.functions
-multiline namespaces prettyprint sequences ;
+io.binary io.buffers io.encodings.string io.encodings.utf8
+io.ports kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image
HELP: role-slot-overlap
{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+ARTICLE: "roles" "Roles"
+"The " { $vocab-link "roles" } " vocabulary provides a form of tuple interface that can be implemented by concrete tuple classes. A " { $link role } " definition is a mixin class that also prescribes a set of tuple slots. Roles are not tuple classes by themselves and cannot be instantiated by " { $link new } ". The vocabulary extends " { $link POSTPONE: TUPLE: } " syntax to allow concrete tuple types to declare membership to one or more roles, automatically including their prescribed slots." $nl
+"The role superclass:"
+{ $subsections role }
+"Syntax for making a new role:"
+{ $subsection POSTPONE: ROLE: }
+"Syntax for making tuples that use roles:"
+{ $subsection POSTPONE: TUPLE: }
+"Errors with roles:"
+{ $subsections multiple-inheritance-attempted role-slot-overlap } ;
+
+ABOUT: "roles"
.
.
; """ }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
;
""" } } ;
+HELP: VARIANT-MEMBER:
+{ $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." }
+{ $examples { $code """
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list ;
+
+VARIANT-MEMBER: list nil
+VARIANT-MEMBER: list cons: { { first object } { rest list } }
+""" } } ;
+
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
{ $subsections
POSTPONE: VARIANT:
+ POSTPONE: VARIANT-MEMBER:
variant-class
match
} ;
[ 4 ]
[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
+
+
+VARIANT: list2 ;
+VARIANT-MEMBER: list2 nil2
+VARIANT-MEMBER: list2 cons2: { { first object } { rest list2 } }
+
+[ t ] [ nil2 list2? ] unit-test
+[ t ] [ 1 nil2 <cons2> list2? ] unit-test
+[ f ] [ 1 list2? ] unit-test
+
+: list2-length ( list2 -- length )
+ {
+ { nil2 [ 0 ] }
+ { cons2 [ nip list2-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil2 <cons2> <cons2> <cons2> <cons2> list2-length ] unit-test
: define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
-: define-variant-class ( class members -- )
- [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
- [ define-variant-member swap add-mixin-instance ] with each ;
+: define-variant-class ( class -- )
+ [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
+
+: define-variant-class-member ( class member -- )
+ define-variant-member swap add-mixin-instance ;
+
+: define-variant-class-members ( class members -- )
+ [ dup define-variant-class ] dip
+ [ define-variant-class-member ] with each ;
: parse-variant-tuple-member ( name -- member )
create-class-in tuple
SYNTAX: VARIANT:
CREATE-CLASS
parse-variant-members
- define-variant-class ;
+ define-variant-class-members ;
+
+SYNTAX: VARIANT-MEMBER:
+ scan-word
+ scan parse-variant-member
+ define-variant-class-member ;
MACRO: unboa ( class -- )
<wrapper> \ boa [ ] 2sequence [undo] ;
projects / factor.git / commitdiff