From ef0001ec536c48a83eee27d382fab48218c888ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Jun 2010 14:57:03 -0500 Subject: [PATCH 01/20] Fix Windows compileation for VS 2010 --- vm/safeseh.asm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/safeseh.asm b/vm/safeseh.asm index fb706c1331..b1fc556845 100755 --- a/vm/safeseh.asm +++ b/vm/safeseh.asm @@ -1,5 +1,5 @@ .386 .model flat -exception_handler proto +exception_handler proto c .safeseh exception_handler end From 732befe2724ab1ef84de637bdc76fbc6f54f7d1e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 8 Jul 2010 10:17:52 -0700 Subject: [PATCH 02/20] cpu.x86.assembler: add MOVQ xmm, xmm/m64 and MOVQ xmm/m64, xmm instructions --- basis/cpu/x86/assembler/assembler-tests.factor | 9 +++++++++ basis/cpu/x86/assembler/assembler.factor | 6 ++++++ 2 files changed, 15 insertions(+) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 83694cae94..f0309c2e58 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/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 diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 401152325b..35613ac163 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/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* ; + Date: Thu, 8 Jul 2010 15:40:34 -0400 Subject: [PATCH 03/20] parser: update unit test --- core/parser/parser-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index ac2310d3f9..842e5c607f 100644 --- a/core/parser/parser-tests.factor +++ b/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 From 59ea478b0a7041e815ca6244acb5647eba68af34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 Jul 2010 14:58:09 -0500 Subject: [PATCH 04/20] Fix typo in timers --- basis/timers/timers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/timers/timers.factor b/basis/timers/timers.factor index a12ecba830..c2d06b0403 100644 --- a/basis/timers/timers.factor +++ b/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 -- ) From 1a8e09116bfc0ba2b6b78832ee072bd7c2797724 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 Jul 2010 15:02:52 -0500 Subject: [PATCH 05/20] Allow variants to be spread across multiple parsing words with a VARIANT-MEMBER: word. Fix typo in docs --- extra/variants/variants-docs.factor | 15 ++++++++++++++- extra/variants/variants-tests.factor | 18 ++++++++++++++++++ extra/variants/variants.factor | 19 +++++++++++++++---- 3 files changed, 47 insertions(+), 5 deletions(-) diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor index 9a230a8535..e23b3ee894 100644 --- a/extra/variants/variants-docs.factor +++ b/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 "" } " 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 "" } " 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 } ; diff --git a/extra/variants/variants-tests.factor b/extra/variants/variants-tests.factor index ef48b36b9c..f49cda6a99 100644 --- a/extra/variants/variants-tests.factor +++ b/extra/variants/variants-tests.factor @@ -19,3 +19,21 @@ VARIANT: list [ 4 ] [ 5 6 7 8 nil 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 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 list2-length ] unit-test diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor index 5cb786afde..df948b1863 100644 --- a/extra/variants/variants.factor +++ b/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-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 -- ) \ boa [ ] 2sequence [undo] ; From 9dfed202ca49f3d9d7c91d2bdb22a7cdb2c4bdce Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 Jul 2010 21:52:26 -0500 Subject: [PATCH 06/20] Add an article for roles --- extra/roles/roles-docs.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor index 129959a1cf..e499c14db5 100644 --- a/extra/roles/roles-docs.factor +++ b/extra/roles/roles-docs.factor @@ -46,3 +46,13 @@ 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 implements a way to extend tuple classes that allows them to be composed of multiple roles objects that contain 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 } ; From e752b4ff62e5eb39d34e907408dea56eb8619ab3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jul 2010 13:22:05 -0500 Subject: [PATCH 07/20] Clean up vocabulary list, remove unused/poorly-named word from io --- core/io/encodings/encodings-tests.factor | 8 ++++---- core/io/io.factor | 3 --- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index 9b88db5136..cc32f30060 100644 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -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 ] diff --git a/core/io/io.factor b/core/io/io.factor index cb6786fe1c..e074135e8c 100644 --- a/core/io/io.factor +++ b/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 -- ) From 2ca509a8fe681d58f80d402ea9da2be20b9ab0a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jul 2010 13:30:57 -0500 Subject: [PATCH 08/20] Split off io.streams.throwing from io.streams.limited and update usages of limited streams --- basis/http/server/server.factor | 28 ++-- basis/images/bitmap/bitmap.factor | 10 +- basis/images/bitmap/loading/authors.txt | 1 - basis/images/bitmap/loading/loading.factor | 7 - basis/images/jpeg/jpeg.factor | 21 ++- basis/images/loader/loader.factor | 16 +- basis/io/streams/limited/limited-docs.factor | 72 ++------- basis/io/streams/limited/limited-tests.factor | 149 +++--------------- basis/io/streams/limited/limited.factor | 80 ++++------ basis/io/streams/throwing/authors.txt | 1 + .../io/streams/throwing/throwing-tests.factor | 36 +++++ basis/io/streams/throwing/throwing.factor | 37 +++++ extra/images/gif/gif.factor | 8 +- 13 files changed, 181 insertions(+), 285 deletions(-) delete mode 100644 basis/images/bitmap/loading/authors.txt delete mode 100644 basis/images/bitmap/loading/loading.factor create mode 100644 basis/io/streams/throwing/authors.txt create mode 100644 basis/io/streams/throwing/throwing-tests.factor create mode 100644 basis/io/streams/throwing/throwing.factor diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 95662523d8..9a323bd38d 100644 --- a/basis/http/server/server.factor +++ b/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 @@ -50,13 +51,14 @@ ERROR: no-boundary ; 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 - binary decode-input - parse-multipart-form-data parse-multipart ; + upload-limit get limited-input + [ "content-type" header ] + [ "content-length" header string>number limited-input ] bi + [ + binary decode-input + parse-multipart-form-data parse-multipart + ] input-throws-on-eof ; : read-content ( request -- bytes ) "content-length" header string>number read ; @@ -277,15 +279,17 @@ 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 - ?refresh-all - [ read-request ] ?benchmark - [ do-request ] ?benchmark - [ do-response ] ?benchmark + request-limit get limited-input + [ + ?refresh-all + [ read-request ] ?benchmark + [ do-request ] ?benchmark + [ do-response ] ?benchmark + ] input-throws-on-eof ] with-destructors ; : ( -- server ) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 424efb993a..6c14490778 100644 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -1,11 +1,9 @@ ! 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 +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 ; QUALIFIED-WITH: bitstreams b SPECIALIZED-ARRAYS: uint ushort ; diff --git a/basis/images/bitmap/loading/authors.txt b/basis/images/bitmap/loading/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/basis/images/bitmap/loading/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor deleted file mode 100644 index 16e0e459f5..0000000000 --- a/basis/images/bitmap/loading/loading.factor +++ /dev/null @@ -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 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 937c73ceb0..89e6851793 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/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 -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 @@ -121,7 +121,7 @@ TUPLE: jpeg-color-info : decode-huff-table ( chunk -- ) data>> [ binary ] [ length ] bi - stream-throws limit + limit-stream [ [ input-stream get [ count>> ] [ limit>> ] bi < ] [ @@ -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 ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 8617a8d442..7f6a5f1dfd 100644 --- a/basis/images/loader/loader.factor +++ b/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 -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 ; + binary ; PRIVATE> @@ -36,9 +36,9 @@ GENERIC: stream>image ( stream class -- image ) M: byte-array load-image* [ - [ binary ] - [ length stream-throws ] bi - ] dip stream>image ; + [ binary ] [ length ] bi + dup + ] dip '[ _ stream>image ] throws-on-eof ; M: limited-stream load-image* stream>image ; diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index 6c1806ff38..37f9c2f27b 100644 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -5,53 +5,29 @@ IN: io.streams.limited HELP: { $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\" 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\" 3 stream-eofs limit" + "\"123456\" 3 limit-stream" "100 swap stream-read ." "\"123\"" } } ; -HELP: unlimited +HELP: unlimit-stream { $values { "stream" "an input stream" } { "stream'" "a stream" } @@ -64,42 +40,22 @@ HELP: limited-stream } { $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 } +{ $subsections limited-input } "Unlimits a limited stream:" -{ $subsections unlimited } +{ $subsections unlimit-stream } "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 unlimited-input } ; ABOUT: "io.streams.limited" diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 047cd117a0..12e5a38340 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -11,7 +11,7 @@ IN: io.streams.limited.tests ascii encode binary "data" set ] unit-test -[ ] [ "data" get 24 stream-throws "limited" set ] unit-test +[ ] [ "data" get 24 "limited" set ] unit-test [ CHAR: h ] [ "limited" get stream-read1 ] unit-test @@ -21,51 +21,48 @@ 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 "data" set ] unit-test -[ ] [ "data" get 7 stream-throws "limited" set ] unit-test +[ ] [ "data" get 4 "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 [ - 5 stream-throws limit-input - "l" read-until - ] with-input-stream -] unit-test [ CHAR: a ] -[ "a" 1 stream-eofs stream-read1 ] unit-test +[ "a" 1 stream-read1 ] unit-test [ "abc" ] [ - "abc" 3 stream-eofs + "abc" 3 4 swap stream-read ] unit-test [ f ] [ - "abc" 3 stream-eofs + "abc" 3 4 over stream-read drop 10 swap stream-read ] unit-test [ t ] [ - "abc" 3 stream-eofs limit unlimited + "abc" 3 limit-stream unlimit-stream "abc" = ] unit-test [ t ] [ - "abc" 3 stream-eofs limit unlimited + "abc" 3 limit-stream unlimit-stream "abc" = ] unit-test @@ -73,145 +70,41 @@ IN: io.streams.limited.tests [ [ "resource:license.txt" utf8 &dispose - 3 stream-eofs limit unlimited + 3 limit-stream unlimit-stream "resource:license.txt" utf8 &dispose [ decoder? ] both? ] with-destructors ] unit-test -[ "HELL" ] [ - "HELLO" - [ f stream-throws limit-input 4 read ] - with-string-reader -] unit-test - [ "asdf" ] [ - "asdf" 2 stream-eofs [ + "asdf" 2 [ unlimited-input contents ] with-input-stream ] unit-test -[ 4 ] [ - "abcdefgh" 4 stream-throws [ - 4 seek-relative seek-input tell-input - ] with-input-stream -] unit-test - -[ - "abcdefgh" 4 stream-throws [ - 4 seek-relative seek-input - 4 read - ] with-input-stream -] [ - limit-exceeded? -] must-fail-with - -[ - "abcdefgh" 4 stream-throws [ - 4 seek-relative seek-input - -2 seek-relative - 2 read - ] with-input-stream -] [ - limit-exceeded? -] must-fail-with - -[ - "abcdefgh" [ - 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" [ - 4 seek-relative seek-input - 2 stream-throws limit-input - 4 seek-absolute seek-input - 2 read - ] with-input-stream -] unit-test - -[ "ef" ] [ - "abcdefgh" [ - 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 [ 2 stream-throws ] change-in - "asdf" over stream-write dup stream-flush - 2 swap stream-read -] unit-test - -[ - latin1 [ 2 stream-throws ] 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 [ 2 stream-eofs ] change-in + latin1 [ 2 ] change-in "asdf" over stream-write dup stream-flush 2 swap stream-read ] unit-test [ "as" ] [ - latin1 [ 2 stream-eofs ] change-in + latin1 [ 2 ] change-in "asdf" over stream-write dup stream-flush 3 swap stream-read ] unit-test ! test seeking on limited unseekable streams [ "as" ] [ - latin1 [ 2 stream-eofs ] change-in + latin1 [ 2 ] change-in "asdf" over stream-write dup stream-flush 2 swap stream-read ] unit-test [ "as" ] [ - latin1 [ 2 stream-eofs ] change-in + latin1 [ 2 ] change-in "asdf" over stream-write dup stream-flush 3 swap stream-read ] unit-test - -[ - latin1 [ 2 stream-throws ] change-in - 2 seek-absolute rot in>> stream-seek -] must-fail - -[ - "as" -] [ - latin1 [ 2 stream-throws ] 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 [ - 7 read drop - tell-input - ] with-input-stream -] unit-test - -[ 70000 ] [ - image binary stream-throws [ - 70000 read drop - tell-input - ] with-input-stream -] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 25f1d88363..45494b3c1d 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -6,87 +6,67 @@ 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 ; - -: ( stream limit mode -- stream' ) +: ( stream limit -- stream' ) limited-stream new - swap >>mode swap >>limit swap >>stream 0 >>count ; -: ( path encoding mode -- stream' ) - [ - [ ] - [ drop file-info size>> ] 2bi - ] dip ; +: ( path encoding -- stream' ) + [ ] + [ drop file-info size>> ] 2bi + ; -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 [ ] [ 2drop ] if ; +M: object limit-stream ( stream limit -- stream' ) + ; -GENERIC: unlimited ( stream -- stream' ) +GENERIC: unlimit-stream ( stream -- stream' ) -M: decoder unlimited ( stream -- stream' ) +M: decoder unlimit-stream ( stream -- stream' ) [ stream>> ] change-stream ; -M: object unlimited ( stream -- stream' ) - stream>> ; +M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ; -: limit-input ( limit mode -- ) - [ input-stream ] 2dip '[ _ _ limit ] change ; +M: object unlimit-stream ( stream -- stream' ) ; + +: limited-input ( limit -- ) + [ input-stream ] dip '[ _ limit-stream ] change ; : unlimited-input ( -- ) - input-stream [ unlimited ] change ; + input-stream [ unlimit-stream ] change ; : with-unlimited-stream ( stream quot -- ) - [ clone unlimited ] dip call ; inline + [ clone unlimit-stream ] 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 ; - > ] [ 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 +104,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 { diff --git a/basis/io/streams/throwing/authors.txt b/basis/io/streams/throwing/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/streams/throwing/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/streams/throwing/throwing-tests.factor b/basis/io/streams/throwing/throwing-tests.factor new file mode 100644 index 0000000000..f7b7dc52b8 --- /dev/null +++ b/basis/io/streams/throwing/throwing-tests.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.streams.limited io.streams.string +io.streams.throwing tools.test ; +IN: io.streams.throwing.tests + +[ "as" ] +[ + "asdf" 2 + [ 6 read-partial ] throws-on-eof +] unit-test + +[ + "asdf" 2 + [ contents ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + +[ + "asdf" 2 + [ 2 read read1 ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + +[ + "asdf" 2 + [ 3 read ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + +[ + "asdf" 2 + [ 2 read 2 read ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + +[ + "asdf" 2 + [ contents contents ] throws-on-eof +] [ stream-exhausted? ] must-fail-with diff --git a/basis/io/streams/throwing/throwing.factor b/basis/io/streams/throwing/throwing.factor new file mode 100644 index 0000000000..3ad4d012f7 --- /dev/null +++ b/basis/io/streams/throwing/throwing.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors destructors io kernel locals namespaces +sequences ; +IN: io.streams.throwing + +ERROR: stream-exhausted n stream word ; + + throws-on-eof + +M: throws-on-eof stream-element-type stream>> stream-element-type ; + +M: throws-on-eof dispose stream>> dispose ; + +M:: throws-on-eof stream-read1 ( stream -- obj ) + stream stream>> stream-read1 + [ 1 stream \ read1 stream-exhausted ] unless* ; + +M:: throws-on-eof stream-read ( n stream -- seq ) + n stream stream>> stream-read + dup length n = [ n stream \ read stream-exhausted ] unless ; + +M:: throws-on-eof stream-read-partial ( n stream -- seq ) + n stream stream>> stream-read-partial + [ n stream \ read-partial stream-exhausted ] unless* ; + +PRIVATE> + +: throws-on-eof ( stream quot -- ) + [ ] dip with-input-stream ; inline + +: input-throws-on-eof ( quot -- ) + [ input-stream get ] dip with-input-stream ; inline diff --git a/extra/images/gif/gif.factor b/extra/images/gif/gif.factor index 7301cc984f..c72f06f139 100644 --- a/extra/images/gif/gif.factor +++ b/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.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 From 57fb4267ab4c5770b51c2217ca448e4b84ac1718 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 13:30:15 -0700 Subject: [PATCH 09/20] clear up roles docs --- extra/roles/roles-docs.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor index e499c14db5..f3073e20a7 100644 --- a/extra/roles/roles-docs.factor +++ b/extra/roles/roles-docs.factor @@ -47,7 +47,7 @@ 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 implements a way to extend tuple classes that allows them to be composed of multiple roles objects that contain slots." $nl +"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:" @@ -56,3 +56,5 @@ ARTICLE: "roles" "Roles" { $subsection POSTPONE: TUPLE: } "Errors with roles:" { $subsections multiple-inheritance-attempted role-slot-overlap } ; + +ABOUT: "roles" From 0bdc1514fd9a8fb4655869e6f240a53639531c68 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 13:52:15 -0700 Subject: [PATCH 10/20] io.streams.limited: remove unlimit* --- basis/http/server/server.factor | 1 - basis/images/jpeg/jpeg.factor | 2 +- basis/io/streams/limited/limited-docs.factor | 16 +--------- basis/io/streams/limited/limited-tests.factor | 29 ------------------- basis/io/streams/limited/limited.factor | 6 ---- 5 files changed, 2 insertions(+), 52 deletions(-) diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 9a323bd38d..c551f5608b 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -51,7 +51,6 @@ ERROR: no-boundary ; SYMBOL: upload-limit : read-multipart-data ( request -- mime-parts ) - unlimited-input upload-limit get limited-input [ "content-type" header ] [ "content-length" header string>number limited-input ] bi diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 89e6851793..fa6d5688bc 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -366,7 +366,7 @@ ERROR: not-a-jpeg-image ; [ parse-marker { SOI } = [ not-a-jpeg-image ] unless parse-headers - unlimited-input contents + contents ] with-input-stream ; PRIVATE> diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index 37f9c2f27b..5a06dedf0d 100644 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -27,13 +27,6 @@ HELP: limit-stream } } ; -HELP: unlimit-stream -{ $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" } @@ -44,18 +37,11 @@ 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 } "." } ; - 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 limited-stream } "Wrap the current " { $link input-stream } " in a limited stream:" -{ $subsections limited-input } -"Unlimits a limited stream:" -{ $subsections unlimit-stream } -"Unlimits the current " { $link input-stream } ":" -{ $subsections unlimited-input } ; +{ $subsections limited-input } ; ABOUT: "io.streams.limited" diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 12e5a38340..7ce7bd2016 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -54,35 +54,6 @@ IN: io.streams.limited.tests 4 over stream-read drop 10 swap stream-read ] unit-test -[ t ] -[ - "abc" 3 limit-stream unlimit-stream - "abc" = -] unit-test - -[ t ] -[ - "abc" 3 limit-stream unlimit-stream - "abc" = -] unit-test - -[ t ] -[ - [ - "resource:license.txt" utf8 &dispose - 3 limit-stream unlimit-stream - "resource:license.txt" utf8 &dispose - [ decoder? ] both? - ] with-destructors -] unit-test - - -[ "asdf" ] [ - "asdf" 2 [ - unlimited-input contents - ] with-input-stream -] unit-test - ! pipes are duplex and not seekable [ "as" ] [ latin1 [ 2 ] change-in diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 45494b3c1d..ba709bd7f1 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -39,12 +39,6 @@ M: object unlimit-stream ( stream -- stream' ) ; : limited-input ( limit -- ) [ input-stream ] dip '[ _ limit-stream ] change ; -: unlimited-input ( -- ) - input-stream [ unlimit-stream ] change ; - -: with-unlimited-stream ( stream quot -- ) - [ clone unlimit-stream ] dip call ; inline - : with-limited-stream ( stream limit quot -- ) [ limit-stream ] dip call ; inline From 99db070c9e8edbedfba29f3021221b0fb74d2c6c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:08:54 -0700 Subject: [PATCH 11/20] io.streams.throwing: implement tell and seek --- basis/io/streams/throwing/throwing-tests.factor | 12 +++++++++++- basis/io/streams/throwing/throwing.factor | 6 ++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/basis/io/streams/throwing/throwing-tests.factor b/basis/io/streams/throwing/throwing-tests.factor index f7b7dc52b8..1e7cc1cd2b 100644 --- a/basis/io/streams/throwing/throwing-tests.factor +++ b/basis/io/streams/throwing/throwing-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.limited io.streams.string -io.streams.throwing tools.test ; +io.streams.throwing tools.test kernel ; IN: io.streams.throwing.tests [ "as" ] @@ -34,3 +34,13 @@ IN: io.streams.throwing.tests "asdf" 2 [ contents contents ] throws-on-eof ] [ stream-exhausted? ] must-fail-with + +[ + "asdf" 2 + [ 1 seek-absolute seek-input 4 read drop ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + +[ 1 ] [ + "asdf" 2 + [ 1 seek-absolute seek-input tell-input ] throws-on-eof +] unit-test diff --git a/basis/io/streams/throwing/throwing.factor b/basis/io/streams/throwing/throwing.factor index 3ad4d012f7..bc9adc66bf 100644 --- a/basis/io/streams/throwing/throwing.factor +++ b/basis/io/streams/throwing/throwing.factor @@ -28,6 +28,12 @@ M:: throws-on-eof stream-read-partial ( n stream -- seq ) n stream stream>> stream-read-partial [ n stream \ read-partial stream-exhausted ] unless* ; +M: throws-on-eof stream-tell + stream>> stream-tell ; + +M: throws-on-eof stream-seek + stream>> stream-seek ; + PRIVATE> : throws-on-eof ( stream quot -- ) From 9a2dd6a96c7f3c73eda9ca76e6baa130897d1886 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:20:32 -0700 Subject: [PATCH 12/20] images.loader and friends: push throws-on-eof down to the loaders that want it --- basis/images/bitmap/bitmap.factor | 32 ++++++++++++++++--------------- basis/images/loader/loader.factor | 9 +++------ basis/images/png/png.factor | 12 +++++++----- basis/images/tga/tga.factor | 4 ++-- basis/images/tiff/tiff.factor | 32 ++++++++++++------------------- 5 files changed, 41 insertions(+), 48 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 6c14490778..df31c8d983 100644 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -4,7 +4,7 @@ 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 ; +specialized-arrays summary io.streams.throwing ; QUALIFIED-WITH: bitstreams b SPECIALIZED-ARRAYS: uint ushort ; IN: images.bitmap @@ -348,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 + ] input-throws-on-eof ] with-input-stream ; : loading-bitmap>bytes ( loading-bitmap -- byte-array ) diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 7f6a5f1dfd..7e1dc9ca31 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -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 ] [ length ] bi - dup - ] dip '[ _ stream>image ] throws-on-eof ; +M: object load-image* stream>image ; -M: limited-stream load-image* stream>image ; +M: byte-array load-image* + [ binary ] dip stream>image ; M: string load-image* [ open-image-file ] dip stream>image ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 0b46fdf653..a539eb7a0c 100644 --- a/basis/images/png/png.factor +++ b/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 ) [ - - read-png-header - read-png-chunks - parse-ihdr-chunk + [ + + read-png-header + read-png-chunks + parse-ihdr-chunk + ] input-throws-on-eof ] with-input-stream ; M: png-image stream>image diff --git a/basis/images/tga/tga.factor b/basis/images/tga/tga.factor index 7a3a400197..3b7a726a1e 100644 --- a/basis/images/tga/tga.factor +++ b/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 ] input-throws-on-eof ] with-input-stream ; M: tga-image image>stream drop diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index a1880a3d3c..3a26cd61d8 100755 --- a/basis/images/tiff/tiff.factor +++ b/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 ) - [ - - read-header [ - dup ifd-offset>> read-ifds - process-ifds - ] with-tiff-endianness - ] with-input-stream* ; +: load-tiff-ifds ( -- 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 ] input-throws-on-eof ] with-input-stream ; { "tif" "tiff" } [ tiff-image register-image-class ] each From 90b962bbd3ba7511eca87ec6c018cbfc31f6511b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:26:01 -0700 Subject: [PATCH 13/20] io.streams.throwing: implement read-until --- basis/io/streams/throwing/throwing-tests.factor | 10 ++++++++++ basis/io/streams/throwing/throwing.factor | 6 +++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/basis/io/streams/throwing/throwing-tests.factor b/basis/io/streams/throwing/throwing-tests.factor index 1e7cc1cd2b..656bf0fb32 100644 --- a/basis/io/streams/throwing/throwing-tests.factor +++ b/basis/io/streams/throwing/throwing-tests.factor @@ -40,6 +40,16 @@ IN: io.streams.throwing.tests [ 1 seek-absolute seek-input 4 read drop ] throws-on-eof ] [ stream-exhausted? ] must-fail-with +[ "asd" CHAR: f ] [ + "asdf" + [ "f" read-until ] throws-on-eof +] unit-test + +[ + "asdf" + [ "g" read-until ] throws-on-eof +] [ stream-exhausted? ] must-fail-with + [ 1 ] [ "asdf" 2 [ 1 seek-absolute seek-input tell-input ] throws-on-eof diff --git a/basis/io/streams/throwing/throwing.factor b/basis/io/streams/throwing/throwing.factor index bc9adc66bf..7e21be9c80 100644 --- a/basis/io/streams/throwing/throwing.factor +++ b/basis/io/streams/throwing/throwing.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors destructors io kernel locals namespaces -sequences ; +sequences fry ; IN: io.streams.throwing ERROR: stream-exhausted n stream word ; @@ -34,6 +34,10 @@ M: throws-on-eof stream-tell M: throws-on-eof stream-seek stream>> stream-seek ; +M: throws-on-eof stream-read-until + [ stream>> stream-read-until ] + [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ; + PRIVATE> : throws-on-eof ( stream quot -- ) From 8b7cb0bc212047c6ac0ddecdafd9dcd550c6bd06 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:26:17 -0700 Subject: [PATCH 14/20] images.p[bgp]m: use throws-on-eof --- basis/images/pbm/pbm.factor | 4 ++-- basis/images/pgm/pgm.factor | 4 ++-- basis/images/ppm/ppm.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/images/pbm/pbm.factor b/basis/images/pbm/pbm.factor index 9b8c7c11f9..40db85f58d 100644 --- a/basis/images/pbm/pbm.factor +++ b/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 ] input-throws-on-eof ] with-input-stream ; M: pbm-image image>stream drop { diff --git a/basis/images/pgm/pgm.factor b/basis/images/pgm/pgm.factor index 52e594ddff..914bdcdccb 100644 --- a/basis/images/pgm/pgm.factor +++ b/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 ] input-throws-on-eof ] with-input-stream ; M: pgm-image image>stream drop { diff --git a/basis/images/ppm/ppm.factor b/basis/images/ppm/ppm.factor index 9610189094..93c36e60a1 100755 --- a/basis/images/ppm/ppm.factor +++ b/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 ] input-throws-on-eof ] with-input-stream ; M: ppm-image image>stream drop { From 7f0ba864219568a590c2ab0a3a815465c16a6826 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:30:26 -0700 Subject: [PATCH 15/20] images.jpeg: fix loading error --- basis/images/jpeg/jpeg.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index fa6d5688bc..1050f0615d 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -120,10 +120,8 @@ TUPLE: jpeg-color-info ] with-byte-reader ; : decode-huff-table ( chunk -- ) - data>> [ binary ] [ length ] bi - limit-stream - [ - [ input-stream get [ count>> ] [ limit>> ] bi < ] + data>> [ binary ] [ length ] bi limit-stream [ + [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ] [ read4/4 swap 2 * + 16 read @@ -131,7 +129,7 @@ TUPLE: jpeg-color-info binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader swap jpeg> huff-tables>> set-nth ] while - ] with-input-stream* ; + ] throws-on-eof ; : decode-scan ( chunk -- ) data>> From 67a241eba370631f55fbf34e3713c96df5c85acc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:47:34 -0700 Subject: [PATCH 16/20] http.server: revert d00ea changes so that server works again --- basis/http/server/server.factor | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c551f5608b..248afdb070 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -51,14 +51,13 @@ ERROR: no-boundary ; SYMBOL: upload-limit : read-multipart-data ( request -- mime-parts ) - upload-limit get limited-input [ "content-type" header ] - [ "content-length" header string>number limited-input ] bi - [ - binary decode-input - parse-multipart-form-data parse-multipart - ] input-throws-on-eof ; - + [ "content-length" header string>number ] bi + upload-limit get limited-input ! throw limit + limited-input ! eof limit + binary decode-input + parse-multipart-form-data parse-multipart ; + : read-content ( request -- bytes ) "content-length" header string>number read ; @@ -278,17 +277,15 @@ TUPLE: http-server < threaded-server ; SYMBOL: request-limit -request-limit [ 64 1024 * ] initialize +64 1024 * request-limit set-global M: http-server handle-client* drop [ request-limit get limited-input - [ - ?refresh-all - [ read-request ] ?benchmark - [ do-request ] ?benchmark - [ do-response ] ?benchmark - ] input-throws-on-eof + ?refresh-all + [ read-request ] ?benchmark + [ do-request ] ?benchmark + [ do-response ] ?benchmark ] with-destructors ; : ( -- server ) From f7960c7f6a9b4facd77fabdff7e97df59e822d34 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:52:42 -0700 Subject: [PATCH 17/20] http.server: reintroduce some code cleanups now that it's back in a working state --- basis/http/server/server.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 248afdb070..942142883a 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -28,6 +28,7 @@ html.templates html.streams html mime.types +math.order xml.writer ; FROM: mime.multipart => parse-multipart ; IN: http.server @@ -53,8 +54,7 @@ SYMBOL: upload-limit : read-multipart-data ( request -- mime-parts ) [ "content-type" header ] [ "content-length" header string>number ] bi - upload-limit get limited-input ! throw limit - limited-input ! eof limit + upload-limit get min limited-input binary decode-input parse-multipart-form-data parse-multipart ; @@ -277,7 +277,7 @@ 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 [ From fb4cbd87d42940525d7e466123e0e9a784a94f34 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 14:56:54 -0700 Subject: [PATCH 18/20] io.streams.limited: scrape out last vestiges of unlimiting --- basis/io/streams/limited/limited.factor | 9 --------- 1 file changed, 9 deletions(-) diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index ba709bd7f1..4ca1779a7b 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -27,15 +27,6 @@ M: decoder limit-stream ( stream limit -- stream' ) M: object limit-stream ( stream limit -- stream' ) ; -GENERIC: unlimit-stream ( stream -- stream' ) - -M: decoder unlimit-stream ( stream -- stream' ) - [ stream>> ] change-stream ; - -M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ; - -M: object unlimit-stream ( stream -- stream' ) ; - : limited-input ( limit -- ) [ input-stream ] dip '[ _ limit-stream ] change ; From b1c557a8251da1cede81589a294c1b278196938b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 18:08:45 -0700 Subject: [PATCH 19/20] io.streams.throwing: rename throws-on-eof -> stream-throw-on-eof and input-throws-on-eof -> throw-on-eof and change stream-throw-on-eof to leave the rigged stream on the stack, to better follow convention of other io words --- basis/images/bitmap/bitmap.factor | 2 +- basis/images/jpeg/jpeg.factor | 18 +++--- basis/images/pbm/pbm.factor | 2 +- basis/images/pgm/pgm.factor | 2 +- basis/images/png/png.factor | 2 +- basis/images/ppm/ppm.factor | 2 +- basis/images/tga/tga.factor | 2 +- basis/images/tiff/tiff.factor | 2 +- .../io/streams/throwing/throwing-tests.factor | 57 +++++++++++-------- basis/io/streams/throwing/throwing.factor | 28 ++++----- 10 files changed, 63 insertions(+), 54 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index df31c8d983..71aaf7b4ec 100644 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -363,7 +363,7 @@ ERROR: unsupported-bitmap-file magic ; ! { "PT" [ parse-os2-pointer ] } [ unsupported-bitmap-file ] } case - ] input-throws-on-eof + ] throw-on-eof ] with-input-stream ; : loading-bitmap>bytes ( loading-bitmap -- byte-array ) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 1050f0615d..7da9f6fc09 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -121,15 +121,17 @@ TUPLE: jpeg-color-info : decode-huff-table ( chunk -- ) data>> [ binary ] [ length ] bi limit-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 - ] throws-on-eof ; + [ 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>> diff --git a/basis/images/pbm/pbm.factor b/basis/images/pbm/pbm.factor index 40db85f58d..a6e7edb9e2 100644 --- a/basis/images/pbm/pbm.factor +++ b/basis/images/pbm/pbm.factor @@ -73,7 +73,7 @@ SINGLETON: pbm-image PRIVATE> M: pbm-image stream>image - drop [ [ read-pbm ] input-throws-on-eof ] with-input-stream ; + drop [ [ read-pbm ] throw-on-eof ] with-input-stream ; M: pbm-image image>stream drop { diff --git a/basis/images/pgm/pgm.factor b/basis/images/pgm/pgm.factor index 914bdcdccb..4457c89135 100644 --- a/basis/images/pgm/pgm.factor +++ b/basis/images/pgm/pgm.factor @@ -50,7 +50,7 @@ SINGLETON: pgm-image wide [ ushort-components ] [ ubyte-components ] if >>component-type ; M: pgm-image stream>image - drop [ [ read-pgm ] input-throws-on-eof ] with-input-stream ; + drop [ [ read-pgm ] throw-on-eof ] with-input-stream ; M: pgm-image image>stream drop { diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index a539eb7a0c..6e8d7a6c1e 100644 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -324,7 +324,7 @@ ERROR: invalid-color-type/bit-depth loading-png ; read-png-header read-png-chunks parse-ihdr-chunk - ] input-throws-on-eof + ] throw-on-eof ] with-input-stream ; M: png-image stream>image diff --git a/basis/images/ppm/ppm.factor b/basis/images/ppm/ppm.factor index 93c36e60a1..454a4b34f5 100755 --- a/basis/images/ppm/ppm.factor +++ b/basis/images/ppm/ppm.factor @@ -47,7 +47,7 @@ SINGLETON: ppm-image ubyte-components >>component-type ; M: ppm-image stream>image - drop [ [ read-ppm ] input-throws-on-eof ] with-input-stream ; + drop [ [ read-ppm ] throw-on-eof ] with-input-stream ; M: ppm-image image>stream drop { diff --git a/basis/images/tga/tga.factor b/basis/images/tga/tga.factor index 3b7a726a1e..efdcbc537c 100644 --- a/basis/images/tga/tga.factor +++ b/basis/images/tga/tga.factor @@ -254,7 +254,7 @@ ERROR: bad-tga-unsupported ; ubyte-components >>component-type ; M: tga-image stream>image - drop [ [ read-tga ] input-throws-on-eof ] with-input-stream ; + drop [ [ read-tga ] throw-on-eof ] with-input-stream ; M: tga-image image>stream drop diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 3a26cd61d8..e79ed5f07d 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -561,6 +561,6 @@ ERROR: unknown-component-order ifd ; ! 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 ] input-throws-on-eof ] with-input-stream ; + drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ; { "tif" "tiff" } [ tiff-image register-image-class ] each diff --git a/basis/io/streams/throwing/throwing-tests.factor b/basis/io/streams/throwing/throwing-tests.factor index 656bf0fb32..1c9e32914b 100644 --- a/basis/io/streams/throwing/throwing-tests.factor +++ b/basis/io/streams/throwing/throwing-tests.factor @@ -1,56 +1,63 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.streams.limited io.streams.string -io.streams.throwing tools.test kernel ; +USING: io io.encodings.utf8 io.files io.streams.string +io.streams.throwing kernel tools.test destructors ; IN: io.streams.throwing.tests -[ "as" ] +[ "asdf" ] [ - "asdf" 2 - [ 6 read-partial ] throws-on-eof + "asdf" [ [ 6 read-partial ] throw-on-eof ] with-string-reader ] unit-test [ - "asdf" 2 - [ contents ] throws-on-eof + "asdf" [ [ 4 read read1 ] throw-on-eof ] with-string-reader ] [ stream-exhausted? ] must-fail-with [ - "asdf" 2 - [ 2 read read1 ] throws-on-eof + [ + "asdf" &dispose [ + [ 4 swap stream-read ] + [ stream-read1 ] bi + ] stream-throw-on-eof + ] with-destructors ] [ stream-exhausted? ] must-fail-with [ - "asdf" 2 - [ 3 read ] throws-on-eof + "asdf" [ [ 5 read ] throw-on-eof ] with-string-reader ] [ stream-exhausted? ] must-fail-with [ - "asdf" 2 - [ 2 read 2 read ] throws-on-eof + "asdf" [ [ 4 read 4 read ] throw-on-eof ] with-string-reader ] [ stream-exhausted? ] must-fail-with -[ - "asdf" 2 - [ contents contents ] throws-on-eof -] [ 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" 2 - [ 1 seek-absolute seek-input 4 read drop ] throws-on-eof + "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 ] throws-on-eof + "asdf" [ [ "f" read-until ] throw-on-eof ] with-string-reader ] unit-test [ - "asdf" - [ "g" read-until ] throws-on-eof + "asdf" [ [ "g" read-until ] throw-on-eof ] with-string-reader ] [ stream-exhausted? ] must-fail-with [ 1 ] [ - "asdf" 2 - [ 1 seek-absolute seek-input tell-input ] throws-on-eof + "asdf" [ [ 1 seek-absolute seek-input tell-input ] throw-on-eof ] with-string-reader ] unit-test diff --git a/basis/io/streams/throwing/throwing.factor b/basis/io/streams/throwing/throwing.factor index 7e21be9c80..f2cdeab4f7 100644 --- a/basis/io/streams/throwing/throwing.factor +++ b/basis/io/streams/throwing/throwing.factor @@ -8,40 +8,40 @@ ERROR: stream-exhausted n stream word ; throws-on-eof +C: throws-on-eof-stream -M: throws-on-eof stream-element-type stream>> stream-element-type ; +M: throws-on-eof-stream stream-element-type stream>> stream-element-type ; -M: throws-on-eof dispose stream>> dispose ; +M: throws-on-eof-stream dispose stream>> dispose ; -M:: throws-on-eof stream-read1 ( stream -- obj ) +M:: throws-on-eof-stream stream-read1 ( stream -- obj ) stream stream>> stream-read1 [ 1 stream \ read1 stream-exhausted ] unless* ; -M:: throws-on-eof stream-read ( n stream -- seq ) +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-read-partial ( n stream -- seq ) +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-tell +M: throws-on-eof-stream stream-tell stream>> stream-tell ; -M: throws-on-eof stream-seek +M: throws-on-eof-stream stream-seek stream>> stream-seek ; -M: throws-on-eof stream-read-until +M: throws-on-eof-stream stream-read-until [ stream>> stream-read-until ] [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ; PRIVATE> -: throws-on-eof ( stream quot -- ) - [ ] dip with-input-stream ; inline +: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b ) + [ ] dip call ; inline -: input-throws-on-eof ( quot -- ) - [ input-stream get ] dip with-input-stream ; inline +: throw-on-eof ( ..a quot: ( ..a -- ..b ) -- ..b ) + [ input-stream get ] dip with-input-stream* ; inline From b04bc8640f1aa773850b6a04516256a9f04322cf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 9 Jul 2010 23:36:40 -0700 Subject: [PATCH 20/20] io.streams.throwing: add test file --- basis/io/streams/throwing/asdf.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/io/streams/throwing/asdf.txt diff --git a/basis/io/streams/throwing/asdf.txt b/basis/io/streams/throwing/asdf.txt new file mode 100644 index 0000000000..8bd6648ed1 --- /dev/null +++ b/basis/io/streams/throwing/asdf.txt @@ -0,0 +1 @@ +asdf