FastReport_2022_VCL/FastScript/fs_iexpression.pas
2024-01-01 16:13:08 +01:00

958 lines
22 KiB
ObjectPascal

{******************************************}
{ }
{ FastScript v1.9 }
{ Expression parser }
{ }
{ (c) 2003-2007 by Alexander Tzyganenko, }
{ Fast Reports Inc }
{ }
{******************************************}
//VCL uses section
{$IFNDEF FMX}
unit fs_iexpression;
interface
{$i fs.inc}
uses
SysUtils, Classes, fs_iinterpreter
{$IFDEF Delphi6}
, Variants
{$ENDIF};
{$ELSE}
interface
{$i fs.inc}
uses
System.SysUtils, System.Classes, FMX.fs_iinterpreter, System.Variants;
{$ENDIF}
type
{ List of operators }
TfsOperatorType = (opNone, opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq,
opPlus, opMinus, opOr, opXor, opMul, opDivFloat, opDivInt, opMod, opAnd,
opShl, opShr, opLeftBracket, opRightBracket, opNot, opUnMinus, opIn, opIs);
{ TfsExpression class holds a list of operands and operators.
List is represented in the tree form.
Call to methods AddXXX puts an expression element to the list.
Call to function Value calculates and returns the expression value }
TfsExpressionNode = class(TfsCustomVariable)
private
FLeft, FRight, FParent: TfsExpressionNode;
procedure AddNode(Node: TfsExpressionNode);
procedure RemoveNode(Node: TfsExpressionNode);
public
destructor Destroy; override;
function Priority: Integer; virtual; abstract;
end;
TfsOperandNode = class(TfsExpressionNode)
public
constructor Create(const AValue: Variant);
function Priority: Integer; override;
end;
TfsOperatorNode = class(TfsExpressionNode)
private
FOp: TfsOperatorType;
FOptimizeInt: Boolean;
FOptimizeBool: Boolean;
public
constructor Create(Op: TfsOperatorType);
function Priority: Integer; override;
end;
TfsDesignatorNode = class(TfsOperandNode)
private
FDesignator: TfsDesignator;
FVar: TfsCustomVariable;
protected
function GetValue: Variant; override;
public
constructor Create(ADesignator: TfsDesignator);
destructor Destroy; override;
end;
TfsSetNode = class(TfsOperandNode)
private
FSetExpression: TfsSetExpression;
protected
function GetValue: Variant; override;
public
constructor Create(ASet: TfsSetExpression);
destructor Destroy; override;
end;
TfsExpression = class(TfsCustomExpression)
private
FCurNode: TfsExpressionNode;
FNode: TfsExpressionNode;
FScript: TfsScript;
FSource: String;
procedure AddOperand(Node: TfsExpressionNode);
protected
function GetValue: Variant; override;
procedure SetValue(const Value: Variant); override;
public
constructor Create(Script: TfsScript);
destructor Destroy; override;
procedure AddConst(const AValue: Variant);
procedure AddConstWithType(const AValue: Variant; aTyp: TfsVarType);
procedure AddDesignator(ADesignator: TfsDesignator);
procedure AddOperator(const Op: String);
procedure AddSet(ASet: TfsSetExpression);
function Finalize: String;
function Optimize(Designator: TfsDesignator): String;
function SingleItem: TfsCustomVariable;
property Source: String read FSource write FSource;
end;
implementation
//VCL uses section
{$IFNDEF FMX}
uses fs_itools;
//FMX uses section
{$ELSE}
uses FMX.fs_itools;
{$ENDIF}
type
TNoneNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TGreatNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TLessNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TLessEqNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TGreatEqNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TNonEqNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TEqNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TPlusNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TStrCatNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TMinusNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TOrNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TXorNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TMulNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TDivFloatNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TDivIntNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TModNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TAndNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TShlNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TShrNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TLeftBracketNode = class(TfsOperatorNode);
TRightBracketNode = class(TfsOperatorNode);
TNotNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TUnMinusNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TInNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
TIsNode = class(TfsOperatorNode)
protected
function GetValue: Variant; override;
end;
function TNoneNode.GetValue: Variant;
begin
Result := FLeft.Value;
end;
function TGreatNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result > FRight.Value;
end;
function TLessNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result < FRight.Value;
end;
function TLessEqNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result <= FRight.Value;
end;
function TGreatEqNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result >= FRight.Value;
end;
function TNonEqNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result <> FRight.Value;
end;
function TEqNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result = FRight.Value;
end;
function TPlusNode.GetValue: Variant;
begin
Result := FLeft.Value;
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result + FRight.Value;
end;
function TStrCatNode.GetValue: Variant;
begin
Result := FLeft.Value;
if (TVarData(Result).VType = varString){$IFDEF Delphi12} or (TVarData(Result).VType = varUString){$ENDIF} then
Result := VarToStr(Result) + VarToStr(FRight.Value) else
Result := Result + FRight.Value;
end;
function TMinusNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeInt then
Result := frxInteger(Result) - frxInteger(FRight.Value)
else
begin
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result - FRight.Value;
end;
end;
function TOrNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeBool then
begin
if Boolean(Result) = False then
Result := FRight.Value;
end
else
Result := Result or FRight.Value;
end;
function TXorNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result xor FRight.Value;
end;
function TMulNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeInt then
Result := frxInteger(Result) * frxInteger(FRight.Value)
else
begin
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result * FRight.Value;
end;
end;
function TDivFloatNode.GetValue: Variant;
begin
Result := FLeft.Value;
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result / FRight.Value;
end;
function TDivIntNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeInt then
Result := frxInteger(Result) div frxInteger(FRight.Value)
else
begin
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result div FRight.Value;
end;
end;
function TModNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeInt then
Result := frxInteger(Result) mod frxInteger(FRight.Value)
else
begin
{$IFDEF FPC}
if TVarData(Result).Vtype = varEmpty then
Result := 0;
{$ENDIF}
Result := Result mod FRight.Value;
end;
end;
function TAndNode.GetValue: Variant;
begin
Result := FLeft.Value;
if FOptimizeBool then
begin
if Boolean(Result) = True then
Result := FRight.Value;
end
else
Result := Result and FRight.Value;
end;
function TShlNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result shl FRight.Value;
end;
function TShrNode.GetValue: Variant;
begin
Result := FLeft.Value;
Result := Result shr FRight.Value;
end;
function TNotNode.GetValue: Variant;
begin
Result := not FLeft.Value;
end;
function TUnMinusNode.GetValue: Variant;
begin
Result := -FLeft.Value;
end;
function TInNode.GetValue: Variant;
var
i: Integer;
ar, val, selfVal: Variant;
Count: Integer;
begin
if FRight is TfsSetNode then
Result := TfsSetNode(FRight).FSetExpression.Check(FLeft.Value)
else
begin
Result := False;
ar := FRight.Value;
Count := VarArrayHighBound(ar, 1);
selfVal := FLeft.Value;
i := 0;
while i <= Count do
begin
val := ar[i];
Result := selfVal = val;
if (i < Count - 1) and (ar[i + 1] = Null) and not Result then { subrange }
begin
Result := (selfVal >= val) and (selfVal <= ar[i + 2]);
Inc(i, 2);
end;
if Result then break;
Inc(i);
end;
end;
end;
function TIsNode.GetValue: Variant;
begin
Result := TObject(frxInteger(FLeft.Value)) is
TfsClassVariable(TfsDesignatorNode(FRight).FDesignator[0].Ref).ClassRef;
end;
{ TfsExpressionNode }
destructor TfsExpressionNode.Destroy;
begin
FLeft.Free;
FRight.Free;
inherited;
end;
procedure TfsExpressionNode.AddNode(Node: TfsExpressionNode);
begin
if FLeft = nil then
FLeft := Node
else if FRight = nil then
FRight := Node;
if Node <> nil then
Node.FParent := Self;
end;
procedure TfsExpressionNode.RemoveNode(Node: TfsExpressionNode);
begin
if FLeft = Node then
FLeft := nil
else if FRight = Node then
FRight := nil;
end;
{ TfsOperandNode }
constructor TfsOperandNode.Create(const AValue: Variant);
var
t: TfsVarType;
begin
{$IFDEF CPUX64}
inherited Create('', fvtInt64, '');
{$ELSE}
inherited Create('', fvtInt, '');
{$ENDIF}
Value := AValue;
t := fvtInt;
if TVarData(AValue).VType = varBoolean then
t := fvtBool
else if TVarData(AValue).VType in [varSingle, varDouble, varCurrency] then
t := fvtFloat
{$IFDEF FS_INT64}
else if (TVarData(AValue).VType = varInt64) then
t := fvtInt64
{$ENDIF}
else if (TVarData(AValue).VType = varOleStr) or
(TVarData(AValue).VType = varString){$IFDEF Delphi12} or (TVarData(AValue).VType = varUString){$ENDIF} then
t := fvtString;
Typ := t;
end;
function TfsOperandNode.Priority: Integer;
begin
Result := 0;
end;
{ TfsOperatorNode }
constructor TfsOperatorNode.Create(Op: TfsOperatorType);
begin
{$IFDEF CPUX64}
inherited Create('', fvtInt64, '');
{$ELSE}
inherited Create('', fvtInt, '');
{$ENDIF}
FOp := Op;
end;
function TfsOperatorNode.Priority: Integer;
begin
case FOp of
opNone:
Result := 7;
opLeftBracket:
Result := 6;
opRightBracket:
Result := 5;
opGreat, opLess, opGreatEq, opLessEq, opNonEq, opEq, opIn, opIs:
Result := 4;
opPlus, opMinus, opOr, opXor:
Result := 3;
opMul, opDivFloat, opDivInt, opMod, opAnd, opShr, opShl:
Result := 2;
opNot, opUnMinus:
Result := 1;
else
Result := 0;
end;
end;
{ TfsDesignatorNode }
constructor TfsDesignatorNode.Create(ADesignator: TfsDesignator);
begin
inherited Create(0);
FDesignator := ADesignator;
Typ := ADesignator.Typ;
TypeName := ADesignator.TypeName;
if FDesignator is TfsVariableDesignator then
FVar := FDesignator.RefItem else
FVar := FDesignator;
end;
destructor TfsDesignatorNode.Destroy;
begin
FDesignator.Free;
inherited;
end;
function TfsDesignatorNode.GetValue: Variant;
begin
Result := FVar.Value;
end;
{ TfsSetNode }
constructor TfsSetNode.Create(ASet: TfsSetExpression);
begin
inherited Create(0);
FSetExpression := ASet;
Typ := fvtVariant;
end;
destructor TfsSetNode.Destroy;
begin
FSetExpression.Free;
inherited;
end;
function TfsSetNode.GetValue: Variant;
begin
Result := FSetExpression.Value;
end;
{ TfsExpression }
constructor TfsExpression.Create(Script: TfsScript);
begin
{$IFDEF CPUX64}
inherited Create('', fvtInt64, '');
{$ELSE}
inherited Create('', fvtInt, '');
{$ENDIF}
FNode := TNoneNode.Create(opNone);
FCurNode := FNode;
FScript := Script;
end;
destructor TfsExpression.Destroy;
begin
FNode.Free;
inherited;
end;
function TfsExpression.GetValue: Variant;
begin
Result := FNode.Value;
end;
procedure TfsExpression.AddOperand(Node: TfsExpressionNode);
begin
FCurNode.AddNode(Node);
FCurNode := Node;
end;
procedure TfsExpression.AddOperator(const Op: String);
var
Node: TfsExpressionNode;
n, n1: TfsExpressionNode;
function CreateOperatorNode(s: String): TfsOperatorNode;
begin
s := AnsiUpperCase(s);
if s = ' ' then
Result := TNoneNode.Create(opNone)
else if s = '>' then
Result := TGreatNode.Create(opGreat)
else if s = '<' then
Result := TLessNode.Create(opLess)
else if s = '<=' then
Result := TLessEqNode.Create(opLessEq)
else if s = '>=' then
Result := TGreatEqNode.Create(opGreatEq)
else if s = '<>' then
Result := TNonEqNode.Create(opNonEq)
else if s = '=' then
Result := TEqNode.Create(opEq)
else if s = '+' then
Result := TPlusNode.Create(opPlus)
else if s = 'STRCAT' then
Result := TStrCatNode.Create(opPlus)
else if s = '-' then
Result := TMinusNode.Create(opMinus)
else if s = 'OR' then
Result := TOrNode.Create(opOr)
else if s = 'XOR' then
Result := TXorNode.Create(opXor)
else if s = '*' then
Result := TMulNode.Create(opMul)
else if s = '/' then
Result := TDivFloatNode.Create(opDivFloat)
else if s = 'DIV' then
Result := TDivIntNode.Create(opDivInt)
else if s = 'MOD' then
Result := TModNode.Create(opMod)
else if s = 'AND' then
Result := TAndNode.Create(opAnd)
else if s = 'SHL' then
Result := TShlNode.Create(opShl)
else if s = 'SHR' then
Result := TShrNode.Create(opShr)
else if s = '(' then
Result := TLeftBracketNode.Create(opLeftBracket)
else if s = ')' then
Result := TRightBracketNode.Create(opRightBracket)
else if s = 'NOT' then
Result := TNotNode.Create(opNot)
else if s = 'UNMINUS' then
Result := TUnMinusNode.Create(opUnMinus)
else if s = 'IN' then
Result := TInNode.Create(opIn)
else if s = 'IS' then
Result := TIsNode.Create(opIs)
else
Result := nil;
end;
begin
Node := CreateOperatorNode(Op);
Node.SourcePos := SourcePos;
if (Op = '(') or (Op = 'unminus') or (Op = 'not') then
AddOperand(Node)
else if Op = ')' then
begin
n := FCurNode;
while n.Priority <= Node.Priority do
n := n.FParent;
n.FParent.RemoveNode(n);
n.FParent.AddNode(n.FLeft);
Node.Free;
Node := n.FLeft;
n.FLeft := nil;
n.Free;
end
else if FCurNode = FNode then
FNode.AddNode(Node)
else
begin
n := FCurNode;
n1 := nil;
if FCurNode.Priority <> 6 then
begin
n := FCurNode.FParent;
n1 := FCurNode;
end;
while n.Priority <= Node.Priority do
begin
n1 := n;
n := n.FParent;
end;
n.RemoveNode(n1);
n.AddNode(Node);
Node.AddNode(n1);
end;
FCurNode := Node;
end;
procedure TfsExpression.AddConst(const AValue: Variant);
var
Node: TfsOperandNode;
begin
Node := TfsOperandNode.Create(AValue);
Node.SourcePos := SourcePos;
AddOperand(Node);
end;
procedure TfsExpression.AddConstWithType(const AValue: Variant;
aTyp: TfsVarType);
begin
AddConst(AValue);
if aTyp = fvtClass then
FCurNode.Typ := fvtVariant;
end;
procedure TfsExpression.AddDesignator(ADesignator: TfsDesignator);
var
Node: TfsDesignatorNode;
begin
Node := TfsDesignatorNode.Create(ADesignator);
Node.SourcePos := SourcePos;
AddOperand(Node);
end;
procedure TfsExpression.AddSet(ASet: TfsSetExpression);
var
Node: TfsSetNode;
begin
Node := TfsSetNode.Create(ASet);
Node.SourcePos := SourcePos;
AddOperand(Node);
end;
function TfsExpression.Finalize: String;
var
ErrorPos: String;
TypeRec: TfsTypeRec;
function GetType(Item: TfsExpressionNode): TfsTypeRec;
var
Typ1, Typ2: TfsTypeRec;
op: TfsOperatorType;
Error: Boolean;
begin
if Item = nil then
Result.Typ := fvtVariant
else if Item is TfsOperandNode then
begin
Result.Typ := Item.Typ;
Result.TypeName := Item.TypeName;
end
else
begin
Typ1 := GetType(Item.FLeft);
Typ2 := GetType(Item.FRight);
// if (Typ1.Typ = fvtInt) and (Typ2.Typ = fvtInt) then
// TfsOperatorNode(Item).FOptimizeInt := True;
if (Typ1.Typ = fvtBool) and (Typ2.Typ = fvtBool) then
TfsOperatorNode(Item).FOptimizeBool := True;
op := TfsOperatorNode(Item).FOp;
if (op = opIs) and (Typ1.Typ = fvtClass) and (Typ2.Typ = fvtClass) then
Error := False
else
begin
{ check types compatibility }
Error := not TypesCompatible(Typ1, Typ2, FScript);
{ check operators applicability }
if not Error then
case Typ1.Typ of
fvtBool:
Error := not (op in [opNonEq, opEq, opOr, opXor, opAnd, opNot]);
fvtChar, fvtString:
Error := not (op in [opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq, opPlus, opIn]);
fvtClass, fvtArray:
Error := not (op in [opNonEq, opEq]);
end;
end;
if not Error then
begin
Result := Typ1;
{ if one type is Float, resulting type is float too }
if [Typ1.Typ] + [Typ2.Typ] = [fvtInt, fvtFloat] then
Result.Typ := fvtFloat;
{ case int / int = float }
if (Typ1.Typ = fvtInt) and (Typ2.Typ = fvtInt) and (op = opDivFloat) then
Result.Typ := fvtFloat;
{$IFDEF FS_INT64}
if [Typ1.Typ] + [Typ2.Typ] = [fvtInt64, fvtFloat] then
Result.Typ := fvtFloat;
{ case int / int = float }
if ((Typ1.Typ = fvtInt64) or (Typ1.Typ = fvtInt))
and ((Typ2.Typ = fvtInt64) or (Typ2.Typ = fvtInt64)) and (op = opDivFloat) then
Result.Typ := fvtFloat;
{$ENDIF}
{ result of comparing two types is always boolean }
if op in [opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq, opIn, opIs] then
Result.Typ := fvtBool;
end
else if ErrorPos = '' then
ErrorPos := Item.SourcePos;
Item.Typ := Result.Typ;
end;
end;
begin
{ remove the empty root node }
FCurNode := FNode.FLeft;
FNode.RemoveNode(FCurNode);
FNode.Free;
FNode := FCurNode;
{ check and get the expression type }
ErrorPos := '';
TypeRec := GetType(FNode);
Typ := TypeRec.Typ;
TypeName := TypeRec.TypeName;
Result := ErrorPos;
{ expression is assignable if it has only one node of type "Variable" }
if not ((FNode is TfsDesignatorNode) and not
(TfsDesignatorNode(FNode).FDesignator.IsReadOnly)) then
IsReadOnly := True;
end;
procedure TfsExpression.SetValue(const Value: Variant);
begin
if not IsReadOnly then
TfsDesignatorNode(FNode).FDesignator.Value := Value;
end;
function TfsExpression.Optimize(Designator: TfsDesignator): String;
var
Op: TfsOperatorType;
begin
Result := ' ';
if not (Designator is TfsVariableDesignator) or
not (FNode is TfsOperatorNode) then Exit;
Op := TfsOperatorNode(FNode).FOp;
if not (Op in [opPlus, opMinus, opDivFloat, opMul]) then Exit;
{ optimize a := a op b statement }
if (FNode.FLeft is TfsDesignatorNode) and
(TfsDesignatorNode(FNode.FLeft).FDesignator is TfsVariableDesignator) and
(TfsDesignatorNode(FNode.FLeft).FDesignator.RefItem = Designator.RefItem) then
begin
FCurNode := FNode.FRight;
FNode.RemoveNode(FCurNode);
FNode.Free;
FNode := FCurNode;
if Op = opPlus then
Result := '+'
else if Op = opMinus then
Result := '-'
else if Op = opDivFloat then
Result := '/'
else if Op = opMul then
Result := '*';
end
{ optimize a := b op a statement }
else if (FNode.FRight is TfsDesignatorNode) and
(TfsDesignatorNode(FNode.FRight).FDesignator is TfsVariableDesignator) and
(TfsDesignatorNode(FNode.FRight).FDesignator.RefItem = Designator.RefItem) and
(Op in [opPlus, opMul]) and
not (Designator.RefItem.Typ in [fvtString, fvtVariant]) then
begin
FCurNode := FNode.FLeft;
FNode.RemoveNode(FCurNode);
FNode.Free;
FNode := FCurNode;
if Op = opPlus then
Result := '+'
else if Op = opMul then
Result := '*';
end;
end;
function TfsExpression.SingleItem: TfsCustomVariable;
begin
{ if expression contains only one item, returns reference to it }
Result := nil;
if FNode is TfsDesignatorNode then
begin
if TfsDesignatorNode(FNode).FDesignator is TfsVariableDesignator then
Result := TfsDesignatorNode(FNode).FDesignator.RefItem else
Result := TfsDesignatorNode(FNode).FDesignator;
end
else if FNode is TfsOperandNode then
Result := FNode;
end;
end.