!
! See http://factorcode.org/license.txt for BSD license.
!
-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 ;
+USING: accessors arrays assocs byte-arrays classes classes.tuple
+combinators endian hashtables io io.encodings.binary
+io.encodings.string io.encodings.utf8 io.streams.byte-array
+kernel math namespaces prettyprint quotations sequences
+sequences.private strings vocabs words ;
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 ;
+ ! Add an object to the sequence of already serialized
+ ! objects.
+ serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
- #! Return the id of an already serialized object
- <id> serialized get at ;
+ ! Return the id of an already serialized object
+ serialized get at ;
-! Numbers are serialized as follows:
+! Positive numbers are serialized as follows:
! 0 => B{ 0 }
-! 1<=x<=126 => B{ x | 0x80 }
-! x>127 => B{ length(x) x[0] x[1] ... }
-! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... }
+! 1<=x<127 => B{ x | 0x80 }
+! 127<=x<2^1024 => B{ length(x) x[0] x[1] ... }; 1<length(x)<129 fits in 1 byte
+! 2^1024<=x => B{ 0xff } + serialize(length(x)) + B{ x[0] x[1] ... }
! 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 0x7f < [
+ 0x80 bitor write1
] [
- dup log2 8 /i 1+
- dup HEX: 7f >= [
- HEX: ff write1
+ dup log2 8 /i 1 +
+ dup 0x80 > [
+ 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 ;
[ CHAR: o write1 serialize-cell drop ]
] dip if* ; inline
-M: f (serialize) ( obj -- )
+M: f (serialize)
drop CHAR: n write1 ;
-M: integer (serialize) ( obj -- )
- dup zero? [
- drop CHAR: z write1
+M: integer (serialize)
+ [
+ CHAR: z write1
] [
dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
serialize-cell
- ] if ;
+ ] if-zero ;
-M: float (serialize) ( obj -- )
+M: float (serialize)
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
[ [ (serialize) ] each ] tri
] curry serialize-shared ;
-M: tuple (serialize) ( obj -- )
+M: tuple (serialize)
[
CHAR: T write1
- [ class (serialize) ]
+ [ class-of (serialize) ]
[ add-object ]
- [ tuple>array rest (serialize) ]
+ [ tuple-slots (serialize) ]
tri
] serialize-shared ;
-M: array (serialize) ( obj -- )
+M: array (serialize)
CHAR: a serialize-seq ;
-M: quotation (serialize) ( obj -- )
+M: quotation (serialize)
[
CHAR: q write1
[ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
-M: hashtable (serialize) ( obj -- )
+M: hashtable (serialize)
[
CHAR: h write1
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
-M: byte-array (serialize) ( obj -- )
+M: byte-array (serialize)
[
CHAR: A write1
[ add-object ]
[ write ] tri
] serialize-shared ;
-M: string (serialize) ( obj -- )
+M: string (serialize)
[
CHAR: s write1
[ add-object ]
[ vocabulary>> (serialize) ]
bi ;
-M: word (serialize) ( obj -- )
+M: word (serialize)
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup vocabulary>> not ] [ serialize-gensym ] }
[ serialize-word ]
} cond ;
-M: wrapper (serialize) ( obj -- )
+M: wrapper (serialize)
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
- dup [ 2nip ] [
- drop
- "Unknown word: " -rot
- 2array unparse append throw
- ] if ;
+ (deserialize) (deserialize)
+ 2dup [ require ] keep lookup-word [ 2nip ] [
+ 2array unparse "Unknown word: " prepend throw
+ ] if* ;
: deserialize-gensym ( -- word )
- gensym {
- [ intern-object ]
- [ (deserialize) define ]
- [ (deserialize) >>props drop ]
- [ ]
- } cleave ;
+ gensym
+ [ intern-object ]
+ [ (deserialize) define ]
+ [ (deserialize) >>props ]
+ tri ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
:: (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 ]
- [ ] tri ;
+ [ (deserialize) assoc-union! ]
+ bi ;
: 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
- #! slots
+ ! Ugly because we have to intern the tuple before reading
+ ! slots
(deserialize) new
[ intern-object ]
[
{ 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 ] }
PRIVATE>
: deserialize ( -- obj )
- V{ } clone deserialized
- [ (deserialize) ] with-variable ;
+ V{ } clone deserialized [ (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 ;
projects / factor.git / blobdiff