compiler.cfg.dependence: moved tree verification code to .tests

Since verify-trees just checked that make-trees worked correctly, it's
better to have that code in the test vocab instead of slowing down
every compile by running it
db4
Björn Lindqvist 2014-11-09 02:02:48 +01:00 committed by Doug Coleman
parent 2ea1a999a4
commit b5754d32ef
2 changed files with 27 additions and 28 deletions

View File

@ -1,6 +1,7 @@
USING: accessors arrays compiler.cfg.dependence compiler.cfg.instructions
kernel namespaces sequences tools.test ;
USING: accessors arrays combinators.short-circuit compiler.cfg.dependence
compiler.cfg.instructions fry kernel namespaces sequences tools.test ;
IN: compiler.cfg.dependence.tests
FROM: sets => set= ;
{
V{
@ -35,13 +36,32 @@ IN: compiler.cfg.dependence.tests
3 iota [ node new swap >>number ] map first3
over attach-parent over attach-parent ;
! Verification tests
ERROR: node-missing-parent trees nodes ;
ERROR: node-missing-children trees nodes ;
: flatten-tree ( node -- nodes )
[ children>> [ flatten-tree ] map concat ] keep suffix ;
: verify-parents ( nodes trees -- )
2dup '[ [ parent>> ] [ _ member? ] bi or ] all?
[ 2drop ] [ node-missing-parent ] if ;
: verify-children ( nodes trees -- )
2dup [ flatten-tree ] map concat
{ [ [ length ] same? ] [ set= ] } 2&&
[ 2drop ] [ node-missing-children ] if ;
: verify-trees ( nodes trees -- )
[ verify-parents ] [ verify-children ] 2bi ;
{ } [ 2node-tree 1array dup verify-parents ] unit-test
[
2node-tree 1array { } verify-parents
] [ node-missing-parent? ] must-fail-with
{ 1 } [ 3node-tree children>> length ] unit-test
{ 3 } [ 3node-tree flatten-tree length ] unit-test

View File

@ -1,9 +1,8 @@
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators compiler.cfg.def-use
compiler.cfg.instructions compiler.cfg.registers fry kernel
locals namespaces sequences sets sorting math.vectors
make math combinators.short-circuit vectors ;
compiler.cfg.instructions compiler.cfg.registers fry kernel locals
namespaces sequences sorting make math math.vectors vectors ;
FROM: namespaces => set ;
IN: compiler.cfg.dependence
@ -102,10 +101,8 @@ M: object add-control-edge 2drop ;
dup node registers<< ;
! Constructing fan-in trees
: attach-parent ( node parent -- )
[ >>parent drop ]
[ [ ?push ] change-children drop ] 2bi ;
[ >>parent drop ] [ [ ?push ] change-children drop ] 2bi ;
: keys-for ( assoc value -- keys )
'[ nip _ = ] assoc-filter keys ;
@ -122,26 +119,8 @@ M: object add-control-edge 2drop ;
: make-trees ( nodes -- trees )
[ [ choose-parent ] each ] [ [ parent>> not ] filter ] bi ;
ERROR: node-missing-parent trees nodes ;
ERROR: node-missing-children trees nodes ;
: flatten-tree ( node -- nodes )
[ children>> [ flatten-tree ] map concat ] keep suffix ;
: verify-parents ( nodes trees -- )
2dup '[ [ parent>> ] [ _ member? ] bi or ] all?
[ 2drop ] [ node-missing-parent ] if ;
: verify-children ( nodes trees -- )
2dup [ flatten-tree ] map concat
{ [ [ length ] same? ] [ set= ] } 2&&
[ 2drop ] [ node-missing-children ] if ;
: verify-trees ( nodes trees -- )
[ verify-parents ] [ verify-children ] 2bi ;
: build-fan-in-trees ( nodes -- )
dup make-trees [ verify-trees ] keep [
make-trees [
-1/0. >>parent-index
calculate-registers drop
] each ;