diff options
Diffstat (limited to 'tcllib/modules/page/analysis_peg_realizable.tcl')
| -rw-r--r-- | tcllib/modules/page/analysis_peg_realizable.tcl | 257 |
1 files changed, 257 insertions, 0 deletions
diff --git a/tcllib/modules/page/analysis_peg_realizable.tcl b/tcllib/modules/page/analysis_peg_realizable.tcl new file mode 100644 index 0000000..ef32a68 --- /dev/null +++ b/tcllib/modules/page/analysis_peg_realizable.tcl @@ -0,0 +1,257 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### + +# Perform realizability analysis (x) on the PE grammar delivered by +# the frontend. The grammar is in normalized form (reduced to +# essentials, graph like node-x-references, expression trees). +# +# (x) = See "doc_realizable.txt". + +# 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. +package require treeql + +namespace eval ::page::analysis::peg::realizable { + namespace import ::page::util::peg::* +} + +# ### ### ### ######### ######### ######### +## API + +proc ::page::analysis::peg::realizable::compute {t} { + + # Ignore call if already done before + + if {[$t keyexists root page::analysis::peg::realizable]} return + + # We compute the set of realizable nonterminal symbols by doing the + # computation for all partial PE's in the grammar. We start at the + # leaves and then iteratively propagate the property as far as + # possible using the rules defining it, see the specification. + + # --- --- --- --------- --------- --------- + + # Initialize all nodes and the local arrays. Everything is not + # realizable, except for the terminal leafs of the tree. Their parents + # are scheduled to be visited as well. + + array set realizable {} ; # Place where realizable nodes are held + array set unrealizable {} ; # Place where unrealizable nodes are held + array set nc {} ; # Per node, number of children. + array set uc {} ; # Per node, number of realizable children. + + set nodeset [$t leaves] + + set q [treeql q -tree $t] + $q query tree withatt op * over n {lappend nodeset $n} + $q query tree withatt op ? over n {lappend nodeset $n} + q destroy + + foreach n [$t nodes] { + set unrealizable($n) . + set nc($n) [$t numchildren $n] + set uc($n) 0 + } + + # A node is visited if it _may_ have changed its status (to + # realizability). + + page::util::flow $nodeset flow n { + # Realizable nodes cannot change, ignore them. + + if {[info exists realizable($n)]} continue + + # Determine new state of realizability, ignore a node if it is + # unchanged. + + if {![Realizable $t $n nc uc realizable]} continue + + # Reclassify changed node, it is now realizable. + unset unrealizable($n) + set realizable($n) . + + # Schedule visits to nodes which may have been affected by + # this change. Update the relevant counters as well. + + # @ root - none + # @ definition - users of the definition + # otherwise - parent of operator. + + if {$n eq "root"} continue + + if {[$t keyexists $n symbol]} { + set users [$t get $n users] + $flow visitl $users + foreach u $users { + incr uc($u) + } + continue + } + + set p [$t parent $n] + incr uc($p) + $flow visit $p + } + + # Set marker preventing future calls. + $t set root page::analysis::peg::realizable [array names realizable] + $t set root page::analysis::peg::unrealizable [array names unrealizable] + return +} + +proc ::page::analysis::peg::realizable::remove! {t} { + # Determine which parts of the grammar are realizable + + compute $t + + # Remove anything which is not realizable (and all their children), + # except for the root itself, should it be unrealizablel. + + set unreal [$t get root page::analysis::peg::unrealizable] + foreach n [lsort $unreal] { + if {$n eq "root"} continue + 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: Nonterminal symbol is not realizable, removed." + } else { + lappend res $sym $def + } + } + $t set root definitions $res + + if {![$t exists [$t get root start]]} { + page_warning " <Start expression>: Is not realizable, removed." + $t set root start {} + } + + # Find and cut operator chains, very restricted. Cut only chains + # of x- and /-operators. The other operators have only one child + # by definition and are thus not chains. + + set q [treeql q -tree $t] + # q query tree over n + foreach n [$t children -all root] { + if {[$t keyexists $n symbol]} continue + if {[llength [$t children $n]] != 1} continue + set op [$t get $n op] + if {($op ne "/") && ($op ne "x")} continue + $t cut $n + } + + flatten $q $t + q destroy + + # Clear computation results. + + $t unset root page::analysis::peg::realizable + $t unset root page::analysis::peg::unrealizable + + updateUndefinedDueRemoval $t + return +} + +proc ::page::analysis::peg::realizable::reset {t} { + # Remove marker, allow recalculation of realizability after changes. + + $t unset root page::analysis::peg::realizable + return +} + +# ### ### ### ######### ######### ######### +## Internal + +proc ::page::analysis::peg::realizable::First {v} { + upvar 1 $v visit + + set id [array startsearch visit] + set first [array nextelement visit $id] + array donesearch visit $id + + unset visit($first) + return $first +} + +proc ::page::analysis::peg::realizable::Realizable {t node ncv ucv uv} { + upvar 1 $ncv nc $ucv uc $uv realizable + + if {$node eq "root"} { + # Root inherits realizability of the start expression. + + return [info exists realizable([$t get root start])] + } + + if {[$t keyexists $node symbol]} { + # Symbol definitions inherit the realizability of their + # expression. + + return [expr {$uc($node) >= $nc($node)}] + } + + switch -exact -- [$t get $node op] { + t - .. - epsilon - alpha - alnum - dot - * - ? { + # The terminal symbols are all realizable. + return 1 + } + n { + # Symbol invokation inherits realizability of its definition. + # Calls to undefined symbols are not realizable. + + set def [$t get $node def] + if {$def eq ""} {return 0} + return [info exists realizable($def)] + } + / - | { + # Choice, ordered and unordered. Realizable if we have at + # least one realizable branch. A quick test based on the count + # of realizable children is used. + + return [expr {$uc($node) > 0}] + } + default { + # Sequence, and all other operators, are realizable if and + # only if all its children are realizable. A quick test based + # on the count of realizable children is used. + + return [expr {$uc($node) >= $nc($node)}] + } + } +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide page::analysis::peg::realizable 0.1 |