procedure main()                                                #: simple arithmetical parser / evaluator
   write("Usage: Input expression = Abstract Syntax Tree = Value, ^Z to end.")
   repeat {
      writes("Input expression : ")
      if not writes(line := read()) then break
      if map(line) ? { (x := E()) & pos(0) } then
         write(" = ", showAST(x), " = ", evalAST(x))
      else
         write(" rejected")
   }
end

procedure evalAST(X)                                            #: return the evaluated AST
   local x

   if type(X) == "list" then {
      x := evalAST(get(X))
      while x := get(X)(x, evalAST(get(X) | stop("Malformed AST.")))
   }
   return \x | X
end

procedure showAST(X)                                            #: return a string representing the AST
   local x,s

   s := ""
   every x := !X do
      s ||:= if type(x) == "list" then "(" || showAST(x) || ")" else x
   return s
end

########
# When you're writing a big parser, a few utility recognisers are very useful
#
procedure ws()    # skip optional whitespace
   suspend tab(many(' \t')) | ""
end

procedure digits()
   suspend tab(many(&digits))
end

procedure radixNum(r)    # r sets the radix
   static chars
   initial chars := &digits || &lcase
   suspend tab(many(chars[1 +: r]))
end
########

global token
record HansonsDevice(precedence,associativity)

procedure opinfo()
   static O
   initial {
      O := HansonsDevice([], table(&null))                         # parsing table
      put(O.precedence, ["+", "-"], ["*", "/", "%"], ["^"])        # Lowest to Highest precedence
      every O.associativity[!!O.precedence] := 1                   # default to 1 for LEFT associativity
      O.associativity["^"] := 0                                    # RIGHT associativity
   }
   return O
end

procedure E(k)                                                  #: Expression
   local lex, pL
   static opT
   initial opT := opinfo()

   /k := 1
   lex := []
   if not (pL := opT.precedence[k]) then                        # this op at this level?
      put(lex, F())
   else {
      put(lex, E(k + 1))
      while ws() & put(lex, token := =!pL) do
         put(lex, E(k + opT.associativity[token]))
   }
   suspend if *lex = 1 then lex[1] else lex                     # strip useless []
end

procedure F()                                                   #: Factor
   suspend ws() & (    # skip optional whitespace, and ...
      (="+" & F())              |          # unary + and a Factor, or ...
      (="-" || V())             |          # unary - and a Value, or ...
      (="-" & [-1, "*", F()])   |          # unary - and a Factor, or ...
     2(="(", E(), ws(), =")")   |          # parenthesized subexpression, or ...
       V()                                 # just a value
   )
end

procedure V()                                                   #: Value
   local r
   suspend ws() & numeric(    # skip optional whitespace, and ...
       =(r := 1 to 36) || ="r" || radixNum(r)             |     # N-based number, or ...
       digits() || (="." || digits() | "") || exponent()        # plain number with optional fraction
   )
end

procedure exponent()
   suspend tab(any('eE')) || =("+" | "-" | "") || digits() | ""
end