add unit tests and fix bugs in serialization code

diff --git a/contrib/serialize/load.factor b/contrib/serialize/load.factor
index cd539679d95f054ba23151d53cca69908d788ebb..8f5274510954a4e58e3a22613e6f1cdf49c6195c 100644 (file)
--- a/contrib/serialize/load.factor
+++ b/contrib/serialize/load.factor
@@ -1,4 +1,6 @@
 PROVIDE: serialize {
        "serialize.factor"
        "serialize.facts"
-} { } ;
+} { 
+       "tests.factor"
+} ;

diff --git a/contrib/serialize/serialize.factor b/contrib/serialize/serialize.factor
index 2bf5ef45a2df866cead995f8aa042a925e777dcd..8474451823dbc9a35aa390dd15c31e5467ee1ab8 100644 (file)
--- a/contrib/serialize/serialize.factor
+++ b/contrib/serialize/serialize.factor
@@ -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 ;
\ No newline at end of file

diff --git a/contrib/serialize/serialize.facts b/contrib/serialize/serialize.facts
index 7dfeaa6d86aee7a9a6396e5439f83d2f31ad85e0..79bc4cf7f302221169bd3527035ae83fe4d5a22e 100644 (file)
--- a/contrib/serialize/serialize.facts
+++ b/contrib/serialize/serialize.facts
@@ -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 } ;

diff --git a/contrib/serialize/tests.factor b/contrib/serialize/tests.factor
new file mode 100644 (file)
index 0000000..24534c1
--- /dev/null
+++ b/contrib/serialize/tests.factor
@@ -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
+
+