204 lines
4.5 KiB
Factor
204 lines
4.5 KiB
Factor
USING: tools.test kernel combinators.short-circuit math sequences accessors make
|
|
compiler.tree
|
|
compiler.tree.builder
|
|
compiler.tree.combinators
|
|
compiler.tree.recursive
|
|
compiler.tree.recursive.private ;
|
|
IN: compiler.tree.recursive.tests
|
|
|
|
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
|
|
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
|
|
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
|
|
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
|
|
|
|
: label-is-loop? ( nodes word -- ? )
|
|
swap [
|
|
[
|
|
dup {
|
|
[ #recursive? ]
|
|
[ label>> loop?>> ]
|
|
} 1&& [ label>> word>> , ] [ drop ] if
|
|
] each-node
|
|
] V{ } make member? ;
|
|
|
|
: label-is-not-loop? ( nodes word -- ? )
|
|
swap [
|
|
[
|
|
dup {
|
|
[ #recursive? ]
|
|
[ label>> loop?>> not ]
|
|
} 1&& [ label>> word>> , ] [ drop ] if
|
|
] each-node
|
|
] V{ } make member? ;
|
|
|
|
: loop-test-1 ( a -- )
|
|
dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ loop-test-1 ] build-tree analyze-recursive
|
|
\ loop-test-1 label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ loop-test-1 1 2 3 ] build-tree analyze-recursive
|
|
\ loop-test-1 label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ [ loop-test-1 ] each ] build-tree analyze-recursive
|
|
\ loop-test-1 label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ [ loop-test-1 ] each ] build-tree analyze-recursive
|
|
\ (each-integer) label-is-loop?
|
|
] unit-test
|
|
|
|
: loop-test-2 ( a b -- a' )
|
|
dup [ 1 + loop-test-2 1 - ] [ drop ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ loop-test-2 ] build-tree analyze-recursive
|
|
\ loop-test-2 label-is-not-loop?
|
|
] unit-test
|
|
|
|
: loop-test-3 ( a -- )
|
|
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ loop-test-3 ] build-tree analyze-recursive
|
|
\ loop-test-3 label-is-not-loop?
|
|
] unit-test
|
|
|
|
[ f ] [
|
|
[ [ [ ] map ] map ] build-tree analyze-recursive
|
|
[
|
|
dup #recursive? [ label>> loop?>> not ] [ drop f ] if
|
|
] contains-node?
|
|
] unit-test
|
|
|
|
: blah ( -- value ) f ;
|
|
|
|
DEFER: a
|
|
|
|
: b ( -- )
|
|
blah [ b ] [ a ] if ; inline recursive
|
|
|
|
: a ( -- )
|
|
blah [ b ] [ a ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ a ] build-tree analyze-recursive
|
|
\ a label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ a ] build-tree analyze-recursive
|
|
\ b label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ b ] build-tree analyze-recursive
|
|
\ a label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ a ] build-tree analyze-recursive
|
|
\ b label-is-loop?
|
|
] unit-test
|
|
|
|
DEFER: a'
|
|
|
|
: b' ( -- )
|
|
blah [ b' b' ] [ a' ] if ; inline recursive
|
|
|
|
: a' ( -- )
|
|
blah [ b' ] [ a' ] if ; inline recursive
|
|
|
|
[ f ] [
|
|
[ a' ] build-tree analyze-recursive
|
|
\ a' label-is-loop?
|
|
] unit-test
|
|
|
|
[ f ] [
|
|
[ b' ] build-tree analyze-recursive
|
|
\ b' label-is-loop?
|
|
] unit-test
|
|
|
|
! I used to think this should be f, but doing this on pen and
|
|
! paper almost convinced me that a loop conversion here is
|
|
! sound.
|
|
|
|
[ t ] [
|
|
[ b' ] build-tree analyze-recursive
|
|
\ a' label-is-loop?
|
|
] unit-test
|
|
|
|
[ f ] [
|
|
[ a' ] build-tree analyze-recursive
|
|
\ b' label-is-loop?
|
|
] unit-test
|
|
|
|
DEFER: a''
|
|
|
|
: b'' ( a -- b )
|
|
a'' ; inline recursive
|
|
|
|
: a'' ( a -- b )
|
|
dup [ b'' a'' ] when ; inline recursive
|
|
|
|
[ t ] [
|
|
[ a'' ] build-tree analyze-recursive
|
|
\ a'' label-is-not-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ a'' ] build-tree analyze-recursive
|
|
\ b'' label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ b'' ] build-tree analyze-recursive
|
|
\ a'' label-is-loop?
|
|
] unit-test
|
|
|
|
[ t ] [
|
|
[ b'' ] build-tree analyze-recursive
|
|
\ b'' label-is-not-loop?
|
|
] unit-test
|
|
|
|
: loop-in-non-loop ( x quot: ( i -- ) -- )
|
|
over 0 > [
|
|
[ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
|
|
] [ 2drop ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
|
|
build-tree analyze-recursive
|
|
\ (each-integer) label-is-loop?
|
|
] unit-test
|
|
|
|
DEFER: a'''
|
|
|
|
: b''' ( -- )
|
|
blah [ b''' ] [ a''' b''' ] if ; inline recursive
|
|
|
|
: a''' ( -- )
|
|
blah [ b''' ] [ a''' ] if ; inline recursive
|
|
|
|
[ t ] [
|
|
[ b''' ] build-tree analyze-recursive
|
|
\ a''' label-is-loop?
|
|
] unit-test
|
|
|
|
DEFER: b4
|
|
|
|
: a4 ( a -- b ) dup [ b4 ] when ; inline recursive
|
|
|
|
: b4 ( a -- b ) dup [ a4 reverse ] when ; inline recursive
|
|
|
|
[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
|
|
[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
|
|
[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
|
|
[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
|