fcl-passrc: added TPasGenericType

git-svn-id: trunk@42502 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -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 }

packages/fcl-passrc/src/pasresolver.pp

@@ -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;

packages/fcl-passrc/src/pastree.pp

@@ -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);

packages/fcl-passrc/src/pparser.pp

@@ -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:

packages/fcl-passrc/tests/tcgenerics.pp

@@ -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;

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -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]);