fcl-passrc: resolver specialize name with params

git-svn-id: trunk@46786 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1791,7 +1791,7 @@ type
     function GetTVarRec(El: TPasArrayType): TPasRecordType; virtual;
     function FindDefaultConstructor(aClass: TPasClassType): TPasConstructor; virtual;
     function GetTypeInfoParamType(Param: TPasExpr;
-      out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual;
+      out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual; // returns type of param in typeinfo(param)
   protected
     // constant evaluation
     fExprEvaluator: TResExprEvaluator;
@@ -1840,8 +1840,7 @@ type
       GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
     function CreateSpecializedItem(El: TPasElement; GenericEl: TPasElement;
       const ParamsResolved: TPasTypeArray): TPRSpecializedItem; virtual;
-    function CreateSpecializedTypeName(SpecializedItems: TObjectList;
+    function CreateSpecializedTypeName(Item: TPRSpecializedItem): string; virtual;
-      Item: TPRSpecializedItem): string; virtual;
     procedure InitSpecializeScopes(El: TPasElement; out State: TScopeStashState); virtual;
     procedure RestoreSpecializeScopes(const State: TScopeStashState); virtual;
     procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); virtual;
@@ -2473,8 +2472,11 @@ function ProcNeedsBody(Proc: TPasProcedure): boolean;
 function ProcHasGroupOverload(Proc: TPasProcedure): boolean;
 procedure ClearHelperList(var List: TPRHelperEntryArray);
 function ChompDottedIdentifier(const Identifier: string): string;
-function FirstDottedIdentifier(const Identifier: string): string;
+function FirstDottedIdentifier(const Identifier: string): string; // without <>
+function LastDottedIdentifier(const Identifier: string): string; // without <>
 function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
+function GetFirstDotPos(const Identifier: string): integer;
+function GetLastDotPos(const Identifier: string): integer;
 {$IF FPC_FULLVERSION<30101}
 function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
 {$ENDIF}
@@ -2943,14 +2945,18 @@ end;
 
 function ChompDottedIdentifier(const Identifier: string): string;
 var
-  p: Integer;
+  p, Lvl: Integer;
 begin
   Result:=Identifier;
   p:=length(Identifier);
+  Lvl:=0;
   while (p>0) do
     begin
-    if Identifier[p]='.' then
+    case Identifier[p] of
-      break;
+    '.': if Lvl=0 then break;
+    '>': inc(Lvl);
+    '<': dec(Lvl);
+    end;
     dec(p);
     end;
   Result:=LeftStr(Identifier,p-1);
@@ -2958,13 +2964,41 @@ end;
 
 function FirstDottedIdentifier(const Identifier: string): string;
 var
-  p: SizeInt;
+  p, l: SizeInt;
 begin
-  p:=Pos('.',Identifier);
+  p:=1;
-  if p<1 then
+  l:=length(Identifier);
-    Result:=Identifier
+  repeat
-  else
+    if p>l then
-    Result:=LeftStr(Identifier,p-1);
+      exit(Identifier)
+    else if Identifier[p] in ['<','.'] then
+      exit(LeftStr(Identifier,p-1))
+    else
+      inc(p);
+  until false;
+end;
+
+function LastDottedIdentifier(const Identifier: string): string;
+var
+  p, Lvl, EndP: Integer;
+begin
+  p:=length(Identifier);
+  EndP:=p;
+  Lvl:=0;
+  while (p>0) do
+    begin
+    case Identifier[p] of
+    '.': if Lvl=0 then break;
+    '>': inc(Lvl);
+    '<':
+      begin
+      dec(Lvl);
+      EndP:=p-1;
+      end;
+    end;
+    dec(p);
+    end;
+  Result:=copy(Identifier,p+1,EndP-p);
 end;
 
 function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
@@ -2978,6 +3012,43 @@ begin
   Result:=(length(Identifier)=l) or (Identifier[l+1]='.');
 end;
 
+function GetFirstDotPos(const Identifier: string): integer;
+var
+  l: SizeInt;
+  Lvl: Integer;
+begin
+  Result:=1;
+  l:=length(Identifier);
+  Lvl:=0;
+  repeat
+    if Result>l then
+      exit(-1);
+    case Identifier[Result] of
+    '.': if Lvl=0 then exit;
+    '<': inc(Lvl);
+    '>': dec(Lvl);
+    end;
+    inc(Result);
+  until false;
+end;
+
+function GetLastDotPos(const Identifier: string): integer;
+var
+  Lvl: Integer;
+begin
+  Result:=length(Identifier);
+  Lvl:=0;
+  while (Result>0) do
+    begin
+    case Identifier[Result] of
+    '.': if Lvl=0 then exit;
+    '>': inc(Lvl);
+    '<': dec(Lvl);
+    end;
+    dec(Result);
+    end;
+end;
+
 function DotExprToName(Expr: TPasExpr): string;
 var
   C: TClass;
@@ -6931,7 +7002,7 @@ begin
         RaiseMsg(20181231150404,nXCannotHaveParameters,sXCannotHaveParameters,[GetElementTypeName(Proc)],Proc);
       end;
 
-    HasDots:=Pos('.',ProcName)>1;
+    HasDots:=GetFirstDotPos(ProcName)>0;
 
     if Proc.Parent is TPasClassType then
       begin
@@ -7309,7 +7380,6 @@ var
   DeclProc: TPasProcedure;
   ClassOrRecScope: TPasClassOrRecordScope;
   SelfArg: TPasArgument;
-  p: Integer;
   SelfType, LoSelfType: TPasType;
   LastNamePart: TProcedureNamePart;
 begin
@@ -7336,11 +7406,7 @@ begin
   else
     begin
     // remove path from ProcName
-    repeat
+    ProcName:=LastDottedIdentifier(ProcName);
-      p:=Pos('.',ProcName);
-      if p<1 then break;
-      Delete(ProcName,1,p);
-    until false;
     end;
 
   if ImplProcScope.DeclarationProc=nil then
@@ -12412,7 +12478,7 @@ begin
 
   // Note: El.ProcType is nil !  It is parsed later.
 
-  HasDot:=Pos('.',ProcName)>1;
+  HasDot:=GetFirstDotPos(ProcName)>1;
   if (TypeParams<>nil) then
     if HasDot<>(TypeParams.Count>1) then
       RaiseNotYetImplemented(20190818093923,El);
@@ -12485,14 +12551,14 @@ begin
       Level:=0;
       repeat
         inc(Level);
-        p:=Pos('.',ProcName);
+        p:=GetFirstDotPos(ProcName);
         if p<1 then
           begin
           if ClassOrRecType=nil then
             RaiseInternalError(20161013170829);
           break;
           end;
-        aClassName:=LeftStr(ProcName,p-1);
+        aClassName:=FirstDottedIdentifier(ProcName);
         Delete(ProcName,1,p);
         TypeParamCount:=0;
         if TypeParams<>nil then
@@ -16503,7 +16569,7 @@ var
   begin
     // insert in front of currently parsed elements
     // beware: specializing an element can create other specialized elements
-    // add behind last specialized element of this GenericEl
+    // add behind last finished specialized element of this GenericEl
     // for example: A = class(B<C<D>>)
     // =>
     //  D
@@ -16548,15 +16614,6 @@ var
       else
         break;
       end;
-
-    //if i<0 then
-    //  begin
-    //  {$IF defined(VerbosePasResolver) or defined(VerbosePas2JS)}
-    //  writeln('InsertBehind Generic=',GetObjName(GenericEl),' Last=',GetObjName(Last));
-    //  //for i:=0 to List.Count-1 do writeln('  ',GetObjName(TObject(List[i])));
-    //  {$ENDIF}
-    //  i:=List.Count-1;
-    //  end;
     List.Insert(i+1,NewEl);
   end;
 
@@ -16571,8 +16628,6 @@ var
   ProcItem: TPRSpecializedProcItem;
 begin
   Result:=nil;
-  if Pos('$G',GenericEl.Name)>0 then
-    RaiseNotYetImplemented(20190813003729,El);
 
   SrcModule:=GenericEl.GetModule;
   SrcModuleScope:=SrcModule.CustomData as TPasModuleScope;
@@ -16602,7 +16657,7 @@ begin
   Result.Params:=ParamsResolved;
   Result.Index:=SpecializedItems.Count;
   SpecializedItems.Add(Result);
-  NewName:=CreateSpecializedTypeName(SpecializedItems,Result);
+  NewName:=CreateSpecializedTypeName(Result);
   NewClass:=TPTreeElement(GenericEl.ClassType);
   NewParent:=GenericEl.Parent;
   NewEl:=TPasElement(NewClass.Create(NewName,NewParent));
@@ -16631,10 +16686,66 @@ begin
     SpecializeGenericImpl(Result);
 end;
 
-function TPasResolver.CreateSpecializedTypeName(SpecializedItems: TObjectList;
+function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): string;
-  Item: TPRSpecializedItem): string;
+
+  function GetTypeName(aType: TPasType): string; forward;
+
+  function GetSpecParams(Item: TPRSpecializedItem): string;
+  var
+    i: Integer;
+  begin
+    Result:='<';
+    for i:=0 to length(Item.Params)-1 do
+      begin
+      if i>0 then Result:=Result+',';
+      Result:=Result+GetTypeName(Item.Params[i]);
+      end;
+    Result:=Result+'>';
+  end;
+
+  function GetTypeName(aType: TPasType): string;
+  var
+    Arr: TPasArrayType;
+    ElType: TPasType;
+    ChildItem: TPRSpecializedItem;
+  begin
+    if aType.Name='' then
+      begin
+      if aType is TPasArrayType then
+        begin
+        // e.g. TBird<array of word>
+        Result:='array of ';
+        Arr:=TPasArrayType(aType);
+        if length(Arr.Ranges)>0 then
+          RaiseNotYetImplemented(20200905173026,Item.FirstSpecialize);
+        ElType:=ResolveAliasType(Arr.ElType,false);
+        if ElType is TPasArrayType then
+          RaiseNotYetImplemented(20200905173159,Arr,'multidimensional anonymous array as generic param');
+        Result:=Result+GetTypeName(ElType);
+        end
+      else
+        RaiseNotYetImplemented(20200905173241,aType);
+      end
+    else
+      begin
+      if aType.Parent is TPasType then
+        Result:=GetTypeName(TPasType(aType.Parent))
+      else if aType is TPasUnresolvedSymbolRef then
+        Result:='System'
+      else
+        Result:=aType.GetModule.Name;
+      Result:=Result+'.'+aType.Name;
+      if aType.CustomData is TPasGenericScope then
+        begin
+        ChildItem:=TPasGenericScope(aType.CustomData).SpecializedFromItem;
+        if ChildItem<>nil then
+          Result:=Result+GetSpecParams(ChildItem);
+        end;
+      end;
+  end;
+
 begin
-  Result:=Item.GenericEl.Name+'$G'+IntToStr(SpecializedItems.Count);
+  Result:=Item.GenericEl.Name+GetSpecParams(Item);
 end;
 
 procedure TPasResolver.InitSpecializeScopes(El: TPasElement; out
@@ -17063,12 +17174,11 @@ begin
     if SpecClassOrRecScope=nil then
       RaiseNotYetImplemented(20190921221839,SpecDeclProc);
     NewImplProcName:=GenImplProc.Name;
-    p:=length(NewImplProcName);
+    LastDotP:=GetLastDotPos(NewImplProcName);
-    while (p>0) and (NewImplProcName[p]<>'.') do dec(p);
+    if LastDotP<1 then
-    if p=0 then
       RaiseNotYetImplemented(20190921221730,GenImplProc);
     // has classname -> replace generic classname with specialized classname
-    LastDotP:=p;
+    p:=LastDotP;
     while (p>1) and (NewImplProcName[p-1]<>'.') do dec(p);
     OldClassname:=copy(NewImplProcName,p,LastDotP-p);
     GenClassOrRec:=GenDeclProc.Parent as TPasMembersType;
@@ -17080,8 +17190,7 @@ begin
     begin
     // use classname of GenImplProc and name of SpecDeclProc
     OldClassname:=GenImplProc.Name;
-    p:=length(OldClassname);
+    p:=GetLastDotPos(OldClassname);
-    while (p>0) and (OldClassname[p]<>'.') do dec(p);
     if p>0 then
       NewImplProcName:=LeftStr(OldClassname,p)+SpecDeclProc.Name
     else
@@ -25384,12 +25493,14 @@ function TPasResolver.GetTypeDescription(aType: TPasType; AddPath: boolean): str
       begin
       i:=GetTypeParameterCount(TPasGenericType(aType));
       if i>0 then
+        // generic, not specialized
         Result:=Result+GetGenericParamCommas(GetTypeParameterCount(TPasGenericType(aType)))
       else if aType.CustomData is TPasGenericScope then
         begin
         GenScope:=TPasGenericScope(aType.CustomData);
-        if GenScope.SpecializedFromItem<>nil then
+        if (GenScope.SpecializedFromItem<>nil) and IsValidIdent(aType.Name) then
           begin
+          // specialized without params in name -> append params
           Params:=GenScope.SpecializedFromItem.Params;
           Result:=Result+'<';
           for i:=0 to length(Params)-1 do
@@ -29527,6 +29638,7 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer;
 // check if Src is equal or descends from Dest
 // Generics: TBird<T> is both directions a TBird<word>
 //       and TBird<TMap<T>> is both directions a TBird<TMap<word>>
+//       but a TBird<word> is not a TBird<char>
 
   function CheckSpecialized(SrcScope, DestScope: TPasGenericScope): boolean;
   var

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -5,7 +5,8 @@ unit tcresolvegenerics;
 interface
 
 uses
-  Classes, SysUtils, testregistry, tcresolver, PasResolveEval, PParser;
+  Classes, SysUtils, testregistry, tcresolver, PasResolveEval, PParser,
+  PScanner;
 
 type
 
@@ -91,7 +92,8 @@ type
     procedure TestGen_Class_MemberTypeConstructor;
     procedure TestGen_Class_AliasMemberType;
     procedure TestGen_Class_AccessGenericMemberTypeFail;
-    procedure TestGen_Class_ReferenceTo; // ToDo
+    procedure TestGen_Class_ReferenceTo;
+    procedure TestGen_Class_TwoSpecsAreNotRelatedWarn;
     procedure TestGen_Class_List;
     // ToDo: different modeswitches at parse time and specialize time
 
@@ -1568,6 +1570,26 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_Class_TwoSpecsAreNotRelatedWarn;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TBird<T> = class F: T; end;',
+  '  TBirdWord = TBird<Word>;',
+  '  TBirdChar = TBird<Char>;',
+  'var',
+  '  w: TBirdWord;',
+  '  c: TBirdChar;',
+  'begin',
+  '  w:=TBirdWord(c);',
+  '']);
+  ParseProgram;
+  CheckResolverHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird<System.Char>" and "TBird<System.Word>" are not related');
+end;
+
 procedure TTestResolveGenerics.TestGen_Class_List;
 begin
   StartProgram(false);