Updated 2012-09-14 00:50:33 by RLE

See Operator precedence expression parser, example
# This code is an operator precedence parser which uses an operator table and a variation 
 # on the shunting yard parser algorithm to convert an infix expression to a series of 
 # prefix operator callbacks.
 #
 #
 namespace eval expression {
    # This is the operator precedence table for C++.  The dot operator is effectively
    # commented out by "renaming" it ".###".  The lexical "analyser" is too primitive 
    # to distinguish floating point numbers and a real . operator usage.
    #
    # The conditional, "?:" and sequence operator, "," are missing.
    #
    # precedence values are spaced out by multiplying the nominal
    # C++ precedence by 10.  This should allow applications to add other
    # operators as needed at any preceduce (???) required.
    #
    # The unary * has been changes to nulary to support tna
    #
    # The index [] operator is nary and treated similarly to a function call to "indx" instead
    # of "call".
    #
    # dolar "$" is added for eventual support of tcl variables in tna.
    #
    set optable {
        ::        {   10                 2        left        name   }
        ++        {   20                 1        left        inc    }
        --        {   20                 1        left        dec    }
      .###        {   20                 2        left        dot    }
        ->        {   20                 2        left        arrow  }
       ++u        {   30                 1        right       uinc   }
       --u        {   30                 1        right       udec   }
        -u        {   30                 1        right       usub   }
        +u        {   30                 1        right       uadd   }
        *u        {   30                 0        right       deref  }
        $u        {   30                 1        right       dolar  }
        &u        {   30                 1        right       refer  }
         *        {   50                 2        left        mul    }
         /        {   50                 2        left        div    }
         %        {   50                 2        left        mod    }
         +        {   60                 2        left        add    }
         -        {   60                 2        left        sub    }
        <<        {   70                 2        left        shl    }
        >>        {   70                 2        left        shr    }
         >        {   80                 2        left        gt     }
         <        {   80                 2        left        lt     }
        <=        {   80                 2        left        lte    }
        >=        {   80                 2        left        gte    }
        ==        {   90                 2        left        equ    }
        !=        {   90                 2        left        neq    }
         &        {  100                 2        left        band   }
         ^        {  110                 2        left        bxor   }
         |        {  120                 2        left        bor    }
        &&        {  130                 2        left        land   }
        ||        {  140                 2        left        lor    }
         ?        {  150                 2        right       hook   }
         =        {  160                 2        right       assign }
        +=        {  160                 2        right       addasn }
        -=        {  160                 2        right       subasn }
        *=        {  160                 2        right       mulasn }
        /=        {  160                 2        right       divasn }
        %=        {  160                 2        right       modasn }
       <<=        {  160                 2        right       shlasn }
       >>=        {  160                 2        right       shrasn }
        &=        {  160                 2        right       bndasn }
        ^=        {  160                 2        right       bxrasn }
        |=        {  160                 2        right       borasn }
         [        { 1000                 0        {}          indx   }
         ]        { 1000                 0        {}          none   }
         (        { 1000                 0        {}          call   }
         )        { 1000                 0        {}          none   }
         ,        { 1000                 0        {}          none   }
         ;        { 1000                 0        {}          semi   }
    }


    # A little helper to sort a precedence table in to a [string map] mapping that will be used
    # for "lexical analysis".
    #
    proc prep-tokens { tokens } {
        variable opers

        foreach token [dict keys $tokens] {
            set opers([lindex [dict get $tokens $token] 3]) $token

            set token [string map { u {} } $token]
            lappend map $token " $token "
        }
        lappend map "\n" " ; "
        lsort -stride 2 -command lencmp [lsort -stride 2 -u $map]
    }

        proc lencmp { a b } {
            return [expr [string len $b] - [string len $a]]
        }

    # Accessors for the operator table data structure.
    #
    proc prec { tok } {                        # Return the precedence of an operator.
        upvar optable optable

        set reply 0
        catch { set reply [lindex [dict get $optable $tok] 0] }
        return $reply
    }
    proc arity { tok } {                # Return the arity of an operator.
        upvar optable optable

        set reply 0
        catch { set reply [lindex [dict get $optable $tok] 1] }
        return $reply
    }
    proc assoc { tok } {                # Return the assiciativity of an operator.
        upvar optable optable

        set reply 0
        catch { set reply [lindex [dict get $optable $tok] 2] }
        return $reply
    }
    proc name { tok } {                        # Return the name of an operator.
        upvar optable optable

        set reply 0
        catch { set reply [lindex [dict get $optable $tok] 3] } reply; # puts $reply
        return $reply
    }

    # Stack operators.
    #
    proc push { stkName value }   { upvar $stkName stk;   lappend stk $value }
    proc pop  { stkName { n 1 } } { upvar $stkName stk;
        set x [expr $n-1]
        set top [lrange $stk end-$x end]
        set stk [lrange $stk      0 end-$n]
        if { $n == 1 } {
            return [join $top]
        } else {
            return $top
        }
    }
    proc top  { stkName }         { upvar $stkName stk;   return [lindex $stk end] }
    proc pull { stkName }         { upvar $stkName stk;   set stk [lassign $stk top]; return $top }
    proc next { stkName }         { upvar $stkName stk;   return [lindex $stk 0] }

    # Here is the parser.  You pass in the input string, the token map, the operator precedence table and
    # a script prefix with will be called as each sub-expression in the input is recognized.
    #
    proc parse { input tokenmap optable prefix } {
        set operator {}                                        ; # Stacks
        set operands {}
        set parens   {}
        set prv {}                                        ; # The previous token.

        set input [string map $tokenmap $input]                ; # Lexing done by mapping spaces around the operators!

        #puts $input

        try {
            while { [llength $input] } {
                set tok [pull input]

                if { $tok eq ";" } {
                    while { [top operator] ne {} } {
                        push operands [{*}$prefix [name [set op [pop operator]]] {*}[pop operands [arity $op]]]
                    }
                    {*}$prefix [name ";"]

                    # Reset everyone
                    #
                    set operator {}                        ; # Stacks
                    set operands {}
                    set parens   {}
                    set prv {}                                ; # The previous token.

                    continue
                }

                if { [prec ${tok}u] && $prv ne ")" && ($prv eq {} || [prec $prv]) } {
                    set tok ${tok}u
                }

                #puts "$tok [prec $tok], op: $operator args: $operands"


                if { ![prec $tok] } {                                                        ; # Push operand
                    if { $prv ne {} && ![prec $prv] } { error "unexpected token : $prv _@_ $tok" }

                    push operands $tok
                } elseif {  $tok eq "("
                        ||  $tok eq {[}
                        ||  [top operator] eq {}
                        ||  [prec $tok] <  [prec [top operator]]
                        || ([prec $tok] <= [prec [top operator]]
                         && [assoc $tok] eq "right" ) } {

                    if { $tok eq "(" || $tok eq {[} } {
                        if { $tok eq {[} || ($prv ne {} && ![prec $prv]) } {
                            if { [next input] eq ")" }        { push parens 0                ; # Function call or Index
                            } else                         { push parens 1   }
                        } else                                 { push parens "(" }        ; # Normal expression paren
                    } else {
                        if { [prec ${tok}u] && ($prv eq {} || $prv eq "," || $prv eq "(" || $prv eq {[}) } {
                            set tok ${tok}u
                        }
                    }

                    push operator $tok

                } elseif { $tok eq ")" || $tok eq {]} || $tok eq "," } {        ; # Function call, Index or comma
                    switch [top parens] {
                     {}  { error "unexpected \")\" : $prv $tok [next input]"        }

                     "(" {                                                        ; # Close paren on normal expression paren
                        while { [top operator] ne "(" } {
                            push operands [{*}$prefix [name [set op [pop operator]]] {*}[pop operands [arity $op]]]
                        }
                        pop operator
                        pop parens
                     }
                     default {                                                                ; # Function call, Index or comma
                        if { $tok eq "," } { push parens [expr [pop parens]+1] }        ; # Incr function nargs

                        while { [top operator] ne "(" && [top operator] ne {[} } {        ; # Output function arg
                            push operands [{*}$prefix [name [set op [pop operator]]] {*}[pop operands [arity $op]]]
                        }
                        if { $tok eq ")" || $tok eq "]" } {                                ; # Output function call or Index
                            push operands [{*}$prefix [name [pop operator]] {*}[pop operands [expr [pop parens]+1]]]
                            pop  parens
                        }
                     }
                    }
                } else {
                    while { [top operator] ne {} && [prec $tok] >= [prec [top operator]] } {
                        push operands [{*}$prefix [name [set op [pop operator]]] {*}[pop operands [arity $op]]]
                    }
                    push operator $tok
                }

                set prv $tok

            }
            if { $parens ne {} } { error "parens not balanced" }

            while { [top operator] ne {} } {
                push operands [{*}$prefix [name [set op [pop operator]]] {*}[pop operands [arity $op]]]
            }
        } on error message {
            puts $::errorInfo
            error "parse error at: $prv _@_ $tok [next input] : $message"
        
        }

        pop operands
    }
 }