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
}
}