* Patch from Mattias Gaertner to fix use of Forward defined Classes

git-svn-id: trunk@35697 -

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1072,6 +1072,7 @@ var
   UsePublished, FirstTime: Boolean;
   ProcScope: TPasProcedureScope;
   ClassScope: TPasClassScope;
+  Ref: TResolvedReference;
 begin
   FirstTime:=true;
   case Mode of
@@ -1092,6 +1093,13 @@ begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
   {$ENDIF}
+  if El.IsForward then
+    begin
+    Ref:=El.CustomData as TResolvedReference;
+    UseClassType(Ref.Declaration as TPasClassType,Mode);
+    exit;
+    end;
+
   ClassScope:=El.CustomData as TPasClassScope;
   if FirstTime then
     begin
@@ -1426,6 +1434,7 @@ begin
     end
   else if C=TPasClassType then
     begin
+    if TPasClassType(El).IsForward then exit;
     for i:=0 to TPasClassType(El).Members.Count-1 do
       begin
       Member:=TPasElement(TPasClassType(El).Members[i]);

packages/fcl-passrc/tests/tcresolver.pas

@@ -315,6 +315,7 @@ type
     Procedure TestClassDefaultInheritance;
     Procedure TestClassTripleInheritance;
     Procedure TestClassForward;
+    Procedure TestClassForwardAsAncestorFail;
     Procedure TestClassForwardNotResolved;
     Procedure TestClass_Method;
     Procedure TestClass_MethodWithoutClassFail;
@@ -4223,9 +4224,22 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClassForwardAsAncestorFail;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class;');
+  Add('  TBird = class end;');
+  Add('  TObject = class');
+  Add('  end;');
+  Add('var');
+  Add('  v: TBird;');
+  Add('begin');
+  CheckResolverException('Can''t use forward declaration "TObject" as ancestor',
+    nCantUseForwardDeclarationAsAncestor);
+end;
+
 procedure TTestResolver.TestClassForwardNotResolved;
-var
-  ErrorNo: Integer;
 begin
   StartProgram(false);
   Add('type');
@@ -4235,14 +4249,8 @@ begin
   Add('var');
   Add('  v: TClassB;');
   Add('begin');
-  ErrorNo:=0;
-  try
-    ParseModule;
-  except
-    on E: EPasResolve do
-      ErrorNo:=E.MsgNumber;
-  end;
-  AssertEquals('Forward class not resolved raises correct error',nForwardTypeNotResolved,ErrorNo);
+  CheckResolverException('Forward class not resolved raises correct error',
+    nForwardTypeNotResolved);
 end;
 
 procedure TTestResolver.TestClass_Method;

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -65,6 +65,7 @@ type
     procedure TestM_ProcedureType;
     procedure TestM_Params;
     procedure TestM_Class;
+    procedure TestM_ClassForward;
     procedure TestM_Class_Property;
     procedure TestM_Class_PropertyOverride;
     procedure TestM_Class_MethodOverride;
@@ -653,6 +654,26 @@ begin
   AnalyzeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestM_ClassForward;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  {#integer_notused}integer = longint;');
+  Add('  {#TObject_used}TObject = class end;');
+  Add('  TFelidae = class;');
+  Add('  {#TCheetah_used}TCheetah = class');
+  Add('  public');
+  Add('    {#i_notused}i: integer;');
+  Add('    {#f_used}f: TFelidae;');
+  Add('  end;');
+  Add('  {TFelidae_used}TFelidae = class');
+  Add('  end;');
+  Add('var {#c_used}c: TCheetah;');
+  Add('begin');
+  Add('  c.f:=nil;');
+  AnalyzeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestM_Class_Property;
 begin
   StartProgram(false);

packages/pastojs/src/fppas2js.pp

@@ -1139,6 +1139,7 @@ function TPas2JSResolver.GetOverloadIndex(Identifier: TPasIdentifier;
 var
   El: TPasElement;
   ProcScope: TPasProcedureScope;
+  C: TClass;
 begin
   Result:=0;
   // iterate from last added to first added
@@ -1151,7 +1152,13 @@ begin
       Result:=0;
       continue;
       end;
-    if El is TPasProcedure then
+    C:=El.ClassType;
+    if C=TPasClassType then
+      begin
+      if TPasClassType(El).IsForward then
+        continue;
+      end
+    else if C.InheritsFrom(TPasProcedure) then
       begin
       if TPasProcedure(El).IsOverride then
         continue;
@@ -1239,6 +1246,9 @@ begin
     RenameSubOverloads(aSection.Declarations);
     end;
   PopOverloadScope;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPas2JSResolver.RenameOverloadsInSection END ',GetObjName(aSection));
+  {$ENDIF}
 end;
 
 procedure TPas2JSResolver.RenameOverloads(DeclEl: TPasElement;
@@ -1275,6 +1285,9 @@ begin
           ProcScope.ImplProc.Name:=Proc.Name;
       end;
     end;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPas2JSResolver.RenameOverloads END ',GetObjName(DeclEl));
+  {$ENDIF}
 end;
 
 procedure TPas2JSResolver.RenameSubOverloads(Declarations: TFPList);
@@ -1296,7 +1309,9 @@ begin
       Proc:=TPasProcedure(El);
       if Proc.IsAbstract or Proc.IsExternal then continue;
       ProcScope:=Proc.CustomData as TPasProcedureScope;
-      //writeln('TPas2JSResolver.RenameSubOverloads Proc=',Proc.Name,' DeclarationProc=',GetObjName(ProcScope.DeclarationProc),' ImplProc=',GetObjName(ProcScope.ImplProc),' ClassScope=',GetObjName(ProcScope.ClassScope));
+      {$IFDEF VerbosePas2JS}
+      writeln('TPas2JSResolver.RenameSubOverloads Proc=',Proc.Name,' DeclarationProc=',GetObjName(ProcScope.DeclarationProc),' ImplProc=',GetObjName(ProcScope.ImplProc),' ClassScope=',GetObjName(ProcScope.ClassScope));
+      {$ENDIF}
       if ProcScope.DeclarationProc<>nil then
         // proc implementation (not forward) -> skip
         continue;
@@ -1318,6 +1333,7 @@ begin
     else if C=TPasClassType then
       begin
       ClassEl:=TPasClassType(El);
+      if ClassEl.IsForward then continue;
       ClassScope:=El.CustomData as TPas2JSClassScope;
       OldScopeCount:=FOverloadScopes.Count;
 
@@ -1341,6 +1357,9 @@ begin
     else if C.InheritsFrom(TPasVariable) and (El.Parent.ClassType=TPasClassType) then
       RenameOverload(El);
     end;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPas2JSResolver.RenameSubOverloads END');
+  {$ENDIF}
 end;
 
 procedure TPas2JSResolver.PushOverloadScope(Scope: TPasIdentifierScope);

packages/pastojs/tests/tcmodules.pas

@@ -6544,10 +6544,12 @@ procedure TTestModule.TestClass_OverloadsAncestor;
 begin
   StartProgram(false);
   Add('type');
+  Add('  TObject = class;');
   Add('  TObject = class');
   Add('    procedure DoIt(vA: longint);');
   Add('    procedure DoIt(vA, vB: longint);');
   Add('  end;');
+  Add('  TCar = class;');
   Add('  TCar = class');
   Add('    procedure DoIt(vA: longint);');
   Add('    procedure DoIt(vA, vB: longint);');