Various fixes
Slava Pestov
parent
4de55d0716
commit
7ad74eb320
|
|
@ -1,4 +1,4 @@
|
|||
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
|
||||
|
|
@ -6,3 +6,5 @@ IN: io.binary.tests
|
|||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -33,6 +33,10 @@ SYMBOL: type-numbers
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -8,9 +8,11 @@ IN: listener.tests
|
|||
: 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+
|
||||
|
|
@ -35,8 +37,10 @@ IN: listener.tests
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"USE: vocabs.loader.test.c" parse-interactive
|
||||
] must-fail
|
||||
[
|
||||
"USE: vocabs.loader.test.c" parse-interactive
|
||||
] must-fail
|
||||
] with-file-vocabs
|
||||
|
||||
[ ] [
|
||||
[
|
||||
|
|
@ -44,7 +48,9 @@ IN: listener.tests
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ IN: math.integers.private
|
|||
|
||||
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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -156,6 +156,8 @@ IN: math.intervals.tests
|
|||
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 +
|
||||
|
|
@ -200,7 +202,7 @@ IN: math.intervals.tests
|
|||
second execute interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 4000 [ drop interval-test ] all? ] unit-test
|
||||
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
|
||||
|
||||
: random-comparison
|
||||
{
|
||||
|
|
@ -219,4 +221,4 @@ IN: math.intervals.tests
|
|||
=
|
||||
] if ;
|
||||
|
||||
[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test
|
||||
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ C: <interval> interval
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
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
|
||||
|
||||
|
|
@ -34,8 +34,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
|
|||
: 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 )
|
||||
|
|
@ -44,6 +44,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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 ;
|
||||
|
|
@ -178,7 +178,14 @@ PRIVATE>
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
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.
|
||||
|
|
@ -107,15 +107,22 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
|||
[ [ 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -108,25 +108,25 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -9,37 +9,37 @@ TUPLE: mysql-statement ;
|
|||
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 ( -- )
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,14 @@
|
|||
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 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
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 -- ? )
|
||||
|
|
@ -14,4 +15,6 @@ IN: http.server.templating.fhtml.tests
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
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 }
|
||||
|
|
@ -23,7 +23,7 @@ $nl
|
|||
{ $subsection buffer-until }
|
||||
"Writing to the buffer:"
|
||||
{ $subsection extend-buffer }
|
||||
{ $subsection ch>buffer }
|
||||
{ $subsection byte>buffer }
|
||||
{ $subsection >buffer }
|
||||
{ $subsection n>buffer } ;
|
||||
|
||||
|
|
@ -48,7 +48,7 @@ HELP: buffer-free
|
|||
{ $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
|
||||
|
|
@ -68,15 +68,15 @@ HELP: buffer-end
|
|||
{ $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
|
||||
|
|
@ -102,11 +102,11 @@ HELP: check-overflow
|
|||
{ $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
|
||||
|
|
@ -123,5 +123,5 @@ HELP: buffer-pop
|
|||
{ $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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
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
|
||||
|
|
@ -18,15 +18,15 @@ sequences tools.test namespaces ;
|
|||
|
||||
[ "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 ] [
|
||||
|
|
@ -36,8 +36,8 @@ sequences tools.test namespaces ;
|
|||
|
||||
[ "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 ] [
|
||||
|
|
@ -47,33 +47,33 @@ sequences tools.test namespaces ;
|
|||
|
||||
[ "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
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
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"
|
||||
|
|
@ -93,12 +93,12 @@ HELP: unless-eof
|
|||
{ $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" } }
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ M: input-port stream-read1
|
|||
[ 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
|
||||
|
|
@ -143,7 +143,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f )
|
|||
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 > [
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
|
|||
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 )
|
||||
|
|
@ -66,6 +66,9 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
|||
{ [ 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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: koszul tools.test kernel sequences assocs namespaces ;
|
||||
USING: koszul tools.test kernel sequences assocs namespaces
|
||||
symbols ;
|
||||
IN: koszul.tests
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ HELP: (serialize)
|
|||
}
|
||||
{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] 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 } ;
|
||||
|
||||
|
|
@ -17,7 +17,7 @@ HELP: (deserialize)
|
|||
}
|
||||
{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] 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 } ;
|
||||
|
||||
|
|
@ -26,7 +26,7 @@ HELP: with-serialized
|
|||
}
|
||||
{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] 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 } ;
|
||||
|
||||
|
|
@ -35,7 +35,7 @@ HELP: serialize
|
|||
}
|
||||
{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] 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 } ;
|
||||
|
||||
|
|
@ -44,6 +44,6 @@ HELP: deserialize
|
|||
}
|
||||
{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." }
|
||||
{ $examples
|
||||
{ $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] 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 } ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,29 @@
|
|||
! 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
|
||||
|
|
@ -25,6 +43,7 @@ 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 }
|
||||
|
|
@ -38,8 +57,9 @@ C: <serialize-test> serialize-test
|
|||
|
||||
: 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 [
|
||||
|
|
@ -47,8 +67,8 @@ C: <serialize-test> serialize-test
|
|||
] [
|
||||
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 ;
|
||||
|
||||
|
|
@ -59,11 +79,14 @@ C: <serialize-test> serialize-test
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ IN: serialize
|
|||
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
|
||||
|
|
@ -24,106 +25,119 @@ 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) ;
|
||||
|
||||
M: string (serialize) ( obj -- )
|
||||
[
|
||||
"s" write
|
||||
dup add-object serialize-cell
|
||||
dup length serialize-cell
|
||||
write
|
||||
] serialize-shared ;
|
||||
: serialize-string ( obj code -- )
|
||||
write1
|
||||
dup add-object serialize-cell
|
||||
utf8 encode
|
||||
dup length serialize-cell
|
||||
write ;
|
||||
|
||||
M: sbuf (serialize) ( obj -- )
|
||||
[
|
||||
"S" write
|
||||
dup add-object serialize-cell
|
||||
dup length serialize-cell
|
||||
>string write
|
||||
] serialize-shared ;
|
||||
M: string (serialize) ( obj -- )
|
||||
[ CHAR: s serialize-string ] 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 ;
|
||||
[
|
||||
CHAR: b write1
|
||||
dup add-object serialize-cell
|
||||
dup length serialize-cell
|
||||
[ 1 0 ? ] B{ } map-as write
|
||||
] serialize-shared ;
|
||||
|
||||
M: quotation (serialize) ( obj -- )
|
||||
"q" serialize-seq ;
|
||||
|
||||
M: curry (serialize) ( obj -- )
|
||||
[
|
||||
"C" write
|
||||
dup add-object serialize-cell
|
||||
dup curry-obj (serialize) curry-quot (serialize)
|
||||
] serialize-shared ;
|
||||
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
|
||||
|
|
@ -131,18 +145,18 @@ M: float-array (serialize) ( obj -- )
|
|||
|
||||
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 )
|
||||
|
|
@ -154,7 +168,7 @@ DEFER: (deserialize) ( -- obj )
|
|||
f ;
|
||||
|
||||
: deserialize-positive-integer ( -- number )
|
||||
deserialize-cell read be> ;
|
||||
deserialize-cell ;
|
||||
|
||||
: deserialize-negative-integer ( -- number )
|
||||
deserialize-positive-integer neg ;
|
||||
|
|
@ -171,11 +185,11 @@ DEFER: (deserialize) ( -- obj )
|
|||
: 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
|
||||
|
|
@ -184,25 +198,30 @@ DEFER: (deserialize) ( -- obj )
|
|||
: 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
|
||||
|
|
@ -213,43 +232,37 @@ DEFER: (deserialize) ( -- obj )
|
|||
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* ;
|
||||
|
|
@ -258,7 +271,11 @@ DEFER: (deserialize) ( -- obj )
|
|||
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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue