mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-19 21:19:31 +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;
|
||||
|
||||
{ TPasImplForLoop }
|
||||
|
||||
TLoopType = (ltNormal,ltDown,ltIn);
|
||||
TPasImplForLoop = class(TPasImplStatement)
|
||||
public
|
||||
@ -2693,7 +2694,7 @@ begin
|
||||
if IfBranch=nil then
|
||||
begin
|
||||
IfBranch:=Element;
|
||||
element.AddRef;
|
||||
Element.AddRef;
|
||||
end
|
||||
else if ElseBranch=nil then
|
||||
begin
|
||||
@ -2712,10 +2713,12 @@ end;
|
||||
procedure TPasImplIfElse.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||
const Arg: Pointer);
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
|
||||
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
|
||||
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
||||
if Elements.IndexOf(IfBranch)<0 then
|
||||
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
|
||||
if Elements.IndexOf(ElseBranch)<0 then
|
||||
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
end;
|
||||
|
||||
function TPasImplIfElse.Condition: string;
|
||||
@ -2749,12 +2752,13 @@ end;
|
||||
procedure TPasImplForLoop.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||
const Arg: Pointer);
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
ForEachChildCall(aMethodCall,Arg,VariableName,false);
|
||||
ForEachChildCall(aMethodCall,Arg,Variable,false);
|
||||
ForEachChildCall(aMethodCall,Arg,StartExpr,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;
|
||||
|
||||
function TPasImplForLoop.Down: boolean;
|
||||
@ -3931,15 +3935,16 @@ begin
|
||||
Body.AddRef;
|
||||
end
|
||||
else
|
||||
raise Exception.Create('TPasImplWhileDo.AddElement body already set - please report this bug');
|
||||
raise Exception.Create('TPasImplWhileDo.AddElement body already set');
|
||||
end;
|
||||
|
||||
procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||
const Arg: Pointer);
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
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;
|
||||
|
||||
function TPasImplWhileDo.Condition: string;
|
||||
@ -3982,9 +3987,10 @@ end;
|
||||
procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||
const Arg: Pointer);
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
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;
|
||||
|
||||
function TPasImplCaseOf.Expression: string;
|
||||
@ -4025,6 +4031,8 @@ begin
|
||||
Body:=Element;
|
||||
Body.AddRef;
|
||||
end
|
||||
else
|
||||
raise Exception.Create('TPasImplCaseStatement.AddElement body already set');
|
||||
end;
|
||||
|
||||
procedure TPasImplCaseStatement.AddExpression(const Expr: TPasExpr);
|
||||
@ -4038,10 +4046,11 @@ procedure TPasImplCaseStatement.ForEachCall(
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
for i:=0 to Expressions.Count-1 do
|
||||
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;
|
||||
|
||||
{ TPasImplWithDo }
|
||||
@ -4071,7 +4080,9 @@ begin
|
||||
begin
|
||||
Body:=Element;
|
||||
Body.AddRef;
|
||||
end;
|
||||
end
|
||||
else
|
||||
raise Exception.Create('TPasImplWithDo.AddElement body already set');
|
||||
end;
|
||||
|
||||
procedure TPasImplWithDo.AddExpression(const Expression: TPasExpr);
|
||||
@ -4086,6 +4097,8 @@ var
|
||||
begin
|
||||
for i:=0 to Expressions.Count-1 do
|
||||
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
|
||||
if Elements.IndexOf(Body)<0 then
|
||||
ForEachChildCall(aMethodCall,Arg,Body,false);
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
end;
|
||||
|
||||
@ -4149,10 +4162,11 @@ end;
|
||||
procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TOnForEachPasElement;
|
||||
const Arg: Pointer);
|
||||
begin
|
||||
inherited ForEachCall(aMethodCall, Arg);
|
||||
ForEachChildCall(aMethodCall,Arg,VarEl,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;
|
||||
|
||||
function TPasImplExceptOn.VariableName: String;
|
||||
|
@ -703,7 +703,8 @@ begin
|
||||
{$ENDIF}
|
||||
if Decl is TPasProcedure then
|
||||
begin
|
||||
if OnlyExports and (TPasProcedure(Decl).PublicName=nil) then continue;
|
||||
if OnlyExports and ([pmExport,pmPublic]*TPasProcedure(Decl).Modifiers=[]) then
|
||||
continue;
|
||||
UseProcedure(TPasProcedure(Decl))
|
||||
end
|
||||
else if Decl is TPasType then
|
||||
|
@ -2599,6 +2599,7 @@ begin
|
||||
Declarations.Declarations.Add(VarEl);
|
||||
Declarations.Variables.Add(VarEl);
|
||||
end;
|
||||
CheckToken(tkSemicolon);
|
||||
finally
|
||||
List.Free;
|
||||
end;
|
||||
@ -3476,8 +3477,6 @@ begin
|
||||
pmPublic:
|
||||
begin
|
||||
NextToken;
|
||||
{ Should be token Name,
|
||||
if not we're in a class and the public section starts }
|
||||
If not CurTokenIsIdentifier('name') then
|
||||
begin
|
||||
if P.Parent is TPasClassType then
|
||||
|
@ -72,6 +72,16 @@ type
|
||||
property Module: TPasModule read FModule write SetModule;
|
||||
end;
|
||||
|
||||
{ TTestResolverMessage }
|
||||
|
||||
TTestResolverMessage = class
|
||||
public
|
||||
Id: int64;
|
||||
MsgType: TMessageType;
|
||||
MsgNumber: integer;
|
||||
Msg: string;
|
||||
end;
|
||||
|
||||
TTestResolverReferenceData = record
|
||||
Filename: string;
|
||||
Row: integer;
|
||||
@ -93,12 +103,16 @@ type
|
||||
FFirstStatement: TPasImplBlock;
|
||||
FModules: TObjectList;// list of TTestEnginePasResolver
|
||||
FResolverEngine: TTestEnginePasResolver;
|
||||
FResolverMsgs: TObjectList; // list of TTestResolverMessage
|
||||
function GetModuleCount: integer;
|
||||
function GetModules(Index: integer): TTestEnginePasResolver;
|
||||
function GetMsgCount: integer;
|
||||
function GetMsgs(Index: integer): TTestResolverMessage;
|
||||
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
|
||||
procedure OnFindReference(El: TPasElement; FindData: pointer);
|
||||
procedure OnCheckElementParent(El: TPasElement; arg: pointer);
|
||||
procedure FreeSrcMarkers;
|
||||
procedure OnPasResolverLog(Sender: TObject; const Msg: String);
|
||||
Protected
|
||||
FirstSrcMarker, LastSrcMarker: PSrcMarker;
|
||||
Procedure SetUp; override;
|
||||
@ -107,6 +121,7 @@ type
|
||||
procedure ParseProgram; virtual;
|
||||
procedure ParseUnit; virtual;
|
||||
procedure CheckReferenceDirectives; virtual;
|
||||
procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer; Msg: string; MustHave: boolean);
|
||||
procedure CheckResolverException(Msg: string; MsgNumber: integer);
|
||||
procedure CheckParserException(Msg: string; MsgNumber: integer);
|
||||
procedure CheckAccessMarkers; virtual;
|
||||
@ -119,6 +134,8 @@ type
|
||||
procedure RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer);
|
||||
procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker);
|
||||
Public
|
||||
constructor Create; override;
|
||||
destructor Destroy; override;
|
||||
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver;
|
||||
function AddModule(aFilename: string): TTestEnginePasResolver;
|
||||
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver;
|
||||
@ -130,6 +147,8 @@ type
|
||||
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
|
||||
property ModuleCount: integer read GetModuleCount;
|
||||
property ResolverEngine: TTestEnginePasResolver read FResolverEngine;
|
||||
property MsgCount: integer read GetMsgCount;
|
||||
property Msgs[Index: integer]: TTestResolverMessage read GetMsgs;
|
||||
end;
|
||||
|
||||
{ TTestResolver }
|
||||
@ -162,8 +181,11 @@ type
|
||||
Procedure TestStr_BaseTypes;
|
||||
Procedure TestStr_StringFail;
|
||||
Procedure TestStr_CharFail;
|
||||
Procedure TestVarNoSemicolonBeginFail;
|
||||
|
||||
// strings
|
||||
Procedure TestChar_Ord;
|
||||
Procedure TestChar_Chr;
|
||||
Procedure TestString_SetLength;
|
||||
Procedure TestString_Element;
|
||||
Procedure TestStringElement_MissingArgFail;
|
||||
@ -198,10 +220,14 @@ type
|
||||
Procedure TestFloatOperators;
|
||||
Procedure TestCAssignments;
|
||||
Procedure TestTypeCastBaseTypes;
|
||||
Procedure TestTypeCastAliasBaseTypes;
|
||||
Procedure TestTypeCastStrToIntFail;
|
||||
Procedure TestTypeCastStrToCharFail;
|
||||
Procedure TestTypeCastIntToStrFail;
|
||||
Procedure TestTypeCastDoubleToStrFail;
|
||||
Procedure TestTypeCastDoubleToIntFail;
|
||||
Procedure TestTypeCastDoubleToBoolFail;
|
||||
Procedure TestTypeCastBooleanToDoubleFail;
|
||||
Procedure TestHighLow;
|
||||
Procedure TestAssign_Access;
|
||||
|
||||
@ -344,6 +370,7 @@ type
|
||||
Procedure TestClass_Sealed;
|
||||
Procedure TestClass_SealedDescendFail;
|
||||
Procedure TestClass_VarExternal;
|
||||
Procedure TestClass_WarnOverrideLowerVisibility;
|
||||
// Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
|
||||
|
||||
// external class
|
||||
@ -428,6 +455,8 @@ type
|
||||
Procedure TestArray_AssignNilToStaticArrayFail1;
|
||||
Procedure TestArray_SetLengthProperty;
|
||||
Procedure TestArray_PassArrayElementToVarParam;
|
||||
Procedure TestArray_OpenArrayOfString;
|
||||
Procedure TestArray_OpenArrayOfString_IntFail;
|
||||
|
||||
// procedure types
|
||||
Procedure TestProcTypesAssignObjFPC;
|
||||
@ -520,6 +549,7 @@ end;
|
||||
|
||||
procedure TCustomTestResolver.TearDown;
|
||||
begin
|
||||
FResolverMsgs.Clear;
|
||||
{$IFDEF VerbosePasResolverMem}
|
||||
writeln('TTestResolver.TearDown START FreeSrcMarkers');
|
||||
{$ENDIF}
|
||||
@ -998,6 +1028,42 @@ begin
|
||||
//writeln('TTestResolver.CheckReferenceDirectives COMPLETE');
|
||||
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);
|
||||
var
|
||||
ok: Boolean;
|
||||
@ -1217,6 +1283,18 @@ begin
|
||||
RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
|
||||
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
|
||||
): TTestEnginePasResolver;
|
||||
var
|
||||
@ -1237,6 +1315,7 @@ begin
|
||||
Result.Filename:=aFilename;
|
||||
Result.AddObjFPCBuiltInIdentifiers;
|
||||
Result.OnFindUnit:=@OnPasResolverFindUnit;
|
||||
Result.OnLog:=@OnPasResolverLog;
|
||||
FModules.Add(Result);
|
||||
end;
|
||||
|
||||
@ -1535,11 +1614,39 @@ begin
|
||||
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;
|
||||
begin
|
||||
Result:=TTestEnginePasResolver(FModules[Index]);
|
||||
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;
|
||||
begin
|
||||
Result:=FModules.Count;
|
||||
@ -1834,6 +1941,7 @@ begin
|
||||
Add(' s: single;');
|
||||
Add(' d: double;');
|
||||
Add(' aString: string;');
|
||||
Add(' r: record end;');
|
||||
Add('begin');
|
||||
Add(' Str(b,{#a_var}aString);');
|
||||
Add(' Str(b:1,aString);');
|
||||
@ -1853,6 +1961,17 @@ begin
|
||||
Add(' aString:=Str(i:3);');
|
||||
Add(' aString:=Str(d:3:4);');
|
||||
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;
|
||||
CheckAccessMarkers;
|
||||
end;
|
||||
@ -1880,6 +1999,40 @@ begin
|
||||
nIncompatibleTypeArgNo);
|
||||
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;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -2553,6 +2706,8 @@ begin
|
||||
Add(' fs: single;');
|
||||
Add(' d: double;');
|
||||
Add(' b: boolean;');
|
||||
Add(' c: char;');
|
||||
Add(' s: char;');
|
||||
Add('begin');
|
||||
Add(' d:=double({#a_read}i);');
|
||||
Add(' i:=shortint({#b_read}i);');
|
||||
@ -2564,6 +2719,39 @@ begin
|
||||
Add(' b:=bytebool({#i_read}longbool({#h_read}b));');
|
||||
Add(' d:=double({#j_read}i)/2.5;');
|
||||
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;
|
||||
CheckAccessMarkers;
|
||||
end;
|
||||
@ -2579,6 +2767,17 @@ begin
|
||||
CheckResolverException('illegal type conversion: string to longint',PasResolver.nIllegalTypeConversionTo);
|
||||
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;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -2612,6 +2811,28 @@ begin
|
||||
CheckResolverException('illegal type conversion: double to longint',PasResolver.nIllegalTypeConversionTo);
|
||||
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;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -5367,6 +5588,44 @@ begin
|
||||
ParseProgram;
|
||||
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;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -6814,6 +7073,34 @@ begin
|
||||
ParseProgram;
|
||||
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;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
@ -97,6 +97,7 @@ type
|
||||
procedure TestWP_UnitInitialization;
|
||||
procedure TestWP_UnitFinalization;
|
||||
procedure TestWP_CallInherited;
|
||||
procedure TestWP_ProgramPublicDeclarations;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -1232,6 +1233,18 @@ begin
|
||||
AnalyzeWholeProgram;
|
||||
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
|
||||
RegisterTests([TTestUseAnalyzer]);
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user