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

fcl-passrc: template is, is template, template(), atype(template)

Browse Source 
git-svn-id: trunk@42881 -
This commit is contained in:
Mattias Gaertner 2019-08-31 07:05:18 +00:00
parent d98c2c8f1a
commit 869fc5c7b3
2 changed files with 93 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4789,14 +4789,15 @@ begin
or (C=TPasProcedureType)
or (C=TPasFunctionType)
or (C=TPasArrayType)
or (C=TPasRangeType) then
or (C=TPasRangeType)
or (C=TPasGenericTemplateType) then
begin
// type cast to user type
Abort:=true; // can't be overloaded
if Data^.Found<>nil then exit;
Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.OnFindCallElements type cast to =',GetObjName(El),' Distance=',Distance);
writeln('TPasResolver.OnFindCallElements type cast to "',GetObjName(El),'" Distance=',Distance);
{$ENDIF}
CandidateFound:=true;
end;
@ -10209,7 +10210,8 @@ begin
or (C=TPasSetType)
or (C=TPasPointerType)
or (C=TPasArrayType)
or (C=TPasRangeType) then
or (C=TPasRangeType)
or (C=TPasGenericTemplateType) then
begin
// type cast
FinishUntypedParams(Access);
@ -24217,6 +24219,10 @@ var
ToTypeBaseType: TResolverBaseType;
C: TClass;
ToProcType, FromProcType: TPasProcedureType;
TemplType: TPasGenericTemplateType;
i: Integer;
Expr: TPasExpr;
ExprToken: TToken;
begin
Result:=cIncompatible;
ToTypeEl:=ToResolved.LoTypeEl;
@ -24372,6 +24378,25 @@ begin
if Result=cIncompatible then
Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
end
else if FromTypeEl.ClassType=TPasGenericTemplateType then
begin
// e.g. classtype(T)
TemplType:=TPasGenericTemplateType(FromTypeEl);
for i:=0 to length(TemplType.Constraints)-1 do
begin
Expr:=TemplType.Constraints[i];
ExprToken:=GetGenericConstraintKeyword(Expr);
case ExprToken of
tkrecord: ; // invalid type cast
tkClass, tkconstructor:
Result:=cExact;
else
// identifier constraint: class or interface -> allow
Result:=cExact;
break;
end;
end;
end;
end
else if FromResolved.BaseType=btPointer then
begin
@ -24381,6 +24406,35 @@ begin
else if FromResolved.BaseType=btNil then
Result:=cExact; // nil to class or interface
end
else if C=TPasGenericTemplateType then
begin
// e.g. T(var)
TemplType:=TPasGenericTemplateType(ToTypeEl);
FromTypeEl:=FromResolved.LoTypeEl;
for i:=0 to length(TemplType.Constraints)-1 do
begin
Expr:=TemplType.Constraints[i];
ExprToken:=GetGenericConstraintKeyword(Expr);
case ExprToken of
tkrecord:
if FromResolved.BaseType=btContext then
begin
if FromTypeEl.ClassType=TPasRecordType then
// typecast record to template record
Result:=cExact
else if FromTypeEl.ClassType=TPasGenericType then
// typecast template to template record
Result:=cExact;
end;
tkClass, tkconstructor:
Result:=cExact;
else
// identifier constraint: class or interface -> allow
Result:=cExact;
break;
end;
end;
end
else if C=TPasClassOfType then
begin
//writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.LoTypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));

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

@ -36,6 +36,7 @@ type
procedure TestGen_ConstraintInheritedMissingClassTypeFail;
procedure TestGen_ConstraintMultiParam;
procedure TestGen_ConstraintMultiParamClassMismatch;
procedure TestGen_ConstraintClassType_DotIsAsTypeCast;
// generic record
procedure TestGen_RecordLocalNameDuplicateFail;
@ -109,9 +110,6 @@ type
// ToDo: for-in
procedure TestGen_TryExcept;
// ToDo: call
// ToDo: dot
// ToDo: is as
// ToDo: typecast
// ToTo: nested proc
end;
@ -392,6 +390,41 @@ begin
nIncompatibleTypesGotExpected);
end;
procedure TTestResolveGenerics.TestGen_ConstraintClassType_DotIsAsTypeCast;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' TAnt = class',
' procedure Run; external; overload;',
' end;',
' TRedAnt = class(TAnt)',
' procedure Run(w: word); external; overload;',
' end;',
' generic TBird<T: TRedAnt> = class',
' y: T;',
' procedure Fly;',
' end;',
' TFireAnt = class(TRedAnt);',
' generic TEagle<U: TRedAnt> = class(TBird<U>) end;',
' TRedEagle = specialize TEagle<TRedAnt>;',
'procedure TBird.Fly;',
'var f: TFireAnt;',
'begin',
' y.Run;',
' y.Run(3);',
' if y is TFireAnt then',
' f:=y as TFireAnt;',
' f:=TFireAnt(y);',
' y:=T(f);',
'end;',
'begin',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_RecordLocalNameDuplicateFail;
begin
StartProgram(false);