fcl-passrc: resolver/parser: detect unit cycle, stop parsing, continue parsing after used unit interfaces have finished

git-svn-id: trunk@37728 -

packages/fcl-passrc/src/pasresolver.pp

@@ -504,6 +504,9 @@ type
   TPasModuleScope = class(TPasScope)
   public
     FirstName: string;
+    PendingResolvers: TFPList; // list of TPasResolver waiting for the unit interface
+    constructor Create; override;
+    destructor Destroy; override;
     procedure IterateElements(const aName: string; StartScope: TPasScope;
       const OnIterateElement: TIterateScopeElement; Data: Pointer;
       var Abort: boolean); override;
@@ -578,6 +581,7 @@ type
       Data: Pointer; var Abort: boolean);
   public
     UsesScopes: TFPList; // list of TPasSectionScope
+    Finished: boolean;
     constructor Create; override;
     destructor Destroy; override;
     function FindIdentifier(const Identifier: String): TPasIdentifier; override;
@@ -1062,6 +1066,8 @@ type
     procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess);
     procedure FinishModule(CurModule: TPasModule); virtual;
     procedure FinishUsesClause; virtual;
+    procedure FinishSection(Section: TPasSection); virtual;
+    procedure FinishInterfaceSection(Section: TPasSection); virtual;
     procedure FinishTypeSection(El: TPasDeclarations); virtual;
     procedure FinishTypeDef(El: TPasType); virtual;
     procedure FinishEnumType(El: TPasEnumType); virtual;
@@ -1262,6 +1268,10 @@ type
       Ref: TResolvedReference); virtual;
     function GetVisibilityContext: TPasElement;
     procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
+    function IsUnitIntfFinished(AModule: TPasModule): boolean;
+    function GetPendingUsedInterface(Section: TPasSection): TPasUsesUnit;
+    procedure CheckPendingUsedInterface(Section: TPasSection); override;
+    procedure ContinueParsing; virtual;
     function NeedArrayValues(El: TPasElement): boolean; override;
     function GetDefaultClassVisibility(AClass: TPasClassType
       ): TPasMemberVisibility; override;
@@ -2365,6 +2375,18 @@ end;
 
 { TPasModuleScope }
 
+constructor TPasModuleScope.Create;
+begin
+  inherited Create;
+  PendingResolvers:=TFPList.Create;
+end;
+
+destructor TPasModuleScope.Destroy;
+begin
+  FreeAndNil(PendingResolvers);
+  inherited Destroy;
+end;
+
 procedure TPasModuleScope.IterateElements(const aName: string;
   StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
   Data: Pointer; var Abort: boolean);
@@ -3389,6 +3411,8 @@ begin
     end
   else if (CurModuleClass=TPasModule) then
     begin
+    // unit
+    FinishSection(CurModule.InterfaceSection);
     if CurModule.FinalizationSection<>nil then
       // finalization section finished -> resolve
       ResolveImplBlock(CurModule.FinalizationSection);
@@ -3501,12 +3525,51 @@ begin
     FirstName:=LeftStr(FirstName,p-1);
     OldIdentifier:=Scope.FindLocalIdentifier(FirstName);
     if (OldIdentifier=nil) then
-      AddIdentifier(Scope,FirstName,UseUnit.Module,pikNamespace);
+      AddIdentifier(Scope,FirstName,UseUnit,pikNamespace);
     end;
   // Note: a sub identifier (e.g. a class member) hides all unitnames starting
   //       with this identifier
 end;
 
+procedure TPasResolver.FinishSection(Section: TPasSection);
+// Note: can be called multiple times for a section
+var
+  Scope: TPasSectionScope;
+begin
+  Scope:=Section.CustomData as TPasSectionScope;
+  if Scope.Finished then exit;
+  Scope.Finished:=true;
+  if Section is TInterfaceSection then
+    FinishInterfaceSection(Section);
+end;
+
+procedure TPasResolver.FinishInterfaceSection(Section: TPasSection);
+var
+  ModuleScope: TPasModuleScope;
+  PendingResolver: TPasResolver;
+  PendingParser: TPasParser;
+  PendingModule: TPasModule;
+  PendingImpl: TImplementationSection;
+begin
+  {$IFDEF VerbosePasResolver}
+  if not IsUnitIntfFinished(Section.GetModule) then
+    RaiseInternalError(20171214004323,'TPasResolver.FinishInterfaceSection "'+CurrentParser.CurModule.Name+'" "'+Section.GetModule.Name+'" IsUnitIntfFinished=false');
+  {$ENDIF}
+  ModuleScope:=CurrentParser.CurModule.CustomData as TPasModuleScope;
+  while ModuleScope.PendingResolvers.Count>0 do
+    begin
+    PendingResolver:=TObject(ModuleScope.PendingResolvers[0]) as TPasResolver;
+    PendingParser:=PendingResolver.CurrentParser;
+    PendingModule:=PendingParser.CurModule;
+    PendingImpl:=PendingModule.ImplementationSection;
+    {$IFDEF VerbosePasResolver}
+    writeln('TPasResolver.FinishInterfaceSection "',ModuleScope.Element.Name,'" Pending="',PendingModule.Name,'"');
+    {$ENDIF}
+    PendingResolver.CheckPendingUsedInterface(PendingImpl);
+    end;
+  if Section=nil then ;
+end;
+
 procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
 
   function ReplaceDestType(AliasType: TPasAliasType; const DestName: string;
@@ -6535,6 +6598,8 @@ procedure TPasResolver.AddSection(El: TPasSection);
 // TInterfaceSection, TImplementationSection, TProgramSection, TLibrarySection
 // Note: implementation scope is within the interface scope
 begin
+  if TopScope is TPasSectionScope then
+    FinishSection(TPasSectionScope(TopScope).Element as TPasSection);
   FPendingForwardProcs.Add(El); // check forward declarations at the end
   PushScope(El,TPasSectionScope);
 end;
@@ -10009,6 +10074,10 @@ begin
       NeedPop:=false;
 
     NextEl:=FindElementWithoutParams(CurName,ErrorEl,true);
+    {$IFDEF VerbosePasResolver}
+    //if RightPath<>'' then
+    //  writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ... NextEl=',GetObjName(NextEl));
+    {$ENDIF}
     if NextEl is TPasModule then
       begin
       if CurScopeEl is TPasModule then
@@ -10458,6 +10527,86 @@ begin
   end;
 end;
 
+function TPasResolver.IsUnitIntfFinished(AModule: TPasModule): boolean;
+var
+  CurIntf: TInterfaceSection;
+begin
+  CurIntf:=AModule.InterfaceSection;
+  Result:=(CurIntf<>nil)
+      and (CurIntf.CustomData is TPasSectionScope)
+      and TPasSectionScope(CurIntf.CustomData).Finished;
+end;
+
+function TPasResolver.GetPendingUsedInterface(Section: TPasSection
+  ): TPasUsesUnit;
+var
+  i: Integer;
+  UseUnit: TPasUsesUnit;
+begin
+  Result:=nil;
+  if not (Section is TImplementationSection) then exit;
+  for i:=0 to length(Section.UsesClause)-1 do
+    begin
+    UseUnit:=Section.UsesClause[i];
+    if not (UseUnit.Module is TPasModule) then continue;
+    if not IsUnitIntfFinished(TPasModule(UseUnit.Module)) then
+      exit(UseUnit);
+    end;
+end;
+
+procedure TPasResolver.CheckPendingUsedInterface(Section: TPasSection);
+var
+  PendingModule: TPasModule;
+  PendingModuleScope: TPasModuleScope;
+  List: TFPList;
+  WasPending: Boolean;
+begin
+  {$IFDEF VerbosePasResolver}
+  //writeln('TPasResolver.CheckPendingUsedInterface START "',CurrentParser.CurModule.Name,'"');
+  {$ENDIF}
+  WasPending:=Section.PendingUsedIntf<>nil;
+  if WasPending then
+    begin
+    PendingModule:=Section.PendingUsedIntf.Module as TPasModule;
+    if not IsUnitIntfFinished(PendingModule) then
+      exit; // still pending
+    // other unit interface is finished
+    PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
+    PendingModuleScope.PendingResolvers.Remove(Self);
+    Section.PendingUsedIntf:=nil;
+    end;
+
+  Section.PendingUsedIntf:=GetPendingUsedInterface(Section);
+  if Section.PendingUsedIntf<>nil then
+    begin
+    // unit not yet finished due to pending used interfaces
+    PendingModule:=Section.PendingUsedIntf.Module as TPasModule;
+    PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
+    {$IFDEF VerbosePasResolver}
+    writeln('TPasResolver.CheckPendingUsedInterface "',CurrentParser.CurModule.Name,'" waiting for unit intf of "',PendingModule.Name,'"');
+    {$ENDIF}
+    List:=PendingModuleScope.PendingResolvers;
+    if List.IndexOf(Self)<0 then
+      List.Add(Self);
+    end
+  else
+    begin
+    if WasPending then
+      // can now continue parsing
+      ContinueParsing;
+    end;
+end;
+
+procedure TPasResolver.ContinueParsing;
+// if there is a unit cycle that stopped parsing this unit
+// this method is called after the needed used unit interfaces have finished
+begin
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.ContinueParsing "',CurrentParser.CurModule.Name,'"...');
+  {$ENDIF}
+  CurrentParser.ParseContinueImplementation;
+end;
+
 function TPasResolver.NeedArrayValues(El: TPasElement): boolean;
 // called by the parser when reading DoParseConstValueExpression
 var

packages/fcl-passrc/src/pastree.pp

@@ -341,6 +341,7 @@ type
   public
     UsesList: TFPList; // kept for compatibility, see TPasUsesUnit.Module
     UsesClause: TPasUsesClause;
+    PendingUsedIntf: TPasUsesUnit; // <>nil while resolving a uses cycle
   end;
 
   { TInterfaceSection }

packages/fcl-passrc/src/pparser.pp

@@ -189,6 +189,7 @@ type
     function FindElement(const AName: String): TPasElement; virtual; abstract;
     procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
     function FindModule(const AName: String): TPasModule; virtual;
+    procedure CheckPendingUsedInterface(Section: TPasSection); virtual;
     function NeedArrayValues(El: TPasElement): boolean; virtual;
     function GetDefaultClassVisibility(AClass: TPasClassType): TPasMemberVisibility; virtual;
     property Package: TPasPackage read FPackage;
@@ -397,6 +398,7 @@ type
     // Main scope parsing
     procedure ParseMain(var Module: TPasModule);
     procedure ParseUnit(var Module: TPasModule);
+    procedure ParseContinueImplementation;
     procedure ParseProgram(var Module: TPasModule; SkipHeader : Boolean = False);
     procedure ParseLibrary(var Module: TPasModule);
     procedure ParseOptionalUsesList(ASection: TPasSection);
@@ -764,6 +766,11 @@ begin
   Result := nil;
 end;
 
+procedure TPasTreeContainer.CheckPendingUsedInterface(Section: TPasSection);
+begin
+  if Section=nil then ;
+end;
+
 function TPasTreeContainer.NeedArrayValues(El: TPasElement): boolean;
 begin
   Result:=false;
@@ -2662,7 +2669,6 @@ begin
   else
     UngetToken;
     ParseProgram(Module,True);
-  //    ParseExcTokenError('unit');
   end;
 end;
 
@@ -2671,6 +2677,7 @@ procedure TPasParser.ParseUnit(var Module: TPasModule);
 var
   AUnitName: String;
   StartPos: TPasSourcePos;
+  HasFinished: Boolean;
 begin
   StartPos:=CurTokenPos;
   Module := nil;
@@ -2685,6 +2692,7 @@ begin
   UngetToken;
   Module := TPasModule(CreateElement(TPasModule, AUnitName, Engine.Package, StartPos));
   FCurModule:=Module;
+  HasFinished:=true;
   try
     if Assigned(Engine.Package) then
       begin
@@ -2693,12 +2701,26 @@ begin
       Module.AddRef;
       end;
     CheckHint(Module,True);
-//    ExpectToken(tkSemicolon);
     ExpectToken(tkInterface);
     If LogEvent(pleInterface) then
       DoLog(mtInfo,nLogStartInterface,SLogStartInterface);
     ParseInterface;
-    Engine.FinishScope(stModule,Module);
+    if (Module.ImplementationSection<>nil)
+        and (Module.ImplementationSection.PendingUsedIntf<>nil) then
+      HasFinished:=false;
+    if HasFinished then
+      Engine.FinishScope(stModule,Module);
+  finally
+    if HasFinished then
+      FCurModule:=nil;
+  end;
+end;
+
+procedure TPasParser.ParseContinueImplementation;
+begin
+  try
+    ParseDeclarations(CurModule.ImplementationSection);
+    Engine.FinishScope(stModule,CurModule);
   finally
     FCurModule:=nil;
   end;
@@ -2840,6 +2862,9 @@ begin
   Section := TImplementationSection(CreateElement(TImplementationSection, '', CurModule));
   CurModule.ImplementationSection := Section;
   ParseOptionalUsesList(Section);
+  Engine.CheckPendingUsedInterface(Section);
+  if Section.PendingUsedIntf<>nil then
+    exit;
   ParseDeclarations(Section);
 end;
 

packages/fcl-passrc/tests/tcresolver.pas

@@ -46,6 +46,7 @@ const
     );
 type
   TOnFindUnit = function(Sender: TPasResolver; const aUnitName: String): TPasModule of object;
+  TOnContinueParsing = procedure(Sender: TPasResolver) of object;
 
   { TTestEnginePasResolver }
 
@@ -53,6 +54,7 @@ type
   private
     FFilename: string;
     FModule: TPasModule;
+    FOnContinueParsing: TOnContinueParsing;
     FOnFindUnit: TOnFindUnit;
     FParser: TPasParser;
     FResolver: TStreamResolver;
@@ -62,7 +64,13 @@ type
   public
     constructor Create;
     destructor Destroy; override;
+    function CreateElement(AClass: TPTreeElement; const AName: String;
+      AParent: TPasElement; AVisibility: TPasMemberVisibility;
+      const ASrcPos: TPasSourcePos): TPasElement;
+      overload; override;
     function FindModule(const AName: String): TPasModule; override;
+    procedure ContinueParsing; override;
+    property OnContinueParsing: TOnContinueParsing read FOnContinueParsing write FOnContinueParsing;
     property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
     property Filename: string read FFilename write FFilename;
     property Resolver: TStreamResolver read FResolver write FResolver;
@@ -110,6 +118,7 @@ type
     function GetModules(Index: integer): TTestEnginePasResolver;
     function GetMsgCount: integer;
     function GetMsgs(Index: integer): TTestResolverMessage;
+    procedure OnPasResolverContinueParsing(Sender: TPasResolver);
     function OnPasResolverFindUnit(SrcResolver: TPasResolver;
       const aUnitName: String): TPasModule;
     procedure OnFindReference(El: TPasElement; FindData: pointer);
@@ -138,6 +147,7 @@ type
     procedure WriteSources(const aFilename: string; aRow, aCol: integer);
     procedure RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer);
     procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker);
+    procedure HandleError(CurEngine: TTestEnginePasResolver; E: Exception);
   Public
     constructor Create; override;
     destructor Destroy; override;
@@ -325,6 +335,7 @@ type
     Procedure TestUnit_MissingUnitErrorPos;
     Procedure TestUnit_UnitNotFoundErrorPos;
     Procedure TestUnit_AccessIndirectUsedUnitFail;
+    Procedure TestUnit_Intf1Impl2Intf1;
 
     // procs
     Procedure TestProcParam;
@@ -723,11 +734,23 @@ begin
   inherited Destroy;
 end;
 
+function TTestEnginePasResolver.CreateElement(AClass: TPTreeElement;
+  const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility;
+  const ASrcPos: TPasSourcePos): TPasElement;
+begin
+  Result:=inherited CreateElement(AClass, AName, AParent, AVisibility, ASrcPos);
+  if (FModule=nil) and AClass.InheritsFrom(TPasModule) then
+    Module:=TPasModule(Result);
+end;
+
 function TTestEnginePasResolver.FindModule(const AName: String): TPasModule;
 begin
-  Result:=nil;
-  if Assigned(OnFindUnit) then
-    Result:=OnFindUnit(Self,AName);
+  Result:=OnFindUnit(Self,AName);
+end;
+
+procedure TTestEnginePasResolver.ContinueParsing;
+begin
+  OnContinueParsing(Self);
 end;
 
 { TCustomTestResolver }
@@ -1519,6 +1542,25 @@ begin
   RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
 end;
 
+procedure TCustomTestResolver.HandleError(CurEngine: TTestEnginePasResolver;
+  E: Exception);
+var
+  ErrFilename: String;
+  ErrRow, ErrCol: Integer;
+begin
+  ErrFilename:=CurEngine.Scanner.CurFilename;
+  ErrRow:=CurEngine.Scanner.CurRow;
+  ErrCol:=CurEngine.Scanner.CurColumn;
+  writeln('ERROR: TTestResolver.OnPasResolverFindUnit during parsing: '+E.ClassName+':'+E.Message
+    +' File='+ErrFilename
+    +' LineNo='+IntToStr(ErrRow)
+    +' Col='+IntToStr(ErrCol)
+    +' Line="'+CurEngine.Scanner.CurLine+'"'
+    );
+  WriteSources(ErrFilename,ErrRow,ErrCol);
+  Fail(E.Message);
+end;
+
 constructor TCustomTestResolver.Create;
 begin
   inherited Create;
@@ -1553,6 +1595,7 @@ begin
   Result.Filename:=aFilename;
   Result.AddObjFPCBuiltInIdentifiers;
   Result.OnFindUnit:=@OnPasResolverFindUnit;
+  Result.OnContinueParsing:=@OnPasResolverContinueParsing;
   Result.OnLog:=@OnPasResolverLog;
   FModules.Add(Result);
 end;
@@ -1694,9 +1737,9 @@ function TCustomTestResolver.OnPasResolverFindUnit(SrcResolver: TPasResolver;
 
   function FindUnit(const aUnitName: String): TPasModule;
   var
-    i, ErrRow, ErrCol: Integer;
+    i: Integer;
     CurEngine: TTestEnginePasResolver;
-    CurUnitName, ErrFilename: String;
+    CurUnitName: String;
   begin
     {$IFDEF VerboseUnitSearch}
     writeln('TTestResolver.OnPasResolverFindUnit START Unit="',aUnitName,'"');
@@ -1733,19 +1776,7 @@ function TCustomTestResolver.OnPasResolverFindUnit(SrcResolver: TPasResolver;
           CurEngine.Parser.ParseUnit(CurEngine.FModule);
         except
           on E: Exception do
-            begin
-            ErrFilename:=CurEngine.Scanner.CurFilename;
-            ErrRow:=CurEngine.Scanner.CurRow;
-            ErrCol:=CurEngine.Scanner.CurColumn;
-            writeln('ERROR: TTestResolver.OnPasResolverFindUnit during parsing: '+E.ClassName+':'+E.Message
-              +' File='+ErrFilename
-              +' LineNo='+IntToStr(ErrRow)
-              +' Col='+IntToStr(ErrCol)
-              +' Line="'+CurEngine.Scanner.CurLine+'"'
-              );
-            WriteSources(ErrFilename,ErrRow,ErrCol);
-            Fail(E.Message);
-            end;
+            HandleError(CurEngine,E);
         end;
         //writeln('TTestResolver.OnPasResolverFindUnit END ',CurUnitName);
         Result:=CurEngine.Module;
@@ -1911,6 +1942,23 @@ begin
   Result:=TTestResolverMessage(FResolverMsgs[Index]);
 end;
 
+procedure TCustomTestResolver.OnPasResolverContinueParsing(Sender: TPasResolver
+  );
+var
+  CurEngine: TTestEnginePasResolver;
+begin
+  CurEngine:=Sender as TTestEnginePasResolver;
+  {$IFDEF VerbosePasResolver}
+  writeln('TCustomTestResolver.OnPasResolverContinueParsing "',CurEngine.Module.Name,'"...');
+  {$ENDIF}
+  try
+    CurEngine.Parser.ParseContinueImplementation;
+  except
+    on E: Exception do
+      HandleError(CurEngine,E);
+  end;
+end;
+
 function TCustomTestResolver.GetModuleCount: integer;
 begin
   Result:=FModules.Count;
@@ -4811,6 +4859,27 @@ begin
   CheckResolverException('identifier not found "unit2"',nIdentifierNotFound);
 end;
 
+procedure TTestResolver.TestUnit_Intf1Impl2Intf1;
+begin
+  AddModuleWithIntfImplSrc('unit1.pp',
+    LinesToStr([
+    'type number = longint;']),
+    LinesToStr([
+    'uses afile;',
+    'procedure DoIt;',
+    'begin',
+    '  i:=3;',
+    'end;']));
+
+  StartUnit(true);
+  Add([
+  'interface',
+  'uses unit1;',
+  'var i: number;',
+  'implementation']);
+  ParseUnit;
+end;
+
 procedure TTestResolver.TestProcParam;
 begin
   StartProgram(false);