1 ! Copyright (C) 2006 Adam Langley and Chris Double.
2 ! Adam Langley was the original author of this work.
4 ! Chris Double modified it to fix bugs and get it working
5 ! correctly under the latest versions of Factor.
7 ! See http://factorcode.org/license.txt for BSD license.
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 ;
18 ! Variable holding a assoc of objects already serialized
25 M: id hashcode* obj>> hashcode* ;
27 M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
29 : add-object ( obj -- )
30 #! Add an object to the sequence of already serialized
32 serialized get [ assoc-size swap <id> ] keep set-at ;
34 : object-id ( obj -- id )
35 #! Return the id of an already serialized object
36 <id> serialized get at ;
39 GENERIC: (serialize) ( obj -- )
41 ! Numbers are serialized as follows:
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 ] [
64 : deserialize-cell ( -- n )
66 { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
67 { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
71 : serialize-shared ( obj quot -- )
73 [ CHAR: o write1 serialize-cell drop ]
76 M: f (serialize) ( obj -- )
79 M: integer (serialize) ( obj -- )
83 dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
87 M: float (serialize) ( obj -- )
89 double>bits serialize-cell ;
91 M: complex (serialize) ( obj -- )
93 [ real-part (serialize) ]
94 [ imaginary-part (serialize) ] bi ;
96 M: ratio (serialize) ( obj -- )
98 [ numerator (serialize) ]
99 [ denominator (serialize) ] bi ;
101 : serialize-seq ( obj code -- )
105 [ length serialize-cell ]
106 [ [ (serialize) ] each ] tri
107 ] curry serialize-shared ;
109 M: tuple (serialize) ( obj -- )
112 [ class (serialize) ]
114 [ tuple>array rest (serialize) ]
118 M: array (serialize) ( obj -- )
119 CHAR: a serialize-seq ;
121 M: quotation (serialize) ( obj -- )
124 [ >array (serialize) ] [ add-object ] bi
127 M: hashtable (serialize) ( obj -- )
130 [ add-object ] [ >alist (serialize) ] bi
133 M: byte-array (serialize) ( obj -- )
137 [ length serialize-cell ]
141 M: string (serialize) ( obj -- )
147 [ length serialize-cell ]
152 : serialize-true ( word -- )
153 drop CHAR: t write1 ;
155 : serialize-gensym ( word -- )
159 [ def>> (serialize) ]
160 [ props>> (serialize) ]
164 : serialize-word ( word -- )
166 [ name>> (serialize) ]
167 [ vocabulary>> (serialize) ]
170 M: word (serialize) ( obj -- )
172 { [ dup t eq? ] [ serialize-true ] }
173 { [ dup vocabulary>> not ] [ serialize-gensym ] }
177 M: wrapper (serialize) ( obj -- )
179 wrapped>> (serialize) ;
181 DEFER: (deserialize) ( -- obj )
185 : intern-object ( obj -- )
186 deserialized get push ;
188 : deserialize-false ( -- f )
191 : deserialize-true ( -- f )
194 : deserialize-positive-integer ( -- number )
197 : deserialize-negative-integer ( -- number )
198 deserialize-positive-integer neg ;
200 : deserialize-zero ( -- number )
203 : deserialize-float ( -- float )
204 deserialize-cell bits>double ;
206 : deserialize-ratio ( -- ratio )
207 (deserialize) (deserialize) / ;
209 : deserialize-complex ( -- complex )
210 (deserialize) (deserialize) rect> ;
212 : (deserialize-string) ( -- string )
213 deserialize-cell read utf8 decode ;
215 : deserialize-string ( -- string )
216 (deserialize-string) dup intern-object ;
218 : deserialize-word ( -- word )
219 (deserialize) (deserialize) 2dup lookup
222 "Unknown word: " -rot
223 2array unparse append throw
226 : deserialize-gensym ( -- word )
229 [ (deserialize) define ]
230 [ (deserialize) >>props drop ]
234 : deserialize-wrapper ( -- wrapper )
235 (deserialize) <wrapper> ;
237 :: (deserialize-seq) ( exemplar quot -- seq )
238 deserialize-cell exemplar new-sequence
240 [ dup [ drop quot call ] change-each ] bi ; inline
242 : deserialize-array ( -- array )
243 { } [ (deserialize) ] (deserialize-seq) ;
245 : deserialize-quotation ( -- array )
246 (deserialize) >quotation dup intern-object ;
248 : deserialize-byte-array ( -- byte-array )
249 B{ } [ read1 ] (deserialize-seq) ;
251 : deserialize-hashtable ( -- hashtable )
254 [ (deserialize) update ]
257 : copy-seq-to-tuple ( seq tuple -- )
258 >r dup length r> [ set-array-nth ] curry 2each ;
260 : deserialize-tuple ( -- array )
261 #! Ugly because we have to intern the tuple before reading
267 [ [ copy-seq-to-tuple ] keep ] bi*
270 : deserialize-unknown ( -- object )
271 deserialize-cell deserialized get nth ;
273 : deserialize* ( -- object ? )
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 ] }
299 : (deserialize) ( -- obj )
300 deserialize* [ "End of stream" throw ] unless ;
302 : deserialize ( -- obj )
304 V{ } clone deserialized
305 [ (deserialize) ] with-variable ;
306 ! ] with-compilation-unit ;
308 : serialize ( obj -- )
309 H{ } clone serialized [ (serialize) ] with-variable ;
311 : bytes>object ( bytes -- obj )
312 binary [ deserialize ] with-byte-reader ;
314 : object>bytes ( obj -- bytes )
315 binary [ serialize ] with-byte-writer ;