util_peg.tcl

Go to the documentation of this file.

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

/*  This package provides a number of utility commands to*/
/*  transformations for common operations. It assumes a 'Normalized PE*/
/*  Grammar Tree' as input, possibly augmented with attributes coming*/
/*  from transformation not in conflict with the base definition.*/

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

package require page::util::quote

namespace ::page::util::peg {
    namespace export \
        symbolOf symbolNodeOf \
        updateUndefinedDueRemoval \
        flatten peOf printTclExpr \
        getWarnings printWarnings

    /*  Get the peg char de/encoder commands.*/
    /*  (unquote, quote'tcl).*/

    namespace import ::page::util::quote::*
}

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

ret  ::page::util::peg::symbolNodeOf (type t , type n) {
    # Given an arbitrary root it determines the node (itself or an
    # ancestor) containing the name of the nonterminal symbol the node
    # belongs to, and returns its id. The result is either the root of
    # the tree (for the start expression), or a definition mode.

    while {![$t keyexists $n symbol]} {
    set n [$t parent $n]
    }
    return $n
}

ret  ::page::util::peg::symbolOf (type t , type n) {
    # As above, but returns the symbol name.

    return [$t get [symbolNodeOf $t $n] symbol]
}

ret  ::page::util::peg::updateUndefinedDueRemoval (type t) {
    # The removal of nodes may have caused symbols to lose one or more
    # users. Example: A used by B and C, B is reachable, C is not, so A
    # now loses a node in the expression for C calling it, or rather
    # not anymore.

    foreach {sym def} [$t get root definitions] {
    set res {}
    foreach u [$t get $def users] {
        if {![$t exists $u]} continue
        lappend res $u
    }
    $t set $def users $res
    }

    # Update the knowledge of undefined nonterminals. To be used when
    # a transformation can remove invokations of undefined symbols,
    # and is not able to generate such invokations.

    set res {}
    foreach {sym invokers} [$t get root undefined] {
    set sres {}
    foreach n $invokers {
        if {![$t exists $n]} continue
        lappend sres $n
    }
    if {[llength $sres]} {
        lappend res $sym $sres
    }
    }
    $t set root undefined $res
    return
}

ret  ::page::util::peg::flatten (type q , type t) {
    # Flatten nested x-, or /-operators.
    # See peg_normalize.tcl, peg::normalize::ExprFlatten

    foreach op {x /} {
    # Locate all x operators, whose parents are x oerators as
    # well, then go back to the child operators and cut them out.

    $q query \
        tree          withatt op $op \
        parent unique withatt op $op \
        children      withatt op $op \
        over n {
        $t cut $n
    }
    }
    return
}

ret  ::page::util::peg::getWarnings (type t) {
    # Look at the attributes for problems with the grammar and issue
    # warnings. They do not prevent us from writing the grammar, but
    # still represent problems with it the user should be made aware
    # of.

    array set msg {}
    array set undefined [$t get root undefined]
    foreach sym [array names undefined] {
    set msg($sym) {}
    foreach ref $undefined($sym) {
        lappend msg($sym) "Undefined symbol used by the definition of '[symbolOf $t $ref]'."
    }
    }

    foreach {sym def} [$t get root definitions] {
    if {[llength [$t get $def users]] == 0} {
        set msg($sym) [list "This symbol has been defined, but is not used."]
    }
    }

    return [array get msg]
}

ret  ::page::util::peg::printWarnings (type msg) {
    if {![llength $msg]} return

    set dict {}
    set max -1
    foreach {k v} $msg {
    set l [string length [list $k]]
    if {$l > $max} {set max $l}
    lappend dict [list $k $v $l]
    }

    foreach e [lsort -dict -index 0 $dict] {
    foreach {k msgs l} $e break

    set off [string repeat " " [expr {$max - $l}]]
    page_info "[list $k]$off : [lindex $msgs 0]"

    if {[llength $msgs] > 1} {
        set indent [string repeat " " [string length [list $k]]]
        foreach m [lrange $msgs 1 end] {
        puts stderr "  $indent$off : $m"
        }
    }
    }
    return
}

ret  ::page::util::peg::peOf (type t , type eroot) {
    set op [$t get $eroot op]
    set pe [list $op]

    set ch [$t children $eroot]

    if {[llength $ch]} {
    foreach c $ch {
        lappend pe [peOf $t $c]
    }
    } elseif {$op eq "n"} {
    lappend pe [$t get $eroot sym]
    } elseif {$op eq "t"} {
    lappend pe [unquote [$t get $eroot char]]
    } elseif {$op eq ".."} {
    lappend pe \
        [unquote [$t get $eroot begin]] \
        [unquote [$t get $eroot end]]

    }
    return $pe
}

ret  ::page::util::peg::printTclExpr (type pe) {
    list [PrintExprSub $pe]
}

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

ret  ::page::util::peg::PrintExprSub (type pe) {
    set op   [lindex $pe 0]
    set args [lrange $pe 1 end]

    #puts stderr "PE [llength $args] $op | $args"

    if {$op eq "t"} {
    set a [lindex $args 0]
    return "$op [quote'tcl $a]"
    } elseif {$op eq ".."} {
    set a [lindex $args 0]
    set b [lindex $args 1]
    return "$op [quote'tcl $a] [quote'tcl $b]"
    } elseif {$op eq "n"} {
    return $pe
    } else {
    set res $op
    foreach a $args {
        lappend res [PrintExprSub $a]
    }
    return $res
    }
}

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

package provide page::util::peg 0.1