Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
edee81ec54
|
|
@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
|||
data-gc ;
|
||||
|
||||
[ "Hello world" ] [
|
||||
[ callback-4 callback_test_1 ] string-out
|
||||
[ callback-4 callback_test_1 ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
: callback-5
|
||||
|
|
|
|||
|
|
@ -416,7 +416,7 @@ M: curry '
|
|||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
<file-writer> [ (write-image) ] with-stream ;
|
||||
[ (write-image) ] with-file-writer ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ UNION: bah fixnum alien ;
|
|||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] string-out ] unit-test
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
||||
! Test redefinition of classes
|
||||
UNION: union-1 fixnum float ;
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ M: generic definer drop f f ;
|
|||
M: generic definition drop f ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
dup { "unannotated-def" } reset-props
|
||||
dup dup "combination" word-prop perform-combination define ;
|
||||
|
||||
TUPLE: method word def specializer generic loc ;
|
||||
|
|
|
|||
|
|
@ -8,4 +8,4 @@ f describe
|
|||
H{ } describe
|
||||
H{ } describe
|
||||
|
||||
[ "fixnum instance\n" ] [ [ 3 describe ] string-out ] unit-test
|
||||
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,3 @@
|
|||
USING: kernel io.encodings ;
|
||||
|
||||
TUPLE: binary ;
|
||||
|
||||
M: binary init-decoding drop ;
|
||||
M: binary init-encoding drop ;
|
||||
|
|
|
|||
|
|
@ -53,27 +53,17 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
|
|||
>r swap start-decoding r>
|
||||
decode-read-loop ;
|
||||
|
||||
GENERIC: init-decoding ( stream encoding -- decoded-stream )
|
||||
|
||||
: <decoding> ( stream decoding-class -- decoded-stream )
|
||||
construct-empty init-decoding <line-reader> ;
|
||||
|
||||
GENERIC: init-encoding ( stream encoding -- encoded-stream )
|
||||
construct-delegate <line-reader> ;
|
||||
|
||||
: <encoding> ( stream encoding-class -- encoded-stream )
|
||||
construct-empty init-encoding <plain-writer> ;
|
||||
construct-delegate <plain-writer> ;
|
||||
|
||||
GENERIC: encode-string ( string encoding -- byte-array )
|
||||
M: tuple-class encode-string construct-empty encode-string ;
|
||||
|
||||
MIXIN: encoding-stream
|
||||
|
||||
M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
|
||||
tuck set-delegate ;
|
||||
|
||||
M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
|
||||
tuck set-delegate ;
|
||||
|
||||
M: encoding-stream stream-read1 1 swap stream-read ;
|
||||
|
||||
M: encoding-stream stream-read
|
||||
|
|
@ -93,3 +83,13 @@ M: encoding-stream stream-write
|
|||
[ encode-string ] keep delegate stream-write ;
|
||||
|
||||
M: encoding-stream dispose delegate dispose ;
|
||||
|
||||
GENERIC: underlying-stream ( encoded-stream -- delegate )
|
||||
M: encoding-stream underlying-stream delegate ;
|
||||
|
||||
GENERIC: set-underlying-stream ( new-underlying stream -- )
|
||||
M: encoding-stream set-underlying-stream set-delegate ;
|
||||
|
||||
: set-encoding ( encoding stream -- ) ! This doesn't work now
|
||||
[ underlying-stream swap construct-delegate ] keep
|
||||
set-underlying-stream ;
|
||||
|
|
|
|||
|
|
@ -1,19 +1,10 @@
|
|||
USING: io io.encodings strings kernel ;
|
||||
IN: io.encodings.latin1
|
||||
|
||||
TUPLE: latin1 stream ;
|
||||
TUPLE: latin1 ;
|
||||
|
||||
M: latin1 init-decoding tuck set-latin1-stream ;
|
||||
M: latin1 init-encoding drop ;
|
||||
M: latin1 stream-read delegate stream-read >string ;
|
||||
|
||||
M: latin1 stream-read1
|
||||
latin1-stream stream-read1 ;
|
||||
M: latin1 stream-read-until delegate stream-read-until >string ;
|
||||
|
||||
M: latin1 stream-read
|
||||
latin1-stream stream-read >string ;
|
||||
|
||||
M: latin1 stream-read-until
|
||||
latin1-stream stream-read-until >string ;
|
||||
|
||||
M: latin1 stream-readln
|
||||
latin1-stream stream-readln >string ;
|
||||
M: latin1 stream-read-partial delegate stream-read-partial >string ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,28 @@
|
|||
USING: tools.test io.utf16 arrays unicode ;
|
||||
USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings
|
||||
io unicode ;
|
||||
|
||||
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
|
||||
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
|
||||
: decode-w/stream ( array encoding -- newarray )
|
||||
>r >sbuf dup reverse-here r> <decoding> contents >array ;
|
||||
|
||||
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
|
||||
: encode-w/stream ( array encoding -- newarray )
|
||||
>r SBUF" " clone tuck r> <encoding> stream-write >array ;
|
||||
|
||||
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
|
||||
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
|
||||
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
|
||||
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test
|
||||
|
||||
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test
|
||||
[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test
|
||||
|
||||
[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test
|
||||
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test
|
||||
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
|
||||
|
||||
[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test
|
||||
|
||||
[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test
|
||||
[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test
|
||||
|
||||
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces io.binary
|
||||
io.encodings combinators splitting ;
|
||||
io.encodings combinators splitting io byte-arrays ;
|
||||
IN: io.encodings.utf16
|
||||
|
||||
SYMBOL: double
|
||||
|
|
@ -104,23 +104,49 @@ SYMBOL: ignore
|
|||
: encode-utf16 ( str -- seq )
|
||||
encode-utf16le bom-le swap append ;
|
||||
|
||||
: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
|
||||
|
||||
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
|
||||
|
||||
: decode-utf16 ( seq -- str )
|
||||
{
|
||||
{ [ bom-le ?head ] [ decode-utf16le ] }
|
||||
{ [ bom-be ?head ] [ decode-utf16be ] }
|
||||
{ [ start-utf16le? ] [ decode-utf16le ] }
|
||||
{ [ start-utf16be? ] [ decode-utf16be ] }
|
||||
{ [ t ] [ decode-error ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: utf16le ;
|
||||
: <utf16le> utf16le construct-delegate ;
|
||||
INSTANCE: utf16le encoding-stream
|
||||
|
||||
M: utf16le encode-string drop encode-utf16le ;
|
||||
M: utf16le decode-step drop decode-utf16le-step ;
|
||||
|
||||
TUPLE: utf16be ;
|
||||
: <utf16be> utf16be construct-delegate ;
|
||||
INSTANCE: utf16be encoding-stream
|
||||
|
||||
M: utf16be encode-string drop encode-utf16be ;
|
||||
M: utf16be decode-step drop decode-utf16be-step ;
|
||||
|
||||
TUPLE: utf16 encoding ;
|
||||
INSTANCE: utf16 encoding-stream
|
||||
M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary?
|
||||
M: utf16 set-underlying-stream delegate set-delegate ; ! necessary?
|
||||
|
||||
M: utf16 encode-string
|
||||
>r encode-utf16le r>
|
||||
dup utf16-encoding [ drop ]
|
||||
[ t swap set-utf16-encoding bom-le swap append ] if ;
|
||||
|
||||
: bom>le/be ( bom -- le/be )
|
||||
dup bom-le sequence= [ drop utf16le ] [
|
||||
bom-be sequence= [ utf16be ] [ decode-error ] if
|
||||
] if ;
|
||||
|
||||
: read-bom ( utf16 -- encoding )
|
||||
2 over delegate stream-read bom>le/be construct-empty
|
||||
[ swap set-utf16-encoding ] keep ;
|
||||
|
||||
M: utf16 decode-step
|
||||
! inefficient: checks if bom is done many times
|
||||
! This should transform itself into utf16be or utf16le after reading BOM
|
||||
dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
USING: io.encodings.utf8 tools.test sbufs kernel io
|
||||
USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
|
||||
sequences strings arrays unicode ;
|
||||
|
||||
: decode-utf8-w/stream ( array -- newarray )
|
||||
>sbuf dup reverse-here <utf8> contents >array ;
|
||||
>sbuf dup reverse-here utf8 <decoding> contents ;
|
||||
|
||||
: encode-utf8-w/stream ( array -- newarray )
|
||||
SBUF" " clone tuck <utf8> write >array ;
|
||||
SBUF" " clone tuck utf8 <encoding> stream-write >array ;
|
||||
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
|
|
@ -19,5 +19,5 @@ sequences strings arrays unicode ;
|
|||
|
||||
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
|
||||
[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8-w/stream ] unit-test
|
||||
|
|
|
|||
|
|
@ -78,7 +78,6 @@ SYMBOL: quad3
|
|||
! Interface for streams
|
||||
|
||||
TUPLE: utf8 ;
|
||||
: <utf8> utf8 construct-delegate ;
|
||||
INSTANCE: utf8 encoding-stream
|
||||
|
||||
M: utf8 encode-string drop encode-utf8 ;
|
||||
|
|
|
|||
|
|
@ -52,12 +52,12 @@ HELP: <file-appender>
|
|||
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: with-file-in
|
||||
HELP: with-file-reader
|
||||
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
|
||||
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
|
||||
{ $errors "Throws an error if the file is unreadable." } ;
|
||||
|
||||
HELP: with-file-out
|
||||
HELP: with-file-writer
|
||||
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
|
||||
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ USING: tools.test io.files io threads kernel continuations ;
|
|||
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path <file-writer> [
|
||||
"test-foo.txt" resource-path [
|
||||
"Hello world." print
|
||||
] with-stream
|
||||
] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ;
|
|||
|
||||
[ f ] [ "test-blah" resource-path exists? ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] unit-test
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] unit-test
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: io.files
|
||||
USING: io.backend io.files.private io hashtables kernel math
|
||||
memory namespaces sequences strings assocs arrays definitions
|
||||
system combinators splitting sbufs ;
|
||||
system combinators splitting sbufs continuations ;
|
||||
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
|
|
@ -116,11 +116,10 @@ HOOK: copy-file io-backend ( from to -- )
|
|||
M: object copy-file
|
||||
dup parent-directory make-directories
|
||||
<file-writer> [
|
||||
stdio get swap
|
||||
<file-reader> [
|
||||
stdio get swap stream-copy
|
||||
] with-stream
|
||||
] with-stream ;
|
||||
swap <file-reader> [
|
||||
swap stream-copy
|
||||
] with-disposal
|
||||
] with-disposal ;
|
||||
|
||||
: copy-directory ( from to -- )
|
||||
dup make-directories
|
||||
|
|
@ -144,12 +143,13 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
: file-lines ( path -- seq ) <file-reader> lines ;
|
||||
|
||||
: file-contents ( path -- str )
|
||||
dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
|
||||
dup <file-reader> swap file-length <sbuf>
|
||||
[ stream-copy ] keep >string ;
|
||||
|
||||
: with-file-in ( path quot -- )
|
||||
: with-file-reader ( path quot -- )
|
||||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: with-file-out ( path quot -- )
|
||||
: with-file-writer ( path quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
||||
: with-file-appender ( path quot -- )
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ IN: temporary
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
image <file-reader> [
|
||||
image [
|
||||
10 [ 65536 read drop ] times
|
||||
] with-stream
|
||||
] with-file-reader
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: tools.test io.streams.byte-array io.encodings.binary
|
||||
io.encodings.utf8 io kernel arrays strings ;
|
||||
|
||||
[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
|
||||
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
|
||||
|
||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
|
||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
|
||||
sequences io namespaces ;
|
||||
IN: io.streams.byte-array
|
||||
|
||||
: <byte-writer> ( encoding -- stream )
|
||||
512 <byte-vector> swap <encoding> ;
|
||||
|
||||
: with-byte-writer ( encoding quot -- byte-array )
|
||||
>r <byte-writer> r> [ stdio get ] compose with-stream*
|
||||
>byte-array ; inline
|
||||
|
||||
: <byte-reader> ( byte-array encoding -- stream )
|
||||
>r >byte-vector dup reverse-here r> <decoding> ;
|
||||
|
||||
: with-byte-reader ( byte-array encoding quot -- )
|
||||
>r <byte-reader> r> with-stream ; inline
|
||||
|
|
@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
|
|||
IN: temporary
|
||||
|
||||
[ "hello world" ] [
|
||||
"test.txt" resource-path <file-writer> [
|
||||
"test.txt" resource-path [
|
||||
"hello world" write
|
||||
] with-stream
|
||||
] with-file-writer
|
||||
|
||||
"test.txt" resource-path "rb" fopen <c-reader> contents
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@ ARTICLE: "io.streams.string" "String streams"
|
|||
{ $subsection <string-reader> }
|
||||
{ $subsection <string-writer> }
|
||||
"Utility combinators:"
|
||||
{ $subsection string-in }
|
||||
{ $subsection string-out } ;
|
||||
{ $subsection with-string-reader }
|
||||
{ $subsection with-string-writer } ;
|
||||
|
||||
ABOUT: "io.streams.string"
|
||||
|
||||
|
|
@ -15,7 +15,7 @@ HELP: <string-writer>
|
|||
{ $values { "stream" "an output stream" } }
|
||||
{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
|
||||
|
||||
HELP: string-out
|
||||
HELP: with-string-writer
|
||||
{ $values { "quot" quotation } { "str" string } }
|
||||
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
|
||||
|
||||
|
|
@ -24,6 +24,6 @@ HELP: <string-reader>
|
|||
{ $description "Creates a new stream for reading " { $snippet "str" } " from beginning to end." }
|
||||
{ $notes "The implementation exploits the ability of string buffers to respond to the input stream protocol by reading characters from the end of the buffer." } ;
|
||||
|
||||
HELP: string-in
|
||||
HELP: with-string-reader
|
||||
{ $values { "str" string } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ unit-test
|
|||
[ "" <string-reader> stream-readln ]
|
||||
unit-test
|
||||
|
||||
[ "xyzzy" ] [ [ "xyzzy" write ] string-out ] unit-test
|
||||
[ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test
|
||||
|
||||
[ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
|
||||
[ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,21 +2,21 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.string
|
||||
USING: io kernel math namespaces sequences sbufs strings
|
||||
generic splitting io.streams.plain io.streams.lines
|
||||
generic splitting io.streams.plain io.streams.lines growable
|
||||
continuations ;
|
||||
|
||||
M: sbuf dispose drop ;
|
||||
M: growable dispose drop ;
|
||||
|
||||
M: sbuf stream-write1 push ;
|
||||
M: sbuf stream-write push-all ;
|
||||
M: sbuf stream-flush drop ;
|
||||
M: growable stream-write1 push ;
|
||||
M: growable stream-write push-all ;
|
||||
M: growable stream-flush drop ;
|
||||
|
||||
: <string-writer> ( -- stream )
|
||||
512 <sbuf> <plain-writer> ;
|
||||
|
||||
: string-out ( quot -- str )
|
||||
<string-writer> [ call stdio get >string ] with-stream* ;
|
||||
inline
|
||||
: with-string-writer ( quot -- str )
|
||||
<string-writer> swap [ stdio get ] compose with-stream*
|
||||
>string ; inline
|
||||
|
||||
: format-column ( seq ? -- seq )
|
||||
[
|
||||
|
|
@ -37,36 +37,39 @@ M: plain-writer stream-write-table
|
|||
|
||||
M: plain-writer make-cell-stream 2drop <string-writer> ;
|
||||
|
||||
M: sbuf stream-read1 dup empty? [ drop f ] [ pop ] if ;
|
||||
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
|
||||
|
||||
: sbuf-read-until ( sbuf n -- str )
|
||||
tail-slice >string dup reverse-here ;
|
||||
: harden-as ( seq growble-exemplar -- newseq )
|
||||
underlying like ;
|
||||
|
||||
: growable-read-until ( growable n -- str )
|
||||
dupd tail-slice swap harden-as dup reverse-here ;
|
||||
|
||||
: find-last-sep swap [ memq? ] curry find-last drop ;
|
||||
|
||||
M: sbuf stream-read-until
|
||||
M: growable stream-read-until
|
||||
[ find-last-sep ] keep over [
|
||||
[ swap 1+ sbuf-read-until ] 2keep [ nth ] 2keep
|
||||
[ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
|
||||
set-length
|
||||
] [
|
||||
[ swap drop 0 sbuf-read-until f like f ] keep
|
||||
[ swap drop 0 growable-read-until f like f ] keep
|
||||
delete-all
|
||||
] if ;
|
||||
|
||||
M: sbuf stream-read
|
||||
M: growable stream-read
|
||||
dup empty? [
|
||||
2drop f
|
||||
] [
|
||||
[ length swap - 0 max ] keep
|
||||
[ swap sbuf-read-until ] 2keep
|
||||
[ swap growable-read-until ] 2keep
|
||||
set-length
|
||||
] if ;
|
||||
|
||||
M: sbuf stream-read-partial
|
||||
M: growable stream-read-partial
|
||||
stream-read ;
|
||||
|
||||
: <string-reader> ( str -- stream )
|
||||
>sbuf dup reverse-here <line-reader> ;
|
||||
|
||||
: string-in ( str quot -- )
|
||||
: with-string-reader ( str quot -- )
|
||||
>r <string-reader> r> with-stream ; inline
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ IN: temporary
|
|||
|
||||
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ [ :c ] string-out drop ] unit-test
|
||||
[ ] [ [ :c ] with-string-writer drop ] unit-test
|
||||
|
||||
: overflow-r 3 >r overflow-r ;
|
||||
|
||||
|
|
@ -80,8 +80,8 @@ IN: temporary
|
|||
[ 0 ] [ f [ 0 ] unless* ] unit-test
|
||||
[ t ] [ t [ "Hello" ] unless* ] unit-test
|
||||
|
||||
[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] string-out ] unit-test
|
||||
[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] string-out ] unit-test
|
||||
[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
|
||||
[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
|
||||
|
||||
[ f ] [ f (clone) ] unit-test
|
||||
[ -123 ] [ -123 (clone) ] unit-test
|
||||
|
|
|
|||
|
|
@ -513,4 +513,4 @@ SYMBOL: interactive-vocabs
|
|||
[
|
||||
parser-notes off
|
||||
[ [ eval ] keep ] try drop
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -67,19 +67,19 @@ unit-test
|
|||
[ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test
|
||||
|
||||
[ t ] [
|
||||
100 \ dup <array> [ pprint-short ] string-out
|
||||
100 \ dup <array> [ pprint-short ] with-string-writer
|
||||
"{" head?
|
||||
] unit-test
|
||||
|
||||
: foo ( a -- b ) dup * ; inline
|
||||
|
||||
[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ]
|
||||
[ [ \ foo see ] string-out ] unit-test
|
||||
[ [ \ foo see ] with-string-writer ] unit-test
|
||||
|
||||
: bar ( x -- y ) 2 + ;
|
||||
|
||||
[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ]
|
||||
[ [ \ bar see ] string-out ] unit-test
|
||||
[ [ \ bar see ] with-string-writer ] unit-test
|
||||
|
||||
: blah
|
||||
drop
|
||||
|
|
@ -105,7 +105,7 @@ unit-test
|
|||
|
||||
[ "drop ;" ] [
|
||||
\ blah f "inferred-effect" set-word-prop
|
||||
[ \ blah see ] string-out "\n" ?tail drop 6 tail*
|
||||
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
|
||||
] unit-test
|
||||
|
||||
: check-see ( expect name -- )
|
||||
|
|
@ -116,7 +116,7 @@ unit-test
|
|||
[ parse-fresh drop ] with-compilation-unit
|
||||
[
|
||||
"temporary" lookup see
|
||||
] string-out "\n" split 1 head*
|
||||
] with-string-writer "\n" split 1 head*
|
||||
] keep =
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -295,7 +295,7 @@ unit-test
|
|||
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
|
||||
dup eval
|
||||
"generic-decl-test" "temporary" lookup
|
||||
[ see ] string-out =
|
||||
[ see ] with-string-writer =
|
||||
] unit-test
|
||||
|
||||
[ [ + ] ] [
|
||||
|
|
|
|||
|
|
@ -63,9 +63,9 @@ combinators quotations ;
|
|||
|
||||
: pprint-use ( obj -- ) [ pprint* ] with-use ;
|
||||
|
||||
: unparse ( obj -- str ) [ pprint ] string-out ;
|
||||
: unparse ( obj -- str ) [ pprint ] with-string-writer ;
|
||||
|
||||
: unparse-use ( obj -- str ) [ pprint-use ] string-out ;
|
||||
: unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
|
||||
|
||||
: pprint-short ( obj -- )
|
||||
H{
|
||||
|
|
@ -192,7 +192,7 @@ M: pathname synopsis* pprint* ;
|
|||
0 margin set
|
||||
1 line-limit set
|
||||
[ synopsis* ] with-in
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
GENERIC: declarations. ( obj -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ SYMBOL: end
|
|||
{ "boolean" [ "\0" = not ] }
|
||||
{ "string" [ "" or ] }
|
||||
{ "integer" [ be> ] }
|
||||
{ "array" [ "" or [ read-array ] string-in ] }
|
||||
{ "array" [ "" or [ read-array ] with-string-reader ] }
|
||||
} case ;
|
||||
|
||||
: read-ber ( syntax -- object )
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ HINTS: random fixnum ;
|
|||
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
|
||||
n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
|
||||
drop
|
||||
] with-file-out
|
||||
] with-file-writer
|
||||
|
||||
] with-locals ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,8 +57,7 @@ IN: benchmark.knucleotide
|
|||
|
||||
: knucleotide ( -- )
|
||||
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
|
||||
<file-reader>
|
||||
[ read-input ] with-stream
|
||||
[ read-input ] with-file-reader
|
||||
process-input ;
|
||||
|
||||
MAIN: knucleotide
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ SYMBOL: cols
|
|||
] with-scope ;
|
||||
|
||||
: mandel-main ( -- )
|
||||
"mandel.ppm" resource-path <file-writer>
|
||||
[ mandel write ] with-stream ;
|
||||
"mandel.ppm" resource-path
|
||||
[ mandel write ] with-file-writer ;
|
||||
|
||||
MAIN: mandel-main
|
||||
|
|
|
|||
|
|
@ -171,6 +171,6 @@ DEFER: create ( level c r -- scene )
|
|||
|
||||
: raytracer-main
|
||||
"raytracer.pnm" resource-path
|
||||
<file-writer> [ run write ] with-stream ;
|
||||
[ run write ] with-file-writer ;
|
||||
|
||||
MAIN: raytracer-main
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: io io.files io.streams.duplex kernel sequences
|
||||
sequences.private strings vectors words memoize splitting
|
||||
hints unicode.case ;
|
||||
hints unicode.case continuations ;
|
||||
IN: benchmark.reverse-complement
|
||||
|
||||
MEMO: trans-map ( -- str )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: benchmark.sum-file
|
|||
readln [ string>number + sum-file-loop ] when* ;
|
||||
|
||||
: sum-file ( file -- )
|
||||
<file-reader> [ 0 sum-file-loop ] with-stream . ;
|
||||
[ 0 sum-file-loop ] with-file-reader . ;
|
||||
|
||||
: sum-file-main ( -- )
|
||||
home "sum-file-in.txt" path+ sum-file ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ bootstrap.image sequences io namespaces io.launcher math ;
|
|||
: compute-checksums ( -- )
|
||||
"checksums.txt" [
|
||||
boot-image-names [ dup write bl file>md5str print ] each
|
||||
] with-file-out ;
|
||||
] with-file-writer ;
|
||||
|
||||
: upload-images ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,11 +1,7 @@
|
|||
|
||||
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
|
||||
arrays system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave benchmark
|
||||
classes strings quotations words parser-combinators new-slots accessors
|
||||
assocs.lib smtp builder.util ;
|
||||
USING: kernel namespaces sequences splitting system combinators continuations
|
||||
parser io io.files io.launcher io.sockets prettyprint threads
|
||||
bootstrap.image benchmark vars bake smtp builder.util accessors ;
|
||||
|
||||
IN: builder
|
||||
|
||||
|
|
@ -48,7 +44,7 @@ VAR: stamp
|
|||
: git-id ( -- id )
|
||||
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
|
||||
|
||||
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
|
||||
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
|
||||
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
|
|
@ -132,9 +128,9 @@ SYMBOL: build-status
|
|||
"Did not pass test-all: " print "../test-all-vocabs" cat
|
||||
|
||||
"Benchmarks: " print
|
||||
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
|
||||
"../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
|
||||
|
||||
] with-file-out
|
||||
] with-file-writer
|
||||
|
||||
build-status on ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,17 +11,17 @@ USING: kernel namespaces sequences assocs builder continuations
|
|||
IN: builder.test
|
||||
|
||||
: do-load ( -- )
|
||||
try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
|
||||
try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
|
||||
|
||||
: do-tests ( -- )
|
||||
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
|
||||
run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
|
||||
|
||||
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
|
||||
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
|
||||
|
||||
: do-all ( -- )
|
||||
bootstrap-time get "../boot-time" [ . ] with-file-out
|
||||
[ do-load ] runtime "../load-time" [ . ] with-file-out
|
||||
[ do-tests ] runtime "../test-time" [ . ] with-file-out
|
||||
bootstrap-time get "../boot-time" [ . ] with-file-writer
|
||||
[ do-load ] runtime "../load-time" [ . ] with-file-writer
|
||||
[ do-tests ] runtime "../test-time" [ . ] with-file-writer
|
||||
do-benchmarks ;
|
||||
|
||||
MAIN: do-all
|
||||
|
|
@ -3,8 +3,8 @@ USING: kernel words namespaces classes parser continuations
|
|||
io io.files io.launcher io.sockets
|
||||
math math.parser
|
||||
combinators sequences splitting quotations arrays strings tools.time
|
||||
parser-combinators accessors assocs.lib
|
||||
combinators.cleave bake calendar new-slots ;
|
||||
parser-combinators new-slots accessors assocs.lib
|
||||
combinators.cleave bake calendar ;
|
||||
|
||||
IN: builder.util
|
||||
|
||||
|
|
@ -14,7 +14,7 @@ IN: builder.util
|
|||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
|
||||
: file>string ( file -- string ) [ stdio get contents ] with-file-reader ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -18,13 +18,7 @@ IN: bunny.model
|
|||
] when* ;
|
||||
|
||||
: parse-model ( stream -- vs is )
|
||||
[
|
||||
100000 <vector> 100000 <vector> (parse-model)
|
||||
] with-stream
|
||||
[
|
||||
over length # " vertices, " %
|
||||
dup length # " triangles" %
|
||||
] "" make print ;
|
||||
100000 <vector> 100000 <vector> (parse-model) ;
|
||||
|
||||
: n ( vs triple -- n )
|
||||
swap [ nth ] curry map
|
||||
|
|
@ -41,7 +35,8 @@ IN: bunny.model
|
|||
|
||||
: read-model ( stream -- model )
|
||||
"Reading model" print flush [
|
||||
<file-reader> parse-model [ normals ] 2keep 3array
|
||||
[ parse-model ] with-file-reader
|
||||
[ normals ] 2keep 3array
|
||||
] time ;
|
||||
|
||||
: model-path "bun_zipper.ply" ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays calendar kernel math sequences tools.test
|
||||
continuations system ;
|
||||
continuations system io.streams.string ;
|
||||
|
||||
[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
|
|
@ -141,3 +141,23 @@ continuations system ;
|
|||
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ -1-1/2 ] [
|
||||
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -347,7 +347,7 @@ M: timestamp year. ( timestamp -- )
|
|||
timestamp-second >fixnum write-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] string-out ;
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
|
|
@ -366,42 +366,63 @@ M: timestamp year. ( timestamp -- )
|
|||
dup (timestamp>string)
|
||||
" " write
|
||||
timestamp-gmt-offset write-gmt-offset
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup timestamp-year number>string write CHAR: - write1
|
||||
dup timestamp-month write-00 CHAR: - write1
|
||||
dup timestamp-day write-00 CHAR: T write1
|
||||
dup timestamp-hour write-00 CHAR: : write1
|
||||
dup timestamp-minute write-00 CHAR: : write1
|
||||
timestamp-second >fixnum write-00 CHAR: Z write1 ;
|
||||
dup timestamp-second >fixnum write-00
|
||||
timestamp-gmt-offset write-rfc3339-gmt-offset ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
>gmt [ (timestamp>rfc3339) ] string-out ;
|
||||
[ (timestamp>rfc3339) ] with-string-writer ;
|
||||
|
||||
: expect read1 assert= ;
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
: read-rfc3339-gmt-offset ( -- n )
|
||||
read1 dup CHAR: Z = [ drop 0 ] [
|
||||
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
|
||||
read-00
|
||||
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
|
||||
60 / + *
|
||||
] if ;
|
||||
|
||||
: (rfc3339>timestamp) ( -- timestamp )
|
||||
4 read string>number ! year
|
||||
CHAR: - expect
|
||||
2 read string>number ! month
|
||||
CHAR: - expect
|
||||
2 read string>number ! day
|
||||
CHAR: T expect
|
||||
2 read string>number ! hour
|
||||
CHAR: : expect
|
||||
2 read string>number ! minute
|
||||
CHAR: : expect
|
||||
2 read string>number ! second
|
||||
0 <timestamp> ;
|
||||
read-0000 ! year
|
||||
"-" expect
|
||||
read-00 ! month
|
||||
"-" expect
|
||||
read-00 ! day
|
||||
"Tt" expect
|
||||
read-00 ! hour
|
||||
":" expect
|
||||
read-00 ! minute
|
||||
":" expect
|
||||
read-00 ! second
|
||||
read-rfc3339-gmt-offset ! timezone
|
||||
<timestamp> ;
|
||||
|
||||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[ (rfc3339>timestamp) ] string-in ;
|
||||
[ (rfc3339>timestamp) ] with-string-reader ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
|
|
@ -413,7 +434,7 @@ M: timestamp year. ( timestamp -- )
|
|||
] [
|
||||
timestamp-year number>string 5 32 pad-left write
|
||||
] if
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
: day-offset ( timestamp m -- timestamp n )
|
||||
over day-of-week - ; inline
|
||||
|
|
|
|||
|
|
@ -461,9 +461,9 @@ M: cpu reset ( cpu -- )
|
|||
: load-rom ( filename cpu -- )
|
||||
#! Load the contents of the file into ROM.
|
||||
#! (address 0x0000-0x1FFF).
|
||||
cpu-ram swap <file-reader> [
|
||||
cpu-ram swap [
|
||||
0 swap (load-rom)
|
||||
] with-stream ;
|
||||
] with-file-reader ;
|
||||
|
||||
SYMBOL: rom-root
|
||||
|
||||
|
|
@ -477,9 +477,9 @@ SYMBOL: rom-root
|
|||
#! file path shoul dbe relative to the '/roms' resource path.
|
||||
rom-dir [
|
||||
cpu-ram [
|
||||
swap first2 rom-dir swap path+ <file-reader> [
|
||||
swap first2 rom-dir swap path+ [
|
||||
swap (load-rom)
|
||||
] with-stream
|
||||
] with-file-reader
|
||||
] curry each
|
||||
] [
|
||||
!
|
||||
|
|
|
|||
|
|
@ -7,11 +7,11 @@ math.parser ;
|
|||
IN: editors.jedit
|
||||
|
||||
: jedit-server-info ( -- port auth )
|
||||
home "/.jedit/server" path+ <file-reader> [
|
||||
home "/.jedit/server" path+ [
|
||||
readln drop
|
||||
readln string>number
|
||||
readln string>number
|
||||
] with-stream ;
|
||||
] with-file-reader ;
|
||||
|
||||
: make-jedit-request ( files -- code )
|
||||
[
|
||||
|
|
@ -21,7 +21,7 @@ IN: editors.jedit
|
|||
"new String[] {" write
|
||||
[ pprint "," write ] each
|
||||
"null});\n" write
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
: send-jedit-request ( request -- )
|
||||
jedit-server-info swap "localhost" swap <inet> <client> [
|
||||
|
|
|
|||
|
|
@ -365,7 +365,7 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
(compile)
|
||||
")" ,
|
||||
] { } make [ write ] each
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
: fjsc-compile* ( string -- string )
|
||||
'statement' parse parse-result-ast fjsc-compile ;
|
||||
|
|
@ -379,5 +379,5 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
: fjsc-literal ( ast -- string )
|
||||
[
|
||||
[ (literal) ] { } make [ write ] each
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
|
|
|
|||
|
|
@ -59,17 +59,17 @@ TUPLE: bitmap magic size reserved offset header-length width
|
|||
dup color-index-length read swap set-bitmap-color-index ;
|
||||
|
||||
: load-bitmap ( path -- bitmap )
|
||||
<file-reader> [
|
||||
[
|
||||
T{ bitmap } clone
|
||||
dup parse-file-header
|
||||
dup parse-bitmap-header
|
||||
dup parse-bitmap
|
||||
] with-stream
|
||||
] with-file-reader
|
||||
dup bitmap-color-index over bitmap-bit-count
|
||||
raw-bitmap>string >byte-array over set-bitmap-array ;
|
||||
|
||||
: save-bitmap ( bitmap path -- )
|
||||
<file-writer> [
|
||||
[
|
||||
"BM" write
|
||||
dup bitmap-array length 14 + 40 + 4 >le write
|
||||
0 4 >le write
|
||||
|
|
@ -88,7 +88,7 @@ TUPLE: bitmap magic size reserved offset header-length width
|
|||
dup bitmap-color-important 4 >le write
|
||||
dup bitmap-rgb-quads write
|
||||
bitmap-color-index write
|
||||
] with-stream ;
|
||||
] with-file-writer ;
|
||||
|
||||
M: bitmap draw-image ( bitmap -- )
|
||||
dup bitmap-height 0 < [
|
||||
|
|
|
|||
|
|
@ -195,7 +195,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Read 1024 bytes from a file:"
|
||||
{ $code
|
||||
"\"data.bin\" <file-reader> [ 1024 read ] with-stream"
|
||||
"\"data.bin\" [ 1024 read ] with-file-reader"
|
||||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
|
||||
{ $code
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ IN: help.lint
|
|||
] each ;
|
||||
|
||||
: check-rendering ( word element -- )
|
||||
[ help ] string-out drop ;
|
||||
[ help ] with-string-writer drop ;
|
||||
|
||||
: all-word-help ( words -- seq )
|
||||
[ word-help ] subset ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ TUPLE: blahblah quux ;
|
|||
test-slot blahblah $spec-reader-values
|
||||
] unit-test
|
||||
|
||||
[ "an int" ] [ [ { "int" } $instance ] string-out ] unit-test
|
||||
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
|
||||
|
||||
[ ] [ \ blahblah-quux help ] unit-test
|
||||
[ ] [ \ set-blahblah-quux help ] unit-test
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ PRIVATE>
|
|||
[
|
||||
dup length header.
|
||||
16 <sliced-groups> [ line. ] each-index
|
||||
] string-out ;
|
||||
] with-string-writer ;
|
||||
|
||||
: hexdump. ( seq -- )
|
||||
hexdump write ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: temporary
|
|||
USING: tools.test html html.elements io.streams.string ;
|
||||
|
||||
: make-html-string
|
||||
[ with-html-stream ] string-out ;
|
||||
[ with-html-stream ] with-string-writer ;
|
||||
|
||||
[ "<a href='h&o'>" ]
|
||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ namespaces tools.test xml.writer sbufs sequences html.private ;
|
|||
IN: temporary
|
||||
|
||||
: make-html-string
|
||||
[ with-html-stream ] string-out ;
|
||||
[ with-html-stream ] with-string-writer ;
|
||||
|
||||
[ ] [
|
||||
512 <sbuf> <html-stream> drop
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: temporary
|
|||
"extra/http/server/templating/test/" swap append
|
||||
[
|
||||
".fhtml" append resource-path
|
||||
[ run-template-file ] string-out
|
||||
[ run-template-file ] with-string-writer
|
||||
] keep
|
||||
".html" append resource-path file-contents = ;
|
||||
|
||||
|
|
|
|||
|
|
@ -93,4 +93,4 @@ DEFER: <% delimiter
|
|||
swap path+ run-template-file ;
|
||||
|
||||
: template-convert ( infile outfile -- )
|
||||
<file-writer> [ run-template-file ] with-stream ;
|
||||
[ run-template-file ] with-file-writer ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
! Copyright (C) 2007 Adam Wendt.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
|
||||
USING: arrays combinators io io.binary io.files io.paths
|
||||
io.encodings.utf16 kernel math math.parser namespaces sequences
|
||||
|
|
@ -121,7 +120,7 @@ C: <extended-header> extended-header
|
|||
id3v2? [ read-id3v2 ] [ f ] if ;
|
||||
|
||||
: id3v2 ( filename -- tag/f )
|
||||
<file-reader> [ read-tag ] with-stream ;
|
||||
[ read-tag ] with-file-reader ;
|
||||
|
||||
: file? ( path -- ? )
|
||||
stat 3drop not ;
|
||||
|
|
@ -136,7 +135,7 @@ C: <extended-header> extended-header
|
|||
[ mp3? ] subset ;
|
||||
|
||||
: id3? ( file -- ? )
|
||||
<file-reader> [ id3v2? ] with-stream ;
|
||||
[ id3v2? ] with-file-reader ;
|
||||
|
||||
: id3s ( files -- id3s )
|
||||
[ id3? ] subset ;
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ M: math-inverse inverse
|
|||
[ drop swap-inverse ] [ pull-inverse ] if ;
|
||||
|
||||
M: pop-inverse inverse
|
||||
[ "pop-length" word-prop cut-slice swap ] keep
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ] keep
|
||||
"pop-inverse" word-prop compose call ;
|
||||
|
||||
: (undo) ( revquot -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ;
|
|||
IN: temporary
|
||||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "mmap-test-file.txt" resource-path <file-writer> [ "12345" write ] with-stream ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test
|
||||
|
|
|
|||
|
|
@ -131,16 +131,16 @@ client-addr <datagram>
|
|||
! Invalid parameter tests
|
||||
|
||||
[
|
||||
image <file-reader> [ stdio get accept ] with-stream
|
||||
image [ stdio get accept ] with-file-reader
|
||||
] must-fail
|
||||
|
||||
[
|
||||
image <file-reader> [ stdio get receive ] with-stream
|
||||
image [ stdio get receive ] with-file-reader
|
||||
] must-fail
|
||||
|
||||
[
|
||||
image <file-reader> [
|
||||
image [
|
||||
B{ 1 2 } server-addr
|
||||
stdio get send
|
||||
] with-stream
|
||||
] with-file-reader
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ GENERIC: json-print ( obj -- )
|
|||
|
||||
: >json ( obj -- string )
|
||||
#! Returns a string representing the factor object in JSON format
|
||||
[ json-print ] string-out ;
|
||||
[ json-print ] with-string-writer ;
|
||||
|
||||
M: f json-print ( f -- )
|
||||
drop "false" write ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ SYMBOL: insomniac-recipients
|
|||
|
||||
: ?analyze-log ( service word-names -- string/f )
|
||||
>r log-path 1 log# dup exists? [
|
||||
file-lines r> [ analyze-log ] string-out
|
||||
file-lines r> [ analyze-log ] with-string-writer
|
||||
] [
|
||||
r> 2drop f
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ PRIVATE>
|
|||
|
||||
: (log-error) ( object word level -- )
|
||||
log-service get [
|
||||
>r >r [ print-error ] string-out r> r> log-message
|
||||
>r >r [ print-error ] with-string-writer r> r> log-message
|
||||
] [
|
||||
2drop rethrow
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -13,6 +13,6 @@ IN: msxml-to-csv
|
|||
] map ;
|
||||
|
||||
: msxml>csv ( infile outfile -- )
|
||||
<file-writer> [
|
||||
[
|
||||
file>xml (msxml>csv) print-csv
|
||||
] with-stream ;
|
||||
] with-file-writer ;
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ USING: io io.streams.string kernel namespaces pack strings tools.test ;
|
|||
<string-reader> [ "int" read-native ] with-stream
|
||||
] unit-test
|
||||
|
||||
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] string-in ] unit-test
|
||||
[ f ] [ "" [ read-c-string ] string-in ] unit-test
|
||||
[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test
|
||||
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test
|
||||
[ f ] [ "" [ read-c-string ] with-string-reader ] unit-test
|
||||
[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,6 @@ MEMO: any-char-parser ( -- parser )
|
|||
any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ;
|
||||
|
||||
: replace ( string parser -- result )
|
||||
[ (replace) [ tree-write ] each ] string-out ;
|
||||
[ (replace) [ tree-write ] each ] with-string-writer ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ C: <entry> entry
|
|||
[
|
||||
{ "content" "summary" } any-tag-named
|
||||
dup tag-children [ string? not ] contains?
|
||||
[ tag-children [ write-chunk ] string-out ]
|
||||
[ tag-children [ write-chunk ] with-string-writer ]
|
||||
[ children>string ] if
|
||||
] keep
|
||||
{ "published" "updated" "issued" "modified" } any-tag-named
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ HELP: (serialize)
|
|||
}
|
||||
{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] string-out\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] string-in eq? ." "t" }
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
|
||||
}
|
||||
{ $see-also deserialize (deserialize) serialize with-serialized } ;
|
||||
|
||||
|
|
@ -17,7 +17,7 @@ HELP: (deserialize)
|
|||
}
|
||||
{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] string-out\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] string-in eq? ." "t" }
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
|
||||
}
|
||||
{ $see-also (serialize) deserialize serialize with-serialized } ;
|
||||
|
||||
|
|
@ -26,7 +26,7 @@ HELP: with-serialized
|
|||
}
|
||||
{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] string-out\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] string-in eq? ." "t" }
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
|
||||
}
|
||||
{ $see-also (serialize) (deserialize) serialize deserialize } ;
|
||||
|
||||
|
|
@ -35,7 +35,7 @@ HELP: serialize
|
|||
}
|
||||
{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] string-out\n\n[ deserialize ] string-in ." "{ 1 2 }" }
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
|
||||
}
|
||||
{ $see-also deserialize (deserialize) (serialize) with-serialized } ;
|
||||
|
||||
|
|
@ -44,6 +44,6 @@ HELP: deserialize
|
|||
}
|
||||
{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] string-out\n\n[ deserialize ] string-in ." "{ 1 2 }" }
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
|
||||
}
|
||||
{ $see-also (serialize) deserialize (deserialize) with-serialized } ;
|
||||
|
|
|
|||
|
|
@ -38,8 +38,8 @@ C: <serialize-test> serialize-test
|
|||
|
||||
: check-serialize-1 ( obj -- ? )
|
||||
dup class .
|
||||
dup [ serialize ] string-out
|
||||
[ deserialize ] string-in = ;
|
||||
dup [ serialize ] with-string-writer
|
||||
[ deserialize ] with-string-reader = ;
|
||||
|
||||
: check-serialize-2 ( obj -- ? )
|
||||
dup number? over wrapper? or [
|
||||
|
|
@ -47,8 +47,8 @@ C: <serialize-test> serialize-test
|
|||
] [
|
||||
dup class .
|
||||
dup 2array
|
||||
[ serialize ] string-out
|
||||
[ deserialize ] string-in
|
||||
[ serialize ] with-string-writer
|
||||
[ deserialize ] with-string-reader
|
||||
first2 eq?
|
||||
] if ;
|
||||
|
||||
|
|
@ -63,7 +63,7 @@ C: <serialize-test> serialize-test
|
|||
[
|
||||
dup (serialize) (serialize)
|
||||
] with-serialized
|
||||
] string-out [
|
||||
] with-string-writer [
|
||||
deserialize-sequence all-eq?
|
||||
] string-in
|
||||
] with-string-reader
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: temporary
|
|||
[ { "hello" "." "world" } validate-message ] must-fail
|
||||
|
||||
[ "hello\r\nworld\r\n.\r\n" ] [
|
||||
{ "hello" "world" } [ send-body ] string-out
|
||||
{ "hello" "world" } [ send-body ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "500 syntax error" check-response ] must-fail
|
||||
|
|
@ -20,17 +20,17 @@ IN: temporary
|
|||
[ ] [ "220 success" check-response ] unit-test
|
||||
|
||||
[ "220 success" ] [
|
||||
"220 success" [ receive-response ] string-in
|
||||
"220 success" [ receive-response ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ "220 the end" ] [
|
||||
"220-a multiline response\r\n250-another line\r\n220 the end"
|
||||
[ receive-response ] string-in
|
||||
[ receive-response ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"220-a multiline response\r\n250-another line\r\n220 the end"
|
||||
[ get-ok ] string-in
|
||||
[ get-ok ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ SYMBOL: filename
|
|||
0 over set-tar-header-size
|
||||
0 over set-tar-header-checksum
|
||||
] [
|
||||
[ read-tar-header ] string-in
|
||||
[ read-tar-header ] with-string-reader
|
||||
[ tar-header-checksum = [
|
||||
\ checksum-error construct-empty throw
|
||||
] unless
|
||||
|
|
@ -241,4 +241,4 @@ TUPLE: unimplemented-typeflag header ;
|
|||
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
|
||||
global [ "Expanding to: " write base-dir get . flush ] bind
|
||||
(parse-tar)
|
||||
] with-file-out ;
|
||||
] with-file-writer ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,26 @@
|
|||
USING: tools.test tools.annotations ;
|
||||
USING: tools.test tools.annotations math parser ;
|
||||
IN: temporary
|
||||
|
||||
: foo ;
|
||||
\ foo watch
|
||||
|
||||
[ ] [ foo ] unit-test
|
||||
|
||||
! erg's bug
|
||||
GENERIC: some-generic
|
||||
|
||||
M: integer some-generic 1+ ;
|
||||
|
||||
[ 4 ] [ 3 some-generic ] unit-test
|
||||
|
||||
[ ] [ \ some-generic watch ] unit-test
|
||||
|
||||
[ 4 ] [ 3 some-generic ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test
|
||||
|
||||
[ 2 ] [ 3 some-generic ] unit-test
|
||||
|
||||
[ ] [ \ some-generic reset ] unit-test
|
||||
|
||||
[ 2 ] [ 3 some-generic ] unit-test
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
|
|||
: set-vocab-file-contents ( seq vocab name -- )
|
||||
dupd vocab-path+ [
|
||||
?resource-path
|
||||
[ [ print ] each ] with-file-out
|
||||
[ [ print ] each ] with-file-writer
|
||||
] [
|
||||
"The " swap vocab-name
|
||||
" vocabulary was not loaded from the file system"
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ M: pair make-disassemble-cmd
|
|||
current-process-handle number>string print
|
||||
"disassemble " write
|
||||
[ number>string write bl ] each
|
||||
] with-file-out ;
|
||||
] with-file-writer ;
|
||||
|
||||
: run-gdb ( -- lines )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -81,11 +81,11 @@ IN: temporary
|
|||
] unit-test
|
||||
|
||||
[ { "hi\n" } ] [
|
||||
[ [ "hi" print ] string-out ] test-interpreter
|
||||
[ [ "hi" print ] with-string-writer ] test-interpreter
|
||||
] unit-test
|
||||
|
||||
[ { "4\n" } ] [
|
||||
[ [ 2 2 + number>string print ] string-out ] test-interpreter
|
||||
[ [ 2 2 + number>string print ] with-string-writer ] test-interpreter
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 3 } ] [
|
||||
|
|
@ -105,7 +105,7 @@ IN: temporary
|
|||
[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test
|
||||
|
||||
[ { "{ 1 2 3 }\n" } ] [
|
||||
[ [ { 1 2 3 } . ] string-out ] test-interpreter
|
||||
[ [ { 1 2 3 } . ] with-string-writer ] test-interpreter
|
||||
] unit-test
|
||||
|
||||
[ { } ] [
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@ quotations io strings words definitions ;
|
|||
IN: tools.profiler
|
||||
|
||||
ARTICLE: "profiling" "Profiling code"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words and methods which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
|
||||
{ $list
|
||||
"The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
|
||||
{ "Calls to " { $link POSTPONE: inline } " words are not counted.." }
|
||||
{ "Calls to methods which were inlined as a result of type inference are not counted." }
|
||||
"Tail-recursive loops will only count the initial invocation of the word, not every tail call."
|
||||
}
|
||||
"Quotations can be passed to a combinator which calls them with the profiler enabled:"
|
||||
|
|
@ -15,7 +16,8 @@ ARTICLE: "profiling" "Profiling code"
|
|||
{ $subsection profile. }
|
||||
{ $subsection vocab-profile. }
|
||||
{ $subsection usage-profile. }
|
||||
{ $subsection vocabs-profile. } ;
|
||||
{ $subsection vocabs-profile. }
|
||||
{ $subsection method-profile. } ;
|
||||
|
||||
ABOUT: "profiling"
|
||||
|
||||
|
|
@ -48,6 +50,9 @@ HELP: usage-profile.
|
|||
HELP: vocabs-profile.
|
||||
{ $description "Print a table of cumilative call counts for each vocabulary. Vocabularies whose words were not called are supressed from the output." } ;
|
||||
|
||||
HELP: method-profile.
|
||||
{ $description "Print a table of cumilative call counts for each method. Methods which were not called are supressed from the output." } ;
|
||||
|
||||
HELP: profiling ( ? -- )
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Internal primitive to switch on call counting. This word should not be used; instead use " { $link profile } "." } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: words sequences math prettyprint kernel arrays io
|
||||
io.styles namespaces assocs kernel.private strings combinators
|
||||
sorting math.parser vocabs definitions tools.profiler.private
|
||||
continuations ;
|
||||
continuations generic ;
|
||||
IN: tools.profiler
|
||||
|
||||
: profile ( quot -- )
|
||||
|
|
@ -28,6 +28,11 @@ C: <vocab-profile> vocab-profile
|
|||
M: string (profile.)
|
||||
dup <vocab-profile> write-object ;
|
||||
|
||||
M: method-body (profile.)
|
||||
"method" word-prop
|
||||
dup method-specializer over method-generic 2array synopsis
|
||||
swap method-generic <usage-profile> write-object ;
|
||||
|
||||
: counter. ( obj n -- )
|
||||
[
|
||||
>r [ (profile.) ] with-cell r>
|
||||
|
|
@ -63,3 +68,7 @@ M: string (profile.)
|
|||
[ "predicating" word-prop not ] subset
|
||||
[ profile-counter ] map sum
|
||||
] { } map>assoc counters. ;
|
||||
|
||||
: method-profile. ( -- )
|
||||
all-words [ subwords ] map concat
|
||||
counters counters. ;
|
||||
|
|
|
|||
|
|
@ -13,4 +13,4 @@ IN: tools.test.ui
|
|||
swap slip
|
||||
ungraft notify-queued
|
||||
] with-variable
|
||||
] string-out print ;
|
||||
] with-string-writer print ;
|
||||
|
|
|
|||
|
|
@ -27,5 +27,5 @@ testing "testing" "hey" {
|
|||
[ "C+x" ] [
|
||||
[
|
||||
{ $command testing "testing" com-test-1 } print-element
|
||||
] string-out
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -191,7 +191,7 @@ M: mock-gadget ungraft*
|
|||
] with-variable ;
|
||||
|
||||
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
|
||||
] string-out print
|
||||
] with-string-writer print
|
||||
|
||||
\ <gadget> must-infer
|
||||
\ unparent must-infer
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ tools.test.ui models ;
|
|||
|
||||
: test-gadget-text
|
||||
dup make-pane gadget-text
|
||||
swap string-out "\n" ?tail drop "\n" ?tail drop = ;
|
||||
swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ;
|
||||
|
||||
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
|
||||
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
|
||||
|
|
|
|||
|
|
@ -10,5 +10,5 @@ tuples ;
|
|||
[ "+" ] [
|
||||
[
|
||||
\ + f \ pprint <command-button> dup button-quot call
|
||||
] string-out
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ io.streams.string math help help.markup ;
|
|||
3 "op" get operation-command command-quot
|
||||
] unit-test
|
||||
|
||||
[ "3" ] [ [ 3 "op" get invoke-command ] string-out ] unit-test
|
||||
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
|
||||
|
||||
[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
|
||||
"op" set
|
||||
|
|
@ -20,9 +20,9 @@ io.streams.string math help help.markup ;
|
|||
[
|
||||
"4" <editor> [ set-editor-string ] keep
|
||||
"op" get invoke-command
|
||||
] string-out
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ { $operations \ + } print-element ] string-out drop
|
||||
[ { $operations \ + } print-element ] with-string-writer drop
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -24,6 +24,9 @@ TUPLE: profiler-gadget pane ;
|
|||
: com-vocabs-profile ( gadget -- )
|
||||
[ vocabs-profile. ] with-profiler-pane ;
|
||||
|
||||
: com-method-profile ( gadget -- )
|
||||
[ method-profile. ] with-profiler-pane ;
|
||||
|
||||
: profiler-help "ui-profiler" help-window ;
|
||||
|
||||
\ profiler-help H{ { +nullary+ t } } define-command
|
||||
|
|
@ -31,6 +34,7 @@ TUPLE: profiler-gadget pane ;
|
|||
profiler-gadget "toolbar" f {
|
||||
{ f com-full-profile }
|
||||
{ f com-vocabs-profile }
|
||||
{ f com-method-profile }
|
||||
{ T{ key-down f f "F1" } profiler-help }
|
||||
} define-command-map
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
USING: tools.test io.streams.string xml.generator xml.writer ;
|
||||
[ "<html><body><a href=\"blah\"/></body></html>" ]
|
||||
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] string-out ] unit-test
|
||||
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
|
|||
[ assemble-data ] map ;
|
||||
|
||||
[ "http://www.foxnews.com/oreilly/" ] [
|
||||
"extra/xml/test/soap.xml" resource-path file>xml
|
||||
"extra/xml/tests/soap.xml" resource-path file>xml
|
||||
parse-result first first
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
|
|||
|
||||
! This is insufficient
|
||||
SYMBOL: xml-file
|
||||
[ ] [ "extra/xml/test/test.xml" resource-path
|
||||
[ ] [ "extra/xml/tests/test.xml" resource-path
|
||||
[ file>xml ] with-html-entities xml-file set ] unit-test
|
||||
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
|
||||
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ M: instruction write-item
|
|||
write-xml nl ;
|
||||
|
||||
: xml>string ( xml -- string )
|
||||
[ write-xml ] string-out ;
|
||||
[ write-xml ] with-string-writer ;
|
||||
|
||||
: with-xml-pprint ( sensitive-tags quot -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ IN: factorbot-commands
|
|||
] if ;
|
||||
|
||||
: memory ( text -- )
|
||||
drop [ room. ] string-out multiline-respond ;
|
||||
drop [ room. ] with-string-writer multiline-respond ;
|
||||
|
||||
: quit ( text -- )
|
||||
drop speaker get "slava" = [ disconnect ] when ;
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ M: number tree-write ( char -- ) write1 ;
|
|||
|
||||
: farkup ( str -- html )
|
||||
'farkup' parse dup nil?
|
||||
[ error ] [ car parse-result-parsed [ tree-write ] string-out ] if ;
|
||||
[ error ] [ car parse-result-parsed [ tree-write ] with-string-writer ] if ;
|
||||
|
||||
! useful debugging code below
|
||||
|
||||
|
|
@ -83,4 +83,4 @@ M: number tree-write ( char -- ) write1 ;
|
|||
: farkup-parsed ( wiki -- all-parses )
|
||||
! for debugging and optimization only
|
||||
'farkup' parse list>array
|
||||
[ parse-result-parsed [ tree-write ] string-out ] map ;
|
||||
[ parse-result-parsed [ tree-write ] with-string-writer ] map ;
|
||||
|
|
@ -148,13 +148,13 @@ DEFER: name>user
|
|||
[ httpd ] in-thread drop ;
|
||||
|
||||
: onigiri-dump ( path -- )
|
||||
<file-writer> [
|
||||
[
|
||||
[
|
||||
entry get-global serialize
|
||||
meta get-global serialize
|
||||
user get-global serialize
|
||||
] with-serialized
|
||||
] with-stream ;
|
||||
] with-file-writer ;
|
||||
|
||||
: onigiri-boot ( path -- )
|
||||
<file-reader> [
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ IN: temporary
|
|||
SYMBOL: mmap "mmap-test.txt" \ mmap set
|
||||
|
||||
[ \ mmap get delete-file ] catch drop
|
||||
\ mmap get <file-writer> [
|
||||
\ mmap get [
|
||||
"Four" write
|
||||
] with-stream
|
||||
] with-file-writer
|
||||
|
||||
\ mmap get [
|
||||
>r CHAR: R r> mmap-address 3 set-alien-unsigned-1
|
||||
|
|
|
|||
Loading…
Reference in New Issue