use reject instead of [ ... not ] filter.

[factor.git] / basis / compiler / tree / recursive / recursive.factor

diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index f6235719ffe5b9700a31e17b5c984b7dbace1c5a..2c65a700b6afca3bace5a94be4a048b0c6d03d0f 100644 (file)
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs arrays namespaces accessors sequences deques fry
-search-deques dlists combinators.short-circuit make sets compiler.tree ;
+USING: accessors combinators.short-circuit compiler.tree fry
+kernel namespaces sequences sets ;
+FROM: namespaces => set ;
 IN: compiler.tree.recursive
 
 TUPLE: call-site tail? node label ;
@@ -11,7 +12,7 @@ TUPLE: call-site tail? node label ;
 
 <PRIVATE
 
-TUPLE: call-tree-node label children calls ;
+TUPLE: call-graph-node tail? label children calls ;
 
 : (tail-calls) ( tail? seq -- seq' )
     reverse [ swap [ and ] keep ] map nip reverse ;
@@ -27,52 +28,54 @@ TUPLE: call-tree-node label children calls ;
 
 SYMBOLS: children calls ;
 
-GENERIC: node-call-tree ( tail? node -- )
+GENERIC: node-call-graph ( tail? node -- )
 
-: (build-call-tree) ( tail? nodes -- )
+: (build-call-graph) ( tail? nodes -- )
     [ tail-calls ] keep
-    [ node-call-tree ] 2each ;
+    [ node-call-graph ] 2each ;
 
-: build-call-tree ( nodes -- labels calls )
+: build-call-graph ( nodes -- labels calls )
     [
         V{ } clone children set
         V{ } clone calls set
-        [ t ] dip (build-call-tree)
+        [ t ] dip (build-call-graph)
         children get
         calls get
     ] with-scope ;
 
-M: #return-recursive node-call-tree
-    nip dup label>> (>>return) ;
+M: #return-recursive node-call-graph
+    nip dup label>> return<< ;
 
-M: #call-recursive node-call-tree
+M: #call-recursive node-call-graph
     [ dup label>> call-site boa ] keep
     [ drop calls get push ]
     [ label>> calls>> push ] 2bi ;
 
-M: #recursive node-call-tree
-    nip
+M: #recursive node-call-graph
     [ label>> V{ } clone >>calls drop ]
     [
-        [ label>> ] [ child>> build-call-tree ] bi
-        call-tree-node boa children get push
+        [ label>> ] [ child>> build-call-graph ] bi
+        call-graph-node boa children get push
     ] bi ;
 
-M: #branch node-call-tree
-    children>> [ (build-call-tree) ] with each ;
+M: #branch node-call-graph
+    children>> [ (build-call-graph) ] with each ;
 
-M: node node-call-tree 2drop ;
+M: #alien-callback node-call-graph
+    child>> (build-call-graph) ;
+
+M: node node-call-graph 2drop ;
 
 SYMBOLS: not-loops recursive-nesting ;
 
-: not-a-loop ( label -- ) not-loops get conjoin ;
+: not-a-loop ( label -- ) not-loops get adjoin ;
 
-: not-a-loop? ( label -- ? ) not-loops get key? ;
+: not-a-loop? ( label -- ? ) not-loops get in? ;
 
-: non-tail-calls ( call-tree-node -- seq )
-    calls>> [ tail?>> not ] filter ;
+: non-tail-calls ( call-graph-node -- seq )
+    calls>> [ tail?>> ] reject ;
 
-: visit-back-edges ( call-tree -- )
+: visit-back-edges ( call-graph -- )
     [
         [ non-tail-calls [ label>> not-a-loop ] each ]
         [ children>> visit-back-edges ]
@@ -84,37 +87,38 @@ SYMBOL: changed?
 : check-cross-frame-call ( call-site -- )
     label>> dup not-a-loop? [ drop ] [
         recursive-nesting get <reversed> [
-            2dup eq? [ 2drop f ] [
-                not-a-loop? [ not-a-loop changed? on ] [ drop ] if t
+            2dup label>> eq? [ 2drop f ] [
+                [ label>> not-a-loop? ] [ tail?>> not ] bi or
+                [ not-a-loop changed? on ] [ drop ] if t
             ] if
         ] with all? drop
     ] if ;
 
-: detect-cross-frame-calls ( call-tree -- )
+: detect-cross-frame-calls ( call-graph -- )
     ! Suppose we have a nesting of recursives A --> B --> C
     ! B tail-calls A, and C non-tail-calls B. Then A cannot be
     ! a loop, it needs its own procedure, since the call from
     ! C to A crosses a call-frame boundary.
     [
-        [ label>> recursive-nesting get push ]
+        [ recursive-nesting get push ]
         [ calls>> [ check-cross-frame-call ] each ]
         [ children>> detect-cross-frame-calls ] tri
         recursive-nesting get pop*
     ] each ;
 
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
     changed? off
     [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
     inline recursive
 
-: detect-loops ( call-tree -- )
-    H{ } clone not-loops set
+: detect-loops ( call-graph -- )
+    HS{ } clone not-loops set
     V{ } clone recursive-nesting set
     [ visit-back-edges ]
     [ '[ _ detect-cross-frame-calls ] while-changing ]
     bi ;
 
-: mark-loops ( call-tree -- )
+: mark-loops ( call-graph -- )
     [
         [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
         [ children>> mark-loops ]
@@ -123,6 +127,11 @@ SYMBOL: changed?
 
 PRIVATE>
 
+SYMBOL: call-graph
+
 : analyze-recursive ( nodes -- nodes )
-    dup build-call-tree drop
-    [ detect-loops ] [ mark-loops ] bi ;
+    dup build-call-graph drop
+    [ call-graph set ]
+    [ detect-loops ]
+    [ mark-loops ]
+    tri ;