mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-16 16:59:12 +02:00
* Patch from Mattias Gaertner:
pastree: fixed double iterations in foreach parser: fixed skipping token after var declaration without checking pasresolver: - ord(char), chr() - method visibility: warn and fix if override has lower visibility - open arrays - allow descendants to add their own base types - typecast to alias type pasuseanalyzer: support public modifier git-svn-id: trunk@35667 -
This commit is contained in:
parent
fc59649a98
commit
a5919aa63f
File diff suppressed because it is too large
Load Diff
@ -1226,6 +1226,7 @@ Type
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
{ TPasImplForLoop }
|
{ TPasImplForLoop }
|
||||||
|
|
||||||
TLoopType = (ltNormal,ltDown,ltIn);
|
TLoopType = (ltNormal,ltDown,ltIn);
|
||||||
TPasImplForLoop = class(TPasImplStatement)
|
TPasImplForLoop = class(TPasImplStatement)
|
||||||
public
|
public
|
||||||
@ -2693,7 +2694,7 @@ begin
|
|||||||
if IfBranch=nil then
|
if IfBranch=nil then
|
||||||
begin
|
begin
|
||||||
IfBranch:=Element;
|
IfBranch:=Element;
|
||||||
element.AddRef;
|
Element.AddRef;
|
||||||
end
|
end
|
||||||
else if ElseBranch=nil then
|
else if ElseBranch=nil then
|
||||||
begin
|
begin
|
||||||
@ -2712,10 +2713,12 @@ end;
|
|||||||
procedure TPasImplIfElse.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
procedure TPasImplIfElse.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||||
const Arg: Pointer);
|
const Arg: Pointer);
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
|
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
|
if Elements.IndexOf(IfBranch)<0 then
|
||||||
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
|
||||||
|
if Elements.IndexOf(ElseBranch)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TPasImplIfElse.Condition: string;
|
function TPasImplIfElse.Condition: string;
|
||||||
@ -2749,12 +2752,13 @@ end;
|
|||||||
procedure TPasImplForLoop.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
procedure TPasImplForLoop.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||||
const Arg: Pointer);
|
const Arg: Pointer);
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
ForEachChildCall(aMethodCall,Arg,VariableName,false);
|
ForEachChildCall(aMethodCall,Arg,VariableName,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,Variable,false);
|
ForEachChildCall(aMethodCall,Arg,Variable,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,StartExpr,false);
|
ForEachChildCall(aMethodCall,Arg,StartExpr,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,EndExpr,false);
|
ForEachChildCall(aMethodCall,Arg,EndExpr,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,Body,false);
|
if Elements.IndexOf(Body)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TPasImplForLoop.Down: boolean;
|
function TPasImplForLoop.Down: boolean;
|
||||||
@ -3931,15 +3935,16 @@ begin
|
|||||||
Body.AddRef;
|
Body.AddRef;
|
||||||
end
|
end
|
||||||
else
|
else
|
||||||
raise Exception.Create('TPasImplWhileDo.AddElement body already set - please report this bug');
|
raise Exception.Create('TPasImplWhileDo.AddElement body already set');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||||
const Arg: Pointer);
|
const Arg: Pointer);
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
|
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,Body,false);
|
if Elements.IndexOf(Body)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TPasImplWhileDo.Condition: string;
|
function TPasImplWhileDo.Condition: string;
|
||||||
@ -3982,9 +3987,10 @@ end;
|
|||||||
procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||||
const Arg: Pointer);
|
const Arg: Pointer);
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
ForEachChildCall(aMethodCall,Arg,CaseExpr,false);
|
ForEachChildCall(aMethodCall,Arg,CaseExpr,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
if Elements.IndexOf(ElseBranch)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TPasImplCaseOf.Expression: string;
|
function TPasImplCaseOf.Expression: string;
|
||||||
@ -4025,6 +4031,8 @@ begin
|
|||||||
Body:=Element;
|
Body:=Element;
|
||||||
Body.AddRef;
|
Body.AddRef;
|
||||||
end
|
end
|
||||||
|
else
|
||||||
|
raise Exception.Create('TPasImplCaseStatement.AddElement body already set');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TPasImplCaseStatement.AddExpression(const Expr: TPasExpr);
|
procedure TPasImplCaseStatement.AddExpression(const Expr: TPasExpr);
|
||||||
@ -4038,10 +4046,11 @@ procedure TPasImplCaseStatement.ForEachCall(
|
|||||||
var
|
var
|
||||||
i: Integer;
|
i: Integer;
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
for i:=0 to Expressions.Count-1 do
|
for i:=0 to Expressions.Count-1 do
|
||||||
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
|
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
|
||||||
ForEachChildCall(aMethodCall,Arg,Body,false);
|
if Elements.IndexOf(Body)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
{ TPasImplWithDo }
|
{ TPasImplWithDo }
|
||||||
@ -4071,7 +4080,9 @@ begin
|
|||||||
begin
|
begin
|
||||||
Body:=Element;
|
Body:=Element;
|
||||||
Body.AddRef;
|
Body.AddRef;
|
||||||
end;
|
end
|
||||||
|
else
|
||||||
|
raise Exception.Create('TPasImplWithDo.AddElement body already set');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TPasImplWithDo.AddExpression(const Expression: TPasExpr);
|
procedure TPasImplWithDo.AddExpression(const Expression: TPasExpr);
|
||||||
@ -4086,6 +4097,8 @@ var
|
|||||||
begin
|
begin
|
||||||
for i:=0 to Expressions.Count-1 do
|
for i:=0 to Expressions.Count-1 do
|
||||||
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
|
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
|
||||||
|
if Elements.IndexOf(Body)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
@ -4149,10 +4162,11 @@ end;
|
|||||||
procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||||
const Arg: Pointer);
|
const Arg: Pointer);
|
||||||
begin
|
begin
|
||||||
inherited ForEachCall(aMethodCall, Arg);
|
|
||||||
ForEachChildCall(aMethodCall,Arg,VarEl,false);
|
ForEachChildCall(aMethodCall,Arg,VarEl,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,TypeEl,false);
|
ForEachChildCall(aMethodCall,Arg,TypeEl,false);
|
||||||
ForEachChildCall(aMethodCall,Arg,Body,false);
|
if Elements.IndexOf(Body)<0 then
|
||||||
|
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||||
|
inherited ForEachCall(aMethodCall, Arg);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TPasImplExceptOn.VariableName: String;
|
function TPasImplExceptOn.VariableName: String;
|
||||||
|
@ -703,7 +703,8 @@ begin
|
|||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
if Decl is TPasProcedure then
|
if Decl is TPasProcedure then
|
||||||
begin
|
begin
|
||||||
if OnlyExports and (TPasProcedure(Decl).PublicName=nil) then continue;
|
if OnlyExports and ([pmExport,pmPublic]*TPasProcedure(Decl).Modifiers=[]) then
|
||||||
|
continue;
|
||||||
UseProcedure(TPasProcedure(Decl))
|
UseProcedure(TPasProcedure(Decl))
|
||||||
end
|
end
|
||||||
else if Decl is TPasType then
|
else if Decl is TPasType then
|
||||||
|
@ -2599,6 +2599,7 @@ begin
|
|||||||
Declarations.Declarations.Add(VarEl);
|
Declarations.Declarations.Add(VarEl);
|
||||||
Declarations.Variables.Add(VarEl);
|
Declarations.Variables.Add(VarEl);
|
||||||
end;
|
end;
|
||||||
|
CheckToken(tkSemicolon);
|
||||||
finally
|
finally
|
||||||
List.Free;
|
List.Free;
|
||||||
end;
|
end;
|
||||||
@ -3476,8 +3477,6 @@ begin
|
|||||||
pmPublic:
|
pmPublic:
|
||||||
begin
|
begin
|
||||||
NextToken;
|
NextToken;
|
||||||
{ Should be token Name,
|
|
||||||
if not we're in a class and the public section starts }
|
|
||||||
If not CurTokenIsIdentifier('name') then
|
If not CurTokenIsIdentifier('name') then
|
||||||
begin
|
begin
|
||||||
if P.Parent is TPasClassType then
|
if P.Parent is TPasClassType then
|
||||||
|
@ -72,6 +72,16 @@ type
|
|||||||
property Module: TPasModule read FModule write SetModule;
|
property Module: TPasModule read FModule write SetModule;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{ TTestResolverMessage }
|
||||||
|
|
||||||
|
TTestResolverMessage = class
|
||||||
|
public
|
||||||
|
Id: int64;
|
||||||
|
MsgType: TMessageType;
|
||||||
|
MsgNumber: integer;
|
||||||
|
Msg: string;
|
||||||
|
end;
|
||||||
|
|
||||||
TTestResolverReferenceData = record
|
TTestResolverReferenceData = record
|
||||||
Filename: string;
|
Filename: string;
|
||||||
Row: integer;
|
Row: integer;
|
||||||
@ -93,12 +103,16 @@ type
|
|||||||
FFirstStatement: TPasImplBlock;
|
FFirstStatement: TPasImplBlock;
|
||||||
FModules: TObjectList;// list of TTestEnginePasResolver
|
FModules: TObjectList;// list of TTestEnginePasResolver
|
||||||
FResolverEngine: TTestEnginePasResolver;
|
FResolverEngine: TTestEnginePasResolver;
|
||||||
|
FResolverMsgs: TObjectList; // list of TTestResolverMessage
|
||||||
function GetModuleCount: integer;
|
function GetModuleCount: integer;
|
||||||
function GetModules(Index: integer): TTestEnginePasResolver;
|
function GetModules(Index: integer): TTestEnginePasResolver;
|
||||||
|
function GetMsgCount: integer;
|
||||||
|
function GetMsgs(Index: integer): TTestResolverMessage;
|
||||||
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
|
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
|
||||||
procedure OnFindReference(El: TPasElement; FindData: pointer);
|
procedure OnFindReference(El: TPasElement; FindData: pointer);
|
||||||
procedure OnCheckElementParent(El: TPasElement; arg: pointer);
|
procedure OnCheckElementParent(El: TPasElement; arg: pointer);
|
||||||
procedure FreeSrcMarkers;
|
procedure FreeSrcMarkers;
|
||||||
|
procedure OnPasResolverLog(Sender: TObject; const Msg: String);
|
||||||
Protected
|
Protected
|
||||||
FirstSrcMarker, LastSrcMarker: PSrcMarker;
|
FirstSrcMarker, LastSrcMarker: PSrcMarker;
|
||||||
Procedure SetUp; override;
|
Procedure SetUp; override;
|
||||||
@ -107,6 +121,7 @@ type
|
|||||||
procedure ParseProgram; virtual;
|
procedure ParseProgram; virtual;
|
||||||
procedure ParseUnit; virtual;
|
procedure ParseUnit; virtual;
|
||||||
procedure CheckReferenceDirectives; virtual;
|
procedure CheckReferenceDirectives; virtual;
|
||||||
|
procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer; Msg: string; MustHave: boolean);
|
||||||
procedure CheckResolverException(Msg: string; MsgNumber: integer);
|
procedure CheckResolverException(Msg: string; MsgNumber: integer);
|
||||||
procedure CheckParserException(Msg: string; MsgNumber: integer);
|
procedure CheckParserException(Msg: string; MsgNumber: integer);
|
||||||
procedure CheckAccessMarkers; virtual;
|
procedure CheckAccessMarkers; virtual;
|
||||||
@ -119,6 +134,8 @@ type
|
|||||||
procedure RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer);
|
procedure RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer);
|
||||||
procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker);
|
procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker);
|
||||||
Public
|
Public
|
||||||
|
constructor Create; override;
|
||||||
|
destructor Destroy; override;
|
||||||
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver;
|
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver;
|
||||||
function AddModule(aFilename: string): TTestEnginePasResolver;
|
function AddModule(aFilename: string): TTestEnginePasResolver;
|
||||||
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver;
|
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver;
|
||||||
@ -130,6 +147,8 @@ type
|
|||||||
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
|
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
|
||||||
property ModuleCount: integer read GetModuleCount;
|
property ModuleCount: integer read GetModuleCount;
|
||||||
property ResolverEngine: TTestEnginePasResolver read FResolverEngine;
|
property ResolverEngine: TTestEnginePasResolver read FResolverEngine;
|
||||||
|
property MsgCount: integer read GetMsgCount;
|
||||||
|
property Msgs[Index: integer]: TTestResolverMessage read GetMsgs;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
{ TTestResolver }
|
{ TTestResolver }
|
||||||
@ -162,8 +181,11 @@ type
|
|||||||
Procedure TestStr_BaseTypes;
|
Procedure TestStr_BaseTypes;
|
||||||
Procedure TestStr_StringFail;
|
Procedure TestStr_StringFail;
|
||||||
Procedure TestStr_CharFail;
|
Procedure TestStr_CharFail;
|
||||||
|
Procedure TestVarNoSemicolonBeginFail;
|
||||||
|
|
||||||
// strings
|
// strings
|
||||||
|
Procedure TestChar_Ord;
|
||||||
|
Procedure TestChar_Chr;
|
||||||
Procedure TestString_SetLength;
|
Procedure TestString_SetLength;
|
||||||
Procedure TestString_Element;
|
Procedure TestString_Element;
|
||||||
Procedure TestStringElement_MissingArgFail;
|
Procedure TestStringElement_MissingArgFail;
|
||||||
@ -198,10 +220,14 @@ type
|
|||||||
Procedure TestFloatOperators;
|
Procedure TestFloatOperators;
|
||||||
Procedure TestCAssignments;
|
Procedure TestCAssignments;
|
||||||
Procedure TestTypeCastBaseTypes;
|
Procedure TestTypeCastBaseTypes;
|
||||||
|
Procedure TestTypeCastAliasBaseTypes;
|
||||||
Procedure TestTypeCastStrToIntFail;
|
Procedure TestTypeCastStrToIntFail;
|
||||||
|
Procedure TestTypeCastStrToCharFail;
|
||||||
Procedure TestTypeCastIntToStrFail;
|
Procedure TestTypeCastIntToStrFail;
|
||||||
Procedure TestTypeCastDoubleToStrFail;
|
Procedure TestTypeCastDoubleToStrFail;
|
||||||
Procedure TestTypeCastDoubleToIntFail;
|
Procedure TestTypeCastDoubleToIntFail;
|
||||||
|
Procedure TestTypeCastDoubleToBoolFail;
|
||||||
|
Procedure TestTypeCastBooleanToDoubleFail;
|
||||||
Procedure TestHighLow;
|
Procedure TestHighLow;
|
||||||
Procedure TestAssign_Access;
|
Procedure TestAssign_Access;
|
||||||
|
|
||||||
@ -344,6 +370,7 @@ type
|
|||||||
Procedure TestClass_Sealed;
|
Procedure TestClass_Sealed;
|
||||||
Procedure TestClass_SealedDescendFail;
|
Procedure TestClass_SealedDescendFail;
|
||||||
Procedure TestClass_VarExternal;
|
Procedure TestClass_VarExternal;
|
||||||
|
Procedure TestClass_WarnOverrideLowerVisibility;
|
||||||
// Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
|
// Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
|
||||||
|
|
||||||
// external class
|
// external class
|
||||||
@ -428,6 +455,8 @@ type
|
|||||||
Procedure TestArray_AssignNilToStaticArrayFail1;
|
Procedure TestArray_AssignNilToStaticArrayFail1;
|
||||||
Procedure TestArray_SetLengthProperty;
|
Procedure TestArray_SetLengthProperty;
|
||||||
Procedure TestArray_PassArrayElementToVarParam;
|
Procedure TestArray_PassArrayElementToVarParam;
|
||||||
|
Procedure TestArray_OpenArrayOfString;
|
||||||
|
Procedure TestArray_OpenArrayOfString_IntFail;
|
||||||
|
|
||||||
// procedure types
|
// procedure types
|
||||||
Procedure TestProcTypesAssignObjFPC;
|
Procedure TestProcTypesAssignObjFPC;
|
||||||
@ -520,6 +549,7 @@ end;
|
|||||||
|
|
||||||
procedure TCustomTestResolver.TearDown;
|
procedure TCustomTestResolver.TearDown;
|
||||||
begin
|
begin
|
||||||
|
FResolverMsgs.Clear;
|
||||||
{$IFDEF VerbosePasResolverMem}
|
{$IFDEF VerbosePasResolverMem}
|
||||||
writeln('TTestResolver.TearDown START FreeSrcMarkers');
|
writeln('TTestResolver.TearDown START FreeSrcMarkers');
|
||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
@ -998,6 +1028,42 @@ begin
|
|||||||
//writeln('TTestResolver.CheckReferenceDirectives COMPLETE');
|
//writeln('TTestResolver.CheckReferenceDirectives COMPLETE');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TCustomTestResolver.CheckResolverHint(MsgType: TMessageType;
|
||||||
|
MsgNumber: integer; Msg: string; MustHave: boolean);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
Item: TTestResolverMessage;
|
||||||
|
Expected,Actual: string;
|
||||||
|
begin
|
||||||
|
writeln('TCustomTestResolver.CheckResolverHint MsgCount=',MsgCount);
|
||||||
|
for i:=0 to MsgCount-1 do
|
||||||
|
begin
|
||||||
|
Item:=Msgs[i];
|
||||||
|
if (Item.MsgNumber<>MsgNumber) or (Item.Msg<>Msg) then continue;
|
||||||
|
// found
|
||||||
|
str(Item.MsgType,Actual);
|
||||||
|
if not MustHave then
|
||||||
|
begin
|
||||||
|
WriteSources('',0,0);
|
||||||
|
Fail('Expected to *not* emit '+Actual+' ('+IntToStr(MsgNumber)+') {'+Msg+'}');
|
||||||
|
end;
|
||||||
|
str(MsgType,Expected);
|
||||||
|
AssertEquals('MsgType',Expected,Actual);
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
if not MustHave then exit;
|
||||||
|
|
||||||
|
// needed message missing -> show emitted messages
|
||||||
|
WriteSources('',0,0);
|
||||||
|
for i:=0 to MsgCount-1 do
|
||||||
|
begin
|
||||||
|
Item:=Msgs[i];
|
||||||
|
writeln('TCustomTestResolver.CheckResolverHint ',Item.MsgType,' ('+IntToStr(Item.MsgNumber),') {',Item.Msg,'}');
|
||||||
|
end;
|
||||||
|
str(MsgType,Expected);
|
||||||
|
Fail('Missing '+Expected+' ('+IntToStr(MsgNumber)+') '+Msg);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TCustomTestResolver.CheckResolverException(Msg: string; MsgNumber: integer);
|
procedure TCustomTestResolver.CheckResolverException(Msg: string; MsgNumber: integer);
|
||||||
var
|
var
|
||||||
ok: Boolean;
|
ok: Boolean;
|
||||||
@ -1217,6 +1283,18 @@ begin
|
|||||||
RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
|
RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
constructor TCustomTestResolver.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FResolverMsgs:=TObjectList.Create(true);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TCustomTestResolver.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FResolverMsgs);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
function TCustomTestResolver.FindModuleWithFilename(aFilename: string
|
function TCustomTestResolver.FindModuleWithFilename(aFilename: string
|
||||||
): TTestEnginePasResolver;
|
): TTestEnginePasResolver;
|
||||||
var
|
var
|
||||||
@ -1237,6 +1315,7 @@ begin
|
|||||||
Result.Filename:=aFilename;
|
Result.Filename:=aFilename;
|
||||||
Result.AddObjFPCBuiltInIdentifiers;
|
Result.AddObjFPCBuiltInIdentifiers;
|
||||||
Result.OnFindUnit:=@OnPasResolverFindUnit;
|
Result.OnFindUnit:=@OnPasResolverFindUnit;
|
||||||
|
Result.OnLog:=@OnPasResolverLog;
|
||||||
FModules.Add(Result);
|
FModules.Add(Result);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
@ -1535,11 +1614,39 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TCustomTestResolver.OnPasResolverLog(Sender: TObject;
|
||||||
|
const Msg: String);
|
||||||
|
var
|
||||||
|
aResolver: TTestEnginePasResolver;
|
||||||
|
Item: TTestResolverMessage;
|
||||||
|
begin
|
||||||
|
aResolver:=Sender as TTestEnginePasResolver;
|
||||||
|
Item:=TTestResolverMessage.Create;
|
||||||
|
Item.Id:=aResolver.LastMsgId;
|
||||||
|
Item.MsgType:=aResolver.LastMsgType;
|
||||||
|
Item.MsgNumber:=aResolver.LastMsgNumber;
|
||||||
|
Item.Msg:=Msg;
|
||||||
|
{$IFDEF VerbosePasResolver}
|
||||||
|
writeln('TCustomTestResolver.OnPasResolverLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
|
||||||
|
{$ENDIF}
|
||||||
|
FResolverMsgs.Add(Item);
|
||||||
|
end;
|
||||||
|
|
||||||
function TCustomTestResolver.GetModules(Index: integer): TTestEnginePasResolver;
|
function TCustomTestResolver.GetModules(Index: integer): TTestEnginePasResolver;
|
||||||
begin
|
begin
|
||||||
Result:=TTestEnginePasResolver(FModules[Index]);
|
Result:=TTestEnginePasResolver(FModules[Index]);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function TCustomTestResolver.GetMsgCount: integer;
|
||||||
|
begin
|
||||||
|
Result:=FResolverMsgs.Count;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomTestResolver.GetMsgs(Index: integer): TTestResolverMessage;
|
||||||
|
begin
|
||||||
|
Result:=TTestResolverMessage(FResolverMsgs[Index]);
|
||||||
|
end;
|
||||||
|
|
||||||
function TCustomTestResolver.GetModuleCount: integer;
|
function TCustomTestResolver.GetModuleCount: integer;
|
||||||
begin
|
begin
|
||||||
Result:=FModules.Count;
|
Result:=FModules.Count;
|
||||||
@ -1834,6 +1941,7 @@ begin
|
|||||||
Add(' s: single;');
|
Add(' s: single;');
|
||||||
Add(' d: double;');
|
Add(' d: double;');
|
||||||
Add(' aString: string;');
|
Add(' aString: string;');
|
||||||
|
Add(' r: record end;');
|
||||||
Add('begin');
|
Add('begin');
|
||||||
Add(' Str(b,{#a_var}aString);');
|
Add(' Str(b,{#a_var}aString);');
|
||||||
Add(' Str(b:1,aString);');
|
Add(' Str(b:1,aString);');
|
||||||
@ -1853,6 +1961,17 @@ begin
|
|||||||
Add(' aString:=Str(i:3);');
|
Add(' aString:=Str(i:3);');
|
||||||
Add(' aString:=Str(d:3:4);');
|
Add(' aString:=Str(d:3:4);');
|
||||||
Add(' aString:=Str(b,i,d);');
|
Add(' aString:=Str(b,i,d);');
|
||||||
|
Add(' aString:=Str(s,''foo'');');
|
||||||
|
Add(' aString:=Str(i,{#assign_read}aString);');
|
||||||
|
Add(' while true do Str(i,{#whiledo_var}aString);');
|
||||||
|
Add(' repeat Str(i,{#repeat_var}aString); until true;');
|
||||||
|
Add(' if true then Str(i,{#ifthen_var}aString) else Str(i,{#ifelse_var}aString);');
|
||||||
|
Add(' for i:=0 to 0 do Str(i,{#fordo_var}aString);');
|
||||||
|
Add(' with r do Str(i,{#withdo_var}aString);');
|
||||||
|
Add(' case Str(s,''caseexpr'') of');
|
||||||
|
Add(' ''bar'': Str(i,{#casest_var}aString);');
|
||||||
|
Add(' else Str(i,{#caseelse_var}aString);');
|
||||||
|
Add(' end;');
|
||||||
ParseProgram;
|
ParseProgram;
|
||||||
CheckAccessMarkers;
|
CheckAccessMarkers;
|
||||||
end;
|
end;
|
||||||
@ -1880,6 +1999,40 @@ begin
|
|||||||
nIncompatibleTypeArgNo);
|
nIncompatibleTypeArgNo);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestVarNoSemicolonBeginFail;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('procedure DoIt; begin end;');
|
||||||
|
Add('var');
|
||||||
|
Add(' i: longint');
|
||||||
|
Add('begin');
|
||||||
|
Add(' doit;');
|
||||||
|
CheckParserException('Expected ";" at token "begin" in file afile.pp at line 5 column 5',
|
||||||
|
nParserExpectTokenError);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestChar_Ord;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' c: char;');
|
||||||
|
Add(' i: longint;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' i:=ord(c);');
|
||||||
|
ParseProgram;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestChar_Chr;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' c: char;');
|
||||||
|
Add(' i: longint;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' c:=chr(i);');
|
||||||
|
ParseProgram;
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TTestResolver.TestString_SetLength;
|
procedure TTestResolver.TestString_SetLength;
|
||||||
begin
|
begin
|
||||||
StartProgram(false);
|
StartProgram(false);
|
||||||
@ -2553,6 +2706,8 @@ begin
|
|||||||
Add(' fs: single;');
|
Add(' fs: single;');
|
||||||
Add(' d: double;');
|
Add(' d: double;');
|
||||||
Add(' b: boolean;');
|
Add(' b: boolean;');
|
||||||
|
Add(' c: char;');
|
||||||
|
Add(' s: char;');
|
||||||
Add('begin');
|
Add('begin');
|
||||||
Add(' d:=double({#a_read}i);');
|
Add(' d:=double({#a_read}i);');
|
||||||
Add(' i:=shortint({#b_read}i);');
|
Add(' i:=shortint({#b_read}i);');
|
||||||
@ -2564,6 +2719,39 @@ begin
|
|||||||
Add(' b:=bytebool({#i_read}longbool({#h_read}b));');
|
Add(' b:=bytebool({#i_read}longbool({#h_read}b));');
|
||||||
Add(' d:=double({#j_read}i)/2.5;');
|
Add(' d:=double({#j_read}i)/2.5;');
|
||||||
Add(' b:=boolean({#k_read}i);');
|
Add(' b:=boolean({#k_read}i);');
|
||||||
|
Add(' i:=longint({#l_read}b);');
|
||||||
|
Add(' d:=double({#m_read}i);');
|
||||||
|
Add(' c:=char({#n_read}c);');
|
||||||
|
Add(' s:=string({#o_read}s);');
|
||||||
|
Add(' s:=string({#p_read}c);');
|
||||||
|
ParseProgram;
|
||||||
|
CheckAccessMarkers;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestTypeCastAliasBaseTypes;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('type');
|
||||||
|
Add(' integer = longint;');
|
||||||
|
Add(' TCaption = string;');
|
||||||
|
Add(' TYesNo = boolean;');
|
||||||
|
Add(' TFloat = double;');
|
||||||
|
Add(' TChar = char;');
|
||||||
|
Add('var');
|
||||||
|
Add(' i: longint;');
|
||||||
|
Add(' s: string;');
|
||||||
|
Add(' b: boolean;');
|
||||||
|
Add(' d: double;');
|
||||||
|
Add(' c: char;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' i:=integer({#a_read}i);');
|
||||||
|
Add(' i:=integer({#h_read}b);');
|
||||||
|
Add(' s:=TCaption({#b_read}s);');
|
||||||
|
Add(' s:=TCaption({#g_read}c);');
|
||||||
|
Add(' b:=TYesNo({#c_read}b);');
|
||||||
|
Add(' b:=TYesNo({#d_read}i);');
|
||||||
|
Add(' d:=TFloat({#e_read}d);');
|
||||||
|
Add(' c:=TChar({#f_read}c);');
|
||||||
ParseProgram;
|
ParseProgram;
|
||||||
CheckAccessMarkers;
|
CheckAccessMarkers;
|
||||||
end;
|
end;
|
||||||
@ -2579,6 +2767,17 @@ begin
|
|||||||
CheckResolverException('illegal type conversion: string to longint',PasResolver.nIllegalTypeConversionTo);
|
CheckResolverException('illegal type conversion: string to longint',PasResolver.nIllegalTypeConversionTo);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestTypeCastStrToCharFail;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' s: string;');
|
||||||
|
Add(' c: char;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' c:=char(s);');
|
||||||
|
CheckResolverException('illegal type conversion: string to char',PasResolver.nIllegalTypeConversionTo);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TTestResolver.TestTypeCastIntToStrFail;
|
procedure TTestResolver.TestTypeCastIntToStrFail;
|
||||||
begin
|
begin
|
||||||
StartProgram(false);
|
StartProgram(false);
|
||||||
@ -2612,6 +2811,28 @@ begin
|
|||||||
CheckResolverException('illegal type conversion: double to longint',PasResolver.nIllegalTypeConversionTo);
|
CheckResolverException('illegal type conversion: double to longint',PasResolver.nIllegalTypeConversionTo);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestTypeCastDoubleToBoolFail;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' b: boolean;');
|
||||||
|
Add(' d: double;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' b:=longint(d);');
|
||||||
|
CheckResolverException('illegal type conversion: double to boolean',PasResolver.nIllegalTypeConversionTo);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestTypeCastBooleanToDoubleFail;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' b: boolean;');
|
||||||
|
Add(' d: double;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' d:=double(b);');
|
||||||
|
CheckResolverException('illegal type conversion: boolean to double',PasResolver.nIllegalTypeConversionTo);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TTestResolver.TestHighLow;
|
procedure TTestResolver.TestHighLow;
|
||||||
begin
|
begin
|
||||||
StartProgram(false);
|
StartProgram(false);
|
||||||
@ -5367,6 +5588,44 @@ begin
|
|||||||
ParseProgram;
|
ParseProgram;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestClass_WarnOverrideLowerVisibility;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('type');
|
||||||
|
Add(' TObject = class');
|
||||||
|
Add(' strict protected');
|
||||||
|
Add(' procedure DoStrictProtected; virtual; abstract;');
|
||||||
|
Add(' protected');
|
||||||
|
Add(' procedure DoProtected; virtual; abstract;');
|
||||||
|
Add(' public');
|
||||||
|
Add(' procedure DoPublic; virtual; abstract;');
|
||||||
|
Add(' published');
|
||||||
|
Add(' procedure DoPublished; virtual; abstract;');
|
||||||
|
Add(' end;');
|
||||||
|
Add(' TBird = class(TObject)');
|
||||||
|
Add(' private');
|
||||||
|
Add(' procedure DoStrictProtected; override;');
|
||||||
|
Add(' procedure DoProtected; override;');
|
||||||
|
Add(' protected');
|
||||||
|
Add(' procedure DoPublic; override;');
|
||||||
|
Add(' procedure DoPublished; override;');
|
||||||
|
Add(' end;');
|
||||||
|
Add('procedure TBird.DoStrictProtected; begin end;');
|
||||||
|
Add('procedure TBird.DoProtected; begin end;');
|
||||||
|
Add('procedure TBird.DoPublic; begin end;');
|
||||||
|
Add('procedure TBird.DoPublished; begin end;');
|
||||||
|
Add('begin');
|
||||||
|
ParseProgram;
|
||||||
|
CheckResolverHint(mtNote,nVirtualMethodXHasLowerVisibility,
|
||||||
|
'Virtual method "DoStrictProtected" has a lower visibility (private) than parent class TObject (strict protected)',true);
|
||||||
|
CheckResolverHint(mtNote,nVirtualMethodXHasLowerVisibility,
|
||||||
|
'Virtual method "DoProtected" has a lower visibility (private) than parent class TObject (protected)',true);
|
||||||
|
CheckResolverHint(mtNote,nVirtualMethodXHasLowerVisibility,
|
||||||
|
'Virtual method "DoPublic" has a lower visibility (protected) than parent class TObject (public)',true);
|
||||||
|
CheckResolverHint(mtNote,nVirtualMethodXHasLowerVisibility,
|
||||||
|
'Virtual method "DoPublished" has a lower visibility (protected) than parent class TObject (published)',true);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TTestResolver.TestExternalClass;
|
procedure TTestResolver.TestExternalClass;
|
||||||
begin
|
begin
|
||||||
StartProgram(false);
|
StartProgram(false);
|
||||||
@ -6814,6 +7073,34 @@ begin
|
|||||||
ParseProgram;
|
ParseProgram;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestArray_OpenArrayOfString;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('procedure DoIt(const a: array of String);');
|
||||||
|
Add('var');
|
||||||
|
Add(' i: longint;');
|
||||||
|
Add(' s: string;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
|
||||||
|
Add('end;');
|
||||||
|
Add('var s: string;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' DoIt([]);');
|
||||||
|
Add(' DoIt([s,''foo'','''',s+s]);');
|
||||||
|
ParseProgram;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTestResolver.TestArray_OpenArrayOfString_IntFail;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('procedure DoIt(const a: array of String);');
|
||||||
|
Add('begin');
|
||||||
|
Add('end;');
|
||||||
|
Add('begin');
|
||||||
|
Add(' DoIt([1]);');
|
||||||
|
CheckResolverException('Incompatible types: got "Longint" expected "String"',nIncompatibleTypesGotExpected);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TTestResolver.TestProcTypesAssignObjFPC;
|
procedure TTestResolver.TestProcTypesAssignObjFPC;
|
||||||
begin
|
begin
|
||||||
StartProgram(false);
|
StartProgram(false);
|
||||||
|
@ -97,6 +97,7 @@ type
|
|||||||
procedure TestWP_UnitInitialization;
|
procedure TestWP_UnitInitialization;
|
||||||
procedure TestWP_UnitFinalization;
|
procedure TestWP_UnitFinalization;
|
||||||
procedure TestWP_CallInherited;
|
procedure TestWP_CallInherited;
|
||||||
|
procedure TestWP_ProgramPublicDeclarations;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
@ -1232,6 +1233,18 @@ begin
|
|||||||
AnalyzeWholeProgram;
|
AnalyzeWholeProgram;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TTestUseAnalyzer.TestWP_ProgramPublicDeclarations;
|
||||||
|
begin
|
||||||
|
StartProgram(false);
|
||||||
|
Add('var');
|
||||||
|
Add(' {#vPublic_used}vPublic: longint; public;');
|
||||||
|
Add(' {#vPrivate_notused}vPrivate: longint;');
|
||||||
|
Add('procedure {#DoPublic_used}DoPublic; public; begin end;');
|
||||||
|
Add('procedure {#DoPrivate_notused}DoPrivate; begin end;');
|
||||||
|
Add('begin');
|
||||||
|
AnalyzeWholeProgram;
|
||||||
|
end;
|
||||||
|
|
||||||
initialization
|
initialization
|
||||||
RegisterTests([TTestUseAnalyzer]);
|
RegisterTests([TTestUseAnalyzer]);
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user