Browse Source

fcl-passrc: fixed no hint when published method hides ancestor method

git-svn-id: trunk@48997 -
(cherry picked from commit 9e9859f14529a75098b16ba693b7edc87d880160)
Mattias Gaertner 4 years ago
parent
commit
6eaceb2f53
2 changed files with 57 additions and 1 deletions
  1. 3 1
      packages/fcl-passrc/src/pasresolver.pp
  2. 54 0
      packages/pastojs/tests/tcmodules.pas

+ 3 - 1
packages/fcl-passrc/src/pasresolver.pp

@@ -5487,7 +5487,9 @@ begin
             if (Proc.Visibility=visStrictPrivate)
             if (Proc.Visibility=visStrictPrivate)
                 or ((Proc.Visibility=visPrivate)
                 or ((Proc.Visibility=visPrivate)
                   and (Proc.GetModule<>Data^.Proc.GetModule)) then
                   and (Proc.GetModule<>Data^.Proc.GetModule)) then
-              // a private private is hidden by definition -> no hint
+              // a private method is hidden by definition -> no hint
+            else if (Proc.Visibility=visPublished) then
+              // a published can hide (used for overloading rtti) -> no hint
             else if (ProcScope.ImplProc<>nil)  // not abstract, external
             else if (ProcScope.ImplProc<>nil)  // not abstract, external
                 and (not ProcHasImplElements(ProcScope.ImplProc)) then
                 and (not ProcHasImplElements(ProcScope.ImplProc)) then
               // hidden method has implementation, but no statements -> useless
               // hidden method has implementation, but no statements -> useless

+ 54 - 0
packages/pastojs/tests/tcmodules.pas

@@ -816,6 +816,7 @@ type
     Procedure TestRTTI_DynArray;
     Procedure TestRTTI_DynArray;
     Procedure TestRTTI_ArrayNestedAnonymous;
     Procedure TestRTTI_ArrayNestedAnonymous;
     Procedure TestRTTI_PublishedMethodOverloadFail;
     Procedure TestRTTI_PublishedMethodOverloadFail;
+    Procedure TestRTTI_PublishedMethodHideNoHint;
     Procedure TestRTTI_PublishedMethodExternalFail;
     Procedure TestRTTI_PublishedMethodExternalFail;
     Procedure TestRTTI_PublishedClassPropertyFail;
     Procedure TestRTTI_PublishedClassPropertyFail;
     Procedure TestRTTI_PublishedClassFieldFail;
     Procedure TestRTTI_PublishedClassFieldFail;
@@ -29497,6 +29498,59 @@ begin
   ConvertProgram;
   ConvertProgram;
 end;
 end;
 
 
+procedure TTestModule.TestRTTI_PublishedMethodHideNoHint;
+begin
+  WithTypeInfo:=true;
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  {$M+}',
+  '  TBird = class',
+  '    procedure Fly;',
+  '  end;',
+  '  {$M-}',
+  'type',
+  '  TEagle = class(TBird)',
+  '    procedure Fly;',
+  '  end;',
+  'implementation',
+  'procedure TBird.Fly;',
+  'begin',
+  'end;',
+  'procedure TEagle.Fly;',
+  'begin',
+  'end;',
+  '']);
+  ConvertUnit;
+  CheckSource('TestRTTI_PublishedMethodHideNoHint',
+    LinesToStr([ // statements
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass(this, "TBird", this.TObject, function () {',
+    '  this.Fly = function () {',
+    '  };',
+    '  var $r = this.$rtti;',
+    '  $r.addMethod("Fly", 0, null);',
+    '});',
+    'rtl.createClass(this, "TEagle", this.TBird, function () {',
+    '  this.Fly = function () {',
+    '  };',
+    '  var $r = this.$rtti;',
+    '  $r.addMethod("Fly", 0, null);',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    ]));
+  CheckResolverUnexpectedHints(true);
+end;
+
 procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
 procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
 begin
 begin
   WithTypeInfo:=true;
   WithTypeInfo:=true;