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
|
||||
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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue