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