fcl-passrc: resolver: objfpc refer to parent generic type without type params

git-svn-id: trunk@43204 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1823,6 +1823,7 @@ type
     procedure SpecializeVariable(GenEl, SpecEl: TPasVariable; Finish: boolean);
     procedure SpecializeConst(GenEl, SpecEl: TPasConst);
     procedure SpecializeProperty(GenEl, SpecEl: TPasProperty);
+    function SpecializeTypeRef(GenEl, SpecEl: TPasElement; GenTypeRef: TPasType): TPasType;
     procedure SpecializeElType(GenEl, SpecEl: TPasElement;
       GenElType: TPasType; var SpecElType: TPasType);
     procedure SpecializeElExpr(GenEl, SpecEl: TPasElement;
@@ -2181,7 +2182,8 @@ type
     function IsSameType(TypeA, TypeB: TPasType; ResolveAlias: TPRResolveAlias): boolean; // check if it is exactly the same
     function HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
     function IndexOfGenericParam(Params: TPasExprArray): integer;
-    procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt; ErrorEl: TPasElement);
+    procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
+      ErrorEl: TPasElement);
     function CheckCallProcCompatibility(ProcType: TPasProcedureType;
       Params: TParamsExpr; RaiseOnError: boolean;
       SetReferenceFlags: boolean = false): integer;
@@ -17059,25 +17061,44 @@ begin
   FinishProperty(SpecEl);
 end;
 
+function TPasResolver.SpecializeTypeRef(GenEl, SpecEl: TPasElement;
+  GenTypeRef: TPasType): TPasType;
+var
+  GenParent, SpecParent, Ref: TPasElement;
+begin
+  if GenTypeRef.Name='' then
+    RaiseNotYetImplemented(20190813213555,GenEl,GetObjPath(GenTypeRef));
+  if GenEl.HasParent(GenTypeRef) then
+    begin
+    GenParent:=GenEl.Parent;
+    SpecParent:=SpecEl.Parent;
+    while GenParent<>GenTypeRef do
+      begin
+      GenParent:=GenParent.Parent;
+      SpecParent:=SpecParent.Parent;
+      end;
+    Ref:=SpecParent;
+    end
+  else
+    Ref:=FindElement(GenTypeRef.Name);
+  if not (Ref is TPasType) then
+    RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
+  Result:=TPasType(Ref);
+end;
+
 procedure TPasResolver.SpecializeElType(GenEl, SpecEl: TPasElement;
   GenElType: TPasType; var SpecElType: TPasType);
 var
-  Ref: TPasElement;
   NewClass: TPTreeElement;
 begin
   if GenElType=nil then exit;
+  if SpecElType<>nil then
+    RaiseNotYetImplemented(20190812021617,GenEl);
   if (GenElType.Parent<>GenEl)
       or (GenElType.ClassType=TPasGenericTemplateType) then
     begin
     // reference
-    if GenElType.Name='' then
-      RaiseNotYetImplemented(20190813213555,GenEl,GetObjName(GenElType)+' Parent='+GetObjName(GenElType.Parent));
-    Ref:=FindElement(GenElType.Name);
-    if not (Ref is TPasType) then
-      RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
-    GenElType:=TPasType(Ref);
-    if SpecElType<>nil then
-      RaiseNotYetImplemented(20190812021617,GenEl);
+    GenElType:=SpecializeTypeRef(GenEl,SpecEl,GenElType);
     SpecElType:=GenElType;
     SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
     exit;
@@ -17153,9 +17174,7 @@ begin
       if not (GenListItem is TPasType) then
         RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
       // reference
-      Ref:=FindElement(GenListItem.Name);
-      if not (Ref is TPasType) then
-        RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
+      Ref:=SpecializeTypeRef(GenEl,SpecEl,TpasType(GenListItem));
       Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
       SpecList.Add(Ref);
       continue;
@@ -17193,9 +17212,7 @@ begin
       if not (GenListItem is TPasType) then
         RaiseNotYetImplemented(20190914102957,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
       // reference
-      Ref:=FindElement(GenListItem.Name);
-      if not (Ref is TPasType) then
-        RaiseNotYetImplemented(20190914103009,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
+      Ref:=SpecializeTypeRef(GenEl,SpecEl,TPasType(GenListItem));
       Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
       SpecList[i]:=Ref;
       continue;
@@ -27103,8 +27120,15 @@ begin
       end;
     if (TPasGenericType(aType).GenericTemplateTypes<>nil)
         and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
-          RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
+      begin
+      // ref to generic type without specialization
+      if not (msDelphi in CurrentParser.CurrentModeswitches)
+          and (ErrorEl.HasParent(aType)) then
+        // ObjFPC allows referring to parent without type params
+      else
+        RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
             [ErrorEl.ElementTypeName],ErrorEl);
+      end;
     end;
 end;
 

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -58,6 +58,8 @@ type
     // generic class
     procedure TestGen_Class;
     procedure TestGen_ClassDelphi;
+    procedure TestGen_ClassObjFPC;
+    procedure TestGen_ClassObjFPC_OverloadFail;
     procedure TestGen_ClassForward;
     procedure TestGen_ClassForwardConstraints;
     procedure TestGen_ClassForwardConstraintNameMismatch;
@@ -66,7 +68,7 @@ type
     procedure TestGen_ClassForward_Circle;
     procedure TestGen_Class_RedeclareInUnitImplFail;
     procedure TestGen_Class_AnotherInUnitImpl;
-    procedure TestGen_Class_Method;
+    procedure TestGen_Class_MethodObjFPC;
     procedure TestGen_Class_MethodOverride;
     procedure TestGen_Class_MethodDelphi;
     procedure TestGen_Class_MethodDelphiTypeParamMissing;
@@ -139,17 +141,20 @@ type
     procedure TestGenProc_TypeParamCntOverload;
     procedure TestGenProc_TypeParamCntOverloadNoParams;
     procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
-    procedure TestGenProc_Inference_NeedExplicitFail;
-    procedure TestGenProc_Inference_Overload;
-    procedure TestGenProc_Inference_OverloadForward;
-    procedure TestGenProc_Inference_Var_Overload;
-    //procedure TestGenProc_Inference_Widen;
-    procedure TestGenProc_Inference_DefaultValue;
-    procedure TestGenProc_Inference_DefaultValueMismatch;
-    procedure TestGenProc_Inference_ProcT;
-    procedure TestGenProc_Inference_Mismatch;
-    procedure TestGenProc_Inference_ArrayOfT;
-    // ToDo procedure TestGenProc_Inference_ProcType;
+    // ToDo: NestedResultAssign
+
+    // generic function infer types
+    procedure TestGenProc_Infer_NeedExplicitFail;
+    procedure TestGenProc_Infer_Overload;
+    procedure TestGenProc_Infer_OverloadForward;
+    procedure TestGenProc_Infer_Var_Overload;
+    //procedure TestGenProc_Infer_Widen;
+    procedure TestGenProc_Infer_DefaultValue;
+    procedure TestGenProc_Infer_DefaultValueMismatch;
+    procedure TestGenProc_Infer_ProcT;
+    procedure TestGenProc_Infer_Mismatch;
+    procedure TestGenProc_Infer_ArrayOfT;
+    // ToDo procedure TestGenProc_Infer_ProcType;
 
     // generic methods
     procedure TestGenMethod_VirtualFail;
@@ -751,6 +756,40 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_ClassObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    v: TBird;',
+  '  end;',
+  'var',
+  '  b: specialize TBird<word>;',
+  'begin',
+  '  b.v:=b;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGen_ClassObjFPC_OverloadFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  TBird = word;',
+  '  generic TBird<T> = class',
+  '    v: T;',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('Duplicate identifier "TBird" at afile.pp(5,8)',nDuplicateIdentifier);
+end;
+
 procedure TTestResolveGenerics.TestGen_ClassForward;
 begin
   StartProgram(false);
@@ -919,7 +958,7 @@ begin
   ParseUnit;
 end;
 
-procedure TTestResolveGenerics.TestGen_Class_Method;
+procedure TTestResolveGenerics.TestGen_Class_MethodObjFPC;
 begin
   StartProgram(false);
   Add([
@@ -2061,7 +2100,7 @@ begin
   CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_NeedExplicitFail;
+procedure TTestResolveGenerics.TestGenProc_Infer_NeedExplicitFail;
 begin
   StartProgram(false);
   Add([
@@ -2076,7 +2115,7 @@ begin
     nCouldNotInferTypeArgXForMethodY);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Overload;
+procedure TTestResolveGenerics.TestGenProc_Infer_Overload;
 begin
   StartProgram(false);
   Add([
@@ -2098,7 +2137,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_OverloadForward;
+procedure TTestResolveGenerics.TestGenProc_Infer_OverloadForward;
 begin
   StartProgram(false);
   Add([
@@ -2126,7 +2165,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Var_Overload;
+procedure TTestResolveGenerics.TestGenProc_Infer_Var_Overload;
 begin
   StartProgram(false);
   Add([
@@ -2152,7 +2191,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValue;
+procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValue;
 begin
   StartProgram(false);
   Add([
@@ -2169,7 +2208,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValueMismatch;
+procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValueMismatch;
 begin
   StartProgram(false);
   Add([
@@ -2185,7 +2224,7 @@ begin
                          nIncompatibleTypesGotExpected);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_ProcT;
+procedure TTestResolveGenerics.TestGenProc_Infer_ProcT;
 begin
   StartProgram(false);
   Add([
@@ -2207,7 +2246,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Mismatch;
+procedure TTestResolveGenerics.TestGenProc_Infer_Mismatch;
 begin
   StartProgram(false);
   Add([
@@ -2222,7 +2261,7 @@ begin
     nInferredTypeXFromDiffArgsMismatchFromMethodY);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_ArrayOfT;
+procedure TTestResolveGenerics.TestGenProc_Infer_ArrayOfT;
 begin
   StartProgram(false);
   Add([