mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-25 11:49:14 +02:00
fcl-passrc: resolver specialize name with params
git-svn-id: trunk@46786 -
This commit is contained in:
Mattias Gaertner
parent
9337b2a3ac
commit
f3579bf526
@ -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;
|
||||
Item: TPRSpecializedItem): string; virtual;
|
||||
function CreateSpecializedTypeName(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
|
||||
break;
|
||||
case Identifier[p] of
|
||||
'.': 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);
|
||||
if p<1 then
|
||||
Result:=Identifier
|
||||
else
|
||||
Result:=LeftStr(Identifier,p-1);
|
||||
p:=1;
|
||||
l:=length(Identifier);
|
||||
repeat
|
||||
if p>l then
|
||||
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
|
||||
p:=Pos('.',ProcName);
|
||||
if p<1 then break;
|
||||
Delete(ProcName,1,p);
|
||||
until false;
|
||||
ProcName:=LastDottedIdentifier(ProcName);
|
||||
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;
|
||||
Item: TPRSpecializedItem): string;
|
||||
function TPasResolver.CreateSpecializedTypeName(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);
|
||||
while (p>0) and (NewImplProcName[p]<>'.') do dec(p);
|
||||
if p=0 then
|
||||
LastDotP:=GetLastDotPos(NewImplProcName);
|
||||
if LastDotP<1 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);
|
||||
while (p>0) and (OldClassname[p]<>'.') do dec(p);
|
||||
p:=GetLastDotPos(OldClassname);
|
||||
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
|
||||
|
||||
@ -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);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user