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

fcl-passrc: added TPasGenericType

Browse Source 
git-svn-id: trunk@42502 -
This commit is contained in:
Mattias Gaertner 2019-07-27 06:57:43 +00:00
parent aa48d5d18c
commit 52ef731f42
6 changed files with 543 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -193,6 +193,7 @@ const
nConstraintXSpecifiedMoreThanOnce = 3127;
nConstraintXAndConstraintYCannotBeTogether = 3128;
nXIsNotAValidConstraint = 3129;
nWrongNumberOfParametersForGenericType = 3130;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -333,6 +334,7 @@ resourcestring
sConstraintXSpecifiedMoreThanOnce = 'Constraint ''%s'' specified more than once';
sConstraintXAndConstraintYCannotBeTogether = '''%s'' constraint and ''%s'' constraint cannot be specified together';
sXIsNotAValidConstraint = '''%s'' is not a valid constraint';
sWrongNumberOfParametersForGenericType = 'wrong number of parameters for generic type %s';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

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

@ -661,6 +661,26 @@ type
Element: TPasType; // TPasClassOfType or TPasPointerType
end;
{ TPasSpecializeTypeData - CustomData of TPasSpecializeType
for the generic type see TPasSpecializeType(Element).DestType }
TPasSpecializeTypeData = Class(TResolveData)
public
SpecializedType: TPasType;
end;
{ TPSSpecializedItem }
TPSSpecializedItem = class
private
FSpecializedType: TPasGenericType;
procedure SetSpecializedType(AValue: TPasGenericType);
public
Params: TPasTypeArray;
destructor Destroy; override;
property SpecializedType: TPasGenericType read FSpecializedType write SetSpecializedType;
end;
TPSRefAccess = (
psraNone,
psraRead,
@ -896,9 +916,17 @@ type
destructor Destroy; override;
end;
{ TPasGenericScope }
TPasGenericScope = Class(TPasIdentifierScope)
public
SpecializedTypes: TObjectList; // list of TPSSpecializedItem
destructor Destroy; override;
end;
{ TPasClassOrRecordScope }
TPasClassOrRecordScope = Class(TPasIdentifierScope)
TPasClassOrRecordScope = Class(TPasGenericScope)
public
DefaultProperty: TPasProperty;
ClassConstructor: TPasClassConstructor;
@ -1239,6 +1267,7 @@ type
Flags: TPasResolverResultFlags;
end;
PPasResolverResult = ^TPasResolverResult;
TPasResolverResultArray = array of TPasResolverResult;
type
TPasResolverComputeFlag = (
@ -1520,13 +1549,16 @@ type
procedure FinishRangeType(El: TPasRangeType); virtual;
procedure FinishConstRangeExpr(RangeExpr: TBinaryExpr;
out LeftResolved, RightResolved: TPasResolverResult);
procedure FinishGenericTemplateTypes(aType: TPasGenericType); virtual;
procedure FinishRecordType(El: TPasRecordType); virtual;
procedure FinishClassType(El: TPasClassType); virtual;
procedure FinishClassOfType(El: TPasClassOfType); virtual;
procedure FinishPointerType(El: TPasPointerType); virtual;
procedure FinishArrayType(El: TPasArrayType); virtual;
procedure FinishGenericTemplateType(El: TPasGenericTemplateType); virtual;
procedure FinishSpecializeType(El: TPasSpecializeType); virtual;
procedure FinishResourcestring(El: TPasResString); virtual;
procedure FinishProcNameParts(aProc: TPasProcedure); virtual;
procedure FinishProcedure(aProc: TPasProcedure); virtual;
procedure FinishProcedureType(El: TPasProcedureType); virtual;
procedure FinishMethodDeclHeader(Proc: TPasProcedure); virtual;
@ -1622,6 +1654,7 @@ type
function FindTVarRec(ErrorEl: TPasElement): TPasRecordType; virtual;
function GetTVarRec(El: TPasArrayType): TPasRecordType; virtual;
protected
// constant evaluation
fExprEvaluator: TResExprEvaluator;
procedure OnExprEvalLog(Sender: TResExprEvaluator; const id: TMaxPrecInt;
MsgType: TMessageType; MsgNumber: integer; const Fmt: String;
@ -1633,6 +1666,10 @@ type
procedure OnRangeCheckEl(Sender: TResExprEvaluator; El: TPasElement;
var MsgType: TMessageType); virtual;
function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
protected
// generic/specialize
function GetSpecializedType(El: TPasSpecializeType): TPasGenericType;
procedure CheckSpecializeConstraints(El : TPasSpecializeType);
protected
// custom types (added by descendant resolvers)
function CheckAssignCompatibilityCustom(
@ -2783,6 +2820,36 @@ begin
str(a,Result);
end;
{ TPasGenericScope }
destructor TPasGenericScope.Destroy;
begin
if SpecializedTypes<>nil then
begin
SpecializedTypes.Free;
SpecializedTypes:=nil;
end;
inherited Destroy;
end;
{ TPSSpecializedItem }
procedure TPSSpecializedItem.SetSpecializedType(AValue: TPasGenericType);
begin
if FSpecializedType=AValue then Exit;
if FSpecializedType<>nil then
FSpecializedType.Release{$IFDEF CheckPasTreeRefCount}('TPSSpecializedItem.SpecializedType'){$ENDIF};
FSpecializedType:=AValue;
if FSpecializedType<>nil then
FSpecializedType.AddRef{$IFDEF CheckPasTreeRefCount}('TPSSpecializedItem.SpecializedType'){$ENDIF};
end;
destructor TPSSpecializedItem.Destroy;
begin
SpecializedType:=nil;
inherited Destroy;
end;
{ TPasInheritedScope }
function TPasInheritedScope.FindIdentifier(const Identifier: String
@ -5412,7 +5479,9 @@ begin
else if (C=TPasPointerType) then
EmitTypeHints(El,TPasPointerType(El).DestType)
else if C=TPasGenericTemplateType then
FinishGenericTemplateType(TPasGenericTemplateType(El));
FinishGenericTemplateType(TPasGenericTemplateType(El))
else if C=TPasSpecializeType then
FinishSpecializeType(TPasSpecializeType(El));
end;
procedure TPasResolver.FinishEnumType(El: TPasEnumType);
@ -5538,6 +5607,32 @@ begin
ReleaseEvalValue(RgValue);
end;
procedure TPasResolver.FinishGenericTemplateTypes(aType: TPasGenericType);
var
C: TClass;
Scope: TPasIdentifierScope;
GenTemplates: TFPList;
i: Integer;
TemplType: TPasGenericTemplateType;
begin
// add template names to scope
C:=aType.ClassType;
if C.InheritsFrom(TPasMembersType) then
Scope:=aType.CustomData as TPasClassOrRecordScope
// ToDo: TPasArrayType
// ToDo: TPasProcedureType
else
RaiseMsg(20190726150359,nNotYetImplemented,sNotYetImplemented,[GetObjName(aType)],aType);
GenTemplates:=aType.GenericTemplateTypes;
if (GenTemplates=nil) or (GenTemplates.Count=0) then
RaiseMsg(20190726184902,nNotYetImplemented,sNotYetImplemented,['emty generic template list'],aType);
for i:=0 to GenTemplates.Count-1 do
begin
TemplType:=TPasGenericTemplateType(GenTemplates[i]);
AddIdentifier(Scope,TemplType.Name,TemplType,pikSimple);
end;
end;
procedure TPasResolver.FinishRecordType(El: TPasRecordType);
begin
if TopScope.Element=El then
@ -5940,6 +6035,50 @@ begin
end;
end;
procedure TPasResolver.FinishSpecializeType(El: TPasSpecializeType);
var
Params, GenericTemplateList: TFPList;
P: TPasElement;
DestType: TPasType;
i: Integer;
begin
// resolve Params
Params:=El.Params;
for i:=0 to Params.Count-1 do
begin
P:=TPasElement(Params[i]);
if P is TPasExpr then
ResolveExpr(TPasExpr(P),rraRead);
end;
if Params.Count=0 then
RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
// check DestType
GenericTemplateList:=nil;
DestType:=El.DestType;
if DestType=nil then
RaiseMsg(20190725184734,nIdentifierNotFound,sIdentifierNotFound,['specialize type'],El)
else if not (DestType is TPasGenericType) then
RaiseMsg(20190725193552,nXExpectedButYFound,sXExpectedButYFound,['generic type',DestType.Name],El);
GenericTemplateList:=TPasGenericType(DestType).GenericTemplateTypes;
if (GenericTemplateList<>nil)
and (GenericTemplateList.Count<>Params.Count) then
GenericTemplateList:=nil;
if GenericTemplateList=nil then
begin
// ToDO: resolve DestType using Params.Count
//FindElementWithoutParams();
//Data:=Default(TPRFindData);
//Data.ErrorPosEl:=El;
//Abort:=false;
//IterateElements(El.Name,@OnFindFirst_PreferNoParams,@Data,Abort);
RaiseMsg(20190725194222,nWrongNumberOfParametersForGenericType,sWrongNumberOfParametersForGenericType,['ToDo'],El);
end;
GetSpecializedType(El);
end;
procedure TPasResolver.FinishResourcestring(El: TPasResString);
var
ResolvedEl: TPasResolverResult;
@ -5950,6 +6089,19 @@ begin
RaiseXExpectedButYFound(20171004135753,'string',GetTypeDescription(ResolvedEl),El.Expr);
end;
procedure TPasResolver.FinishProcNameParts(aProc: TPasProcedure);
var
i, j: Integer;
begin
for i:=0 to length(aProc.NameParts)-1 do
with aProc.NameParts[i] do
begin
if Templates<>nil then
for j:=0 to Templates.Count-1 do
AddType(TPasGenericTemplateType(Templates[j]));
end;
end;
procedure TPasResolver.FinishProcedure(aProc: TPasProcedure);
var
i: Integer;
@ -13755,6 +13907,169 @@ begin
end;
end;
function TPasResolver.GetSpecializedType(El: TPasSpecializeType
): TPasGenericType;
var
Data: TPasSpecializeTypeData;
GenericType: TPasGenericType;
GenScope: TPasGenericScope;
Params: TFPList;
i, j: Integer;
Param: TPasElement;
ParamsResolved: TPasTypeArray;
ResolvedEl: TPasResolverResult;
SpecializedTypes: TObjectList;
Item: TPSSpecializedItem;
begin
Result:=nil;
if El.CustomData<>nil then
RaiseInternalError(20190726142522);
CheckSpecializeConstraints(El);
// spezialize: parsing implementation must be delayed until implementation section is complete
GenericType:=El.DestType as TPasGenericType;
if not (GenericType.CustomData is TPasGenericScope) then
RaiseMsg(20190726194316,nNotYetImplemented,sNotYetImplemented,[GetObjName(GenericType.CustomData)],El);
GenScope:=TPasGenericScope(GenericType.CustomData);
Params:=El.Params;
SetLength(ParamsResolved,Params.Count);
for i:=0 to Params.Count-1 do
begin
Param:=TPasElement(Params[i]);
ComputeElement(Param,ResolvedEl,[rcType]);
ParamsResolved[i]:=ResolvedEl.LoTypeEl;
end;
SpecializedTypes:=GenScope.SpecializedTypes;
if SpecializedTypes=nil then
begin
SpecializedTypes:=TObjectList.Create(true);
GenScope.SpecializedTypes:=SpecializedTypes;
end;
i:=SpecializedTypes.Count-1;
Item:=nil;
while i>=0 do
begin
Item:=TPSSpecializedItem(SpecializedTypes[i]);
j:=length(Item.Params);
while (j>=0) and (Item.Params[j]=ParamsResolved[j]) do dec(j);
if j<0 then
break;
Item:=nil;
dec(i);
end;
if Item<>nil then
begin
// already specialized
Result:=Item.SpecializedType;
end
else
begin
// new specialization
Item:=TPSSpecializedItem.Create;
Item.Params:=ParamsResolved;
SpecializedTypes.Add(Item);
// ToDo: create specilized type
RaiseMsg(20190726141738,nNotYetImplemented,sNotYetImplemented,['specialize'],El);
end;
Data:=TPasSpecializeTypeData.Create;
// add to free list
AddResolveData(El,Data,lkModule);
Data.SpecializedType:=Result;
end;
procedure TPasResolver.CheckSpecializeConstraints(El: TPasSpecializeType);
var
Params, GenericTemplateList: TFPList;
i, j: Integer;
P: TPasElement;
ParamType, DestType: TPasType;
ResolvedEl, ResolvedConstraint: TPasResolverResult;
GenTempl: TPasGenericTemplateType;
ConExpr: TPasExpr;
Value: String;
ConstraintClass: TPasClassType;
begin
Params:=El.Params;
DestType:=El.DestType;
if not (DestType is TPasGenericType) then
RaiseMsg(20190726193025,nXExpectedButYFound,sXExpectedButYFound,['generic type',DestType.Name],El);
GenericTemplateList:=TPasGenericType(DestType).GenericTemplateTypes;
if GenericTemplateList=nil then
RaiseMsg(20190726193048,nXExpectedButYFound,sXExpectedButYFound,['generic templates',DestType.Name],El);
if GenericTemplateList.Count<>Params.Count then
RaiseMsg(20190726193107,nXExpectedButYFound,sXExpectedButYFound,['type with '+IntToStr(Params.Count)+' generic templates',DestType.Name],El);
// check constraints
for i:=0 to Params.Count-1 do
begin
P:=TPasElement(Params[i]);
if P is TPasType then
ParamType:=TPasType(P)
else if P is TPasExpr then
begin
ComputeElement(P,ResolvedEl,[rcType]);
if not (ResolvedEl.IdentEl is TPasType) then
RaiseMsg(20190725195434,nXExpectedButYFound,sXExpectedButYFound,['type',GetResolverResultDescription(ResolvedEl)],P);
ParamType:=TPasType(ResolvedEl.IdentEl);
end;
GenTempl:=TPasGenericTemplateType(GenericTemplateList[i]);
for j:=0 to length(GenTempl.Constraints)-1 do
begin
ConExpr:=GenTempl.Constraints[j];
if (ConExpr.Kind=pekIdent) then
begin
Value:=TPrimitiveExpr(ConExpr).Value;
if SameText(Value,'record') then
begin
if not (ParamType is TPasRecordType) then
RaiseMsg(20190725200015,nXExpectedButYFound,sXExpectedButYFound,['record type',ParamType.Name],P);
continue;
end
else if SameText(Value,'class') or SameText(Value,'constructor') then
begin
if not (ParamType is TPasClassType) then
RaiseMsg(20190726133231,nXExpectedButYFound,sXExpectedButYFound,['class type',ParamType.Name],P);
if TPasClassType(ParamType).ObjKind<>okClass then
RaiseMsg(20190726133232,nXExpectedButYFound,sXExpectedButYFound,['class type',ParamType.Name],P);
if TPasClassType(ParamType).IsExternal then
RaiseMsg(20190726133233,nXExpectedButYFound,sXExpectedButYFound,['class type',ParamType.Name],P);
if SameText(Value,'constructor') then
begin
// check if ParamType has the default constructor
// ToDo
RaiseMsg(20190726133722,nXIsNotSupported,sXIsNotSupported,['constraint keyword construcor'],P);
end;
continue;
end;
end;
// constraint can be a class type or interface type
// Param must be a class
ComputeElement(ConExpr,ResolvedConstraint,[rcType]);
if ResolvedConstraint.IdentEl=nil then
RaiseMsg(20190726134037,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
if not (ResolvedConstraint.LoTypeEl is TPasClassType) then
RaiseMsg(20190726134223,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
ConstraintClass:=TPasClassType(ResolvedConstraint.LoTypeEl);
if not (ParamType is TPasClassType) then
RaiseIncompatibleType(20190726135859,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
case ConstraintClass.ObjKind of
okClass:
// Param must be a ConstraintClass
if CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible then
RaiseIncompatibleType(20190726135309,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
okInterface:
// ParamType must implement ConstraintClass
if GetClassImplementsIntf(TPasClassType(ParamType),ConstraintClass)=nil then
RaiseIncompatibleType(20190726135458,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
else
RaiseIncompatibleType(20190726135310,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
end;
end;
end;
end;
function TPasResolver.CheckAssignCompatibilityCustom(const LHS,
RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean;
var Handled: boolean): integer;
@ -15955,8 +16270,12 @@ begin
or (AClass=TPasProcedureType)
or (AClass=TPasFunctionType)
or (AClass=TPasSetType)
or (AClass=TPasRangeType) then
or (AClass=TPasRangeType)
or (AClass=TPasSpecializeType) then
AddType(TPasType(El))
else if AClass=TPasGenericTemplateType then
// TPasParser first collects template types and later adds them as a list
// they are not real types
else if AClass=TPasStringType then
begin
AddType(TPasType(El));
@ -16003,8 +16322,6 @@ begin
// resolved when finished
else if AClass=TPasImplCommand then
else if AClass=TPasAttributes then
else if AClass=TPasGenericTemplateType then
AddType(TPasType(El))
else if AClass=TPasUnresolvedUnitRef then
RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
else
@ -16687,6 +17004,11 @@ begin
stTypeSection: FinishTypeSection(El);
stTypeDef: FinishTypeDef(El as TPasType);
stResourceString: FinishResourcestring(El as TPasResString);
stGenericTypeTemplates:
if El is TPasGenericType then
FinishGenericTemplateTypes(TPasGenericType(El))
else
FinishProcNameParts(El as TPasProcedure);
stProcedure: FinishProcedure(El as TPasProcedure);
stProcedureHeader: FinishProcedureType(El as TPasProcedureType);
stExceptOnExpr: FinishExceptOnExpr;

205
packages/fcl-passrc/src/pastree.pp
View File

@ -508,6 +508,7 @@ type
public
function ElementTypeName: string; override;
end;
TPasTypeArray = array of TPasType;
{ TPasAliasType }
@ -549,12 +550,33 @@ type
function ElementTypeName: string; override;
end;
{ TPasClassOfType }
{ TPasGenericTemplateType }
TPasClassOfType = class(TPasAliasType)
TPasGenericTemplateType = Class(TPasType)
public
function ElementTypeName: string; override;
function GetDeclaration(full: boolean) : string; override;
destructor Destroy; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
procedure AddConstraint(Expr: TPasExpr);
Public
TypeConstraint: String deprecated; // deprecated in fpc 3.3.1
Constraints: TPasExprArray;
end;
{ TPasGenericType }
TPasGenericType = class(TPasType)
private
procedure ClearChildReferences(El: TPasElement; arg: pointer);
protected
procedure SetParent(const AValue: TPasElement); override;
public
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType, can be nil
destructor Destroy; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
procedure SetGenericTemplates(AList: TFPList); virtual;
end;
{ TPasSpecializeType DestType<Params> }
@ -588,6 +610,14 @@ type
Params: TFPList; // list of TPasType or TPasExpr
end;
{ TPasClassOfType }
TPasClassOfType = class(TPasAliasType)
public
function ElementTypeName: string; override;
function GetDeclaration(full: boolean) : string; override;
end;
{ TPasRangeType }
TPasRangeType = class(TPasType)
@ -605,27 +635,19 @@ type
{ TPasArrayType }
TPasArrayType = class(TPasType)
private
procedure ClearChildReferences(El: TPasElement; arg: pointer);
protected
procedure SetParent(const AValue: TPasElement); override;
TPasArrayType = class(TPasGenericType)
public
destructor Destroy; override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
public
IndexRange : string; // only valid if Parser po_arrayrangeexpr disabled
Ranges: TPasExprArray; // only valid if Parser po_arrayrangeexpr enabled
PackMode : TPackMode;
ElType: TPasType;
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType, can be nil
function IsGenericArray : Boolean;
function IsPacked : Boolean;
procedure AddRange(Range: TPasExpr);
procedure SetGenericTemplates(AList: TFPList); virtual;
end;
{ TPasFileType }
@ -701,22 +723,16 @@ type
{ TPasMembersType - base type for TPasRecordType and TPasClassType }
TPasMembersType = class(TPasType)
private
procedure ClearChildReferences(El: TPasElement; arg: pointer);
protected
procedure SetParent(const AValue: TPasElement); override;
TPasMembersType = class(TPasGenericType)
public
PackMode: TPackMode;
Members: TFPList;
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
Constructor Create(const AName: string; AParent: TPasElement); override;
Destructor Destroy; override;
Function IsPacked: Boolean;
Function IsBitPacked : Boolean;
Procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
Procedure SetGenericTemplates(AList: TFPList); virtual;
end;
{ TPasRecordType }
@ -737,23 +753,9 @@ type
Function IsAdvancedRecord : Boolean;
end;
{ TPasGenericTemplateType }
TPasGenericTemplateType = Class(TPasType)
public
destructor Destroy; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
procedure AddConstraint(Expr: TPasExpr);
Public
TypeConstraint: String deprecated; // deprecated in fpc 3.3.1
Constraints: TPasExprArray;
end;
TPasObjKind = (
okObject, okClass, okInterface,
// okGeneric removed in FPC 3.3.1 check instead GenericTemplateTypes.Count>0
// okGeneric removed in FPC 3.3.1 check instead GenericTemplateTypes<>nil
// okSpecialize removed in FPC 3.1.1
okClassHelper,okRecordHelper,okTypeHelper,
okDispInterface);
@ -823,7 +825,7 @@ type
{ TPasProcedureType }
TPasProcedureType = class(TPasType)
TPasProcedureType = class(TPasGenericType)
private
function GetIsNested: Boolean;
function GetIsOfObject: Boolean;
@ -1845,6 +1847,58 @@ begin
end;
end;
{ TPasGenericType }
procedure TPasGenericType.ClearChildReferences(El: TPasElement; arg: pointer);
begin
El.ClearTypeReferences(Self);
if arg=nil then ;
end;
procedure TPasGenericType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this array (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
end;
destructor TPasGenericType.Destroy;
begin
ReleaseGenericTemplateTypes(GenericTemplateTypes{$IFDEF CheckPasTreeRefCount},'TPasGenericType'{$ENDIF});
inherited Destroy;
end;
procedure TPasGenericType.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
if GenericTemplateTypes<>nil then
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
end;
procedure TPasGenericType.SetGenericTemplates(AList: TFPList);
var
I: Integer;
El: TPasElement;
begin
if GenericTemplateTypes=nil then
GenericTemplateTypes:=TFPList.Create;
For I:=0 to AList.Count-1 do
begin
El:=TPasElement(AList[i]);
El.Parent:=Self;
GenericTemplateTypes.Add(El);
end;
AList.Clear;
end;
{ TPasGenericTemplateType }
destructor TPasGenericTemplateType.Destroy;
@ -3078,28 +3132,10 @@ begin
inherited Destroy;
end;
procedure TPasArrayType.ClearChildReferences(El: TPasElement; arg: pointer);
begin
El.ClearTypeReferences(Self);
if arg=nil then ;
end;
procedure TPasArrayType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this array (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
end;
destructor TPasArrayType.Destroy;
var
i: Integer;
begin
ReleaseGenericTemplateTypes(GenericTemplateTypes{$IFDEF CheckPasTreeRefCount},'TPasArrayType'{$ENDIF});
for i:=0 to length(Ranges)-1 do
Ranges[i].Release{$IFDEF CheckPasTreeRefCount}('TPasArrayType.Ranges'){$ENDIF};
ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF});
@ -4088,18 +4124,6 @@ begin
Result:=Result+'const';
end;
procedure TPasArrayType.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
if GenericTemplateTypes<>nil then
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
ForEachChildCall(aMethodCall,Arg,ElType,true);
end;
function TPasArrayType.IsGenericArray: Boolean;
begin
Result:=GenericTemplateTypes<>nil;
@ -4119,22 +4143,6 @@ begin
Ranges[i]:=Range;
end;
procedure TPasArrayType.SetGenericTemplates(AList: TFPList);
var
I: Integer;
El: TPasElement;
begin
if GenericTemplateTypes=nil then
GenericTemplateTypes:=TFPList.Create;
For I:=0 to AList.Count-1 do
begin
El:=TPasElement(AList[i]);
El.Parent:=Self;
GenericTemplateTypes.Add(El);
end;
AList.Clear;
end;
function TPasFileType.GetDeclaration (full : boolean) : string;
begin
Result:='File';
@ -4224,23 +4232,6 @@ end;
{ TPasMembersType }
procedure TPasMembersType.ClearChildReferences(El: TPasElement; arg: pointer);
begin
El.ClearTypeReferences(Self);
if arg=nil then ;
end;
procedure TPasMembersType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this class/record (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
end;
constructor TPasMembersType.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
@ -4284,26 +4275,10 @@ var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
for i:=0 to Members.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
end;
procedure TPasMembersType.SetGenericTemplates(AList: TFPList);
var
I: Integer;
El: TPasElement;
begin
For I:=0 to AList.Count-1 do
begin
El:=TPasElement(AList[i]);
El.Parent:=Self;
GenericTemplateTypes.Add(El);
end;
AList.Clear;
end;
{ TPasRecordType }
procedure TPasRecordType.GetMembers(S: TStrings);

39
packages/fcl-passrc/src/pparser.pp
View File

@ -169,6 +169,7 @@ type
stTypeSection,
stTypeDef, // e.g. a TPasType
stResourceString, // e.g. TPasResString
stGenericTypeTemplates, // called after TPasGenericType.SetGenericTemplates or TPasProcedure.setNameParts
stProcedure, // also method, procedure, constructor, destructor, ...
stProcedureHeader,
stWithExpr, // calls BeginScope after parsing every WITH-expression
@ -3354,6 +3355,13 @@ var
Scanner.SetForceCaret(NewBlock=declType);
end;
procedure InitGenericType(NewEl: TPasGenericType; GenericTemplateTypes: TFPList);
begin
Declarations.Declarations.Add(NewEl);
NewEl.SetGenericTemplates(GenericTemplateTypes);
Engine.FinishScope(stGenericTypeTemplates,NewEl);
end;
var
ConstEl: TPasConst;
ResStrEl: TPasResString;
@ -3365,13 +3373,14 @@ var
ExpEl: TPasExportSymbol;
PropEl : TPasProperty;
TypeName: String;
PT : TProcType;
PT , ProcType: TProcType;
NamePos: TPasSourcePos;
ok: Boolean;
Proc: TPasProcedure;
RecordEl: TPasRecordType;
Attr: TPasAttributes;
CurEl: TPasElement;
ProcTypeEl: TPasProcedureType;
begin
CurBlock := declNone;
HadTypeSection:=false;
@ -3600,9 +3609,8 @@ begin
begin
ClassEl := TPasClassType(CreateElement(TPasClassType,
TypeName, Declarations, NamePos));
Declarations.Declarations.Add(ClassEl);
Declarations.Classes.Add(ClassEl);
ClassEl.SetGenericTemplates(List);
InitGenericType(ClassEl,List);
NextToken;
DoParseClassType(ClassEl);
CheckHint(ClassEl,True);
@ -3612,9 +3620,8 @@ begin
begin
RecordEl := TPasRecordType(CreateElement(TPasRecordType,
TypeName, Declarations, NamePos));
Declarations.Declarations.Add(RecordEl);
Declarations.Classes.Add(RecordEl);
RecordEl.SetGenericTemplates(List);
InitGenericType(RecordEl,List);
NextToken;
ParseRecordMembers(RecordEl,tkend,
(msAdvancedRecords in Scanner.CurrentModeSwitches)
@ -3626,13 +3633,28 @@ begin
tkArray:
begin
ArrEl := TPasArrayType(CreateElement(TPasArrayType, TypeName, Declarations, NamePos));
Declarations.Declarations.Add(ArrEl);
Declarations.Types.Add(ArrEl);
ArrEl.SetGenericTemplates(List);
InitGenericType(ArrEl,List);
DoParseArrayType(ArrEl);
CheckHint(ArrEl,True);
Engine.FinishScope(stTypeDef,ArrEl);
end;
tkprocedure,tkfunction:
begin
if CurToken=tkFunction then
begin
ProcTypeEl := CreateFunctionType(TypeName, 'Result', Declarations, False, NamePos);
ProcType:=ptFunction;
end
else
begin
ProcTypeEl := TPasProcedureType(CreateElement(TPasProcedureType, TypeName, Declarations, NamePos));
ProcType:=ptProcedure;
end;
Declarations.Functions.Add(ProcTypeEl);
InitGenericType(ProcTypeEl,List);
ParseProcedureOrFunction(ProcTypeEl, ProcTypeEl, ProcType, True);
end;
else
ParseExc(nParserGenericClassOrArray,SParserGenericClassOrArray);
end;
@ -6389,7 +6411,10 @@ begin
Parent:=CheckIfOverLoaded(Parent,Name);
Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility));
if NameParts<>nil then
begin
Result.SetNameParts(NameParts);
Engine.FinishScope(stGenericTypeTemplates,Result);
end;
case ProcType of
ptFunction, ptClassFunction, ptOperator, ptClassOperator, ptAnonymousFunction:

14
packages/fcl-passrc/tests/tcgenerics.pp
View File

@ -16,8 +16,9 @@ Type
Procedure TestObjectGenerics;
Procedure TestRecordGenerics;
Procedure TestArrayGenerics;
Procedure TestProcTypeGenerics;
Procedure TestGenericConstraint;
Procedure TestGenericInterfaceConstraint; // ToDo
Procedure TestGenericInterfaceConstraint;
Procedure TestDeclarationConstraint;
Procedure TestSpecializationDelphi;
Procedure TestDeclarationDelphi;
@ -61,6 +62,17 @@ begin
Add([
'Type',
' Generic TSome<T> = array of T;',
' Generic TStatic<R,T> = array[R] of T;',
'']);
ParseDeclarations;
end;
procedure TTestGenerics.TestProcTypeGenerics;
begin
Add([
'Type',
' Generic TSome<T> = procedure(v: T);',
' Generic TFunc<R,T> = function(b: R): T;',
'']);
ParseDeclarations;
end;

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

@ -5,7 +5,7 @@ unit tcresolvegenerics;
interface
uses
Classes, SysUtils, testregistry, tcresolver, PasResolveEval;
Classes, SysUtils, testregistry, tcresolver, PasResolveEval, PParser;
type
@ -14,13 +14,21 @@ type
TTestResolveGenerics = Class(TCustomTestResolver)
Published
procedure TestGen_GenericFunction; // ToDo
procedure TestGen_MissingTemplateFail;
procedure TestGen_ConstraintStringFail;
procedure TestGen_ConstraintMultiClassFail;
procedure TestGen_ConstraintRecordExpectedFail;
// ToDo: constraint keyword record
// ToDo: constraint keyword class, constructor, class+constructor
// ToDo: constraint Unit2.TBird
// ToDo: constraint Unit2.TGen<word>
procedure TestGen_GenericNotFoundFail;
procedure TestGen_RecordLocalNameDuplicateFail;
procedure TestGen_Record;
// ToDo: generic class
// ToDo: generic interface
// ToDo: generic array
// ToDo: generic procedure type
end;
implementation
@ -44,6 +52,16 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_MissingTemplateFail;
begin
StartProgram(false);
Add([
'type generic g< > = array of word;',
'begin',
'']);
CheckParserException('Expected "Identifier"',nParserExpectTokenError);
end;
procedure TTestResolveGenerics.TestGen_ConstraintStringFail;
begin
StartProgram(false);
@ -77,6 +95,66 @@ begin
nConstraintXAndConstraintYCannotBeTogether);
end;
procedure TTestResolveGenerics.TestGen_ConstraintRecordExpectedFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' generic TBird<T:record> = record v: T; end;',
'var r: specialize TBird<word>;',
'begin',
'']);
CheckResolverException('record type expected, but Word found',
nXExpectedButYFound);
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_RecordLocalNameDuplicateFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' generic TBird<T> = record T: word; end;',
'begin',
'']);
CheckResolverException('Duplicate identifier "T" at afile.pp(4,18)',
nDuplicateIdentifier);
end;
procedure TTestResolveGenerics.TestGen_Record;
begin
exit; // ToDo
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' {#Typ}T = word;',
' generic TRec<{#Templ}T> = record',
' {=Templ}v: T;',
' end;',
'var',
' r: specialize TRec<word>;',
' {=Typ}w: T;',
'begin',
' r.v:=w;',
'']);
ParseProgram;
end;
initialization
RegisterTests([TTestResolveGenerics]);