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: accessors arrays assocs byte-arrays classes classes.tuple
10 combinators hashtables hashtables.identity io io.binary
11 io.encodings.binary io.encodings.string io.encodings.utf8
12 io.streams.byte-array kernel locals math namespaces prettyprint
13 quotations sequences sequences.private strings vocabs words ;
16 GENERIC: (serialize) ( obj -- )
20 ! Variable holding a assoc of objects already serialized
23 : add-object ( obj -- )
24 #! Add an object to the sequence of already serialized
26 serialized get [ assoc-size swap ] keep set-at ;
28 : object-id ( obj -- id )
29 #! Return the id of an already serialized object
32 ! Numbers are serialized as follows:
34 ! 1<=x<=126 => B{ x | 0x80 }
35 ! x>127 => B{ length(x) x[0] x[1] ... }
36 ! x>2^1024 => B{ 0xff length(x) 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 -- )
55 : deserialize-cell ( -- n )
57 { [ dup 0xff = ] [ drop deserialize-cell read be> ] }
58 { [ dup 0x80 >= ] [ 0x80 bitxor ] }
62 : serialize-shared ( obj quot -- )
65 [ CHAR: o write1 serialize-cell drop ]
68 M: f (serialize) ( obj -- )
71 M: integer (serialize) ( obj -- )
75 dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
79 M: float (serialize) ( obj -- )
81 double>bits serialize-cell ;
83 : serialize-seq ( obj code -- )
87 [ length serialize-cell ]
88 [ [ (serialize) ] each ] tri
89 ] curry serialize-shared ;
91 M: tuple (serialize) ( obj -- )
94 [ class-of (serialize) ]
96 [ tuple-slots (serialize) ]
100 M: array (serialize) ( obj -- )
101 CHAR: a serialize-seq ;
103 M: quotation (serialize) ( obj -- )
106 [ >array (serialize) ] [ add-object ] bi
109 M: hashtable (serialize) ( obj -- )
112 [ add-object ] [ >alist (serialize) ] bi
115 M: byte-array (serialize) ( obj -- )
119 [ length serialize-cell ]
123 M: string (serialize) ( obj -- )
129 [ length serialize-cell ]
134 : serialize-true ( word -- )
135 drop CHAR: t write1 ;
137 : serialize-gensym ( word -- )
141 [ def>> (serialize) ]
142 [ props>> (serialize) ]
146 : serialize-word ( word -- )
148 [ name>> (serialize) ]
149 [ vocabulary>> (serialize) ]
152 M: word (serialize) ( obj -- )
154 { [ dup t eq? ] [ serialize-true ] }
155 { [ dup vocabulary>> not ] [ serialize-gensym ] }
159 M: wrapper (serialize) ( obj -- )
161 wrapped>> (serialize) ;
167 : intern-object ( obj -- )
168 deserialized get push ;
170 : deserialize-false ( -- f )
173 : deserialize-true ( -- f )
176 : deserialize-positive-integer ( -- number )
179 : deserialize-negative-integer ( -- number )
180 deserialize-positive-integer neg ;
182 : deserialize-zero ( -- number )
185 : deserialize-float ( -- float )
186 deserialize-cell bits>double ;
188 : (deserialize-string) ( -- string )
189 deserialize-cell read utf8 decode ;
191 : deserialize-string ( -- string )
192 (deserialize-string) dup intern-object ;
194 : deserialize-word ( -- word )
195 (deserialize) (deserialize)
196 2dup [ require ] keep lookup-word [ 2nip ] [
197 2array unparse "Unknown word: " prepend throw
200 : deserialize-gensym ( -- word )
203 [ (deserialize) define ]
204 [ (deserialize) >>props ]
207 : deserialize-wrapper ( -- wrapper )
208 (deserialize) <wrapper> ;
210 :: (deserialize-seq) ( exemplar quot -- seq )
211 deserialize-cell exemplar new-sequence
213 [ [ drop quot call ] map! ] bi ; inline
215 : deserialize-array ( -- array )
216 { } [ (deserialize) ] (deserialize-seq) ;
218 : deserialize-quotation ( -- array )
219 (deserialize) >quotation dup intern-object ;
221 : deserialize-byte-array ( -- byte-array )
222 B{ } [ read1 ] (deserialize-seq) ;
224 : deserialize-hashtable ( -- hashtable )
227 [ (deserialize) assoc-union! ]
230 : copy-seq-to-tuple ( seq tuple -- )
231 [ set-array-nth ] curry each-index ;
233 : deserialize-tuple ( -- array )
234 #! Ugly because we have to intern the tuple before reading
240 [ [ copy-seq-to-tuple ] keep ] bi*
243 : deserialize-unknown ( -- object )
244 deserialize-cell deserialized get nth ;
246 : deserialize* ( -- object ? )
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 ] }
270 : (deserialize) ( -- obj )
271 deserialize* [ "End of stream" throw ] unless ;
275 : deserialize ( -- obj )
276 V{ } clone deserialized [ (deserialize) ] with-variable ;
278 : serialize ( obj -- )
279 IH{ } clone serialized [ (serialize) ] with-variable ;
281 : bytes>object ( bytes -- obj )
282 binary [ deserialize ] with-byte-reader ;
284 : object>bytes ( obj -- bytes )
285 binary [ serialize ] with-byte-writer ;