fcl-passrc: more const operators

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

File diff suppressed because it is too large Load Diff

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,

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);