📄 dbf_prscore.pas
字号:
unit dbf_prscore;
{--------------------------------------------------------------
| TCustomExpressionParser
|
| - contains core expression parser
|
| This code is based on code from:
|
| Original author: Egbert van Nes
| With contributions of: John Bultena and Ralf Junker
| Homepage: http://www.slm.wau.nl/wkao/parseexpr.html
|
| see also: http://www.datalog.ro/delphi/parser.html
| (Renate Schaaf (schaaf at math.usu.edu), 1993
| Alin Flaider (aflaidar at datalog.ro), 1996
| Version 9-10: Stefan Hoffmeister, 1996-1997)
|
|---------------------------------------------------------------}
interface
{$I dbf_common.inc}
uses
SysUtils,
Classes,
Db,
dbf_prssupp,
dbf_prsdef;
{$define ENG_NUMBERS}
// ENG_NUMBERS will force the use of english style numbers 8.1 instead of 8,1
// (if the comma is your decimal separator)
// the advantage is that arguments can be separated with a comma which is
// fairly common, otherwise there is ambuigity: what does 'var1,8,4,4,5' mean?
// if you don't define ENG_NUMBERS and DecimalSeparator is a comma then
// the argument separator will be a semicolon ';'
type
TCustomExpressionParser = class(TObject)
private
FHexChar: Char;
FArgSeparator: Char;
FDecimalSeparator: Char;
FOptimize: Boolean;
FConstantsList: TOCollection;
FLastRec: PExpressionRec;
FCurrentRec: PExpressionRec;
FExpResult: PChar;
FExpResultPos: PChar;
FExpResultSize: Integer;
procedure ParseString(AnExpression: string; DestCollection: TExprCollection);
function MakeTree(Expr: TExprCollection; FirstItem, LastItem: Integer): PExpressionRec;
procedure MakeLinkedList(var ExprRec: PExpressionRec; Memory: PPChar;
MemoryPos: PPChar; MemSize: PInteger);
procedure Check(AnExprList: TExprCollection);
procedure CheckArguments(ExprRec: PExpressionRec);
procedure RemoveConstants(var ExprRec: PExpressionRec);
function ResultCanVary(ExprRec: PExpressionRec): Boolean;
protected
FWordsList: TSortedCollection;
function MakeRec: PExpressionRec; virtual;
procedure FillExpressList; virtual; abstract;
procedure HandleUnknownVariable(VarName: string); virtual; abstract;
procedure CompileExpression(AnExpression: string);
procedure EvaluateCurrent;
procedure DisposeList(ARec: PExpressionRec);
procedure DisposeTree(ExprRec: PExpressionRec);
function CurrentExpression: string; virtual; abstract;
function GetResultType: TExpressionType; virtual;
property CurrentRec: PExpressionRec read FCurrentRec write FCurrentRec;
property LastRec: PExpressionRec read FLastRec write FLastRec;
property ExpResult: PChar read FExpResult;
property ExpResultPos: PChar read FExpResultPos write FExpResultPos;
public
constructor Create;
destructor Destroy; override;
function DefineFloatVariable(AVarName: string; AValue: PDouble): TExprWord;
function DefineIntegerVariable(AVarName: string; AValue: PInteger): TExprWord;
// procedure DefineSmallIntVariable(AVarName: string; AValue: PSmallInt);
{$ifdef SUPPORT_INT64}
function DefineLargeIntVariable(AVarName: string; AValue: PLargeInt): TExprWord;
{$endif}
function DefineDateTimeVariable(AVarName: string; AValue: PDateTimeRec): TExprWord;
function DefineBooleanVariable(AVarName: string; AValue: PBoolean): TExprWord;
function DefineStringVariable(AVarName: string; AValue: PPChar): TExprWord;
function DefineFunction(AFunctName, AShortName, ADescription, ATypeSpec: string;
AMinFunctionArg: Integer; AResultType: TExpressionType; AFuncAddress: TExprFunc): TExprWord;
procedure Evaluate(AnExpression: string);
function AddExpression(AnExpression: string): Integer;
procedure ClearExpressions; virtual;
// procedure GetGeneratedVars(AList: TList);
procedure GetFunctionNames(AList: TStrings);
function GetFunctionDescription(AFunction: string): string;
property HexChar: Char read FHexChar write FHexChar;
property ArgSeparator: Char read FArgSeparator write FArgSeparator;
property Optimize: Boolean read FOptimize write FOptimize;
property ResultType: TExpressionType read GetResultType;
//if optimize is selected, constant expressions are tried to remove
//such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x
end;
//--Expression functions-----------------------------------------------------
procedure FuncFloatToStr(Param: PExpressionRec);
procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: {$ifdef SUPPORT_INT64}Int64{$else}Integer{$endif});
procedure FuncIntToStr(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure FuncInt64ToStr(Param: PExpressionRec);
{$endif}
procedure FuncDateToStr(Param: PExpressionRec);
procedure FuncSubString(Param: PExpressionRec);
procedure FuncUppercase(Param: PExpressionRec);
procedure FuncLowercase(Param: PExpressionRec);
procedure FuncAdd_F_FF(Param: PExpressionRec);
procedure FuncAdd_F_FI(Param: PExpressionRec);
procedure FuncAdd_F_II(Param: PExpressionRec);
procedure FuncAdd_F_IF(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure FuncAdd_F_FL(Param: PExpressionRec);
procedure FuncAdd_F_IL(Param: PExpressionRec);
procedure FuncAdd_F_LL(Param: PExpressionRec);
procedure FuncAdd_F_LF(Param: PExpressionRec);
procedure FuncAdd_F_LI(Param: PExpressionRec);
{$endif}
procedure FuncSub_F_FF(Param: PExpressionRec);
procedure FuncSub_F_FI(Param: PExpressionRec);
procedure FuncSub_F_II(Param: PExpressionRec);
procedure FuncSub_F_IF(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure FuncSub_F_FL(Param: PExpressionRec);
procedure FuncSub_F_IL(Param: PExpressionRec);
procedure FuncSub_F_LL(Param: PExpressionRec);
procedure FuncSub_F_LF(Param: PExpressionRec);
procedure FuncSub_F_LI(Param: PExpressionRec);
{$endif}
procedure FuncMul_F_FF(Param: PExpressionRec);
procedure FuncMul_F_FI(Param: PExpressionRec);
procedure FuncMul_F_II(Param: PExpressionRec);
procedure FuncMul_F_IF(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure FuncMul_F_FL(Param: PExpressionRec);
procedure FuncMul_F_IL(Param: PExpressionRec);
procedure FuncMul_F_LL(Param: PExpressionRec);
procedure FuncMul_F_LF(Param: PExpressionRec);
procedure FuncMul_F_LI(Param: PExpressionRec);
{$endif}
procedure FuncDiv_F_FF(Param: PExpressionRec);
procedure FuncDiv_F_FI(Param: PExpressionRec);
procedure FuncDiv_F_II(Param: PExpressionRec);
procedure FuncDiv_F_IF(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure FuncDiv_F_FL(Param: PExpressionRec);
procedure FuncDiv_F_IL(Param: PExpressionRec);
procedure FuncDiv_F_LL(Param: PExpressionRec);
procedure FuncDiv_F_LF(Param: PExpressionRec);
procedure FuncDiv_F_LI(Param: PExpressionRec);
{$endif}
procedure FuncStrI_EQ(Param: PExpressionRec);
procedure FuncStrI_NEQ(Param: PExpressionRec);
procedure FuncStrI_LT(Param: PExpressionRec);
procedure FuncStrI_GT(Param: PExpressionRec);
procedure FuncStrI_LTE(Param: PExpressionRec);
procedure FuncStrI_GTE(Param: PExpressionRec);
procedure FuncStr_EQ(Param: PExpressionRec);
procedure FuncStr_NEQ(Param: PExpressionRec);
procedure FuncStr_LT(Param: PExpressionRec);
procedure FuncStr_GT(Param: PExpressionRec);
procedure FuncStr_LTE(Param: PExpressionRec);
procedure FuncStr_GTE(Param: PExpressionRec);
procedure Func_FF_EQ(Param: PExpressionRec);
procedure Func_FF_NEQ(Param: PExpressionRec);
procedure Func_FF_LT(Param: PExpressionRec);
procedure Func_FF_GT(Param: PExpressionRec);
procedure Func_FF_LTE(Param: PExpressionRec);
procedure Func_FF_GTE(Param: PExpressionRec);
procedure Func_FI_EQ(Param: PExpressionRec);
procedure Func_FI_NEQ(Param: PExpressionRec);
procedure Func_FI_LT(Param: PExpressionRec);
procedure Func_FI_GT(Param: PExpressionRec);
procedure Func_FI_LTE(Param: PExpressionRec);
procedure Func_FI_GTE(Param: PExpressionRec);
procedure Func_II_EQ(Param: PExpressionRec);
procedure Func_II_NEQ(Param: PExpressionRec);
procedure Func_II_LT(Param: PExpressionRec);
procedure Func_II_GT(Param: PExpressionRec);
procedure Func_II_LTE(Param: PExpressionRec);
procedure Func_II_GTE(Param: PExpressionRec);
procedure Func_IF_EQ(Param: PExpressionRec);
procedure Func_IF_NEQ(Param: PExpressionRec);
procedure Func_IF_LT(Param: PExpressionRec);
procedure Func_IF_GT(Param: PExpressionRec);
procedure Func_IF_LTE(Param: PExpressionRec);
procedure Func_IF_GTE(Param: PExpressionRec);
{$ifdef SUPPORT_INT64}
procedure Func_LL_EQ(Param: PExpressionRec);
procedure Func_LL_NEQ(Param: PExpressionRec);
procedure Func_LL_LT(Param: PExpressionRec);
procedure Func_LL_GT(Param: PExpressionRec);
procedure Func_LL_LTE(Param: PExpressionRec);
procedure Func_LL_GTE(Param: PExpressionRec);
procedure Func_LF_EQ(Param: PExpressionRec);
procedure Func_LF_NEQ(Param: PExpressionRec);
procedure Func_LF_LT(Param: PExpressionRec);
procedure Func_LF_GT(Param: PExpressionRec);
procedure Func_LF_LTE(Param: PExpressionRec);
procedure Func_LF_GTE(Param: PExpressionRec);
procedure Func_FL_EQ(Param: PExpressionRec);
procedure Func_FL_NEQ(Param: PExpressionRec);
procedure Func_FL_LT(Param: PExpressionRec);
procedure Func_FL_GT(Param: PExpressionRec);
procedure Func_FL_LTE(Param: PExpressionRec);
procedure Func_FL_GTE(Param: PExpressionRec);
procedure Func_LI_EQ(Param: PExpressionRec);
procedure Func_LI_NEQ(Param: PExpressionRec);
procedure Func_LI_LT(Param: PExpressionRec);
procedure Func_LI_GT(Param: PExpressionRec);
procedure Func_LI_LTE(Param: PExpressionRec);
procedure Func_LI_GTE(Param: PExpressionRec);
procedure Func_IL_EQ(Param: PExpressionRec);
procedure Func_IL_NEQ(Param: PExpressionRec);
procedure Func_IL_LT(Param: PExpressionRec);
procedure Func_IL_GT(Param: PExpressionRec);
procedure Func_IL_LTE(Param: PExpressionRec);
procedure Func_IL_GTE(Param: PExpressionRec);
{$endif}
procedure Func_AND(Param: PExpressionRec);
procedure Func_OR(Param: PExpressionRec);
procedure Func_NOT(Param: PExpressionRec);
var
DbfWordsSensGeneralList, DbfWordsInsensGeneralList: TExpressList;
DbfWordsSensPartialList, DbfWordsInsensPartialList: TExpressList;
DbfWordsSensNoPartialList, DbfWordsInsensNoPartialList: TExpressList;
DbfWordsGeneralList: TExpressList;
implementation
procedure LinkVariable(ExprRec: PExpressionRec);
begin
with ExprRec^ do
begin
if ExprWord.IsVariable then
begin
// copy pointer to variable
Args[0] := ExprWord.AsPointer;
// store length as second parameter
Args[1] := PChar(ExprWord.LenAsPointer);
end;
end;
end;
procedure LinkVariables(ExprRec: PExpressionRec);
var
I: integer;
begin
with ExprRec^ do
begin
I := 0;
while (I < MaxArg) and (ArgList[I] <> nil) do
begin
LinkVariables(ArgList[I]);
Inc(I);
end;
end;
LinkVariable(ExprRec);
end;
{ TCustomExpressionParser }
constructor TCustomExpressionParser.Create;
begin
inherited;
FHexChar := '$';
{$IFDEF ENG_NUMBERS}
FDecimalSeparator := '.';
FArgSeparator := ',';
{$ELSE}
FDecimalSeparator := DecimalSeparator;
if DecimalSeparator = ',' then
FArgSeparator := ';'
else
FArgSeparator := ',';
{$ENDIF}
FConstantsList := TOCollection.Create;
FWordsList := TExpressList.Create;
GetMem(FExpResult, ArgAllocSize);
FExpResultPos := FExpResult;
FExpResultSize := ArgAllocSize;
FOptimize := true;
FillExpressList;
end;
destructor TCustomExpressionParser.Destroy;
begin
ClearExpressions;
FreeMem(FExpResult);
FConstantsList.Free;
FWordsList.Free;
inherited;
end;
procedure TCustomExpressionParser.CompileExpression(AnExpression: string);
var
ExpColl: TExprCollection;
ExprTree: PExpressionRec;
begin
if Length(AnExpression) > 0 then
begin
ExprTree := nil;
ExpColl := TExprCollection.Create;
try
// FCurrentExpression := anExpression;
ParseString(AnExpression, ExpColl);
Check(ExpColl);
ExprTree := MakeTree(ExpColl, 0, ExpColl.Count - 1);
FCurrentRec := nil;
CheckArguments(ExprTree);
LinkVariables(ExprTree);
if Optimize then
RemoveConstants(ExprTree);
// all constant expressions are evaluated and replaced by variables
FCurrentRec := nil;
FExpResultPos := FExpResult;
MakeLinkedList(ExprTree, @FExpResult, @FExpResultPos, @FExpResultSize);
except
on E: Exception do
begin
DisposeTree(ExprTree);
ExpColl.Free;
raise;
end;
end;
ExpColl.Free;
end;
end;
procedure TCustomExpressionParser.CheckArguments(ExprRec: PExpressionRec);
var
TempExprWord: TExprWord;
I, error, firstFuncIndex, funcIndex: Integer;
foundAltFunc: Boolean;
procedure FindAlternate;
begin
// see if we can find another function
if funcIndex < 0 then
begin
firstFuncIndex := FWordsList.IndexOf(ExprRec^.ExprWord);
funcIndex := firstFuncIndex;
end;
// check if not last function
if (0 <= funcIndex) and (funcIndex < FWordsList.Count - 1) then
begin
inc(funcIndex);
TempExprWord := TExprWord(FWordsList.Items[funcIndex]);
if FWordsList.Compare(FWordsList.KeyOf(ExprRec^.ExprWord), FWordsList.KeyOf(TempExprWord)) = 0 then
begin
ExprRec^.ExprWord := TempExprWord;
ExprRec^.Oper := ExprRec^.ExprWord.ExprFunc;
foundAltFunc := true;
end;
end;
end;
procedure InternalCheckArguments;
begin
I := 0;
error := 0;
foundAltFunc := false;
with ExprRec^ do
begin
if WantsFunction <> (ExprWord.IsFunction and not ExprWord.IsOperator) then
begin
error := 4;
exit;
end;
while (I < ExprWord.MaxFunctionArg) and (ArgList[I] <> nil) and (error = 0) do
begin
// test subarguments first
CheckArguments(ArgList[I]);
// test if correct type
if (ArgList[I]^.ExprWord.ResultType <> ExprCharToExprType(ExprWord.TypeSpec[I+1])) then
error := 2;
// goto next argument
Inc(I);
end;
// test if enough parameters passed; I = num args user passed
if (error = 0) and (I < ExprWord.MinFunctionArg) then
error := 1;
// test if too many parameters passed
if (error = 0) and (I > ExprWord.MaxFunctionArg) then
error := 3;
end;
end;
begin
funcIndex := -1;
repeat
InternalCheckArguments;
// error occurred?
if error <> 0 then
FindAlternate;
until (error = 0) or not foundAltFunc;
// maybe it's an undefined variable
if (error <> 0) and not ExprRec^.WantsFunction and (firstFuncIndex >= 0) then
begin
HandleUnknownVariable(ExprRec^.ExprWord.Name);
{ must not add variable as first function in this set of duplicates,
otherwise following searches will not find it }
FWordsList.Exchange(firstFuncIndex, firstFuncIndex+1);
ExprRec^.ExprWord := TExprWord(FWordsList.Items[firstFuncIndex+1]);
ExprRec^.Oper := ExprRec^.ExprWord.ExprFunc;
InternalCheckArguments;
end;
// fatal error?
case error of
1: raise EParserException.Create('Function or operand has too few arguments');
2: raise EParserException.Create('Argument type mismatch');
3: raise EParserException.Create('Function or operand has too many arguments');
4: raise EParserException.Create('No function with this name, remove brackets for variable');
end;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -