paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 13:09:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: mark inherited a:= as assignment, issue #37851

Browse Source 
git-svn-id: trunk@47028 -
(cherry picked from commit 43b236a4df)
This commit is contained in:
Mattias Gaertner 2020-10-01 19:59:50 +00:00 committed by Florian Klämpfl
parent 8ee9840f96
commit f87f381362
3 changed files with 147 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
packages/fcl-passrc/src/pasresolver.pp
View File

@ -1635,7 +1635,7 @@ type
procedure ResolveStatementConditionExpr(El: TPasExpr); virtual;
procedure ResolveNameExpr(El: TPasExpr; const aName: string; Access: TResolvedRefAccess); virtual;
procedure ResolveInherited(El: TInheritedExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveInheritedCall(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveInheritedName(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveBinaryExpr(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveSubIdent(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
@ -10303,7 +10303,7 @@ begin
and (TBinaryExpr(El.Parent).OpCode=eopNone) then
begin
// e.g. 'inherited Proc;'
ResolveInheritedCall(TBinaryExpr(El.Parent),Access);
ResolveInheritedName(TBinaryExpr(El.Parent),Access);
exit;
end;
@ -10377,11 +10377,11 @@ begin
sAbstractMethodsCannotBeCalledDirectly,[],El);
end;
procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr;
procedure TPasResolver.ResolveInheritedName(El: TBinaryExpr;
Access: TResolvedRefAccess);
// El.OpCode=eopNone
// El.left is TInheritedExpr
// El.right is the identifier and parameters
// El.right is the identifier and/or paramexpr
var
SelfScope: TPasProcedureScope;
ClassRecScope: TPasClassOrRecordScope;
@ -10393,7 +10393,7 @@ var
InhScope: TPasInheritedScope;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El));
writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El),' Access=',Access);
{$ENDIF}
SelfScope:=GetCurrentSelfScope(El);
@ -10453,15 +10453,20 @@ begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.ResolveBinaryExpr left=',GetObjName(El.left),' right=',GetObjName(El.right),' opcode=',OpcodeStrings[El.OpCode]);
{$ENDIF}
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
case El.OpCode of
eopNone:
case El.Kind of
pekRange:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveExpr(El.right,rraRead);
end;
else
if El.left.ClassType=TInheritedExpr then
begin
ResolveExpr(El.left,Access);
end
else
begin
{$IFDEF VerbosePasResolver}
@ -10493,9 +10498,17 @@ begin
eopIs,
eopAs,
eopSymmetricaldifference:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveExpr(El.right,rraRead);
end;
eopSubIdent:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveSubIdent(El,Access);
end;
else
RaiseNotYetImplemented(20160922163459,El,OpcodeStrings[El.OpCode]);
end;

57
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -725,6 +725,7 @@ type
Procedure TestPropertyArgs2;
Procedure TestPropertyArgsWithDefaultsFail;
Procedure TestPropertyArgs_StringConstDefault;
Procedure TestPropertyInherited;
Procedure TestClassProperty;
Procedure TestClassPropertyNonStaticFail;
Procedure TestClassPropertyNonStaticAllow;
@ -12997,6 +12998,62 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestPropertyInherited;
var
aMarker: PSrcMarker;
Elements: TFPList;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add(['type',
' TObject = class',
' FA: word;',
' property A: word read FA write FA;',
' end;',
' TBird = class(TObject)',
' FB: word;',
' procedure Run(Value: word);',
' property A read FB write FB;',
' end;',
'procedure TBird.Run(Value: word);',
'begin',
' inherited {#A}A:=Value;',
//' Value:=inherited {@A1}A;',
'end;',
'begin',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
writeln('TTestResolver.TestPropertyInherited ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestPropertyInherited ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' CustomData=',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProperty) then continue;
writeln('TTestResolver.TestPropertyInherited ',GetObjName(Ref.Declaration),' Ref.Access=',Ref.Access);
case aMarker^.Identifier of
'A': if Ref.Access<>rraAssign then
RaiseErrorAtSrcMarker('expected property write at "#'+aMarker^.Identifier+', but got "'+dbgs(Ref.Access),aMarker);
'B': if Ref.Access<>rraRead then
RaiseErrorAtSrcMarker('expected property read at "#'+aMarker^.Identifier+', but got "'+dbgs(Ref.Access),aMarker);
end;
break;
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestClassProperty;
begin
StartProgram(false);

84
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -80,6 +80,8 @@ type
procedure TestM_Class_Property;
procedure TestM_Class_PropertyProtected;
procedure TestM_Class_PropertyOverride;
procedure TestM_Class_PropertyOverride2;
procedure TestM_Class_PropertyInherited;
procedure TestM_Class_MethodOverride;
procedure TestM_Class_MethodOverride2;
procedure TestM_ClassInterface_Corba;
@ -1178,20 +1180,74 @@ end;
procedure TTestUseAnalyzer.TestM_Class_PropertyOverride;
begin
StartProgram(false);
Add('type');
Add(' {#integer_used}integer = longint;');
Add(' {tobject_used}TObject = class');
Add(' {#fa_used}FA: integer;');
Add(' {#fb_notused}FB: integer;');
Add(' property {#obj_a_notused}A: integer read FA write FB;');
Add(' end;');
Add(' {tmobile_used}TMobile = class(TObject)');
Add(' {#fc_used}FC: integer;');
Add(' property {#mob_a_used}A write FC;');
Add(' end;');
Add('var {#m_used}M: TMobile;');
Add('begin');
Add(' M.A:=M.A;');
Add(['type',
' {#integer_used}integer = longint;',
' {tobject_used}TObject = class',
' {#fa_used}FA: integer;',
' {#fb_notused}FB: integer;',
' property {#obj_a_notused}A: integer read FA write FB;',
' end;',
' {tmobile_used}TMobile = class(TObject)',
' {#fc_used}FC: integer;',
' property {#mob_a_used}A write FC;',
' end;',
'var {#m_used}M: TMobile;',
'begin',
' M.A:=M.A;']);
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_Class_PropertyOverride2;
begin
StartProgram(false);
Add(['type',
' {#integer_used}integer = longint;',
' {tobject_used}TObject = class',
' {#fa_used}FA: integer;',
' {#fb_used}FB: integer;',
' property {#obj_a_used}A: integer read FA write FB;',
' end;',
' {tmobile_used}TMobile = class(TObject)',
' {#fc_notused}FC: integer;',
' property {#mob_a_notused}A write FC;',
' end;',
'var',
' {#m_used}M: TMobile;',
' {#o_used}o: TObject;',
'begin',
' o:=m;',
' o.A:=o.A;',
'']);
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_Class_PropertyInherited;
begin
StartProgram(false);
Add(['type',
' {tobject_used}TObject = class',
' {#fa_used}FA: word;',
' {#fb_used}FB: word;',
' property {#obj_a_used}A: word write FA;',
' property {#obj_b_used}B: word read FB;',
' end;',
' {tbird_used}TBird = class(TObject)',
' {#fc_notused}FC: word;',
' {#fd_notused}FD: word;',
' procedure {#run_used}Run({#run_value_used}Value: word);',
' property {#bird_a_notused}A write FC;',
' property {#bird_b_notused}B write FD;',
' end;',
'procedure TBird.Run(Value: word);',
'begin',
' inherited A:=Value;',
' Value:=inherited B;',
'end;',
'var',
' {#b_used}b: TBird;',
'begin',
' b.Run(3);',
'']);
AnalyzeProgram;
end;