factor: trim using lists

[factor.git] / basis / serialize / serialize.factor

diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor
index 86d5ca8676aa880a311b7e8986a22b7ec961e669..2f305bc174c8f0a6c58c88d967ecafcb12cbab7e 100644 (file)
--- a/basis/serialize/serialize.factor
+++ b/basis/serialize/serialize.factor
@@ -6,13 +6,11 @@
 !
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: namespaces sequences kernel math io math.functions
-io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables hashtables.identity
-assocs help.syntax help.markup splitting io.streams.byte-array
-io.encodings.string io.encodings.utf8 io.encodings.binary
-combinators accessors locals prettyprint compiler.units
-sequences.private classes.tuple.private vocabs ;
+USING: accessors arrays assocs byte-arrays classes classes.tuple
+combinators endian hashtables io io.encodings.binary
+io.encodings.string io.encodings.utf8 io.streams.byte-array
+kernel math namespaces prettyprint quotations sequences
+sequences.private strings vocabs words ;
 IN: serialize
 
 GENERIC: (serialize) ( obj -- )
@@ -23,29 +21,29 @@ GENERIC: (serialize) ( obj -- )
 SYMBOL: serialized
 
 : add-object ( obj -- )
-    #! Add an object to the sequence of already serialized
-    #! objects.
+    ! Add an object to the sequence of already serialized
+    ! objects.
     serialized get [ assoc-size swap ] keep set-at ;
 
 : object-id ( obj -- id )
-    #! Return the id of an already serialized object 
+    ! Return the id of an already serialized object
     serialized get at ;
 
-! Numbers are serialized as follows:
+! Positive 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] ... }
+! 1<=x<127 => B{ x | 0x80 }
+! 127<=x<2^1024 => B{ length(x) x[0] x[1] ... }; 1<length(x)<129 fits in 1 byte
+! 2^1024<=x => B{ 0xff } + serialize(length(x)) + B{ 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 -- )
     [ 0 write1 ] [
-        dup HEX: 7e <= [
-            HEX: 80 bitor write1
+        dup 0x7f < [
+            0x80 bitor write1
         ] [
-            dup log2 8 /i 1 + 
-            dup HEX: 7f >= [
-                HEX: ff write1
+            dup log2 8 /i 1 +
+            dup 0x80 > [
+                0xff write1
                 dup serialize-cell
             ] [
                 dup write1
@@ -56,8 +54,8 @@ SYMBOL: serialized
 
 : deserialize-cell ( -- n )
     read1 {
-        { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
-        { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
+        { [ dup 0xff = ] [ drop deserialize-cell read be> ] }
+        { [ dup 0x80 > ] [ 0x80 bitxor ] }
         [ read be> ]
     } cond ;
 
@@ -67,10 +65,10 @@ SYMBOL: serialized
         [ CHAR: o write1 serialize-cell drop ]
     ] dip if* ; inline
 
-M: f (serialize) ( obj -- )
+M: f (serialize)
     drop CHAR: n write1 ;
 
-M: integer (serialize) ( obj -- )
+M: integer (serialize)
     [
         CHAR: z write1
     ] [
@@ -78,7 +76,7 @@ M: integer (serialize) ( obj -- )
         serialize-cell
     ] if-zero ;
 
-M: float (serialize) ( obj -- )
+M: float (serialize)
     CHAR: F write1
     double>bits serialize-cell ;
 
@@ -90,31 +88,31 @@ M: float (serialize) ( obj -- )
         [ [ (serialize) ] each ] tri
     ] curry serialize-shared ;
 
-M: tuple (serialize) ( obj -- )
+M: tuple (serialize)
     [
         CHAR: T write1
         [ class-of (serialize) ]
         [ add-object ]
-        [ tuple>array rest (serialize) ]
+        [ tuple-slots (serialize) ]
         tri
     ] serialize-shared ;
 
-M: array (serialize) ( obj -- )
+M: array (serialize)
     CHAR: a serialize-seq ;
 
-M: quotation (serialize) ( obj -- )
+M: quotation (serialize)
     [
         CHAR: q write1
         [ >array (serialize) ] [ add-object ] bi
     ] serialize-shared ;
 
-M: hashtable (serialize) ( obj -- )
+M: hashtable (serialize)
     [
         CHAR: h write1
         [ add-object ] [ >alist (serialize) ] bi
     ] serialize-shared ;
 
-M: byte-array (serialize) ( obj -- )
+M: byte-array (serialize)
     [
         CHAR: A write1
         [ add-object ]
@@ -122,7 +120,7 @@ M: byte-array (serialize) ( obj -- )
         [ write ] tri
     ] serialize-shared ;
 
-M: string (serialize) ( obj -- )
+M: string (serialize)
     [
         CHAR: s write1
         [ add-object ]
@@ -151,14 +149,14 @@ M: string (serialize) ( obj -- )
     [ vocabulary>> (serialize) ]
     bi ;
 
-M: word (serialize) ( obj -- )
+M: word (serialize)
     {
         { [ dup t eq? ] [ serialize-true ] }
         { [ dup vocabulary>> not ] [ serialize-gensym ] }
         [ serialize-word ]
     } cond ;
 
-M: wrapper (serialize) ( obj -- )
+M: wrapper (serialize)
     CHAR: W write1
     wrapped>> (serialize) ;
 
@@ -194,19 +192,17 @@ SYMBOL: deserialized
     (deserialize-string) dup intern-object ;
 
 : deserialize-word ( -- word )
-    (deserialize) (deserialize) 2dup [ require ] keep lookup-word
-    dup [ 2nip ] [
-        drop
+    (deserialize) (deserialize)
+    2dup [ require ] keep lookup-word [ 2nip ] [
         2array unparse "Unknown word: " prepend throw
-    ] if ;
+    ] if* ;
 
 : deserialize-gensym ( -- word )
-    gensym {
-        [ intern-object ]
-        [ (deserialize) define ]
-        [ (deserialize) >>props drop ]
-        [ ]
-    } cleave ;
+    gensym
+    [ intern-object ]
+    [ (deserialize) define ]
+    [ (deserialize) >>props ]
+    tri ;
 
 : deserialize-wrapper ( -- wrapper )
     (deserialize) <wrapper> ;
@@ -228,15 +224,15 @@ SYMBOL: deserialized
 : deserialize-hashtable ( -- hashtable )
     H{ } clone
     [ intern-object ]
-    [ (deserialize) assoc-union! drop ]
-    [ ] tri ;
+    [ (deserialize) assoc-union! ]
+    bi ;
 
 : copy-seq-to-tuple ( seq tuple -- )
     [ set-array-nth ] curry each-index ;
 
 : deserialize-tuple ( -- array )
-    #! Ugly because we have to intern the tuple before reading
-    #! slots
+    ! Ugly because we have to intern the tuple before reading
+    ! slots
     (deserialize) new
     [ intern-object ]
     [
@@ -277,8 +273,7 @@ SYMBOL: deserialized
 PRIVATE>
 
 : deserialize ( -- obj )
-    V{ } clone deserialized
-    [ (deserialize) ] with-variable ;
+    V{ } clone deserialized [ (deserialize) ] with-variable ;
 
 : serialize ( obj -- )
     IH{ } clone serialized [ (serialize) ] with-variable ;