analysis_peg_reachable.tcl

Go to the documentation of this file.

/*  -*- 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 ::page::analysis::peg::reachable {
    namespace import ::page::util::peg::*
}

/*  ### ### ### ######### ######### #########*/
/*  API*/

ret  ::page::analysis::peg::reachable::compute (type 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
}

ret  ::page::analysis::peg::reachable::remove! (type 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
}

ret  ::page::analysis::peg::reachable::reset (type 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