add unit tests and fix bugs in serialization code

release
chris.double 2006-08-30 22:36:20 +00:00
parent 0a41eb31ae
commit fb6eb27869
4 changed files with 220 additions and 84 deletions

View File

@ -1,4 +1,6 @@
PROVIDE: serialize { PROVIDE: serialize {
"serialize.factor" "serialize.factor"
"serialize.facts" "serialize.facts"
} { } ; } {
"tests.factor"
} ;

View File

@ -24,15 +24,15 @@ SYMBOL: serialized
USE: prettyprint USE: prettyprint
! Serialize object ! Serialize object
GENERIC: (serialize) ( obj -- ) GENERIC: serialize ( obj -- )
: serialize-shared ( obj quot -- ) : serialize-shared ( obj quot -- )
>r dup object-id [ "o" write (serialize) drop ] r> if* ; inline >r dup object-id [ "o" write serialize drop ] r> if* ; inline
M: f (serialize) ( obj -- ) M: f serialize ( obj -- )
drop "n" write ; drop "n" write ;
M: fixnum (serialize) ( obj -- ) M: fixnum serialize ( obj -- )
! Factor may use 64 bit fixnums on such systems ! Factor may use 64 bit fixnums on such systems
"f" write "f" write
4 >be write ; 4 >be write ;
@ -40,85 +40,85 @@ M: fixnum (serialize) ( obj -- )
: bytes-needed ( bignum -- int ) : bytes-needed ( bignum -- int )
log2 8 + 8 / floor ; log2 8 + 8 / floor ;
M: bignum (serialize) ( obj -- ) M: bignum serialize ( obj -- )
"b" write "b" write
dup bytes-needed (serialize) dup bytes-needed serialize
dup bytes-needed >be write ; dup bytes-needed >be write ;
M: float (serialize) ( obj -- ) M: float serialize ( obj -- )
"F" write "F" write
float>bits (serialize) ; float>bits serialize ;
M: complex (serialize) ( obj -- ) M: complex serialize ( obj -- )
[ [
"c" write "c" write
dup add-object (serialize) dup add-object serialize
dup real (serialize) dup real serialize
imaginary (serialize) imaginary serialize
] serialize-shared ; ] serialize-shared ;
M: ratio (serialize) ( obj -- ) M: ratio serialize ( obj -- )
"r" write "r" write
dup numerator (serialize) dup numerator serialize
denominator (serialize) ; denominator serialize ;
M: string (serialize) ( obj -- ) M: string serialize ( obj -- )
[ [
"s" write "s" write
dup add-object (serialize) dup add-object serialize
dup length (serialize) dup length serialize
write write
] serialize-shared ; ] serialize-shared ;
M: object (serialize) ( obj -- ) M: object serialize ( obj -- )
class word-name "Don't know to serialize a " swap append throw ; class word-name "Don't know to serialize a " swap append throw ;
M: sbuf (serialize) ( obj -- ) M: sbuf serialize ( obj -- )
"S" write "S" write
dup length (serialize) dup length serialize
[ (serialize) ] each ; [ serialize ] each ;
: (serialize-seq) ( seq code -- ) : serialize-seq ( seq code -- )
swap [ swap [
over write over write
dup add-object (serialize) dup add-object serialize
dup length (serialize) dup length serialize
[ (serialize) ] each [ serialize ] each
] serialize-shared drop ; ] serialize-shared drop ;
M: tuple (serialize) ( obj -- ) M: tuple serialize ( obj -- )
[ [
"t" write "t" write
dup add-object (serialize) dup add-object serialize
tuple>array (serialize) tuple>array serialize
] serialize-shared ; ] serialize-shared ;
M: array (serialize) ( obj -- ) M: array serialize ( obj -- )
"a" (serialize-seq) ; "a" serialize-seq ;
M: vector (serialize) ( obj -- ) M: vector serialize ( obj -- )
"v" (serialize-seq) ; "v" serialize-seq ;
M: quotation (serialize) ( obj -- ) M: quotation serialize ( obj -- )
"q" (serialize-seq) ; "q" serialize-seq ;
M: hashtable (serialize) ( obj -- ) M: hashtable serialize ( obj -- )
[ [
"h" write "h" write
dup add-object (serialize) dup add-object serialize
hash>alist (serialize) hash>alist serialize
] serialize-shared ; ] serialize-shared ;
M: word (serialize) ( obj -- ) M: word serialize ( obj -- )
"w" write "w" write
dup word-name (serialize) dup word-name serialize
word-vocabulary (serialize) ; word-vocabulary serialize ;
M: wrapper (serialize) ( obj -- ) M: wrapper serialize ( obj -- )
"W" write "W" write
wrapped (serialize) ; wrapped serialize ;
DEFER: (deserialize) ( -- obj ) DEFER: deserialize ( -- obj )
: intern-object ( id obj -- ) : intern-object ( id obj -- )
swap serialized get set-nth ; swap serialized get set-nth ;
@ -130,59 +130,62 @@ DEFER: (deserialize) ( -- obj )
4 read be> ; 4 read be> ;
: deserialize-string ( -- string ) : deserialize-string ( -- string )
(deserialize) (deserialize) read [ intern-object ] keep ; deserialize deserialize read [ intern-object ] keep ;
: deserialize-ratio ( -- ratio ) : deserialize-ratio ( -- ratio )
(deserialize) (deserialize) / ; deserialize deserialize / ;
: deserialize-complex ( -- complex ) : deserialize-complex ( -- complex )
(deserialize) (deserialize) (deserialize) rect> [ intern-object ] keep ; deserialize deserialize deserialize rect> [ intern-object ] keep ;
: deserialize-bignum ( -- bignum ) : deserialize-bignum ( -- bignum )
(deserialize) read be> ; deserialize read be> ;
: deserialize-float ( -- float )
deserialize bits>float ;
: deserialize-word ( -- word ) : deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup dup [ nip ] [ "Unknown word" throw ] if ; deserialize dup deserialize lookup dup [ nip ] [ "Unknown word" throw ] if ;
: deserialize-wrapper ( -- wrapper ) : deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ; deserialize <wrapper> ;
: deserialize-array ( -- array ) : deserialize-array ( -- array )
(deserialize) deserialize
[ [
(deserialize) deserialize
[ (deserialize) , ] repeat [ deserialize , ] repeat
] { } make ] { } make
[ intern-object ] keep ; [ intern-object ] keep ;
: deserialize-vector ( -- array ) : deserialize-vector ( -- array )
(deserialize) deserialize
[ [
(deserialize) deserialize
[ (deserialize) , ] repeat [ deserialize , ] repeat
] V{ } make ] V{ } make
[ intern-object ] keep ; [ intern-object ] keep ;
: deserialize-quotation ( -- array ) : deserialize-quotation ( -- array )
(deserialize) deserialize
[ [
(deserialize) deserialize
[ (deserialize) , ] repeat [ deserialize , ] repeat
] [ ] make ] [ ] make
[ intern-object ] keep ; [ intern-object ] keep ;
: deserialize-hashtable ( -- array ) : deserialize-hashtable ( -- array )
(deserialize) deserialize
(deserialize) alist>hash deserialize alist>hash
[ intern-object ] keep ; [ intern-object ] keep ;
: deserialize-tuple ( -- array ) : deserialize-tuple ( -- array )
(deserialize) deserialize
(deserialize) array>tuple deserialize array>tuple
[ intern-object ] keep ; [ intern-object ] keep ;
: deserialize-unknown ( -- object ) : deserialize-unknown ( -- object )
(deserialize) serialized get nth ; deserialize serialized get nth ;
: deserialize ( -- object ) : deserialize ( -- object )
read1 ch>string dup read1 ch>string dup
@ -191,6 +194,7 @@ DEFER: (deserialize) ( -- obj )
{ "r" deserialize-ratio } { "r" deserialize-ratio }
{ "c" deserialize-complex } { "c" deserialize-complex }
{ "b" deserialize-bignum } { "b" deserialize-bignum }
{ "F" deserialize-float }
{ "w" deserialize-word } { "w" deserialize-word }
{ "W" deserialize-wrapper } { "W" deserialize-wrapper }
{ "n" deserialize-false } { "n" deserialize-false }
@ -206,16 +210,3 @@ DEFER: (deserialize) ( -- obj )
: with-serialized ( quot -- ) : with-serialized ( quot -- )
[ V{ } serialized set call ] with-scope ; inline [ V{ } serialized set call ] with-scope ; inline
: serialize ( obj -- )
[
V{ } serialized set
(serialize)
] with-scope ;
: deserialize ( -- obj )
[
V{ } serialized set
(deserialize)
] with-scope ;
PROVIDE: serialize ;

View File

@ -5,17 +5,26 @@ USING: help serialize ;
HELP: serialize HELP: serialize
{ $values { "obj" "object to serialize" } { $values { "obj" "object to 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. It must be called from within the scope of a " { $link with-serialized } " call." }
{ $examples { $examples
{ $example "[ { 1 2 } dup serialize serialize ] string-out\n[ deserialize deserialize ] string-in eq?\n => t" } { $example "[\n [ { 1 2 } dup serialize serialize ] with-serialized\n] string-out\n\n[\n [ deserialize deserialize ] with-serialized\n] string-in eq?\n => t" }
} }
{ $see-also deserialize } ; { $see-also deserialize with-serialized } ;
HELP: deserialize HELP: deserialize
{ $values { "obj" "deserialized object" } { $values { "obj" "deserialized object" }
} }
{ $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. It must be called from within the scope of a " { $link with-serialized } " call." }
{ $examples { $examples
{ $example "[ { 1 2 } dup serialize serialize ] string-out\n[ deserialize deserialize ] string-in eq?\n => t" } { $example "[\n [ { 1 2 } dup serialize serialize ] with-serialized\n] string-out\n\n[\n [ deserialize deserialize ] with-serialized\n] string-in eq?\n => t" }
} }
{ $see-also serialize } ; { $see-also serialize with-serialized } ;
HELP: with-serialized
{ $values { "quot" "a quotation" }
}
{ $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 "[\n [ { 1 2 } dup serialize serialize ] with-serialized\n] string-out\n\n[\n [ deserialize deserialize ] with-serialized\n] string-in eq?\n => t" }
}
{ $see-also serialize deserialize } ;

View File

@ -0,0 +1,134 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: test kernel serialize io math ;
IN: temporary
[ f ] [
[ [ f serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ t serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ 20 ] [
[ [ 20 serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ 5 5 5 ^ ^ serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in 5 5 5 ^ ^ =
] unit-test
[ 5.25 ] [
[ [ 5.25 serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ C{ 1 2 } ] [
[ [ C{ 1 2 } serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ C{ 1 2 } dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ C{ 1 2 } C{ 1 2 } serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ 1/2 ] [
[ [ 1/2 serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ "test" ] [
[ [ "test" serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ "test" dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ "test" "test" serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ t ] [
[ [ "test" dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ { 1 2 "three" } ] [
[ [ { 1 2 "three" } serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ { 1 2 "three" } dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ { 1 2 "three" } { 1 2 "three" } serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ V{ 1 2 "three" } ] [
[ [ V{ 1 2 "three" } serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ V{ 1 2 "three" } dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ V{ 1 2 "three" } V{ 1 2 "three" } serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ [ \ dup dup ] ] [
[ [ [ \ dup dup ] serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ [ \ dup dup ] dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ [ \ dup dup ] [ \ dup dup ] serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
TUPLE: serialize-test a b ;
[ T{ serialize-test f "a" 2 } ] [
[ [ "a" 2 <serialize-test> serialize ] with-serialized ] string-out
[ [ deserialize ] with-serialized ] string-in
] unit-test
[ t ] [
[ [ "a" 2 <serialize-test> dup serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test
[ f ] [
[ [ "a" 2 <serialize-test> "a" 2 <serialize-test> serialize serialize ] with-serialized ] string-out
[ [ deserialize deserialize ] with-serialized ] string-in eq?
] unit-test