-USING: io.binary tools.test ;
+USING: io.binary tools.test classes math ;
IN: io.binary.tests
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test
+
+[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
USING: kernel math sequences ;
IN: io.binary
-: le> ( seq -- x ) B{ } like byte-array>bignum ;
+: le> ( seq -- x ) B{ } like byte-array>bignum >integer ;
: be> ( seq -- x ) <reversed> le> ;
: mask-byte ( x -- y ) HEX: ff bitand ; inline
-USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ;
+USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray )
utf8 decode >array ;
: most-negative-fixnum ( -- n )
first-bignum neg ;
+M: bignum >integer
+ dup most-negative-fixnum most-positive-fixnum between?
+ [ >fixnum ] when ;
+
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ;
: parse-interactive ( string -- quot )
<string-reader> stream-read-quot ;
-[ [ ] ] [
- "USE: listener.tests hello" parse-interactive
-] unit-test
+[
+ [ [ ] ] [
+ "USE: listener.tests hello" parse-interactive
+ ] unit-test
+] with-file-vocabs
[
"debugger" use+
] unit-test
[
- "USE: vocabs.loader.test.c" parse-interactive
-] must-fail
+ [
+ "USE: vocabs.loader.test.c" parse-interactive
+ ] must-fail
+] with-file-vocabs
[ ] [
[
] with-compilation-unit
] unit-test
-[ ] [
- "IN: listener.tests : hello\n\"world\" ;" parse-interactive
+[
+ [ ] [
+ "IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop
-] unit-test
+ ] unit-test
+] with-file-vocabs
M: integer numerator ;
M: integer denominator drop 1 ;
-M: integer >integer ;
M: fixnum >fixnum ;
M: fixnum >bignum fixnum>bignum ;
+M: fixnum >integer ;
M: fixnum number= eq? ;
interval-contains?
] unit-test
+[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
+
! Interval random tester
: random-element ( interval -- n )
dup interval-to first over interval-from first tuck - random +
second execute interval-contains?
] if ;
-[ t ] [ 4000 [ drop interval-test ] all? ] unit-test
+[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
: random-comparison
{
=
] if ;
-[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test
+[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
[ drop 0 ] if ;
: interval-closure ( i1 -- i2 )
- interval>points [ first ] 2apply [a,b] ;
+ dup [ interval>points [ first ] 2apply [a,b] ] when ;
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
-USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ;
+USING: kernel io strings byte-arrays sequences namespaces math
+parser crypto.hmac tools.test ;
IN: crypto.hmac.tests
-[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" string>md5-hmac >string ] unit-test
-[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test
-[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>md5-hmac >string ] unit-test
+[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
+[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
-[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" string>sha1-hmac >string ] unit-test
-[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test
-[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>sha1-hmac >string ] unit-test
+[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
USING: arrays combinators crypto.common crypto.md5 crypto.sha1
-crypto.md5.private io io.binary io.files io.streams.string
+crypto.md5.private io io.binary io.files io.streams.byte-array
kernel math math.vectors memoize sequences io.encodings.binary ;
IN: crypto.hmac
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
-: string>sha1-hmac ( K string -- hmac )
- <string-reader> stream>sha1-hmac ;
+: byte-array>sha1-hmac ( K string -- hmac )
+ binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
-: string>md5-hmac ( K string -- hmac )
- <string-reader> stream>md5-hmac ;
-
+: byte-array>md5-hmac ( K string -- hmac )
+ binary <byte-reader> stream>md5-hmac ;
USING: help.markup help.syntax kernel math sequences quotations
-crypto.common ;
+crypto.common byte-arrays ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." }
-{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
+{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
-HELP: string>md5
-{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } }
-{ $description "Outputs the MD5 hash of a string." }
+HELP: byte-array>md5
+{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
+{ $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5
-USING: kernel math namespaces crypto.md5 tools.test ;
+USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
-[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
-[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
-[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
-[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
-[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
-[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
-[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
+[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
+[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
+[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
+[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
+[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
+[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
+[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test
! See http://www.faqs.org/rfcs/rfc1321.html
-USING: kernel io io.binary io.files io.streams.string math
+USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols ;
: stream>md5 ( stream -- byte-array )
[ initialize-md5 (stream>md5) get-md5 ] with-stream ;
-: string>md5 ( string -- byte-array ) <string-reader> stream>md5 ;
-: string>md5str ( string -- md5-string ) string>md5 hex-string ;
-: file>md5 ( path -- byte-array ) binary <file-reader> stream>md5 ;
-: file>md5str ( path -- md5-string ) file>md5 hex-string ;
+: byte-array>md5 ( byte-array -- checksum )
+ binary <byte-reader> stream>md5 ;
+
+: byte-array>md5str ( byte-array -- md5-string )
+ byte-array>md5 hex-string ;
+
+: file>md5 ( path -- byte-array )
+ binary <file-reader> stream>md5 ;
+
+: file>md5str ( path -- md5-string )
+ file>md5 hex-string ;
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
-[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
-[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
-10 swap <array> concat string>sha1str ] unit-test
+10 swap <array> concat byte-array>sha1str ] unit-test
[
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
- string>sha1-interleave
+ byte-array>sha1-interleave
] unit-test
-USING: arrays combinators crypto.common kernel io io.encodings.binary
-io.files io.streams.string math.vectors strings sequences
-namespaces math parser sequences vectors io.binary
-hashtables symbols ;
+USING: arrays combinators crypto.common kernel io
+io.encodings.binary io.files io.streams.byte-array math.vectors
+strings sequences namespaces math parser sequences vectors
+io.binary hashtables symbols ;
IN: crypto.sha1
! Implemented according to RFC 3174.
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 )
- [ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ;
+ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
-: string>sha1 ( string -- sha1 ) <string-reader> stream>sha1 ;
-: string>sha1str ( string -- str ) string>sha1 hex-string ;
-: string>sha1-bignum ( string -- n ) string>sha1 be> ;
-: file>sha1 ( file -- sha1 ) binary <file-reader> stream>sha1 ;
+: byte-array>sha1 ( string -- sha1 )
+ binary <byte-reader> stream>sha1 ;
-: string>sha1-interleave ( string -- seq )
+: byte-array>sha1str ( string -- str )
+ byte-array>sha1 hex-string ;
+
+: byte-array>sha1-bignum ( string -- n )
+ byte-array>sha1 be> ;
+
+: file>sha1 ( file -- sha1 )
+ binary <file-reader> stream>sha1 ;
+
+: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
- seq>2seq [ string>sha1 ] 2apply
+ seq>2seq [ byte-array>sha1 ] 2apply
swap 2seq>seq ;
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test
T1 T2 update-vars
] with each vars get H get [ w+ ] 2map H set ;
-: seq>string ( n seq -- string )
- [ swap [ >be % ] curry each ] "" make ;
+: seq>byte-array ( n seq -- string )
+ [ swap [ >be % ] curry each ] B{ } make ;
-: string>sha2 ( string -- string )
+: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each
- 4 H get seq>string ;
+ 4 H get seq>byte-array ;
PRIVATE>
-: string>sha-256 ( string -- string )
+: byte-array>sha-256 ( string -- string )
[
K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
\ >32-bit >word set
- string>sha2
+ byte-array>sha2
] with-scope ;
-: string>sha-256-string ( string -- hexstring )
- string>sha-256 hex-string ;
+: byte-array>sha-256-string ( string -- hexstring )
+ byte-array>sha-256 hex-string ;
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
- ;
+ drop ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
-M: mysql-db <simple-statement> ( str -- statement )
- ;
+M: mysql-db <simple-statement> ( str in out -- statement )
+ 3drop f ;
-M: mysql-db <prepared-statement> ( str -- statement )
- ;
+M: mysql-db <prepared-statement> ( str in out -- statement )
+ 3drop f ;
M: mysql-statement prepare-statement ( statement -- )
- ;
+ drop ;
M: mysql-statement bind-statement* ( statement -- )
- ;
+ drop ;
M: mysql-statement query-results ( query -- result-set )
- ;
+ drop f ;
M: mysql-result-set #rows ( result-set -- n )
- ;
+ drop 0 ;
M: mysql-result-set #columns ( result-set -- n )
- ;
+ drop 0 ;
M: mysql-result-set row-column ( result-set n -- obj )
- ;
+ 2drop f ;
-M: mysql-result-set advance-row ( result-set -- ? )
- ;
+M: mysql-result-set advance-row ( result-set -- )
+ drop ;
M: mysql-db begin-transaction ( -- )
;
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 2 }
{ deploy-io 1 }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
{ deploy-compiler? t }
+ { deploy-word-defs? f }
+ { deploy-word-props? f }
+ { deploy-math? t }
{ deploy-name "Hello world" }
{ deploy-c-types? f }
+ { deploy-ui? t }
+ { deploy-threads? t }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
}
USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating.fhtml kernel tools.test sequences ;
+http.server.templating.fhtml kernel tools.test sequences
+parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
[ t ] [ "bug" test-template ] unit-test
[ t ] [ "stack" test-template ] unit-test
-[ ] [ "<%\n%>" parse-template drop ] unit-test
+[
+ [ ] [ "<%\n%>" parse-template drop ] unit-test
+] with-file-vocabs
-USING: help.markup help.syntax strings alien ;
+USING: help.markup help.syntax byte-arrays alien ;
IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers"
-"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
+"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
$nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer }
{ $subsection buffer-until }
"Writing to the buffer:"
{ $subsection extend-buffer }
-{ $subsection ch>buffer }
+{ $subsection byte>buffer }
{ $subsection >buffer }
{ $subsection n>buffer } ;
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: (buffer>>)
-{ $values { "buffer" buffer } { "string" "a string" } }
+{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the entire contents of the buffer into a string." } ;
HELP: buffer-reset
{ $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer>)
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } }
+{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } }
+{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>>
-{ $values { "buffer" buffer } { "string" "a string" } }
+{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
HELP: buffer-length
{ $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
HELP: >buffer
-{ $values { "string" "a string" } { "buffer" buffer } }
+{ $values { "byte-array" byte-array } { "buffer" buffer } }
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
-HELP: ch>buffer
-{ $values { "ch" "a character" } { "buffer" buffer } }
+HELP: byte>buffer
+{ $values { "byte" "a byte" } { "buffer" buffer } }
{ $description "Appends a single byte to a buffer." } ;
HELP: n>buffer
{ $description "Outputs the byte at the buffer position and advances the position." } ;
HELP: buffer-until
-{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } }
-{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
+{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } }
+{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
-sequences tools.test namespaces ;
+sequences tools.test namespaces byte-arrays strings ;
: buffer-set ( string buffer -- )
- 2dup buffer-ptr string>char-memory
+ over >byte-array over buffer-ptr byte-array>memory
>r length r> buffer-reset ;
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
-[ "" 65536 ] [
+[ B{ } 65536 ] [
65536 <buffer>
dup (buffer>>)
over buffer-capacity
[ "hello world" "" ] [
"hello world" string>buffer
- dup (buffer>>)
+ dup (buffer>>) >string
0 pick buffer-reset
- over (buffer>>)
+ over (buffer>>) >string
rot buffer-free
] unit-test
[ "hello" ] [
"hello world" string>buffer
- 5 over buffer> swap buffer-free
+ 5 over buffer> >string swap buffer-free
] unit-test
[ 11 ] [
[ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep
- " world" over >buffer
- dup (buffer>>) swap buffer-free
+ " world" >byte-array over >buffer
+ dup (buffer>>) >string swap buffer-free
] unit-test
[ CHAR: e ] [
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
- "\r" over buffer-until
+ "\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
- "\n\r" over buffer-until
+ "\n\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello\rworld" f ] [
"hello\rworld" string>buffer
- "X" over buffer-until
+ "X" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r "world" CHAR: \n ] [
"hello\rworld\n" string>buffer
- [ "\r\n" swap buffer-until ] keep
- [ "\r\n" swap buffer-until ] keep
+ [ "\r\n" swap buffer-until >r >string r> ] keep
+ [ "\r\n" swap buffer-until >r >string r> ] keep
buffer-free
] unit-test
"hello world" string>buffer "b" set
-[ "hello world" ] [ 1000 "b" get buffer> ] unit-test
+[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test
"b" get buffer-free
100 <buffer> "b" set
-[ 1000 "b" get n>buffer ] must-fail
+[ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free
[ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
-: ch>buffer ( ch buffer -- )
+: byte>buffer ( ch buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
[ buffer-fill 1+ ] keep set-buffer-fill ;
USING: io io.buffers io.backend help.markup help.syntax kernel
-strings sbufs words continuations ;
+byte-arrays sbufs words continuations byte-vectors ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: read-until-step
-{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } }
+{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } }
{ $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ;
HELP: read-until-loop
-{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } }
-{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
+{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } }
+{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
HELP: can-write?
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
[ wait-to-read ] 2keep
[ dupd buffer> ] unless-eof nip ;
-: read-loop ( count port sbuf -- )
+: read-loop ( count port accum -- )
pick over length - dup 0 > [
pick read-step dup [
over push-all read-loop
tuck can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
- 1 over wait-to-write ch>buffer ;
+ 1 over wait-to-write byte>buffer ;
M: output-port stream-write
over length over buffer-size > [
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields ;
+combinators math.bitfields strings ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
{ [ t ] [ +modify-file+ ] }
} cond nip ;
+: memory>u16-string ( alien len -- string )
+ [ memory>byte-array ] keep 2/ c-ushort-array> >string ;
+
: parse-file-notify ( buffer -- changed path )
{
FILE_NOTIFY_INFORMATION-FileName
-USING: koszul tools.test kernel sequences assocs namespaces ;
+USING: koszul tools.test kernel sequences assocs namespaces
+symbols ;
IN: koszul.tests
[
}
{ $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] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
+ { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" }
}
{ $see-also deserialize (deserialize) serialize with-serialized } ;
}
{ $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] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
+ { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" }
}
{ $see-also (serialize) deserialize serialize 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] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
+ { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" }
}
{ $see-also (serialize) (deserialize) serialize deserialize } ;
}
{ $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 ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
+ { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
}
{ $see-also deserialize (deserialize) (serialize) with-serialized } ;
}
{ $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 ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
+ { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
}
{ $see-also (serialize) deserialize (deserialize) with-serialized } ;
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: tools.test kernel serialize io io.streams.string math
+USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
-classes math.constants ;
+classes math.constants io.encodings.binary random
+combinators.lib ;
IN: serialize.tests
+: test-serialize-cell
+ 2^ random dup
+ binary [ serialize-cell ] with-byte-writer
+ binary [ deserialize-cell ] with-byte-reader = ;
+
+[ t ] [
+ 100 [
+ drop
+ {
+ [ 40 [ test-serialize-cell ] all? ]
+ [ 4 [ 40 * test-serialize-cell ] all? ]
+ [ 4 [ 400 * test-serialize-cell ] all? ]
+ [ 4 [ 4000 * test-serialize-cell ] all? ]
+ } &&
+ ] all?
+] unit-test
+
TUPLE: serialize-test a b ;
C: <serialize-test> serialize-test
{ 1 2 "three" }
V{ 1 2 "three" }
SBUF" hello world"
+ "hello \u123456 unicode"
\ dup
[ \ dup dup ]
T{ serialize-test f "a" 2 }
: check-serialize-1 ( obj -- ? )
dup class .
- dup [ serialize ] with-string-writer
- [ deserialize ] with-string-reader = ;
+ dup
+ binary [ serialize ] with-byte-writer
+ binary [ deserialize ] with-byte-reader = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
] [
dup class .
dup 2array
- [ serialize ] with-string-writer
- [ deserialize ] with-string-reader
+ binary [ serialize ] with-byte-writer
+ binary [ deserialize ] with-byte-reader
first2 eq?
] if ;
[ t ] [ pi check-serialize-1 ] unit-test
[ t ] [
- { 1 2 3 } [
+ { 1 2 3 }
+ binary [
[
dup (serialize) (serialize)
] with-serialized
- ] with-string-writer [
- deserialize-sequence all-eq?
- ] with-string-reader
+ ] with-byte-writer
+ binary [ deserialize-sequence all-eq? ] with-byte-reader
] unit-test
+
+[ serialize ] must-infer
+[ deserialize ] must-infer
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
-assocs help.syntax help.markup float-arrays splitting ;
+assocs help.syntax help.markup float-arrays splitting
+io.encodings.string io.encodings.utf8 combinators ;
! Variable holding a sequence of objects already serialized
SYMBOL: serialized
#! Return the id of an already serialized object
serialized get [ eq? ] with find [ drop f ] unless ;
-USE: prettyprint
-
! Serialize object
GENERIC: (serialize) ( obj -- )
-: serialize-cell 8 >be write ;
+! Numbers are serialized as follows:
+! 0 => B{ 0 }
+! 1<=x<=126 => B{ x | 0x80 }
+! x>127 => B{ length(x) x[0] x[1] ... }
+! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... }
+! The last case is needed because a very large number would
+! otherwise be confused with a small number.
+: serialize-cell ( n -- )
+ dup zero? [ drop 0 write1 ] [
+ dup HEX: 7e <= [
+ HEX: 80 bitor write1
+ ] [
+ dup log2 8 /i 1+
+ dup HEX: 7f >= [
+ HEX: ff write1
+ dup serialize-cell
+ ] [
+ dup write1
+ ] if
+ >be write
+ ] if
+ ] if ;
-: deserialize-cell 8 read be> ;
+: deserialize-cell ( -- n )
+ read1 {
+ { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
+ { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
+ { [ t ] [ read be> ] }
+ } cond ;
: serialize-shared ( obj quot -- )
>r dup object-id
- [ "o" write serialize-cell drop ] r> if* ; inline
+ [ CHAR: o write1 serialize-cell drop ] r> if* ; inline
M: f (serialize) ( obj -- )
- drop "n" write ;
-
-: bytes-needed ( number -- int )
- log2 8 + 8 /i ; inline
+ drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup 0 = [
- drop "z" write
+ dup zero? [
+ drop CHAR: z write1
] [
- dup 0 < [ neg "m" ] [ "p" ] if write
- dup bytes-needed dup serialize-cell
- >be write
+ dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
+ serialize-cell
] if ;
M: float (serialize) ( obj -- )
- "F" write
+ CHAR: F write1
double>bits serialize-cell ;
M: complex (serialize) ( obj -- )
- "c" write
+ CHAR: c write1
dup real-part (serialize)
imaginary-part (serialize) ;
M: ratio (serialize) ( obj -- )
- "r" write
+ CHAR: r write1
dup numerator (serialize)
denominator (serialize) ;
+: serialize-string ( obj code -- )
+ write1
+ dup add-object serialize-cell
+ utf8 encode
+ dup length serialize-cell
+ write ;
+
M: string (serialize) ( obj -- )
- [
- "s" write
- dup add-object serialize-cell
- dup length serialize-cell
- write
- ] serialize-shared ;
+ [ CHAR: s serialize-string ] serialize-shared ;
-M: sbuf (serialize) ( obj -- )
- [
- "S" write
- dup add-object serialize-cell
- dup length serialize-cell
- >string write
- ] serialize-shared ;
+: serialize-elements
+ [ (serialize) ] each CHAR: . write1 ;
M: tuple (serialize) ( obj -- )
[
- "T" write
+ CHAR: T write1
dup add-object serialize-cell
- tuple>array
- dup length serialize-cell
- [ (serialize) ] each
+ tuple>array serialize-elements
] serialize-shared ;
: serialize-seq ( seq code -- )
[
- write
+ write1
dup add-object serialize-cell
- dup length serialize-cell
- [ (serialize) ] each
+ serialize-elements
] curry serialize-shared ;
M: array (serialize) ( obj -- )
- "a" serialize-seq ;
-
-M: vector (serialize) ( obj -- )
- "v" serialize-seq ;
+ CHAR: a serialize-seq ;
M: byte-array (serialize) ( obj -- )
- "A" serialize-seq ;
+ [
+ CHAR: A write1
+ dup add-object serialize-cell
+ dup length serialize-cell write
+ ] serialize-shared ;
M: bit-array (serialize) ( obj -- )
- "b" serialize-seq ;
-
-M: quotation (serialize) ( obj -- )
- "q" serialize-seq ;
-
-M: curry (serialize) ( obj -- )
[
- "C" write
+ CHAR: b write1
dup add-object serialize-cell
- dup curry-obj (serialize) curry-quot (serialize)
+ dup length serialize-cell
+ [ 1 0 ? ] B{ } map-as write
] serialize-shared ;
+M: quotation (serialize) ( obj -- )
+ CHAR: q serialize-seq ;
+
M: float-array (serialize) ( obj -- )
[
- "f" write
+ CHAR: f write1
dup add-object serialize-cell
dup length serialize-cell
[ double>bits 8 >be write ] each
M: hashtable (serialize) ( obj -- )
[
- "h" write
+ CHAR: h write1
dup add-object serialize-cell
>alist (serialize)
] serialize-shared ;
M: word (serialize) ( obj -- )
- "w" write
+ CHAR: w write1
dup word-name (serialize)
word-vocabulary (serialize) ;
M: wrapper (serialize) ( obj -- )
- "W" write
+ CHAR: W write1
wrapped (serialize) ;
DEFER: (deserialize) ( -- obj )
f ;
: deserialize-positive-integer ( -- number )
- deserialize-cell read be> ;
+ deserialize-cell ;
: deserialize-negative-integer ( -- number )
deserialize-positive-integer neg ;
: deserialize-complex ( -- complex )
(deserialize) (deserialize) rect> ;
-: deserialize-string ( -- string )
- deserialize-cell deserialize-cell read intern-object ;
+: (deserialize-string) ( -- string )
+ deserialize-cell read utf8 decode ;
-: deserialize-sbuf ( -- sbuf )
- deserialize-cell deserialize-cell read >sbuf intern-object ;
+: deserialize-string ( -- string )
+ deserialize-cell (deserialize-string) intern-object ;
: deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
+SYMBOL: +stop+
+
+: (deserialize-seq)
+ [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
+
: deserialize-seq ( seq -- array )
- deserialize-cell deserialize-cell
- [ drop (deserialize) ] roll map-as
- intern-object ;
+ >r deserialize-cell (deserialize-seq) r> like intern-object ;
: deserialize-array ( -- array )
{ } deserialize-seq ;
-: deserialize-vector ( -- array )
- V{ } deserialize-seq ;
-
: deserialize-quotation ( -- array )
[ ] deserialize-seq ;
+: (deserialize-byte-array) ( -- byte-array )
+ deserialize-cell read B{ } like ;
+
: deserialize-byte-array ( -- byte-array )
- B{ } deserialize-seq ;
+ deserialize-cell (deserialize-byte-array) intern-object ;
: deserialize-bit-array ( -- bit-array )
- ?{ } deserialize-seq ;
+ deserialize-cell
+ (deserialize-byte-array) [ 0 > ] ?{ } map-as
+ intern-object ;
: deserialize-float-array ( -- float-array )
deserialize-cell deserialize-cell
deserialize-cell (deserialize) >hashtable intern-object ;
: deserialize-tuple ( -- array )
- deserialize-cell
- deserialize-cell [ drop (deserialize) ] map >tuple
- intern-object ;
-
-: deserialize-curry ( -- curry )
- deserialize-cell
- (deserialize) (deserialize) curry
- intern-object ;
+ deserialize-cell (deserialize-seq) >tuple intern-object ;
: deserialize-unknown ( -- object )
deserialize-cell serialized get nth ;
+: deserialize-stop ( -- object )
+ +stop+ get ;
+
: deserialize* ( -- object ? )
read1 [
- H{
- { CHAR: A deserialize-byte-array }
- { CHAR: C deserialize-curry }
- { CHAR: F deserialize-float }
- { CHAR: S deserialize-sbuf }
- { CHAR: T deserialize-tuple }
- { CHAR: W deserialize-wrapper }
- { CHAR: a deserialize-array }
- { CHAR: b deserialize-bit-array }
- { CHAR: c deserialize-complex }
- { CHAR: f deserialize-float-array }
- { CHAR: h deserialize-hashtable }
- { CHAR: m deserialize-negative-integer }
- { CHAR: n deserialize-false }
- { CHAR: o deserialize-unknown }
- { CHAR: p deserialize-positive-integer }
- { CHAR: q deserialize-quotation }
- { CHAR: r deserialize-ratio }
- { CHAR: s deserialize-string }
- { CHAR: v deserialize-vector }
- { CHAR: w deserialize-word }
- { CHAR: z deserialize-zero }
- } at dup [ "Unknown typecode" throw ] unless execute t
+ {
+ { CHAR: A [ deserialize-byte-array ] }
+ { CHAR: F [ deserialize-float ] }
+ { CHAR: T [ deserialize-tuple ] }
+ { CHAR: W [ deserialize-wrapper ] }
+ { CHAR: a [ deserialize-array ] }
+ { CHAR: b [ deserialize-bit-array ] }
+ { CHAR: c [ deserialize-complex ] }
+ { CHAR: f [ deserialize-float-array ] }
+ { CHAR: h [ deserialize-hashtable ] }
+ { CHAR: m [ deserialize-negative-integer ] }
+ { CHAR: n [ deserialize-false ] }
+ { CHAR: o [ deserialize-unknown ] }
+ { CHAR: p [ deserialize-positive-integer ] }
+ { CHAR: q [ deserialize-quotation ] }
+ { CHAR: r [ deserialize-ratio ] }
+ { CHAR: s [ deserialize-string ] }
+ { CHAR: w [ deserialize-word ] }
+ { CHAR: z [ deserialize-zero ] }
+ { CHAR: . [ deserialize-stop ] }
+ } case t
] [
f f
] if* ;
deserialize* [ "End of stream" throw ] unless ;
: with-serialized ( quot -- )
- V{ } clone serialized rot with-variable ; inline
+ [
+ V{ } clone serialized set
+ gensym +stop+ set
+ call
+ ] with-scope ; inline
: deserialize-sequence ( -- seq )
[ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;
projects / factor.git / commitdiff