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

git-svn-id: trunk@47028 -

packages/fcl-passrc/src/pasresolver.pp

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

packages/fcl-passrc/tests/tcresolver.pas

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

packages/fcl-passrc/tests/tcuseanalyzer.pas

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