# How to make formula programmable ?

Dear Sir,
How to let user define formula for their own?
For Example:
S=@Price  P=Profit% F=Freight% I=Insurance% C=Commision%. These vars are not changeable, user can set values of their own.

The formula can be defined by user as:
(S*(1+P)+F)*(1+I)  or (S/(1-P)+F)/(1-I)/(1-C) or (S*(1+P)+F)*(1+C) or .......... (as they wish)

###### Who is Participating?

If your looking for something a little smaller for math parsing, you can use the following code

Russell

---

example usage:

var  dblResult:     Double;
begin

// Set variables
//    S=@Price  P=Profit% F=Freight% I=Insurance% C=Commision%
//
SetVar('S', 120.99);
SetVar('P', 45.99);
SetVar('F', 5.99);
SetVar('I', 1.20);
SetVar('C', 3.45);

// Evaluate expressions
if Evaluate('(S*(1+P)+F)*(1+I)', dblResult) then ShowMessage(FloatToStr(dblResult));
if Evaluate('(S/(1-P)+F)/(1-I)/(1-C)', dblResult) then ShowMessage(FloatToStr(dblResult));
if Evaluate('(S*(1+P)+F)*(1+C)', dblResult) then ShowMessage(FloatToStr(dblResult));

end;

--- Eval.pas ---

unit Eval;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  EVAL
//   Classes     :  TEvalExpr
//   Author      :  rllibby
//   Date        :  02.17.2004
//
//   Description :  Numeric expression parser with support for variables A-Z.
//                  All data is treated as double type, and support for common
//                  functions such as Cos, Sin, Tan, etc have also been included.
//
////////////////////////////////////////////////////////////////////////////////
interface

////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
Windows, SysUtils, Classes;

////////////////////////////////////////////////////////////////////////////////
//   Node definitions for hashing elements
////////////////////////////////////////////////////////////////////////////////
type
PHashNode         =  ^THashNode;
THashNode         =  packed record
Item:          PChar;
Data:          Pointer;
Next:          PHashNode;
end;

////////////////////////////////////////////////////////////////////////////////
//   Hashing constants
////////////////////////////////////////////////////////////////////////////////
const
HASH_SIZE         =  521;

////////////////////////////////////////////////////////////////////////////////
//   Callback for optional freeing of the data items
////////////////////////////////////////////////////////////////////////////////
type
THashDeallocator  =  procedure(Sender: TObject; P: Pointer) of object;

////////////////////////////////////////////////////////////////////////////////
//   Hash class definition
////////////////////////////////////////////////////////////////////////////////
type
THash             =  class(TObject)
private
// Private declarations
FHash:         Array [0..Pred(HASH_SIZE)] of PHashNode;
FDeallocator:  THashDeallocator;
FCareCase:     Boolean;
FCount:        Integer;
protected
// Protected declarations
function       NewNode(Item: PChar; Data: Pointer): PHashNode;
public
// Public declarations
constructor    Create(Deallocator: THashDeallocator = nil);
destructor     Destroy; override;
procedure      Clear;
function       Delete(Item: PChar): Boolean;
function       Extract(Item: PChar; out Data: Pointer): Boolean;
function       Add(Item: PChar; Data: Pointer): Boolean;
function       Find(Item: PChar; out Data: Pointer): Boolean;
property       CaseSensitive: Boolean read FCareCase write FCareCase;
end;

////////////////////////////////////////////////////////////////////////////////
//   Hashing functions
////////////////////////////////////////////////////////////////////////////////
function   HashFunc(Key: PChar; CareCase: Boolean): Integer;
function   HashCompare(Item1, Item2: PChar; CareCase: Boolean): Boolean;

////////////////////////////////////////////////////////////////////////////////
//   Assembly opcodes for expression evaluation
////////////////////////////////////////////////////////////////////////////////
const
// Operations requiring 2 numbers
OP_EQ             =  01;
OP_LEQ            =  02;
OP_GEQ            =  03;
OP_LT             =  04;
OP_GT             =  05;
OP_NEQ            =  06;
OP_SUB            =  08;
OP_DIV            =  09;
OP_MULT           =  10;
OP_MOD            =  11;
OP_OR             =  12;
OP_XOR            =  13;
OP_AND            =  14;
OP_SHL            =  15;
OP_SHR            =  16;
// Operations requiring 1 number
OP_NEG            =  17;
OP_NOT            =  18;
OP_ABS            =  19;
OP_SIN            =  20;
OP_COS            =  21;
OP_TAN            =  22;
OP_ATAN           =  23;
OP_EXP            =  24;
OP_SQRT           =  25;
OP_INT            =  26;
// Special
OP_PI             =  27;
OP_MI             =  28;
OP_MW             =  29;
OP_MB             =  30;
OP_LVN            =  31;
OP_LCN            =  32;

////////////////////////////////////////////////////////////////////////////////
//   Max limits for structures
////////////////////////////////////////////////////////////////////////////////
const
MAX_NUM           =  32;
MAX_STACK         =  64;
MAX_ASM           =  124;

////////////////////////////////////////////////////////////////////////////////
//   Token constants for parsing
////////////////////////////////////////////////////////////////////////////////
type
TEvalToken        =  (tokEq,     tokLeq,  tokLt,   tokGeq,  tokGt,   tokNeq,
tokAdd,    tokSub,  tokDiv,  tokMult, tokMod,  tokOr,
tokAnd,    tokXor,  tokNot,  tokShl,  tokShr,  tokAbs,
tokSin,    tokCos,  tokTan,  tokAtan, tokVar,  tokLp,
tokRp,     tokExp,  tokNum,  tokSqrt, tokInt,  tokPi,
tokMi,     tokMw,   tokMb,   tokEnd);

////////////////////////////////////////////////////////////////////////////////
//   Evaluation stack data type
////////////////////////////////////////////////////////////////////////////////
type
TEvalStack        =  Array [0..Pred(MAX_STACK)] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Data space for constants
////////////////////////////////////////////////////////////////////////////////
type
TEvalConsts       =  Array [0..Pred(MAX_NUM)] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Psuedo assembly instruction and program space definition
////////////////////////////////////////////////////////////////////////////////
type
TEvalAsm          =  packed record
cbAL:          Byte;
cbDL:          Byte;
end;
TEvalPgm          =  Array [0..Pred(MAX_ASM)] of TEvalAsm;

////////////////////////////////////////////////////////////////////////////////
//   Token parser data type
////////////////////////////////////////////////////////////////////////////////
type
TEvalParse        =  packed record
etIdent:       TEvalToken;
cbVar:         Byte;
dblVal:        Double;
end;

////////////////////////////////////////////////////////////////////////////////
//   Compiled expression type
////////////////////////////////////////////////////////////////////////////////
type
TEvalCompile      =  packed record
cbAsm:         Integer;
epAsm:         TEvalPgm;
cbConsts:      Integer;
ecConsts:      TEvalConsts;
end;

////////////////////////////////////////////////////////////////////////////////
//   Exception class for evaluation
////////////////////////////////////////////////////////////////////////////////
type
EEvalException    =  class(Exception);

////////////////////////////////////////////////////////////////////////////////
//   Resource strings for exceptions
////////////////////////////////////////////////////////////////////////////////
resourcestring
SUnexpected       =  'Unexpected character encountered';
SInvalidIdent     =  'Invalid identifier encountered';
SInvalidNum       =  'Invalid number';
SAsmOverflow      =  'Too many operations for a single expression';
SNumOverflow      =  'Too many constant numbers for a single expression';
SCloseParen       =  'Closing parentheses missing';
SOpenParen        =  'Open parentheses missing';
SSyntaxError      =  'Syntax error in expression';
SUnderflow        =  'Stack underflow';
SOverflow         =  'Stack overflow';

////////////////////////////////////////////////////////////////////////////////
//   Expression evaluator class
////////////////////////////////////////////////////////////////////////////////
type
TExprEval         =  class(TObject)
private
// Private declarations
FExpression:   PChar;
FParse:        PChar;
FCompiled:     TEvalCompile;
FToken:        TEvalParse;
protected
// Protected declarations
function       StoreConst(dblVal: Double): Byte;
procedure      GenOpCode(cbAL, cbDL: Byte);
procedure      Parse;
procedure      ParseNext;
procedure      ParseLevel1;
procedure      ParseLevel2;
procedure      ParseLevel3;
procedure      ParseLevel4;
public
// Public declarations
constructor    Create(Expression: PChar);
destructor     Destroy; override;
function       Evaluate: Double;
end;

////////////////////////////////////////////////////////////////////////////////
//   Variable class for use in expression evaluation
////////////////////////////////////////////////////////////////////////////////
type
TVariables        =  Array ['A'..'Z'] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Functions for expression handling
////////////////////////////////////////////////////////////////////////////////
function   Evaluate(lpszExpression: PChar; var Value: Double): Boolean;
function   GetVar(Variable: Char; var Value: Double): Boolean;
function   SetVar(Variable: Char; Value: Double): Boolean;
function   LastEvalError: PChar;
procedure  ClearVars;

implementation

////////////////////////////////////////////////////////////////////////////////
//   Protected variables
////////////////////////////////////////////////////////////////////////////////
var
hshIdent:         THash;
lpVars:           TVariables;
lpError:          Array [0..255] of Char;

function TExprEval.Evaluate: Double;
var  esStack:       TEvalStack;
dwCount:       Integer;
dwOffset:      Integer;
dwStack:       Integer;
begin

// Clear the stack
dwStack:=0;

// Start executing the instructions
for dwCount:=0 to Pred(FCompiled.cbAsm) do
begin
// Get the instruction and offset
case FCompiled.epAsm[dwCount].cbAL of
// 2 number ops
OP_EQ..OP_SHR     :
begin
// Check stack for underflow
if (dwStack < 2) then raise EEvalException.CreateRes(@SUnderflow);
// Decrement the stack count
Dec(dwStack);
dwOffset:=Pred(dwStack);
// Perform the operation
case FCompiled.epAsm[dwCount].cbAL of
OP_EQ    :  esStack[dwOffset]:=Integer(esStack[dwOffset] = esStack[dwStack]);
OP_LEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] <= esStack[dwStack]);
OP_GEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] >= esStack[dwStack]);
OP_LT    :  esStack[dwOffset]:=Integer(esStack[dwOffset] < esStack[dwStack]);
OP_GT    :  esStack[dwOffset]:=Integer(esStack[dwOffset] > esStack[dwStack]);
OP_NEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] <> esStack[dwStack]);
OP_SUB   :  esStack[dwOffset]:=esStack[dwOffset] - esStack[dwStack];
OP_DIV   :  esStack[dwOffset]:=esStack[dwOffset] / esStack[dwStack];
OP_MULT  :  esStack[dwOffset]:=esStack[dwOffset] * esStack[dwStack];
OP_MOD   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) mod Trunc(esStack[dwStack]);
OP_OR    :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) or Trunc(esStack[dwStack]);
OP_XOR   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) xor Trunc(esStack[dwStack]);
OP_AND   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) and Trunc(esStack[dwStack]);
OP_SHL   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) shl Trunc(esStack[dwStack]);
OP_SHR   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) shr Trunc(esStack[dwStack]);
end;
end;
// Operation on current stack item
OP_NEG..OP_INT    :
begin
// Check stack for underflow
if (dwStack < 1) then raise EEvalException.CreateRes(@SUnderflow);
dwOffset:=Pred(dwStack);
// Perform the operation
case FCompiled.epAsm[dwCount].cbAL of
OP_NEG   :  esStack[dwOffset]:=esStack[dwOffset] * -1;
OP_NOT   :  esStack[dwOffset]:=not(Trunc(esStack[dwOffset]));
OP_ABS   :  esStack[dwOffset]:=Abs(esStack[dwOffset]);
OP_SIN   :  esStack[dwOffset]:=Sin(esStack[dwOffset]);
OP_COS   :  esStack[dwOffset]:=Cos(esStack[dwOffset]);
OP_TAN   :  esStack[dwOffset]:=Sin(esStack[dwOffset]) / Cos(esStack[dwOffset]);
OP_ATAN  :  esStack[dwOffset]:=ArcTan(esStack[dwOffset]);
OP_EXP   :  esStack[dwOffset]:=Exp(esStack[dwOffset]);
OP_SQRT  :  esStack[dwOffset]:=Sqrt(esStack[dwOffset]);
OP_INT   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]);
end;
end;
// Special
OP_PI,
OP_MI,
OP_MW,
OP_MB             :
begin
// Push special value on the stack
case FCompiled.epAsm[dwCount].cbAL of
OP_PI    :  esStack[dwStack]:=pi;
OP_MI    :  esStack[dwStack]:=MaxInt;
OP_MW    :  esStack[dwStack]:=MaxWord;
OP_MB    :  esStack[dwStack]:=MaxByte;
end;
// Increment the stack
Inc(dwStack);
// Check stack overflow
if (dwStack > Pred(MAX_STACK)) then raise EEvalException.CreateRes(@SOverflow);
end;
OP_LVN..OP_LCN    :
begin
// Get the index for the item
dwOffset:=FCompiled.epAsm[dwCount].cbDL;
// Load either global var or constant number
case FCompiled.epAsm[dwCount].cbAL of
OP_LVN   :  esStack[dwStack]:=lpVars[Chr(65+dwOffset)];
OP_LCN   :  esStack[dwStack]:=FCompiled.ecConsts[dwOffset];
end;
// Increment the stack
Inc(dwStack);
// Check stack overflow
if (dwStack > Pred(MAX_STACK)) then raise EEvalException.CreateRes(@SOverflow);
end;
end;
end;

// Stack count should be one at this stage
if (dwStack = 1) then
// Push the item from the stack
result:=esStack[0]
else
result:=0;

end;

procedure TExprEval.ParseLevel4;
var  etIdent:       TEvalToken;
begin

// Low level expression evaluator
case FToken.etIdent of
// Negate
tokSub      :
begin
// Seed the next token
ParseNext;
// Build factor
ParseLevel4;
// Generate code for negate
GenOpCode(OP_NEG, 0);
end;
tokVar      :
begin
// Generate code to load the variable
GenOpCode(OP_LVN, FToken.cbVar);
// Seed the next token
ParseNext;
end;
tokNum      :
begin
// Store the number in the static data table
FToken.cbVar:=StoreConst(FToken.dblVal);
// Generate code to push constant number stored in code
GenOpCode(OP_LCN, FToken.cbVar);
// Seed the next token
ParseNext;
end;
// Left paren
tokLp       :
begin
// Seed the next token
ParseNext;
// Build the sub expression
ParseLevel1;
// Better be sitting at a right paren
if (FToken.etIdent <> tokRp) then raise EEvalException.CreateRes(@SCloseParen);
// Seed the next token
ParseNext;
end;
// Single parameter functions
tokNot,
tokAbs,
tokSin,
tokCos,
tokTan,
tokAtan,
tokExp,
tokSqrt,
tokInt      :
begin
// Hold the token identifier
etIdent:=FToken.etIdent;
// Seed next token
ParseNext;
// Check open parens
if (FToken.etIdent <> tokLp) then raise EEvalException.CreateRes(@SOpenParen);
// Seed next token
ParseNext;
// Build numeric expression
ParseLevel1;
// Better be sitting at a right paren
if (FToken.etIdent <> tokRp) then raise EEvalException.CreateRes(@SCloseParen);
// Seed the next token
ParseNext;
// Generate code
case etIdent of
tokNot   :  GenOpCode(OP_NOT, 0);
tokAbs   :  GenOpCode(OP_ABS, 0);
tokSin   :  GenOpCode(OP_SIN, 0);
tokCos   :  GenOpCode(OP_COS, 0);
tokTan   :  GenOpCode(OP_TAN, 0);
tokAtan  :  GenOpCode(OP_ATAN, 0);
tokExp   :  GenOpCode(OP_EXP, 0);
tokSqrt  :  GenOpCode(OP_SQRT, 0);
tokInt   :  GenOpCode(OP_INT, 0);
end;
end;
// Special
tokPi,
tokMi,
tokMw,
tokMb       :
begin
// Generate code
case FToken.etIdent of
tokPi    :  GenOpCode(OP_PI, 0);
tokMi    :  GenOpCode(OP_MI, 0);
tokMw    :  GenOpCode(OP_MW, 0);
tokMb    :  GenOpCode(OP_MB, 0);
end;
// Seed the next token
ParseNext;
end;
else
// Syntax error
raise EEvalException.CreateRes(@SSyntaxError);
end;

end;

procedure TExprEval.ParseLevel3;
var  etIdent:       TEvalToken;
begin

// Build factor
ParseLevel4;

// Handle /, *, %, >>, <<, and
while (FToken.etIdent in [tokMult, tokDiv, tokMod, tokShr, tokShl, tokAnd]) do
begin
// Hold the identifier
etIdent:=FToken.etIdent;
// Seed the next token
ParseNext;
// Build factor
ParseLevel4;
// Generate code
case etIdent of
tokMult  :  GenOpCode(OP_MULT, 0);
tokDiv   :  GenOpCode(OP_DIV, 0);
tokMod   :  GenOpCode(OP_MOD, 0);
tokShl   :  GenOpCode(OP_SHL, 0);
tokShr   :  GenOpCode(OP_SHR, 0);
tokAnd   :  GenOpCode(OP_AND, 0);
end;
end;

end;

procedure TExprEval.ParseLevel2;
var  etIdent:       TEvalToken;
begin

// Handle + and - numbers
if (FToken.etIdent in [tokAdd, tokSub]) then
begin
// Hold the identifier
etIdent:=FToken.etIdent;
// Seed the next token
ParseNext;
// Build term
ParseLevel3;
// Generate code for negate
if (etIdent = tokSub) then GenOpCode(OP_NEG, 0);
end
else
// Build term
ParseLevel3;

// Handle +, -, or, xor
while (FToken.etIdent in [tokAdd, tokSub, tokOr, tokXor]) do
begin
// Hold the identifier
etIdent:=FToken.etIdent;
// Seed the next token
ParseNext;
// Build next term
ParseLevel3;
// Generate code
case etIdent of
tokSub   :  GenOpCode(OP_SUB, 0);
tokOr    :  GenOpCode(OP_OR, 0);
tokXor   :  GenOpCode(OP_XOR, 0);
end;
end;

end;

procedure TExprEval.ParseLevel1;
var  etIdent:       TEvalToken;
begin

// Build a simple expression
ParseLevel2;

// What kind of token?
if (FToken.etIdent in [tokEq, tokNeq, tokLeq, tokLt, tokGeq, tokGt]) then
begin
// Save the identifier
etIdent:=FToken.etIdent;
// Seed the next token
ParseNext;
// Build another simple expression
ParseLevel2;
// Generate asm code
case etIdent of
tokEq    :  GenOpCode(OP_EQ, 0);
tokLt    :  GenOpCode(OP_LT, 0);
tokLeq   :  GenOpCode(OP_LEQ, 0);
tokGt    :  GenOpCode(OP_GT, 0);
tokGeq   :  GenOpCode(OP_GEQ, 0);
tokNeq   :  GenOpCode(OP_NEQ, 0);
end;
end;

end;

procedure TExprEval.Parse;
var  lpszMark:      PChar;
begin

// Lock the parse point
lpszMark:=FParse;

// Seed the first token
ParseNext;

// Check for "=" and allow it, example: " = 5.4 + 3"
if (FToken.etIdent = tokEq) then
// Ignore the extraneous equal symbol
ParseNext
else
begin
// Need to check for an assignment operation
if (FToken.etIdent = tokVar) then
begin
// Parse next

end;
end;

// Repeat until we get to the end of the expression
while (FToken.etIdent <> tokEnd) do ParseLevel1;

end;

procedure TExprEval.ParseNext;
var  lpszIdent:  PChar;
lpIdent:    Pointer;
dwError:    Integer;
cMark:      Char;
begin

// Clear the current token
ZeroMemory(@FToken, SizeOf(TEvalParse));

// Check current parse point
if (FParse = nil) or (FParse^ = #0) then
// End of expression
FToken.etIdent:=tokEnd
else
begin
// Skip white space
while (FParse^ in [#9, #10, #13, #32]) do Inc(FParse);
// Get next token
case FParse^ of
// End of expression
#0       :  FToken.etIdent:=tokEnd;
// Mod
'%'      :  FToken.etIdent:=tokMod;
// Left paren
'('      :  FToken.etIdent:=tokLp;
// Right paren
')'      :  FToken.etIdent:=tokRp;
// Multiply
'*'      :  FToken.etIdent:=tokMult;
// Subtract
'-'      :  FToken.etIdent:=tokSub;
// Divide
'/'      :  FToken.etIdent:=tokDiv;
'0'..'9' :
begin
// Hold the identifier start
lpszIdent:=FParse;
// Find the end of the number, or a period
while (FParse^ in ['.', '0'..'9']) do Inc(FParse);
// Hold the current char and mark
cMark:=FParse^;
FParse^:=#0;
// Convert to number
FToken.etIdent:=tokNum;
Val(lpszIdent, FToken.dblVal, dwError);
// Check conversion
if (dwError > 0) then raise EEvalException.CreateRes(@SInvalidNum);
// Reset the mark point and skip back one in the parse stream
FParse^:=cMark;
Dec(FParse);
end;
// Less than
'<'      :
begin
// Move to next char in stream
Inc(FParse);
// Check next character
case FParse^ of
// Less than equals
'='   :  FToken.etIdent:=tokLeq;
// Not equals
'>'   :  FToken.etIdent:=tokNeq;
// Shift left
'<'   :  FToken.etIdent:=tokShl;
else
// Less than
FToken.etIdent:=tokLt;
Dec(FParse);
end;
end;
// Equals
'='      :  FToken.etIdent:=tokEq;
// Greater than
'>'      :
begin
// Move to next char in stream
Inc(FParse);
// Check next character
case FParse^ of
// Greater than equals
'='   :  FToken.etIdent:=tokGeq;
// Shift right
'>'   :  FToken.etIdent:=tokShr;
else
// Greater than
FToken.etIdent:=tokGt;
Dec(FParse);
end;
end;
// Identifier
'A'..'Z',
'a'..'z' :
begin
// Hold the identifier start
lpszIdent:=FParse;
// Find the end of the identifier
while (FParse^ in ['A'..'Z', 'a'..'z']) do Inc(FParse);
// Hold the current char and mark
cMark:=FParse^;
FParse^:=#0;
// Check identifier
if (StrLen(lpszIdent) = 1) then
begin
// This is a variable
lpszIdent^:=UpCase(lpszIdent^);
FToken.etIdent:=tokVar;
FToken.cbVar:=Byte(lpszIdent^)-Byte('A');
end
else
begin
// Has to be an identifier
if hshIdent.Find(lpszIdent, lpIdent) then
// Found in hash table
FToken.etIdent:=TEvalToken(lpIdent)
else
// Invalid identifier
raise EEvalException.CreateRes(@SInvalidIdent);
end;
// Reset the mark point and skip back one in the parse stream
FParse^:=cMark;
Dec(FParse);
end;
else
// Invalid chararcter
raise EEvalException.CreateRes(@SUnexpected);
end;
// Push next in parse stream
Inc(FParse);
end;

end;

function TExprEval.StoreConst(dblVal: Double): Byte;
begin

// Store the constant number
FCompiled.ecConsts[FCompiled.cbConsts]:=dblVal;

// Return the index of the constant that was added
result:=FCompiled.cbConsts;

// Increment the const counter
Inc(FCompiled.cbConsts);

// Check for overflow
if (FCompiled.cbConsts >= MAX_NUM) then raise EEvalException.CreateRes(@SNumOverflow);

end;

procedure TExprEval.GenOpCode(cbAL, cbDL: Byte);
begin

// Add the next assembly instruction
FCompiled.epAsm[FCompiled.cbAsm].cbAL:=cbAL;
FCompiled.epAsm[FCompiled.cbAsm].cbDL:=cbDL;

// Increment the instruction
Inc(FCompiled.cbAsm);

// Check for overflow
if (FCompiled.cbAsm >= MAX_ASM) then raise EEvalException.CreateRes(@SAsmOverflow);

end;

constructor TExprEval.Create(Expression: PChar);
begin

// Perform inherited
inherited Create;

// Clear the internal structures
ZeroMemory(@FCompiled, SizeOf(TEvalCompile));
ZeroMemory(@FToken, SizeOf(TEvalParse));

// Copy the expression over and set parse point
FExpression:=StrCopy(AllocMem(Succ(StrLen(Expression))), Expression);
FParse:=FExpression;

// Parse
Parse;

end;

destructor TExprEval.Destroy;
begin

// Clean up
FreeMem(FExpression);

// Perform inherited
inherited Destroy;

end;

function LastEvalError: PChar;
begin

// Return the last error string
result:=@lpError;

end;

function Evaluate(lpszExpression: PChar; var Value: Double): Boolean;
begin

// Creates a one shot evaluation object to handle the compilation and execution
try
// Clear the error string
ZeroMemory(@lpError, SizeOf(lpError));
// Create object
with TExprEval.Create(lpszExpression) do
begin
// Perform the evaluation
Value:=Evaluate;
// Done
Free;
end;
// Success
result:=True;
except
// Catch exceptions
on E: Exception do
begin
// Copy the exception error message
StrPCopy(@lpError, E.Message);
// Failure
result:=False;
end;
end;

end;

procedure ClearVars;
begin

// Clear all variables
ZeroMemory(@lpVars, SizeOf(TVariables));

end;

function GetVar(Variable: Char; var Value: Double): Boolean;
begin

// Range check
result:=(UpCase(Variable) in ['A'..'Z']);

// Return value if success
if result then Value:=lpVars[UpCase(Variable)];

end;

function SetVar(Variable: Char; Value: Double): Boolean;
begin

// Range check
result:=(UpCase(Variable) in ['A'..'Z']);

// Set variable if success
if result then lpVars[UpCase(Variable)]:=Value;

end;

function HashCompare(Item1, Item2: PChar; CareCase: Boolean): Boolean;
begin

// Null assignment checks
if (Item1 = nil) then
// Check for Item2 being nil
result:=(Item2 = nil)
else if (Item2 = nil) then
// Item1 is not null, so no possible match
result:=False
// Check case
else if CareCase then
// Case sensitive compare
result:=(StrComp(Item1, Item2) = 0)
else
// In-case sensitive compare
result:=(StrIComp(Item1, Item2) = 0);

end;

function HashFunc(Key: PChar; CareCase: Boolean): Integer;
var  bChar:         Byte;
begin

// Set starting result
result:=0;

// Generate hash index for key
while (Key^ > #0) do
begin
if CareCase then
bChar:=Byte(Key^)
else if (Key^ in ['A'..'Z']) then
bChar:=Byte(Key^)+32
else
bChar:=Byte(Key^);
Inc(result, (result shl 3) + bChar);
Inc(Key);
end;

// Keep result in bounds of array
result:=LongWord(result) mod HASH_SIZE;

end;

////////////////////////////////////////////////////////////////////////////////
//   THash
////////////////////////////////////////////////////////////////////////////////
constructor THash.Create(Deallocator: THashDeallocator = nil);
begin

// Perform inherited
inherited Create;

// Set default values
ZeroMemory(@FHash, SizeOf(FHash));
FDeallocator:=Deallocator;
FCareCase:=True;
FCount:=0;

end;

destructor THash.Destroy;
begin

// Resource protection
try
// Clear the hash
Clear;
finally
// Perform inherited
inherited Destroy;
end;

end;

procedure THash.Clear;
var  phNode1:       PHashNode;
phNode2:       PHashNode;
dwIndex:       Integer;
begin

// Resource protection
try
// Iterate the array and clear the hash nodes
for dwIndex:=0 to Pred(HASH_SIZE) do
begin
// Get bucket node
phNode1:=FHash[dwIndex];
// Walk the nodes
while Assigned(phNode1) do
begin
// Get pointer to next item
phNode2:=phNode1^.Next;
// Free memory for node name
if Assigned(phNode1^.Item) then FreeMem(phNode1^.Item);
// Callback
if (Assigned(phNode1^.Data) and Assigned(FDeallocator)) then FDeallocator(Self, phNode1^.Data);
// Free node item
FreeMem(phNode1);
// Set iterator to next item
phNode1:=phNode2;
end;
end;
finally
// Clear all top level buckets
for dwIndex:=0 to Pred(HASH_SIZE) do FHash[dwIndex]:=nil;
// Reset the count
FCount:=0;
end;

end;

function THash.Extract(Item: PChar; out Data: Pointer): Boolean;
var  phNode1:       PHashNode;
phNode2:       PHashNode;
dwIndex:       Integer;
begin

// Get the hash index
dwIndex:=HashFunc(Item, FCareCase);

// Get the hash bucket item
phNode1:=FHash[dwIndex];

// Did top level item exist?
if Assigned(phNode1) then
begin
// Prepare for loop
phNode2:=phNode1;
// Walk the nodes
while Assigned(phNode2) do
begin
// Match key
if HashCompare(phNode2^.Item, Item, FCareCase) then break;
// Save current node
phNode1:=phNode2;
// Move to the next node in the chain
phNode2:=phNode2^.Next;
end;
// Check to see if the node is still set
if Assigned(phNode2) then
begin
// Set out param data value
Data:=phNode2^.Data;
// Check to see if this is the top level item
if (phNode2 = phNode1) then
// Link next node into the bucket
FHash[dwIndex]:=phNode2^.Next
else
phNode1^.Next:=phNode2^.Next;
// Free memory for node name
if Assigned(phNode2^.Item) then FreeMem(phNode2^.Item);
// Free the node
FreeMem(phNode2);
// Decrement the node count
Dec(FCount);
// Success
result:=True;
end
else
// Did not find the node
result:=False;
end
else
// No nodes in bucket
result:=False;

end;

function THash.Delete(Item: PChar): Boolean;
var  lpData:        Pointer;
begin

// Extract the item
result:=Extract(Item, lpData);

// Check result, perform callback if needed
if (result and Assigned(lpData) and Assigned(FDeallocator)) then FDeallocator(Self, lpData);

end;

function THash.Add(Item: PChar; Data: Pointer): Boolean;
var  phNode1:          PHashNode;
phNode2:          PHashNode;
dwIndex:          Integer;
begin

// Get the hash bucket item index
dwIndex:=HashFunc(Item, FCareCase);

// Resource protection
try
// Get the hash bucket item
phNode1:=FHash[dwIndex];
// Is the bucket empty
if (phNode1 = nil) then
FHash[dwIndex]:=NewNode(Item, Data)
else
begin
// Save current node
phNode2:=phNode1;
// Walk nodes
while Assigned(phNode2) do
begin
// Match the key
if HashCompare(phNode2^.Item, Item, FCareCase) then
begin
// Check for data change
if (phNode2^.Data <> Data) then
begin
// Callback
if (Assigned(phNode2^.Data) and Assigned(FDeallocator)) then FDeallocator(Self, phNode2^.Data);
// Set new data item
phNode2^.Data:=Data;
end;
// Break loop
break;
end;
// Save current node
phNode1:=phNode2;
// Walk next node
phNode2:=phNode2^.Next;
end;
// Do we need to add a new item to the end of the chain?
if (phNode2 = nil) then
begin
// Create hash node
phNode2:=NewNode(Item, Data);
phNode1^.Next:=phNode2;
end;
end;
finally
// Always success
result:=True;
end;

end;

function THash.Find(Item: PChar; out Data: Pointer): Boolean;
var  phNode:        PHashNode;
begin

// Get the hash bucket item
phNode:=FHash[HashFunc(Item, FCareCase)];

// Resource protection
try
// Walk the items
while Assigned(phNode) do
begin
// Compare the key
if HashCompare(phNode^.Item, Item, FCareCase) then
begin
// Key exists, set out return data
Data:=phNode^.Data;
break;
end;
// Walk the next item
phNode:=phNode^.Next;
end;
finally
// Success if node is assigned
result:=Assigned(phNode);
end;

end;

function THash.NewNode(Item: PChar; Data: Pointer): PHashNode;
begin

// Allocate memory for new node
result:=AllocMem(SizeOf(THashNode));

// Set the structure fields
result^.Item:=StrCopy(AllocMem(Succ(StrLen(Item))), Item);
result^.Data:=Data;

// Increment the count
Inc(FCount);

end;

initialization

// Initialize all variables to zero
ZeroMemory(@lpVars, SizeOf(TVariables));

// Clear the error string
ZeroMemory(@lpError, SizeOf(lpError));

// Create identifier hash table and load
hshIdent:=THash.Create(nil);
with hshIdent do
begin
CaseSensitive:=False;
end;

finalization

// Free the identifier hash table
hshIdent.Free;

end.

0

Commented:
0

Commented:
nice bit of code that rllibby, something I might be able to use for user-defineable functions/calcs myself.
0

Author Commented:
So appreciate for you help, rllibby!
This is really helpful, Thanks for your generosity for sharing with me!
0

Author Commented: