!
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables assocs help.syntax
-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 ;
+vectors byte-arrays quotations hashtables hashtables.identity
+assocs help.syntax 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 vocabs ;
IN: serialize
GENERIC: (serialize) ( obj -- )
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
-TUPLE: id obj ;
-
-C: <id> id
-
-M: id hashcode* obj>> hashcode* ;
-
-M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
-
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
#! objects.
- serialized get [ assoc-size swap <id> ] keep set-at ;
+ serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
- <id> serialized get at ;
+ serialized get at ;
! Numbers are serialized as follows:
! 0 => B{ 0 }
! 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 ] [
- dup HEX: 7e <= [
- HEX: 80 bitor write1
+ [ 0 write1 ] [
+ dup 0x7e <= [
+ 0x80 bitor write1
] [
- dup log2 8 /i 1+
- dup HEX: 7f >= [
- HEX: ff write1
+ dup log2 8 /i 1 +
+ dup 0x7f >= [
+ 0xff write1
dup serialize-cell
] [
dup write1
] if
>be write
] if
- ] if ;
+ ] if-zero ;
: deserialize-cell ( -- n )
read1 {
- { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
- { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
+ { [ dup 0xff = ] [ drop deserialize-cell read be> ] }
+ { [ dup 0x80 >= ] [ 0x80 bitxor ] }
[ read be> ]
} cond ;
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
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
- [ class (serialize) ]
+ [ class-of (serialize) ]
[ add-object ]
[ tuple>array rest (serialize) ]
tri
CHAR: W write1
wrapped>> (serialize) ;
-DEFER: (deserialize) ( -- obj )
+DEFER: (deserialize)
SYMBOL: deserialized
: 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-word
dup [ 2nip ] [
drop
2array unparse "Unknown word: " prepend throw
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new-sequence
[ intern-object ]
- [ dup [ drop quot call ] change-each ] bi ; inline
+ [ [ drop quot call ] map! ] bi ; inline
: deserialize-array ( -- array )
{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
H{ } clone
[ intern-object ]
- [ (deserialize) update ]
+ [ (deserialize) assoc-union! drop ]
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
- [ dup length ] dip [ set-array-nth ] curry 2each ;
+ [ set-array-nth ] curry each-index ;
: 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) ] with-variable ;
: serialize ( obj -- )
- H{ } clone serialized [ (serialize) ] with-variable ;
+ IH{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
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 ;