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

compiler.graphviz: was broken since some time ago, fix and add tests

db4
Slava Pestov 2009-09-22 03:20:22 -05:00
parent fe0701deb1
commit 661bf83ff3
2 changed files with 16 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/compiler/graphviz/graphviz-tests.factor Normal file
View File

@ -0,0 +1,6 @@
IN: compiler.graphviz.tests
USING: compiler.graphviz io.files ;
[ t ] [ [ [ 1 ] [ 2 ] if ] render-cfg exists? ] unit-test
[ t ] [ [ [ 1 ] [ 2 ] if ] render-dom exists? ] unit-test
[ t ] [ [ [ 1 ] [ 2 ] if ] render-call-graph exists? ] unit-test

17
extra/compiler/graphviz/graphviz.factor
View File

@ -18,15 +18,18 @@ IN: compiler.graphviz
"}" , "}" ,
] { } make , ; inline ] { } make , ; inline
: render-graph ( quot -- ) : render-graph ( quot -- name )
{ } make { } make
"cfg" ".dot" make-unique-file "cfg" ".dot" make-unique-file
dup "Wrote " prepend print dup "Wrote " prepend print
[ [ concat ] dip ascii set-file-lines ] [ [ concat ] dip ascii set-file-lines ]
[ { "dot" "-Tpng" "-O" } swap suffix try-process ] [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
[ ".png" append "open" swap 2array try-process ] [ ".png" append ]
tri ; inline tri ; inline
: display-graph ( name -- )
"open" swap 2array try-process ;
: attrs>string ( seq -- str ) : attrs>string ( seq -- str )
[ "" ] [ "," join "[" "]" surround ] if-empty ; [ "" ] [ "," join "[" "]" surround ] if-empty ;
@ -75,12 +78,12 @@ IN: compiler.graphviz
: optimized-cfg ( quot -- cfgs ) : optimized-cfg ( quot -- cfgs )
{ {
{ [ dup cfg? ] [ 1array ] } { [ dup cfg? ] [ 1array ] }
{ [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] } { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
{ [ dup word? ] [ test-cfg [ optimize-cfg ] map ] } { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
[ ] [ ]
} cond ; } cond ;
: render-cfg ( cfg -- ) : render-cfg ( cfg -- name )
optimized-cfg [ cfgs ] render-graph ; optimized-cfg [ cfgs ] render-graph ;
: dom-trees ( cfgs -- ) : dom-trees ( cfgs -- )
@ -95,7 +98,7 @@ IN: compiler.graphviz
] over cfg-title graph, ] over cfg-title graph,
] each ; ] each ;
: render-dom ( cfg -- ) : render-dom ( cfg -- name )
optimized-cfg [ dom-trees ] render-graph ; optimized-cfg [ dom-trees ] render-graph ;
SYMBOL: word-counts SYMBOL: word-counts
@ -131,7 +134,7 @@ SYMBOL: vertex-names
H{ } clone vertex-names set H{ } clone vertex-names set
[ "ROOT" ] dip (call-graph-edges) ; [ "ROOT" ] dip (call-graph-edges) ;
: render-call-graph ( tree -- ) : render-call-graph ( tree -- name )
dup quotation? [ build-tree ] when dup quotation? [ build-tree ] when
analyze-recursive drop analyze-recursive drop
[ [ call-graph get call-graph-edges ] "Call graph" graph, ] [ [ call-graph get call-graph-edges ] "Call graph" graph, ]