* 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:
michael 2017-03-27 10:33:53 +00:00
parent fc59649a98
commit a5919aa63f
6 changed files with 861 additions and 258 deletions

File diff suppressed because it is too large Load Diff

View File

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

View File

@ -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

View File

@ -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

View File

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

View File

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