From 5d4ae23df8015af1d2392afb66a6758b048b0f68 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Wed, 17 Jul 2019 16:35:30 +0000 Subject: [PATCH] fcl-passrc: store generic procedure templates git-svn-id: trunk@42451 - --- packages/fcl-passrc/src/pastree.pp | 116 ++++++++++++++++- packages/fcl-passrc/src/pparser.pp | 163 ++++++++++++++++-------- packages/fcl-passrc/tests/tcgenerics.pp | 32 ++++- 3 files changed, 249 insertions(+), 62 deletions(-) diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 39661abefb..30a0a413ab 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index bce67954db..00a07d7a8b 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/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 + Delphi generic Method Declaration: + MustBeGeneric=false, Name + ObjFPC Method implementation of generic class: + aClass.SubClass.Name + Delphi Method implementation of generic class: + aClass.SubClass.Name + aClass.SubClass.Name + } 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; diff --git a/packages/fcl-passrc/tests/tcgenerics.pp b/packages/fcl-passrc/tests/tcgenerics.pp index 4dc0959666..3a2c65ed99 100644 --- a/packages/fcl-passrc/tests/tcgenerics.pp +++ b/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 = object'); Add(' procedure foo(v:T);'); + Add(' procedure bar(v:T);'); + Add(' type'); + Add(' TSub = class'); + Add(' procedure DoIt(v:T);'); + Add(' end;'); Add(' end;'); Add('implementation'); Add('procedure TTest.foo;'); Add('begin'); Add('end;'); + Add('procedure TTest.bar;'); + Add('begin'); + Add('end;'); + Add('procedure TTest.TSub.DoIt;'); + 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(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(val: T) :T;', + 'implementation', + 'generic function Get(val: T) :T;', + 'begin', + 'end;', + 'initialization', + ' specialize GetIt(2);', + '']); + ParseModule; +end; + initialization RegisterTest(TTestGenerics); end.