Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-02-16 18:15:30 -06:00
commit edee81ec54
88 changed files with 373 additions and 251 deletions

View File

@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
data-gc ; data-gc ;
[ "Hello world" ] [ [ "Hello world" ] [
[ callback-4 callback_test_1 ] string-out [ callback-4 callback_test_1 ] with-string-writer
] unit-test ] unit-test
: callback-5 : callback-5

View File

@ -416,7 +416,7 @@ M: curry '
"Writing image to " write "Writing image to " write
architecture get boot-image-name resource-path architecture get boot-image-name resource-path
dup write "..." print flush dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ; [ (write-image) ] with-file-writer ;
PRIVATE> PRIVATE>

View File

@ -63,7 +63,7 @@ UNION: bah fixnum alien ;
! Test generic see and parsing ! Test generic see and parsing
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] [ "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 ! Test redefinition of classes
UNION: union-1 fixnum float ; UNION: union-1 fixnum float ;

View File

@ -30,6 +30,7 @@ M: generic definer drop f f ;
M: generic definition drop f ; M: generic definition drop f ;
: make-generic ( word -- ) : make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ; dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ; TUPLE: method word def specializer generic loc ;

View File

@ -8,4 +8,4 @@ f describe
H{ } describe H{ } describe
H{ } describe H{ } describe
[ "fixnum instance\n" ] [ [ 3 describe ] string-out ] unit-test [ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test

View File

@ -1,6 +1,3 @@
USING: kernel io.encodings ; USING: kernel io.encodings ;
TUPLE: binary ; TUPLE: binary ;
M: binary init-decoding drop ;
M: binary init-encoding drop ;

View File

@ -53,27 +53,17 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
>r swap start-decoding r> >r swap start-decoding r>
decode-read-loop ; decode-read-loop ;
GENERIC: init-decoding ( stream encoding -- decoded-stream )
: <decoding> ( stream decoding-class -- decoded-stream ) : <decoding> ( stream decoding-class -- decoded-stream )
construct-empty init-decoding <line-reader> ; construct-delegate <line-reader> ;
GENERIC: init-encoding ( stream encoding -- encoded-stream )
: <encoding> ( stream encoding-class -- encoded-stream ) : <encoding> ( stream encoding-class -- encoded-stream )
construct-empty init-encoding <plain-writer> ; construct-delegate <plain-writer> ;
GENERIC: encode-string ( string encoding -- byte-array ) GENERIC: encode-string ( string encoding -- byte-array )
M: tuple-class encode-string construct-empty encode-string ; M: tuple-class encode-string construct-empty encode-string ;
MIXIN: encoding-stream 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-read1 1 swap stream-read ;
M: encoding-stream stream-read M: encoding-stream stream-read
@ -93,3 +83,13 @@ M: encoding-stream stream-write
[ encode-string ] keep delegate stream-write ; [ encode-string ] keep delegate stream-write ;
M: encoding-stream dispose delegate dispose ; 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 ;

View File

@ -1,19 +1,10 @@
USING: io io.encodings strings kernel ; USING: io io.encodings strings kernel ;
IN: io.encodings.latin1 IN: io.encodings.latin1
TUPLE: latin1 stream ; TUPLE: latin1 ;
M: latin1 init-decoding tuck set-latin1-stream ; M: latin1 stream-read delegate stream-read >string ;
M: latin1 init-encoding drop ;
M: latin1 stream-read1 M: latin1 stream-read-until delegate stream-read-until >string ;
latin1-stream stream-read1 ;
M: latin1 stream-read M: latin1 stream-read-partial delegate stream-read-partial >string ;
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 ;

View File

@ -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 : decode-w/stream ( array encoding -- newarray )
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test >r >sbuf dup reverse-here r> <decoding> contents >array ;
[ { 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
[ 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 [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test [ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test [ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] 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

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting ; io.encodings combinators splitting io byte-arrays ;
IN: io.encodings.utf16 IN: io.encodings.utf16
SYMBOL: double SYMBOL: double
@ -104,23 +104,49 @@ SYMBOL: ignore
: encode-utf16 ( str -- seq ) : encode-utf16 ( str -- seq )
encode-utf16le bom-le swap append ; encode-utf16le bom-le swap append ;
: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
: decode-utf16 ( seq -- str ) : decode-utf16 ( seq -- str )
{ {
{ [ bom-le ?head ] [ decode-utf16le ] } { [ start-utf16le? ] [ decode-utf16le ] }
{ [ bom-be ?head ] [ decode-utf16be ] } { [ start-utf16be? ] [ decode-utf16be ] }
{ [ t ] [ decode-error ] } { [ t ] [ decode-error ] }
} cond ; } cond ;
TUPLE: utf16le ; TUPLE: utf16le ;
: <utf16le> utf16le construct-delegate ;
INSTANCE: utf16le encoding-stream INSTANCE: utf16le encoding-stream
M: utf16le encode-string drop encode-utf16le ; M: utf16le encode-string drop encode-utf16le ;
M: utf16le decode-step drop decode-utf16le-step ; M: utf16le decode-step drop decode-utf16le-step ;
TUPLE: utf16be ; TUPLE: utf16be ;
: <utf16be> utf16be construct-delegate ;
INSTANCE: utf16be encoding-stream INSTANCE: utf16be encoding-stream
M: utf16be encode-string drop encode-utf16be ; M: utf16be encode-string drop encode-utf16be ;
M: utf16be decode-step drop decode-utf16be-step ; 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 ;

View File

@ -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 ; sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray ) : 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 ) : 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 [ { 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 [ { 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: 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: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8-w/stream ] unit-test

View File

@ -78,7 +78,6 @@ SYMBOL: quad3
! Interface for streams ! Interface for streams
TUPLE: utf8 ; TUPLE: utf8 ;
: <utf8> utf8 construct-delegate ;
INSTANCE: utf8 encoding-stream INSTANCE: utf8 encoding-stream
M: utf8 encode-string drop encode-utf8 ; M: utf8 encode-string drop encode-utf8 ;

View File

@ -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." } { $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." } ; { $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" } } { $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ; { $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" } } { $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } { $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." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;

View File

@ -6,9 +6,9 @@ USING: tools.test io.files io threads kernel continuations ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [ [ ] [
"test-foo.txt" resource-path <file-writer> [ "test-foo.txt" resource-path [
"Hello world." print "Hello world." print
] with-stream ] with-file-writer
] unit-test ] unit-test
[ ] [ [ ] [
@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ;
[ f ] [ "test-blah" resource-path exists? ] unit-test [ 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 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 [ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test [ t ] [ "quux-test.txt" resource-path exists? ] unit-test

View File

@ -3,7 +3,7 @@
IN: io.files IN: io.files
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs ; system combinators splitting sbufs continuations ;
HOOK: cd io-backend ( path -- ) HOOK: cd io-backend ( path -- )
@ -116,11 +116,10 @@ HOOK: copy-file io-backend ( from to -- )
M: object copy-file M: object copy-file
dup parent-directory make-directories dup parent-directory make-directories
<file-writer> [ <file-writer> [
stdio get swap swap <file-reader> [
<file-reader> [ swap stream-copy
stdio get swap stream-copy ] with-disposal
] with-stream ] with-disposal ;
] with-stream ;
: copy-directory ( from to -- ) : copy-directory ( from to -- )
dup make-directories dup make-directories
@ -144,12 +143,13 @@ M: pathname <=> [ pathname-string ] compare ;
: file-lines ( path -- seq ) <file-reader> lines ; : file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str ) : 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 >r <file-reader> r> with-stream ; inline
: with-file-out ( path quot -- ) : with-file-writer ( path quot -- )
>r <file-writer> r> with-stream ; inline >r <file-writer> r> with-stream ; inline
: with-file-appender ( path quot -- ) : with-file-appender ( path quot -- )

View File

@ -53,7 +53,7 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
image <file-reader> [ image [
10 [ 65536 read drop ] times 10 [ 65536 read drop ] times
] with-stream ] with-file-reader
] unit-test ] unit-test

View File

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

View File

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

View File

@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
IN: temporary IN: temporary
[ "hello world" ] [ [ "hello world" ] [
"test.txt" resource-path <file-writer> [ "test.txt" resource-path [
"hello world" write "hello world" write
] with-stream ] with-file-writer
"test.txt" resource-path "rb" fopen <c-reader> contents "test.txt" resource-path "rb" fopen <c-reader> contents
] unit-test ] unit-test

View File

@ -6,8 +6,8 @@ ARTICLE: "io.streams.string" "String streams"
{ $subsection <string-reader> } { $subsection <string-reader> }
{ $subsection <string-writer> } { $subsection <string-writer> }
"Utility combinators:" "Utility combinators:"
{ $subsection string-in } { $subsection with-string-reader }
{ $subsection string-out } ; { $subsection with-string-writer } ;
ABOUT: "io.streams.string" ABOUT: "io.streams.string"
@ -15,7 +15,7 @@ HELP: <string-writer>
{ $values { "stream" "an output stream" } } { $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." } ; { $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 } } { $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." } ; { $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." } { $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." } ; { $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 } } { $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." } ; { $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." } ;

View File

@ -12,7 +12,7 @@ unit-test
[ "" <string-reader> stream-readln ] [ "" <string-reader> stream-readln ]
unit-test 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 [ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
[ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test [ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test

View File

@ -2,21 +2,21 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings 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 ; continuations ;
M: sbuf dispose drop ; M: growable dispose drop ;
M: sbuf stream-write1 push ; M: growable stream-write1 push ;
M: sbuf stream-write push-all ; M: growable stream-write push-all ;
M: sbuf stream-flush drop ; M: growable stream-flush drop ;
: <string-writer> ( -- stream ) : <string-writer> ( -- stream )
512 <sbuf> <plain-writer> ; 512 <sbuf> <plain-writer> ;
: string-out ( quot -- str ) : with-string-writer ( quot -- str )
<string-writer> [ call stdio get >string ] with-stream* ; <string-writer> swap [ stdio get ] compose with-stream*
inline >string ; inline
: format-column ( seq ? -- seq ) : format-column ( seq ? -- seq )
[ [
@ -37,36 +37,39 @@ M: plain-writer stream-write-table
M: plain-writer make-cell-stream 2drop <string-writer> ; 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 ) : harden-as ( seq growble-exemplar -- newseq )
tail-slice >string dup reverse-here ; 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 ; : find-last-sep swap [ memq? ] curry find-last drop ;
M: sbuf stream-read-until M: growable stream-read-until
[ find-last-sep ] keep over [ [ find-last-sep ] keep over [
[ swap 1+ sbuf-read-until ] 2keep [ nth ] 2keep [ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
set-length set-length
] [ ] [
[ swap drop 0 sbuf-read-until f like f ] keep [ swap drop 0 growable-read-until f like f ] keep
delete-all delete-all
] if ; ] if ;
M: sbuf stream-read M: growable stream-read
dup empty? [ dup empty? [
2drop f 2drop f
] [ ] [
[ length swap - 0 max ] keep [ length swap - 0 max ] keep
[ swap sbuf-read-until ] 2keep [ swap growable-read-until ] 2keep
set-length set-length
] if ; ] if ;
M: sbuf stream-read-partial M: growable stream-read-partial
stream-read ; stream-read ;
: <string-reader> ( str -- stream ) : <string-reader> ( str -- stream )
>sbuf dup reverse-here <line-reader> ; >sbuf dup reverse-here <line-reader> ;
: string-in ( str quot -- ) : with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline >r <string-reader> r> with-stream ; inline

View File

@ -32,7 +32,7 @@ IN: temporary
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ 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 ; : overflow-r 3 >r overflow-r ;
@ -80,8 +80,8 @@ IN: temporary
[ 0 ] [ f [ 0 ] unless* ] unit-test [ 0 ] [ f [ 0 ] unless* ] unit-test
[ t ] [ t [ "Hello" ] unless* ] unit-test [ t ] [ t [ "Hello" ] unless* ] unit-test
[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] string-out ] unit-test [ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] string-out ] unit-test [ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
[ f ] [ f (clone) ] unit-test [ f ] [ f (clone) ] unit-test
[ -123 ] [ -123 (clone) ] unit-test [ -123 ] [ -123 (clone) ] unit-test

View File

@ -513,4 +513,4 @@ SYMBOL: interactive-vocabs
[ [
parser-notes off parser-notes off
[ [ eval ] keep ] try drop [ [ eval ] keep ] try drop
] string-out ; ] with-string-writer ;

View File

@ -67,19 +67,19 @@ unit-test
[ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test [ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test
[ t ] [ [ t ] [
100 \ dup <array> [ pprint-short ] string-out 100 \ dup <array> [ pprint-short ] with-string-writer
"{" head? "{" head?
] unit-test ] unit-test
: foo ( a -- b ) dup * ; inline : foo ( a -- b ) dup * ; inline
[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ] [ "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 + ; : bar ( x -- y ) 2 + ;
[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ] [ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ]
[ [ \ bar see ] string-out ] unit-test [ [ \ bar see ] with-string-writer ] unit-test
: blah : blah
drop drop
@ -105,7 +105,7 @@ unit-test
[ "drop ;" ] [ [ "drop ;" ] [
\ blah f "inferred-effect" set-word-prop \ 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 ] unit-test
: check-see ( expect name -- ) : check-see ( expect name -- )
@ -116,7 +116,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit [ parse-fresh drop ] with-compilation-unit
[ [
"temporary" lookup see "temporary" lookup see
] string-out "\n" split 1 head* ] with-string-writer "\n" split 1 head*
] keep = ] keep =
] with-scope ; ] with-scope ;
@ -295,7 +295,7 @@ unit-test
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval dup eval
"generic-decl-test" "temporary" lookup "generic-decl-test" "temporary" lookup
[ see ] string-out = [ see ] with-string-writer =
] unit-test ] unit-test
[ [ + ] ] [ [ [ + ] ] [

View File

@ -63,9 +63,9 @@ combinators quotations ;
: pprint-use ( obj -- ) [ pprint* ] with-use ; : 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 -- ) : pprint-short ( obj -- )
H{ H{
@ -192,7 +192,7 @@ M: pathname synopsis* pprint* ;
0 margin set 0 margin set
1 line-limit set 1 line-limit set
[ synopsis* ] with-in [ synopsis* ] with-in
] string-out ; ] with-string-writer ;
GENERIC: declarations. ( obj -- ) GENERIC: declarations. ( obj -- )

View File

@ -112,7 +112,7 @@ SYMBOL: end
{ "boolean" [ "\0" = not ] } { "boolean" [ "\0" = not ] }
{ "string" [ "" or ] } { "string" [ "" or ] }
{ "integer" [ be> ] } { "integer" [ be> ] }
{ "array" [ "" or [ read-array ] string-in ] } { "array" [ "" or [ read-array ] with-string-reader ] }
} case ; } case ;
: read-ber ( syntax -- object ) : read-ber ( syntax -- object )

View File

@ -101,7 +101,7 @@ HINTS: random fixnum ;
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta 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 n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
drop drop
] with-file-out ] with-file-writer
] with-locals ; ] with-locals ;

View File

@ -57,8 +57,7 @@ IN: benchmark.knucleotide
: knucleotide ( -- ) : knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
<file-reader> [ read-input ] with-file-reader
[ read-input ] with-stream
process-input ; process-input ;
MAIN: knucleotide MAIN: knucleotide

View File

@ -65,7 +65,7 @@ SYMBOL: cols
] with-scope ; ] with-scope ;
: mandel-main ( -- ) : mandel-main ( -- )
"mandel.ppm" resource-path <file-writer> "mandel.ppm" resource-path
[ mandel write ] with-stream ; [ mandel write ] with-file-writer ;
MAIN: mandel-main MAIN: mandel-main

View File

@ -171,6 +171,6 @@ DEFER: create ( level c r -- scene )
: raytracer-main : raytracer-main
"raytracer.pnm" resource-path "raytracer.pnm" resource-path
<file-writer> [ run write ] with-stream ; [ run write ] with-file-writer ;
MAIN: raytracer-main MAIN: raytracer-main

View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.duplex kernel sequences USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting sequences.private strings vectors words memoize splitting
hints unicode.case ; hints unicode.case continuations ;
IN: benchmark.reverse-complement IN: benchmark.reverse-complement
MEMO: trans-map ( -- str ) MEMO: trans-map ( -- str )

View File

@ -5,7 +5,7 @@ IN: benchmark.sum-file
readln [ string>number + sum-file-loop ] when* ; readln [ string>number + sum-file-loop ] when* ;
: sum-file ( file -- ) : sum-file ( file -- )
<file-reader> [ 0 sum-file-loop ] with-stream . ; [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- ) : sum-file-main ( -- )
home "sum-file-in.txt" path+ sum-file ; home "sum-file-in.txt" path+ sum-file ;

View File

@ -11,7 +11,7 @@ bootstrap.image sequences io namespaces io.launcher math ;
: compute-checksums ( -- ) : compute-checksums ( -- )
"checksums.txt" [ "checksums.txt" [
boot-image-names [ dup write bl file>md5str print ] each boot-image-names [ dup write bl file>md5str print ] each
] with-file-out ; ] with-file-writer ;
: upload-images ( -- ) : upload-images ( -- )
[ [

View File

@ -1,11 +1,7 @@
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads USING: kernel namespaces sequences splitting system combinators continuations
arrays system continuations namespaces sequences splitting math.parser parser io io.files io.launcher io.sockets prettyprint threads
prettyprint tools.time calendar bake vars http.client bootstrap.image benchmark vars bake smtp builder.util accessors ;
combinators bootstrap.image bootstrap.image.download
combinators.cleave benchmark
classes strings quotations words parser-combinators new-slots accessors
assocs.lib smtp builder.util ;
IN: builder IN: builder
@ -48,7 +44,7 @@ VAR: stamp
: git-id ( -- id ) : git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ; { "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" } ; : make-clean ( -- desc ) { "make" "clean" } ;
@ -132,9 +128,9 @@ SYMBOL: build-status
"Did not pass test-all: " print "../test-all-vocabs" cat "Did not pass test-all: " print "../test-all-vocabs" cat
"Benchmarks: " print "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 ; build-status on ;

View File

@ -11,17 +11,17 @@ USING: kernel namespaces sequences assocs builder continuations
IN: builder.test IN: builder.test
: do-load ( -- ) : do-load ( -- )
try-everything keys "../load-everything-vocabs" [ . ] with-file-out ; try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
: do-tests ( -- ) : 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 ( -- ) : do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-out bootstrap-time get "../boot-time" [ . ] with-file-writer
[ do-load ] runtime "../load-time" [ . ] with-file-out [ do-load ] runtime "../load-time" [ . ] with-file-writer
[ do-tests ] runtime "../test-time" [ . ] with-file-out [ do-tests ] runtime "../test-time" [ . ] with-file-writer
do-benchmarks ; do-benchmarks ;
MAIN: do-all MAIN: do-all

View File

@ -3,8 +3,8 @@ USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets io io.files io.launcher io.sockets
math math.parser math math.parser
combinators sequences splitting quotations arrays strings tools.time combinators sequences splitting quotations arrays strings tools.time
parser-combinators accessors assocs.lib parser-combinators new-slots accessors assocs.lib
combinators.cleave bake calendar new-slots ; combinators.cleave bake calendar ;
IN: builder.util IN: builder.util
@ -14,7 +14,7 @@ IN: builder.util
: minutes>ms ( min -- ms ) 60 * 1000 * ; : 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -18,13 +18,7 @@ IN: bunny.model
] when* ; ] when* ;
: parse-model ( stream -- vs is ) : parse-model ( stream -- vs is )
[ 100000 <vector> 100000 <vector> (parse-model) ;
100000 <vector> 100000 <vector> (parse-model)
] with-stream
[
over length # " vertices, " %
dup length # " triangles" %
] "" make print ;
: n ( vs triple -- n ) : n ( vs triple -- n )
swap [ nth ] curry map swap [ nth ] curry map
@ -41,7 +35,8 @@ IN: bunny.model
: read-model ( stream -- model ) : read-model ( stream -- model )
"Reading model" print flush [ "Reading model" print flush [
<file-reader> parse-model [ normals ] 2keep 3array [ parse-model ] with-file-reader
[ normals ] 2keep 3array
] time ; ] time ;
: model-path "bun_zipper.ply" ; : model-path "bun_zipper.ply" ;

22
extra/calendar/calendar-tests.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test 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 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 [ 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 ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test [ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
[ t ] [ 123456789123456789 [ 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

View File

@ -347,7 +347,7 @@ M: timestamp year. ( timestamp -- )
timestamp-second >fixnum write-00 ; timestamp-second >fixnum write-00 ;
: timestamp>string ( timestamp -- str ) : timestamp>string ( timestamp -- str )
[ (timestamp>string) ] string-out ; [ (timestamp>string) ] with-string-writer ;
: (write-gmt-offset) ( ratio -- ) : (write-gmt-offset) ( ratio -- )
1 /mod swap write-00 60 * write-00 ; 1 /mod swap write-00 60 * write-00 ;
@ -366,42 +366,63 @@ M: timestamp year. ( timestamp -- )
dup (timestamp>string) dup (timestamp>string)
" " write " " write
timestamp-gmt-offset write-gmt-offset timestamp-gmt-offset write-gmt-offset
] string-out ; ] with-string-writer ;
: timestamp>http-string ( timestamp -- str ) : timestamp>http-string ( timestamp -- str )
#! http timestamp format #! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT #! Example: Tue, 15 Nov 1994 08:12:31 GMT
>gmt timestamp>rfc822-string ; >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 -- ) : (timestamp>rfc3339) ( timestamp -- )
dup timestamp-year number>string write CHAR: - write1 dup timestamp-year number>string write CHAR: - write1
dup timestamp-month write-00 CHAR: - write1 dup timestamp-month write-00 CHAR: - write1
dup timestamp-day write-00 CHAR: T write1 dup timestamp-day write-00 CHAR: T write1
dup timestamp-hour write-00 CHAR: : write1 dup timestamp-hour write-00 CHAR: : write1
dup timestamp-minute 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 ) : 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 ) : (rfc3339>timestamp) ( -- timestamp )
4 read string>number ! year read-0000 ! year
CHAR: - expect "-" expect
2 read string>number ! month read-00 ! month
CHAR: - expect "-" expect
2 read string>number ! day read-00 ! day
CHAR: T expect "Tt" expect
2 read string>number ! hour read-00 ! hour
CHAR: : expect ":" expect
2 read string>number ! minute read-00 ! minute
CHAR: : expect ":" expect
2 read string>number ! second read-00 ! second
0 <timestamp> ; read-rfc3339-gmt-offset ! timezone
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp ) : rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] string-in ; [ (rfc3339>timestamp) ] with-string-reader ;
: file-time-string ( timestamp -- string ) : file-time-string ( timestamp -- string )
[ [
@ -413,7 +434,7 @@ M: timestamp year. ( timestamp -- )
] [ ] [
timestamp-year number>string 5 32 pad-left write timestamp-year number>string 5 32 pad-left write
] if ] if
] string-out ; ] with-string-writer ;
: day-offset ( timestamp m -- timestamp n ) : day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline over day-of-week - ; inline

View File

@ -461,9 +461,9 @@ M: cpu reset ( cpu -- )
: load-rom ( filename cpu -- ) : load-rom ( filename cpu -- )
#! Load the contents of the file into ROM. #! Load the contents of the file into ROM.
#! (address 0x0000-0x1FFF). #! (address 0x0000-0x1FFF).
cpu-ram swap <file-reader> [ cpu-ram swap [
0 swap (load-rom) 0 swap (load-rom)
] with-stream ; ] with-file-reader ;
SYMBOL: rom-root SYMBOL: rom-root
@ -477,9 +477,9 @@ SYMBOL: rom-root
#! file path shoul dbe relative to the '/roms' resource path. #! file path shoul dbe relative to the '/roms' resource path.
rom-dir [ rom-dir [
cpu-ram [ cpu-ram [
swap first2 rom-dir swap path+ <file-reader> [ swap first2 rom-dir swap path+ [
swap (load-rom) swap (load-rom)
] with-stream ] with-file-reader
] curry each ] curry each
] [ ] [
! !

View File

@ -7,11 +7,11 @@ math.parser ;
IN: editors.jedit IN: editors.jedit
: jedit-server-info ( -- port auth ) : jedit-server-info ( -- port auth )
home "/.jedit/server" path+ <file-reader> [ home "/.jedit/server" path+ [
readln drop readln drop
readln string>number readln string>number
readln string>number readln string>number
] with-stream ; ] with-file-reader ;
: make-jedit-request ( files -- code ) : make-jedit-request ( files -- code )
[ [
@ -21,7 +21,7 @@ IN: editors.jedit
"new String[] {" write "new String[] {" write
[ pprint "," write ] each [ pprint "," write ] each
"null});\n" write "null});\n" write
] string-out ; ] with-string-writer ;
: send-jedit-request ( request -- ) : send-jedit-request ( request -- )
jedit-server-info swap "localhost" swap <inet> <client> [ jedit-server-info swap "localhost" swap <inet> <client> [

View File

@ -365,7 +365,7 @@ M: quotation fjsc-parse ( object -- ast )
(compile) (compile)
")" , ")" ,
] { } make [ write ] each ] { } make [ write ] each
] string-out ; ] with-string-writer ;
: fjsc-compile* ( string -- string ) : fjsc-compile* ( string -- string )
'statement' parse parse-result-ast fjsc-compile ; 'statement' parse parse-result-ast fjsc-compile ;
@ -379,5 +379,5 @@ M: quotation fjsc-parse ( object -- ast )
: fjsc-literal ( ast -- string ) : fjsc-literal ( ast -- string )
[ [
[ (literal) ] { } make [ write ] each [ (literal) ] { } make [ write ] each
] string-out ; ] with-string-writer ;

View File

@ -59,17 +59,17 @@ TUPLE: bitmap magic size reserved offset header-length width
dup color-index-length read swap set-bitmap-color-index ; dup color-index-length read swap set-bitmap-color-index ;
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
<file-reader> [ [
T{ bitmap } clone T{ bitmap } clone
dup parse-file-header dup parse-file-header
dup parse-bitmap-header dup parse-bitmap-header
dup parse-bitmap dup parse-bitmap
] with-stream ] with-file-reader
dup bitmap-color-index over bitmap-bit-count dup bitmap-color-index over bitmap-bit-count
raw-bitmap>string >byte-array over set-bitmap-array ; raw-bitmap>string >byte-array over set-bitmap-array ;
: save-bitmap ( bitmap path -- ) : save-bitmap ( bitmap path -- )
<file-writer> [ [
"BM" write "BM" write
dup bitmap-array length 14 + 40 + 4 >le write dup bitmap-array length 14 + 40 + 4 >le write
0 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-color-important 4 >le write
dup bitmap-rgb-quads write dup bitmap-rgb-quads write
bitmap-color-index write bitmap-color-index write
] with-stream ; ] with-file-writer ;
M: bitmap draw-image ( bitmap -- ) M: bitmap draw-image ( bitmap -- )
dup bitmap-height 0 < [ dup bitmap-height 0 < [

View File

@ -195,7 +195,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
} }
"Read 1024 bytes from a file:" "Read 1024 bytes from a file:"
{ $code { $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:" "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
{ $code { $code

View File

@ -69,7 +69,7 @@ IN: help.lint
] each ; ] each ;
: check-rendering ( word element -- ) : check-rendering ( word element -- )
[ help ] string-out drop ; [ help ] with-string-writer drop ;
: all-word-help ( words -- seq ) : all-word-help ( words -- seq )
[ word-help ] subset ; [ word-help ] subset ;

View File

@ -16,7 +16,7 @@ TUPLE: blahblah quux ;
test-slot blahblah $spec-reader-values test-slot blahblah $spec-reader-values
] unit-test ] unit-test
[ "an int" ] [ [ { "int" } $instance ] string-out ] unit-test [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ blahblah-quux help ] unit-test [ ] [ \ blahblah-quux help ] unit-test
[ ] [ \ set-blahblah-quux help ] unit-test [ ] [ \ set-blahblah-quux help ] unit-test

View File

@ -25,7 +25,7 @@ PRIVATE>
[ [
dup length header. dup length header.
16 <sliced-groups> [ line. ] each-index 16 <sliced-groups> [ line. ] each-index
] string-out ; ] with-string-writer ;
: hexdump. ( seq -- ) : hexdump. ( seq -- )
hexdump write ; hexdump write ;

View File

@ -2,7 +2,7 @@ IN: temporary
USING: tools.test html html.elements io.streams.string ; USING: tools.test html html.elements io.streams.string ;
: make-html-string : make-html-string
[ with-html-stream ] string-out ; [ with-html-stream ] with-string-writer ;
[ "<a href='h&amp;o'>" ] [ "<a href='h&amp;o'>" ]
[ [ <a "h&o" =href a> ] make-html-string ] unit-test [ [ <a "h&o" =href a> ] make-html-string ] unit-test

View File

@ -3,7 +3,7 @@ namespaces tools.test xml.writer sbufs sequences html.private ;
IN: temporary IN: temporary
: make-html-string : make-html-string
[ with-html-stream ] string-out ; [ with-html-stream ] with-string-writer ;
[ ] [ [ ] [
512 <sbuf> <html-stream> drop 512 <sbuf> <html-stream> drop

View File

@ -6,7 +6,7 @@ IN: temporary
"extra/http/server/templating/test/" swap append "extra/http/server/templating/test/" swap append
[ [
".fhtml" append resource-path ".fhtml" append resource-path
[ run-template-file ] string-out [ run-template-file ] with-string-writer
] keep ] keep
".html" append resource-path file-contents = ; ".html" append resource-path file-contents = ;

View File

@ -93,4 +93,4 @@ DEFER: <% delimiter
swap path+ run-template-file ; swap path+ run-template-file ;
: template-convert ( infile outfile -- ) : template-convert ( infile outfile -- )
<file-writer> [ run-template-file ] with-stream ; [ run-template-file ] with-file-writer ;

View File

@ -1,6 +1,5 @@
! Copyright (C) 2007 Adam Wendt. ! Copyright (C) 2007 Adam Wendt.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
!
USING: arrays combinators io io.binary io.files io.paths USING: arrays combinators io io.binary io.files io.paths
io.encodings.utf16 kernel math math.parser namespaces sequences io.encodings.utf16 kernel math math.parser namespaces sequences
@ -121,7 +120,7 @@ C: <extended-header> extended-header
id3v2? [ read-id3v2 ] [ f ] if ; id3v2? [ read-id3v2 ] [ f ] if ;
: id3v2 ( filename -- tag/f ) : id3v2 ( filename -- tag/f )
<file-reader> [ read-tag ] with-stream ; [ read-tag ] with-file-reader ;
: file? ( path -- ? ) : file? ( path -- ? )
stat 3drop not ; stat 3drop not ;
@ -136,7 +135,7 @@ C: <extended-header> extended-header
[ mp3? ] subset ; [ mp3? ] subset ;
: id3? ( file -- ? ) : id3? ( file -- ? )
<file-reader> [ id3v2? ] with-stream ; [ id3v2? ] with-file-reader ;
: id3s ( files -- id3s ) : id3s ( files -- id3s )
[ id3? ] subset ; [ id3? ] subset ;

View File

@ -100,7 +100,7 @@ M: math-inverse inverse
[ drop swap-inverse ] [ pull-inverse ] if ; [ drop swap-inverse ] [ pull-inverse ] if ;
M: pop-inverse inverse 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 ; "pop-inverse" word-prop compose call ;
: (undo) ( revquot -- ) : (undo) ( revquot -- )

View File

@ -2,7 +2,7 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ;
IN: temporary IN: temporary
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ "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 [ ] [ "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 [ 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 [ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test

View File

@ -131,16 +131,16 @@ client-addr <datagram>
! Invalid parameter tests ! Invalid parameter tests
[ [
image <file-reader> [ stdio get accept ] with-stream image [ stdio get accept ] with-file-reader
] must-fail ] must-fail
[ [
image <file-reader> [ stdio get receive ] with-stream image [ stdio get receive ] with-file-reader
] must-fail ] must-fail
[ [
image <file-reader> [ image [
B{ 1 2 } server-addr B{ 1 2 } server-addr
stdio get send stdio get send
] with-stream ] with-file-reader
] must-fail ] must-fail

View File

@ -10,7 +10,7 @@ GENERIC: json-print ( obj -- )
: >json ( obj -- string ) : >json ( obj -- string )
#! Returns a string representing the factor object in JSON format #! Returns a string representing the factor object in JSON format
[ json-print ] string-out ; [ json-print ] with-string-writer ;
M: f json-print ( f -- ) M: f json-print ( f -- )
drop "false" write ; drop "false" write ;

View File

@ -11,7 +11,7 @@ SYMBOL: insomniac-recipients
: ?analyze-log ( service word-names -- string/f ) : ?analyze-log ( service word-names -- string/f )
>r log-path 1 log# dup exists? [ >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 r> 2drop f
] if ; ] if ;

View File

@ -103,7 +103,7 @@ PRIVATE>
: (log-error) ( object word level -- ) : (log-error) ( object word level -- )
log-service get [ 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 2drop rethrow
] if ; ] if ;

View File

@ -13,6 +13,6 @@ IN: msxml-to-csv
] map ; ] map ;
: msxml>csv ( infile outfile -- ) : msxml>csv ( infile outfile -- )
<file-writer> [ [
file>xml (msxml>csv) print-csv file>xml (msxml>csv) print-csv
] with-stream ; ] with-file-writer ;

View File

@ -41,7 +41,7 @@ USING: io io.streams.string kernel namespaces pack strings tools.test ;
<string-reader> [ "int" read-native ] with-stream <string-reader> [ "int" read-native ] with-stream
] unit-test ] unit-test
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] string-in ] unit-test [ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test
[ f ] [ "" [ read-c-string ] string-in ] 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 ] string-in ] unit-test [ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test

View File

@ -27,6 +27,6 @@ MEMO: any-char-parser ( -- parser )
any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ; any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ;
: replace ( string parser -- result ) : replace ( string parser -- result )
[ (replace) [ tree-write ] each ] string-out ; [ (replace) [ tree-write ] each ] with-string-writer ;

View File

@ -55,7 +55,7 @@ C: <entry> entry
[ [
{ "content" "summary" } any-tag-named { "content" "summary" } any-tag-named
dup tag-children [ string? not ] contains? dup tag-children [ string? not ] contains?
[ tag-children [ write-chunk ] string-out ] [ tag-children [ write-chunk ] with-string-writer ]
[ children>string ] if [ children>string ] if
] keep ] keep
{ "published" "updated" "issued" "modified" } any-tag-named { "published" "updated" "issued" "modified" } any-tag-named

View File

@ -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." } { $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 { $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 } ; { $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." } { $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 { $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 } ; { $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." } { $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 { $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 } ; { $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." } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." }
{ $examples { $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 } ; { $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." } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." }
{ $examples { $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 } ; { $see-also (serialize) deserialize (deserialize) with-serialized } ;

View File

@ -38,8 +38,8 @@ C: <serialize-test> serialize-test
: check-serialize-1 ( obj -- ? ) : check-serialize-1 ( obj -- ? )
dup class . dup class .
dup [ serialize ] string-out dup [ serialize ] with-string-writer
[ deserialize ] string-in = ; [ deserialize ] with-string-reader = ;
: check-serialize-2 ( obj -- ? ) : check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [ dup number? over wrapper? or [
@ -47,8 +47,8 @@ C: <serialize-test> serialize-test
] [ ] [
dup class . dup class .
dup 2array dup 2array
[ serialize ] string-out [ serialize ] with-string-writer
[ deserialize ] string-in [ deserialize ] with-string-reader
first2 eq? first2 eq?
] if ; ] if ;
@ -63,7 +63,7 @@ C: <serialize-test> serialize-test
[ [
dup (serialize) (serialize) dup (serialize) (serialize)
] with-serialized ] with-serialized
] string-out [ ] with-string-writer [
deserialize-sequence all-eq? deserialize-sequence all-eq?
] string-in ] with-string-reader
] unit-test ] unit-test

View File

@ -12,7 +12,7 @@ IN: temporary
[ { "hello" "." "world" } validate-message ] must-fail [ { "hello" "." "world" } validate-message ] must-fail
[ "hello\r\nworld\r\n.\r\n" ] [ [ "hello\r\nworld\r\n.\r\n" ] [
{ "hello" "world" } [ send-body ] string-out { "hello" "world" } [ send-body ] with-string-writer
] unit-test ] unit-test
[ "500 syntax error" check-response ] must-fail [ "500 syntax error" check-response ] must-fail
@ -20,17 +20,17 @@ IN: temporary
[ ] [ "220 success" check-response ] unit-test [ ] [ "220 success" check-response ] unit-test
[ "220 success" ] [ [ "220 success" ] [
"220 success" [ receive-response ] string-in "220 success" [ receive-response ] with-string-reader
] unit-test ] unit-test
[ "220 the end" ] [ [ "220 the end" ] [
"220-a multiline response\r\n250-another line\r\n220 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 ] unit-test
[ ] [ [ ] [
"220-a multiline response\r\n250-another line\r\n220 the end" "220-a multiline response\r\n250-another line\r\n220 the end"
[ get-ok ] string-in [ get-ok ] with-string-reader
] unit-test ] unit-test
[ [

View File

@ -72,7 +72,7 @@ SYMBOL: filename
0 over set-tar-header-size 0 over set-tar-header-size
0 over set-tar-header-checksum 0 over set-tar-header-checksum
] [ ] [
[ read-tar-header ] string-in [ read-tar-header ] with-string-reader
[ tar-header-checksum = [ [ tar-header-checksum = [
\ checksum-error construct-empty throw \ checksum-error construct-empty throw
] unless ] unless
@ -241,4 +241,4 @@ TUPLE: unimplemented-typeflag header ;
global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar) (parse-tar)
] with-file-out ; ] with-file-writer ;

21
extra/tools/annotations/annotations-tests.factor Normal file → Executable file
View File

@ -1,7 +1,26 @@
USING: tools.test tools.annotations ; USING: tools.test tools.annotations math parser ;
IN: temporary IN: temporary
: foo ; : foo ;
\ foo watch \ foo watch
[ ] [ foo ] unit-test [ ] [ 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

View File

@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
: set-vocab-file-contents ( seq vocab name -- ) : set-vocab-file-contents ( seq vocab name -- )
dupd vocab-path+ [ dupd vocab-path+ [
?resource-path ?resource-path
[ [ print ] each ] with-file-out [ [ print ] each ] with-file-writer
] [ ] [
"The " swap vocab-name "The " swap vocab-name
" vocabulary was not loaded from the file system" " vocabulary was not loaded from the file system"

View File

@ -20,7 +20,7 @@ M: pair make-disassemble-cmd
current-process-handle number>string print current-process-handle number>string print
"disassemble " write "disassemble " write
[ number>string write bl ] each [ number>string write bl ] each
] with-file-out ; ] with-file-writer ;
: run-gdb ( -- lines ) : run-gdb ( -- lines )
[ [

View File

@ -81,11 +81,11 @@ IN: temporary
] unit-test ] unit-test
[ { "hi\n" } ] [ [ { "hi\n" } ] [
[ [ "hi" print ] string-out ] test-interpreter [ [ "hi" print ] with-string-writer ] test-interpreter
] unit-test ] unit-test
[ { "4\n" } ] [ [ { "4\n" } ] [
[ [ 2 2 + number>string print ] string-out ] test-interpreter [ [ 2 2 + number>string print ] with-string-writer ] test-interpreter
] unit-test ] unit-test
[ { 1 2 3 } ] [ [ { 1 2 3 } ] [
@ -105,7 +105,7 @@ IN: temporary
[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test
[ { "{ 1 2 3 }\n" } ] [ [ { "{ 1 2 3 }\n" } ] [
[ [ { 1 2 3 } . ] string-out ] test-interpreter [ [ { 1 2 3 } . ] with-string-writer ] test-interpreter
] unit-test ] unit-test
[ { } ] [ [ { } ] [

9
extra/tools/profiler/profiler-docs.factor Normal file → Executable file
View File

@ -3,10 +3,11 @@ quotations io strings words definitions ;
IN: tools.profiler IN: tools.profiler
ARTICLE: "profiling" "Profiling code" 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 { $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." "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 " { $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." "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:" "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 profile. }
{ $subsection vocab-profile. } { $subsection vocab-profile. }
{ $subsection usage-profile. } { $subsection usage-profile. }
{ $subsection vocabs-profile. } ; { $subsection vocabs-profile. }
{ $subsection method-profile. } ;
ABOUT: "profiling" ABOUT: "profiling"
@ -48,6 +50,9 @@ HELP: usage-profile.
HELP: vocabs-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." } ; { $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 ( ? -- ) HELP: profiling ( ? -- )
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }
{ $description "Internal primitive to switch on call counting. This word should not be used; instead use " { $link profile } "." } ; { $description "Internal primitive to switch on call counting. This word should not be used; instead use " { $link profile } "." } ;

View File

@ -3,7 +3,7 @@
USING: words sequences math prettyprint kernel arrays io USING: words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private sorting math.parser vocabs definitions tools.profiler.private
continuations ; continuations generic ;
IN: tools.profiler IN: tools.profiler
: profile ( quot -- ) : profile ( quot -- )
@ -28,6 +28,11 @@ C: <vocab-profile> vocab-profile
M: string (profile.) M: string (profile.)
dup <vocab-profile> write-object ; 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 -- ) : counter. ( obj n -- )
[ [
>r [ (profile.) ] with-cell r> >r [ (profile.) ] with-cell r>
@ -63,3 +68,7 @@ M: string (profile.)
[ "predicating" word-prop not ] subset [ "predicating" word-prop not ] subset
[ profile-counter ] map sum [ profile-counter ] map sum
] { } map>assoc counters. ; ] { } map>assoc counters. ;
: method-profile. ( -- )
all-words [ subwords ] map concat
counters counters. ;

View File

@ -13,4 +13,4 @@ IN: tools.test.ui
swap slip swap slip
ungraft notify-queued ungraft notify-queued
] with-variable ] with-variable
] string-out print ; ] with-string-writer print ;

View File

@ -27,5 +27,5 @@ testing "testing" "hey" {
[ "C+x" ] [ [ "C+x" ] [
[ [
{ $command testing "testing" com-test-1 } print-element { $command testing "testing" com-test-1 } print-element
] string-out ] with-string-writer
] unit-test ] unit-test

View File

@ -191,7 +191,7 @@ M: mock-gadget ungraft*
] with-variable ; ] with-variable ;
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] string-out print ] with-string-writer print
\ <gadget> must-infer \ <gadget> must-infer
\ unparent must-infer \ unparent must-infer

View File

@ -18,7 +18,7 @@ tools.test.ui models ;
: test-gadget-text : test-gadget-text
dup make-pane 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" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test

View File

@ -10,5 +10,5 @@ tuples ;
[ "+" ] [ [ "+" ] [
[ [
\ + f \ pprint <command-button> dup button-quot call \ + f \ pprint <command-button> dup button-quot call
] string-out ] with-string-writer
] unit-test ] unit-test

View File

@ -11,7 +11,7 @@ io.streams.string math help help.markup ;
3 "op" get operation-command command-quot 3 "op" get operation-command command-quot
] unit-test ] 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 [ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
"op" set "op" set
@ -20,9 +20,9 @@ io.streams.string math help help.markup ;
[ [
"4" <editor> [ set-editor-string ] keep "4" <editor> [ set-editor-string ] keep
"op" get invoke-command "op" get invoke-command
] string-out ] with-string-writer
] unit-test ] unit-test
[ ] [ [ ] [
[ { $operations \ + } print-element ] string-out drop [ { $operations \ + } print-element ] with-string-writer drop
] unit-test ] unit-test

4
extra/ui/tools/profiler/profiler.factor Normal file → Executable file
View File

@ -24,6 +24,9 @@ TUPLE: profiler-gadget pane ;
: com-vocabs-profile ( gadget -- ) : com-vocabs-profile ( gadget -- )
[ vocabs-profile. ] with-profiler-pane ; [ vocabs-profile. ] with-profiler-pane ;
: com-method-profile ( gadget -- )
[ method-profile. ] with-profiler-pane ;
: profiler-help "ui-profiler" help-window ; : profiler-help "ui-profiler" help-window ;
\ profiler-help H{ { +nullary+ t } } define-command \ profiler-help H{ { +nullary+ t } } define-command
@ -31,6 +34,7 @@ TUPLE: profiler-gadget pane ;
profiler-gadget "toolbar" f { profiler-gadget "toolbar" f {
{ f com-full-profile } { f com-full-profile }
{ f com-vocabs-profile } { f com-vocabs-profile }
{ f com-method-profile }
{ T{ key-down f f "F1" } profiler-help } { T{ key-down f f "F1" } profiler-help }
} define-command-map } define-command-map

View File

@ -1,3 +1,3 @@
USING: tools.test io.streams.string xml.generator xml.writer ; USING: tools.test io.streams.string xml.generator xml.writer ;
[ "<html><body><a href=\"blah\"/></body></html>" ] [ "<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

View File

@ -9,6 +9,6 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
[ assemble-data ] map ; [ assemble-data ] map ;
[ "http://www.foxnews.com/oreilly/" ] [ [ "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 parse-result first first
] unit-test ] unit-test

View File

@ -7,7 +7,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
! This is insufficient ! This is insufficient
SYMBOL: xml-file 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 [ file>xml ] with-html-entities xml-file set ] unit-test
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test

View File

@ -108,7 +108,7 @@ M: instruction write-item
write-xml nl ; write-xml nl ;
: xml>string ( xml -- string ) : xml>string ( xml -- string )
[ write-xml ] string-out ; [ write-xml ] with-string-writer ;
: with-xml-pprint ( sensitive-tags quot -- ) : with-xml-pprint ( sensitive-tags quot -- )
[ [

View File

@ -98,7 +98,7 @@ IN: factorbot-commands
] if ; ] if ;
: memory ( text -- ) : memory ( text -- )
drop [ room. ] string-out multiline-respond ; drop [ room. ] with-string-writer multiline-respond ;
: quit ( text -- ) : quit ( text -- )
drop speaker get "slava" = [ disconnect ] when ; drop speaker get "slava" = [ disconnect ] when ;

View File

@ -72,7 +72,7 @@ M: number tree-write ( char -- ) write1 ;
: farkup ( str -- html ) : farkup ( str -- html )
'farkup' parse dup nil? '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 ! useful debugging code below
@ -83,4 +83,4 @@ M: number tree-write ( char -- ) write1 ;
: farkup-parsed ( wiki -- all-parses ) : farkup-parsed ( wiki -- all-parses )
! for debugging and optimization only ! for debugging and optimization only
'farkup' parse list>array 'farkup' parse list>array
[ parse-result-parsed [ tree-write ] string-out ] map ; [ parse-result-parsed [ tree-write ] with-string-writer ] map ;

View File

@ -148,13 +148,13 @@ DEFER: name>user
[ httpd ] in-thread drop ; [ httpd ] in-thread drop ;
: onigiri-dump ( path -- ) : onigiri-dump ( path -- )
<file-writer> [ [
[ [
entry get-global serialize entry get-global serialize
meta get-global serialize meta get-global serialize
user get-global serialize user get-global serialize
] with-serialized ] with-serialized
] with-stream ; ] with-file-writer ;
: onigiri-boot ( path -- ) : onigiri-boot ( path -- )
<file-reader> [ <file-reader> [

View File

@ -4,9 +4,9 @@ IN: temporary
SYMBOL: mmap "mmap-test.txt" \ mmap set SYMBOL: mmap "mmap-test.txt" \ mmap set
[ \ mmap get delete-file ] catch drop [ \ mmap get delete-file ] catch drop
\ mmap get <file-writer> [ \ mmap get [
"Four" write "Four" write
] with-stream ] with-file-writer
\ mmap get [ \ mmap get [
>r CHAR: R r> mmap-address 3 set-alien-unsigned-1 >r CHAR: R r> mmap-address 3 set-alien-unsigned-1