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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
contrib/serialize/load.factor
View File

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

145
contrib/serialize/serialize.factor
View File

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

21
contrib/serialize/serialize.facts
View File

@ -5,17 +5,26 @@ USING: help serialize ;
HELP: 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
{ $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
{ $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
{ $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 } ;

134
contrib/serialize/tests.factor Normal file
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