paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-05 09:10:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: store generic procedure templates

Browse Source 
git-svn-id: trunk@42451 -
This commit is contained in:
Mattias Gaertner 2019-07-17 16:35:30 +00:00
parent 3b1c2061f5
commit 5d4ae23df8
3 changed files with 249 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
packages/fcl-passrc/src/pastree.pp
View File

@ -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;

163
packages/fcl-passrc/src/pparser.pp
View File

@ -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;

32
packages/fcl-passrc/tests/tcgenerics.pp
View File

@ -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.