paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 04:59:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: objfpc refer to parent generic type without type params

Browse Source 
git-svn-id: trunk@43204 -
This commit is contained in:
Mattias Gaertner 2019-10-15 18:57:30 +00:00
parent 84ebe96d41
commit 1127e3d27b
2 changed files with 102 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
packages/fcl-passrc/src/pasresolver.pp
View File

@ -1823,6 +1823,7 @@ type
procedure SpecializeVariable(GenEl, SpecEl: TPasVariable; Finish: boolean);
procedure SpecializeConst(GenEl, SpecEl: TPasConst);
procedure SpecializeProperty(GenEl, SpecEl: TPasProperty);
function SpecializeTypeRef(GenEl, SpecEl: TPasElement; GenTypeRef: TPasType): TPasType;
procedure SpecializeElType(GenEl, SpecEl: TPasElement;
GenElType: TPasType; var SpecElType: TPasType);
procedure SpecializeElExpr(GenEl, SpecEl: TPasElement;
@ -2181,7 +2182,8 @@ type
function IsSameType(TypeA, TypeB: TPasType; ResolveAlias: TPRResolveAlias): boolean; // check if it is exactly the same
function HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
function IndexOfGenericParam(Params: TPasExprArray): integer;
procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt; ErrorEl: TPasElement);
procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
ErrorEl: TPasElement);
function CheckCallProcCompatibility(ProcType: TPasProcedureType;
Params: TParamsExpr; RaiseOnError: boolean;
SetReferenceFlags: boolean = false): integer;
@ -17059,25 +17061,44 @@ begin
FinishProperty(SpecEl);
end;
function TPasResolver.SpecializeTypeRef(GenEl, SpecEl: TPasElement;
GenTypeRef: TPasType): TPasType;
var
GenParent, SpecParent, Ref: TPasElement;
begin
if GenTypeRef.Name='' then
RaiseNotYetImplemented(20190813213555,GenEl,GetObjPath(GenTypeRef));
if GenEl.HasParent(GenTypeRef) then
begin
GenParent:=GenEl.Parent;
SpecParent:=SpecEl.Parent;
while GenParent<>GenTypeRef do
begin
GenParent:=GenParent.Parent;
SpecParent:=SpecParent.Parent;
end;
Ref:=SpecParent;
end
else
Ref:=FindElement(GenTypeRef.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
Result:=TPasType(Ref);
end;
procedure TPasResolver.SpecializeElType(GenEl, SpecEl: TPasElement;
GenElType: TPasType; var SpecElType: TPasType);
var
Ref: TPasElement;
NewClass: TPTreeElement;
begin
if GenElType=nil then exit;
if SpecElType<>nil then
RaiseNotYetImplemented(20190812021617,GenEl);
if (GenElType.Parent<>GenEl)
or (GenElType.ClassType=TPasGenericTemplateType) then
begin
// reference
if GenElType.Name='' then
RaiseNotYetImplemented(20190813213555,GenEl,GetObjName(GenElType)+' Parent='+GetObjName(GenElType.Parent));
Ref:=FindElement(GenElType.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
GenElType:=TPasType(Ref);
if SpecElType<>nil then
RaiseNotYetImplemented(20190812021617,GenEl);
GenElType:=SpecializeTypeRef(GenEl,SpecEl,GenElType);
SpecElType:=GenElType;
SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
exit;
@ -17153,9 +17174,7 @@ begin
if not (GenListItem is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
// reference
Ref:=FindElement(GenListItem.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
Ref:=SpecializeTypeRef(GenEl,SpecEl,TpasType(GenListItem));
Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
SpecList.Add(Ref);
continue;
@ -17193,9 +17212,7 @@ begin
if not (GenListItem is TPasType) then
RaiseNotYetImplemented(20190914102957,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
// reference
Ref:=FindElement(GenListItem.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190914103009,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
Ref:=SpecializeTypeRef(GenEl,SpecEl,TPasType(GenListItem));
Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
SpecList[i]:=Ref;
continue;
@ -27103,8 +27120,15 @@ begin
end;
if (TPasGenericType(aType).GenericTemplateTypes<>nil)
and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
begin
// ref to generic type without specialization
if not (msDelphi in CurrentParser.CurrentModeswitches)
and (ErrorEl.HasParent(aType)) then
// ObjFPC allows referring to parent without type params
else
RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
[ErrorEl.ElementTypeName],ErrorEl);
end;
end;
end;

83
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -58,6 +58,8 @@ type
// generic class
procedure TestGen_Class;
procedure TestGen_ClassDelphi;
procedure TestGen_ClassObjFPC;
procedure TestGen_ClassObjFPC_OverloadFail;
procedure TestGen_ClassForward;
procedure TestGen_ClassForwardConstraints;
procedure TestGen_ClassForwardConstraintNameMismatch;
@ -66,7 +68,7 @@ type
procedure TestGen_ClassForward_Circle;
procedure TestGen_Class_RedeclareInUnitImplFail;
procedure TestGen_Class_AnotherInUnitImpl;
procedure TestGen_Class_Method;
procedure TestGen_Class_MethodObjFPC;
procedure TestGen_Class_MethodOverride;
procedure TestGen_Class_MethodDelphi;
procedure TestGen_Class_MethodDelphiTypeParamMissing;
@ -139,17 +141,20 @@ type
procedure TestGenProc_TypeParamCntOverload;
procedure TestGenProc_TypeParamCntOverloadNoParams;
procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
procedure TestGenProc_Inference_NeedExplicitFail;
procedure TestGenProc_Inference_Overload;
procedure TestGenProc_Inference_OverloadForward;
procedure TestGenProc_Inference_Var_Overload;
//procedure TestGenProc_Inference_Widen;
procedure TestGenProc_Inference_DefaultValue;
procedure TestGenProc_Inference_DefaultValueMismatch;
procedure TestGenProc_Inference_ProcT;
procedure TestGenProc_Inference_Mismatch;
procedure TestGenProc_Inference_ArrayOfT;
// ToDo procedure TestGenProc_Inference_ProcType;
// ToDo: NestedResultAssign
// generic function infer types
procedure TestGenProc_Infer_NeedExplicitFail;
procedure TestGenProc_Infer_Overload;
procedure TestGenProc_Infer_OverloadForward;
procedure TestGenProc_Infer_Var_Overload;
//procedure TestGenProc_Infer_Widen;
procedure TestGenProc_Infer_DefaultValue;
procedure TestGenProc_Infer_DefaultValueMismatch;
procedure TestGenProc_Infer_ProcT;
procedure TestGenProc_Infer_Mismatch;
procedure TestGenProc_Infer_ArrayOfT;
// ToDo procedure TestGenProc_Infer_ProcType;
// generic methods
procedure TestGenMethod_VirtualFail;
@ -751,6 +756,40 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassObjFPC;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T> = class',
' v: TBird;',
' end;',
'var',
' b: specialize TBird<word>;',
'begin',
' b.v:=b;',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassObjFPC_OverloadFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' TBird = word;',
' generic TBird<T> = class',
' v: T;',
' end;',
'begin',
'']);
CheckResolverException('Duplicate identifier "TBird" at afile.pp(5,8)',nDuplicateIdentifier);
end;
procedure TTestResolveGenerics.TestGen_ClassForward;
begin
StartProgram(false);
@ -919,7 +958,7 @@ begin
ParseUnit;
end;
procedure TTestResolveGenerics.TestGen_Class_Method;
procedure TTestResolveGenerics.TestGen_Class_MethodObjFPC;
begin
StartProgram(false);
Add([
@ -2061,7 +2100,7 @@ begin
CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal);
end;
procedure TTestResolveGenerics.TestGenProc_Inference_NeedExplicitFail;
procedure TTestResolveGenerics.TestGenProc_Infer_NeedExplicitFail;
begin
StartProgram(false);
Add([
@ -2076,7 +2115,7 @@ begin
nCouldNotInferTypeArgXForMethodY);
end;
procedure TTestResolveGenerics.TestGenProc_Inference_Overload;
procedure TTestResolveGenerics.TestGenProc_Infer_Overload;
begin
StartProgram(false);
Add([
@ -2098,7 +2137,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Inference_OverloadForward;
procedure TTestResolveGenerics.TestGenProc_Infer_OverloadForward;
begin
StartProgram(false);
Add([
@ -2126,7 +2165,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Inference_Var_Overload;
procedure TTestResolveGenerics.TestGenProc_Infer_Var_Overload;
begin
StartProgram(false);
Add([
@ -2152,7 +2191,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValue;
procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValue;
begin
StartProgram(false);
Add([
@ -2169,7 +2208,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValueMismatch;
procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValueMismatch;
begin
StartProgram(false);
Add([
@ -2185,7 +2224,7 @@ begin
nIncompatibleTypesGotExpected);
end;
procedure TTestResolveGenerics.TestGenProc_Inference_ProcT;
procedure TTestResolveGenerics.TestGenProc_Infer_ProcT;
begin
StartProgram(false);
Add([
@ -2207,7 +2246,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Inference_Mismatch;
procedure TTestResolveGenerics.TestGenProc_Infer_Mismatch;
begin
StartProgram(false);
Add([
@ -2222,7 +2261,7 @@ begin
nInferredTypeXFromDiffArgsMismatchFromMethodY);
end;
procedure TTestResolveGenerics.TestGenProc_Inference_ArrayOfT;
procedure TTestResolveGenerics.TestGenProc_Infer_ArrayOfT;
begin
StartProgram(false);
Add([