{******************************************} { } { 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.