Merge branch 'master' into native-image-loader

basis/cpu/x86/assembler/assembler-tests.factor

@@ -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

basis/cpu/x86/assembler/assembler.factor

@@ -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 )

basis/http/server/server.factor

@@ -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,9 +54,7 @@ SYMBOL: upload-limit
 : read-multipart-data ( request -- mime-parts )
     [ "content-type" header ]
     [ "content-length" header string>number ] bi
-    unlimited-input
+    upload-limit get min limited-input
-    upload-limit get stream-throws limit-input
-    stream-eofs limit-input
     binary decode-input
     parse-multipart-form-data parse-multipart ;
  
@@ -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

basis/images/bitmap/bitmap.factor

@@ -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
+USING: accessors alien.c-types arrays byte-arrays combinators
-combinators compression.run-length endian fry grouping images
+compression.run-length fry grouping images images.loader
-images.loader images.normalization io io.binary
+images.normalization io io.binary io.encodings.8-bit.latin1
-io.encodings.8-bit.latin1 io.encodings.binary
+io.encodings.string kernel math math.bitwise sequences
-io.encodings.string io.files io.streams.limited kernel locals
+specialized-arrays summary io.streams.throwing ;
-macros math math.bitwise math.functions namespaces sequences
-specialized-arrays summary ;
 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>> {
+            \ loading-bitmap new
-            { "BM" [
+            parse-file-header [ >>file-header ] [ ] bi magic>> {
-                dup file-header>> header-length>> parse-header >>header
+                { "BM" [
-                parse-color-palette
+                    dup file-header>> header-length>> parse-header >>header
-                parse-color-data
+                    parse-color-palette
-            ] }
+                    parse-color-data
-            ! { "BA" [ parse-os2-bitmap-array ] }
+                ] }
-            ! { "CI" [ parse-os2-color-icon ] }
+                ! { "BA" [ parse-os2-bitmap-array ] }
-            ! { "CP" [ parse-os2-color-pointer ] }
+                ! { "CI" [ parse-os2-color-icon ] }
-            ! { "IC" [ parse-os2-icon ] }
+                ! { "CP" [ parse-os2-color-pointer ] }
-            ! { "PT" [ parse-os2-pointer ] }
+                ! { "IC" [ parse-os2-icon ] }
-            [ unsupported-bitmap-file ]
+                ! { "PT" [ parse-os2-pointer ] }
-        } case
+                [ unsupported-bitmap-file ]
+            } case
+        ] throw-on-eof
     ] with-input-stream ;
 
 : loading-bitmap>bytes ( loading-bitmap -- byte-array )

basis/images/bitmap/loading/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

basis/images/bitmap/loading/loading.factor

@@ -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 ;

basis/images/jpeg/jpeg.factor

@@ -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
+compression.huffman fry grouping images images.loader
-images.processing io io.binary io.encodings.binary io.files
+images.processing io io.binary io.encodings.binary
-io.streams.byte-array kernel locals math math.bitwise
+io.streams.byte-array io.streams.limited io.streams.throwing
-math.constants math.functions math.matrices math.order
+kernel locals math math.bitwise math.blas.matrices
-math.ranges math.vectors memoize multiline namespaces
+math.blas.vectors math.constants math.functions math.matrices
-sequences sequences.deep images.loader io.streams.limited ;
+math.order math.vectors memoize namespaces sequences
-IN: images.jpeg
+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
+    data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
-    stream-throws limit
-    [   
-        [ input-stream get [ count>> ] [ limit>> ] bi < ]
         [
-            read4/4 swap 2 * +
+            [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
-            16 read
+            [
-            dup [ ] [ + ] map-reduce read
+                read4/4 swap 2 * +
-            binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+                16 read
-            swap jpeg> huff-tables>> set-nth
+                dup [ ] [ + ] map-reduce read
-        ] while
+                binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
-    ] with-input-stream* ;
+                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>

basis/images/loader/loader.factor

@@ -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
+USING: assocs byte-arrays io.encodings.binary io.files
-io.encodings.binary io.files io.pathnames io.streams.byte-array
+io.pathnames io.streams.byte-array io.streams.limited
-io.streams.limited kernel namespaces sequences splitting
+io.streams.throwing kernel namespaces sequences strings
-strings unicode.case ;
+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*
+M: object load-image* stream>image ;
-    [
-        [ binary <byte-reader> ]
-        [ length stream-throws <limited-stream> ] bi
-    ] dip 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 ;
 

basis/images/pbm/pbm.factor

@@ -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 {

basis/images/pgm/pgm.factor

@@ -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 {

basis/images/png/png.factor

@@ -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
+            <loading-png>
-        read-png-chunks
+            read-png-header
-        parse-ihdr-chunk
+            read-png-chunks
+            parse-ihdr-chunk
+        ] throw-on-eof
     ] with-input-stream ;
 
 M: png-image stream>image

basis/images/ppm/ppm.factor

@@ -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 {

basis/images/tga/tga.factor

@@ -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

basis/images/tiff/tiff.factor

@@ -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 )
+: load-tiff-ifds ( -- loading-tiff )
-    [
+    <loading-tiff>
-        <loading-tiff>
+    read-header [
-        read-header [
+        dup ifd-offset>> read-ifds
-            dup ifd-offset>> read-ifds
+        process-ifds
-            process-ifds
+    ] with-tiff-endianness ;
-        ] with-tiff-endianness
-    ] with-input-stream* ;
 
 : 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 ( -- loading-tiff )
-    [ load-tiff-ifds dup ]
+    load-tiff-ifds dup
-    [
+    0 seek-absolute seek-input
-        [ [ 0 seek-absolute ] dip stream-seek ]
+    [ process-tif-ifds ] with-tiff-endianness ;
-        [
-            [
-                [ process-tif-ifds ] with-tiff-endianness
-            ] with-input-stream
-        ] bi
-    ] bi ;
 
 ! 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

basis/io/streams/limited/limited-docs.factor

@@ -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:"
+{ $examples
-    { $example
+    "Limiting a longer stream to length three:"
-        "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:"
     { $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
+HELP: limited-input
-{ $values
+{ $values { "limit" integer } }
-     { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
-}
 { $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 }
+{ $subsections limited-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 } ;
 
 ABOUT: "io.streams.limited"

basis/io/streams/limited/limited-tests.factor

@@ -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 ]
+! pipes are duplex and not seekable
-[
-    "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
+    latin1 <pipe> [ 2 <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
     "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

basis/io/streams/limited/limited.factor

@@ -6,87 +6,52 @@ io.encodings io.files io.files.info kernel locals math
 namespaces sequences ;
 IN: io.streams.limited
 
-TUPLE: limited-stream
+TUPLE: limited-stream stream count limit current start stop ;
-    stream mode
-    count limit
-    current start stop ;
 
-SINGLETONS: stream-throws stream-eofs ;
+: <limited-stream> ( stream limit -- stream' )
-
-: <limited-stream> ( stream limit mode -- stream' )
     limited-stream new
-        swap >>mode
         swap >>limit
         swap >>stream
         0 >>count ;
 
-: <limited-file-reader> ( path encoding mode -- stream' )
+: <limited-file-reader> ( path encoding -- stream' )
-    [
+    [ <file-reader> ]
-        [ <file-reader> ]
+    [ drop file-info size>> ] 2bi
-        [ drop file-info size>> ] 2bi
+    <limited-stream> ;
-    ] dip <limited-stream> ;
 
-GENERIC# limit 2 ( stream limit mode -- stream' )
+GENERIC# limit-stream 1 ( stream limit -- stream' )
 
-M: decoder limit ( stream limit mode -- stream' )
+M: decoder limit-stream ( stream limit -- stream' )
-    [ clone ] 2dip '[ _ _ limit ] change-stream ;
+    [ clone ] dip '[ _ limit-stream ] change-stream ;
 
-M: object limit ( stream limit mode -- stream' )
+M: object limit-stream ( stream limit -- stream' )
-    over [ <limited-stream> ] [ 2drop ] if ;
+    <limited-stream> ;
 
-GENERIC: unlimited ( stream -- stream' )
+: limited-input ( limit -- )
+    [ input-stream ] dip '[ _ limit-stream ] change ;
 
-M: decoder unlimited ( stream -- stream' )
+: with-limited-stream ( stream limit quot -- )
-    [ stream>> ] change-stream ;
+    [ limit-stream ] dip call ; inline
-
-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
 
 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>> {
+        dup [ current>> ] [ stop>> ] bi -
-            { stream-throws [ limit-exceeded ] }
+        '[ _ - ] dip
-            { stream-eofs [ 
-                dup [ current>> ] [ stop>> ] bi -
-                '[ _ - ] dip
-            ] }
-            [ bad-stream-mode ]
-        } case
     ] when ; inline
 
 : adjust-count-limit ( n stream -- n' stream )
     2dup [ + ] change-count
     [ count>> ] [ limit>> ] bi >
     [
-        dup mode>> {
+        dup [ count>> ] [ limit>> ] bi -
-            { stream-throws [ limit-exceeded ] }
+        '[ _ - ] dip
-            { stream-eofs [ 
+        dup limit>> >>count
-                dup [ count>> ] [ limit>> ] bi -
-                '[ _ - ] dip
-                dup limit>> >>count
-            ] }
-            [ bad-stream-mode ]
-        } case
     ] 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 {

basis/io/streams/throwing/asdf.txt

@@ -0,0 +1 @@
+asdf

basis/io/streams/throwing/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/io/streams/throwing/throwing-tests.factor

@@ -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

basis/io/streams/throwing/throwing.factor

@@ -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

basis/timers/timers.factor

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

core/io/encodings/encodings-tests.factor

@@ -1,7 +1,7 @@
-USING: io.files io.streams.string io io.streams.byte-array
+USING: accessors io io.encodings io.encodings.ascii
-tools.test kernel io.encodings.ascii io.encodings.utf8
+io.encodings.utf8 io.files io.streams.byte-array
-namespaces accessors io.encodings io.streams.limited ;
+io.streams.string kernel namespaces tools.test ;
-IN: io.streams.encodings.tests
+IN: io.encodings.tests
 
 [ { } ]
 [ "vocab:io/test/empty-file.txt" ascii file-lines ]

core/io/io.factor

@@ -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 -- )

core/parser/parser-tests.factor

@@ -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
 

extra/images/gif/gif.factor

@@ -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.binary io.buffers io.encodings.string io.encodings.utf8
-io.encodings.utf8 io.files io.files.info io.ports
+io.ports kernel make math math.bitwise namespaces sequences ;
-io.streams.limited kernel make math math.bitwise math.functions
-multiline namespaces prettyprint sequences ;
 IN: images.gif
 
 SINGLETON: gif-image

extra/roles/roles-docs.factor

@@ -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"

extra/variants/variants-docs.factor

@@ -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
 } ;

extra/variants/variants-tests.factor

@@ -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

extra/variants/variants.factor

@@ -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-variant-class ( class -- )
-    [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+    [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
-    [ define-variant-member swap add-mixin-instance ] with each ;
+
+: 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] ;