1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3
4# Perform reachability analysis on the PE grammar delivered by the
5# frontend. The grammar is in normalized form (reduced to essentials,
6# graph like node-x-references, expression trees).
7
8# This package assumes to be used from within a PAGE plugin. It uses
9# the API commands listed below. These are identical across the major
10# types of PAGE plugins, allowing this package to be used in reader,
11# transform, and writer plugins. It cannot be used in a configuration
12# plugin, and this makes no sense either.
13#
14# To ensure that our assumption is ok we require the relevant pseudo
15# package setup by the PAGE plugin management code.
16#
17# -----------------+--
18# page_info        | Reporting to the user.
19# page_warning     |
20# page_error       |
21# -----------------+--
22# page_log_error   | Reporting of internals.
23# page_log_warning |
24# page_log_info    |
25# -----------------+--
26
27# ### ### ### ######### ######### #########
28## Requisites
29
30# @mdgen NODEP: page::plugin
31
32package require page::plugin     ; # S.a. pseudo-package.
33package require page::util::flow ; # Dataflow walking.
34package require page::util::peg  ; # General utilities.
35
36namespace eval ::page::analysis::peg::reachable {
37    namespace import ::page::util::peg::*
38}
39
40# ### ### ### ######### ######### #########
41## API
42
43proc ::page::analysis::peg::reachable::compute {t} {
44
45    # Ignore call if already done before
46    if {[$t keyexists root page::analysis::peg::reachable]} return
47
48    # We compute the set of all nodes which are reachable from the
49    # root node of the start expression. This is a simple topdown walk
50    # where the children of all reachable nodes are mode reachable as
51    # well, and invokations of nonterminals symbols are treated as
52    # children as well. At the end of the flow all reachable non-
53    # terminal symbols and their expressions are marked, and none
54    # other.
55
56    # Initialize walking state: 2 arrays, all nodes (except root) are
57    # in or the other array, and their location tells if they are
58    # reachable or not. In the beginning no node is reachable. The
59    # goal array (reach) also serves as minder of which nodes have
60    # been seen, to cut multiple visits short.
61
62    array set unreach {} ; foreach n [$t nodes] {set unreach($n) .}
63    unset     unreach(root)
64    array set reach   {}
65
66    # A node is visited if it has been determined that it is indeed
67    # reachable.
68
69    page::util::flow [list [$t get root start]] flow n {
70	# Ignore nodes already reached.
71	if {[info exists reach($n)]} continue
72
73	# Reclassify node, has been reached now.
74	unset unreach($n)
75	set   reach($n) .
76
77	# Schedule children for visit --> topdown flow.
78	$flow visitl [$t children $n]
79
80	# Treat n-Nodes as special, their definition as indirect
81	# child. But ignore invokations of undefined nonterminal
82	# symbols, or those already marked as reachable.
83
84	if {![$t keyexists $n op]} continue
85	if {[$t get $n op] ne "n"} continue
86
87	set def [$t get $n def]
88	if {$def eq ""}                continue
89	if {[info exists reach($def)]} continue
90	$flow visit $def
91    }
92
93    # Store results. This also serves as marker.
94
95    $t set root page::analysis::peg::reachable   [array names reach]
96    $t set root page::analysis::peg::unreachable [array names unreach]
97    return
98}
99
100proc ::page::analysis::peg::reachable::remove! {t} {
101
102    # Determine which nonterminal symbols are reachable from the root
103    # of the start expression.
104
105    compute $t
106
107    # Remove all nodes which are not reachable.
108
109    set unreach [$t get root page::analysis::peg::unreachable]
110    foreach n [lsort $unreach] {
111	if {[$t exists $n]} {
112	    $t delete $n
113	}
114    }
115
116    # Notify the user of the definitions which were among the removed
117    # nodes. Keep only the still-existing definitions.
118
119    set res {}
120    foreach {sym def} [$t get root definitions] {
121	if {![$t exists $def]} {
122	    page_warning "  $sym: Unreachable nonterminal symbol, deleting"
123	} else {
124	    lappend res $sym $def
125	}
126    }
127
128    # Clear computation results.
129
130    $t unset root page::analysis::peg::reachable
131    $t unset root page::analysis::peg::unreachable
132
133    $t set root definitions $res
134    updateUndefinedDueRemoval $t
135    return
136}
137
138proc ::page::analysis::peg::reachable::reset {t} {
139    # Remove marker, allow recalculation of reachability after
140    # changes.
141
142    $t unset root page::analysis::peg::reachable
143    $t unset root page::analysis::peg::unreachable
144    return
145}
146
147# ### ### ### ######### ######### #########
148## Ready
149
150package provide page::analysis::peg::reachable 0.1
151