help.markup splitting io.streams.byte-array io.encodings.string
io.encodings.utf8 io.encodings.binary combinators accessors
locals prettyprint compiler.units sequences.private
-classes.tuple.private ;
+classes.tuple.private vocabs.loader ;
IN: serialize
+GENERIC: (serialize) ( obj -- )
+
+<PRIVATE
+
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
#! Return the id of an already serialized object
<id> serialized get at ;
-! Serialize object
-GENERIC: (serialize) ( obj -- )
-
! Numbers are serialized as follows:
! 0 => B{ 0 }
! 1<=x<=126 => B{ x | 0x80 }
! The last case is needed because a very large number would
! otherwise be confused with a small number.
: serialize-cell ( n -- )
- dup zero? [ drop 0 write1 ] [
+ [ 0 write1 ] [
dup HEX: 7e <= [
HEX: 80 bitor write1
] [
- dup log2 8 /i 1+
+ dup log2 8 /i 1 +
dup HEX: 7f >= [
HEX: ff write1
dup serialize-cell
] if
>be write
] if
- ] if ;
+ ] if-zero ;
: deserialize-cell ( -- n )
read1 {
} cond ;
: serialize-shared ( obj quot -- )
- >r dup object-id
- [ CHAR: o write1 serialize-cell drop ]
- r> if* ; inline
+ [
+ dup object-id
+ [ CHAR: o write1 serialize-cell drop ]
+ ] dip if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup zero? [
- drop CHAR: z write1
+ [
+ CHAR: z write1
] [
dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
serialize-cell
- ] if ;
+ ] if-zero ;
M: float (serialize) ( obj -- )
CHAR: F write1
double>bits serialize-cell ;
-M: complex (serialize) ( obj -- )
- CHAR: c write1
- [ real-part (serialize) ]
- [ imaginary-part (serialize) ] bi ;
-
-M: ratio (serialize) ( obj -- )
- CHAR: r write1
- [ numerator (serialize) ]
- [ denominator (serialize) ] bi ;
-
: serialize-seq ( obj code -- )
[
write1
: deserialize-float ( -- float )
deserialize-cell bits>double ;
-: deserialize-ratio ( -- ratio )
- (deserialize) (deserialize) / ;
-
-: deserialize-complex ( -- complex )
- (deserialize) (deserialize) rect> ;
-
: (deserialize-string) ( -- string )
deserialize-cell read utf8 decode ;
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
- (deserialize) (deserialize) 2dup lookup
+ (deserialize) (deserialize) 2dup [ require ] keep lookup
dup [ 2nip ] [
drop
- "Unknown word: " -rot
- 2array unparse append throw
+ 2array unparse "Unknown word: " prepend throw
] if ;
: deserialize-gensym ( -- word )
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
- >r dup length r> [ set-array-nth ] curry 2each ;
+ [ dup length ] dip [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
{ CHAR: T [ deserialize-tuple ] }
{ CHAR: W [ deserialize-wrapper ] }
{ CHAR: a [ deserialize-array ] }
- { CHAR: c [ deserialize-complex ] }
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
- { CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
{ CHAR: G [ deserialize-word ] }
: (deserialize) ( -- obj )
deserialize* [ "End of stream" throw ] unless ;
+PRIVATE>
+
: deserialize ( -- obj )
- ! [
V{ } clone deserialized
[ (deserialize) ] with-variable ;
- ! ] with-compilation-unit ;
: serialize ( obj -- )
H{ } clone serialized [ (serialize) ] with-variable ;
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
- binary [ serialize ] with-byte-writer ;
\ No newline at end of file
+ binary [ serialize ] with-byte-writer ;