paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 07:09:23 +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 SpecializeVariable(GenEl, SpecEl: TPasVariable; Finish: boolean);
procedure SpecializeConst(GenEl, SpecEl: TPasConst); procedure SpecializeConst(GenEl, SpecEl: TPasConst);
procedure SpecializeProperty(GenEl, SpecEl: TPasProperty); procedure SpecializeProperty(GenEl, SpecEl: TPasProperty);
function SpecializeTypeRef(GenEl, SpecEl: TPasElement; GenTypeRef: TPasType): TPasType;
procedure SpecializeElType(GenEl, SpecEl: TPasElement; procedure SpecializeElType(GenEl, SpecEl: TPasElement;
GenElType: TPasType; var SpecElType: TPasType); GenElType: TPasType; var SpecElType: TPasType);
procedure SpecializeElExpr(GenEl, SpecEl: TPasElement; 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 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 HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
function IndexOfGenericParam(Params: TPasExprArray): integer; 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; function CheckCallProcCompatibility(ProcType: TPasProcedureType;
Params: TParamsExpr; RaiseOnError: boolean; Params: TParamsExpr; RaiseOnError: boolean;
SetReferenceFlags: boolean = false): integer; SetReferenceFlags: boolean = false): integer;
@ -17059,25 +17061,44 @@ begin
FinishProperty(SpecEl); FinishProperty(SpecEl);
end; 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; procedure TPasResolver.SpecializeElType(GenEl, SpecEl: TPasElement;
GenElType: TPasType; var SpecElType: TPasType); GenElType: TPasType; var SpecElType: TPasType);
var var
Ref: TPasElement;
NewClass: TPTreeElement; NewClass: TPTreeElement;
begin begin
if GenElType=nil then exit; if GenElType=nil then exit;
if SpecElType<>nil then
RaiseNotYetImplemented(20190812021617,GenEl);
if (GenElType.Parent<>GenEl) if (GenElType.Parent<>GenEl)
or (GenElType.ClassType=TPasGenericTemplateType) then or (GenElType.ClassType=TPasGenericTemplateType) then
begin begin
// reference // reference
if GenElType.Name='' then GenElType:=SpecializeTypeRef(GenEl,SpecEl,GenElType);
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);
SpecElType:=GenElType; SpecElType:=GenElType;
SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF}; SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
exit; exit;
@ -17153,9 +17174,7 @@ begin
if not (GenListItem is TPasType) then if not (GenListItem is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)); RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
// reference // reference
Ref:=FindElement(GenListItem.Name); Ref:=SpecializeTypeRef(GenEl,SpecEl,TpasType(GenListItem));
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF}; Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
SpecList.Add(Ref); SpecList.Add(Ref);
continue; continue;
@ -17193,9 +17212,7 @@ begin
if not (GenListItem is TPasType) then if not (GenListItem is TPasType) then
RaiseNotYetImplemented(20190914102957,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)); RaiseNotYetImplemented(20190914102957,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
// reference // reference
Ref:=FindElement(GenListItem.Name); Ref:=SpecializeTypeRef(GenEl,SpecEl,TPasType(GenListItem));
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190914103009,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF}; Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
SpecList[i]:=Ref; SpecList[i]:=Ref;
continue; continue;
@ -27103,8 +27120,15 @@ begin
end; end;
if (TPasGenericType(aType).GenericTemplateTypes<>nil) if (TPasGenericType(aType).GenericTemplateTypes<>nil)
and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then 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); [ErrorEl.ElementTypeName],ErrorEl);
end;
end; end;
end; end;

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

@ -58,6 +58,8 @@ type
// generic class // generic class
procedure TestGen_Class; procedure TestGen_Class;
procedure TestGen_ClassDelphi; procedure TestGen_ClassDelphi;
procedure TestGen_ClassObjFPC;
procedure TestGen_ClassObjFPC_OverloadFail;
procedure TestGen_ClassForward; procedure TestGen_ClassForward;
procedure TestGen_ClassForwardConstraints; procedure TestGen_ClassForwardConstraints;
procedure TestGen_ClassForwardConstraintNameMismatch; procedure TestGen_ClassForwardConstraintNameMismatch;
@ -66,7 +68,7 @@ type
procedure TestGen_ClassForward_Circle; procedure TestGen_ClassForward_Circle;
procedure TestGen_Class_RedeclareInUnitImplFail; procedure TestGen_Class_RedeclareInUnitImplFail;
procedure TestGen_Class_AnotherInUnitImpl; procedure TestGen_Class_AnotherInUnitImpl;
procedure TestGen_Class_Method; procedure TestGen_Class_MethodObjFPC;
procedure TestGen_Class_MethodOverride; procedure TestGen_Class_MethodOverride;
procedure TestGen_Class_MethodDelphi; procedure TestGen_Class_MethodDelphi;
procedure TestGen_Class_MethodDelphiTypeParamMissing; procedure TestGen_Class_MethodDelphiTypeParamMissing;
@ -139,17 +141,20 @@ type
procedure TestGenProc_TypeParamCntOverload; procedure TestGenProc_TypeParamCntOverload;
procedure TestGenProc_TypeParamCntOverloadNoParams; procedure TestGenProc_TypeParamCntOverloadNoParams;
procedure TestGenProc_TypeParamWithDefaultParamDelphiFail; procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
procedure TestGenProc_Inference_NeedExplicitFail; // ToDo: NestedResultAssign
procedure TestGenProc_Inference_Overload;
procedure TestGenProc_Inference_OverloadForward; // generic function infer types
procedure TestGenProc_Inference_Var_Overload; procedure TestGenProc_Infer_NeedExplicitFail;
//procedure TestGenProc_Inference_Widen; procedure TestGenProc_Infer_Overload;
procedure TestGenProc_Inference_DefaultValue; procedure TestGenProc_Infer_OverloadForward;
procedure TestGenProc_Inference_DefaultValueMismatch; procedure TestGenProc_Infer_Var_Overload;
procedure TestGenProc_Inference_ProcT; //procedure TestGenProc_Infer_Widen;
procedure TestGenProc_Inference_Mismatch; procedure TestGenProc_Infer_DefaultValue;
procedure TestGenProc_Inference_ArrayOfT; procedure TestGenProc_Infer_DefaultValueMismatch;
// ToDo procedure TestGenProc_Inference_ProcType; procedure TestGenProc_Infer_ProcT;
procedure TestGenProc_Infer_Mismatch;
procedure TestGenProc_Infer_ArrayOfT;
// ToDo procedure TestGenProc_Infer_ProcType;
// generic methods // generic methods
procedure TestGenMethod_VirtualFail; procedure TestGenMethod_VirtualFail;
@ -751,6 +756,40 @@ begin
ParseProgram; ParseProgram;
end; 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; procedure TTestResolveGenerics.TestGen_ClassForward;
begin begin
StartProgram(false); StartProgram(false);
@ -919,7 +958,7 @@ begin
ParseUnit; ParseUnit;
end; end;
procedure TTestResolveGenerics.TestGen_Class_Method; procedure TTestResolveGenerics.TestGen_Class_MethodObjFPC;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2061,7 +2100,7 @@ begin
CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal); CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal);
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_NeedExplicitFail; procedure TTestResolveGenerics.TestGenProc_Infer_NeedExplicitFail;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2076,7 +2115,7 @@ begin
nCouldNotInferTypeArgXForMethodY); nCouldNotInferTypeArgXForMethodY);
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_Overload; procedure TTestResolveGenerics.TestGenProc_Infer_Overload;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2098,7 +2137,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_OverloadForward; procedure TTestResolveGenerics.TestGenProc_Infer_OverloadForward;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2126,7 +2165,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_Var_Overload; procedure TTestResolveGenerics.TestGenProc_Infer_Var_Overload;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2152,7 +2191,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValue; procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValue;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2169,7 +2208,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValueMismatch; procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValueMismatch;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2185,7 +2224,7 @@ begin
nIncompatibleTypesGotExpected); nIncompatibleTypesGotExpected);
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_ProcT; procedure TTestResolveGenerics.TestGenProc_Infer_ProcT;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2207,7 +2246,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_Mismatch; procedure TTestResolveGenerics.TestGenProc_Infer_Mismatch;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -2222,7 +2261,7 @@ begin
nInferredTypeXFromDiffArgsMismatchFromMethodY); nInferredTypeXFromDiffArgsMismatchFromMethodY);
end; end;
procedure TTestResolveGenerics.TestGenProc_Inference_ArrayOfT; procedure TTestResolveGenerics.TestGenProc_Infer_ArrayOfT;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([