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 itdb4
parent
2ea1a999a4
commit
b5754d32ef
|
@ -1,6 +1,7 @@
|
||||||
USING: accessors arrays compiler.cfg.dependence compiler.cfg.instructions
|
USING: accessors arrays combinators.short-circuit compiler.cfg.dependence
|
||||||
kernel namespaces sequences tools.test ;
|
compiler.cfg.instructions fry kernel namespaces sequences tools.test ;
|
||||||
IN: compiler.cfg.dependence.tests
|
IN: compiler.cfg.dependence.tests
|
||||||
|
FROM: sets => set= ;
|
||||||
|
|
||||||
{
|
{
|
||||||
V{
|
V{
|
||||||
|
@ -35,13 +36,32 @@ IN: compiler.cfg.dependence.tests
|
||||||
3 iota [ node new swap >>number ] map first3
|
3 iota [ node new swap >>number ] map first3
|
||||||
over attach-parent over attach-parent ;
|
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 dup verify-parents ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
2node-tree 1array { } verify-parents
|
2node-tree 1array { } verify-parents
|
||||||
] [ node-missing-parent? ] must-fail-with
|
] [ node-missing-parent? ] must-fail-with
|
||||||
|
|
||||||
|
|
||||||
{ 1 } [ 3node-tree children>> length ] unit-test
|
{ 1 } [ 3node-tree children>> length ] unit-test
|
||||||
|
|
||||||
{ 3 } [ 3node-tree flatten-tree length ] unit-test
|
{ 3 } [ 3node-tree flatten-tree length ] unit-test
|
||||||
|
|
|
@ -1,9 +1,8 @@
|
||||||
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
|
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs combinators compiler.cfg.def-use
|
USING: accessors assocs combinators compiler.cfg.def-use
|
||||||
compiler.cfg.instructions compiler.cfg.registers fry kernel
|
compiler.cfg.instructions compiler.cfg.registers fry kernel locals
|
||||||
locals namespaces sequences sets sorting math.vectors
|
namespaces sequences sorting make math math.vectors vectors ;
|
||||||
make math combinators.short-circuit vectors ;
|
|
||||||
FROM: namespaces => set ;
|
FROM: namespaces => set ;
|
||||||
IN: compiler.cfg.dependence
|
IN: compiler.cfg.dependence
|
||||||
|
|
||||||
|
@ -102,10 +101,8 @@ M: object add-control-edge 2drop ;
|
||||||
dup node registers<< ;
|
dup node registers<< ;
|
||||||
|
|
||||||
! Constructing fan-in trees
|
! Constructing fan-in trees
|
||||||
|
|
||||||
: attach-parent ( node parent -- )
|
: attach-parent ( node parent -- )
|
||||||
[ >>parent drop ]
|
[ >>parent drop ] [ [ ?push ] change-children drop ] 2bi ;
|
||||||
[ [ ?push ] change-children drop ] 2bi ;
|
|
||||||
|
|
||||||
: keys-for ( assoc value -- keys )
|
: keys-for ( assoc value -- keys )
|
||||||
'[ nip _ = ] assoc-filter keys ;
|
'[ nip _ = ] assoc-filter keys ;
|
||||||
|
@ -122,26 +119,8 @@ M: object add-control-edge 2drop ;
|
||||||
: make-trees ( nodes -- trees )
|
: make-trees ( nodes -- trees )
|
||||||
[ [ choose-parent ] each ] [ [ parent>> not ] filter ] bi ;
|
[ [ 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 -- )
|
: build-fan-in-trees ( nodes -- )
|
||||||
dup make-trees [ verify-trees ] keep [
|
make-trees [
|
||||||
-1/0. >>parent-index
|
-1/0. >>parent-index
|
||||||
calculate-registers drop
|
calculate-registers drop
|
||||||
] each ;
|
] each ;
|
||||||
|
|
Loading…
Reference in New Issue