Here is a (hopefully) simple one I wrote a few years ago. It uses precedence climbing to parse the expression.
Code: Select all
'Eval function, supports all QBasic operators and selected numeric functions.
'
'Numeric functions:
'abs atan cos exp fix int len log rnd sgn sin sqr tan val
'
'Simple to add additional single parameter functions
'Just a little busy work to add multiple parameter functions
'
'Compiles with QB64 and FreeBasic (-lang qb).
'
'Precedence - highest to lowest:
' ^
' unary -, +
' *, /
' \
' mod
' +, -
' =, <>, <, >, <=, >=
' unary not
' and
' or
' xor
' eqv
' imp
'
'Example usage:
'
'calc abs(1+2*3+(5-1) + sin(42))
'
'Written by Ed Davis. Contact: ed_davis2 at that yahoo place.
'Use at your own risk.
option explicit ' drop the "_" for FreeBasic
declare function eval#(userstr as string)
declare function expr#(p as integer, userstr as string, sym as string)
const rightassoc=0, leftassoc=1
dim userstr as string
userstr = command$
if userstr <> "" then print eval#(userstr)
' lexical analyzer functions
function isdigit%(ch as string)
isdigit% = left$(ch, 1) >= "0" and left$(ch, 1) <= "9"
end function
function isnumeric%(ch as string)
isnumeric% = isdigit(ch) or left$(ch, 1) = "."
end function
function isalpha%(ch as string)
isalpha% = lcase$(left$(ch, 1)) >= "a" and lcase$(left$(ch, 1)) <= "z"
end function
sub takechar(userstr as string, sym as string)
sym = sym + left$(userstr, 1)
userstr = right$(userstr, len(userstr) - 1)
end sub
sub nextsym(userstr as string, sym as string)
sym = ""
userstr = ltrim$(userstr)
takechar userstr, sym
select case sym
case "%", "(", ")", "*", "+", "-", "/", "=", "\", "^" 'all set
case "0" to "9"
while isdigit%(userstr)
takechar userstr, sym
wend
if left$(userstr, 1) = "." then
takechar userstr, sym
while isdigit%(userstr)
takechar userstr, sym
wend
end if
case "."
while isdigit%(userstr)
takechar userstr, sym
wend
case "<"
if left$(userstr, 1) = "=" or left$(userstr, 1) = ">" then
takechar userstr, sym
end if
case ">"
if left$(userstr, 1) = "=" then
takechar userstr, sym
end if
case "a" to "z"
while isalpha%(userstr) or isdigit%(userstr)
takechar userstr, sym
wend
case ""
case else
print "unrecognized character:", sym
sym = ""
end select
end sub
' parser starts here
function accept&(s as string, userstr as string, sym as string)
accept& = 0
if sym = s then accept& = -1: call nextsym(userstr, sym)
end function
sub expect(s as string, userstr as string, sym as string)
if not accept&(s, userstr, sym) then print "expecting "; s; " but found "; sym
end sub
function unaryprec%(op as string)
select case op
case "+", "-": unaryprec% = 13
case "not": unaryprec% = 6
case else: unaryprec% = 0 ' not a unary operator
end select
end function
function binaryprec%(op as string)
select case op
case "^": binaryprec% = 14
case "*", "/": binaryprec% = 12
case "\" : binaryprec% = 11
case "mod": binaryprec% = 10
case "+", "-": binaryprec% = 9
case "=", "<>", "<", ">", "<=", ">=": binaryprec% = 7
case "and": binaryprec% = 5
case "or": binaryprec% = 4
case "xor": binaryprec% = 3
case "eqv": binaryprec% = 2
case "imp": binaryprec% = 1
case else: binaryprec% = 0 ' not a binary operator
end select
end function
' all QBasic operators are left associative
function associativity%(op as string)
if op = op then :
associativity% = leftassoc
end function
' parse a parenthesized numeric expression
function getvalue#(userstr as string, sym as string)
getvalue# = 1
call nextsym(userstr, sym) ' skip fun
call expect("(", userstr, sym)
getvalue# = expr#(0, userstr, sym)
call expect(")", userstr, sym)
end function
' handle numeric operands - numbers, functions - and unary operators
function primary#(userstr as string, sym as string)
dim op as string, prec as integer, n as double
primary# = 0 'prepare for errors
prec = unaryprec%(sym)
if prec > 0 then
op = sym
call nextsym(userstr, sym)
select case op
case "-": primary# = -expr#(prec, userstr, sym)
case "+": primary# = expr#(prec, userstr, sym)
case "not": primary# = not expr#(prec, userstr, sym)
end select
elseif sym = "(" then
call nextsym(userstr, sym)
primary# = expr#(0, userstr, sym)
call expect(")", userstr, sym)
elseif isnumeric%(sym) then
primary# = val(sym)
call nextsym(userstr, sym)
else
select case sym
case "abs": n = getvalue#(userstr, sym): primary# = abs(n)
case "atan": n = getvalue#(userstr, sym): primary# = atn(n)
case "cos": n = getvalue#(userstr, sym): primary# = cos(n)
case "exp": n = getvalue#(userstr, sym): primary# = exp(n)
case "fix": n = getvalue#(userstr, sym): primary# = fix(n)
case "int": n = getvalue#(userstr, sym): primary# = int(n)
case "log": n = getvalue#(userstr, sym): primary# = log(n)
case "sgn": n = getvalue#(userstr, sym): primary# = sgn(n)
case "sin": n = getvalue#(userstr, sym): primary# = sin(n)
case "sqr": n = getvalue#(userstr, sym): primary# = sqr(n)
case "tan": n = getvalue#(userstr, sym): primary# = tan(n)
case else: print "syntax error: expecting a primary, found:", sym
end select
end if
end function
' main expression parsing routine
function expr#(p as integer, userstr as string, sym as string)
dim n as double, n2 as double, op as string, q as integer, prec as integer
n = primary#(userstr, sym)
do ' while binary operator and precedence of sym >= p
prec = binaryprec%(sym)
if prec = 0 or prec < p% then exit do
op = sym
call nextsym(userstr, sym)
select case associativity%(op)
case rightassoc : q = binaryprec%(op)
case leftassoc : q = binaryprec%(op) + 1
end select
n2 = expr#(q, userstr, sym)
select case op
case "^": n = n ^ n2
case "*": n = n * n2
case "/": n = n / n2
case "\": n = n \ n2
case "mod": n = n mod n2
case "+": n = n + n2
case "-": n = n - n2
case "=": n = n = n2
case "<>": n = n <> n2
case "<": n = n < n2
case ">": n = n > n2
case "<=": n = n <= n2
case ">=": n = n >= n2
case "and": n = n and n2
case "or": n = n or n2
case "xor": n = n xor n2
case "eqv": n = n eqv n2
case "imp": n = n imp n2
case else: print "syntax error: expecting a binary operator, found:", sym
end select
loop
expr# = n
end function
function eval#(userstr as string)
dim sym as string
call nextsym(userstr, sym)
eval# = expr#(0, userstr, sym)
if sym <> "" then print "error: extra input found: "; sym; userstr
end function
