add serialisation code
chris.double
parent
2ca80eea6f
commit
fd1db437a5
|
|
@ -0,0 +1,201 @@
|
|||
IN: serialise
|
||||
USING: kernel generic strings lists vectors arrays sequences math
|
||||
io words errors hashtables prettyprint memory namespaces ;
|
||||
|
||||
! Variable holding a hashtable of object addresses already serialised
|
||||
SYMBOL: serialised
|
||||
|
||||
: serialised-address ( obj -- number|f )
|
||||
#! Return the address of the object if it has already been serialised
|
||||
#! otherwise false if it has not been serialised.
|
||||
address serialised get hash ;
|
||||
|
||||
: mark-serialised ( obj -- )
|
||||
#! Set the fact that this object has been serialised
|
||||
address dup serialised get set-hash ;
|
||||
|
||||
USE: prettyprint
|
||||
: get-serialised-object ( id -- obj )
|
||||
#! Return the object with the given id for a previously
|
||||
#! serialised object.
|
||||
serialised get hash ;
|
||||
|
||||
: set-serialised-object ( object id -- )
|
||||
#! Associate the id with the given object for deserialisation.
|
||||
serialised get set-hash ;
|
||||
|
||||
! Serialise object
|
||||
GENERIC: (serialise) ( obj -- )
|
||||
|
||||
M: f (serialise) ( obj -- )
|
||||
drop "n" write ;
|
||||
|
||||
M: fixnum (serialise) ( obj -- )
|
||||
! Factor may use 64 bit fixnums on such systems
|
||||
"f" write
|
||||
4 >be write ;
|
||||
|
||||
: bytes-needed ( bignum -- int )
|
||||
log2 8 + 8 / floor ;
|
||||
|
||||
M: bignum (serialise) ( obj -- )
|
||||
"b" write
|
||||
dup bytes-needed (serialise)
|
||||
dup bytes-needed >be write ;
|
||||
|
||||
M: float (serialise) ( obj -- )
|
||||
"F" write
|
||||
float>bits (serialise) ;
|
||||
|
||||
M: complex (serialise) ( obj -- )
|
||||
"c" write
|
||||
dup real (serialise)
|
||||
imaginary (serialise) ;
|
||||
|
||||
M: ratio (serialise) ( obj -- )
|
||||
"r" write
|
||||
dup numerator (serialise)
|
||||
denominator (serialise) ;
|
||||
|
||||
M: string (serialise) ( obj -- )
|
||||
"s" write
|
||||
dup length (serialise)
|
||||
write ;
|
||||
|
||||
M: object (serialise) ( obj -- )
|
||||
class word-name "Don't know to serialise a " swap append throw ;
|
||||
|
||||
M: sbuf (serialise) ( obj -- )
|
||||
"S" write
|
||||
dup length (serialise)
|
||||
[ (serialise) ] each ;
|
||||
|
||||
: object-unknown ( obj -- obj was-found-p )
|
||||
dup serialised-address [ "o" write (serialise) f ] [ t ] if* ;
|
||||
|
||||
: (serialise-seq) ( seq code -- )
|
||||
>r object-unknown
|
||||
[
|
||||
r> write
|
||||
dup address (serialise)
|
||||
dup length (serialise)
|
||||
dup mark-serialised
|
||||
[ (serialise) ] each
|
||||
] [
|
||||
r> 2drop
|
||||
] if ;
|
||||
|
||||
M: tuple (serialise)
|
||||
object-unknown
|
||||
[ "t" write tuple>array (serialise) ] [ drop ] if ;
|
||||
|
||||
M: array (serialise)
|
||||
"a" (serialise-seq) ;
|
||||
|
||||
M: vector (serialise)
|
||||
"v" (serialise-seq) ;
|
||||
|
||||
M: hashtable (serialise)
|
||||
"h"
|
||||
>r object-unknown
|
||||
[
|
||||
r> write
|
||||
dup mark-serialised
|
||||
dup address (serialise)
|
||||
dup hash-size (serialise)
|
||||
[ (serialise) (serialise) ] hash-each
|
||||
] [
|
||||
r> 2drop
|
||||
] if ;
|
||||
|
||||
M: cons (serialise) ( obj -- )
|
||||
object-unknown [ "C" write
|
||||
dup mark-serialised
|
||||
dup address (serialise)
|
||||
dup car (serialise)
|
||||
cdr (serialise) ] [ drop ] if ;
|
||||
|
||||
M: word (serialise)
|
||||
"w" write
|
||||
dup word-name (serialise)
|
||||
word-vocabulary (serialise) ;
|
||||
|
||||
DEFER: (deserialise)
|
||||
|
||||
: deserialise-false ( -- f )
|
||||
f ;
|
||||
|
||||
: deserialise-fixnum
|
||||
4 read be> ;
|
||||
|
||||
: deserialise-string
|
||||
(deserialise) read ;
|
||||
|
||||
: deserialise-word
|
||||
(deserialise) dup (deserialise) lookup dup [ nip ] [ "Unknown word" throw ] if ;
|
||||
|
||||
: deserialise-ratio
|
||||
(deserialise) (deserialise) / ;
|
||||
|
||||
: deserialise-complex
|
||||
(deserialise) (deserialise) rect> ;
|
||||
|
||||
: deserialise-bignum
|
||||
(deserialise) read be> ;
|
||||
|
||||
: deserialise-array ( -- array )
|
||||
(deserialise)
|
||||
(deserialise)
|
||||
[ [ (deserialise) , ] repeat ] { } make
|
||||
dup rot set-serialised-object ;
|
||||
|
||||
: deserialise-vector ( -- vector )
|
||||
(deserialise) ( address )
|
||||
(deserialise) ( address length )
|
||||
[ [ (deserialise) , ] repeat ] V{ } make ( address obj )
|
||||
dup rot set-serialised-object ;
|
||||
|
||||
: deserialise-hashtable ( -- vector )
|
||||
(deserialise) ( address )
|
||||
(deserialise) ( address length )
|
||||
[ [ (deserialise) (deserialise) swap f cons cons , ] repeat ] [ ] make alist>hash ( address obj )
|
||||
dup rot set-serialised-object ;
|
||||
|
||||
: deserialise-cons ( -- cons )
|
||||
(deserialise) ( address )
|
||||
(deserialise) ( address car )
|
||||
(deserialise) ( address car cdr )
|
||||
cons dup rot set-serialised-object ;
|
||||
|
||||
: deserialise-unknown ( -- obj )
|
||||
(deserialise) get-serialised-object ;
|
||||
|
||||
: serialise ( obj -- )
|
||||
[
|
||||
8 <hashtable> serialised set
|
||||
(serialise)
|
||||
] with-scope ;
|
||||
|
||||
: (deserialise)
|
||||
read1 ch>string dup
|
||||
H{ { "f" deserialise-fixnum }
|
||||
{ "s" deserialise-string }
|
||||
{ "r" deserialise-ratio }
|
||||
{ "c" deserialise-complex }
|
||||
{ "b" deserialise-bignum }
|
||||
{ "w" deserialise-word }
|
||||
{ "n" deserialise-false }
|
||||
{ "a" deserialise-array }
|
||||
{ "v" deserialise-vector }
|
||||
{ "h" deserialise-hashtable }
|
||||
{ "C" deserialise-cons }
|
||||
{ "o" deserialise-unknown }
|
||||
}
|
||||
hash dup [ "Unknown typecode" throw ] unless nip execute ;
|
||||
|
||||
: deserialise ( -- obj )
|
||||
[
|
||||
8 <hashtable> serialised set (deserialise)
|
||||
] with-scope ;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue