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