extra/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 bit-arrays quotations hashtables assocs
  12 help.syntax help.markup float-arrays splitting
  13 io.streams.byte-array io.encodings.string io.encodings.utf8
  14 io.encodings.binary combinators accessors locals prettyprint
  15 compiler.units sequences.private 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         { [ t ] [ 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 1 tail (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: bit-array (serialize) ( obj -- )
 134     CHAR: b serialize-seq ;
 135
 136 M: byte-array (serialize) ( obj -- )
 137     [
 138         CHAR: A write1
 139         [ add-object ]
 140         [ length serialize-cell ]
 141         [ write ] tri
 142     ] serialize-shared ;
 143
 144 M: float-array (serialize) ( obj -- )
 145     [
 146         CHAR: f write1
 147         [ add-object ]
 148         [ length serialize-cell ]
 149         [ [ double>bits 8 >be write ] each ]
 150         tri
 151     ] serialize-shared ;
 152
 153 M: string (serialize) ( obj -- )
 154     [
 155         CHAR: s write1
 156         [ add-object ]
 157         [
 158             utf8 encode
 159             [ length serialize-cell ]
 160             [ write ] bi
 161         ] bi
 162     ] serialize-shared ;
 163
 164 : serialize-true ( word -- )
 165     drop CHAR: t write1 ;
 166
 167 : serialize-gensym ( word -- )
 168     [
 169         CHAR: G write1
 170         [ add-object ]
 171         [ word-def (serialize) ]
 172         [ word-props (serialize) ]
 173         tri
 174     ] serialize-shared ;
 175
 176 : serialize-word ( word -- )
 177     CHAR: w write1
 178     [ word-name (serialize) ]
 179     [ word-vocabulary (serialize) ]
 180     bi ;
 181
 182 M: word (serialize) ( obj -- )
 183     {
 184         { [ dup t eq? ] [ serialize-true ] }
 185         { [ dup word-vocabulary not ] [ serialize-gensym ] }
 186         { [ t ] [ serialize-word ] }
 187     } cond ;
 188
 189 M: wrapper (serialize) ( obj -- )
 190     CHAR: W write1
 191     wrapped (serialize) ;
 192
 193 DEFER: (deserialize) ( -- obj )
 194
 195 SYMBOL: deserialized
 196
 197 : intern-object ( obj -- )
 198     deserialized get push ;
 199
 200 : deserialize-false ( -- f )
 201     f ;
 202
 203 : deserialize-true ( -- f )
 204     t ;
 205
 206 : deserialize-positive-integer ( -- number )
 207     deserialize-cell ;
 208
 209 : deserialize-negative-integer ( -- number )
 210     deserialize-positive-integer neg ;
 211
 212 : deserialize-zero ( -- number )
 213     0 ;
 214
 215 : deserialize-float ( -- float )
 216     deserialize-cell bits>double ;
 217
 218 : deserialize-ratio ( -- ratio )
 219     (deserialize) (deserialize) / ;
 220
 221 : deserialize-complex ( -- complex )
 222     (deserialize) (deserialize) rect> ;
 223
 224 : (deserialize-string) ( -- string )
 225     deserialize-cell read utf8 decode ;
 226
 227 : deserialize-string ( -- string )
 228     (deserialize-string) dup intern-object ;
 229
 230 : deserialize-word ( -- word )
 231     (deserialize) (deserialize) 2dup lookup
 232     dup [ 2nip ] [
 233         "Unknown word: " -rot
 234         2array unparse append throw
 235     ] if ;
 236
 237 : deserialize-gensym ( -- word )
 238     gensym {
 239         [ intern-object ]
 240         [ (deserialize) define ]
 241         [ (deserialize) swap set-word-props ]
 242         [ ]
 243     } cleave ;
 244
 245 : deserialize-wrapper ( -- wrapper )
 246     (deserialize) <wrapper> ;
 247
 248 :: (deserialize-seq) ( exemplar quot -- seq )
 249     deserialize-cell exemplar new
 250     [ intern-object ]
 251     [ dup [ drop quot call ] change-each ] bi ; inline
 252
 253 : deserialize-array ( -- array )
 254     { } [ (deserialize) ] (deserialize-seq) ;
 255
 256 : deserialize-quotation ( -- array )
 257     (deserialize) >quotation dup intern-object ;
 258
 259 : deserialize-byte-array ( -- byte-array )
 260     B{ } [ read1 ] (deserialize-seq) ;
 261
 262 : deserialize-bit-array ( -- bit-array )
 263     ?{ } [ (deserialize) ] (deserialize-seq) ;
 264
 265 : deserialize-float-array ( -- float-array )
 266     F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
 267
 268 : deserialize-hashtable ( -- hashtable )
 269     H{ } clone
 270     [ intern-object ]
 271     [ (deserialize) update ]
 272     [ ] tri ;
 273
 274 : copy-seq-to-tuple ( seq tuple -- )
 275     >r dup length r> [ set-array-nth ] curry 2each ;
 276
 277 : deserialize-tuple ( -- array )
 278     #! Ugly because we have to intern the tuple before reading
 279     #! slots
 280     (deserialize) construct-empty
 281     [ intern-object ]
 282     [
 283         [ (deserialize) ]
 284         [ [ copy-seq-to-tuple ] keep ] bi*
 285     ] bi ;
 286
 287 : deserialize-unknown ( -- object )
 288     deserialize-cell deserialized get nth ;
 289
 290 : deserialize* ( -- object ? )
 291     read1 [
 292         {
 293             { CHAR: A [ deserialize-byte-array ] }
 294             { CHAR: F [ deserialize-float ] }
 295             { CHAR: T [ deserialize-tuple ] }
 296             { CHAR: W [ deserialize-wrapper ] }
 297             { CHAR: a [ deserialize-array ] }
 298             { CHAR: b [ deserialize-bit-array ] }
 299             { CHAR: c [ deserialize-complex ] }
 300             { CHAR: f [ deserialize-float-array ] }
 301             { CHAR: h [ deserialize-hashtable ] }
 302             { CHAR: m [ deserialize-negative-integer ] }
 303             { CHAR: n [ deserialize-false ] }
 304             { CHAR: t [ deserialize-true ] }
 305             { CHAR: o [ deserialize-unknown ] }
 306             { CHAR: p [ deserialize-positive-integer ] }
 307             { CHAR: q [ deserialize-quotation ] }
 308             { CHAR: r [ deserialize-ratio ] }
 309             { CHAR: s [ deserialize-string ] }
 310             { CHAR: w [ deserialize-word ] }
 311             { CHAR: G [ deserialize-word ] }
 312             { CHAR: z [ deserialize-zero ] }
 313         } case t
 314     ] [
 315         f f
 316     ] if* ;
 317
 318 : (deserialize) ( -- obj )
 319     deserialize* [ "End of stream" throw ] unless ;
 320
 321 : deserialize ( -- obj )
 322     ! [
 323     V{ } clone deserialized
 324     [ (deserialize) ] with-variable ;
 325     ! ] with-compilation-unit ;
 326
 327 : serialize ( obj -- )
 328     H{ } clone serialized [ (serialize) ] with-variable ;
 329
 330 : bytes>object ( bytes -- obj )
 331     binary [ deserialize ] with-byte-reader ;
 332
 333 : object>bytes ( obj -- bytes )
 334     binary [ serialize ] with-byte-writer ;