fcl-passrc: store generic procedure templates

git-svn-id: trunk@42451 -

packages/fcl-passrc/src/pastree.pp

@@ -1038,6 +1038,14 @@ type
                         pmNoReturn, pmFar, pmFinal);
   TProcedureModifiers = Set of TProcedureModifier;
   TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
+
+  { TProcedureNamePart }
+
+  TProcedureNamePart = record
+    Name: string;
+    Templates: TFPList; // optional list of TPasGenericTemplateType, can nil!
+  end;
+  TProcedureNameParts = array of TProcedureNamePart;
                         
   TProcedureBody = class;
 
@@ -1067,6 +1075,7 @@ type
     AliasName : String;
     ProcType : TPasProcedureType;
     Body : TProcedureBody;
+    NameParts: TProcedureNameParts; // only used for generic functions
     Procedure AddModifier(AModifier : TProcedureModifier);
     Function IsVirtual : Boolean;
     Function IsDynamic : Boolean;
@@ -1080,6 +1089,7 @@ type
     Function IsStatic : Boolean;
     Function IsForward: Boolean;
     Function GetProcTypeEnum: TProcType; virtual;
+    procedure SetNameParts(var Parts: TProcedureNameParts);
     Property Modifiers : TProcedureModifiers Read FModifiers Write FModifiers;
     Property CallingConvention : TCallingConvention Read GetCallingConvention Write SetCallingConvention;
     Property MessageName : String Read FMessageName Write FMessageName;
@@ -1724,12 +1734,15 @@ const
      = ('cvar', 'external', 'public', 'export', 'class', 'static');
 
 procedure ReleaseAndNil(var El: TPasElement {$IFDEF CheckPasTreeRefCount}; const Id: string{$ENDIF}); overload;
+function GenericTemplateTypesAsString(List: TFPList): string;
 
 {$IFDEF HasPTDumpStack}
 procedure PTDumpStack;
 function GetPTDumpStack: string;
 {$ENDIF}
 
+procedure ReleaseProcNameParts(var NameParts: TProcedureNameParts);
+
 implementation
 
 uses SysUtils;
@@ -1742,6 +1755,54 @@ begin
   El:=nil;
 end;
 
+function GenericTemplateTypesAsString(List: TFPList): string;
+var
+  i, j: Integer;
+  T: TPasGenericTemplateType;
+begin
+  Result:='';
+  for i:=0 to List.Count-1 do
+    begin
+    if i>0 then
+      Result:=Result+',';
+    T:=TPasGenericTemplateType(List[i]);
+    Result:=Result+T.Name;
+    if length(T.Constraints)>0 then
+      begin
+      Result:=Result+':';
+      for j:=0 to length(T.Constraints)-1 do
+        begin
+        if j>0 then
+          Result:=Result+',';
+        Result:=Result+T.GetDeclaration(false);
+        end;
+      end;
+    end;
+  Result:='<'+Result+'>';
+end;
+
+procedure ReleaseProcNameParts(var NameParts: TProcedureNameParts);
+var
+  El: TPasElement;
+  i, j: Integer;
+begin
+  for i := 0 to length(NameParts)-1 do
+    begin
+    with NameParts[i] do
+      if Templates<>nil then
+        begin
+        for j:=0 to Templates.Count-1 do
+          begin
+          El:=TPasGenericTemplateType(Templates[j]);
+          El.Parent:=nil;
+          El.Release{$IFDEF CheckPasTreeRefCount}('TPasProcedure.NameParts'){$ENDIF};
+          end;
+        Templates.Free;
+        end;
+    end;
+  NameParts:=nil;
+end;
+
 Function IndentStrings(S : TStrings; indent : Integer) : string;
 Var
   I,CurrLen,CurrPos : Integer;
@@ -3496,6 +3557,7 @@ begin
   ReleaseAndNil(TPasElement(MessageExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.MessageExpr'{$ENDIF});
   ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
   ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
+  ReleaseProcNameParts(NameParts);
   inherited Destroy;
 end;
 
@@ -4164,7 +4226,7 @@ var
 begin
   inherited ForEachCall(aMethodCall, Arg);
   for i:=0 to GenericTemplateTypes.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),true);
+    ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
   for i:=0 to Members.Count-1 do
     ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
 end;
@@ -4256,7 +4318,12 @@ begin
       else
         Temp:='packed '+Temp;
     If Full and (Name<>'') then
-      Temp:=Name+' = '+Temp;
+      begin
+      if GenericTemplateTypes.Count>0 then
+        Temp:=Name+GenericTemplateTypesAsString(GenericTemplateTypes)+' = '+Temp
+      else
+        Temp:=Name+' = '+Temp;
+      end;
     S.Add(Temp);
     GetMembers(S);
     S.Add('end');
@@ -4562,8 +4629,15 @@ end;
 
 procedure TPasProcedure.ForEachCall(const aMethodCall: TOnForEachPasElement;
   const Arg: Pointer);
+var
+  i, j: Integer;
 begin
   inherited ForEachCall(aMethodCall, Arg);
+  for i:=0 to length(NameParts)-1 do
+    with NameParts[i] do
+      if Templates<>nil then
+        for j:=0 to Templates.Count-1 do
+          ForEachChildCall(aMethodCall,Arg,TPasElement(Templates[i]),false);
   ForEachChildCall(aMethodCall,Arg,ProcType,false);
   ForEachChildCall(aMethodCall,Arg,PublicName,false);
   ForEachChildCall(aMethodCall,Arg,LibraryExpr,false);
@@ -4573,7 +4647,6 @@ begin
 end;
 
 procedure TPasProcedure.AddModifier(AModifier: TProcedureModifier);
-
 begin
   Include(FModifiers,AModifier);
 end;
@@ -4639,17 +4712,52 @@ begin
   Result:=ptProcedure;
 end;
 
+procedure TPasProcedure.SetNameParts(var Parts: TProcedureNameParts);
+var
+  i, j: Integer;
+  El: TPasElement;
+begin
+  if length(NameParts)>0 then
+    ReleaseProcNameParts(NameParts);
+  NameParts:=Parts;
+  Parts:=nil;
+  for i:=0 to length(NameParts)-1 do
+    with NameParts[i] do
+      if Templates<>nil then
+        for j:=0 to Templates.Count-1 do
+          begin
+          El:=TPasElement(Templates[j]);
+          El.Parent:=Self;
+          end;
+end;
+
 function TPasProcedure.GetDeclaration(full: Boolean): string;
 Var
   S : TStringList;
   T: String;
+  i: Integer;
 begin
   S:=TStringList.Create;
   try
     If Full then
       begin
       T:=TypeName;
-      if Name<>'' then
+      if length(NameParts)>0 then
+        begin
+        T:=T+' ';
+        for i:=0 to length(NameParts)-1 do
+          begin
+          if i>0 then
+            T:=T+'.';
+          with NameParts[i] do
+            begin
+            T:=T+Name;
+            if Templates<>nil then
+              T:=T+GenericTemplateTypesAsString(Templates);
+            end;
+          end;
+        end
+      else if Name<>'' then
         T:=T+' '+Name;
       S.Add(T);
       end;

packages/fcl-passrc/src/pparser.pp

@@ -6318,42 +6318,86 @@ end;
 function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement;
   ProcType: TProcType; MustBeGeneric: boolean; AVisibility: TPasMemberVisibility
   ): TPasProcedure;
+var
+  NameParts: TProcedureNameParts;
 
   function ExpectProcName: string;
-
+  { Simple procedure:
+      Name
+    Method implementation of non generic class:
+      aClass.SubClass.Name
+    ObjFPC generic procedure or method declaration:
+      MustBeGeneric=true, Name<Templates>
+    Delphi generic Method Declaration:
+      MustBeGeneric=false, Name<Templates>
+    ObjFPC Method implementation of generic class:
+      aClass.SubClass.Name
+    Delphi Method implementation of generic class:
+      aClass<Templates>.SubClass<Templates>.Name
+      aClass.SubClass<Templates>.Name<Templates>
+  }
   Var
     L : TFPList;
-    I : Integer;
-
+    I , Cnt, p: Integer;
+    CurName: String;
   begin
     Result:=ExpectIdentifier;
-    //writeln('ExpectProcName ',Parent.Classname);
-    if Parent is TImplementationSection then
-      begin
+    Cnt:=1;
+    repeat
       NextToken;
-      repeat
-        if CurToken=tkDot then
-          Result:=Result+'.'+ExpectIdentifier
-        else if CurToken=tkLessThan then
+      if CurToken=tkDot then
+        begin
+          if Parent is TImplementationSection then
+            begin
+            inc(Cnt);
+            CurName:=ExpectIdentifier;
+            Result:=Result+'.'+CurName;
+            if length(NameParts)>0 then
+              begin
+              SetLength(NameParts,Cnt);
+              NameParts[Cnt-1].Name:=CurName;
+              end;
+            end
+          else
+            ParseExcSyntaxError;
+        end
+      else if CurToken=tkLessThan then
+        begin
+        if (not MustBeGeneric) and not (msDelphi in CurrentModeswitches) then
+          ParseExc(nParserGenericFunctionNeedsGenericKeyword,SParserGenericFunctionNeedsGenericKeyword);
+        // generic templates
+        if length(NameParts)=0 then
           begin
-          if (not MustBeGeneric) and not (msDelphi in CurrentModeswitches) then
-            ParseExc(nParserGenericFunctionNeedsGenericKeyword,SParserGenericFunctionNeedsGenericKeyword);
-          UnGetToken;
-          L:=TFPList.Create;
-          Try
-            ReadGenericArguments(L,Parent);
-          finally
-            For I:=0 to L.Count-1 do
-              TPasElement(L[i]).Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
-            L.Free;
-          end;
+          // initialize NameParts
+          SetLength(NameParts,Cnt);
+          i:=0;
+          CurName:=Result;
+          repeat
+            p:=Pos('.',CurName);
+            if p>0 then
+              begin
+              NameParts[i].Name:=LeftStr(CurName,p-1);
+              System.Delete(CurName,1,p);
+              end
+            else
+              begin
+              NameParts[i].Name:=CurName;
+              break;
+              end;
+            inc(i);
+          until false;
           end
-        else
-          break;
-        NextToken;
-      until false;
-      UngetToken;
-      end;
+        else if NameParts[Cnt-1].Templates<>nil then
+          ParseExcSyntaxError;
+        UnGetToken;
+        L:=TFPList.Create;
+        NameParts[Cnt-1].Templates:=L;
+        ReadGenericArguments(L,Parent);
+        end
+      else
+        break;
+    until false;
+    UngetToken;
   end;
 
 var
@@ -6362,36 +6406,41 @@ var
   Ot : TOperatorType;
   IsTokenBased , ok: Boolean;
 begin
-  case ProcType of
-  ptOperator,ptClassOperator:
-    begin
-    if MustBeGeneric then
-      ParseExcTokenError('procedure');
-    NextToken;
-    IsTokenBased:=CurToken<>tkIdentifier;
-    if IsTokenBased then
-      OT:=TPasOperator.TokenToOperatorType(CurTokenText)
-    else
-      OT:=TPasOperator.NameToOperatorType(CurTokenString);
-    if (ot=otUnknown) then
-      ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
-    Name:=OperatorNames[Ot];
-    end;
-  ptAnonymousProcedure,ptAnonymousFunction:
-    begin
-    Name:='';
-    if MustBeGeneric then
-      ParseExcTokenError('generic'); // inconsistency
-    end
-  else
-    Name:=ExpectProcName;
-  end;
-  PC:=GetProcedureClass(ProcType);
-  if Name<>'' then
-    Parent:=CheckIfOverLoaded(Parent,Name);
-  Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility));
+  NameParts:=nil;
+  Result:=nil;
   ok:=false;
   try
+    case ProcType of
+    ptOperator,ptClassOperator:
+      begin
+      if MustBeGeneric then
+        ParseExcTokenError('procedure');
+      NextToken;
+      IsTokenBased:=CurToken<>tkIdentifier;
+      if IsTokenBased then
+        OT:=TPasOperator.TokenToOperatorType(CurTokenText)
+      else
+        OT:=TPasOperator.NameToOperatorType(CurTokenString);
+      if (ot=otUnknown) then
+        ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
+      Name:=OperatorNames[Ot];
+      end;
+    ptAnonymousProcedure,ptAnonymousFunction:
+      begin
+      Name:='';
+      if MustBeGeneric then
+        ParseExcTokenError('generic'); // inconsistency
+      end
+    else
+      Name:=ExpectProcName;
+    end;
+    PC:=GetProcedureClass(ProcType);
+    if Name<>'' then
+      Parent:=CheckIfOverLoaded(Parent,Name);
+    Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility));
+    if NameParts<>nil then
+      Result.SetNameParts(NameParts);
+
     case ProcType of
     ptFunction, ptClassFunction, ptOperator, ptClassOperator, ptAnonymousFunction:
       begin
@@ -6428,7 +6477,9 @@ begin
         end;
     ok:=true;
   finally
-    if not ok then
+    if NameParts<>nil then;
+      ReleaseProcNameParts(NameParts);
+    if (not ok) and (Result<>nil) then
       Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
   end;
 end;

packages/fcl-passrc/tests/tcgenerics.pp

@@ -28,7 +28,8 @@ Type
     Procedure TestSpecializeNested;
     Procedure TestInlineSpecializeInStatement;
     Procedure TestInlineSpecializeInStatementDelphi;
-    Procedure TestGenericFunction;
+    Procedure TestGenericFunction_Program;
+    Procedure TestGenericFunction_Unit;
   end;
 
 implementation
@@ -200,11 +201,22 @@ begin
     Add('type');
     Add('  TTest<T> =  object');
     Add('    procedure foo(v:T);');
+    Add('    procedure bar<Y>(v:T);');
+    Add('  type');
+    Add('    TSub = class');
+    Add('      procedure DoIt<Y>(v:T);');
+    Add('    end;');
     Add('  end;');
     Add('implementation');
     Add('procedure TTest<T>.foo;');
     Add('begin');
     Add('end;');
+    Add('procedure TTest<T>.bar<Y>;');
+    Add('begin');
+    Add('end;');
+    Add('procedure TTest<T>.TSub.DoIt<Y>;');
+    Add('begin');
+    Add('end;');
     end;
   ParseModule;
 end;
@@ -258,7 +270,7 @@ begin
   ParseModule;
 end;
 
-procedure TTestGenerics.TestGenericFunction;
+procedure TTestGenerics.TestGenericFunction_Program;
 begin
   Add([
   'generic function IfThen<T>(val:boolean;const iftrue:T; const iffalse:T) :T; inline; overload;',
@@ -270,6 +282,22 @@ begin
   ParseModule;
 end;
 
+procedure TTestGenerics.TestGenericFunction_Unit;
+begin
+  Add([
+  'unit afile;',
+  'interface',
+  'generic function Get<T>(val: T) :T;',
+  'implementation',
+  'generic function Get<T>(val: T) :T;',
+  'begin',
+  'end;',
+  'initialization',
+  '  specialize GetIt<word>(2);',
+  '']);
+  ParseModule;
+end;
+
 initialization
   RegisterTest(TTestGenerics);
 end.