util_norm_peg.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/* */
/*  Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
/*  Parser Generator / Transformation - Normalize PEG AST for later.*/

/*  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 treeql
package require page::util::quote

namespace ::page::util::norm::peg {
    /*  Get the peg char de/encoder commands.*/
    /*  (unquote, quote'tcl)*/

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

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

ret  ::page::util::norm::peg (type t) {
    set q [treeql q -tree $t]

    page_info {[PEG Normalization]}
    page_log_info ..Terminals   ; peg::Terminals   $q $t
    page_log_info ..Chains      ; peg::CutChains   $q $t
    page_log_info ..Metadata    ; peg::Metadata    $q $t
    page_log_info ..Definitions ; peg::Definitions $q $t
    page_log_info ..Expressions ; peg::Expressions $q $t

    # Sentinel for PE algorithms.
    $t set root symbol <StartExpression>
    $q destroy

    page_log_info Ok
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Documentation*/
/* */
/*  See doc_normalize.txt for the specification of the publicly visible*/
/*  attributes.*/
/** 
 *# Internal attributes
 *# - DATA - Transient storage for terminal data.
 */

/*  ### ### ### ######### ######### #########*/
/*  Internal. Helpers*/

ret  ::page::util::norm::peg::Terminals (type q , type t) {
    # The data for all terminals is stored in their grandparental
    # nodes. We get rid of both terminals and their parents.

    $q query tree withatt type terminal over n {
    set p  [$t parent $n]
    set gp [$t parent $p]

    CopyLocation $t $n $gp
    AttrCopy     $t $n detail $gp DATA
    TokReduce    $t           $gp DATA
    $t delete $p
    }

    # We can now drop the type attribute, as all the remaining nodes
    # (which have it) will contain the value 'nonterminal'.

    $q query tree hasatt type over n {
    $t unset $n type
    }
    return
}

ret  ::page::util::norm::peg::CutChains (type q , type t) {
    # All nodes which have exactly one child are irrelevant. We get
    # rid of them. The root node is the sole exception. The immediate
    # child of the root however is superfluous as well.

    $q query tree notq {root} over n {
    if {[llength [$t children $n]] != 1} continue
    $t cut $n
    }

    foreach n [$t children root] {$t cut $n}
    return
}

ret  ::page::util::norm::peg::Metadata (type q , type t) {
    # Having the name of the grammar in a tree node is overkill. We
    # move this information into an attribute of the root node.
    # The node keeping the start expression separate is irrelevant as
    # well. We get rid of it, and tag the root of the start expression
    # with a marker attribute.

    $q query tree withatt detail Header over n {
    set tmp    [Child $t $n 0]
    set sexpr  [Child $t $n 1]

    AttrCopy $t $tmp DATA root name
    $t cut $tmp
    $t cut $n
    break
    }

    # Remember the node for the start expression in the root for quick
    # access by later stages.

    $t set root start $sexpr
    return
}

ret  ::page::util::norm::peg::Definitions (type q , type t) {
    # We move nonterminal hint information from nodes into attributes,
    # and delete the now irrelevant nodes.

    # NOTE: This transformation is dependent on the removal of all
    # nodes with exactly one child, as it removes the all 'Attribute'
    # nodes already. Otherwise this transformation would have to put
    # the information into the grandparental node.

    # The default mode for nonterminals is 'value'.

    $q query tree withatt detail Definition over n {
    $t set $n mode value
    }

    foreach {a mode} {
    VOID  discard
    MATCH match
    LEAF  leaf
    } {
    $q query tree withatt detail $a over n {
        set p [$t parent $n]
        $t set $p mode $mode
        $t delete $n
    }
    }

    # Like with the global metadata we move definition specific
    # information out of nodes into attributes, get rid of the
    # superfluous nodes, and tag the definition roots with marker
    # attributes.

    set defs {}
    $q query tree withatt detail Definition over n {
    # Define mode information for all nonterminals without an
    # explicit specification. We also save the mode information
    # from deletion when we redo the definition node.

    set first [Child $t $n 0]

    set sym [$t get $first DATA]
    $t set $n symbol $sym
    $t set $n label  $sym
    $t set $n users  {}

    # Now determine the range in the input covered by the
    # definition. The left extent comes from the terminal for the
    # nonterminal symbol it defines. The right extent comes from
    # the rightmost child under the definition. While this not an
    # expression tree yet the location data is sound already.

    MergeLocations $t $first [Rightmost $t $n] $n
    $t unset $n detail

    lappend defs $sym $n
    $t cut $first
    }

    # We remember a mapping from nonterminal names to their defining
    # nodes in the root as well, for quick reference later, when we
    # build nonterminal usage references

    $t set root definitions $defs
    return
}

ret  ::page::util::norm::peg::Rightmost (type t , type n) {
    # Determine the rightmost leaf under the specified node.

    if {[$t isleaf $n]} {return $n}
    return [Rightmost $t [lindex [$t children $n] end]]
}

ret  ::page::util::norm::peg::Expressions (type q , type t) {
    # We now transform the remaining nodes into proper expression
    # trees. The order matters, to shed as much nodes as possible
    # early, and to avoid unncessary work.

    ExprRanges       $q $t
    ExprUnaryOps     $q $t
    ExprChars        $q $t
    ExprNonterminals $q $t
    ExprOperators    $q $t
    ExprFlatten      $q $t
    return
}

ret  ::page::util::norm::peg::ExprRanges (type q , type t) {
    # Ranges = .. operator

    $q query tree withatt detail Range over n {
    # Two the children, both of text 'Char', their data is what we
    # take. The children become irrelevant and are removed.

    foreach {b e} [$t children $n] break
    set begin [unquote [$t get $b DATA]]
    set end   [unquote [$t get $e DATA]]

    $t set $n op ..
    $t set $n begin $begin
    $t set $n end   $end

    MergeLocations $t $b $e $n

    $t unset $n detail

    $t delete $b
    $t delete $e
    }
    return
}

ret  ::page::util::norm::peg::ExprUnaryOps (type q , type t) {
    # Unary operators ... Their transformation sheds more nodes.

    foreach {a op} {
    QUESTION ?
    STAR     *
    PLUS     +
    AND      &
    NOT      !
    } {
    $q query tree withatt detail $a over n {
        set p [$t parent $n]

        $t set $p op $op
        $t cut $n

        $t unset $p detail
    }
    }
    return
}

ret  ::page::util::norm::peg::ExprChars (type q , type t) {
    # Chars = t operator (The remaining Char'acters are plain terminal
    # symbols.

    $q query tree withatt detail Char over n {
    set ch [unquote [$t get $n DATA]]

    $t set $n op   t
    $t set $n char $ch

    $t unset $n detail
    $t unset $n DATA
    }
    return
}

ret  ::page::util::norm::peg::ExprNonterminals (type q , type t) {
    # Identifiers = n operator (nonterminal references) ...

    array set defs [$t get root definitions]
    array set undefined {}

    $q query tree withatt detail Identifier over n {
    set sym [$t get $n DATA]

    $t set $n op  n
    $t set $n sym $sym

    $t unset $n detail
    $t unset $n DATA

    # Create x-references between the users and the definition of
    # a nonterminal symbol.

    if {![info exists defs($sym)]} {
        $t set $n def {}
        lappend undefined($sym) $n
        continue
    } else {
        set def $defs($sym)
        $t set $n def $def
    }

    set users [$t get $def users]
    lappend users $n
    $t set $def users $users
    }

    $t set root undefined [array get undefined]
    return
}

ret  ::page::util::norm::peg::ExprOperators (type q , type t) {
    # The remaining operator nodes can be changed directly from node
    # text to operator. Se we do.

    foreach {a op} {
    EPSILON    epsilon
    ALNUM      alnum
    ALPHA      alpha
    DOT        dot
    Literal    x
    Class      /
    Sequence   x
    Expression /
    } {
    $q query tree withatt detail $a over n {
        $t set   $n op $op
        $t unset $n detail
    }
    }
    return
}

ret  ::page::util::norm::peg::ExprFlatten (type q , type t) {
    # Last tweaks of the expressions. Classes inside of Expressions,
    # and Literals in Sequences create nested / or x expressions. We
    # locate such and flatten the nested expression, cutting out the
    # superfluous operator.

    foreach op {x /} {
    # Locate all x operators, whose parents are x operators 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
    }

    # Locate all x operators without children and convert them
    # into epsilon operators. Because that is what they accept,
    # nothing.

    $q query tree withatt op $op over n {
        if {[$t numchildren $n]} continue
        $t set $n op epsilon
    }
    }
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Internal. Low-level helpers.*/

ret  ::page::util::norm::peg::CopyLocation (type t , type src , type dst) {
    $t set $dst range    [$t get $src range]
    $t set $dst range_lc [$t get $src range_lc]
    return
}

ret  ::page::util::norm::peg::MergeLocations (type t , type srca , type srcb , type dst) {
    set ar   [$t get $srca range]
    set arlc [$t get $srca range_lc]

    set br   [$t get $srcb range]
    set brlc [$t get $srcb range_lc]

    $t set $dst range    [list [lindex $ar   0] [lindex $br   1]]
    $t set $dst range_lc [list [lindex $arlc 0] [lindex $brlc 1]]
    return
}

ret  ::page::util::norm::peg::TokReduce (type t , type src , type attr) {
    set tokens [$t get $src $attr]
    set ch     {}
    foreach tok $tokens {
    lappend ch [lindex $tok 0]
    }
    $t set $src $attr [join $ch {}]
    return
}

ret  ::page::util::norm::peg::AttrCopy (type t , type src , type asrc , type dst , type adst) {
    $t set $dst $adst [$t get $src $asrc]
    return
}

ret  ::page::util::norm::peg::Child (type t , type n , type index) {
    return [lindex [$t children $n] $index]
}

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

package provide page::util::norm::peg 0.1