factor/contrib/serialize/serialize.factor

213 lines
4.7 KiB
Factor
Raw Normal View History

! Copyright (C) 2006 Adam Langley and Chris Double.
! Adam Langley was the original author of this work.
!
! Chris Double modified it to fix bugs and get it working
! correctly under the latest versions of Factor.
!
2006-08-30 08:05:26 -04:00
! See http://factorcode.org/license.txt for BSD license.
!
2006-08-30 08:05:26 -04:00
IN: serialize
2006-08-30 18:11:53 -04:00
USING: kernel kernel-internals math hashtables namespaces io strings sequences generic words errors arrays vectors ;
2006-08-30 08:05:26 -04:00
! Variable holding a sequence of objects already serialized
SYMBOL: serialized
: add-object ( obj -- id )
#! Add an object to the sequence of already serialized objects.
#! Return the id of that object.
serialized get [ push ] keep length 1 - ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
serialized get [ eq? ] find-with [ drop f ] unless ;
USE: prettyprint
! Serialize object
GENERIC: serialize ( obj -- )
2006-08-30 08:05:26 -04:00
2006-08-30 18:11:53 -04:00
: serialize-shared ( obj quot -- )
>r dup object-id [ "o" write serialize drop ] r> if* ; inline
2006-08-30 18:11:53 -04:00
M: f serialize ( obj -- )
drop "n" write ;
2006-08-30 08:05:26 -04:00
M: fixnum serialize ( obj -- )
! Factor may use 64 bit fixnums on such systems
"f" write
4 >be write ;
2006-08-30 08:05:26 -04:00
: bytes-needed ( bignum -- int )
log2 8 + 8 / floor ;
2006-08-30 08:05:26 -04:00
M: bignum serialize ( obj -- )
"b" write
dup bytes-needed serialize
dup bytes-needed >be write ;
2006-08-30 08:05:26 -04:00
M: float serialize ( obj -- )
"F" write
float>bits serialize ;
2006-08-30 08:05:26 -04:00
M: complex serialize ( obj -- )
2006-08-30 18:11:53 -04:00
[
"c" write
dup add-object serialize
dup real serialize
imaginary serialize
2006-08-30 18:11:53 -04:00
] serialize-shared ;
2006-08-30 08:05:26 -04:00
M: ratio serialize ( obj -- )
"r" write
dup numerator serialize
denominator serialize ;
2006-08-30 08:05:26 -04:00
M: string serialize ( obj -- )
2006-08-30 18:11:53 -04:00
[
"s" write
dup add-object serialize
dup length serialize
2006-08-30 18:11:53 -04:00
write
] serialize-shared ;
2006-08-30 08:05:26 -04:00
M: object serialize ( obj -- )
class word-name "Don't know to serialize a " swap append throw ;
2006-08-30 08:05:26 -04:00
M: sbuf serialize ( obj -- )
"S" write
dup length serialize
[ serialize ] each ;
2006-08-30 08:05:26 -04:00
: serialize-seq ( seq code -- )
2006-08-30 18:11:53 -04:00
swap [
over write
dup add-object serialize
dup length serialize
[ serialize ] each
2006-08-30 18:11:53 -04:00
] serialize-shared drop ;
M: tuple serialize ( obj -- )
2006-08-30 18:11:53 -04:00
[
"t" write
dup add-object serialize
tuple>array serialize
2006-08-30 18:11:53 -04:00
] serialize-shared ;
M: array serialize ( obj -- )
"a" serialize-seq ;
M: vector serialize ( obj -- )
"v" serialize-seq ;
M: quotation serialize ( obj -- )
"q" serialize-seq ;
M: hashtable serialize ( obj -- )
2006-08-30 18:11:53 -04:00
[
"h" write
dup add-object serialize
hash>alist serialize
2006-08-30 18:11:53 -04:00
] serialize-shared ;
M: word serialize ( obj -- )
"w" write
dup word-name serialize
word-vocabulary serialize ;
M: wrapper serialize ( obj -- )
"W" write
wrapped serialize ;
DEFER: deserialize ( -- obj )
2006-08-30 08:05:26 -04:00
2006-08-30 18:11:53 -04:00
: intern-object ( id obj -- )
swap serialized get set-nth ;
2006-08-30 08:05:26 -04:00
: deserialize-false ( -- f )
f ;
2006-08-30 08:05:26 -04:00
: deserialize-fixnum ( -- fixnum )
4 read be> ;
2006-08-30 08:05:26 -04:00
: deserialize-string ( -- string )
deserialize deserialize read [ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-ratio ( -- ratio )
deserialize deserialize / ;
2006-08-30 08:05:26 -04:00
: deserialize-complex ( -- complex )
deserialize deserialize deserialize rect> [ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-bignum ( -- bignum )
deserialize read be> ;
: deserialize-float ( -- float )
deserialize bits>float ;
2006-08-30 08:05:26 -04:00
: deserialize-word ( -- word )
deserialize dup deserialize lookup dup [ nip ] [ "Unknown word" throw ] if ;
2006-08-30 08:05:26 -04:00
: deserialize-wrapper ( -- wrapper )
deserialize <wrapper> ;
2006-08-30 08:05:26 -04:00
: deserialize-array ( -- array )
deserialize
2006-08-30 08:05:26 -04:00
[
deserialize
[ deserialize , ] repeat
2006-08-30 08:05:26 -04:00
] { } make
2006-08-30 18:11:53 -04:00
[ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-vector ( -- array )
deserialize
2006-08-30 08:05:26 -04:00
[
deserialize
[ deserialize , ] repeat
2006-08-30 08:05:26 -04:00
] V{ } make
2006-08-30 18:11:53 -04:00
[ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-quotation ( -- array )
deserialize
[
deserialize
[ deserialize , ] repeat
] [ ] make
2006-08-30 18:11:53 -04:00
[ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-hashtable ( -- array )
deserialize
deserialize alist>hash
2006-08-30 18:11:53 -04:00
[ intern-object ] keep ;
: deserialize-tuple ( -- array )
deserialize
deserialize array>tuple
2006-08-30 18:11:53 -04:00
[ intern-object ] keep ;
2006-08-30 08:05:26 -04:00
: deserialize-unknown ( -- object )
deserialize serialized get nth ;
2006-08-30 08:05:26 -04:00
2006-08-30 18:11:53 -04:00
: deserialize ( -- object )
read1 ch>string dup
H{ { "f" deserialize-fixnum }
{ "s" deserialize-string }
{ "r" deserialize-ratio }
{ "c" deserialize-complex }
{ "b" deserialize-bignum }
{ "F" deserialize-float }
{ "w" deserialize-word }
{ "W" deserialize-wrapper }
{ "n" deserialize-false }
{ "a" deserialize-array }
{ "v" deserialize-vector }
{ "q" deserialize-quotation }
{ "h" deserialize-hashtable }
2006-08-30 18:11:53 -04:00
{ "t" deserialize-tuple }
{ "o" deserialize-unknown }
}
hash dup [ "Unknown typecode" throw ] unless nip execute ;
2006-08-30 08:05:26 -04:00
2006-08-30 18:11:53 -04:00
: with-serialized ( quot -- )
[ V{ } serialized set call ] with-scope ; inline