This is based on the eval code by utopiomania. I changed a lot of things, add string support and turned it into a generic eval object. Variables, commands and functions are yet not supported the original code is there but invalidated so this is a beta.
The idea is to supply the operators, op delimiters, string delimiter and a Calc() function callback so is very flexible. This function will receive the Op and the 2 parameters, free of syntax errors, it's up to you to make the calculation and set the return value. Since distinguishes between integers, floats and strings you have to check the var type. You distinguish unary operators because the 1st param is empty see CalcMinus_Negation(). You can use words for operators, see 'mod' in the code.
There's just one syntax rule, you have to use parenthesis to concatenate operators, mostly with unary operators, like -(-(-3)), this should be improved.
I'll add vars, commands, etc.. later. I think the syntax checking is pretty robust, feel free to improve it.
Code: Select all
;String math expression evaluator, Justin, based on utopiomania code
;PureBasic 3.93
;Beta, vars, commands, functions not supported
#MAXVARS=1000
Global Dim VarNames.s(#MAXVARS)
Global Dim Vars.f(#MAXVARS)
#MAXFNC=11
Global Dim Fnc.s(#MAXFNC)
Fnc(0)="ACOS":Fnc(1)="ASIN":Fnc(2)="ATAN":Fnc(3)="ABS"
Fnc(4)="COS":Fnc(5)="INT":Fnc(6)="LOG":Fnc(7)="LOG10"
Fnc(8)="SIN":Fnc(9)="SQR":Fnc(10)="TAN"
#MAXCMD=1
Global Dim Cmd.s(#MAXCMD)
Cmd(0)="CLEAR"
;- #CONSTANTS
;- Enum Token Type
Enumeration 0
#EV_TT_EMPTY
#EV_TT_DELIM
#EV_TT_VARIABLE
#EV_TT_INTEGER
#EV_TT_STRING
#EV_TT_FLOAT
#EV_TT_FUNCTION
#EV_TT_COMMAND
#EV_TT_OPERATOR
#EV_TT_OPENPAR
#EV_TT_CLOSEPAR
EndEnumeration
;- Enum Operator type
Enumeration
#EV_OT_ARITHMETIC
#EV_OT_RELATIONAL
#EV_OT_LOGICAL
#EV_OT_ASSIGNMENT
#EV_OT_DIRECTIONAL
EndEnumeration
;Generic error codes
Enumeration -1 Step -1
#EV_EC_SYNTAX
#EV_EC_NOTSUPPORTED
#EV_EC_NOEXPR
#EV_EC_DIVZERO
#EV_EC_INVALIDTYPES
EndEnumeration
;- #STRUCTURES
Structure EV_ARR_STR ;holds op arrays
el.s[100]
EndStructure
Structure VAR_TYPE
vt.w
StructureUnion
LongVal.l
FloatVal.f
EndStructureUnion
strVal.s
VarName.s
EndStructure
Structure EVAL_DATA
Expr.s ;Holds the expression to be evaluated
Progr.l ;Points to the next token in expression
Token.s ;Holds the token
Ttype.l ;Token type enum
OldTtype.l ;used for error checking
ErrPar.l ;used to check unbalanced parenthesis
Error.l ;Error code returned by evEval()
ErrorStr.s ;Error string
OpDelimiters.s ;Op Delimiters string
strDelim.s ;String delimiter (1 char)
;Op Arrays
;Arithmetic Ops
MaxAriOps.l
*AriOps.EV_ARR_STR
;Relational Ops
MaxRelOps.l
*RelOps.EV_ARR_STR
;Logical Ops
MaxLogOps.l
*LogOps.EV_ARR_STR
CalcFunc.l ;address of function that does the Operator calculation
param.l ;user param
EndStructure
;- #DECLARES
Declare evEval(*heval.EVAL_DATA, Str.s, *Result.VAR_TYPE)
Declare evLevel1(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evLevel2(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evLevel3(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evLevel4(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evLevel5(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evLevel6(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evPrimitive(*heval.EVAL_DATA, *Result.VAR_TYPE)
Declare evIsOpDelim(*heval.EVAL_DATA, Str.s)
Declare evNotDelim(*heval.EVAL_DATA, Str.s)
Declare evIsOp(*heval.EVAL_DATA, Op.s)
Declare evMakeOpArr(opList.s, *opCount.LONG)
Declare evRewind(*heval.EVAL_DATA)
Declare evIsFloat(num$)
Declare evGetToken(*heval.EVAL_DATA)
Declare evIsSpace(Str.s)
Declare evIsAlpha(Str.s)
Declare evIsDigit(Str.s)
Declare Calc(*heval.EVAL_DATA, Op.s, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
Declare.f LetVar(Var.s,Num.f)
Declare.f GetVar()
Declare.f ClearVars()
Declare IsFunc(Str.s)
Declare IsCommand(Str.s)
;- #PROCEDURES
Procedure evInit(*CalcFunc, param.l)
*heval.EVAL_DATA = AllocateMemory(SizeOf(EVAL_DATA))
*heval\CalcFunc = *CalcFunc
*heval\param = param
ProcedureReturn *heval
EndProcedure
Procedure.s evGetErrorStr(*heval.EVAL_DATA)
ProcedureReturn *heval\ErrorStr
EndProcedure
Procedure evSetOpDelims(*heval.EVAL_DATA, OpDelimiters.s)
*heval\OpDelimiters = OpDelimiters
EndProcedure
Procedure evSetStrDelim(*heval.EVAL_DATA, strDelim.s)
*heval\strDelim = strDelim
EndProcedure
Procedure evSetOps(*heval.EVAL_DATA, OpType.l, OpList.s)
*OpArr.EV_ARR_STR = evMakeOpArr(OpList, @opCount.l)
Select OpType
Case #EV_OT_ARITHMETIC
*heval\AriOps = *OpArr
*heval\MaxAriOps = opCount
Case #EV_OT_RELATIONAL
*heval\RelOps = *OpArr
*heval\MaxRelOps = opCount
Case #EV_OT_LOGICAL
*heval\LogOps = *OpArr
*heval\MaxLogOps = opCount
EndSelect
EndProcedure
Procedure evMakeOpArr(opList.s, *opCount.LONG)
*opCount\l = CountString(opList, ",") + 1
*opArr.EV_ARR_STR = AllocateMemory((SizeOf(STRING) * *opCount\l) + 1)
For iOp=1 To *opCount\l
*opArr\el[iOp] = StringField(opList, iOp, ",")
Next
ProcedureReturn *opArr
EndProcedure
Procedure evIsAriOp(*heval.EVAL_DATA, Op.s)
For iOp=1 To *heval\MaxAriOps
If *heval\AriOps\el[iOp]=Op
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False ;not found
EndProcedure
Procedure evIsRelOp(*heval.EVAL_DATA, Op.s)
For iOp=1 To *heval\MaxRelOps
If *heval\RelOps\el[iOp]=Op
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False ;not found
EndProcedure
Procedure evIsLogOp(*heval.EVAL_DATA, Op.s)
For iOp=1 To *heval\MaxLogOps
If *heval\LogOps\el[iOp]=Op
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False ;not found
EndProcedure
Procedure evIsOp(*heval.EVAL_DATA, Op.s)
If evIsAriOp(*heval, Op) : ProcedureReturn #True
ElseIf evIsRelOp(*heval, Op) : ProcedureReturn #True
ElseIf evIsLogOp(*heval, Op) : ProcedureReturn #True
Else : ProcedureReturn #False
EndIf
EndProcedure
Procedure evFree(*heval.EVAL_DATA)
If *heval\AriOps : FreeMemory(*heval\AriOps) : EndIf
If *heval\RelOps : FreeMemory(*heval\RelOps) : EndIf
If *heval\LogOps : FreeMemory(*heval\LogOps) : EndIf
FreeMemory(*heval)
EndProcedure
Procedure evEval(*heval.EVAL_DATA, Str.s, *Result.VAR_TYPE)
;Entry point into parser
*heval\Progr = 1
*heval\Expr = Str
*heval\ErrPar = 0
*heval\Error = 0
*heval\ErrorStr = ""
If Str=""
*heval\error = #EV_EC_NOEXPR
ProcedureReturn *heval\error
EndIf
If evGetToken(*heval)=0 ;Error
ProcedureReturn *heval\error
EndIf
evLevel1(*heval, *Result)
;Check unbalanced parenthesis
If *heval\ErrPar
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Unbalanced parenthesis"
ProcedureReturn *heval\Error
EndIf
If *heval\OldTtype = #EV_TT_OPERATOR ;Error
*heval\error = #EV_EC_SYNTAX
EndIf
ProcedureReturn *heval\error
EndProcedure
;Assignment statement/command
Procedure evLevel1(*heval.EVAL_DATA, *Result.VAR_TYPE)
Typ.l
Tok.s
If *heval\Ttype = #EV_TT_VARIABLE
;Save old token
Tok = *heval\Token
Typ = *heval\Ttype
evGetToken(*heval)
If *heval\Token="="
;Assignment
evGetToken(*heval)
;ProcedureReturn LetVar(Tok, evLevel2(*heval, *Result))
Else
;Restore
evRewind(*heval)
*heval\Token = Tok
*heval\Ttype = Typ
ProcedureReturn evLevel2(*heval, *Result)
EndIf
ElseIf *heval\Ttype=#EV_TT_COMMAND
If *heval\Token="CLEAR"
;Restore
evRewind(*heval)
*heval\Token = Tok
*heval\Ttype = Typ
ClearVars()
ProcedureReturn 0
EndIf
Else
ProcedureReturn evLevel2(*heval, *Result)
EndIf
EndProcedure
;Logical Ops
Procedure evLevel2(*heval.EVAL_DATA, *Result.VAR_TYPE)
retVal = evLevel3(*heval, *Result)
Op.s = *heval\Token
While evIsLogOp(*heval, Op)
If evGetToken(*heval) And evLevel3(*heval, @Param2.VAR_TYPE)
retVal = CallFunctionFast(*heval\CalcFunc, *heval, @Op, *Result, @Param2, *Result)
EndIf
Op = *heval\Token
Wend
ProcedureReturn retVal
EndProcedure
;Relational Ops
Procedure evLevel3(*heval.EVAL_DATA, *Result.VAR_TYPE)
retVal = evLevel4(*heval, *Result)
Op.s = *heval\Token
While evIsRelOp(*heval, Op)
If evGetToken(*heval) And evLevel4(*heval, @Param2.VAR_TYPE)
retVal = CallFunctionFast(*heval\CalcFunc, *heval, @Op, *Result, @Param2, *Result)
EndIf
Op = *heval\Token
Wend
ProcedureReturn retVal
EndProcedure
;Arithmetic Ops
Procedure evLevel4(*heval.EVAL_DATA, *Result.VAR_TYPE)
retVal = evLevel5(*heval, *Result)
Op.s = *heval\Token
While evIsAriOp(*heval, Op)
If evGetToken(*heval) And evLevel5(*heval, @Param2.VAR_TYPE)
retVal = CallFunctionFast(*heval\CalcFunc, *heval, @Op, *Result, @Param2, *Result)
EndIf
Op = *heval\Token
Wend
ProcedureReturn retVal
EndProcedure
;Functions
Procedure evLevel5(*heval.EVAL_DATA, *Result.VAR_TYPE)
Op.s=""
If *heval\Ttype=#EV_TT_FUNCTION
Op = *heval\Token
evGetToken(*heval)
EndIf
retVal = evLevel6(*heval, *Result)
If Len(Op)
retVal = CallFunctionFast(*heval\CalcFunc, *heval, @Op, *Result, #Null, *Result)
EndIf
ProcedureReturn retVal
EndProcedure
;Parenthesized expression
Procedure evLevel6(*heval.EVAL_DATA, *Result.VAR_TYPE)
If *heval\Ttype=#EV_TT_OPENPAR
evGetToken(*heval)
retVal.l = evLevel1(*heval, *Result)
evGetToken(*heval)
Else
retVal.l = evPrimitive(*heval, *Result)
EndIf
ProcedureReturn retVal
EndProcedure
;Find value of number or variable
Procedure evPrimitive(*heval.EVAL_DATA, *Result.VAR_TYPE)
Select *heval\Ttype
Case #EV_TT_VARIABLE
*Result\vt = #EV_TT_VARIABLE
;Result = GetVar()
evGetToken(*heval)
ProcedureReturn #True
Case #EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER
*Result\LongVal = Val(*heval\Token)
evGetToken(*heval)
ProcedureReturn #True
Case #EV_TT_STRING
*Result\vt = #EV_TT_STRING
*Result\strVal = *heval\Token
evGetToken(*heval)
ProcedureReturn #True
Case #EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT
*Result\FloatVal = ValF(*heval\Token)
evGetToken(*heval)
ProcedureReturn #True
Case #EV_TT_OPERATOR ;Assumed unary operator
;do nothing
ProcedureReturn #True
Default ;Error
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Invalid token"
ProcedureReturn #False
EndSelect
EndProcedure
;Checks if a variable is a number (long, float)
Procedure evIsVTypeNum(*var1.VAR_TYPE)
If *var1\vt = #EV_TT_INTEGER Or *var1\vt = #EV_TT_FLOAT
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
;Checks if two variables are string and number
Procedure evIsStrAndNum(*var1.VAR_TYPE, *var2.VAR_TYPE)
If *var1\vt=#EV_TT_STRING And evIsVTypeNum(*var2)
ProcedureReturn #True
ElseIf *var2\vt=#EV_TT_STRING And evIsVTypeNum(*var1)
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
Procedure CalcMult(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = *var1\LongVal * *var2\LongVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal * *var2\FloatVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal * *var2\LongVal
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\LongVal * *var2\FloatVal
EndIf
EndProcedure
Procedure CalcSum(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If evIsStrAndNum(*var1, *var2) ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_STRING And *var2\vt=#EV_TT_STRING
*Result\vt = #EV_TT_STRING
*Result\strVal = *var1\strVal + *var2\strVal
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER
*Result\LongVal = *var1\LongVal + *var2\LongVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal + *var2\FloatVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal + *var2\LongVal
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\LongVal + *var2\FloatVal
EndIf
EndProcedure
Procedure CalcMod(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = *var1\LongVal % *var2\LongVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Int(*var1\FloatVal) % *var2\LongVal
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = *var1\LongVal % Int(*var2\FloatVal)
EndIf
EndProcedure
Procedure CalcNot(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var2\vt = #EV_TT_INTEGER
If *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
EndIf
ElseIf *var2\vt = #EV_TT_FLOAT
If *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
EndIf
EndIf
EndProcedure
Procedure CalcMinus_Negation(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_EMPTY ;Unary Op, negation
If *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = - *var2\LongVal
ElseIf *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = - *var2\FloatVal
EndIf
Else ;Minus
If *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = *var1\LongVal - *var2\LongVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal - *var2\FloatVal
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\FloatVal - *var2\LongVal
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = *var1\LongVal - *var2\FloatVal
EndIf
EndIf
EndProcedure
Procedure CalcPow(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Pow(*var1\LongVal, *var2\LongVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = Pow(*var1\FloatVal, *var2\FloatVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = Pow(*var1\FloatVal, *var2\LongVal)
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_FLOAT : *Result\FloatVal = Pow(*var1\LongVal, *var2\FloatVal)
EndIf
EndProcedure
Procedure CalcEqual(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt = #EV_TT_STRING And *var2\vt = #EV_TT_STRING
If *var1\strVal=*var2\strVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt = #EV_TT_INTEGER
If *var1\LongVal=*var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
If *var1\FloatVal=*var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf (*var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER) Or (*var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT)
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
Else ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
EndIf
EndProcedure
Procedure CalcNotEqual(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
CalcEqual(*heval, *var1, *var2, @Result2.VAR_TYPE)
If Result2\vt<>#EV_TT_EMPTY ;Ok
If Result2\vt=#EV_TT_INTEGER And Result2\LongVal=#True
*Result\vt=#EV_TT_INTEGER : *Result\LongVal=#False
Else
*Result\vt=#EV_TT_INTEGER : *Result\LongVal=#True
EndIf
Else ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
EndIf
EndProcedure
Procedure CalcOr(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING ;Error
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt = #EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\LongVal Or *var2\LongVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\FloatVal Or *var2\FloatVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\FloatVal Or *var2\LongVal)
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\LongVal Or *var2\FloatVal)
EndIf
EndProcedure
Procedure CalcAnd(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If *var1\vt=#EV_TT_STRING Or *var2\vt=#EV_TT_STRING
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt = #EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\LongVal And *var2\LongVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\FloatVal And *var2\FloatVal)
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\FloatVal And *var2\LongVal)
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = Bool(*var1\LongVal And *var2\FloatVal)
EndIf
EndProcedure
Procedure CalcMajor(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If evIsStrAndNum(*var1, *var2) ;Error
*Result\vt = #EV_TT_EMPTY : *heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
If *var1\LongVal > *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_STRING And *var2\vt=#EV_TT_STRING
If *var1\StrVal > *var2\StrVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
If *var1\FloatVal > *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
If *var1\FloatVal > *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
If *var1\LongVal > *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
EndIf
EndProcedure
Procedure CalcMinor(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If evIsStrAndNum(*var1, *var2) ;Error
*Result\vt = #EV_TT_EMPTY : *heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
If *var1\LongVal < *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_STRING And *var2\vt=#EV_TT_STRING
If *var1\StrVal < *var2\StrVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
If *var1\FloatVal < *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
If *var1\FloatVal < *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
If *var1\LongVal < *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
EndIf
EndProcedure
Procedure CalcMajorEqual(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If evIsStrAndNum(*var1, *var2) ;Error
*Result\vt = #EV_TT_EMPTY : *heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
If *var1\LongVal >= *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_STRING And *var2\vt=#EV_TT_STRING
If *var1\StrVal >= *var2\StrVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
If *var1\FloatVal >= *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
If *var1\FloatVal >= *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
If *var1\LongVal >= *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
EndIf
EndProcedure
Procedure CalcMinorEqual(*heval.EVAL_DATA, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
If evIsStrAndNum(*var1, *var2) ;Error
*Result\vt = #EV_TT_EMPTY : *heval\Error = #EV_EC_INVALIDTYPES
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_INTEGER
If *var1\LongVal <= *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_STRING And *var2\vt=#EV_TT_STRING
If *var1\StrVal <= *var2\StrVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_FLOAT
If *var1\FloatVal <= *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_FLOAT And *var2\vt=#EV_TT_INTEGER
If *var1\FloatVal <= *var2\LongVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
ElseIf *var1\vt=#EV_TT_INTEGER And *var2\vt=#EV_TT_FLOAT
If *var1\LongVal <= *var2\FloatVal
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #True
Else
*Result\vt = #EV_TT_INTEGER : *Result\LongVal = #False
EndIf
EndIf
EndProcedure
Procedure Calc(*heval.EVAL_DATA, Op.s, *var1.VAR_TYPE, *var2.VAR_TYPE, *Result.VAR_TYPE)
;Debug "CALC"
;Debug Str(*var1\vt) + " " + Op + " " + Str(*var2\vt)
If *var1\vt=#EV_TT_VARIABLE Or *var2\vt=#EV_TT_VARIABLE
*Result\vt = #EV_TT_EMPTY
*heval\Error = #EV_EC_NOTSUPPORTED
*heval\ErrorStr = "Variables not supported yet"
ProcedureReturn #False
Else
Select Op
Case "*" : CalcMult(*heval, *var1, *var2, *Result)
Case "!" : CalcNot(*heval, *var1, *var2, *Result)
Case "^" : CalcPow(*heval, *var1, *var2, *Result)
Case "mod" : CalcMod(*heval, *var1, *var2, *Result)
Case "==" : CalcEqual(*heval, *var1, *var2, *Result)
Case "<>" : CalcNotEqual(*heval, *var1, *var2, *Result)
Case "|" : CalcOr(*heval, *var1, *var2, *Result)
Case "&" : CalcAnd(*heval, *var1, *var2, *Result)
Case ">" : CalcMajor(*heval, *var1, *var2, *Result)
Case "<" : CalcMinor(*heval, *var1, *var2, *Result)
Case ">=" : CalcMajorEqual(*heval, *var1, *var2, *Result)
Case "<=" : CalcMinorEqual(*heval, *var1, *var2, *Result)
Case "+" : CalcSum(*heval, *var1, *var2, *Result)
Case "-" : CalcMinus_Negation(*heval, *var1, *var2, *Result)
EndSelect
ProcedureReturn #True
EndIf
EndProcedure
;Back up to the previous token
Procedure evRewind(*heval.EVAL_DATA)
*heval\Progr = *heval\Progr - Len(*heval\Token)
EndProcedure
;Assign a value to a variable
Procedure.f LetVar(Var.s,Num.f)
I=0
While Len(VarNames(I))
If Var=VarNames(I)
Vars(I)=Num
ProcedureReturn Num
EndIf
I+1
Wend
VarNames(I)=Var
Vars(I)=Num
ProcedureReturn Num
EndProcedure
;Procedure.f GetVar()
;;Find value of a variable
; I=0
; While Len(VarNames(I))
; If Token=VarNames(I)
; ProcedureReturn Vars(I)
; EndIf
; I+1
; Wend
; LetVar(Token,0)
; ProcedureReturn GetVar()
;EndProcedure
Procedure.f ClearVars()
;Clears variable names and values:
For I=0 To #MAXVARS-1
Vars(I)=0
VarNames(I)=""
Next
EndProcedure
;Get the next token/token type in expression
Procedure evGetToken(*heval.EVAL_DATA)
OldToken.s = *heval\Token
*heval\OldTtype = *heval\Ttype ;save old type
*heval\Ttype = 0
*heval\Token = ""
Result.l = 0
If *heval\Progr>Len(*heval\Expr)
ProcedureReturn 0
EndIf
While evIsSpace(Mid(*heval\Expr, *heval\Progr, 1))
*heval\Progr + 1
Wend
FirstChar$ = Mid(*heval\Expr, *heval\Progr, 1)
;Debug FirstChar$
;Parenth, sets ( or ) in Token
If FirstChar$="("
*heval\Ttype = #EV_TT_OPENPAR
*heval\Token = FirstChar$
*heval\Progr+1
*heval\ErrPar + 1
ElseIf FirstChar$=")"
*heval\Ttype = #EV_TT_CLOSEPAR
*heval\Token = FirstChar$
*heval\Progr+1
*heval\ErrPar - 1
;OpDelim, sets Op in Token
ElseIf evIsOpDelim(*heval, FirstChar$) ;does not include ',),(
*heval\Ttype = #EV_TT_OPERATOR
While evIsOpDelim(*heval, Mid(*heval\Expr, *heval\Progr, 1))
*heval\Token + Mid(*heval\Expr, *heval\Progr, 1)
*heval\Progr+1
Wend
If evIsOp(*heval, *heval\Token)=0 ;Invalid Op
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Invalid operator"
ProcedureReturn #False
EndIf
;Debug *heval\Token
ElseIf evIsAlpha(FirstChar$)
While evNotDelim(*heval, Mid(*heval\Expr, *heval\Progr, 1)) ;delims include ',),(
*heval\Token + Mid(*heval\Expr, *heval\Progr, 1)
*heval\Progr + 1
Wend
If IsFunc(*heval\Token)
*heval\Ttype = #EV_TT_FUNCTION
ElseIf evIsOp(*heval, *heval\Token)
*heval\Ttype = #EV_TT_OPERATOR
ElseIf IsCommand(*heval\Token)
*heval\Ttype = #EV_TT_COMMAND
Else
*heval\Ttype = #EV_TT_VARIABLE
EndIf
;Digit
ElseIf evIsDigit(FirstChar$)
While evIsDigit(Mid(*heval\Expr, *heval\Progr, 1))
*heval\Token + Mid(*heval\Expr, *heval\Progr, 1)
*heval\Progr + 1
Wend
If evIsFloat(*heval\Token)
*heval\Ttype = #EV_TT_FLOAT
Else
*heval\Ttype = #EV_TT_INTEGER
EndIf
;Debug *heval\Token
;String
ElseIf FirstChar$=*heval\strDelim
*heval\Ttype = #EV_TT_STRING
strStart.l = *heval\Progr
*heval\Progr + 1 ;skip 1st
While #True
char$ = Mid(*heval\Expr, *heval\Progr, 1)
;Debug char$
If char$=""
strEnd = *heval\Progr
Break
ElseIf char$<>*heval\strDelim
*heval\Token + char$
ElseIf char$=*heval\strDelim ;check for double delimiter
If Mid(*heval\Expr, *heval\Progr + 1, 1)=*heval\strDelim
*heval\Token + *heval\strDelim
*heval\Progr + 1
Else
strEnd = *heval\Progr
*heval\Progr + 1
Break
EndIf
Else
strEnd = *heval\Progr
*heval\Progr + 1
Break
EndIf
*heval\Progr + 1
Wend
;Check for unbalanced string delim
If strEnd > Len(*heval\Expr)
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Unbalanced string delimiter"
ProcedureReturn #False
EndIf
EndIf
; Debug *heval\OldTtype
; Debug *heval\Ttype
; Debug *heval\Token
;Syntax checker
If *heval\OldTtype=#EV_TT_CLOSEPAR And *heval\Ttype<>#EV_TT_OPERATOR And *heval\Ttype<>#EV_TT_CLOSEPAR ;Op expected
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Operator expected"
ProcedureReturn #False
ElseIf (*heval\OldTtype=#EV_TT_STRING Or *heval\OldTtype=#EV_TT_INTEGER)
If *heval\Ttype<>#EV_TT_OPERATOR And *heval\Ttype<>#EV_TT_CLOSEPAR
*heval\Error = #EV_EC_SYNTAX
*heval\ErrorStr = "Operator or ) expected"
ProcedureReturn #False
EndIf
EndIf
ProcedureReturn #True
EndProcedure
Procedure IsFunc(Str.s)
For I=0 To #MAXFNC-1
If Str = Fnc(I)
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False
EndProcedure
Procedure IsCommand(Str.s)
For I=0 To #MAXCMD-1
If Str=Cmd(I)
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False
EndProcedure
;Is op delimiter
Procedure evIsOpDelim(*heval.EVAL_DATA, Str.s)
If FindString(*heval\OpDelimiters, Str, 1) And Str<>""
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
Procedure evNotDelim(*heval.EVAL_DATA, Str.s)
If FindString(*heval\OpDelimiters + "() " + *heval\strDelim + Chr(9), Str, 1) Or Str=""
ProcedureReturn #False
Else
ProcedureReturn #True
EndIf
EndProcedure
Procedure evIsAlpha(Str.s)
If Str And FindString("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", Str, 1)
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
Procedure evIsDigit(Str.s)
If Str And FindString(".0123456789", Str, 1)
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
;Checks if a number is float
Procedure evIsFloat(num$)
If num$ And FindString(num$, ".", 1) : ProcedureReturn #True
Else : ProcedureReturn #False : EndIf
EndProcedure
Procedure evIsSpace(Str.s)
If ((Str=" ") Or (Str=Chr(9))) And (Str<>"")
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
;- #TEST
heval = evInit(@Calc(), 0)
evSetOpDelims(heval, "&|<>+/*^=-!") ;Operator delimiters
evSetStrDelim(heval, "'") ;String delimiter, only 1 char
;Setting operators
evSetOps(heval, #EV_OT_ARITHMETIC, "+,-,mod,*,/,^")
evSetOps(heval, #EV_OT_RELATIONAL, "<,>,<>,<=,>=,==")
evSetOps(heval, #EV_OT_LOGICAL, "&,|,!")
Exp$ = "(4==4 | 4==3) & 1==1"
Exp$ = "'a''' + 'b''''' + 'c'"
Exp$ = "('a''B''' + 'b') + 'cd'"
Exp$ = "(4 + 3) - 2"
Exp$ = "!(5==3 | 4==4)"
Exp$ = "3 ^ 3 ^ 3"
Exp$ = "!((5==2 | 4==4) & 3==3)"
Exp$ = "5mod(-(-3))"
Exp$ = "a + 3"
Exp$ = "-(-5+2) * (-1)" ;Invalid syntax
Exp$ = "(-(-5+2)) * (-1)" ;OK
Exp$ = "-3+4"
Exp$ = "-3+4 >= 2"
Exp$ = "'aab' <= 'ab'"
Exp$ = "'aab' - 'ab'"
Exp$ = "-(-(-3))"
r = evEval(heval, Exp$, @Result.VAR_TYPE)
If r<>0 ;error
Debug "Error: " + Str(r)
Debug evGetErrorStr(heval)
Else
Debug "Result:"
If Result\vt = #EV_TT_INTEGER
Debug Result\LongVal
ElseIf Result\vt = #EV_TT_STRING
Debug Result\strVal
ElseIf Result\vt = #EV_TT_FLOAT
Debug Result\FloatVal
EndIf
EndIf
evFree(heval)
Debug "END"