selected numeric and string functions, and numeric and string variables and
assignment.
String functions:
chr$ date$ hex$ lcase$ left$ ltrim$ mid$ right$ rtrim$ space$ str$ string$ time$
trim$ ucase$
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
Precedence - highest to lowest:
^
unary -, +
*, /
\
mod
+, -
=, <>, <, >, <=, >=
unary not
and
or
xor
eqv
imp
Example usage:
dim st as string
st = "abs(1+2*3+(5-1) + sin(42))"
print eval(st)
To Create variables:
st = "num1 = 42"
print eval(st)
st = "st1$ = " + chr$(34) + "hello" + chr$(34)
print eval(st)
Code features a simple demonstration program.
Code: Select all
'Numeric/String Eval function, supports all QBasic operators, as well as
' selected numeric and string functions, and numeric and string variables and
' assignment.
'
'String functions:
'chr$ date$ hex$ lcase$ left$ ltrim$ mid$ right$ rtrim$ space$ str$ string$ time$
'trim$ ucase$
'
'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
'
'Precedence - highest to lowest:
' ^
' unary -, +
' *, /
' \
' mod
' +, -
' =, <>, <, >, <=, >=
' unary not
' and
' or
' xor
' eqv
' imp
'
'Example usage:
'
'dim st as string
'st = "abs(1+2*3+(5-1) + sin(42))"
'print eval(st)
'
'To Create variables:
'
'st = "num1 = 42"
'print eval(st)
'
'st = "st1$ = " + chr$(34) + "hello" + chr$(34)
'print eval(st)
'
'Written by Ed Davis. Contact: ed_davis2 at that yahoo place.
'Use at your own risk.
declare function eval(userstr as string) as string
declare function numeric_expr(p as integer, userstr as string, sym as string) as double
declare function str_expr(userstr as string, sym as string) as string
declare sub dump_tables
declare sub help
declare sub store_numeric_var(vname as string, nvalue as double)
declare sub store_string_var(vname as string, svalue as string)
' simple demonstration
dim userstr as string
help
do
line input "Enter expression: ", userstr
select case userstr
case "list": dump_tables
case "help": help
case "cls": cls
case "": exit do
case else
print eval(userstr)
end select
loop
const rightassoc=0, leftassoc=1
const tyunknown=0,tystring=1,tynum=2
const max_store=256
type names_t
vname as string
index as integer
end type
' used by expression parser
dim shared num_stack(1 to max_store) as double
dim shared str_stack(1 to max_store) as string
dim shared str_stk_ndx as integer, num_stk_ndx as integer
' variable store
dim shared numeric_store(1 to max_store) as double
dim shared string_store(1 to max_store) as string
dim shared str_store_ndx as integer, num_store_ndx as integer, var_names_ndx as integer
dim shared var_names(1 to max_store) as names_t
sub help
print
print "Eval function, supports string and numeric variables and assignment"
print "All QBasic operators are supported"
print
print "String functions:"
print "chr$ date$ hex$ lcase$ left$ ltrim$ mid$ right$ rtrim$ space$ str$ string$"
print "time$ trim$ ucase$"
print
print "Numeric functions:"
print "abs atan cos exp fix int len log rnd sgn sin sqr tan val"
print
print "cls -- clear the screen"
print "help -- this screen"
print "list -- list assigned variables"
print
print "Examples:"
print "(1+(2-5)*3+8/(5+3)^2)/sqr(4^2+3^2)"
print "s$ = " + chr(34) + "abc" + chr(34) + " + space$(9/3) + " + chr(34) + "def" + chr(34)
print
end sub
sub dump_tables
dim i as integer
print "Variables: "; var_names_ndx
for i = 1 to var_names_ndx
print var_names(i).vname, " index: "; var_names(i).index; " "
if right(var_names(i).vname, 1) = "$" then
print string_store(var_names(i).index)
else
print numeric_store(var_names(i).index)
end if
next
print "String store: "; str_store_ndx
for i = 1 to str_store_ndx
print i, string_store(i)
next
print "Numeric store: "; num_store_ndx
for i = 1 to num_store_ndx
print i, numeric_store(i)
next
end sub
' get the value of a string variable
function get_string_var(vname as string) as string
dim i as integer
for i = 1 to var_names_ndx
if var_names(i).vname = vname then
get_string_var = string_store(var_names(i).index)
exit function
end if
next
get_string_var = ""
end function
' get the value of a numeric variable
function get_numeric_var(vname as string) as double
dim i as integer
for i = 1 to var_names_ndx
if var_names(i).vname = vname then
get_numeric_var = numeric_store(var_names(i).index)
exit function
end if
next
get_numeric_var = 0
end function
' Create or update a string variable
sub store_string_var(vname as string, svalue as string)
dim i as integer
for i = 1 to var_names_ndx
if var_names(i).vname = vname then
string_store(var_names(i).index) = svalue
exit sub
end if
next
str_store_ndx = str_store_ndx + 1
var_names_ndx = var_names_ndx + 1
var_names(var_names_ndx).vname = vname
var_names(var_names_ndx).index = str_store_ndx
string_store(str_store_ndx) = svalue
end sub
' Create or update a numeric variable
sub store_numeric_var(vname as string, nvalue as double)
dim i as integer
for i = 1 to var_names_ndx
if var_names(i).vname = vname then
numeric_store(var_names(i).index) = nvalue
exit sub
end if
next
num_store_ndx = num_store_ndx + 1
var_names_ndx = var_names_ndx + 1
var_names(var_names_ndx).vname = vname
var_names(var_names_ndx).index = num_store_ndx
numeric_store(num_store_ndx) = nvalue
end sub
' lexical analyzer functions
function isdigit(ch as string) as integer
isdigit = left(ch, 1) >= "0" and left(ch, 1) <= "9"
end function
function isnumeric(ch as string) as integer
isnumeric = isdigit(ch) or left(ch, 1) = "."
end function
function isalpha(ch as string) as integer
isalpha = lcase(left(ch, 1)) >= "a" and lcase(left(ch, 1)) <= "z"
end function
function is_str_var(s as string) as integer
is_str_var = isalpha(s) and right(s, 1) = "$"
end function
function is_str_lit(s as string) as integer
is_str_lit = left(s, 1) = chr(34)
end function
sub takechar(userstr as string, sym as string)
sym = sym + left(userstr, 1)
userstr = right(userstr, len(userstr) - 1)
end sub
function peekch(userstr as string) as string
peekch = left(ltrim(userstr), 1)
end function
sub finish_number(userstr as string, sym as string)
if lcase(left(userstr, 1)) = "e" then
takechar userstr, sym
if left(userstr, 1) = "+" or left(userstr, 1) = "-" then
takechar userstr, sym
end if
while isdigit(userstr)
takechar userstr, sym
wend
end if
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
finish_number(userstr, sym)
case "."
while isdigit(userstr)
takechar(userstr, sym)
wend
finish_number(userstr, sym)
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", "A" to "Z"
while isalpha(userstr) or isdigit(userstr) or left(userstr, 1) = "_"
takechar(userstr, sym)
wend
if left(userstr, 1) = "$" then
takechar(userstr, sym)
end if
sym = lcase(sym)
' literal strings keep the double quotes at begin/end
case chr(34)
while left(userstr, 1) <> chr(34) and userstr <> ""
takechar(userstr, sym)
wend
if left(userstr, 1) <> chr(34) then
print "Closing: '"; chr(34); "' expected"
else
takechar(userstr, sym)
end if
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) as integer
accept = 0
if sym = s then accept = -1: 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) as integer
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) as integer
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) as integer
'if op = op then :
associativity = leftassoc
end function
' parse a parenthesized one argument numeric expression
function getvalue(userstr as string, sym as string) as double
getvalue = 1
nextsym(userstr, sym) ' skip fun
expect("(", userstr, sym)
getvalue = numeric_expr(0, userstr, sym)
expect(")", userstr, sym)
end function
' parse a parenthesized one argument string expression
function getstring(userstr as string, sym as string) as string
getstring = ""
nextsym(userstr, sym) ' skip fun
expect("(", userstr, sym)
getstring = str_expr(userstr, sym)
expect(")", userstr, sym)
end function
' Handle string operands - functions, variables, literal strings
function strfactor(userstr as string, sym as string) as string
dim x as integer, y as integer, s as string, n as double
select case sym
case "chr$": n = getvalue(userstr, sym): strfactor = chr(n)
case "date$": nextsym(userstr, sym): strfactor = date
case "hex$": n = getvalue(userstr, sym): strfactor = hex(n)
case "lcase$": s = getstring(userstr, sym): strfactor = lcase(s)
case "left$"
nextsym(userstr, sym)
expect("(", userstr, sym)
s = str_expr(userstr, sym)
expect(",", userstr, sym)
x = numeric_expr(0, userstr, sym)
strfactor = left(s, x)
expect(")", userstr, sym)
case "ltrim$": s = getstring(userstr, sym): strfactor = ltrim(s)
case "mid$"
nextsym(userstr, sym)
expect("(", userstr, sym)
s = str_expr(userstr, sym)
expect(",", userstr, sym)
x = numeric_expr(0, userstr, sym)
if accept(",", userstr, sym) then
y = numeric_expr(0, userstr, sym)
strfactor = mid(s, x, y)
else
strfactor = mid(s, x)
end if
expect(")", userstr, sym)
case "right$"
nextsym(userstr, sym)
expect("(", userstr, sym)
s = str_expr(userstr, sym)
expect(",", userstr, sym)
x = numeric_expr(0, userstr, sym)
strfactor = right(s, x)
expect(")", userstr, sym)
case "rtrim$": s = getstring(userstr, sym): strfactor = rtrim(s)
case "space$"
nextsym(userstr, sym)
expect("(", userstr, sym)
strfactor = space(numeric_expr(0, userstr, sym))
expect(")", userstr, sym)
case "str$": n = getvalue(userstr, sym): strfactor = str(n)
case "string$"
nextsym(userstr, sym) ' string$(n [, strexpr])
expect("(", userstr, sym)
x = numeric_expr(0, userstr, sym)
expect(",", userstr, sym)
if is_str_lit(sym) or is_str_var(sym) then
strfactor = string(x, str_expr(userstr, sym))
else
strfactor = string(x, numeric_expr(0, userstr, sym))
end if
expect(")", userstr, sym)
case "time$": nextsym(userstr, sym): strfactor = time
case "trim$": s = getstring(userstr, sym): strfactor = ltrim(rtrim(s))
case "ucase$": s = getstring(userstr, sym): strfactor = ucase(s)
case else
if is_str_lit(sym) then
strfactor = mid(sym, 2, len(sym) - 2)
nextsym(userstr, sym)
elseif is_str_var(sym) then
if peekch(userstr) = "(" then
print "strfactor, unknown function: "; sym
else
strfactor = get_string_var(sym)
nextsym(userstr, sym)
end if
else
print "strfactor, expecting an operand, found: "; sym
end if
end select
end function
' handle numeric operands - numbers, variables, functions and unary operators
function primary(userstr as string, sym as string) as double
dim op as string, prec as integer, n as double, s as string
primary = 0 'prepare for errors
prec = unaryprec(sym)
if prec > 0 then
op = sym
nextsym(userstr, sym)
select case op
case "-": primary = -numeric_expr(prec, userstr, sym)
case "+": primary = numeric_expr(prec, userstr, sym)
case "not": primary = not numeric_expr(prec, userstr, sym)
end select
elseif isnumeric(sym) then
primary = val(sym)
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 "len": s = getstring(userstr, sym): primary = len(s)
case "log": n = getvalue(userstr, sym): primary = log(n)
case "rnd"
if peekch(userstr) = "(" then
n = getvalue(userstr, sym): primary = rnd(n)
else
nextsym(userstr, sym)
primary = rnd
end if
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 "val": s = getstring(userstr, sym): primary = val(s)
case else
if isalpha(sym) then
if peekch(userstr) = "(" then
print "primary, unknown function: "; sym
else
primary = get_numeric_var(sym)
nextsym(userstr, sym)
end if
else
print "syntax error: expecting a primary, found:", sym
end if
end select
end if
end function
sub push_str(s as string)
str_stk_ndx = str_stk_ndx + 1
str_stack(str_stk_ndx) = s
end sub
sub push_num(n as double)
num_stk_ndx = num_stk_ndx + 1
num_stack(num_stk_ndx) = n
end sub
function pop_str as string
pop_str = str_stack(str_stk_ndx)
str_stk_ndx = str_stk_ndx - 1
end function
function pop_num as double
pop_num = num_stack(num_stk_ndx)
num_stk_ndx = num_stk_ndx - 1
end function
' evaluate binary string operators, operands on the stack
function evalstrexpr(op as string) as integer
dim s as string, s2 as string, n as double, val_type as integer
val_type = tynum ' most operators give a numeric result
s2 = pop_str
s = pop_str
select case op
case "=": n = s = s2
case "<>": n = s <> s2
case "<": n = s < s2
case ">": n = s > s2
case "<=": n = s <= s2
case ">=": n = s >= s2
case "+": s = s + s2: val_type = tystring
case else
print "evalstrexpr: expecting a string operator, found: "; op
end select
if val_type = tynum then
push_num(n)
evalstrexpr = tynum
elseif val_type = tystring then
push_str(s)
evalstrexpr = tystring
end if
end function
' evaluate binary numeric operators, operands on the stack
function evalnumericexpr(op as string) as integer
dim n as double, n2 as double
n2 = pop_num
n = pop_num
select case op
case "^": n = n ^ n2
case "*": n = n * n2
case "/": if n2 = 0 then print "division by 0" else n = n / n2
case "\": if n2 = 0 then print "division by 0" else n = n \ n2
case "mod": if n2 = 0 then print "division by 0" else 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 "evalnumericexpr: unexpected operator: "; op
end select
push_num(n)
evalnumericexpr = tynum
end function
' main expression parsing routine
function any_expr(p as integer, userstr as string, sym as string) as integer
dim op as string, q as integer, prec as integer
dim left_type as integer, right_type as integer
' we need to decide which primary to call - numeric or string
' leading parens don't tell us which primary, so just do recursive call
if accept("(", userstr, sym) then
left_type = any_expr(0, userstr, sym)
expect(")", userstr, sym)
elseif is_str_lit(sym) or is_str_var(sym) then
push_str(strfactor(userstr, sym))
left_type = tystring
elseif isnumeric(sym) or sym = "-" or sym = "+" or sym = "not" or isalpha(sym) then
push_num(primary(userstr, sym))
left_type = tynum
elseif sym = "" then
print "In expr, unexpected end-of-input found: "
else
print "In expr, unexpected symbol found: "; sym
end if
do ' while binary operator and precedence of sym >= p
prec = binaryprec(sym)
if prec = 0 or prec < p then exit do
op = sym
nextsym(userstr, sym)
select case associativity(op)
case rightassoc : q = binaryprec(op)
case leftassoc : q = binaryprec(op) + 1
end select
right_type = any_expr(q, userstr, sym)
if left_type = tystring and right_type = tystring then
left_type = evalstrexpr(op)
elseif left_type = tynum and right_type = tynum then
left_type = evalnumericexpr(op)
else
print "type missmatch in expr - left_type:"; left_type; " right_type:"; right_type
end if
loop
any_expr = left_type
end function
function numeric_expr(p as integer, userstr as string, sym as string) as double
if any_expr(p, userstr, sym) = tynum then
numeric_expr = pop_num
else
print "numeric expression expected"
numeric_expr = 0
end if
end function
function str_expr(userstr as string, sym as string) as string
if any_expr(0, userstr, sym) = tystring then
str_expr = pop_str
else
print "string expression expected"
str_expr = ""
end if
end function
function eval(userstr as string) as string
dim sym as string, save_sym as string, val_type as integer, nresult as double, sresult as string
eval = ""
' reset the stacks used during expression parsing
str_stk_ndx = 0: num_stk_ndx = 0
nextsym(userstr, sym)
' does it look like an assignment? "var = expression"
save_sym = ""
if peekch(userstr) = "=" then
save_sym = sym ' save the left side variable
nextsym(userstr, sym) ' skip the variable
nextsym(userstr, sym) ' skip "="
end if
' evalualte the expression
val_type = any_expr(0, userstr, sym)
if sym <> "" then
print "error: extra symbols found: "; sym; userstr
elseif val_type = tystring then
sresult = pop_str
eval = sresult
elseif val_type = tynum then
nresult = pop_num
eval = str(nresult)
end if
' was it an assignment?
if save_sym <> "" then
if is_str_var(save_sym) and val_type = tystring then
store_string_var(save_sym, sresult)
elseif isalpha(save_sym) and val_type = tynum then
store_numeric_var(save_sym, nresult)
else
print "Type mismatch in assignment"
end if
end if
end function