RosettaCodeData/Task/Arithmetic-evaluation/FreeBASIC/arithmetic-evaluation.freebasic

'Arithmetic evaluation
'
'Create a program which parses and evaluates arithmetic expressions.
'
'Requirements
'
'    * An abstract-syntax tree (AST) for the expression must be created from parsing the
'      input.
'    * The AST must be used in evaluation, also, so the input may not be directly evaluated
'      (e.g. by calling eval or a similar language feature.)
'    * The expression will be a string or list of symbols like "(1+3)*7".
'    * The four symbols + - * / must be supported as binary operators with conventional
'      precedence rules.
'    * Precedence-control parentheses must also be supported.
'
'Standard mathematical precedence should be followed:
'
'    Parentheses
'    Multiplication/Division (left to right)
'    Addition/Subtraction (left to right)
'
'  test cases:
'  2*-3--4+-0.25 : returns -2.25
'  1 + 2 * (3 + (4 * 5 + 6 * 7 * 8) - 9) / 10 : returns 71

enum
    false = 0
    true = -1
end enum

enum Symbol
    unknown_sym
    minus_sym
    plus_sym
    lparen_sym
    rparen_sym
    number_sym
    mul_sym
    div_sym
    unary_minus_sym
    unary_plus_sym
    done_sym
    eof_sym
end enum

type Tree
    as Tree ptr leftp, rightp
    op as Symbol
    value as double
end type

dim shared sym as Symbol
dim shared tokenval as double
dim shared usr_input as string

declare function expr(byval p as integer) as Tree ptr

function isdigit(byval ch as string) as long
    return ch <> "" and Asc(ch) >= Asc("0") and Asc(ch) <= Asc("9")
end function

sub error_msg(byval msg as string)
    print msg
    system
end sub

' tokenize the input string
sub getsym()
    do
        if usr_input = "" then
            line input usr_input
            usr_input += chr(10)
        endif
        dim as string ch = mid(usr_input, 1, 1) ' get the next char
        usr_input = mid(usr_input, 2)           ' remove it from input

        sym = unknown_sym
        select case ch
            case " ":     continue do
            case chr(10), "": sym = done_sym: return
            case "+":     sym = plus_sym:     return
            case "-":     sym = minus_sym:    return
            case "*":     sym = mul_sym:      return
            case "/":     sym = div_sym:      return
            case "(":     sym = lparen_sym:   return
            case ")":     sym = rparen_sym:   return
            case else
                if isdigit(ch) then
                    dim s as string = ""
                    dim dot as integer = 0
                    do
                        s += ch
                        if ch = "." then dot += 1
                        ch = mid(usr_input, 1, 1)       ' get the next char
                        usr_input = mid(usr_input, 2)   ' remove it from input
                    loop while isdigit(ch) orelse ch = "."
                    if ch = "." or dot > 1 then error_msg("bogus number")
                    usr_input = ch + usr_input          ' prepend the char to input
                    tokenval = val(s)
                    sym = number_sym
                end if
                return
        end select
    loop
end sub

function make_node(byval op as Symbol, byval leftp as Tree ptr, byval rightp as Tree ptr) as Tree ptr
    dim t as Tree ptr

    t = callocate(len(Tree))
    t->op = op
    t->leftp = leftp
    t->rightp = rightp
    return t
end function

function is_binary(byval op as Symbol) as integer
    select case op
        case mul_sym, div_sym, plus_sym, minus_sym: return true
        case else: return false
    end select
end function

function prec(byval op as Symbol) as integer
    select case op
        case unary_minus_sym, unary_plus_sym:  return 100
        case mul_sym, div_sym:                 return  90
        case plus_sym, minus_sym:              return  80
        case else:                             return   0
    end select
end function

function primary as Tree ptr
    dim t as Tree ptr = 0

    select case sym
        case minus_sym, plus_sym
            dim op as Symbol = sym
            getsym()
            t = expr(prec(unary_minus_sym))
            if op = minus_sym then return make_node(unary_minus_sym, t, 0)
            if op = plus_sym  then return make_node(unary_plus_sym,  t, 0)
        case lparen_sym
            getsym()
            t = expr(0)
            if sym <> rparen_sym then error_msg("expecting rparen")
            getsym()
            return t
        case number_sym
            t = make_node(sym, 0, 0)
            t->value = tokenval
            getsym()
            return t
        case else: error_msg("expecting a primary")
    end select
end function

function expr(byval p as integer) as Tree ptr
    dim t as Tree ptr = primary()

    while is_binary(sym) andalso prec(sym) >= p
        dim t1 as Tree ptr
        dim op as Symbol = sym
        getsym()
        t1 = expr(prec(op) + 1)
        t = make_node(op, t, t1)
    wend
    return t
end function

function eval(byval t as Tree ptr) as double
    if t <> 0 then
        select case t->op
            case minus_sym:       return eval(t->leftp) - eval(t->rightp)
            case plus_sym:        return eval(t->leftp) + eval(t->rightp)
            case mul_sym:         return eval(t->leftp) * eval(t->rightp)
            case div_sym:         return eval(t->leftp) / eval(t->rightp)
            case unary_minus_sym: return -eval(t->leftp)
            case unary_plus_sym:  return  eval(t->leftp)
            case number_sym:      return t->value
            case else:            error_msg("unexpected tree node")
        end select
    end if
    return 0
end function

do
    getsym()
    if sym = eof_sym then exit do
    if sym = done_sym then continue do
    dim t as Tree ptr = expr(0)
    print"> "; eval(t)
    if sym = eof_sym then exit do
    if sym <> done_sym then error_msg("unexpected input")
loop