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     [
  74         dup object-id
  75         [ CHAR: o write1 serialize-cell drop ]
  76     ] dip if* ; inline
  77
  78 M: f (serialize) ( obj -- )
  79     drop CHAR: n write1 ;
  80
  81 M: integer (serialize) ( obj -- )
  82     dup zero? [
  83         drop CHAR: z write1
  84     ] [
  85         dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
  86         serialize-cell
  87     ] if ;
  88
  89 M: float (serialize) ( obj -- )
  90     CHAR: F write1
  91     double>bits serialize-cell ;
  92
  93 M: complex (serialize) ( obj -- )
  94     CHAR: c write1
  95     [ real-part (serialize) ]
  96     [ imaginary-part (serialize) ] bi ;
  97
  98 M: ratio (serialize) ( obj -- )
  99     CHAR: r write1
 100     [ numerator (serialize) ]
 101     [ denominator (serialize) ] bi ;
 102
 103 : serialize-seq ( obj code -- )
 104     [
 105         write1
 106         [ add-object ]
 107         [ length serialize-cell ]
 108         [ [ (serialize) ] each ] tri
 109     ] curry serialize-shared ;
 110
 111 M: tuple (serialize) ( obj -- )
 112     [
 113         CHAR: T write1
 114         [ class (serialize) ]
 115         [ add-object ]
 116         [ tuple>array rest (serialize) ]
 117         tri
 118     ] serialize-shared ;
 119
 120 M: array (serialize) ( obj -- )
 121     CHAR: a serialize-seq ;
 122
 123 M: quotation (serialize) ( obj -- )
 124     [
 125         CHAR: q write1
 126         [ >array (serialize) ] [ add-object ] bi
 127     ] serialize-shared ;
 128
 129 M: hashtable (serialize) ( obj -- )
 130     [
 131         CHAR: h write1
 132         [ add-object ] [ >alist (serialize) ] bi
 133     ] serialize-shared ;
 134
 135 M: byte-array (serialize) ( obj -- )
 136     [
 137         CHAR: A write1
 138         [ add-object ]
 139         [ length serialize-cell ]
 140         [ write ] tri
 141     ] serialize-shared ;
 142
 143 M: string (serialize) ( obj -- )
 144     [
 145         CHAR: s write1
 146         [ add-object ]
 147         [
 148             utf8 encode
 149             [ length serialize-cell ]
 150             [ write ] bi
 151         ] bi
 152     ] serialize-shared ;
 153
 154 : serialize-true ( word -- )
 155     drop CHAR: t write1 ;
 156
 157 : serialize-gensym ( word -- )
 158     [
 159         CHAR: G write1
 160         [ add-object ]
 161         [ def>> (serialize) ]
 162         [ props>> (serialize) ]
 163         tri
 164     ] serialize-shared ;
 165
 166 : serialize-word ( word -- )
 167     CHAR: w write1
 168     [ name>> (serialize) ]
 169     [ vocabulary>> (serialize) ]
 170     bi ;
 171
 172 M: word (serialize) ( obj -- )
 173     {
 174         { [ dup t eq? ] [ serialize-true ] }
 175         { [ dup vocabulary>> not ] [ serialize-gensym ] }
 176         [ serialize-word ]
 177     } cond ;
 178
 179 M: wrapper (serialize) ( obj -- )
 180     CHAR: W write1
 181     wrapped>> (serialize) ;
 182
 183 DEFER: (deserialize) ( -- obj )
 184
 185 SYMBOL: deserialized
 186
 187 : intern-object ( obj -- )
 188     deserialized get push ;
 189
 190 : deserialize-false ( -- f )
 191     f ;
 192
 193 : deserialize-true ( -- f )
 194     t ;
 195
 196 : deserialize-positive-integer ( -- number )
 197     deserialize-cell ;
 198
 199 : deserialize-negative-integer ( -- number )
 200     deserialize-positive-integer neg ;
 201
 202 : deserialize-zero ( -- number )
 203     0 ;
 204
 205 : deserialize-float ( -- float )
 206     deserialize-cell bits>double ;
 207
 208 : deserialize-ratio ( -- ratio )
 209     (deserialize) (deserialize) / ;
 210
 211 : deserialize-complex ( -- complex )
 212     (deserialize) (deserialize) rect> ;
 213
 214 : (deserialize-string) ( -- string )
 215     deserialize-cell read utf8 decode ;
 216
 217 : deserialize-string ( -- string )
 218     (deserialize-string) dup intern-object ;
 219
 220 : deserialize-word ( -- word )
 221     (deserialize) (deserialize) 2dup lookup
 222     dup [ 2nip ] [
 223         drop
 224         "Unknown word: " -rot
 225         2array unparse append throw
 226     ] if ;
 227
 228 : deserialize-gensym ( -- word )
 229     gensym {
 230         [ intern-object ]
 231         [ (deserialize) define ]
 232         [ (deserialize) >>props drop ]
 233         [ ]
 234     } cleave ;
 235
 236 : deserialize-wrapper ( -- wrapper )
 237     (deserialize) <wrapper> ;
 238
 239 :: (deserialize-seq) ( exemplar quot -- seq )
 240     deserialize-cell exemplar new-sequence
 241     [ intern-object ]
 242     [ dup [ drop quot call ] change-each ] bi ; inline
 243
 244 : deserialize-array ( -- array )
 245     { } [ (deserialize) ] (deserialize-seq) ;
 246
 247 : deserialize-quotation ( -- array )
 248     (deserialize) >quotation dup intern-object ;
 249
 250 : deserialize-byte-array ( -- byte-array )
 251     B{ } [ read1 ] (deserialize-seq) ;
 252
 253 : deserialize-hashtable ( -- hashtable )
 254     H{ } clone
 255     [ intern-object ]
 256     [ (deserialize) update ]
 257     [ ] tri ;
 258
 259 : copy-seq-to-tuple ( seq tuple -- )
 260     [ dup length ] dip [ set-array-nth ] curry 2each ;
 261
 262 : deserialize-tuple ( -- array )
 263     #! Ugly because we have to intern the tuple before reading
 264     #! slots
 265     (deserialize) new
 266     [ intern-object ]
 267     [
 268         [ (deserialize) ]
 269         [ [ copy-seq-to-tuple ] keep ] bi*
 270     ] bi ;
 271
 272 : deserialize-unknown ( -- object )
 273     deserialize-cell deserialized get nth ;
 274
 275 : deserialize* ( -- object ? )
 276     read1 [
 277         {
 278             { CHAR: A [ deserialize-byte-array ] }
 279             { CHAR: F [ deserialize-float ] }
 280             { CHAR: T [ deserialize-tuple ] }
 281             { CHAR: W [ deserialize-wrapper ] }
 282             { CHAR: a [ deserialize-array ] }
 283             { CHAR: c [ deserialize-complex ] }
 284             { CHAR: h [ deserialize-hashtable ] }
 285             { CHAR: m [ deserialize-negative-integer ] }
 286             { CHAR: n [ deserialize-false ] }
 287             { CHAR: t [ deserialize-true ] }
 288             { CHAR: o [ deserialize-unknown ] }
 289             { CHAR: p [ deserialize-positive-integer ] }
 290             { CHAR: q [ deserialize-quotation ] }
 291             { CHAR: r [ deserialize-ratio ] }
 292             { CHAR: s [ deserialize-string ] }
 293             { CHAR: w [ deserialize-word ] }
 294             { CHAR: G [ deserialize-word ] }
 295             { CHAR: z [ deserialize-zero ] }
 296         } case t
 297     ] [
 298         f f
 299     ] if* ;
 300
 301 : (deserialize) ( -- obj )
 302     deserialize* [ "End of stream" throw ] unless ;
 303
 304 PRIVATE>
 305
 306 : deserialize ( -- obj )
 307     V{ } clone deserialized
 308     [ (deserialize) ] with-variable ;
 309
 310 : serialize ( obj -- )
 311     H{ } clone serialized [ (serialize) ] with-variable ;
 312
 313 : bytes>object ( bytes -- obj )
 314     binary [ deserialize ] with-byte-reader ;
 315
 316 : object>bytes ( obj -- bytes )
 317     binary [ serialize ] with-byte-writer ;