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