diff --git a/core/flow-chart/flow-chart.factor b/core/flow-chart/flow-chart.factor new file mode 100644 index 0000000000..5b6cb5f4f5 --- /dev/null +++ b/core/flow-chart/flow-chart.factor @@ -0,0 +1,74 @@ +USING: kernel words math inference.dataflow sequences +optimizer.def-use combinators.private namespaces arrays +math.parser assocs prettyprint io strings inference hashtables ; +IN: flow-chart + +GENERIC: flow-chart* ( n word -- value nodes ) + +M: word flow-chart* + 2drop f f ; + +M: compound flow-chart* + word-def swap 1+ [ drop ] map + [ dataflow-with compute-def-use ] keep + first dup used-by prune [ t eq? not ] subset ; + +GENERIC: node-word ( node -- word ) + +M: #call node-word node-param ; + +M: #if node-word drop \ if ; + +M: #dispatch node-word drop \ dispatch ; + +DEFER: flow-chart + +: flow-chart-node ( value node -- ) + [ node-in-d index ] keep + node-word flow-chart , ; + +SYMBOL: pruned + +SYMBOL: nesting + +SYMBOL: max-nesting + +2 max-nesting set + +: flow-chart ( n word -- seq ) + [ + 2dup 2array , + nesting dup inc get max-nesting get > [ + 2drop pruned , + ] [ + flow-chart* dup length 5 > [ + 2drop pruned , + ] [ + [ flow-chart-node ] curry* each + ] if + ] if + ] { } make ; + +: th ( n -- ) + dup number>string write + 100 mod dup 20 > [ 10 mod ] when + H{ { 1 "st" } { 2 "nd" } { 3 "rd" } } at "th" or write ; + +: chart-heading. ( pair -- ) + first2 >r 1+ th " argument to " write r> . ; + +GENERIC# show-chart 1 ( seq n -- ) + +: indent CHAR: \s write ; + +M: sequence show-chart + dup indent + >r unclip chart-heading. r> + 2 + [ show-chart ] curry each ; + +M: word show-chart + dup indent + "... pruned" print ; + +: flow-chart. ( n word -- ) + flow-chart 2 show-chart ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index e9dc4f3e55..a7a112b58a 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -145,7 +145,7 @@ SYMBOL: load-help? : update-roots ( vocabs -- ) [ dup find-vocab-root swap vocab set-vocab-root ] each ; -: to-refresh ( prefix -- seq ) +: to-refresh ( prefix -- modified-sources modified-docs ) child-vocabs dup update-roots dup modified-sources swap modified-docs ;