1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3
4# Perform realizability analysis (x) on the PE grammar delivered by
5# the frontend. The grammar is in normalized form (reduced to
6# essentials, graph like node-x-references, expression trees).
7#
8# (x) = See "doc_realizable.txt".
9
10# This package assumes to be used from within a PAGE plugin. It uses
11# the API commands listed below. These are identical across the major
12# types of PAGE plugins, allowing this package to be used in reader,
13# transform, and writer plugins. It cannot be used in a configuration
14# plugin, and this makes no sense either.
15#
16# To ensure that our assumption is ok we require the relevant pseudo
17# package setup by the PAGE plugin management code.
18#
19# -----------------+--
20# page_info        | Reporting to the user.
21# page_warning     |
22# page_error       |
23# -----------------+--
24# page_log_error   | Reporting of internals.
25# page_log_warning |
26# page_log_info    |
27# -----------------+--
28
29# ### ### ### ######### ######### #########
30## Requisites
31
32# @mdgen NODEP: page::plugin
33
34package require page::plugin     ; # S.a. pseudo-package.
35package require page::util::flow ; # Dataflow walking.
36package require page::util::peg  ; # General utilities.
37package require treeql
38
39namespace eval ::page::analysis::peg::realizable {
40    namespace import ::page::util::peg::*
41}
42
43# ### ### ### ######### ######### #########
44## API
45
46proc ::page::analysis::peg::realizable::compute {t} {
47
48    # Ignore call if already done before
49
50    if {[$t keyexists root page::analysis::peg::realizable]} return
51
52    # We compute the set of realizable nonterminal symbols by doing the
53    # computation for all partial PE's in the grammar. We start at the
54    # leaves and then iteratively propagate the property as far as
55    # possible using the rules defining it, see the specification.
56
57    # --- --- --- --------- --------- ---------
58
59    # Initialize all nodes and the local arrays. Everything is not
60    # realizable, except for the terminal leafs of the tree. Their parents
61    # are scheduled to be visited as well.
62
63    array set realizable   {} ; # Place where realizable nodes are held
64    array set unrealizable {} ; # Place where unrealizable nodes are held
65    array set nc           {} ; # Per node, number of children.
66    array set uc           {} ; # Per node, number of realizable children.
67
68    set nodeset [$t leaves]
69
70    set q [treeql q -tree $t]
71    $q query tree withatt op * over n {lappend nodeset $n}
72    $q query tree withatt op ? over n {lappend nodeset $n}
73    q destroy
74
75    foreach n [$t nodes] {
76	set unrealizable($n) .
77	set nc($n)       [$t numchildren $n]
78	set uc($n)       0
79    }
80
81    # A node is visited if it _may_ have changed its status (to
82    # realizability).
83
84    page::util::flow $nodeset flow n {
85	# Realizable nodes cannot change, ignore them.
86
87	if {[info exists realizable($n)]} continue
88
89	# Determine new state of realizability, ignore a node if it is
90	# unchanged.
91
92	if {![Realizable $t $n nc uc realizable]} continue
93
94	# Reclassify changed node, it is now realizable.
95	unset unrealizable($n)
96	set   realizable($n) .
97
98	# Schedule visits to nodes which may have been affected by
99	# this change. Update the relevant counters as well.
100
101	# @ root       - none
102	# @ definition - users of the definition
103	# otherwise    - parent of operator.
104
105	if {$n eq "root"} continue
106
107	if {[$t keyexists $n symbol]} {
108	    set users [$t get $n users]
109	    $flow visitl $users
110	    foreach u $users {
111		incr uc($u)
112	    }
113	    continue
114	}
115
116	set p [$t parent $n]
117	incr uc($p)
118	$flow visit $p
119    }
120
121    # Set marker preventing future calls.
122    $t set root page::analysis::peg::realizable   [array names realizable]
123    $t set root page::analysis::peg::unrealizable [array names unrealizable]
124    return
125}
126
127proc ::page::analysis::peg::realizable::remove! {t} {
128    # Determine which parts of the grammar are realizable
129
130    compute $t
131
132    # Remove anything which is not realizable (and all their children),
133    # except for the root itself, should it be unrealizablel.
134
135    set unreal [$t get root page::analysis::peg::unrealizable]
136    foreach n [lsort $unreal] {
137	if {$n eq "root"} continue
138	if {[$t exists $n]} {
139	    $t delete $n
140	}
141    }
142
143    # Notify the user of the definitions which were among the removed
144    # nodes. Keep only the still-existing definitions.
145
146    set res {}
147    foreach {sym def} [$t get root definitions] {
148	if {![$t exists $def]} {
149	    page_warning "  $sym: Nonterminal symbol is not realizable, removed."
150	} else {
151	    lappend res $sym $def
152	}
153    }
154    $t set root definitions $res
155
156    if {![$t exists [$t get root start]]} {
157	page_warning "  <Start expression>: Is not realizable, removed."
158	$t set root start {}
159    }
160
161    # Find and cut operator chains, very restricted. Cut only chains
162    # of x- and /-operators. The other operators have only one child
163    # by definition and are thus not chains.
164
165    set q [treeql q -tree $t]
166    # q query tree over n
167    foreach n [$t children -all root] {
168	if {[$t keyexists $n symbol]}        continue
169	if {[llength [$t children $n]] != 1} continue
170	set op [$t get $n op]
171	if {($op ne "/") && ($op ne "x")} continue
172	$t cut $n
173    }
174
175    flatten $q $t
176    q destroy
177
178    # Clear computation results.
179
180    $t unset root page::analysis::peg::realizable
181    $t unset root page::analysis::peg::unrealizable
182
183    updateUndefinedDueRemoval $t
184    return
185}
186
187proc ::page::analysis::peg::realizable::reset {t} {
188    # Remove marker, allow recalculation of realizability after changes.
189
190    $t unset root page::analysis::peg::realizable
191    return
192}
193
194# ### ### ### ######### ######### #########
195## Internal
196
197proc ::page::analysis::peg::realizable::First {v} {
198    upvar 1 $v visit
199
200    set id    [array startsearch visit]
201    set first [array nextelement visit $id]
202    array donesearch visit $id
203
204    unset visit($first)
205    return $first
206}
207
208proc ::page::analysis::peg::realizable::Realizable {t node ncv ucv uv} {
209    upvar 1 $ncv nc $ucv uc $uv realizable
210
211    if {$node eq "root"} {
212	# Root inherits realizability of the start expression.
213
214	return [info exists realizable([$t get root start])]
215    }
216
217    if {[$t keyexists $node symbol]} {
218	# Symbol definitions inherit the realizability of their
219	# expression.
220
221	return [expr {$uc($node) >= $nc($node)}]
222    }
223
224    switch -exact -- [$t get $node op] {
225	t - .. - epsilon - alpha - alnum - dot - * - ? {
226	    # The terminal symbols are all realizable.
227	    return 1
228	}
229	n {
230	    # Symbol invokation inherits realizability of its definition.
231	    # Calls to undefined symbols are not realizable.
232
233	    set def [$t get $node def]
234	    if {$def eq ""} {return 0}
235	    return [info exists realizable($def)]
236	}
237	/ - | {
238	    # Choice, ordered and unordered. Realizable if we have at
239	    # least one realizable branch. A quick test based on the count
240	    # of realizable children is used.
241
242	    return [expr {$uc($node) > 0}]
243	}
244	default {
245	    # Sequence, and all other operators, are realizable if and
246	    # only if all its children are realizable. A quick test based
247	    # on the count of realizable children is used.
248
249	    return [expr {$uc($node) >= $nc($node)}]
250	}
251    }
252}
253
254# ### ### ### ######### ######### #########
255## Ready
256
257package provide page::analysis::peg::realizable 0.1
258