steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Various fixes

db4
Slava Pestov 2008-03-08 02:51:26 -06:00
parent 4de55d0716
commit 7ad74eb320
30 changed files with 325 additions and 249 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/io/binary/binary-tests.factor
View File

@ -1,4 +1,4 @@
USING: io.binary tools.test ; USING: io.binary tools.test classes math ;
IN: io.binary.tests IN: io.binary.tests
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test [ 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 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] 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

2
core/io/binary/binary.factor
View File

@ -3,7 +3,7 @@
USING: kernel math sequences ; USING: kernel math sequences ;
IN: io.binary 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> ; : be> ( seq -- x ) <reversed> le> ;
: mask-byte ( x -- y ) HEX: ff bitand ; inline : mask-byte ( x -- y ) HEX: ff bitand ; inline

2
core/io/encodings/utf8/utf8-tests.factor Normal file → Executable file
View File

@ -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 ) : decode-utf8-w/stream ( array -- newarray )
utf8 decode >array ; utf8 decode >array ;

4
core/layouts/layouts.factor
View File

@ -33,6 +33,10 @@ SYMBOL: type-numbers
: most-negative-fixnum ( -- n ) : most-negative-fixnum ( -- n )
first-bignum neg ; first-bignum neg ;
M: bignum >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] when ;
M: real >integer M: real >integer
dup most-negative-fixnum most-positive-fixnum between? dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ; [ >fixnum ] [ >bignum ] if ;

16
core/listener/listener-tests.factor
View File

@ -8,9 +8,11 @@ IN: listener.tests
: parse-interactive ( string -- quot ) : parse-interactive ( string -- quot )
<string-reader> stream-read-quot ; <string-reader> stream-read-quot ;
[ [ ] ] [ [
[ [ ] ] [
"USE: listener.tests hello" parse-interactive "USE: listener.tests hello" parse-interactive
] unit-test ] unit-test
] with-file-vocabs
[ [
"debugger" use+ "debugger" use+
@ -35,8 +37,10 @@ IN: listener.tests
] unit-test ] unit-test
[ [
[
"USE: vocabs.loader.test.c" parse-interactive "USE: vocabs.loader.test.c" parse-interactive
] must-fail ] must-fail
] with-file-vocabs
[ ] [ [ ] [
[ [
@ -44,7 +48,9 @@ IN: listener.tests
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ ] [ [
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive "IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test
] with-file-vocabs

2
core/math/integers/integers.factor
View File

@ -6,10 +6,10 @@ IN: math.integers.private
M: integer numerator ; M: integer numerator ;
M: integer denominator drop 1 ; M: integer denominator drop 1 ;
M: integer >integer ;
M: fixnum >fixnum ; M: fixnum >fixnum ;
M: fixnum >bignum fixnum>bignum ; M: fixnum >bignum fixnum>bignum ;
M: fixnum >integer ;
M: fixnum number= eq? ; M: fixnum number= eq? ;

6
core/math/intervals/intervals-tests.factor
View File

@ -156,6 +156,8 @@ IN: math.intervals.tests
interval-contains? interval-contains?
] unit-test ] unit-test
[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
! Interval random tester ! Interval random tester
: random-element ( interval -- n ) : random-element ( interval -- n )
dup interval-to first over interval-from first tuck - random + dup interval-to first over interval-from first tuck - random +
@ -200,7 +202,7 @@ IN: math.intervals.tests
second execute interval-contains? second execute interval-contains?
] if ; ] if ;
[ t ] [ 4000 [ drop interval-test ] all? ] unit-test [ t ] [ 40000 [ drop interval-test ] all? ] unit-test
: random-comparison : random-comparison
{ {
@ -219,4 +221,4 @@ IN: math.intervals.tests
= =
] if ; ] if ;
[ t ] [ 4000 [ drop comparison-test ] all? ] unit-test [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test

2
core/math/intervals/intervals.factor Normal file → Executable file
View File

@ -141,7 +141,7 @@ C: <interval> interval
[ drop 0 ] if ; [ drop 0 ] if ;
: interval-closure ( i1 -- i2 ) : interval-closure ( i1 -- i2 )
interval>points [ first ] 2apply [a,b] ; dup [ interval>points [ first ] 2apply [a,b] ] when ;
: interval-shift ( i1 i2 -- i3 ) : interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! Inaccurate; could be tighter

15
extra/crypto/hmac/hmac-tests.factor
View File

@ -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 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 [ "\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?" string>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 <string> 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 <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 [ "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?" 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?" >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 <string> 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 <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test

11
extra/crypto/hmac/hmac.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: arrays combinators crypto.common crypto.md5 crypto.sha1 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 ; kernel math math.vectors memoize sequences io.encodings.binary ;
IN: crypto.hmac IN: crypto.hmac
@ -34,8 +34,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>sha1-hmac ( K path -- hmac ) : file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ; binary <file-reader> stream>sha1-hmac ;
: string>sha1-hmac ( K string -- hmac ) : byte-array>sha1-hmac ( K string -- hmac )
<string-reader> stream>sha1-hmac ; binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac ) : stream>md5-hmac ( K stream -- hmac )
@ -44,6 +44,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>md5-hmac ( K path -- hmac ) : file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ; binary <file-reader> stream>md5-hmac ;
: string>md5-hmac ( K string -- hmac ) : byte-array>md5-hmac ( K string -- hmac )
<string-reader> stream>md5-hmac ; binary <byte-reader> stream>md5-hmac ;

10
extra/crypto/md5/md5-docs.factor Normal file → Executable file
View File

@ -1,15 +1,15 @@
USING: help.markup help.syntax kernel math sequences quotations USING: help.markup help.syntax kernel math sequences quotations
crypto.common ; crypto.common byte-arrays ;
IN: crypto.md5 IN: crypto.md5
HELP: stream>md5 HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } } { $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." } { $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 HELP: byte-array>md5
{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } } { $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
{ $description "Outputs the MD5 hash of a string." } { $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ; { $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5 HELP: file>md5

16
extra/crypto/md5/md5-tests.factor Normal file → Executable file
View File

@ -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 [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test [ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test [ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test [ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test [ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test [ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test

17
extra/crypto/md5/md5.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! See http://www.faqs.org/rfcs/rfc1321.html ! 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 math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols ; io.encodings.binary symbols ;
@ -178,7 +178,14 @@ PRIVATE>
: stream>md5 ( stream -- byte-array ) : stream>md5 ( stream -- byte-array )
[ initialize-md5 (stream>md5) get-md5 ] with-stream ; [ initialize-md5 (stream>md5) get-md5 ] with-stream ;
: string>md5 ( string -- byte-array ) <string-reader> stream>md5 ; : byte-array>md5 ( byte-array -- checksum )
: string>md5str ( string -- md5-string ) string>md5 hex-string ; binary <byte-reader> stream>md5 ;
: file>md5 ( path -- byte-array ) binary <file-reader> stream>md5 ;
: file>md5str ( path -- md5-string ) file>md5 hex-string ; : 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 ;

8
extra/crypto/sha1/sha1-tests.factor
View File

@ -1,14 +1,14 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test [ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test [ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ "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" ";\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" "\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 ] unit-test

29
extra/crypto/sha1/sha1.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: arrays combinators crypto.common kernel io io.encodings.binary USING: arrays combinators crypto.common kernel io
io.files io.streams.string math.vectors strings sequences io.encodings.binary io.files io.streams.byte-array math.vectors
namespaces math parser sequences vectors io.binary strings sequences namespaces math parser sequences vectors
hashtables symbols ; io.binary hashtables symbols ;
IN: crypto.sha1 IN: crypto.sha1
! Implemented according to RFC 3174. ! 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 ; [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 ) : 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 ; : byte-array>sha1 ( string -- sha1 )
: string>sha1str ( string -- str ) string>sha1 hex-string ; binary <byte-reader> stream>sha1 ;
: string>sha1-bignum ( string -- n ) string>sha1 be> ;
: file>sha1 ( file -- sha1 ) binary <file-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 [ zero? ] left-trim
dup length odd? [ 1 tail ] when dup length odd? [ 1 tail ] when
seq>2seq [ string>sha1 ] 2apply seq>2seq [ byte-array>sha1 ] 2apply
swap 2seq>seq ; swap 2seq>seq ;

12
extra/crypto/sha2/sha2-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ; USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test [ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test [ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test [ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test [ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test [ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test [ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test

16
extra/crypto/sha2/sha2.factor Normal file → Executable file
View File

@ -108,25 +108,25 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
T1 T2 update-vars T1 T2 update-vars
] with each vars get H get [ w+ ] 2map H set ; ] with each vars get H get [ w+ ] 2map H set ;
: seq>string ( n seq -- string ) : seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] "" make ; [ swap [ >be % ] curry each ] B{ } make ;
: string>sha2 ( string -- string ) : byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext t preprocess-plaintext
block-size get group [ process-chunk ] each block-size get group [ process-chunk ] each
4 H get seq>string ; 4 H get seq>byte-array ;
PRIVATE> PRIVATE>
: string>sha-256 ( string -- string ) : byte-array>sha-256 ( string -- string )
[ [
K-256 K set K-256 K set
initial-H-256 H set initial-H-256 H set
4 word-size set 4 word-size set
64 block-size set 64 block-size set
\ >32-bit >word set \ >32-bit >word set
string>sha2 byte-array>sha2
] with-scope ; ] with-scope ;
: string>sha-256-string ( string -- hexstring ) : byte-array>sha-256-string ( string -- hexstring )
string>sha-256 hex-string ; byte-array>sha-256 hex-string ;

26
extra/db/mysql/mysql.factor Normal file → Executable file
View File

@ -9,37 +9,37 @@ TUPLE: mysql-statement ;
TUPLE: mysql-result-set ; TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- ) M: mysql-db db-open ( mysql-db -- )
; drop ;
M: mysql-db dispose ( mysql-db -- ) M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ; 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 -- ) M: mysql-statement prepare-statement ( statement -- )
; drop ;
M: mysql-statement bind-statement* ( statement -- ) M: mysql-statement bind-statement* ( statement -- )
; drop ;
M: mysql-statement query-results ( query -- result-set ) M: mysql-statement query-results ( query -- result-set )
; drop f ;
M: mysql-result-set #rows ( result-set -- n ) M: mysql-result-set #rows ( result-set -- n )
; drop 0 ;
M: mysql-result-set #columns ( result-set -- n ) M: mysql-result-set #columns ( result-set -- n )
; drop 0 ;
M: mysql-result-set row-column ( result-set n -- obj ) 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 ( -- ) M: mysql-db begin-transaction ( -- )
; ;

13
extra/hello-ui/deploy.factor
View File

@ -1,13 +1,14 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
H{ H{
{ deploy-math? t }
{ deploy-reflection 2 }
{ deploy-io 1 } { deploy-io 1 }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-name "Hello world" } { deploy-name "Hello world" }
{ deploy-c-types? f } { deploy-c-types? f }
{ deploy-ui? t }
{ deploy-threads? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
} }

7
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -1,5 +1,6 @@
USING: io io.files io.streams.string io.encodings.utf8 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 IN: http.server.templating.fhtml.tests
: test-template ( path -- ? ) : test-template ( path -- ? )
@ -14,4 +15,6 @@ IN: http.server.templating.fhtml.tests
[ t ] [ "bug" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test
[ t ] [ "stack" 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

24
extra/io/buffers/buffers-docs.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax strings alien ; USING: help.markup help.syntax byte-arrays alien ;
IN: io.buffers IN: io.buffers
ARTICLE: "buffers" "Locked I/O 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 $nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer } { $subsection buffer }
@ -23,7 +23,7 @@ $nl
{ $subsection buffer-until } { $subsection buffer-until }
"Writing to the buffer:" "Writing to the buffer:"
{ $subsection extend-buffer } { $subsection extend-buffer }
{ $subsection ch>buffer } { $subsection byte>buffer }
{ $subsection >buffer } { $subsection >buffer }
{ $subsection n>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." } ; { $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: (buffer>>) 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." } ; { $description "Collects the entire contents of the buffer into a string." } ;
HELP: buffer-reset HELP: buffer-reset
@ -68,15 +68,15 @@ HELP: buffer-end
{ $description "Outputs the memory address of the current fill-pointer." } ; { $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer>) 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." } ; { $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> 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." } ; { $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>> 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." } ; { $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
HELP: buffer-length 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." } ; { $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
HELP: >buffer 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." } ; { $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
HELP: ch>buffer HELP: byte>buffer
{ $values { "ch" "a character" } { "buffer" buffer } } { $values { "byte" "a byte" } { "buffer" buffer } }
{ $description "Appends a single byte to a buffer." } ; { $description "Appends a single byte to a buffer." } ;
HELP: n>buffer HELP: n>buffer
@ -123,5 +123,5 @@ HELP: buffer-pop
{ $description "Outputs the byte at the buffer position and advances the position." } ; { $description "Outputs the byte at the buffer position and advances the position." } ;
HELP: buffer-until HELP: buffer-until
{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $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 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 } "." } ; { $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 } "." } ;

30
extra/io/buffers/buffers-tests.factor
View File

@ -1,15 +1,15 @@
IN: io.buffers.tests IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc 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 -- ) : buffer-set ( string buffer -- )
2dup buffer-ptr string>char-memory over >byte-array over buffer-ptr byte-array>memory
>r length r> buffer-reset ; >r length r> buffer-reset ;
: string>buffer ( string -- buffer ) : string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ; dup length <buffer> tuck buffer-set ;
[ "" 65536 ] [ [ B{ } 65536 ] [
65536 <buffer> 65536 <buffer>
dup (buffer>>) dup (buffer>>)
over buffer-capacity over buffer-capacity
@ -18,15 +18,15 @@ sequences tools.test namespaces ;
[ "hello world" "" ] [ [ "hello world" "" ] [
"hello world" string>buffer "hello world" string>buffer
dup (buffer>>) dup (buffer>>) >string
0 pick buffer-reset 0 pick buffer-reset
over (buffer>>) over (buffer>>) >string
rot buffer-free rot buffer-free
] unit-test ] unit-test
[ "hello" ] [ [ "hello" ] [
"hello world" string>buffer "hello world" string>buffer
5 over buffer> swap buffer-free 5 over buffer> >string swap buffer-free
] unit-test ] unit-test
[ 11 ] [ [ 11 ] [
@ -36,8 +36,8 @@ sequences tools.test namespaces ;
[ "hello world" ] [ [ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep "hello" 1024 <buffer> [ buffer-set ] keep
" world" over >buffer " world" >byte-array over >buffer
dup (buffer>>) swap buffer-free dup (buffer>>) >string swap buffer-free
] unit-test ] unit-test
[ CHAR: e ] [ [ CHAR: e ] [
@ -47,33 +47,33 @@ sequences tools.test namespaces ;
[ "hello" CHAR: \r ] [ [ "hello" CHAR: \r ] [
"hello\rworld" string>buffer "hello\rworld" string>buffer
"\r" over buffer-until "\r" over buffer-until >r >string r>
rot buffer-free rot buffer-free
] unit-test ] unit-test
[ "hello" CHAR: \r ] [ [ "hello" CHAR: \r ] [
"hello\rworld" string>buffer "hello\rworld" string>buffer
"\n\r" over buffer-until "\n\r" over buffer-until >r >string r>
rot buffer-free rot buffer-free
] unit-test ] unit-test
[ "hello\rworld" f ] [ [ "hello\rworld" f ] [
"hello\rworld" string>buffer "hello\rworld" string>buffer
"X" over buffer-until "X" over buffer-until >r >string r>
rot buffer-free rot buffer-free
] unit-test ] unit-test
[ "hello" CHAR: \r "world" CHAR: \n ] [ [ "hello" CHAR: \r "world" CHAR: \n ] [
"hello\rworld\n" string>buffer "hello\rworld\n" string>buffer
[ "\r\n" swap buffer-until ] keep [ "\r\n" swap buffer-until >r >string r> ] keep
[ "\r\n" swap buffer-until ] keep [ "\r\n" swap buffer-until >r >string r> ] keep
buffer-free buffer-free
] unit-test ] unit-test
"hello world" string>buffer "b" set "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 "b" get buffer-free
100 <buffer> "b" set 100 <buffer> "b" set
[ 1000 "b" get n>buffer ] must-fail [ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free "b" get buffer-free

2
extra/io/buffers/buffers.factor
View File

@ -90,7 +90,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
[ buffer-end byte-array>memory ] 2keep [ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ; [ buffer-fill swap length + ] keep set-buffer-fill ;
: ch>buffer ( ch buffer -- ) : byte>buffer ( ch buffer -- )
1 over check-overflow 1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep [ buffer-end 0 set-alien-unsigned-1 ] keep
[ buffer-fill 1+ ] keep set-buffer-fill ; [ buffer-fill 1+ ] keep set-buffer-fill ;

8
extra/io/nonblocking/nonblocking-docs.factor
View File

@ -1,5 +1,5 @@
USING: io io.buffers io.backend help.markup help.syntax kernel 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 IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" 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." } ; { $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: read-until-step 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." } ; { $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 HELP: read-until-loop
{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } } { $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte 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." } ; { $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? HELP: can-write?
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } } { $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }

4
extra/io/nonblocking/nonblocking.factor
View File

@ -75,7 +75,7 @@ M: input-port stream-read1
[ wait-to-read ] 2keep [ wait-to-read ] 2keep
[ dupd buffer> ] unless-eof nip ; [ dupd buffer> ] unless-eof nip ;
: read-loop ( count port sbuf -- ) : read-loop ( count port accum -- )
pick over length - dup 0 > [ pick over length - dup 0 > [
pick read-step dup [ pick read-step dup [
over push-all read-loop 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 ; tuck can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1 M: output-port stream-write1
1 over wait-to-write ch>buffer ; 1 over wait-to-write byte>buffer ;
M: output-port stream-write M: output-port stream-write
over length over buffer-size > [ over length over buffer-size > [

5
extra/io/windows/nt/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays io.files io.timeouts io sequences hashtables sorting arrays
combinators math.bitfields ; combinators math.bitfields strings ;
IN: io.windows.nt.monitors IN: io.windows.nt.monitors
: open-directory ( path -- handle ) : open-directory ( path -- handle )
@ -66,6 +66,9 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
{ [ t ] [ +modify-file+ ] } { [ t ] [ +modify-file+ ] }
} cond nip ; } cond nip ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
: parse-file-notify ( buffer -- changed path ) : parse-file-notify ( buffer -- changed path )
{ {
FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileName

3
extra/koszul/koszul-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: koszul tools.test kernel sequences assocs namespaces ; USING: koszul tools.test kernel sequences assocs namespaces
symbols ;
IN: koszul.tests IN: koszul.tests
[ [

10
extra/serialize/serialize-docs.factor Normal file → Executable file
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] 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 } ; { $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] 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 } ; { $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] 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 } ; { $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 ] 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 } ; { $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 ] 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 } ; { $see-also (serialize) deserialize (deserialize) with-serialized } ;

43
extra/serialize/serialize-tests.factor
View File

@ -1,11 +1,29 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! 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 alien arrays byte-arrays sequences math prettyprint parser
classes math.constants ; classes math.constants io.encodings.binary random
combinators.lib ;
IN: serialize.tests 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 ; TUPLE: serialize-test a b ;
C: <serialize-test> serialize-test C: <serialize-test> serialize-test
@ -25,6 +43,7 @@ C: <serialize-test> serialize-test
{ 1 2 "three" } { 1 2 "three" }
V{ 1 2 "three" } V{ 1 2 "three" }
SBUF" hello world" SBUF" hello world"
"hello \u123456 unicode"
\ dup \ dup
[ \ dup dup ] [ \ dup dup ]
T{ serialize-test f "a" 2 } T{ serialize-test f "a" 2 }
@ -38,8 +57,9 @@ C: <serialize-test> serialize-test
: check-serialize-1 ( obj -- ? ) : check-serialize-1 ( obj -- ? )
dup class . dup class .
dup [ serialize ] with-string-writer dup
[ deserialize ] with-string-reader = ; binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader = ;
: check-serialize-2 ( obj -- ? ) : check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [ dup number? over wrapper? or [
@ -47,8 +67,8 @@ C: <serialize-test> serialize-test
] [ ] [
dup class . dup class .
dup 2array dup 2array
[ serialize ] with-string-writer binary [ serialize ] with-byte-writer
[ deserialize ] with-string-reader binary [ deserialize ] with-byte-reader
first2 eq? first2 eq?
] if ; ] if ;
@ -59,11 +79,14 @@ C: <serialize-test> serialize-test
[ t ] [ pi check-serialize-1 ] unit-test [ t ] [ pi check-serialize-1 ] unit-test
[ t ] [ [ t ] [
{ 1 2 3 } [ { 1 2 3 }
binary [
[ [
dup (serialize) (serialize) dup (serialize) (serialize)
] with-serialized ] with-serialized
] with-string-writer [ ] with-byte-writer
deserialize-sequence all-eq? binary [ deserialize-sequence all-eq? ] with-byte-reader
] with-string-reader
] unit-test ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer

217
extra/serialize/serialize.factor
View File

@ -10,7 +10,8 @@ IN: serialize
USING: namespaces sequences kernel math io math.functions USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables 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 ! Variable holding a sequence of objects already serialized
SYMBOL: serialized SYMBOL: serialized
@ -24,106 +25,119 @@ SYMBOL: serialized
#! Return the id of an already serialized object #! Return the id of an already serialized object
serialized get [ eq? ] with find [ drop f ] unless ; serialized get [ eq? ] with find [ drop f ] unless ;
USE: prettyprint
! Serialize object ! Serialize object
GENERIC: (serialize) ( obj -- ) 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 -- ) : serialize-shared ( obj quot -- )
>r dup object-id >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 -- ) M: f (serialize) ( obj -- )
drop "n" write ; drop CHAR: n write1 ;
: bytes-needed ( number -- int )
log2 8 + 8 /i ; inline
M: integer (serialize) ( obj -- ) M: integer (serialize) ( obj -- )
dup 0 = [ dup zero? [
drop "z" write drop CHAR: z write1
] [ ] [
dup 0 < [ neg "m" ] [ "p" ] if write dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
dup bytes-needed dup serialize-cell serialize-cell
>be write
] if ; ] if ;
M: float (serialize) ( obj -- ) M: float (serialize) ( obj -- )
"F" write CHAR: F write1
double>bits serialize-cell ; double>bits serialize-cell ;
M: complex (serialize) ( obj -- ) M: complex (serialize) ( obj -- )
"c" write CHAR: c write1
dup real-part (serialize) dup real-part (serialize)
imaginary-part (serialize) ; imaginary-part (serialize) ;
M: ratio (serialize) ( obj -- ) M: ratio (serialize) ( obj -- )
"r" write CHAR: r write1
dup numerator (serialize) dup numerator (serialize)
denominator (serialize) ; denominator (serialize) ;
M: string (serialize) ( obj -- ) : serialize-string ( obj code -- )
[ write1
"s" write
dup add-object serialize-cell dup add-object serialize-cell
utf8 encode
dup length serialize-cell dup length serialize-cell
write write ;
] serialize-shared ;
M: sbuf (serialize) ( obj -- ) M: string (serialize) ( obj -- )
[ [ CHAR: s serialize-string ] serialize-shared ;
"S" write
dup add-object serialize-cell : serialize-elements
dup length serialize-cell [ (serialize) ] each CHAR: . write1 ;
>string write
] serialize-shared ;
M: tuple (serialize) ( obj -- ) M: tuple (serialize) ( obj -- )
[ [
"T" write CHAR: T write1
dup add-object serialize-cell dup add-object serialize-cell
tuple>array tuple>array serialize-elements
dup length serialize-cell
[ (serialize) ] each
] serialize-shared ; ] serialize-shared ;
: serialize-seq ( seq code -- ) : serialize-seq ( seq code -- )
[ [
write write1
dup add-object serialize-cell dup add-object serialize-cell
dup length serialize-cell serialize-elements
[ (serialize) ] each
] curry serialize-shared ; ] curry serialize-shared ;
M: array (serialize) ( obj -- ) M: array (serialize) ( obj -- )
"a" serialize-seq ; CHAR: a serialize-seq ;
M: vector (serialize) ( obj -- )
"v" serialize-seq ;
M: byte-array (serialize) ( obj -- ) 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 -- ) 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 -- ) M: quotation (serialize) ( obj -- )
"q" serialize-seq ; CHAR: q serialize-seq ;
M: curry (serialize) ( obj -- )
[
"C" write
dup add-object serialize-cell
dup curry-obj (serialize) curry-quot (serialize)
] serialize-shared ;
M: float-array (serialize) ( obj -- ) M: float-array (serialize) ( obj -- )
[ [
"f" write CHAR: f write1
dup add-object serialize-cell dup add-object serialize-cell
dup length serialize-cell dup length serialize-cell
[ double>bits 8 >be write ] each [ double>bits 8 >be write ] each
@ -131,18 +145,18 @@ M: float-array (serialize) ( obj -- )
M: hashtable (serialize) ( obj -- ) M: hashtable (serialize) ( obj -- )
[ [
"h" write CHAR: h write1
dup add-object serialize-cell dup add-object serialize-cell
>alist (serialize) >alist (serialize)
] serialize-shared ; ] serialize-shared ;
M: word (serialize) ( obj -- ) M: word (serialize) ( obj -- )
"w" write CHAR: w write1
dup word-name (serialize) dup word-name (serialize)
word-vocabulary (serialize) ; word-vocabulary (serialize) ;
M: wrapper (serialize) ( obj -- ) M: wrapper (serialize) ( obj -- )
"W" write CHAR: W write1
wrapped (serialize) ; wrapped (serialize) ;
DEFER: (deserialize) ( -- obj ) DEFER: (deserialize) ( -- obj )
@ -154,7 +168,7 @@ DEFER: (deserialize) ( -- obj )
f ; f ;
: deserialize-positive-integer ( -- number ) : deserialize-positive-integer ( -- number )
deserialize-cell read be> ; deserialize-cell ;
: deserialize-negative-integer ( -- number ) : deserialize-negative-integer ( -- number )
deserialize-positive-integer neg ; deserialize-positive-integer neg ;
@ -171,11 +185,11 @@ DEFER: (deserialize) ( -- obj )
: deserialize-complex ( -- complex ) : deserialize-complex ( -- complex )
(deserialize) (deserialize) rect> ; (deserialize) (deserialize) rect> ;
: deserialize-string ( -- string ) : (deserialize-string) ( -- string )
deserialize-cell deserialize-cell read intern-object ; deserialize-cell read utf8 decode ;
: deserialize-sbuf ( -- sbuf ) : deserialize-string ( -- string )
deserialize-cell deserialize-cell read >sbuf intern-object ; deserialize-cell (deserialize-string) intern-object ;
: deserialize-word ( -- word ) : deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup (deserialize) dup (deserialize) lookup
@ -184,25 +198,30 @@ DEFER: (deserialize) ( -- obj )
: deserialize-wrapper ( -- wrapper ) : deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ; (deserialize) <wrapper> ;
SYMBOL: +stop+
: (deserialize-seq)
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
: deserialize-seq ( seq -- array ) : deserialize-seq ( seq -- array )
deserialize-cell deserialize-cell >r deserialize-cell (deserialize-seq) r> like intern-object ;
[ drop (deserialize) ] roll map-as
intern-object ;
: deserialize-array ( -- array ) : deserialize-array ( -- array )
{ } deserialize-seq ; { } deserialize-seq ;
: deserialize-vector ( -- array )
V{ } deserialize-seq ;
: deserialize-quotation ( -- array ) : deserialize-quotation ( -- array )
[ ] deserialize-seq ; [ ] deserialize-seq ;
: (deserialize-byte-array) ( -- byte-array )
deserialize-cell read B{ } like ;
: deserialize-byte-array ( -- byte-array ) : deserialize-byte-array ( -- byte-array )
B{ } deserialize-seq ; deserialize-cell (deserialize-byte-array) intern-object ;
: deserialize-bit-array ( -- bit-array ) : deserialize-bit-array ( -- bit-array )
?{ } deserialize-seq ; deserialize-cell
(deserialize-byte-array) [ 0 > ] ?{ } map-as
intern-object ;
: deserialize-float-array ( -- float-array ) : deserialize-float-array ( -- float-array )
deserialize-cell deserialize-cell deserialize-cell deserialize-cell
@ -213,43 +232,37 @@ DEFER: (deserialize) ( -- obj )
deserialize-cell (deserialize) >hashtable intern-object ; deserialize-cell (deserialize) >hashtable intern-object ;
: deserialize-tuple ( -- array ) : deserialize-tuple ( -- array )
deserialize-cell deserialize-cell (deserialize-seq) >tuple intern-object ;
deserialize-cell [ drop (deserialize) ] map >tuple
intern-object ;
: deserialize-curry ( -- curry )
deserialize-cell
(deserialize) (deserialize) curry
intern-object ;
: deserialize-unknown ( -- object ) : deserialize-unknown ( -- object )
deserialize-cell serialized get nth ; deserialize-cell serialized get nth ;
: deserialize-stop ( -- object )
+stop+ get ;
: deserialize* ( -- object ? ) : deserialize* ( -- object ? )
read1 [ read1 [
H{ {
{ CHAR: A deserialize-byte-array } { CHAR: A [ deserialize-byte-array ] }
{ CHAR: C deserialize-curry } { CHAR: F [ deserialize-float ] }
{ CHAR: F deserialize-float } { CHAR: T [ deserialize-tuple ] }
{ CHAR: S deserialize-sbuf } { CHAR: W [ deserialize-wrapper ] }
{ CHAR: T deserialize-tuple } { CHAR: a [ deserialize-array ] }
{ CHAR: W deserialize-wrapper } { CHAR: b [ deserialize-bit-array ] }
{ CHAR: a deserialize-array } { CHAR: c [ deserialize-complex ] }
{ CHAR: b deserialize-bit-array } { CHAR: f [ deserialize-float-array ] }
{ CHAR: c deserialize-complex } { CHAR: h [ deserialize-hashtable ] }
{ CHAR: f deserialize-float-array } { CHAR: m [ deserialize-negative-integer ] }
{ CHAR: h deserialize-hashtable } { CHAR: n [ deserialize-false ] }
{ CHAR: m deserialize-negative-integer } { CHAR: o [ deserialize-unknown ] }
{ CHAR: n deserialize-false } { CHAR: p [ deserialize-positive-integer ] }
{ CHAR: o deserialize-unknown } { CHAR: q [ deserialize-quotation ] }
{ CHAR: p deserialize-positive-integer } { CHAR: r [ deserialize-ratio ] }
{ CHAR: q deserialize-quotation } { CHAR: s [ deserialize-string ] }
{ CHAR: r deserialize-ratio } { CHAR: w [ deserialize-word ] }
{ CHAR: s deserialize-string } { CHAR: z [ deserialize-zero ] }
{ CHAR: v deserialize-vector } { CHAR: . [ deserialize-stop ] }
{ CHAR: w deserialize-word } } case t
{ CHAR: z deserialize-zero }
} at dup [ "Unknown typecode" throw ] unless execute t
] [ ] [
f f f f
] if* ; ] if* ;
@ -258,7 +271,11 @@ DEFER: (deserialize) ( -- obj )
deserialize* [ "End of stream" throw ] unless ; deserialize* [ "End of stream" throw ] unless ;
: with-serialized ( quot -- ) : 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-sequence ( -- seq )
[ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;