paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 21:29:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: more const operators

Browse Source 
git-svn-id: trunk@36376 -
This commit is contained in:
Mattias Gaertner 2017-05-31 10:55:24 +00:00
parent 59e0ca7278
commit 9ff7e70ffc
3 changed files with 1020 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

737
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -1,13 +1,38 @@
{
This file is part of the Free Component Library
Pascal source parser
Copyright (c) 2017 by Mattias Gaertner, mattias@freepascal.org
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
Abstract:
Evaluation of Pascal constants.
Works:
- Emitting range check warnings
- Error on overflow
- int/uint unary +, -
- int/uint binary: +, -
}
unit PasResolveEval; unit PasResolveEval;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF} {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
{$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
interface interface
uses uses
PasTree, PScanner, sysutils; Sysutils, Math, PasTree, PScanner;
// message numbers // message numbers
const const
@ -79,6 +104,7 @@ const
nRangeCheckEvaluatingConstantsVMinMax = 3066; nRangeCheckEvaluatingConstantsVMinMax = 3066;
nIllegalChar = 3067; nIllegalChar = 3067;
nOverflowInArithmeticOperation = 3068; nOverflowInArithmeticOperation = 3068;
nDivByZero = 3069;
// resourcestring patterns of messages // resourcestring patterns of messages
resourcestring resourcestring
@ -150,6 +176,7 @@ resourcestring
sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s must be between %s and %s)'; sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s must be between %s and %s)';
sIllegalChar = 'Illegal character'; sIllegalChar = 'Illegal character';
sOverflowInArithmeticOperation = 'Overflow in arithmetic operation'; sOverflowInArithmeticOperation = 'Overflow in arithmetic operation';
sDivByZero = 'Division by zero';
type type
{ TResolveData - base class for data stored in TPasElement.CustomData } { TResolveData - base class for data stored in TPasElement.CustomData }
@ -167,6 +194,11 @@ type
end; end;
TResolveDataClass = class of TResolveData; TResolveDataClass = class of TResolveData;
type
MaxPrecInt = int64;
MaxPrecUInt = qword;
MaxPrecFloat = extended;
type type
{ TResEvalValue } { TResEvalValue }
@ -174,7 +206,7 @@ type
revkNone, revkNone,
revkCustom, revkCustom,
revkNil, // TResEvalValue revkNil, // TResEvalValue
revkBool, // TResEvalInt revkBool, // TResEvalBool
revkInt, // TResEvalInt revkInt, // TResEvalInt
revkUInt, // TResEvalUInt revkUInt, // TResEvalUInt
revkFloat, // TResEvalFloat revkFloat, // TResEvalFloat
@ -196,11 +228,21 @@ type
end; end;
TResEvalValueClass = class of TResEvalValue; TResEvalValueClass = class of TResEvalValue;
{ TResEvalBool }
TResEvalBool = class(TResEvalValue)
public
B: boolean;
constructor Create; override;
function Clone: TResEvalValue; override;
function AsString: string; override;
end;
{ TResEvalInt } { TResEvalInt }
TResEvalInt = class(TResEvalValue) TResEvalInt = class(TResEvalValue)
public public
Int: NativeInt; Int: MaxPrecInt;
constructor Create; override; constructor Create; override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
@ -210,7 +252,7 @@ type
TResEvalUInt = class(TResEvalValue) TResEvalUInt = class(TResEvalValue)
public public
UInt: NativeUInt; UInt: MaxPrecUInt;
constructor Create; override; constructor Create; override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
@ -220,7 +262,7 @@ type
TResEvalFloat = class(TResEvalValue) TResEvalFloat = class(TResEvalValue)
public public
FloatValue: extended; FloatValue: MaxPrecFloat;
constructor Create; override; constructor Create; override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
@ -281,7 +323,7 @@ type
TResEvalRangeUInt = class(TResEvalValue) TResEvalRangeUInt = class(TResEvalValue)
public public
RangeStart, RangeEnd: qword; RangeStart, RangeEnd: MaxPrecUInt;
constructor Create; override; constructor Create; override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
@ -342,13 +384,25 @@ type
procedure RaiseConstantExprExp(id: int64; ErrorEl: TPasElement); procedure RaiseConstantExprExp(id: int64; ErrorEl: TPasElement);
procedure RaiseRangeCheck(id: int64; ErrorEl: TPasElement); procedure RaiseRangeCheck(id: int64; ErrorEl: TPasElement);
procedure RaiseOverflowArithmetic(id: int64; ErrorEl: TPasElement); procedure RaiseOverflowArithmetic(id: int64; ErrorEl: TPasElement);
procedure RaiseDivByZero(id: int64; ErrorEl: TPasElement);
function EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags): TResEvalValue; function EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags): TResEvalValue;
function EvalBinaryExpr(Expr: TBinaryExpr; Flags: TResEvalFlags): TResEvalValue; function EvalBinaryExpr(Expr: TBinaryExpr; Flags: TResEvalFlags): TResEvalValue;
function EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
function EvalArrayParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; function EvalArrayParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
function EvalFuncParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; function EvalFuncParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
function EvalSetParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; function EvalSetParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
function ExprStringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual; function ExprStringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual;
function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual; function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual;
function CreateResEvalInt(UInt: MaxPrecUInt): TResEvalValue; virtual;
public public
function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue; function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue;
function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean; function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean;
@ -357,10 +411,11 @@ type
procedure EmitRangeCheckConst(id: int64; const aValue, MinVal, MaxVal: String; procedure EmitRangeCheckConst(id: int64; const aValue, MinVal, MaxVal: String;
PosEl: TPasElement); virtual; PosEl: TPasElement); virtual;
procedure EmitRangeCheckConst(id: int64; const aValue: String; procedure EmitRangeCheckConst(id: int64; const aValue: String;
MinVal, MaxVal: int64; PosEl: TPasElement); MinVal, MaxVal: MaxPrecInt; PosEl: TPasElement);
property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog; property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog;
property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier; property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier;
end; end;
TResExprEvaluatorClass = class of TResExprEvaluator;
procedure ReleaseEvalValue(var Value: TResEvalValue); procedure ReleaseEvalValue(var Value: TResEvalValue);
@ -638,6 +693,25 @@ begin
Result:=v.AsDebugString; Result:=v.AsDebugString;
end; end;
{ TResEvalBool }
constructor TResEvalBool.Create;
begin
inherited Create;
Kind:=revkBool;
end;
function TResEvalBool.Clone: TResEvalValue;
begin
Result:=inherited Clone;
TResEvalBool(Result).B:=B;
end;
function TResEvalBool.AsString: string;
begin
if B then Result:='false' else Result:='true';
end;
{ TResEvalRangeUInt } { TResEvalRangeUInt }
constructor TResEvalRangeUInt.Create; constructor TResEvalRangeUInt.Create;
@ -710,6 +784,11 @@ begin
RaiseMsg(id,nOverflowInArithmeticOperation,sOverflowInArithmeticOperation,[],ErrorEl); RaiseMsg(id,nOverflowInArithmeticOperation,sOverflowInArithmeticOperation,[],ErrorEl);
end; end;
procedure TResExprEvaluator.RaiseDivByZero(id: int64; ErrorEl: TPasElement);
begin
RaiseMsg(id,nDivByZero,sDivByZero,[],ErrorEl);
end;
function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags
): TResEvalValue; ): TResEvalValue;
begin begin
@ -746,10 +825,7 @@ begin
begin begin
if Result.Element<>nil then if Result.Element<>nil then
Result:=Result.Clone; Result:=Result.Clone;
if TResEvalInt(Result).Int=0 then TResEvalBool(Result).B:=not TResEvalBool(Result).B;
TResEvalInt(Result).Int:=1
else
TResEvalInt(Result).Int:=0;
end end
else else
begin begin
@ -762,12 +838,12 @@ begin
begin begin
if Result.Element=nil then if Result.Element=nil then
Result.Free; Result.Free;
// @ operator requires a compiler -> return nil // @ operator requires a compiler (not just a resolver) -> return nil
Result:=TResEvalValue.Create; Result:=TResEvalValue.Create;
Result.Kind:=revkNil; Result.Kind:=revkNil;
end end
else else
RaiseNotYetImplemented(20170518232823,Expr); RaiseNotYetImplemented(20170518232823,Expr,'operator='+OpcodeStrings[Expr.OpCode]);
end; end;
end; end;
@ -775,9 +851,6 @@ function TResExprEvaluator.EvalBinaryExpr(Expr: TBinaryExpr;
Flags: TResEvalFlags): TResEvalValue; Flags: TResEvalFlags): TResEvalValue;
var var
LeftValue, RightValue: TResEvalValue; LeftValue, RightValue: TResEvalValue;
LeftInt, RightInt: LongWord;
Int: NativeInt;
UInt: NativeUInt;
begin begin
Result:=nil; Result:=nil;
LeftValue:=nil; LeftValue:=nil;
@ -790,6 +863,51 @@ begin
case Expr.Kind of case Expr.Kind of
pekRange: pekRange:
// leftvalue..rightvalue // leftvalue..rightvalue
Result:=EvalBinaryRangeExpr(Expr,LeftValue,RightValue);
pekBinary:
case Expr.OpCode of
eopAdd:
Result:=EvalBinaryAddExpr(Expr,LeftValue,RightValue);
eopSubtract:
Result:=EvalBinarySubExpr(Expr,LeftValue,RightValue);
eopMultiply:
Result:=EvalBinaryMulExpr(Expr,LeftValue,RightValue);
eopDiv:
Result:=EvalBinaryDivExpr(Expr,LeftValue,RightValue);
eopMod:
Result:=EvalBinaryModExpr(Expr,LeftValue,RightValue);
eopPower:
Result:=EvalBinaryPowerExpr(Expr,LeftValue,RightValue);
eopShl,eopShr:
Result:=EvalBinaryShiftExpr(Expr,LeftValue,RightValue);
eopAnd,eopOr,eopXor:
Result:=EvalBinaryBoolOpExpr(Expr,LeftValue,RightValue);
eopEqual,eopNotEqual:
Result:=EvalBinaryNEqualExpr(Expr,LeftValue,RightValue);
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr Opcode=',OpcodeStrings[Expr.OpCode],' Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530100823,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode]);
{$ENDIF}
RaiseNotYetImplemented(20170530100827,Expr);
end;
finally
ReleaseEvalValue(LeftValue);
ReleaseEvalValue(RightValue);
end;
end;
function TResExprEvaluator.EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
// LeftValue..RightValue
var
LeftInt, RightInt: LongWord;
begin
case LeftValue.Kind of case LeftValue.Kind of
revkInt: revkInt:
if RightValue.Kind=revkInt then if RightValue.Kind=revkInt then
@ -806,7 +924,7 @@ begin
else if RightValue.Kind=revkUInt then else if RightValue.Kind=revkUInt then
begin begin
// Note: when FPC compares int64 with qword it converts the qword to an int64 // Note: when FPC compares int64 with qword it converts the qword to an int64
if TResEvalUInt(RightValue).UInt<=NativeUInt(High(NativeInt)) then if TResEvalUInt(RightValue).UInt<=MaxPrecUInt(High(MaxPrecInt)) then
begin begin
if TResEvalInt(LeftValue).Int>TResEvalUInt(RightValue).UInt then if TResEvalInt(LeftValue).Int>TResEvalUInt(RightValue).UInt then
RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit, RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit,
@ -819,7 +937,7 @@ begin
end end
else if TResEvalInt(LeftValue).Int<0 then else if TResEvalInt(LeftValue).Int<0 then
RaiseRangeCheck(20170522151629,Expr.Right) RaiseRangeCheck(20170522151629,Expr.Right)
else if qword(TResEvalInt(LeftValue).Int)>TResEvalUInt(RightValue).UInt then else if MaxPrecUInt(TResEvalInt(LeftValue).Int)>TResEvalUInt(RightValue).UInt then
RaiseMsg(20170522151708,nHighRangeLimitLTLowRangeLimit, RaiseMsg(20170522151708,nHighRangeLimitLTLowRangeLimit,
sHighRangeLimitLTLowRangeLimit,[],Expr.Right); sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
Result:=TResEvalRangeUInt.Create; Result:=TResEvalRangeUInt.Create;
@ -833,11 +951,11 @@ begin
if RightValue.Kind=revkInt then if RightValue.Kind=revkInt then
begin begin
// Note: when FPC compares int64 with qword it converts the qword to an int64 // Note: when FPC compares int64 with qword it converts the qword to an int64
if TResEvalUInt(LeftValue).UInt>NativeUInt(High(NativeInt)) then if TResEvalUInt(LeftValue).UInt>MaxPrecUInt(High(MaxPrecInt)) then
begin begin
if TResEvalInt(RightValue).Int<0 then if TResEvalInt(RightValue).Int<0 then
RaiseRangeCheck(20170522152608,Expr.Right) RaiseRangeCheck(20170522152608,Expr.Right)
else if TResEvalUInt(LeftValue).UInt>qword(TResEvalInt(RightValue).Int) then else if TResEvalUInt(LeftValue).UInt>MaxPrecUInt(TResEvalInt(RightValue).Int) then
RaiseMsg(20170522152648,nHighRangeLimitLTLowRangeLimit, RaiseMsg(20170522152648,nHighRangeLimitLTLowRangeLimit,
sHighRangeLimitLTLowRangeLimit,[],Expr.Right); sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
Result:=TResEvalRangeUInt.Create; Result:=TResEvalRangeUInt.Create;
@ -902,64 +1020,550 @@ begin
end end
else else
{$IFDEF EnablePasResRangeCheck} {$IFDEF EnablePasResRangeCheck}
writeln('TPasResolver.Eval pekRange Left=',GetObjName(Expr.Left),' LeftValue.Kind=',LeftValue.Kind); writeln('TResExprEvaluator.EvalBinaryRangeExpr Left=',GetObjName(Expr.Left),' LeftValue.Kind=',LeftValue.Kind);
RaiseNotYetImplemented(20170518221103,Expr.Left); RaiseNotYetImplemented(20170518221103,Expr.Left);
{$ELSE} {$ELSE}
exit(nil); exit(nil);
{$ENDIF} {$ENDIF}
end; end;
pekBinary: end;
case Expr.OpCode of
eopAdd: function TResExprEvaluator.EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
begin
case LeftValue.Kind of case LeftValue.Kind of
revkInt: revkInt:
if RightValue.Kind=revkInt then case RightValue.Kind of
revkInt:
// int+int // int+int
try try
{$Q+} {$Q+}
Int:=TResEvalInt(LeftValue).Int+TResEvalInt(RightValue).Int; Int:=TResEvalInt(LeftValue).Int + TResEvalInt(RightValue).Int;
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF} {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
Result:=TResEvalInt.Create; Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=NativeInt(Int); TResEvalInt(Result).Int:=Int;
except except
on E: EOverflow do on E: EOverflow do
if (TResEvalInt(LeftValue).Int>0) and (TResEvalInt(RightValue).Int>0) then if (TResEvalInt(LeftValue).Int>0) and (TResEvalInt(RightValue).Int>0) then
begin begin
UInt:=NativeUInt(TResEvalInt(LeftValue).Int)+NativeUInt(TResEvalInt(RightValue).Int); UInt:=MaxPrecUInt(TResEvalInt(LeftValue).Int)+MaxPrecUInt(TResEvalInt(RightValue).Int);
Result:=TResEvalUInt.Create; Result:=CreateResEvalInt(UInt);
TResEvalUInt(Result).UInt:=UInt;
end end
else else
RaiseOverflowArithmetic(20170525122256,Expr); RaiseOverflowArithmetic(20170525122256,Expr);
end end
// ToDo: int+uint
else else
begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr add int+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); writeln('TResExprEvaluator.EvalBinaryAddExpr int+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF} {$ENDIF}
RaiseNotYetImplemented(20170525115537,Expr); RaiseNotYetImplemented(20170525115537,Expr);
end; end;
// ToDo: uint+int, uint+uint
else else
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr add ?+ Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); writeln('TResExprEvaluator.EvalBinaryAddExpr ?+ Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF} {$ENDIF}
RaiseNotYetImplemented(20170525115548,Expr); RaiseNotYetImplemented(20170525115548,Expr);
end; end;
end;
function TResExprEvaluator.EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
begin
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int-int
try
{$Q+}
Int:=TResEvalInt(LeftValue).Int - TResEvalInt(RightValue).Int;
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
on E: EOverflow do
if (TResEvalInt(LeftValue).Int>0) and (TResEvalInt(RightValue).Int<0) then
begin
UInt:=MaxPrecUInt(TResEvalInt(LeftValue).Int)+MaxPrecUInt(-TResEvalInt(RightValue).Int);
Result:=CreateResEvalInt(UInt);
end
else
RaiseOverflowArithmetic(20170525230247,Expr);
end;
// ToDo: int-uint
else else
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr Opcode=',OpcodeStrings[Expr.OpCode],' Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); writeln('TResExprEvaluator.EvalBinarySubExpr sub int-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF} {$ENDIF}
RaiseNotYetImplemented(20170518232823,Expr); RaiseNotYetImplemented(20170525230028,Expr);
end;
// ToDo: uint-int, uint-uint
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinarySubExpr sub ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170525225946,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
begin
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int*int
try
{$Q+}
Int:=TResEvalInt(LeftValue).Int * TResEvalInt(RightValue).Int;
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
on E: EOverflow do
if (TResEvalInt(LeftValue).Int>0) and (TResEvalInt(RightValue).Int>0) then
try
// try uint*uint
{$Q+}
UInt:=MaxPrecUInt(TResEvalInt(LeftValue).Int) * MaxPrecUInt(TResEvalInt(RightValue).Int);
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
Result:=CreateResEvalInt(UInt);
except
on E: EOverflow do
RaiseOverflowArithmetic(20170530101616,Expr);
end
else
RaiseOverflowArithmetic(20170525230247,Expr);
end;
// ToDo: int*uint
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryMulExpr mul int*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170525230028,Expr);
end;
// ToDo: uint*int, uint*uint
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryMulExpr mul ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170525225946,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
begin
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int div int
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530102619,Expr)
else
begin
Int:=TResEvalInt(LeftValue).Int div TResEvalInt(RightValue).Int;
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end;
revkUInt:
// int div uint
if TResEvalUInt(RightValue).UInt=0 then
RaiseDivByZero(20170530102745,Expr)
else
begin
if TResEvalUInt(RightValue).UInt>High(MaxPrecInt) then
Int:=0
else
Int:=TResEvalInt(LeftValue).Int div TResEvalUInt(RightValue).UInt;
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end; end;
else else
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode]); writeln('TResExprEvaluator.EvalBinaryDivExpr int div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF} {$ENDIF}
RaiseNotYetImplemented(20170518232823,Expr); RaiseNotYetImplemented(20170530102403,Expr);
end; end;
finally revkUInt:
ReleaseEvalValue(LeftValue); case RightValue.Kind of
ReleaseEvalValue(RightValue); revkInt:
// uint div int
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530103026,Expr)
else if TResEvalUInt(LeftValue).UInt<=High(MaxPrecInt) then
begin
Int:=MaxPrecInt(TResEvalUInt(LeftValue).UInt) div TResEvalInt(RightValue).Int;
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end
else if TResEvalInt(RightValue).Int>0 then
begin
UInt:=TResEvalUInt(LeftValue).UInt div MaxPrecUInt(TResEvalInt(RightValue).Int);
Result:=CreateResEvalInt(UInt);
end
else
RaiseOverflowArithmetic(20170530104315,Expr);
revkUInt:
// uint div uint
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530103026,Expr)
else
begin
UInt:=TResEvalUInt(LeftValue).UInt div TResEvalUInt(RightValue).UInt;
Result:=CreateResEvalInt(UInt);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryDivExpr uint div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530102403,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryDivExpr div ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530102352,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
begin
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int mod int
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530104638,Expr)
else
begin
Int:=TResEvalInt(LeftValue).Int mod TResEvalInt(RightValue).Int;
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end;
revkUInt:
// int mod uint
if TResEvalUInt(RightValue).UInt=0 then
RaiseDivByZero(20170530104758,Expr)
else
begin
if TResEvalInt(LeftValue).Int<0 then
UInt:=MaxPrecUInt(-TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt
else
UInt:=MaxPrecUInt(TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt;
Result:=CreateResEvalInt(UInt);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryModExpr int mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530110057,Expr);
end;
revkUInt:
case RightValue.Kind of
revkInt:
// uint mod int
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530110110,Expr)
else if TResEvalUInt(LeftValue).UInt<=High(MaxPrecInt) then
begin
Int:=MaxPrecInt(TResEvalUInt(LeftValue).UInt) mod TResEvalInt(RightValue).Int;
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end
else if TResEvalInt(RightValue).Int>0 then
begin
UInt:=TResEvalUInt(LeftValue).UInt mod MaxPrecUInt(TResEvalInt(RightValue).Int);
Result:=CreateResEvalInt(UInt);
end
else
RaiseOverflowArithmetic(20170530110602,Expr);
revkUInt:
// uint div uint
if TResEvalInt(RightValue).Int=0 then
RaiseDivByZero(20170530110609,Expr)
else
begin
UInt:=TResEvalUInt(LeftValue).UInt mod TResEvalUInt(RightValue).UInt;
Result:=CreateResEvalInt(UInt);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryModExpr uint mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530110633,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryModExpr mod ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530110644,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
UInt: MaxPrecUInt;
ShiftLeft: Boolean;
begin
ShiftLeft:=Expr.OpCode=eopShl;
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int shl int
begin
if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
EmitRangeCheckConst(20170530203840,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
if ShiftLeft then
Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalInt(RightValue).Int)
else
Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalInt(RightValue).Int);
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end;
revkUInt:
// int shl uint
begin
if (TResEvalUInt(RightValue).UInt>63) then
EmitRangeCheckConst(20170530203840,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
if ShiftLeft then
Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalUInt(RightValue).UInt)
else
Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalUInt(RightValue).UInt);
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryModExpr int shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205332,Expr);
end;
revkUInt:
case RightValue.Kind of
revkInt:
// uint shl int
begin
if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
EmitRangeCheckConst(20170530205414,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
if ShiftLeft then
UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalInt(RightValue).Int)
else
UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalInt(RightValue).Int);
Result:=CreateResEvalInt(UInt);
end;
revkUInt:
// uint shl uint
begin
if (TResEvalUInt(RightValue).UInt>63) then
EmitRangeCheckConst(20170530205601,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
if ShiftLeft then
UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalUInt(RightValue).UInt)
else
UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalUInt(RightValue).UInt);
Result:=CreateResEvalInt(UInt);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryShiftExpr uint shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205640,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryShiftExpr shl/shr ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205646,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
// AND, OR, XOR
begin
case LeftValue.Kind of
revkBool:
case RightValue.Kind of
revkBool:
begin
// logical and/or/xor
Result:=TResEvalBool.Create;
case Expr.OpCode of
eopAnd: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B and TResEvalBool(RightValue).B;
eopOr: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B or TResEvalBool(RightValue).B;
eopXor: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B xor TResEvalBool(RightValue).B;
end;
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryBoolOpExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170531011502,Expr);
end;
revkInt:
case RightValue.Kind of
revkInt:
begin
// bitwise and/or/xor
Result:=TResEvalInt.Create;
case Expr.OpCode of
eopAnd: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int and TResEvalInt(RightValue).Int;
eopOr: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int or TResEvalInt(RightValue).Int;
eopXor: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int xor TResEvalInt(RightValue).Int;
end;
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryBoolOpExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530211140,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryBoolOpExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205938,Expr);
end;
end;
function TResExprEvaluator.EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
begin
Result:=TResEvalBool.Create;
case LeftValue.Kind of
revkBool:
case RightValue.Kind of
revkBool:
TResEvalBool(Result).B:=TResEvalBool(LeftValue).B=TResEvalBool(RightValue).B;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryNEqualExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170531011937,Expr);
end;
revkInt:
case RightValue.Kind of
revkInt:
TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalInt(RightValue).Int;
revkUInt:
TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalUInt(RightValue).UInt;
revkFloat:
TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalFloat(RightValue).FloatValue;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryNEqualExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170531012412,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryNEqualExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170531011931,Expr);
end;
if Expr.OpCode=eopNotEqual then
TResEvalBool(Result).B:=not TResEvalBool(Result).B;
end;
function TResExprEvaluator.EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue,
RightValue: TResEvalValue): TResEvalValue;
var
Int: MaxPrecInt;
begin
case LeftValue.Kind of
revkInt:
case RightValue.Kind of
revkInt:
// int^^int
try
{$Q+}{$R+}
Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalInt(RightValue).Int));
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
{$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
RaiseOverflowArithmetic(20170530210533,Expr);
end;
revkUInt:
// int^^uint
try
{$Q+}{$R+}
Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalUInt(RightValue).UInt));
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
{$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
RaiseOverflowArithmetic(20170530211028,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryPowerExpr int ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205640,Expr);
end;
revkUInt:
case RightValue.Kind of
revkInt:
// uint^^int
try
{$Q+}{$R+}
Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalInt(RightValue).Int));
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
{$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
RaiseOverflowArithmetic(20170530211102,Expr);
end;
revkUInt:
// uint^^uint
try
{$Q+}{$R+}
Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalUInt(RightValue).UInt));
{$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
{$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=Int;
except
RaiseOverflowArithmetic(20170530211121,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryPowerExpr uint ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530211140,Expr);
end;
else
{$IFDEF VerbosePasResolver}
writeln('TResExprEvaluator.EvalBinaryPowerExpr ^^ ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170530205938,Expr);
end; end;
end; end;
@ -1205,14 +1809,28 @@ begin
{$ENDIF} {$ENDIF}
end; end;
function TResExprEvaluator.CreateResEvalInt(UInt: MaxPrecUInt): TResEvalValue;
begin
if UInt<=high(MaxPrecInt) then
begin
Result:=TResEvalInt.Create;
TResEvalInt(Result).Int:=MaxPrecInt(UInt);
end
else
begin
Result:=TResEvalUInt.Create;
TResEvalUInt(Result).UInt:=UInt;
end;
end;
function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags
): TResEvalValue; ): TResEvalValue;
var var
C: TClass; C: TClass;
Code: integer; Code: integer;
Int: NativeInt; Int: MaxPrecInt;
UInt: NativeUInt; UInt: MaxPrecUInt;
Ext: Extended; Flo: MaxPrecFloat;
begin begin
Result:=nil; Result:=nil;
if Expr.CustomData is TResEvalValue then if Expr.CustomData is TResEvalValue then
@ -1238,7 +1856,7 @@ begin
Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags); Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags);
pekNumber: pekNumber:
begin begin
// try int64 // try MaxPrecInt
val(TPrimitiveExpr(Expr).Value,Int,Code); val(TPrimitiveExpr(Expr).Value,Int,Code);
if Code=0 then if Code=0 then
begin begin
@ -1246,7 +1864,7 @@ begin
TResEvalInt(Result).Int:=Int; TResEvalInt(Result).Int:=Int;
exit; exit;
end; end;
// try qword // try MaxPrecUInt
val(TPrimitiveExpr(Expr).Value,UInt,Code); val(TPrimitiveExpr(Expr).Value,UInt,Code);
if Code=0 then if Code=0 then
begin begin
@ -1255,11 +1873,11 @@ begin
exit; exit;
end; end;
// try float // try float
val(TPrimitiveExpr(Expr).Value,Ext,Code); val(TPrimitiveExpr(Expr).Value,Flo,Code);
if Code=0 then if Code=0 then
begin begin
Result:=TResEvalFloat.Create; Result:=TResEvalFloat.Create;
TResEvalFloat(Result).FloatValue:=Ext; TResEvalFloat(Result).FloatValue:=Flo;
exit; exit;
end; end;
RaiseRangeCheck(20170518202252,Expr); RaiseRangeCheck(20170518202252,Expr);
@ -1280,12 +1898,8 @@ begin
end end
else if C=TBoolConstExpr then else if C=TBoolConstExpr then
begin begin
Result:=TResEvalInt.Create; Result:=TResEvalBool.Create;
Result.Kind:=revkBool; TResEvalBool(Result).B:=TBoolConstExpr(Expr).Value;
if TBoolConstExpr(Expr).Value then
TResEvalInt(Result).Int:=1
else
TResEvalInt(Result).Int:=0;
end end
else if C=TUnaryExpr then else if C=TUnaryExpr then
Result:=EvalUnaryExpr(TUnaryExpr(Expr),Flags) Result:=EvalUnaryExpr(TUnaryExpr(Expr),Flags)
@ -1377,9 +1991,9 @@ begin
else if ExprValue.Kind=revkUInt then else if ExprValue.Kind=revkUInt then
begin begin
// uint in int..int // uint in int..int
if (TResEvalUInt(ExprValue).UInt>NativeUInt(High(NativeInt))) if (TResEvalUInt(ExprValue).UInt>MaxPrecUInt(High(MaxPrecInt)))
or (NativeInt(TResEvalUInt(ExprValue).UInt)<RgInt.RangeStart) or (MaxPrecInt(TResEvalUInt(ExprValue).UInt)<RgInt.RangeStart)
or (NativeInt(TResEvalUInt(ExprValue).UInt)>RgInt.RangeEnd) then or (MaxPrecInt(TResEvalUInt(ExprValue).UInt)>RgInt.RangeEnd) then
begin begin
if EmitHints then if EmitHints then
EmitRangeCheckConst(20170522215852,ExprValue.AsString, EmitRangeCheckConst(20170522215852,ExprValue.AsString,
@ -1422,8 +2036,8 @@ begin
// int in uint..uint // int in uint..uint
RgUInt:=TResEvalRangeUInt(RangeValue); RgUInt:=TResEvalRangeUInt(RangeValue);
if (TResEvalInt(ExprValue).Int<0) if (TResEvalInt(ExprValue).Int<0)
or (NativeUInt(TResEvalInt(ExprValue).Int)<RgUInt.RangeStart) or (MaxPrecUInt(TResEvalInt(ExprValue).Int)<RgUInt.RangeStart)
or (NativeUInt(TResEvalInt(ExprValue).Int)>RgUInt.RangeEnd) then or (MaxPrecUInt(TResEvalInt(ExprValue).Int)>RgUInt.RangeEnd) then
begin begin
if EmitHints then if EmitHints then
EmitRangeCheckConst(20170522172250,ExprValue.AsString, EmitRangeCheckConst(20170522172250,ExprValue.AsString,
@ -1495,7 +2109,7 @@ begin
end; end;
procedure TResExprEvaluator.EmitRangeCheckConst(id: int64; procedure TResExprEvaluator.EmitRangeCheckConst(id: int64;
const aValue: String; MinVal, MaxVal: int64; PosEl: TPasElement); const aValue: String; MinVal, MaxVal: MaxPrecInt; PosEl: TPasElement);
begin begin
EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl); EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl);
end; end;
@ -1592,10 +2206,7 @@ end;
function TResEvalInt.AsString: string; function TResEvalInt.AsString: string;
begin begin
case Kind of Result:=IntToStr(Int);
revkBool: if Int=0 then Result:='false' else Result:='true';
revkInt: Result:=IntToStr(Int);
end;
end; end;
{ TResEvalFloat } { TResEvalFloat }

178
packages/fcl-passrc/src/pasresolver.pp
View File

@ -144,13 +144,15 @@ ToDo:
- boolean ranges - boolean ranges
- enum ranges - enum ranges
- char ranges - char ranges
- +, -, *, div, mod, /, shl, shr, or, and, xor - +, -, *, div, mod, /, shl, shr, or, and, xor, in, ^^, ><
- =, <>, <, <=, >, >=
- ord(), low(), high(), pred(), succ(), length() - ord(), low(), high(), pred(), succ(), length()
- string[index] - string[index]
- arr[index] - arr[index]
- call(param) - call(param)
- indexedprop[param] - indexedprop[param]
- a:=value - a:=value
- set+set, set*set, set-set
- @@ - @@
- fail to write a loop var inside the loop - fail to write a loop var inside the loop
- warn: create class with abstract methods - warn: create class with abstract methods
@ -840,6 +842,8 @@ type
Exp: TPasExpr; RaiseOnError: boolean): integer of object; Exp: TPasExpr; RaiseOnError: boolean): integer of object;
TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr; TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
out ResolvedEl: TPasResolverResult) of object; out ResolvedEl: TPasResolverResult) of object;
TOnEvalBIFunction = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
out Evaluated: TResEvalValue) of object;
TOnFinishParamsExpr = procedure(Proc: TResElDataBuiltInProc; TOnFinishParamsExpr = procedure(Proc: TResElDataBuiltInProc;
Params: TParamsExpr) of object; Params: TParamsExpr) of object;
@ -857,6 +861,7 @@ type
BuiltIn: TResolverBuiltInProc; BuiltIn: TResolverBuiltInProc;
GetCallCompatibility: TOnGetCallCompatibility; GetCallCompatibility: TOnGetCallCompatibility;
GetCallResult: TOnGetCallResult; GetCallResult: TOnGetCallResult;
Eval: TOnEvalBIFunction;
FinishParamsExpression: TOnFinishParamsExpr; FinishParamsExpression: TOnFinishParamsExpr;
Flags: TBuiltInProcFlags; Flags: TBuiltInProcFlags;
end; end;
@ -1101,6 +1106,8 @@ type
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc; procedure BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
procedure BI_Length_OnEval(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out Evaluated: TResEvalValue); virtual;
function BI_SetLength_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; function BI_SetLength_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_SetLength_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; procedure BI_SetLength_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
@ -1208,6 +1215,7 @@ type
function AddBuiltInProc(const aName: string; Signature: string; function AddBuiltInProc(const aName: string; Signature: string;
const GetCallCompatibility: TOnGetCallCompatibility; const GetCallCompatibility: TOnGetCallCompatibility;
const GetCallResult: TOnGetCallResult; const GetCallResult: TOnGetCallResult;
const EvalConst: TOnEvalBIFunction = nil;
const FinishParamsExpr: TOnFinishParamsExpr = nil; const FinishParamsExpr: TOnFinishParamsExpr = nil;
const BuiltIn: TResolverBuiltInProc = bfCustom; const BuiltIn: TResolverBuiltInProc = bfCustom;
const Flags: TBuiltInProcFlags = []): TResElDataBuiltInProc; const Flags: TBuiltInProcFlags = []): TResElDataBuiltInProc;
@ -1304,6 +1312,7 @@ type
ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean; ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
function CheckAssignCompatibility(const LHS, RHS: TPasElement; function CheckAssignCompatibility(const LHS, RHS: TPasElement;
RaiseOnIncompatible: boolean = true): integer; RaiseOnIncompatible: boolean = true): integer;
procedure CheckAssignExprRange(const LeftResolved: TPasResolverResult; RHS: TPasExpr);
function CheckAssignResCompatibility(const LHS, RHS: TPasResolverResult; function CheckAssignResCompatibility(const LHS, RHS: TPasResolverResult;
ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
function CheckEqualElCompatibility(Left, Right: TPasElement; function CheckEqualElCompatibility(Left, Right: TPasElement;
@ -3359,6 +3368,7 @@ end;
procedure TPasResolver.FinishConstRangeExpr(Left, Right: TPasExpr; out LeftResolved, procedure TPasResolver.FinishConstRangeExpr(Left, Right: TPasExpr; out LeftResolved,
RightResolved: TPasResolverResult); RightResolved: TPasResolverResult);
// for example Left..Right
{$IFDEF EnablePasResRangeCheck} {$IFDEF EnablePasResRangeCheck}
var var
RgValue: TResEvalValue; RgValue: TResEvalValue;
@ -3427,7 +3437,9 @@ procedure TPasResolver.FinishConstDef(El: TPasConst);
begin begin
ResolveExpr(El.Expr,rraRead); ResolveExpr(El.Expr,rraRead);
if El.VarType<>nil then if El.VarType<>nil then
CheckAssignCompatibility(El,El.Expr,true); CheckAssignCompatibility(El,El.Expr,true)
else
Eval(El.Expr,[refConst]);
end; end;
procedure TPasResolver.FinishProcedure(aProc: TPasProcedure); procedure TPasResolver.FinishProcedure(aProc: TPasProcedure);
@ -4775,7 +4787,12 @@ begin
case El.Kind of case El.Kind of
akDefault: akDefault:
begin
CheckAssignResCompatibility(LeftResolved,RightResolved,El.right,true); CheckAssignResCompatibility(LeftResolved,RightResolved,El.right,true);
{$IFDEF EnablePasResRangeCheck}
CheckAssignExprRange(LeftResolved,El.right);
{$ENDIF}
end;
akAdd, akMinus,akMul,akDivision: akAdd, akMinus,akMul,akDivision:
begin begin
if (El.Kind in [akAdd,akMinus,akMul]) and (LeftResolved.BaseType in btAllInteger) then if (El.Kind in [akAdd,akMinus,akMul]) and (LeftResolved.BaseType in btAllInteger) then
@ -4816,6 +4833,8 @@ begin
end end
else else
RaiseMsg(20170216152125,nIllegalQualifier,sIllegalQualifier,[AssignKindNames[El.Kind]],El); RaiseMsg(20170216152125,nIllegalQualifier,sIllegalQualifier,[AssignKindNames[El.Kind]],El);
// store const expression result
Eval(El.right,[]);
end; end;
else else
RaiseNotYetImplemented(20160927143649,El,'AssignKind '+AssignKindNames[El.Kind]); RaiseNotYetImplemented(20160927143649,El,'AssignKind '+AssignKindNames[El.Kind]);
@ -6167,6 +6186,8 @@ begin
if not (RightResolved.BaseType in btAllInteger) then if not (RightResolved.BaseType in btAllInteger) then
RaiseXExpectedButYFound(20170216152600,'integer',BaseTypeNames[RightResolved.BaseType],Bin.right); RaiseXExpectedButYFound(20170216152600,'integer',BaseTypeNames[RightResolved.BaseType],Bin.right);
SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]); SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
if Bin.Parent is TPasRangeType then
ResolvedEl.TypeEl:=TPasRangeType(Bin.Parent);
exit; exit;
end; end;
eopAdd, eopSubtract, eopAdd, eopSubtract,
@ -7407,6 +7428,9 @@ function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags;
// Important: Caller must free result if (Result<>nil) and (Result.Element=nil) // Important: Caller must free result if (Result<>nil) and (Result.Element=nil)
// use utility function ReleaseEvalValue(Result) // use utility function ReleaseEvalValue(Result)
begin begin
{$IFNDEF EnablePasResRangeCheck}
exit(nil);
{$ENDIF}
Result:=fExprEvaluator.Eval(Expr,Flags); Result:=fExprEvaluator.Eval(Expr,Flags);
if Result=nil then exit; if Result=nil then exit;
@ -7482,6 +7506,28 @@ begin
FBaseTypes[BaseTypeLength],[rrfReadable]); FBaseTypes[BaseTypeLength],[rrfReadable]);
end; end;
procedure TPasResolver.BI_Length_OnEval(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out Evaluated: TResEvalValue);
var
Value: TResEvalValue;
begin
Evaluated:=nil;
Value:=Eval(Params.Params[0],[refAutoConst]);
if Value=nil then exit;
if Value.Kind=revkString then
begin
Evaluated:=TResEvalInt.Create;
TResEvalInt(Evaluated).Int:=length(TResEvalString(Value).S);
end
else if Value.Kind=revkUnicodeString then
begin
Evaluated:=TResEvalInt.Create;
TResEvalInt(Evaluated).Int:=length(TResEvalUTF16(Value).S);
end;
ReleaseEvalValue(Value);
if Proc=nil then ;
end;
function TPasResolver.BI_SetLength_OnGetCallCompatibility( function TPasResolver.BI_SetLength_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
// check params of built in proc 'setlength' // check params of built in proc 'setlength'
@ -7985,7 +8031,7 @@ function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
// floats supports value:Width:Precision // floats supports value:Width:Precision
Ok:=true Ok:=true
else else
// all other only support only Width // all other only support value:Width
Ok:=Index<2; Ok:=Index<2;
if not Ok then if not Ok then
begin begin
@ -9109,82 +9155,91 @@ begin
AddBaseType(BaseTypeNames[bt],bt); AddBaseType(BaseTypeNames[bt],bt);
if bfLength in TheBaseProcs then if bfLength in TheBaseProcs then
AddBuiltInProc('Length','function Length(const String or Array): sizeint', AddBuiltInProc('Length','function Length(const String or Array): sizeint',
@BI_Length_OnGetCallCompatibility,@BI_Length_OnGetCallResult,nil,bfLength); @BI_Length_OnGetCallCompatibility,@BI_Length_OnGetCallResult,
@BI_Length_OnEval,nil,bfLength);
if bfSetLength in TheBaseProcs then if bfSetLength in TheBaseProcs then
AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)', AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)',
@BI_SetLength_OnGetCallCompatibility,nil, @BI_SetLength_OnGetCallCompatibility,nil,nil,
@BI_SetLength_OnFinishParamsExpr,bfSetLength,[bipfCanBeStatement]); @BI_SetLength_OnFinishParamsExpr,bfSetLength,[bipfCanBeStatement]);
if bfInclude in TheBaseProcs then if bfInclude in TheBaseProcs then
AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)', AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)',
@BI_InExclude_OnGetCallCompatibility,nil, @BI_InExclude_OnGetCallCompatibility,nil,nil,
@BI_InExclude_OnFinishParamsExpr,bfInclude,[bipfCanBeStatement]); @BI_InExclude_OnFinishParamsExpr,bfInclude,[bipfCanBeStatement]);
if bfExclude in TheBaseProcs then if bfExclude in TheBaseProcs then
AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)', AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)',
@BI_InExclude_OnGetCallCompatibility,nil, @BI_InExclude_OnGetCallCompatibility,nil,nil,
@BI_InExclude_OnFinishParamsExpr,bfExclude,[bipfCanBeStatement]); @BI_InExclude_OnFinishParamsExpr,bfExclude,[bipfCanBeStatement]);
if bfBreak in TheBaseProcs then if bfBreak in TheBaseProcs then
AddBuiltInProc('Break','procedure Break', AddBuiltInProc('Break','procedure Break',
@BI_Break_OnGetCallCompatibility,nil,nil,bfBreak,[bipfCanBeStatement]); @BI_Break_OnGetCallCompatibility,nil,nil,nil,bfBreak,[bipfCanBeStatement]);
if bfContinue in TheBaseProcs then if bfContinue in TheBaseProcs then
AddBuiltInProc('Continue','procedure Continue', AddBuiltInProc('Continue','procedure Continue',
@BI_Continue_OnGetCallCompatibility,nil,nil,bfContinue,[bipfCanBeStatement]); @BI_Continue_OnGetCallCompatibility,nil,nil,nil,bfContinue,[bipfCanBeStatement]);
if bfExit in TheBaseProcs then if bfExit in TheBaseProcs then
AddBuiltInProc('Exit','procedure Exit(result)', AddBuiltInProc('Exit','procedure Exit(result)',
@BI_Exit_OnGetCallCompatibility,nil,nil,bfExit,[bipfCanBeStatement]); @BI_Exit_OnGetCallCompatibility,nil,nil,nil,bfExit,[bipfCanBeStatement]);
if bfInc in TheBaseProcs then if bfInc in TheBaseProcs then
AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)', AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)',
@BI_IncDec_OnGetCallCompatibility,nil, @BI_IncDec_OnGetCallCompatibility,nil,nil,
@BI_IncDec_OnFinishParamsExpr,bfInc,[bipfCanBeStatement]); @BI_IncDec_OnFinishParamsExpr,bfInc,[bipfCanBeStatement]);
if bfDec in TheBaseProcs then if bfDec in TheBaseProcs then
AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)', AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)',
@BI_IncDec_OnGetCallCompatibility,nil, @BI_IncDec_OnGetCallCompatibility,nil,nil,
@BI_IncDec_OnFinishParamsExpr,bfDec,[bipfCanBeStatement]); @BI_IncDec_OnFinishParamsExpr,bfDec,[bipfCanBeStatement]);
if bfAssigned in TheBaseProcs then if bfAssigned in TheBaseProcs then
AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean', AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean',
@BI_Assigned_OnGetCallCompatibility,@BI_Assigned_OnGetCallResult,nil,bfAssigned); @BI_Assigned_OnGetCallCompatibility,@BI_Assigned_OnGetCallResult,
nil,nil,bfAssigned);
if bfChr in TheBaseProcs then if bfChr in TheBaseProcs then
AddBuiltInProc('Chr','function Chr(const Integer): char', AddBuiltInProc('Chr','function Chr(const Integer): char',
@BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,nil,bfChr); @BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,nil,nil,bfChr);
if bfOrd in TheBaseProcs then if bfOrd in TheBaseProcs then
AddBuiltInProc('Ord','function Ord(const Enum or Char): integer', AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
@BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,nil,bfOrd); @BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,nil,nil,bfOrd);
if bfLow in TheBaseProcs then if bfLow in TheBaseProcs then
AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer', AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
@BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,nil,bfLow); @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
nil,nil,bfLow);
if bfHigh in TheBaseProcs then if bfHigh in TheBaseProcs then
AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer', AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer',
@BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,nil,bfHigh); @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
nil,nil,bfHigh);
if bfPred in TheBaseProcs then if bfPred in TheBaseProcs then
AddBuiltInProc('Pred','function Pred(const ordinal): ordinal', AddBuiltInProc('Pred','function Pred(const ordinal): ordinal',
@BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,nil,bfPred); @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
nil,nil,bfPred);
if bfSucc in TheBaseProcs then if bfSucc in TheBaseProcs then
AddBuiltInProc('Succ','function Succ(const ordinal): ordinal', AddBuiltInProc('Succ','function Succ(const ordinal): ordinal',
@BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,nil,bfSucc); @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
nil,nil,bfSucc);
if bfStrProc in TheBaseProcs then if bfStrProc in TheBaseProcs then
AddBuiltInProc('Str','procedure Str(const var; var String)', AddBuiltInProc('Str','procedure Str(const var; var String)',
@BI_StrProc_OnGetCallCompatibility,nil, @BI_StrProc_OnGetCallCompatibility,nil,nil,
@BI_StrProc_OnFinishParamsExpr,bfStrProc,[bipfCanBeStatement]); @BI_StrProc_OnFinishParamsExpr,bfStrProc,[bipfCanBeStatement]);
if bfStrFunc in TheBaseProcs then if bfStrFunc in TheBaseProcs then
AddBuiltInProc('Str','function Str(const var): String', AddBuiltInProc('Str','function Str(const var): String',
@BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,nil,bfStrFunc); @BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,
nil,nil,bfStrFunc);
if bfConcatArray in TheBaseProcs then if bfConcatArray in TheBaseProcs then
AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array', AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array',
@BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,nil,bfConcatArray); @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,
nil,nil,bfConcatArray);
if bfCopyArray in TheBaseProcs then if bfCopyArray in TheBaseProcs then
AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array', AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array',
@BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,nil,bfCopyArray); @BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,
nil,nil,bfCopyArray);
if bfInsertArray in TheBaseProcs then if bfInsertArray in TheBaseProcs then
AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)', AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)',
@BI_InsertArray_OnGetCallCompatibility,nil, @BI_InsertArray_OnGetCallCompatibility,nil,nil,
@BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]); @BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]);
if bfDeleteArray in TheBaseProcs then if bfDeleteArray in TheBaseProcs then
AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)', AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)',
@BI_DeleteArray_OnGetCallCompatibility,nil, @BI_DeleteArray_OnGetCallCompatibility,nil,nil,
@BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]); @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]);
if bfTypeInfo in TheBaseProcs then if bfTypeInfo in TheBaseProcs then
AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer', AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
@BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult, @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
nil,bfTypeInfo); nil,nil,bfTypeInfo);
end; end;
function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
@ -9226,7 +9281,7 @@ end;
function TPasResolver.AddBuiltInProc(const aName: string; Signature: string; function TPasResolver.AddBuiltInProc(const aName: string; Signature: string;
const GetCallCompatibility: TOnGetCallCompatibility; const GetCallCompatibility: TOnGetCallCompatibility;
const GetCallResult: TOnGetCallResult; const GetCallResult: TOnGetCallResult; const EvalConst: TOnEvalBIFunction;
const FinishParamsExpr: TOnFinishParamsExpr; const FinishParamsExpr: TOnFinishParamsExpr;
const BuiltIn: TResolverBuiltInProc; const Flags: TBuiltInProcFlags const BuiltIn: TResolverBuiltInProc; const Flags: TBuiltInProcFlags
): TResElDataBuiltInProc; ): TResElDataBuiltInProc;
@ -9240,6 +9295,7 @@ begin
Result.BuiltIn:=BuiltIn; Result.BuiltIn:=BuiltIn;
Result.GetCallCompatibility:=GetCallCompatibility; Result.GetCallCompatibility:=GetCallCompatibility;
Result.GetCallResult:=GetCallResult; Result.GetCallResult:=GetCallResult;
Result.Eval:=EvalConst;
Result.FinishParamsExpression:=FinishParamsExpr; Result.FinishParamsExpression:=FinishParamsExpr;
Result.Flags:=Flags; Result.Flags:=Flags;
AddResolveData(El,Result,lkBuiltIn); AddResolveData(El,Result,lkBuiltIn);
@ -10162,6 +10218,74 @@ begin
Include(Flags,rcNoImplicitProcType); Include(Flags,rcNoImplicitProcType);
ComputeElement(RHS,RightResolved,Flags); ComputeElement(RHS,RightResolved,Flags);
Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,RHS,RaiseOnIncompatible); Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,RHS,RaiseOnIncompatible);
if RHS is TPasExpr then
begin
{$IFDEF EnablePasResRangeCheck}
CheckAssignExprRange(LeftResolved,TPasExpr(RHS));
{$ENDIF}
end;
end;
procedure TPasResolver.CheckAssignExprRange(
const LeftResolved: TPasResolverResult; RHS: TPasExpr);
var
RValue: TResEvalValue;
MinVal, MaxVal: int64;
RgExpr: TBinaryExpr;
begin
RValue:=Eval(RHS,[refAutoConst]);
if RValue=nil then
exit; // not a const expression
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.CheckAssignExprRange ',RValue.AsDebugString);
{$ENDIF}
try
if LeftResolved.TypeEl is TPasRangeType then
begin
RgExpr:=TPasRangeType(LeftResolved.TypeEl).RangeExpr;
fExprEvaluator.IsInRange(RHS,RgExpr,true);
end
else if (LeftResolved.BaseType in (btAllInteger-[btQWord]))
and GetIntegerRange(LeftResolved.BaseType,MinVal,MaxVal) then
case RValue.Kind of
revkInt:
if (MinVal>TResEvalInt(RValue).Int)
or (MaxVal<TResEvalInt(RValue).Int) then
fExprEvaluator.EmitRangeCheckConst(20170530093126,
IntToStr(TResEvalInt(RValue).Int),MinVal,MaxVal,RHS);
revkUInt:
if (TResEvalUInt(RValue).UInt>High(MaxPrecInt))
or (MinVal>MaxPrecInt(TResEvalUInt(RValue).UInt))
or (MaxVal<MaxPrecInt(TResEvalUInt(RValue).UInt)) then
fExprEvaluator.EmitRangeCheckConst(20170530093616,
IntToStr(TResEvalUInt(RValue).UInt),IntToStr(MinVal),IntToStr(MaxVal),RHS);
else
RaiseNotYetImplemented(20170530092731,RHS);
end
else if LeftResolved.BaseType=btQWord then
case RValue.Kind of
revkInt:
if (TResEvalInt(RValue).Int<0) then
fExprEvaluator.EmitRangeCheckConst(20170530094316,
IntToStr(TResEvalUInt(RValue).UInt),'0',IntToStr(High(QWord)),RHS);
revkUInt: ;
else
RaiseNotYetImplemented(20170530094311,RHS);
end
else if RValue.Kind=revkNil then
// simple type check is enough
else if RValue.Kind=revkBool then
// simple type check is enough
else
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckAssignExprRange LeftResolved=',GetResolverResultDbg(LeftResolved));
{$ENDIF}
RaiseNotYetImplemented(20170530095243,RHS);
end;
finally
ReleaseEvalValue(RValue);
end;
end; end;
function TPasResolver.CheckAssignResCompatibility(const LHS, function TPasResolver.CheckAssignResCompatibility(const LHS,

71
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -186,7 +186,11 @@ type
Procedure TestVarNoSemicolonBeginFail; Procedure TestVarNoSemicolonBeginFail;
Procedure TestIntegerRange; Procedure TestIntegerRange;
Procedure TestIntegerRangeHighLowerLowFail; Procedure TestIntegerRangeHighLowerLowFail;
Procedure TestAssignIntRangeFail; // ToDo Procedure TestAssignIntRangeFail;
Procedure TestByteRangeFail;
Procedure TestCustomIntRangeFail;
Procedure TestConstIntOperators;
//Procedure TestConstBoolOperators; ToDo
// strings // strings
Procedure TestChar_Ord; Procedure TestChar_Ord;
@ -198,6 +202,7 @@ type
Procedure TestStringElement_AsVarArgFail; Procedure TestStringElement_AsVarArgFail;
Procedure TestString_DoubleQuotesFail; Procedure TestString_DoubleQuotesFail;
Procedure TestString_ShortstringType; Procedure TestString_ShortstringType;
//Procedure TestConstStringOperators; ToDo
// enums // enums
Procedure TestEnums; Procedure TestEnums;
@ -1156,7 +1161,7 @@ begin
for i:=0 to MsgCount-1 do for i:=0 to MsgCount-1 do
begin begin
Item:=Msgs[i]; Item:=Msgs[i];
writeln('TCustomTestResolver.CheckResolverHint ',Item.MsgType,' ('+IntToStr(Item.MsgNumber),') {',Item.Msg,'}'); writeln('TCustomTestResolver.CheckResolverHint ',i,'/',MsgCount,' ',Item.MsgType,' ('+IntToStr(Item.MsgNumber),') {',Item.Msg,'}');
end; end;
str(MsgType,Expected); str(MsgType,Expected);
Fail('Missing '+Expected+' ('+IntToStr(MsgNumber)+') '+Msg); Fail('Missing '+Expected+' ('+IntToStr(MsgNumber)+') '+Msg);
@ -2148,20 +2153,74 @@ end;
procedure TTestResolver.TestAssignIntRangeFail; procedure TTestResolver.TestAssignIntRangeFail;
begin begin
// ToDo
StartProgram(false); StartProgram(false);
Add([ Add([
'type TMyInt = 1..2;', 'type TMyInt = 1..2;',
'var i: TMyInt;', 'var i: TMyInt;',
'begin', 'begin',
' i:=3;']); ' i:=3;']);
exit; ParseProgram;
{$IFDEF EnablePasResRangeCheck} {$IFDEF EnablePasResRangeCheck}
CheckResolverException(sHighRangeLimitLTLowRangeLimit, CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
nHighRangeLimitLTLowRangeLimit); 'range check error while evaluating constants (3 must be between 1 and 2)');
CheckResolverUnexpectedHints;
{$ENDIF} {$ENDIF}
end; end;
procedure TTestResolver.TestByteRangeFail;
begin
StartProgram(false);
Add([
'var b:byte=300;',
'begin']);
ParseProgram;
{$IFDEF EnablePasResRangeCheck}
CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
'range check error while evaluating constants (300 must be between 0 and 255)');
CheckResolverUnexpectedHints;
{$ENDIF}
end;
procedure TTestResolver.TestCustomIntRangeFail;
begin
StartProgram(false);
Add([
'const i:1..2 = 3;',
'begin']);
ParseProgram;
{$IFDEF EnablePasResRangeCheck}
CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
'range check error while evaluating constants (3 must be between 1 and 2)');
CheckResolverUnexpectedHints;
{$ENDIF}
end;
procedure TTestResolver.TestConstIntOperators;
begin
StartProgram(false);
Add([
'const',
' a:byte=1+2;',
' b:shortint=1-2;',
' c:word=2*3;',
' d:smallint=5 div 2;',
' e:longword=5 mod 2;',
' f:longint=5 shl 2;',
' g:qword=5 shr 2;',
' h:boolean=5=2;',
' i:boolean=5<>2;',
//' j:boolean=5<2;',
//' k:boolean=5>2;',
//' l:boolean=5<=2;',
//' m:boolean=5>=2;',
//' n:longword=5 and 2;',
//' o:longword=5 or 2;',
//' p:longword=5 xor 2;',
//' q:longword=5 or not 2;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestChar_Ord; procedure TTestResolver.TestChar_Ord;
begin begin
StartProgram(false); StartProgram(false);