[SS] 23Jan2004 - In order to add the [expr] command to Jim (A small-footprint Tcl implementation I'm working on)
I had to write a compiler able to turn mathematical expressions into bytecode for a stack-based machine.
Before to write it in C, I wrote a prototype in Tcl that can be useful. [AM] is also working on
something like this, similar in design to the Tcl's expr parser itself.
This one is a bit different. It generates a stack program from the expr representation, and optionally
can turn the stack program into a Tcl program (i.e. a parse tree). For Jim the last part is not
useful, but I added it for completeness. This code does not check at all if the input expression
is correct. It's just a prototype, I'm going to write the real version in C.

Example output:

 Exp: 1+2*3
 Rpn: 1 2 3 * +
 Tcl: [+ 1 [* 2 3]]
 
 Exp: 1*2+3
 Rpn: 1 2 * 3 +
 Tcl: [+ [* 1 2] 3]
 
 Exp: ((1*(2+3)*4)+5)*2
 Rpn: 1 2 3 + * 4 * 5 + 2 *
 Tcl: [* [+ [* [* 1 [+ 2 3]] 4] 5] 2]
 
 Exp: 0-1+5
 Rpn: 0 1 - 5 +
 Tcl: [+ [- 0 1] 5]
 
 Exp: 2*0-1+5
 Rpn: 2 0 * 1 - 5 +
 Tcl: [+ [- [* 2 0] 1] 5]
 
 Exp: 1+2*3+4*5+6
 Rpn: 1 2 3 * + 4 5 * + 6 +
 Tcl: [+ [+ [+ 1 [* 2 3]] [* 4 5]] 6]

Exp is the input expression, Rpn is the generated RPN program, Tcl is the RPN program translated
into a Tcl program.

And That's the code:

 # Expression parser in Tcl.
 # Copyright (C) 2005 Salvatore Sanfilippo
 # Under the BSD license.
 
 # This list represent the operators.
 # is composed of groups of three elements:
 # The operator name, precedente, arity.
 set ExprOperators {
    "-" 0 2
    "+" 0 2
    "*" 1 2
    "/" 1 2
 }
 
 proc ExprOperatorPrecedence op {
     foreach {name prec arity} $::ExprOperators {
 	if {$name eq $op} {return $prec}
     }
     return -1
 }
 
 proc ExprOperatorArity op {
     foreach {name prec arity} $::ExprOperators {
 	if {$name eq $op} {return $arity}
     }
     return -1
 }
 
 proc ExprIsOperator op {
     expr {[ExprOperatorPrecedence $op] != -1}
 }
 
 proc ExprGetToken exprVar {
     upvar 1 $exprVar expression
     set expression [string trim $expression]
     if {[regexp {(^[0-9]+)(.*)} $expression -> tok exprRest]} {
 	set res [list operand $tok]
 	set expression $exprRest
     } elseif {[ExprIsOperator [string index $expression 0]]} {
 	set res [list operator [string index $expression 0]]
 	set expression [string range $expression 1 end]
     } elseif {[string index $expression 0] eq "("} {
 	set res [list substart {}]
 	set expression [string range $expression 1 end]
     } elseif {[string index $expression 0] eq ")"} {
 	set res [list subend {}]
 	set expression [string range $expression 1 end]
     } else {
 	return -code error \
 	    "default reached in ExprGetToken. String: '$expression'"
     }
     return $res
 }
 
 proc ExprTokenize expression {
     set tokens {}
     while {[string length [string trim $expression]]} {
 	lappend tokens [ExprGetToken expression]
     }
     return $tokens
 }
 
 proc ExprPop listVar {
     upvar 1 $listVar list
     set ele [lindex $list end]
     set list [lindex [list [lrange $list 0 end-1] [set list {}]] 0]
     return $ele
 }
 
 proc ExprPush {listVar element} {
     upvar 1 $listVar list
     lappend list $element
 }
 
 proc ExprPeek listVar {
     upvar 1 $listVar list
     lindex $list end
 }
 
 proc ExprTokensToRPN tokens {
     set rpn {}
     set stack {}
     foreach t $tokens {
 	foreach {type token} $t {}
 	if {$type eq {operand}} {
 	    ExprPush rpn $token
 	} elseif {$type eq {operator}} {
 	    while {[llength $stack] && \
 	            [ExprOperatorPrecedence [ExprPeek stack]] >= \
 		    [ExprOperatorPrecedence $token]} \
 	    {
 		ExprPush rpn [ExprPop stack]
 	    }
 	    ExprPush stack $token
 	} elseif {$type eq {substart}} {
 	    ExprPush stack "("
 	} elseif {$type eq {subend}} {
 	    while 1 {
 		set op [ExprPop stack]
 		if {$op eq "("} break
 		ExprPush rpn $op
 	    }
 	}
     }
     while {[llength $stack]} {
 	ExprPush rpn [ExprPop stack]
     }
     return $rpn
 }
 
 proc ExprToRpn expression {
     set tokens [ExprTokenize $expression]
     ExprTokensToRPN $tokens
 }
 
 proc ExprRpnToTcl rpn {
     set stack {}
     foreach item $rpn {
 	if {[ExprIsOperator $item]} {
 	    set arity [ExprOperatorArity $item]
 	    set operators [lrange $stack end-[expr {$arity-1}] end]
 	    set stack [lrange $stack 0 end-$arity]
 	    while {$arity} {ExprPop rpn; incr arity -1}
 	    set item "$item "
 	    foreach operator $operators {
 		append item "$operator "
 	    }
 	    set item [string range $item 0 end-1]
 	    ExprPush stack "\[$item\]"
 	} else {
 	    ExprPush stack $item
 	}
     }
     return [lindex $stack 0]
 }
 
 proc ExprTest {} {
     set expressions {
 	{1+2*3}
 	{1*2+3}
 	{((1*(2+3)*4)+5)*2}
 	{0-1+5}
 	{2*0-1+5}
 	{1+2*3+4*5+6}
     }
     foreach e $expressions {
 	set rpn [ExprToRpn $e]
 	set tcl [ExprRpnToTcl $rpn]
 	puts "Exp: $e"
 	puts "Rpn: $rpn"
 	puts "Tcl: $tcl"
 	puts {}
     }
 }
 
 ExprTest