steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix serialization of circular structure

db4
Slava Pestov 2008-03-16 23:41:26 -05:00
parent 4e0c0dab49
commit ea2723a5a0
5 changed files with 177 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/db/postgresql/lib/lib.factor
View File

@ -73,7 +73,7 @@ IN: db.postgresql.lib
sql-spec-type {
{ FACTOR-BLOB [
dup [
binary [ serialize ] with-byte-writer
object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ binary [ deserialize ] with-byte-reader ] when ] }
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull

4
extra/db/sqlite/lib/lib.factor
View File

@ -94,7 +94,7 @@ IN: db.sqlite.lib
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
binary [ serialize ] with-byte-writer
object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
@ -131,7 +131,7 @@ IN: db.sqlite.lib
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ binary [ deserialize ] with-byte-reader ] when
dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]

28
extra/reports/optimizer/optimizer.factor Executable file
View File

@ -0,0 +1,28 @@
USING: assocs words sequences arrays compiler tools.time
io.styles io prettyprint vocabs kernel sorting generator
optimizer math ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: results
[ [ second ] swap compose compare ] curry sort 20 tail*
print
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
] tabular-output ;
: optimizer-report
all-words [ compiled? ] subset
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array
] { } map>assoc
[ first ] "Worst number of optimizer passes:" results
[ second ] "Worst compile times:" results ;
MAIN: optimizer-report

30
extra/serialize/serialize-tests.factor
View File

@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
combinators.lib ;
combinators.lib assocs ;
IN: serialize.tests
: test-serialize-cell
@ -56,19 +56,23 @@ C: <serialize-test> serialize-test
} ;
: check-serialize-1 ( obj -- ? )
"=====" print
dup class .
dup .
dup
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader = ;
object>bytes
bytes>object
dup . = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
drop t ! we don't care if numbers aren't interned
] [
"=====" print
dup class .
dup 2array
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader
dup 2array dup .
object>bytes
bytes>object dup .
first2 eq?
] if ;
@ -79,3 +83,17 @@ C: <serialize-test> serialize-test
[ t ] [ pi check-serialize-1 ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer
[ t ] [
V{ } dup dup push
object>bytes
bytes>object
dup first eq?
] unit-test
[ t ] [
H{ } dup dup dup set-at
object>bytes
bytes>object
dup keys first eq?
] unit-test

206
extra/serialize/serialize.factor
View File

@ -11,8 +11,9 @@ USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
assocs help.syntax help.markup float-arrays splitting
io.encodings.string io.encodings.utf8 combinators new-slots
accessors ;
io.encodings.string io.encodings.utf8 combinators
combinators.cleave new-slots accessors locals prettyprint
compiler.units sequences.private tuples.private ;
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- )
: serialize-shared ( obj quot -- )
>r dup object-id
[ CHAR: o write1 serialize-cell drop ] r> if* ; inline
[ CHAR: o write1 serialize-cell drop ]
r> if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- )
dup numerator (serialize)
denominator (serialize) ;
: serialize-string ( obj code -- )
write1
dup utf8 encode dup length serialize-cell write
add-object ;
M: string (serialize) ( obj -- )
[ CHAR: s serialize-string ] serialize-shared ;
: serialize-elements ( seq -- )
[ (serialize) ] each CHAR: . write1 ;
: serialize-seq ( obj code -- )
[
write1
[ add-object ]
[ length serialize-cell ]
[ [ (serialize) ] each ] tri
] curry serialize-shared ;
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
dup tuple>array serialize-elements
add-object
[ class (serialize) ]
[ add-object ]
[ tuple>array 1 tail (serialize) ]
tri
] serialize-shared ;
: serialize-seq ( seq code -- )
[
write1
dup serialize-elements
add-object
] curry serialize-shared ;
M: array (serialize) ( obj -- )
CHAR: a serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: A write1
dup dup length serialize-cell write
add-object
] serialize-shared ;
M: bit-array (serialize) ( obj -- )
[
CHAR: b write1
dup length serialize-cell
dup [ 1 0 ? ] B{ } map-as write
add-object
] serialize-shared ;
M: quotation (serialize) ( obj -- )
CHAR: q serialize-seq ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
dup length serialize-cell
dup [ double>bits 8 >be write ] each
add-object
CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
[
CHAR: h write1
dup >alist (serialize)
add-object
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
M: word (serialize) ( obj -- )
M: bit-array (serialize) ( obj -- )
CHAR: b serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: w write1
dup word-name (serialize)
dup word-vocabulary (serialize)
add-object
CHAR: A write1
[ add-object ]
[ length serialize-cell ]
[ write ] tri
] serialize-shared ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
[ add-object ]
[ length serialize-cell ]
[ [ double>bits 8 >be write ] each ]
tri
] serialize-shared ;
M: string (serialize) ( obj -- )
[
CHAR: s write1
[ add-object ]
[
utf8 encode
[ length serialize-cell ]
[ write ] bi
] bi
] serialize-shared ;
: serialize-true ( word -- )
drop CHAR: t write1 ;
: serialize-gensym ( word -- )
[
CHAR: G write1
[ add-object ]
[ word-def (serialize) ]
[ word-props (serialize) ]
tri
] serialize-shared ;
: serialize-word ( word -- )
CHAR: w write1
[ word-name (serialize) ]
[ word-vocabulary (serialize) ]
bi ;
M: word (serialize) ( obj -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
{ [ t ] [ serialize-word ] }
} cond ;
M: wrapper (serialize) ( obj -- )
CHAR: W write1
wrapped (serialize) ;
@ -179,6 +199,9 @@ SYMBOL: deserialized
: deserialize-false ( -- f )
f ;
: deserialize-true ( -- f )
t ;
: deserialize-positive-integer ( -- number )
deserialize-cell ;
@ -204,53 +227,63 @@ SYMBOL: deserialized
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup
[ dup intern-object ] [ "Unknown word" throw ] ?if ;
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
"Unknown word: " -rot
2array unparse append throw
] if ;
: deserialize-gensym ( -- word )
gensym
dup intern-object
dup (deserialize) define
dup (deserialize) swap set-word-props ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
SYMBOL: +stop+
: (deserialize-seq) ( -- seq )
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
: deserialize-seq ( seq -- array )
>r (deserialize-seq) r> like dup intern-object ;
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-array ( -- array )
{ } deserialize-seq ;
{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-quotation ( -- array )
[ ] deserialize-seq ;
: (deserialize-byte-array) ( -- byte-array )
deserialize-cell read B{ } like ;
(deserialize) >quotation dup intern-object ;
: deserialize-byte-array ( -- byte-array )
(deserialize-byte-array) dup intern-object ;
B{ } [ read1 ] (deserialize-seq) ;
: deserialize-bit-array ( -- bit-array )
(deserialize-byte-array) [ 0 > ] ?{ } map-as
dup intern-object ;
?{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-float-array ( -- float-array )
deserialize-cell
8 * read 8 <groups> [ be> bits>double ] F{ } map-as
dup intern-object ;
F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
(deserialize) >hashtable dup intern-object ;
H{ } clone
[ intern-object ]
[ (deserialize) update ]
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
>r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
(deserialize-seq) >tuple dup intern-object ;
#! Ugly because we have to intern the tuple before reading
#! slots
(deserialize) construct-empty
[ intern-object ]
[
[ (deserialize) ]
[ [ copy-seq-to-tuple ] keep ] bi*
] bi ;
: deserialize-unknown ( -- object )
deserialize-cell deserialized get nth ;
: deserialize-stop ( -- object )
+stop+ get ;
: deserialize* ( -- object ? )
read1 [
{
@ -265,14 +298,15 @@ SYMBOL: +stop+
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
{ CHAR: t [ deserialize-true ] }
{ 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 ] }
{ CHAR: z [ deserialize-zero ] }
{ CHAR: . [ deserialize-stop ] }
} case t
] [
f f
@ -283,13 +317,15 @@ SYMBOL: +stop+
: deserialize ( -- obj )
[
V{ } clone deserialized set
gensym +stop+ set
(deserialize)
] with-scope ;
V{ } clone deserialized
[ (deserialize) ] with-variable
] with-compilation-unit ;
: serialize ( obj -- )
[
H{ } clone serialized set
(serialize)
] with-scope ;
H{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
binary [ serialize ] with-byte-writer ;