analysis_peg_emodes.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  ### ### ### ######### ######### #########*/

/*  Perform mode analysis (x) on the PE grammar delivered by the*/
/*  frontend. The grammar is in normalized form (*).*/
/* */
/*  (x) = See "doc_emodes.txt".*/
/*        and "doc_emodes_alg.txt".*/
/*  (*) = See "doc_normalize.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 ::page::analysis::peg::emodes {
    namespace import ::page::util::peg::*
}

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

ret  ::page::analysis::peg::emodes::compute (type t) {

    # Ignore call if already done before
    if {[$t keyexists root page::analysis::peg::emodes]} {return 1}

    # We do not actually compute per node a mode, but rather their
    # gen'erate and acc'eptance properties, as described in
    # "doc_emodes.txt".

    # Note: This implementation will not compute acc/gen information
    # for unreachable nodes.

    # --- --- --- --------- --------- ---------

    array set acc  {} ; # Per node X, acc(X), undefined if no element
    array set call {} ; # Per definition node, number of users
    array set cala {} ; # Per definition node, number of (non-)accepting users

    foreach {sym def} [$t get root definitions] {
    set call($def)   [llength [$t get $def users]]
    set cala(0,$def) 0
    set cala(1,$def) 0
    }

    set acc(root) 1 ; # Sentinel for root of start expression.

    # --- --- --- --------- --------- ---------

    #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
    #puts stderr Node\tAcc\tNew\tWhat\tOp
    #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~

    # A node is visited if its value for acc() is either undefined or
    # may have changed. Basic flow is top down, from the start
    # expression and a definition a child of its invokers.

    set gstart [$t get root start]
    if {$gstart eq ""} {
    page_error "  No start expression, unable to compute accept/generate properties"
    return 0
    }

    page::util::flow [list $gstart] flow n {
    # Determine first or new value.

    #puts -nonewline stderr [string replace $n 1 3]

    if {![info exists acc($n)]} {
        set a [Accepting $t $n acc call cala]
        set acc($n) $a
        set change 0

        #puts -nonewline stderr \t-\t$a\t^
    } else {
        set a   [Accepting $t $n acc call cala]
        set old $acc($n)
        if {$a == $old} {
        #puts stderr \t$old\t$a\t\ =
        continue
        }
        set change 1
        set acc($n) $a

        #puts -nonewline stderr \t$old\t$a\t\ \ *
    }

    # Update counters in definitions, if the node invokes them.
    # Also, schedule the children for their (re)definition.

    if {[$t keyexists $n symbol]} {
        #puts -nonewline stderr \t\ DEF\t[$t get $n symbol]\t[$t get $n mode]
    } else {
        #puts -nonewline stderr \t[$t get $n op]\t\t
    }

    if {[$t keyexists $n op] && ([$t get $n op] eq "n")} {
        #puts -nonewline stderr ->\ [$t get $n sym]
        set def [$t get $n def]
        if {$def eq ""} continue

        if {$change} {
        incr cala($old,$def) -1
        }
        incr cala($a,$def)
        $flow visit $def

        #puts -nonewline stderr @$def\t(0a$cala(0,$def),\ 1a$cala(1,$def),\ #$call($def))\tv($def)
        #puts stderr ""
        continue
    }

    #puts stderr \t\t\t\tv([$t children $n])
    $flow visitl [$t children $n]
    }

    # --- --- --- --------- --------- ---------

    array set gen {} ; # Per node X, gen(X), undefined if no element
    array set nc  {} ; # Per node, number of children
    array set ng  {} ; # Per node, number of (non-)generating children

    foreach n [$t nodes] {
    set nc($n)       [$t numchildren $n]
    set ng(0,$n)     0
    set ng(1,$n)     0
    }

    # --- --- --- --------- --------- ---------

    #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
    #puts stderr Node\tGen\tNew\tWhat\tOp
    #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~

    # A node is visited if its value for gen() is either undefined or
    # may have changed. Basic flow is bottom up, from the all
    # leaves (and lookahead operators). Users of a definition are
    # considered as its parents.

    set start [$t leaves]
    set q [treeql q -tree $t]
    q query tree withatt op ! over n {lappend start $n}
    q query tree withatt op & over n {lappend start $n}
    q destroy

    page::util::flow $start flow n {
    # Ignore root.

    if {$n eq "root"} continue

    #puts -nonewline stderr [string replace $n 1 3]

    # Determine first or new value.

    if {![info exists gen($n)]} {
        set g [Generating $t $n gen nc ng acc call cala]
        set gen($n) $g

        #puts -nonewline stderr \t-\t$g\t^

    } else {
        set g   [Generating $t $n gen nc ng acc call cala]
        set old $gen($n)
        if {$g eq $old} {
        #puts stderr \t$old\t$g\t\ =
        continue
        }
        set gen($n) $g

        #puts -nonewline stderr \t$old\t$g\t\ \ *
    }

    if {($g ne "maybe") && !$g && $acc($n)} {
        # No generate here implies that none of our children will
        # generate anything either. So the current acceptance of
        # these non-existing values can be safely forced to
        # non-acceptance.

        set acc($n) 0
        #puts -nonewline stderr "-a"
    }

    if {0} {
        if {[$t keyexists $n symbol]} {
        #puts -nonewline stderr \t\ DEF\t[$t get $n symbol]\t[$t get $n mode]
        } else {
        #puts -nonewline stderr \t[$t get $n op]\t\t
        }
    }

    #puts -nonewline stderr \t(0g$ng(0,$n),1g$ng(1,$n),\ #$nc($n))

    # Update counters in the (virtual) parents, and schedule them
    # for a visit.

    if {[$t keyexists $n symbol]} {
        # Users are virtual parents.

        set users  [$t get $n users]
        $flow visitl $users

        if {$g ne "maybe"} {
        foreach u $users {incr ng($g,$u)}
        }
        #puts stderr \tv($users)
        continue
    }

    set p [$t parent $n]
    $flow visit $p
    if {$g ne "maybe"} {
        incr ng($g,$p)
    }

    #puts stderr \tv($p)
    }

    # --- --- --- --------- --------- ---------

    # Copy the calculated data over into the tree.
    # Note: There will be no data for unreachable nodes.

    foreach n [$t nodes] {
    if {$n eq "root"}           continue
    if {![info exists acc($n)]} continue
    $t set $n acc $acc($n)
    $t set $n gen $gen($n)
    }

    # Recompute the modes based on the current
    # acc/gen status of the definitions.

    #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~
    #puts stderr Node\tSym\tMode\tNew\tGen\tAcc
    #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~

    foreach {sym def} [$t get root definitions] {
    set m {}

    set old [$t get $def mode]

    if {[info exists acc($def)]} {
        switch -exact -- $gen($def)/$acc($def) {
        0/0     {set m discard}
        0/1     {error "Bad gen/acc for $sym"}
        1/0     {# don't touch (match, leaf)}
        1/1     {set m value}
        maybe/0 {error "Bad gen/acc for $sym"}
        maybe/1 {set m value}
        }
        if {$m ne ""} {
        # Should check correctness of change, if any (We can drop
        # to discard, nothing else).
        $t set $def mode $m
        }
        #puts stderr [string replace $def 1 3]\t$sym\t$old\t[$t get $def mode]\t[$t get $def gen]\t[$t get $def acc]
    } else {
        #puts stderr [string replace $def 1 3]\t$sym\t$old\t\t\t\tNOT_REACHED
    }
    }

    #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~

    # Wrap up the whole state and save it in the tree. No need to
    # throw this away, useful for other mode based transforms and
    # easier to get in this way than walking the tree again.

    $t set root page::analysis::peg::emodes [list \
        [array get acc] \
        [array get call] \
        [array get cala] \
        [array get gen] \
        [array get nc] \
        [array get ng]]
    return 1
}

ret  ::page::analysis::peg::emodes::reset (type t) {
    # Remove marker, allow recalculation of emodesness after changes.

    $t unset root page::analysis::peg::emodes
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Internal*/

ret  ::page::analysis::peg::emodes::Accepting (type t , type n , type av , type cv , type cav) {
    upvar 1 $av acc $cv call $cav cala

    # Definitions accept based on how they are called first, and on
    # their mode if that is not possible.

    if {[$t keyexists $n symbol]} {
    # Call based acceptance.
    # !acc if all callers do not accept.

    if {$cala(0,$n) >= $call($n)} {
        return 0
    }

    # Falling back to mode specific accptance
    return [expr {([$t get $n mode] eq "value") ? 1 : 0}]
    }

    set op [$t get $n op]

    # Lookahead operators will never accept.

    if {($op eq "!") || ($op eq "&")} {
    return 0
    }

    # All other operators inherit the acceptance
    # of their parent.

    return $acc([$t parent $n])
}

ret  ::page::analysis::peg::emodes::Generating (type t , type n , type gv , type ncv , type ngv , type av , type cv , type cav) {
    upvar 1 $gv gen $ncv nc $ngv ng $av acc $cv call $cav cala
    #           ~~~      ~~      ~~     ~~~     ~~~~      ~~~~

    # Definitions generate based on their mode, their defining
    # expression, and the acceptance of their callers.

    if {[$t keyexists $n symbol]} {

    # If no caller accepts a value, then this definition will not
    # generate one, even if its own mode asked it to do so.

    if {$cala(0,$n) >= $call($n)} {
        return 0
    }

    # The definition has callers accepting values and callres not
    # doing so. It will generate as per its own mode and defining
    # expression.

    # The special modes know if they generate a value or not.
    # The pass through mode looks at the expression for the
    # information.

    switch -exact -- [$t get $n mode] {
        value   {return $gen([lindex [$t children $n] 0])}
        match   {return 1}
        leaf    {return 1}
        discard {return 0}
    }
    error PANIC
    }

    set op [$t get $n op]

    # Inner nodes generate based on operator and children.

    if {$nc($n)} {
    switch -exact -- $op {
        ! - & {return 0}
        ? - * {
        # No for all children --> no
        # Otherwise           --> maybe

        if {$ng(0,$n) >= $nc($n)} {
            return 0
        } else {
            return maybe
        }
        }
        + - / - | {
        # Yes for all children --> yes
        # No for all children  --> no
        # Otherwise            --> maybe

        if {$ng(1,$n) >= $nc($n)} {
            return 1
        } elseif {$ng(0,$n) >= $nc($n)} {
            return 0
        } else {
            return maybe
        }
        }
        x {
        # Yes for some children --> yes
        # No for all children   --> no
        # Otherwise             --> maybe

        if {$ng(1,$n) > 0} {
            return 1
        } elseif {$ng(0,$n) >= $nc($n)} {
            return 0
        } else {
            return maybe
        }
        }
    }
    error PANIC
    }

    # Nonterminal leaves generate based on acceptance from their
    # parent and the referenced definition.

    # As acc(X) == acc(parent(X)) the test doesn't have to go to the
    # parent itself.

    if {$op eq "n"} {
    if {[info exists acc($n)] && !$acc($n)} {return 0}

    set def [$t get $n def]

    # Undefine symbols do not generate anything.
    if {$def eq ""} {return 0}

    # Inherit directly from the definition, if existing.
    if {![info exists gen($def)]} {
        return maybe
    }

    return $gen($def)
    }

    # Terminal leaves generate values if and only if such values are
    # accepted by their parent. As acc(X) == acc(parent(X) the test
    # doesn't have to go to the parent itself.


    return $acc($n)
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/

package provide page::analysis::peg::emodes 0.1