steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into native-image-loader

db4
Joe Groff 2010-07-11 08:27:29 -07:00
parent e228d8478f b04bc8640f
commit 3d9c1f9cd5
30 changed files with 330 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -103,6 +103,15 @@ cell 4 = [
[ [ 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

6
basis/cpu/x86/assembler/assembler.factor
View File

@ -554,6 +554,9 @@ PRIVATE>
: 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) ;
@ -771,6 +774,9 @@ ALIAS: PINSRQ PINSRD
: 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 )

12
basis/http/server/server.factor
View File

@ -14,6 +14,7 @@ io.encodings.ascii
io.encodings.binary
io.streams.limited
io.streams.string
io.streams.throwing
io.servers.connection
io.timeouts
io.crlf
@ -27,6 +28,7 @@ html.templates
html.streams
html
mime.types
math.order
xml.writer ;
FROM: mime.multipart => parse-multipart ;
IN: http.server
@ -52,12 +54,10 @@ SYMBOL: upload-limit
: 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 ;
@ -277,11 +277,11 @@ TUPLE: http-server < threaded-server ;
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

42
basis/images/bitmap/bitmap.factor
View File

@ -1,12 +1,10 @@
! 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
@ -350,20 +348,22 @@ ERROR: unsupported-bitmap-file magic ;
: 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 )

1
basis/images/bitmap/loading/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

7
basis/images/bitmap/loading/loading.factor
View File

@ -1,7 +0,0 @@
! 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 ;

43
basis/images/jpeg/jpeg.factor
View File

@ -1,15 +1,15 @@
! 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
@ -120,18 +120,18 @@ TUPLE: jpeg-color-info
] 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>>
@ -219,9 +219,6 @@ MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ;
: 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 ;
@ -369,7 +366,7 @@ ERROR: not-a-jpeg-image ;
[
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
unlimited-input contents <loading-jpeg>
contents <loading-jpeg>
] with-input-stream ;
PRIVATE>

19
basis/images/loader/loader.factor
View File

@ -1,9 +1,9 @@
! 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 ;
@ -18,7 +18,7 @@ types [ H{ } clone ] initialize
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
binary stream-throws <limited-file-reader> ;
binary <limited-file-reader> ;
PRIVATE>
@ -34,13 +34,10 @@ GENERIC: stream>image ( stream class -- image )
: 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 ;

4
basis/images/pbm/pbm.factor
View File

@ -3,7 +3,7 @@
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
@ -73,7 +73,7 @@ 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 {

4
basis/images/pgm/pgm.factor
View File

@ -2,7 +2,7 @@
! 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
@ -50,7 +50,7 @@ SINGLETON: pgm-image
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 {

12
basis/images/png/png.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays checksums checksums.crc32 combinators
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
@ -319,10 +319,12 @@ ERROR: invalid-color-type/bit-depth loading-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

4
basis/images/ppm/ppm.factor
View File

@ -2,7 +2,7 @@
! 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
@ -47,7 +47,7 @@ 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 {

4
basis/images/tga/tga.factor
View File

@ -3,7 +3,7 @@
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
@ -254,7 +254,7 @@ ERROR: bad-tga-unsupported ;
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

32
basis/images/tiff/tiff.factor
View File

@ -6,7 +6,7 @@ io.binary io.encodings.ascii io.encodings.binary
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
@ -519,14 +519,12 @@ ERROR: unknown-component-order ifd ;
: 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
@ -556,19 +554,13 @@ ERROR: unknown-component-order ifd ;
: 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

80
basis/io/streams/limited/limited-docs.factor
View File

@ -5,101 +5,43 @@ IN: io.streams.limited
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"

170
basis/io/streams/limited/limited-tests.factor
View File

@ -11,7 +11,7 @@ IN: io.streams.limited.tests
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
@ -21,197 +21,61 @@ IN: io.streams.limited.tests
[ "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
! 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
[ "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

81
basis/io/streams/limited/limited.factor
View File

@ -6,87 +6,52 @@ io.encodings io.files io.files.info kernel locals math
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> ;
: <limited-file-reader> ( path encoding -- stream' )
[ <file-reader> ]
[ drop file-info size>> ] 2bi
<limited-stream> ;
GENERIC# limit 2 ( stream limit mode -- stream' )
GENERIC# limit-stream 1 ( stream limit -- stream' )
M: decoder limit ( stream limit mode -- stream' )
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: decoder limit-stream ( stream limit -- stream' )
[ clone ] dip '[ _ limit-stream ] change-stream ;
M: object limit ( stream limit mode -- stream' )
over [ <limited-stream> ] [ 2drop ] if ;
M: object limit-stream ( stream limit -- stream' )
<limited-stream> ;
GENERIC: unlimited ( stream -- stream' )
: limited-input ( limit -- )
[ input-stream ] dip '[ _ limit-stream ] change ;
M: decoder unlimited ( stream -- stream' )
[ stream>> ] change-stream ;
M: object unlimited ( stream -- stream' )
stream>> ;
: limit-input ( limit mode -- )
[ input-stream ] 2dip '[ _ _ limit ] 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 )
@ -124,7 +89,11 @@ M: limited-stream stream-read-partial
: (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 {

1
basis/io/streams/throwing/asdf.txt Normal file
View File

@ -0,0 +1 @@
asdf

1
basis/io/streams/throwing/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

63
basis/io/streams/throwing/throwing-tests.factor Normal file
View File

@ -0,0 +1,63 @@
! 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

47
basis/io/streams/throwing/throwing.factor Normal file
View File

@ -0,0 +1,47 @@
! 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

2
basis/timers/timers.factor
View File

@ -84,7 +84,7 @@ PRIVATE>
: start-timer ( timer -- )
[
'[ _ timer-loop ] "Alarm execution" spawn
'[ _ timer-loop ] "Timer execution" spawn
] keep thread<< ;
: stop-timer ( timer -- )

8
core/io/encodings/encodings-tests.factor
View File

@ -1,7 +1,7 @@
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 ]

3
core/io/io.factor
View File

@ -101,9 +101,6 @@ SYMBOL: error-stream
: 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 -- )

2
core/parser/parser-tests.factor
View File

@ -101,7 +101,7 @@ DEFER: foo
! 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

8
extra/images/gif/gif.factor
View File

@ -1,11 +1,9 @@
! 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

12
extra/roles/roles-docs.factor
View File

@ -46,3 +46,15 @@ HELP: multiple-inheritance-attempted
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"

15
extra/variants/variants-docs.factor
View File

@ -13,7 +13,7 @@ VARIANT: class-name
.
.
; """ }
{ $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
@ -24,6 +24,18 @@ VARIANT: list
;
""" } } ;
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." }
@ -58,6 +70,7 @@ ARTICLE: "variants" "Algebraic data types"
"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
} ;

18
extra/variants/variants-tests.factor
View File

@ -19,3 +19,21 @@ VARIANT: list
[ 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

19
extra/variants/variants.factor
View File

@ -18,9 +18,15 @@ M: variant-class initial-value*
: 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
@ -38,7 +44,12 @@ M: variant-class initial-value*
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] ;