Merge branch 'master' into native-image-loader
Joe Groff
commit
3d9c1f9cd5
basis
cpu/x86/assembler
http/server
images
bitmap
jpeg
loader
pbm
pgm
png
ppm
tga
tiff
timers
core
io
encodings
parser
extra
images/gif
roles
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
asdf
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -84,7 +84,7 @@ PRIVATE>
|
|||
|
||||
: start-timer ( timer -- )
|
||||
[
|
||||
'[ _ timer-loop ] "Alarm execution" spawn
|
||||
'[ _ timer-loop ] "Timer execution" spawn
|
||||
] keep thread<< ;
|
||||
|
||||
: stop-timer ( timer -- )
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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] ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue