basis/serialize/serialize.factor

   1 ! Copyright (C) 2006 Adam Langley and Chris Double.
   2 ! Adam Langley was the original author of this work.
   3 !
   4 ! Chris Double modified it to fix bugs and get it working
   5 ! correctly under the latest versions of Factor.
   6 !
   7 ! See http://factorcode.org/license.txt for BSD license.
   8 !
   9 USING: namespaces sequences kernel math io math.functions
  10 io.binary strings classes words sbufs classes.tuple arrays
  11 vectors byte-arrays quotations hashtables hashtables.identity
  12 assocs help.syntax help.markup splitting io.streams.byte-array
  13 io.encodings.string io.encodings.utf8 io.encodings.binary
  14 combinators accessors locals prettyprint compiler.units
  15 sequences.private classes.tuple.private vocabs ;
  16 IN: serialize
  17
  18 GENERIC: (serialize) ( obj -- )
  19
  20 <PRIVATE
  21
  22 ! Variable holding a assoc of objects already serialized
  23 SYMBOL: serialized
  24
  25 : add-object ( obj -- )
  26     #! Add an object to the sequence of already serialized
  27     #! objects.
  28     serialized get [ assoc-size swap ] keep set-at ;
  29
  30 : object-id ( obj -- id )
  31     #! Return the id of an already serialized object
  32     serialized get at ;
  33
  34 ! Numbers are serialized as follows:
  35 ! 0 => B{ 0 }
  36 ! 1<=x<=126 => B{ x | 0x80 }
  37 ! x>127 => B{ length(x) x[0] x[1] ... }
  38 ! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... }
  39 ! The last case is needed because a very large number would
  40 ! otherwise be confused with a small number.
  41 : serialize-cell ( n -- )
  42     [ 0 write1 ] [
  43         dup 0x7e <= [
  44             0x80 bitor write1
  45         ] [
  46             dup log2 8 /i 1 +
  47             dup 0x7f >= [
  48                 0xff write1
  49                 dup serialize-cell
  50             ] [
  51                 dup write1
  52             ] if
  53             >be write
  54         ] if
  55     ] if-zero ;
  56
  57 : deserialize-cell ( -- n )
  58     read1 {
  59         { [ dup 0xff = ] [ drop deserialize-cell read be> ] }
  60         { [ dup 0x80 >= ] [ 0x80 bitxor ] }
  61         [ read be> ]
  62     } cond ;
  63
  64 : serialize-shared ( obj quot -- )
  65     [
  66         dup object-id
  67         [ CHAR: o write1 serialize-cell drop ]
  68     ] dip if* ; inline
  69
  70 M: f (serialize) ( obj -- )
  71     drop CHAR: n write1 ;
  72
  73 M: integer (serialize) ( obj -- )
  74     [
  75         CHAR: z write1
  76     ] [
  77         dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
  78         serialize-cell
  79     ] if-zero ;
  80
  81 M: float (serialize) ( obj -- )
  82     CHAR: F write1
  83     double>bits serialize-cell ;
  84
  85 : serialize-seq ( obj code -- )
  86     [
  87         write1
  88         [ add-object ]
  89         [ length serialize-cell ]
  90         [ [ (serialize) ] each ] tri
  91     ] curry serialize-shared ;
  92
  93 M: tuple (serialize) ( obj -- )
  94     [
  95         CHAR: T write1
  96         [ class-of (serialize) ]
  97         [ add-object ]
  98         [ tuple>array rest (serialize) ]
  99         tri
 100     ] serialize-shared ;
 101
 102 M: array (serialize) ( obj -- )
 103     CHAR: a serialize-seq ;
 104
 105 M: quotation (serialize) ( obj -- )
 106     [
 107         CHAR: q write1
 108         [ >array (serialize) ] [ add-object ] bi
 109     ] serialize-shared ;
 110
 111 M: hashtable (serialize) ( obj -- )
 112     [
 113         CHAR: h write1
 114         [ add-object ] [ >alist (serialize) ] bi
 115     ] serialize-shared ;
 116
 117 M: byte-array (serialize) ( obj -- )
 118     [
 119         CHAR: A write1
 120         [ add-object ]
 121         [ length serialize-cell ]
 122         [ write ] tri
 123     ] serialize-shared ;
 124
 125 M: string (serialize) ( obj -- )
 126     [
 127         CHAR: s write1
 128         [ add-object ]
 129         [
 130             utf8 encode
 131             [ length serialize-cell ]
 132             [ write ] bi
 133         ] bi
 134     ] serialize-shared ;
 135
 136 : serialize-true ( word -- )
 137     drop CHAR: t write1 ;
 138
 139 : serialize-gensym ( word -- )
 140     [
 141         CHAR: G write1
 142         [ add-object ]
 143         [ def>> (serialize) ]
 144         [ props>> (serialize) ]
 145         tri
 146     ] serialize-shared ;
 147
 148 : serialize-word ( word -- )
 149     CHAR: w write1
 150     [ name>> (serialize) ]
 151     [ vocabulary>> (serialize) ]
 152     bi ;
 153
 154 M: word (serialize) ( obj -- )
 155     {
 156         { [ dup t eq? ] [ serialize-true ] }
 157         { [ dup vocabulary>> not ] [ serialize-gensym ] }
 158         [ serialize-word ]
 159     } cond ;
 160
 161 M: wrapper (serialize) ( obj -- )
 162     CHAR: W write1
 163     wrapped>> (serialize) ;
 164
 165 DEFER: (deserialize)
 166
 167 SYMBOL: deserialized
 168
 169 : intern-object ( obj -- )
 170     deserialized get push ;
 171
 172 : deserialize-false ( -- f )
 173     f ;
 174
 175 : deserialize-true ( -- f )
 176     t ;
 177
 178 : deserialize-positive-integer ( -- number )
 179     deserialize-cell ;
 180
 181 : deserialize-negative-integer ( -- number )
 182     deserialize-positive-integer neg ;
 183
 184 : deserialize-zero ( -- number )
 185     0 ;
 186
 187 : deserialize-float ( -- float )
 188     deserialize-cell bits>double ;
 189
 190 : (deserialize-string) ( -- string )
 191     deserialize-cell read utf8 decode ;
 192
 193 : deserialize-string ( -- string )
 194     (deserialize-string) dup intern-object ;
 195
 196 : deserialize-word ( -- word )
 197     (deserialize) (deserialize) 2dup [ require ] keep lookup-word
 198     dup [ 2nip ] [
 199         drop
 200         2array unparse "Unknown word: " prepend throw
 201     ] if ;
 202
 203 : deserialize-gensym ( -- word )
 204     gensym {
 205         [ intern-object ]
 206         [ (deserialize) define ]
 207         [ (deserialize) >>props drop ]
 208         [ ]
 209     } cleave ;
 210
 211 : deserialize-wrapper ( -- wrapper )
 212     (deserialize) <wrapper> ;
 213
 214 :: (deserialize-seq) ( exemplar quot -- seq )
 215     deserialize-cell exemplar new-sequence
 216     [ intern-object ]
 217     [ [ drop quot call ] map! ] bi ; inline
 218
 219 : deserialize-array ( -- array )
 220     { } [ (deserialize) ] (deserialize-seq) ;
 221
 222 : deserialize-quotation ( -- array )
 223     (deserialize) >quotation dup intern-object ;
 224
 225 : deserialize-byte-array ( -- byte-array )
 226     B{ } [ read1 ] (deserialize-seq) ;
 227
 228 : deserialize-hashtable ( -- hashtable )
 229     H{ } clone
 230     [ intern-object ]
 231     [ (deserialize) assoc-union! drop ]
 232     [ ] tri ;
 233
 234 : copy-seq-to-tuple ( seq tuple -- )
 235     [ set-array-nth ] curry each-index ;
 236
 237 : deserialize-tuple ( -- array )
 238     #! Ugly because we have to intern the tuple before reading
 239     #! slots
 240     (deserialize) new
 241     [ intern-object ]
 242     [
 243         [ (deserialize) ]
 244         [ [ copy-seq-to-tuple ] keep ] bi*
 245     ] bi ;
 246
 247 : deserialize-unknown ( -- object )
 248     deserialize-cell deserialized get nth ;
 249
 250 : deserialize* ( -- object ? )
 251     read1 [
 252         {
 253             { CHAR: A [ deserialize-byte-array ] }
 254             { CHAR: F [ deserialize-float ] }
 255             { CHAR: T [ deserialize-tuple ] }
 256             { CHAR: W [ deserialize-wrapper ] }
 257             { CHAR: a [ deserialize-array ] }
 258             { CHAR: h [ deserialize-hashtable ] }
 259             { CHAR: m [ deserialize-negative-integer ] }
 260             { CHAR: n [ deserialize-false ] }
 261             { CHAR: t [ deserialize-true ] }
 262             { CHAR: o [ deserialize-unknown ] }
 263             { CHAR: p [ deserialize-positive-integer ] }
 264             { CHAR: q [ deserialize-quotation ] }
 265             { CHAR: s [ deserialize-string ] }
 266             { CHAR: w [ deserialize-word ] }
 267             { CHAR: G [ deserialize-word ] }
 268             { CHAR: z [ deserialize-zero ] }
 269         } case t
 270     ] [
 271         f f
 272     ] if* ;
 273
 274 : (deserialize) ( -- obj )
 275     deserialize* [ "End of stream" throw ] unless ;
 276
 277 PRIVATE>
 278
 279 : deserialize ( -- obj )
 280     V{ } clone deserialized
 281     [ (deserialize) ] with-variable ;
 282
 283 : serialize ( obj -- )
 284     IH{ } clone serialized [ (serialize) ] with-variable ;
 285
 286 : bytes>object ( bytes -- obj )
 287     binary [ deserialize ] with-byte-reader ;
 288
 289 : object>bytes ( obj -- bytes )
 290     binary [ serialize ] with-byte-writer ;