fcl-passrc: resolver: nested class: search parent

git-svn-id: trunk@43199 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1047,6 +1047,7 @@ type
   public
     Scopes: TPasIdentifierScopeArray;
     Count: integer;
+    OnlyTypeMembers: boolean;
     procedure Add(Scope: TPasIdentifierScope);
     destructor Destroy; override;
     function GetFirstNonHelperScope: TPasIdentifierScope;
@@ -1075,7 +1076,7 @@ type
     OverriddenProc: TPasProcedure; // the ancestor proc with same signature
     ClassRecScope: TPasClassOrRecordScope;
     GroupScope: TPasGroupScope; // set during parsing a method body
-    NestedMembersScope: TPasIdentifierScope; // set during parsing a method body of a nested class
+    NestedMembersScope: TPasGroupScope; // set during parsing a method body of a nested class
     SelfArg: TPasArgument;
     Flags: TPasProcedureScopeFlags;
     BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc
@@ -3694,7 +3695,7 @@ begin
   {$ENDIF}
   FreeAndNil(References);
   FreeAndNil(GroupScope);
-  NestedMembersScope:=nil;  // do not free NestedMembersScope
+  NestedMembersScope:=nil; // NestedMembersScope is auto freed
   inherited Destroy;
   ReleaseAndNil(TPasElement(SelfArg){$IFDEF CheckPasTreeRefCount},'TPasProcedureScope.SelfArg'{$ENDIF});
   {$IFDEF VerbosePasResolverMem}
@@ -12173,7 +12174,7 @@ var
   Level, TypeParamCount, i: Integer;
   NamePart: TProcedureNamePart;
   TemplType, FoundTemplType: TPasGenericTemplateType;
-  NestedMembersScope: TPasDotBaseScope;
+  NestedMembersScope: TPasGroupScope;
 begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.AddProcedure ',GetObjName(El));
@@ -12402,31 +12403,21 @@ begin
       begin
       // nested class
       ClassOrRecType:=TPasMembersType(ClassOrRecType.Parent);
-      NestedMembersScope:=PushDotScope(ClassOrRecType);
+      NestedMembersScope:=CreateGroupScope(ClassOrRecType);
       ProcScope.NestedMembersScope:=NestedMembersScope;
       NestedMembersScope.OnlyTypeMembers:=true;
       // Delphi searches the parent class scopes *after* the section scopes
       // and before the module scope - sigh
       // -> Move scope between module scope and section scope
-      i:=ScopeCount-1;
-      while true do
-        begin
-        if i<=0 then
-          RaiseNotYetImplemented(20191015002850,El)
-        else if FScopes[i-1] is TPasModuleScope then
-          begin
-          FScopes[i]:=NestedMembersScope;
-          break;
-          end;
-        FScopes[i]:=FScopes[i-1];
-        dec(i);
-        end;
-      FTopScope:=FScopes[FScopeCount-1];
+      i:=0;
+      while (i<ScopeCount) and not (FScopes[i] is TPasModuleScope) do
+        inc(i);
+      InsertScope(NestedMembersScope,i+1);
 
       while ClassOrRecType.Parent is TPasMembersType do
         begin
         ClassOrRecType:=TPasMembersType(ClassOrRecType.Parent);
-        GroupScope_AddTypeAndAncestors(NestedMembersScope.GroupScope,ClassOrRecType);
+        GroupScope_AddTypeAndAncestors(NestedMembersScope,ClassOrRecType);
         end;
       end;
     end;
@@ -20710,7 +20701,9 @@ begin
     //writeln('TPasResolver.CheckFoundElement ',GetObjName(Proc),' ',IsClassMethod(Proc),' ElScope=',GetObjName(FindData.ElScope));
     if (FindData.ElScope<>StartScope) and IsClassMethod(Proc) then
       OnlyTypeMembers:=true;
-    end;
+    end
+  else if StartScope.ClassType=TPasGroupScope then
+    OnlyTypeMembers:=TPasGroupScope(StartScope).OnlyTypeMembers;
 
   //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',StartScope.ClassName,
   //    ' StartIsDot=',StartScope is TPasDotBaseScope,

packages/fcl-passrc/tests/tcresolver.pas

@@ -640,8 +640,9 @@ type
     Procedure TestNestedClass_Forward;
     procedure TestNestedClass_StrictPrivateFail;
     procedure TestNestedClass_AccessStrictPrivate;
-    procedure TestNestedClass_AccessParentVarFail;
     procedure TestNestedClass_AccessParent;
+    procedure TestNestedClass_BodyAccessParentVarFail;
+    procedure TestNestedClass_PropertyAccessParentVarFail;
 
     // external class
     Procedure TestExternalClass;
@@ -11477,28 +11478,6 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolver.TestNestedClass_AccessParentVarFail;
-begin
-  StartProgram(false);
-  Add([
-  'type',
-  '  TObject = class end;',
-  '  TBird = class',
-  '  public type',
-  '    TWing = class',
-  '      procedure Fly;',
-  '    end;',
-  '  public',
-  '    var i: longint;',
-  '  end;',
-  'procedure TBird.TWing.Fly;',
-  'begin',
-  '  i:=3;',
-  'end;',
-  'begin']);
-  CheckResolverException('Instance member "i" inaccessible here',nInstanceMemberXInaccessible);
-end;
-
 procedure TTestResolver.TestNestedClass_AccessParent;
 begin
   StartUnit(false);
@@ -11518,7 +11497,7 @@ begin
   '      TAnt = word;',
   '      TWing = class(TLimb)',
   '        {#ant}ant: TAnt;',
-  '        procedure Fly;',
+  '        procedure Fly(i: longint);',
   '      end;',
   '    public',
   '      class var {#tbody_a}a, {#tbody_b}b, {#tbody_d}d, {#tbody_e}e: longint;',
@@ -11529,7 +11508,7 @@ begin
   'var {#intf_a}a, {#intf_d}d: longint;',
   'implementation',
   'var {#impl_e}e: longint;',
-  'procedure TBird.TBody.TWing.Fly;',
+  'procedure TBird.TBody.TWing.Fly(i: longint);',
   'begin',
   '  {@ant}ant:=2;',
   '  {@intf_a}a:=3;',
@@ -11542,6 +11521,45 @@ begin
   ParseUnit;
 end;
 
+procedure TTestResolver.TestNestedClass_BodyAccessParentVarFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class',
+  '  public type',
+  '    TWing = class',
+  '      procedure Fly;',
+  '    end;',
+  '  public',
+  '    var i: longint;',
+  '  end;',
+  'procedure TBird.TWing.Fly;',
+  'begin',
+  '  i:=3;',
+  'end;',
+  'begin']);
+  CheckResolverException('Instance member "i" inaccessible here',nInstanceMemberXInaccessible);
+end;
+
+procedure TTestResolver.TestNestedClass_PropertyAccessParentVarFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class',
+  '    fSize: word;',
+  '  public type',
+  '    TWing = class',
+  '      property Size: word read fSize;',
+  '    end;',
+  '  end;',
+  'begin']);
+  CheckResolverException('identifier not found "fSize"',nIdentifierNotFound);
+end;
+
 procedure TTestResolver.TestExternalClass;
 begin
   StartProgram(false);