mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-15 21:09:27 +02:00
fcl-passrc: more const operators
git-svn-id: trunk@36376 -
This commit is contained in:
parent
59e0ca7278
commit
9ff7e70ffc
File diff suppressed because it is too large
Load Diff
@ -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,
|
||||||
|
@ -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);
|
||||||
|
Loading…
Reference in New Issue
Block a user