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 assocs help.syntax
  12 help.markup splitting io.streams.byte-array io.encodings.string
  13 io.encodings.utf8 io.encodings.binary combinators accessors
  14 locals prettyprint compiler.units sequences.private
  15 classes.tuple.private ;
  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 TUPLE: id obj ;
  26
  27 C: <id> id
  28
  29 M: id hashcode* obj>> hashcode* ;
  30
  31 M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
  32
  33 : add-object ( obj -- )
  34     #! Add an object to the sequence of already serialized
  35     #! objects.
  36     serialized get [ assoc-size swap <id> ] keep set-at ;
  37
  38 : object-id ( obj -- id )
  39     #! Return the id of an already serialized object
  40     <id> serialized get at ;
  41
  42 ! Numbers are serialized as follows:
  43 ! 0 => B{ 0 }
  44 ! 1<=x<=126 => B{ x | 0x80 }
  45 ! x>127 => B{ length(x) x[0] x[1] ... }
  46 ! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... }
  47 ! The last case is needed because a very large number would
  48 ! otherwise be confused with a small number.
  49 : serialize-cell ( n -- )
  50     dup zero? [ drop 0 write1 ] [
  51         dup HEX: 7e <= [
  52             HEX: 80 bitor write1
  53         ] [
  54             dup log2 8 /i 1+
  55             dup HEX: 7f >= [
  56                 HEX: ff write1
  57                 dup serialize-cell
  58             ] [
  59                 dup write1
  60             ] if
  61             >be write
  62         ] if
  63     ] if ;
  64
  65 : deserialize-cell ( -- n )
  66     read1 {
  67         { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
  68         { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
  69         [ read be> ]
  70     } cond ;
  71
  72 : serialize-shared ( obj quot -- )
  73     >r dup object-id
  74     [ CHAR: o write1 serialize-cell drop ]
  75     r> if* ; inline
  76
  77 M: f (serialize) ( obj -- )
  78     drop CHAR: n write1 ;
  79
  80 M: integer (serialize) ( obj -- )
  81     dup zero? [
  82         drop CHAR: z write1
  83     ] [
  84         dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
  85         serialize-cell
  86     ] if ;
  87
  88 M: float (serialize) ( obj -- )
  89     CHAR: F write1
  90     double>bits serialize-cell ;
  91
  92 M: complex (serialize) ( obj -- )
  93     CHAR: c write1
  94     [ real-part (serialize) ]
  95     [ imaginary-part (serialize) ] bi ;
  96
  97 M: ratio (serialize) ( obj -- )
  98     CHAR: r write1
  99     [ numerator (serialize) ]
 100     [ denominator (serialize) ] bi ;
 101
 102 : serialize-seq ( obj code -- )
 103     [
 104         write1
 105         [ add-object ]
 106         [ length serialize-cell ]
 107         [ [ (serialize) ] each ] tri
 108     ] curry serialize-shared ;
 109
 110 M: tuple (serialize) ( obj -- )
 111     [
 112         CHAR: T write1
 113         [ class (serialize) ]
 114         [ add-object ]
 115         [ tuple>array rest (serialize) ]
 116         tri
 117     ] serialize-shared ;
 118
 119 M: array (serialize) ( obj -- )
 120     CHAR: a serialize-seq ;
 121
 122 M: quotation (serialize) ( obj -- )
 123     [
 124         CHAR: q write1
 125         [ >array (serialize) ] [ add-object ] bi
 126     ] serialize-shared ;
 127
 128 M: hashtable (serialize) ( obj -- )
 129     [
 130         CHAR: h write1
 131         [ add-object ] [ >alist (serialize) ] bi
 132     ] serialize-shared ;
 133
 134 M: byte-array (serialize) ( obj -- )
 135     [
 136         CHAR: A write1
 137         [ add-object ]
 138         [ length serialize-cell ]
 139         [ write ] tri
 140     ] serialize-shared ;
 141
 142 M: string (serialize) ( obj -- )
 143     [
 144         CHAR: s write1
 145         [ add-object ]
 146         [
 147             utf8 encode
 148             [ length serialize-cell ]
 149             [ write ] bi
 150         ] bi
 151     ] serialize-shared ;
 152
 153 : serialize-true ( word -- )
 154     drop CHAR: t write1 ;
 155
 156 : serialize-gensym ( word -- )
 157     [
 158         CHAR: G write1
 159         [ add-object ]
 160         [ def>> (serialize) ]
 161         [ props>> (serialize) ]
 162         tri
 163     ] serialize-shared ;
 164
 165 : serialize-word ( word -- )
 166     CHAR: w write1
 167     [ name>> (serialize) ]
 168     [ vocabulary>> (serialize) ]
 169     bi ;
 170
 171 M: word (serialize) ( obj -- )
 172     {
 173         { [ dup t eq? ] [ serialize-true ] }
 174         { [ dup vocabulary>> not ] [ serialize-gensym ] }
 175         [ serialize-word ]
 176     } cond ;
 177
 178 M: wrapper (serialize) ( obj -- )
 179     CHAR: W write1
 180     wrapped>> (serialize) ;
 181
 182 DEFER: (deserialize) ( -- obj )
 183
 184 SYMBOL: deserialized
 185
 186 : intern-object ( obj -- )
 187     deserialized get push ;
 188
 189 : deserialize-false ( -- f )
 190     f ;
 191
 192 : deserialize-true ( -- f )
 193     t ;
 194
 195 : deserialize-positive-integer ( -- number )
 196     deserialize-cell ;
 197
 198 : deserialize-negative-integer ( -- number )
 199     deserialize-positive-integer neg ;
 200
 201 : deserialize-zero ( -- number )
 202     0 ;
 203
 204 : deserialize-float ( -- float )
 205     deserialize-cell bits>double ;
 206
 207 : deserialize-ratio ( -- ratio )
 208     (deserialize) (deserialize) / ;
 209
 210 : deserialize-complex ( -- complex )
 211     (deserialize) (deserialize) rect> ;
 212
 213 : (deserialize-string) ( -- string )
 214     deserialize-cell read utf8 decode ;
 215
 216 : deserialize-string ( -- string )
 217     (deserialize-string) dup intern-object ;
 218
 219 : deserialize-word ( -- word )
 220     (deserialize) (deserialize) 2dup lookup
 221     dup [ 2nip ] [
 222         drop
 223         "Unknown word: " -rot
 224         2array unparse append throw
 225     ] if ;
 226
 227 : deserialize-gensym ( -- word )
 228     gensym {
 229         [ intern-object ]
 230         [ (deserialize) define ]
 231         [ (deserialize) >>props drop ]
 232         [ ]
 233     } cleave ;
 234
 235 : deserialize-wrapper ( -- wrapper )
 236     (deserialize) <wrapper> ;
 237
 238 :: (deserialize-seq) ( exemplar quot -- seq )
 239     deserialize-cell exemplar new-sequence
 240     [ intern-object ]
 241     [ dup [ drop quot call ] change-each ] bi ; inline
 242
 243 : deserialize-array ( -- array )
 244     { } [ (deserialize) ] (deserialize-seq) ;
 245
 246 : deserialize-quotation ( -- array )
 247     (deserialize) >quotation dup intern-object ;
 248
 249 : deserialize-byte-array ( -- byte-array )
 250     B{ } [ read1 ] (deserialize-seq) ;
 251
 252 : deserialize-hashtable ( -- hashtable )
 253     H{ } clone
 254     [ intern-object ]
 255     [ (deserialize) update ]
 256     [ ] tri ;
 257
 258 : copy-seq-to-tuple ( seq tuple -- )
 259     >r dup length r> [ set-array-nth ] curry 2each ;
 260
 261 : deserialize-tuple ( -- array )
 262     #! Ugly because we have to intern the tuple before reading
 263     #! slots
 264     (deserialize) new
 265     [ intern-object ]
 266     [
 267         [ (deserialize) ]
 268         [ [ copy-seq-to-tuple ] keep ] bi*
 269     ] bi ;
 270
 271 : deserialize-unknown ( -- object )
 272     deserialize-cell deserialized get nth ;
 273
 274 : deserialize* ( -- object ? )
 275     read1 [
 276         {
 277             { CHAR: A [ deserialize-byte-array ] }
 278             { CHAR: F [ deserialize-float ] }
 279             { CHAR: T [ deserialize-tuple ] }
 280             { CHAR: W [ deserialize-wrapper ] }
 281             { CHAR: a [ deserialize-array ] }
 282             { CHAR: c [ deserialize-complex ] }
 283             { CHAR: h [ deserialize-hashtable ] }
 284             { CHAR: m [ deserialize-negative-integer ] }
 285             { CHAR: n [ deserialize-false ] }
 286             { CHAR: t [ deserialize-true ] }
 287             { CHAR: o [ deserialize-unknown ] }
 288             { CHAR: p [ deserialize-positive-integer ] }
 289             { CHAR: q [ deserialize-quotation ] }
 290             { CHAR: r [ deserialize-ratio ] }
 291             { CHAR: s [ deserialize-string ] }
 292             { CHAR: w [ deserialize-word ] }
 293             { CHAR: G [ deserialize-word ] }
 294             { CHAR: z [ deserialize-zero ] }
 295         } case t
 296     ] [
 297         f f
 298     ] if* ;
 299
 300 : (deserialize) ( -- obj )
 301     deserialize* [ "End of stream" throw ] unless ;
 302
 303 PRIVATE>
 304
 305 : deserialize ( -- obj )
 306     V{ } clone deserialized
 307     [ (deserialize) ] with-variable ;
 308
 309 : serialize ( obj -- )
 310     H{ } clone serialized [ (serialize) ] with-variable ;
 311
 312 : bytes>object ( bytes -- obj )
 313     binary [ deserialize ] with-byte-reader ;
 314
 315 : object>bytes ( obj -- bytes )
 316     binary [ serialize ] with-byte-writer ;