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