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