-- demo\rosetta\Arithmetic_evaluation.exw
sequence opstack = {}       -- atom elements are literals,
                            -- sequence elements are subexpressions
                            -- on completion length(opstack) should be 1
object token

constant p_p_op = -1,       -- expressions stored as p1,p2,op
         p_op_p =  0,       -- expressions stored as p1,op,p2
         op_p_p = +1,       -- expressions stored as op,p1,p2
         opp = op_p_p

object op = 0   -- 0 if none, else "+", "-", "*", "/", "^", "%", or "u-"

string s        -- the expression being parsed
integer ch
integer sidx

procedure err(string msg)
    crash("%s\n%s^ %s\n\nPressEnter...",{s,repeat(' ',sidx-1),msg})
end procedure

procedure nxtch(object msg="eof")
    sidx += 1
    if sidx>length(s) then
        if string(msg) then err(msg) end if
        ch = -1
    else
        ch = s[sidx]
    end if
end procedure

procedure skipspaces()
    while find(ch," \t\r\n") do nxtch(0) end while
end procedure

procedure get_token()
    skipspaces()
    if ch=-1 then token = "eof" return end if
    if ch>='0' and ch<='9' then
        atom n = ch-'0'
        while 1 do
            nxtch(0)
            if ch<'0' or ch>'9' then exit end if
            n = n*10+(ch-'0')
        end while
        if ch='.' then
            integer decimal = 1
            atom fraction = 0
            while true do
                nxtch(0)
                if ch<'0' or ch>'9' then exit end if
                fraction = fraction*10 + (ch-'0')
                decimal *= 10
            end while
            n += fraction/decimal
        end if
--      if find(ch,"eE") then   -- you get the idea
--      end if
        token = n
        return
    end if
    if find(ch,"+-/*()^%")=0 then err("syntax error") end if
    token = s[sidx..sidx]
    nxtch(0)
    return
end procedure

procedure Match(string t)
    if token!=t then err(t&" expected") end if
    get_token()
end procedure

procedure PopFactor()
    object p1, p2 = opstack[$], f
    if op="u-" then
        p1 = 0
    else
        opstack = opstack[1..$-1]
        p1 = opstack[$]
    end if
    switch opp do
        case op_p_p:    f = {op,p1,p2}
        case p_op_p:    f = {p1,op,p2}
        case p_p_op:    f = {p1,p2,op}
    end switch
    opstack[$] = f
    op = 0
end procedure

procedure PushFactor(atom t)
    if op!=0 then PopFactor() end if
    opstack = append(opstack,t)
end procedure

procedure PushOp(string t)
    if op!=0 then PopFactor() end if
    op = t
end procedure

forward procedure Expr(integer p)

procedure Factor()
    if atom(token) then
        PushFactor(token)
        if ch!=-1 then
            get_token()
        end if
    elsif token="+" then -- (ignore)
        nxtch()
        Factor()
    elsif token="-" then
        get_token()
--      Factor()
        Expr(3) -- makes "-3^2" yield -9 (ie -(3^2)) not 9 (ie (-3)^2).
        if op!=0 then PopFactor() end if
        if integer(opstack[$]) then
            opstack[$] = -opstack[$]
        else
            PushOp("u-")
        end if
    elsif token="(" then
        get_token()
        Expr(0)
        Match(")")
    else
        err("syntax error")
    end if
end procedure

constant {operators,
          precedence,
          associativity} = columnize({{"^",3,0},
                                      {"%",2,1},
                                      {"*",2,1},
                                      {"/",2,1},
                                      {"+",1,1},
                                      {"-",1,1},
                                      $})

procedure Expr(integer p)
--
-- Parse an expression, using precedence climbing.
--
-- p is the precedence level we should parse to, eg/ie
--      4: Factor only (may as well just call Factor)
--      3: "" and ^
--      2: "" and *,/,%
--      1: "" and +,-
--      0: full expression (effectively the same as 1)
--  obviously, parentheses override any setting of p.
--
    Factor()
    while 1 do
        integer k = find(token,operators) -- *,/,+,-
        if k=0 then exit end if
        integer thisp = precedence[k]
        if thisp<p then exit end if
        get_token()
        Expr(thisp+associativity[k])
        PushOp(operators[k])
    end while
end procedure

function evaluate(object s)
    object lhs, rhs
    string op
    if atom(s) then return s end if
    switch opp do
        case op_p_p:    {op,lhs,rhs} = s
        case p_op_p:    {lhs,op,rhs} = s
        case p_p_op:    {lhs,rhs,op} = s
        default: ?9/0
    end switch
    if sequence(lhs) then lhs = evaluate(lhs) end if
    if sequence(rhs) then rhs = evaluate(rhs) end if
    if op="+" then      return lhs+rhs
    elsif op="-" then   return lhs-rhs
    elsif op="*" then   return lhs*rhs
    elsif op="/" then   return lhs/rhs
    elsif op="^" then   return power(lhs,rhs)
    elsif op="%" then   return rmdr(lhs,rhs)
    elsif op="u-" then  return -rhs
    else ?9/0
    end if
end function

s = "3+4+5+6*7/1*5^2^3"     -- 16406262
sidx = 0
nxtch()
get_token()
Expr(0)
if op!=0 then PopFactor() end if
if length(opstack)!=1 then err("some error") end if
printf(1,"expression: \"%s\"\n",{s})
puts(1,"AST (flat): ")
?opstack[1]
puts(1,"AST (tree):\n")
ppEx(opstack[1],{pp_Nest,9999})
puts(1,"result: ")
?evaluate(opstack[1])
{} = wait_key()