mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 07:08:29 +02:00
fcl-passrc: specialize for-loop
git-svn-id: trunk@42602 -
This commit is contained in:
Mattias Gaertner
parent
70b2904c48
commit
c4cd0ad776
@ -1726,11 +1726,14 @@ type
|
||||
procedure SpecializeProcedureType(GenEl, SpecEl: TPasProcedureType);
|
||||
procedure SpecializeProcedureBody(GenEl, SpecEl: TProcedureBody);
|
||||
procedure SpecializeDeclarations(GenEl, SpecEl: TPasDeclarations);
|
||||
procedure SpecializeSpecializeType(GenEl, SpecEl: TPasSpecializeType);
|
||||
procedure SpecializeArgument(GenEl, SpecEl: TPasArgument);
|
||||
procedure SpecializeImplBlock(GenEl, SpecEl: TPasImplBlock);
|
||||
procedure SpecializeImplAssign(GenEl, SpecEl: TPasImplAssign);
|
||||
procedure SpecializeImplForLoop(GenEl, SpecEl: TPasImplForLoop);
|
||||
procedure SpecializeExpr(GenEl, SpecEl: TPasExpr);
|
||||
procedure SpecializePrimitiveExpr(GenEl, SpecEl: TPrimitiveExpr);
|
||||
procedure SpecializeBinaryExpr(GenEl, SpecEl: TBinaryExpr);
|
||||
protected
|
||||
// custom types (added by descendant resolvers)
|
||||
function CheckAssignCompatibilityCustom(
|
||||
@ -2138,6 +2141,7 @@ type
|
||||
function IsArrayOperatorAdd(Expr: TPasExpr): boolean;
|
||||
function IsTypeCast(Params: TParamsExpr): boolean;
|
||||
function GetTypeParameterCount(aType: TPasGenericType): integer;
|
||||
function IsGenericTemplType(const ResolvedEl: TPasResolverResult): boolean;
|
||||
function IsInterfaceType(const ResolvedEl: TPasResolverResult;
|
||||
IntfType: TPasClassInterfaceType): boolean; overload;
|
||||
function IsInterfaceType(TypeEl: TPasType; IntfType: TPasClassInterfaceType): boolean; overload;
|
||||
@ -4244,6 +4248,30 @@ begin
|
||||
Result:=(El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent);
|
||||
end;
|
||||
|
||||
// inline
|
||||
function TPasResolver.IsGenericTemplType(const ResolvedEl: TPasResolverResult
|
||||
): boolean;
|
||||
begin
|
||||
Result:=(ResolvedEl.BaseType=btContext)
|
||||
and (ResolvedEl.LoTypeEl.ClassType=TPasGenericTemplateType);
|
||||
end;
|
||||
|
||||
// inline
|
||||
function TPasResolver.GetLocalScope: TPasScope;
|
||||
begin
|
||||
Result:=TopScope;
|
||||
if Result.ClassType=TPasGroupScope then
|
||||
Result:=TPasGroupScope(Result).Scopes[0];
|
||||
end;
|
||||
|
||||
// inline
|
||||
function TPasResolver.GetParentLocalScope: TPasScope;
|
||||
begin
|
||||
Result:=Scopes[ScopeCount-2];
|
||||
if Result.ClassType=TPasGroupScope then
|
||||
Result:=TPasGroupScope(Result).Scopes[0];
|
||||
end;
|
||||
|
||||
function TPasResolver.GetNameExprValue(El: TPasExpr): string;
|
||||
begin
|
||||
if El=nil then
|
||||
@ -11479,6 +11507,14 @@ begin
|
||||
|
||||
//writeln('TPasResolver.ComputeBinaryExpr ',OpcodeStrings[Bin.OpCode],' Left=',GetResolverResultDbg(LeftResolved),' Right=',GetResolverResultDbg(RightResolved));
|
||||
|
||||
if IsGenericTemplType(LeftResolved) or IsGenericTemplType(RightResolved) then
|
||||
begin
|
||||
// cannot yet be decided
|
||||
ResolvedEl:=LeftResolved;
|
||||
ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
|
||||
exit;
|
||||
end;
|
||||
|
||||
if LeftResolved.BaseType in btAllInteger then
|
||||
begin
|
||||
if (rrfReadable in LeftResolved.Flags)
|
||||
@ -14249,9 +14285,15 @@ begin
|
||||
// check if there is already such a specialization
|
||||
GenericType:=El.DestType as TPasGenericType;
|
||||
if not (GenericType.CustomData is TPasGenericScope) then
|
||||
RaiseNotYetImplemented(20190726194316,El,GetObjName(GenericType.CustomData));
|
||||
RaiseMsg(20190726194316,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
|
||||
[GetTypeDescription(GenericType)],El);
|
||||
GenScope:=TPasGenericScope(GenericType.CustomData);
|
||||
|
||||
if (not (GenericType is TPasClassType))
|
||||
and (GenScope.GenericStep<psgsInterfaceParsed) then
|
||||
RaiseMsg(20190807205038,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
|
||||
[GetTypeDescription(GenericType)],El);
|
||||
|
||||
if not CheckSpecializeConstraints(El) then
|
||||
begin
|
||||
// not fully specialized -> use generic type
|
||||
@ -14625,7 +14667,8 @@ begin
|
||||
|
||||
// check specialized type step
|
||||
if SpecializedItem.Step<psssInterfaceFinished then
|
||||
RaiseNotYetImplemented(20190804120128,GenericType,GetObjName(SpecializedItem.SpecializedType));
|
||||
RaiseMsg(20190804120128,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
|
||||
[GetTypeDescription(GenericType)],SpecializedItem.FirstSpecialize);
|
||||
if SpecializedItem.Step>psssInterfaceFinished then
|
||||
exit;
|
||||
SpecializedItem.Step:=psssImplementationBuilding;
|
||||
@ -14740,12 +14783,14 @@ begin
|
||||
C:=GenEl.ClassType;
|
||||
if C=TPrimitiveExpr then
|
||||
SpecializePrimitiveExpr(TPrimitiveExpr(GenEl),TPrimitiveExpr(SpecEl))
|
||||
else if C=TBinaryExpr then
|
||||
SpecializeBinaryExpr(TBinaryExpr(GenEl),TBinaryExpr(SpecEl))
|
||||
else if C=TPasImplBeginBlock then
|
||||
// no special Add
|
||||
SpecializeImplBlock(TPasImplBeginBlock(GenEl),TPasImplBeginBlock(SpecEl))
|
||||
else if C=TPasImplAssign then
|
||||
// no special Add
|
||||
SpecializeImplAssign(TPasImplAssign(GenEl),TPasImplAssign(SpecEl))
|
||||
else if C=TPasImplForLoop then
|
||||
SpecializeImplForLoop(TPasImplForLoop(GenEl),TPasImplForLoop(SpecEl))
|
||||
else if C=TPasVariable then
|
||||
begin
|
||||
AddVariable(TPasVariable(SpecEl));
|
||||
@ -14771,6 +14816,11 @@ begin
|
||||
AddType(TPasProcedureType(SpecEl));
|
||||
SpecializeProcedureType(TPasProcedureType(GenEl),TPasProcedureType(SpecEl));
|
||||
end
|
||||
else if C=TPasSpecializeType then
|
||||
begin
|
||||
AddType(TPasSpecializeType(SpecEl));
|
||||
SpecializeSpecializeType(TPasSpecializeType(GenEl),TPasSpecializeType(SpecEl));
|
||||
end
|
||||
else
|
||||
RaiseNotYetImplemented(20190728151215,GenEl);
|
||||
end;
|
||||
@ -14807,6 +14857,7 @@ procedure TPasResolver.SpecializeElType(GenEl, SpecEl: TPasElement;
|
||||
GenElType: TPasType; var SpecElType: TPasType);
|
||||
var
|
||||
Ref: TPasElement;
|
||||
NewClass: TPTreeElement;
|
||||
begin
|
||||
if GenElType=nil then exit;
|
||||
if GenElType.Parent<>GenEl then
|
||||
@ -14828,7 +14879,9 @@ begin
|
||||
exit;
|
||||
end;
|
||||
// e.g. anonymous type
|
||||
RaiseNotYetImplemented(20190728152244,GenEl);
|
||||
NewClass:=TPTreeElement(GenElType.ClassType);
|
||||
SpecElType:=TPasType(NewClass.Create(GenElType.Name,SpecEl));
|
||||
SpecializeElement(GenElType,SpecElType);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeElExpr(GenEl, SpecEl: TPasElement;
|
||||
@ -14997,6 +15050,34 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeSpecializeType(GenEl,
|
||||
SpecEl: TPasSpecializeType);
|
||||
var
|
||||
i: Integer;
|
||||
GenParam, SpecParam: TPasElement;
|
||||
NewClass: TPTreeElement;
|
||||
begin
|
||||
SpecializeElType(GenEl,SpecEl,GenEl.DestType,SpecEl.DestType);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
|
||||
for i:=0 to GenEl.Params.Count-1 do
|
||||
begin
|
||||
GenParam:=TPasElement(GenEl.Params[i]);
|
||||
if GenParam.Parent<>GenEl then
|
||||
begin
|
||||
// reference
|
||||
GenParam.AddRef{$IFDEF CheckPasTreeRefCount}('TPasSpecializeType.Params'){$ENDIF};
|
||||
SpecEl.AddParam(GenParam);
|
||||
continue;
|
||||
end;
|
||||
NewClass:=TPTreeElement(GenParam.ClassType);
|
||||
SpecParam:=TPasElement(NewClass.Create(GenParam.Name,SpecEl));
|
||||
SpecEl.Params.Add(SpecParam);
|
||||
SpecializeElement(GenParam,SpecParam);
|
||||
end;
|
||||
|
||||
FinishSpecializeType(SpecEl);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeArgument(GenEl, SpecEl: TPasArgument);
|
||||
begin
|
||||
SpecEl.Access:=GenEl.Access;
|
||||
@ -15027,18 +15108,45 @@ end;
|
||||
|
||||
procedure TPasResolver.SpecializeImplAssign(GenEl, SpecEl: TPasImplAssign);
|
||||
begin
|
||||
SpecializeImplBlock(GenEl,SpecEl);
|
||||
if GenEl.Elements.Count>0 then
|
||||
RaiseNotYetImplemented(20190808142935,GenEl);
|
||||
SpecEl.Kind:=GenEl.Kind;
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.left,SpecEl.left);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.right,SpecEl.right);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeImplForLoop(GenEl, SpecEl: TPasImplForLoop);
|
||||
var
|
||||
i: Integer;
|
||||
GenImpl, NewImpl: TPasImplElement;
|
||||
NewClass: TPTreeElement;
|
||||
begin
|
||||
if GenEl.Variable<>nil then
|
||||
RaiseNotYetImplemented(20190808142627,GenEl);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.VariableName,SpecEl.VariableName);
|
||||
SpecEl.LoopType:=GenEl.LoopType;
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.StartExpr,SpecEl.StartExpr);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.EndExpr,SpecEl.EndExpr);
|
||||
FinishForLoopHeader(SpecEl);
|
||||
// SpecEl.Body is set via AddElement
|
||||
for i:=0 to GenEl.Elements.Count-1 do
|
||||
begin
|
||||
GenImpl:=TPasImplElement(GenEl.Elements[i]);
|
||||
if GenImpl.Parent<>GenEl then
|
||||
RaiseNotYetImplemented(20190806092151,GenEl,GetElementSourcePosStr(GenImpl));
|
||||
NewClass:=TPTreeElement(GenImpl.ClassType);
|
||||
NewImpl:=TPasImplElement(NewClass.Create(GenImpl.Name,SpecEl));
|
||||
SpecEl.AddElement(NewImpl);
|
||||
SpecializeElement(GenImpl,NewImpl);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeExpr(GenEl, SpecEl: TPasExpr);
|
||||
begin
|
||||
SpecEl.Kind:=GenEl.Kind;
|
||||
SpecEl.OpCode:=GenEl.OpCode;
|
||||
SpecEl.format1:=GenEl.format1;
|
||||
SpecEl.format2:=GenEl.format2;
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.format1,SpecEl.format1);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.format2,SpecEl.format2);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializePrimitiveExpr(GenEl, SpecEl: TPrimitiveExpr);
|
||||
@ -15047,6 +15155,13 @@ begin
|
||||
SpecEl.Value:=GenEl.Value;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.SpecializeBinaryExpr(GenEl, SpecEl: TBinaryExpr);
|
||||
begin
|
||||
SpecializeExpr(GenEl,SpecEl);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.left,SpecEl.left);
|
||||
SpecializeElExpr(GenEl,SpecEl,GenEl.right,SpecEl.right);
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckAssignCompatibilityCustom(const LHS,
|
||||
RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean;
|
||||
var Handled: boolean): integer;
|
||||
@ -18592,20 +18707,6 @@ begin
|
||||
{AllowWriteln-}
|
||||
end;
|
||||
|
||||
function TPasResolver.GetLocalScope: TPasScope;
|
||||
begin
|
||||
Result:=TopScope;
|
||||
if Result.ClassType=TPasGroupScope then
|
||||
Result:=TPasGroupScope(Result).Scopes[0];
|
||||
end;
|
||||
|
||||
function TPasResolver.GetParentLocalScope: TPasScope;
|
||||
begin
|
||||
Result:=Scopes[ScopeCount-2];
|
||||
if Result.ClassType=TPasGroupScope then
|
||||
Result:=TPasGroupScope(Result).Scopes[0];
|
||||
end;
|
||||
|
||||
function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass
|
||||
): TPasScope;
|
||||
begin
|
||||
@ -20314,6 +20415,11 @@ begin
|
||||
begin
|
||||
LBT:=GetActualBaseType(LHS.BaseType);
|
||||
RBT:=GetActualBaseType(RHS.BaseType);
|
||||
if IsGenericTemplType(LHS) or IsGenericTemplType(RHS) then
|
||||
begin
|
||||
// not fully specified -> maybe
|
||||
exit(cCompatible);
|
||||
end;
|
||||
if LHS.LoTypeEl=nil then
|
||||
begin
|
||||
if LBT=btUntyped then
|
||||
|
||||
@ -4081,45 +4081,28 @@ procedure TPasParser.ReadSpecializeArguments(Spec: TPasElement);
|
||||
end;
|
||||
|
||||
Var
|
||||
Expr: TPasExpr;
|
||||
TypeEl: TPasType;
|
||||
|
||||
begin
|
||||
//writeln('START TPasParser.ReadSpecializeArguments ',CurTokenText,' ',CurTokenString);
|
||||
CheckToken(tkLessThan);
|
||||
NextToken;
|
||||
Expr:=nil;
|
||||
try
|
||||
repeat
|
||||
//writeln('ARG TPasParser.ReadSpecializeArguments ',CurTokenText,' ',CurTokenString);
|
||||
TypeEl:=ParseTypeReference(Spec,true,Expr);
|
||||
if TypeEl.Parent=Spec then
|
||||
AddParam(TypeEl)
|
||||
else
|
||||
begin
|
||||
TypeEl.Release{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
|
||||
AddParam(Expr);
|
||||
Expr:=nil;
|
||||
end;
|
||||
if CurToken=tkComma then
|
||||
begin
|
||||
NextToken;
|
||||
continue;
|
||||
end
|
||||
else if CurToken=tkshr then
|
||||
begin
|
||||
ChangeToken(tkGreaterThan);
|
||||
break;
|
||||
end
|
||||
else if CurToken=tkGreaterThan then
|
||||
break
|
||||
else
|
||||
ParseExc(nParserExpectToken2Error,SParserExpectToken2Error,
|
||||
[TokenInfos[tkComma], TokenInfos[tkGreaterThan]]);
|
||||
until false;
|
||||
finally
|
||||
Expr.Free;
|
||||
end;
|
||||
repeat
|
||||
//writeln('ARG TPasParser.ReadSpecializeArguments ',CurTokenText,' ',CurTokenString);
|
||||
TypeEl:=ParseType(Spec,CurTokenPos,'');
|
||||
AddParam(TypeEl);
|
||||
NextToken;
|
||||
if CurToken=tkComma then
|
||||
continue
|
||||
else if CurToken=tkshr then
|
||||
begin
|
||||
ChangeToken(tkGreaterThan);
|
||||
break;
|
||||
end
|
||||
else if CurToken=tkGreaterThan then
|
||||
break
|
||||
else
|
||||
ParseExc(nParserExpectToken2Error,SParserExpectToken2Error,
|
||||
[TokenInfos[tkComma], TokenInfos[tkGreaterThan]]);
|
||||
until false;
|
||||
end;
|
||||
|
||||
function TPasParser.ReadDottedIdentifier(Parent: TPasElement; out
|
||||
|
||||
@ -557,8 +557,8 @@ begin
|
||||
AssertNotNull('Have param types',C.Params);
|
||||
AssertEquals('Have one param type',1,C.Params.Count);
|
||||
AssertNotNull('First Param ',C.Params[0]);
|
||||
AssertEquals('First Param expr',TPrimitiveExpr,TObject(C.Params[0]).ClassType);
|
||||
AssertEquals('Has specialize param integer','Integer',TPrimitiveExpr(C.Params[0]).Value);
|
||||
AssertEquals('First Param unresolvedtype',TPasUnresolvedTypeRef,TObject(C.Params[0]).ClassType);
|
||||
AssertEquals('Has specialize param integer','Integer',TPasUnresolvedTypeRef(C.Params[0]).Name);
|
||||
end;
|
||||
|
||||
procedure TTestClassType.TestOneSpecializedClass;
|
||||
|
||||
@ -13,13 +13,14 @@ type
|
||||
|
||||
TTestResolveGenerics = Class(TCustomTestResolver)
|
||||
Published
|
||||
// generic functions
|
||||
procedure TestGen_GenericFunction; // ToDo
|
||||
|
||||
// generic types
|
||||
procedure TestGen_MissingTemplateFail;
|
||||
procedure TestGen_VarTypeWithoutSpecializeFail;
|
||||
procedure TestGen_GenTypeWithWrongParamCountFail;
|
||||
procedure TestGen_GenericNotFoundFail;
|
||||
procedure TestGen_SameNameSameParamCountFail;
|
||||
|
||||
// constraints
|
||||
procedure TestGen_ConstraintStringFail;
|
||||
procedure TestGen_ConstraintMultiClassFail;
|
||||
procedure TestGen_ConstraintRecordExpectedFail;
|
||||
@ -30,56 +31,65 @@ type
|
||||
// ToDo: constraint T:Unit2.TBird
|
||||
// ToDo: constraint T:Unit2.TGen<word>
|
||||
procedure TestGen_TemplNameEqTypeNameFail;
|
||||
procedure TestGen_GenericNotFoundFail;
|
||||
procedure TestGen_SameNameSameParamCountFail;
|
||||
|
||||
// generic record
|
||||
procedure TestGen_RecordLocalNameDuplicateFail;
|
||||
procedure TestGen_Record;
|
||||
procedure TestGen_RecordDelphi;
|
||||
procedure TestGen_RecordNestedSpecialized;
|
||||
procedure TestGen_Record_SpecializeSelfInsideFail;
|
||||
// ToDo: enums within generic
|
||||
procedure TestGen_RecordAnoArray;
|
||||
// ToDo: procedure TestGen_SpecializeArg_ArrayOf; type TBird = specialize<array of word>
|
||||
// ToDo: unitname.specialize TBird<word>.specialize
|
||||
|
||||
// generic class
|
||||
procedure TestGen_Class;
|
||||
procedure TestGen_ClassDelphi;
|
||||
procedure TestGen_ClassForward;
|
||||
procedure TestGen_Class_Method;
|
||||
procedure TestGen_Class_Method_LocalVar;
|
||||
// ToDo: specialize inside generic fail
|
||||
procedure TestGen_Class_SpecializeSelfInside;
|
||||
// ToDo: generic class forward (constraints must be repeated)
|
||||
// ToDo: generic class forward constraints mismatch fail
|
||||
// ToDo: generic class overload <T> <S,T>
|
||||
// ToDo: generic class method overload <T> <S,T>
|
||||
procedure TestGen_Class_GenAncestor;
|
||||
procedure TestGen_Class_AncestorSelfFail;
|
||||
// ToDo: ancestor cycle: TBird<T> = class(TBird<word>) fail
|
||||
// ToDo: class-of
|
||||
// ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
|
||||
|
||||
// ToDo: generic interface
|
||||
|
||||
// ToDo: generic array
|
||||
|
||||
// ToDo: generic procedure type
|
||||
|
||||
// ToDo: pointer of generic
|
||||
// ToDo: generic helpers
|
||||
|
||||
// ToDo: helpers for generics
|
||||
|
||||
// generic functions
|
||||
// ToDo: generic class method overload <T> <S,T>
|
||||
procedure TestGen_GenericFunction; // ToDo
|
||||
|
||||
// generic statements
|
||||
procedure TestGen_LocalVar;
|
||||
procedure TestGen_ForLoop;
|
||||
// ToDo: for
|
||||
// ToDo: for-in
|
||||
// ToDo: if
|
||||
// ToDo: case
|
||||
// ToDo: while, repeat
|
||||
// ToDo: try finally/except
|
||||
// ToDo: call
|
||||
// ToDo: dot
|
||||
// ToDo: is as
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TTestResolveGenerics }
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_GenericFunction;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'generic function DoIt<T>(a: T): T;',
|
||||
'var i: T;',
|
||||
'begin',
|
||||
' a:=i;',
|
||||
' Result:=a;',
|
||||
'end;',
|
||||
'var w: word;',
|
||||
'begin',
|
||||
//' w:=DoIt<word>(3);',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_MissingTemplateFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -114,6 +124,33 @@ begin
|
||||
nIdentifierNotFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_GenericNotFoundFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TBird = specialize TAnimal<word>;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('identifier not found "TAnimal<>"',
|
||||
nIdentifierNotFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_SameNameSameParamCountFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode delphi}',
|
||||
'type',
|
||||
' TBird<S,T> = record w: T; end;',
|
||||
' TBird<X,Y> = record f: X; end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('Duplicate identifier "TBird" at afile.pp(4,8)',
|
||||
nDuplicateIdentifier);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_ConstraintStringFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -211,7 +248,7 @@ begin
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' generic TBird<TBird:record> = record v: T; end;',
|
||||
' generic TBird<TBird> = record v: T; end;',
|
||||
'var r: specialize TBird<word>;',
|
||||
'begin',
|
||||
'']);
|
||||
@ -219,33 +256,6 @@ begin
|
||||
nDuplicateIdentifier);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_GenericNotFoundFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TBird = specialize TAnimal<word>;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('identifier not found "TAnimal<>"',
|
||||
nIdentifierNotFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_SameNameSameParamCountFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode delphi}',
|
||||
'type',
|
||||
' TBird<S,T> = record w: T; end;',
|
||||
' TBird<X,Y> = record f: X; end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('Duplicate identifier "TBird" at afile.pp(4,8)',
|
||||
nDuplicateIdentifier);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_RecordLocalNameDuplicateFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -312,6 +322,34 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_Record_SpecializeSelfInsideFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' generic TBird<T> = record',
|
||||
' v: specialize TBird<word>;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('type "TBird" is not yet completely defined',
|
||||
nTypeXIsNotYetCompletelyDefined);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_RecordAnoArray;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' generic TBird<T> = record v: T; end;',
|
||||
'var b: specialize TBird<array of word>;',
|
||||
'begin',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_Class;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -403,7 +441,82 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_Class_Method_LocalVar;
|
||||
procedure TTestResolveGenerics.TestGen_Class_SpecializeSelfInside;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TObject = class end;',
|
||||
' generic TBird<T> = class',
|
||||
' e: T;',
|
||||
' v: TBird<boolean>;',
|
||||
' end;',
|
||||
'var',
|
||||
' b: specialize TBird<word>;',
|
||||
' w: word;',
|
||||
'begin',
|
||||
' b.e:=w;',
|
||||
' if b.v.e then ;',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_Class_GenAncestor;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TObject = class end;',
|
||||
' generic TBird<T> = class',
|
||||
' i: T;',
|
||||
' end;',
|
||||
' generic TEagle<T> = class(TBird<T>)',
|
||||
' j: T;',
|
||||
' end;',
|
||||
'var',
|
||||
' e: specialize TEagle<word>;',
|
||||
'begin',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_Class_AncestorSelfFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TObject = class end;',
|
||||
' generic TBird<T> = class(TBird<word>)',
|
||||
' e: T;',
|
||||
' end;',
|
||||
'var',
|
||||
' b: specialize TBird<word>;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_GenericFunction;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'generic function DoIt<T>(a: T): T;',
|
||||
'var i: T;',
|
||||
'begin',
|
||||
' a:=i;',
|
||||
' Result:=a;',
|
||||
'end;',
|
||||
'var w: word;',
|
||||
'begin',
|
||||
//' w:=DoIt<word>(3);',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_LocalVar;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
@ -431,6 +544,29 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolveGenerics.TestGen_ForLoop;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode objfpc}',
|
||||
'type',
|
||||
' TObject = class end;',
|
||||
' generic TBird<{#Templ}T> = class',
|
||||
' function Fly(p:T): T;',
|
||||
' end;',
|
||||
'function TBird.Fly(p:T): T;',
|
||||
'var i: T;',
|
||||
'begin',
|
||||
' for i:=0 to 3 do Result:=i+p;',
|
||||
'end;',
|
||||
'var',
|
||||
' b: specialize TBird<word>;',
|
||||
'begin',
|
||||
' b.Fly(2);',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTests([TTestResolveGenerics]);
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user