administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Add generic interface support: IFoo<T> = interface...end

Browse source 
Implements full generic interface support through the compiler pipeline:

Parser: TGenericInterfaceDef AST node; IDENT<TypeParams> = interface...end
syntax; ParseGenericName helper for class(IFoo<T>) parent/implements lists.

AST: TGenericInterfaceDef (ParamNames + IntfDef) and TGenericInterfaceInstance
(mangled InstName + TypeDesc) tracked on TProgram.GenericIntfInstances.

Symbol table: TInterfaceTypeDesc extended with FReturnTypes parallel list so
interface dispatch expressions can resolve return types.

Semantic: InstantiateGenericInterface instantiates IFoo<T> on demand from a
template; FindTypeOrInstantiate falls through class→interface; parent-as-interface
detection moves IFoo<Integer> from ParentName to ImplementsNames; type-safe
guard in InstantiateGeneric prevents misidentifying interface templates as class
templates; AnalyseMethodCallExpr extended with interface dispatch path.

Codegen: EmitInterfaceDefs emits typeinfo for GenericIntfInstances using the
mangled name (IEqualityComparer_Integer); itab/impllist names QBEMangle interface
names; EmitExpr TMethodCallExpr handles interface dispatch via itab pointer.

13 new tests in cp.test.genericintfs covering parser, semantic, and codegen.
This commit is contained in:
Graeme Geldenhuys 2026-04-22 10:17:30 +01:00
parent f05982f8c5
commit e30757fef3
8 changed files with 761 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
compiler/src/main/pascal/uAST.pas
View file

@ -334,6 +334,26 @@ type
destructor Destroy; override;
end;
{ Generic interface template: type IFoo<T> = interface ... end }
TGenericInterfaceDef = class(TASTTypeDef)
public
ParamNames: TStringList; { owned — type parameter names, e.g. ['T'] }
IntfDef: TInterfaceTypeDef; { owned — template interface body with unresolved param types }
constructor Create;
destructor Destroy; override;
end;
{ One concrete instantiation of a generic interface — stored on TProgram.
Codegen iterates this list to emit typeinfo data. }
TGenericInterfaceInstance = class
public
InstName: string; { mangled name e.g. 'IEqualityComparer_Integer' }
IntfDef: TInterfaceTypeDef; { owned — cloned with substituted type names }
TypeDesc: TTypeDesc; { non-owned — points to TInterfaceTypeDesc in SymbolTable }
constructor Create;
destructor Destroy; override;
end;
TTypeDecl = class(TASTNode)
public
Name: string;
@ -363,6 +383,7 @@ type
SymbolTable: TSymbolTable; { owned after semantic analysis; nil before }
GenericInstances: TObjectList; { owned TGenericInstance — populated by uSemantic }
GenericFuncInstances: TObjectList; { owned TGenericFuncInstance — populated by uSemantic }
GenericIntfInstances: TObjectList; { owned TGenericInterfaceInstance — populated by uSemantic }
constructor Create;
destructor Destroy; override;
end;
@ -712,6 +733,36 @@ begin
inherited Destroy;
end;
{ TGenericInterfaceDef }
constructor TGenericInterfaceDef.Create;
begin
inherited Create;
ParamNames := TStringList.Create;
IntfDef := TInterfaceTypeDef.Create;
end;
destructor TGenericInterfaceDef.Destroy;
begin
IntfDef.Free;
ParamNames.Free;
inherited Destroy;
end;
{ TGenericInterfaceInstance }
constructor TGenericInterfaceInstance.Create;
begin
inherited Create;
IntfDef := TInterfaceTypeDef.Create;
end;
destructor TGenericInterfaceInstance.Destroy;
begin
IntfDef.Free;
inherited Destroy;
end;
{ TGenericInstance }
constructor TGenericInstance.Create;
@ -762,10 +813,12 @@ begin
UsedUnits := TStringList.Create;
GenericInstances := TObjectList.Create(True);
GenericFuncInstances := TObjectList.Create(True);
GenericIntfInstances := TObjectList.Create(True);
end;
destructor TProgram.Destroy;
begin
GenericIntfInstances.Free;
GenericFuncInstances.Free;
GenericInstances.Free;
SymbolTable.Free;

66
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -1008,8 +1008,10 @@ var
ItabLine: string;
ImplLine: string;
MethName: string;
IntfMangle: string;
GII: TGenericInterfaceInstance;
begin
{ Typeinfo blocks for every interface }
{ Typeinfo blocks for every plain interface }
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
TD := TTypeDecl(AProg.Block.TypeDecls[I]);
@ -1017,6 +1019,13 @@ begin
EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }');
end;
{ Typeinfo blocks for generic interface instantiations }
for I := 0 to AProg.GenericIntfInstances.Count - 1 do
begin
GII := TGenericInterfaceInstance(AProg.GenericIntfInstances[I]);
EmitLine('data $typeinfo_' + GII.InstName + ' = { l 0 }');
end;
{ Itab and impllist blocks for each implementing class }
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
@ -1030,8 +1039,9 @@ begin
{ One itab per interface }
for J := 0 to ClassRT.ImplementsCount - 1 do
begin
IntfDesc := ClassRT.ImplementsIntfAt(J);
ItabLine := 'data $itab_' + TD.Name + '_' + IntfDesc.Name + ' = {';
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfMangle := QBEMangle(IntfDesc.Name);
ItabLine := 'data $itab_' + TD.Name + '_' + IntfMangle + ' = {';
for K := 0 to IntfDesc.MethodCount - 1 do
begin
MethName := IntfDesc.MethodName(K);
@ -1048,13 +1058,14 @@ begin
ImplLine := 'data $impllist_' + TD.Name + ' = {';
for J := 0 to ClassRT.ImplementsCount - 1 do
begin
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfMangle := QBEMangle(IntfDesc.Name);
if J = 0 then
ImplLine := ImplLine + ' l $typeinfo_' + IntfDesc.Name +
', l $itab_' + TD.Name + '_' + IntfDesc.Name
ImplLine := ImplLine + ' l $typeinfo_' + IntfMangle +
', l $itab_' + TD.Name + '_' + IntfMangle
else
ImplLine := ImplLine + ', l $typeinfo_' + IntfDesc.Name +
', l $itab_' + TD.Name + '_' + IntfDesc.Name;
ImplLine := ImplLine + ', l $typeinfo_' + IntfMangle +
', l $itab_' + TD.Name + '_' + IntfMangle;
end;
ImplLine := ImplLine + ', l 0 }';
EmitLine(ImplLine);
@ -1359,6 +1370,10 @@ var
RT: TRecordTypeDesc;
FuncName: string;
I: Integer;
IntfDesc: TInterfaceTypeDesc;
VTblTemp: string;
FPtrTemp: string;
SlotOff: Integer;
begin
if AExpr is TFuncCallExpr then
begin
@ -1436,6 +1451,41 @@ begin
if AExpr is TMethodCallExpr then
begin
MCallExpr := TMethodCallExpr(AExpr);
{ Interface method call expression: dispatch through itab }
if (MCallExpr.ResolvedClassType <> nil) and
(MCallExpr.ResolvedClassType.Kind = tyInterface) then
begin
IntfDesc := TInterfaceTypeDesc(MCallExpr.ResolvedClassType);
SelfTemp := AllocTemp;
EmitLine(Format(' %s =l loadl %%_var_%s_obj',
[SelfTemp, MCallExpr.ObjectName]));
VTblTemp := AllocTemp;
EmitLine(Format(' %s =l loadl %%_var_%s_itab',
[VTblTemp, MCallExpr.ObjectName]));
SlotOff := IntfDesc.MethodIndex(MCallExpr.Name) * 8;
FPtrTemp := AllocTemp;
if SlotOff = 0 then
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, VTblTemp]))
else
begin
ArgTemp := AllocTemp;
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
end;
{ Evaluate arguments before the call }
ArgLine := Format('l %s', [SelfTemp]);
for I := 0 to MCallExpr.Args.Count - 1 do
begin
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args[I]));
ArgLine := ArgLine + Format(', w %s', [ArgTemp]);
end;
T := AllocTemp;
EmitLine(Format(' %s =w call %%%s(%s)', [T, FPtrTemp, ArgLine]));
Result := T;
Exit;
end;
RT := TRecordTypeDesc(MCallExpr.ResolvedClassType);
MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
if MDecl.OwnerTypeName <> '' then

77
compiler/src/main/pascal/uParser.pas
View file

@ -56,6 +56,7 @@ type
procedure ParseTypeSection(ABlock: TBlock);
procedure ParseTypeDecl(ABlock: TBlock);
function ParseRecordDef: TRecordTypeDef;
function ParseGenericName: string; { reads IDENT optionally followed by '<' TypeArgs '>' }
function ParseClassDef: TClassTypeDef;
function ParseInterfaceDef: TInterfaceTypeDef;
procedure ParseFieldDecl(AFields: TObjectList);
@ -290,6 +291,7 @@ procedure TParser.ParseTypeDecl(ABlock: TBlock);
var
TD: TTypeDecl;
GD: TGenericTypeDef;
GID: TGenericInterfaceDef;
ParamNames: TStringList;
IsGeneric: Boolean;
begin
@ -302,7 +304,7 @@ begin
[FCurrent.Line, FCurrent.Col]);
TD.Name := FCurrent.Value;
Advance;
{ Check for generic type parameters: TBox<T> or TPair<K, V> }
{ Check for generic type parameters: TBox<T>, TPair<K,V>, IFoo<T> }
IsGeneric := Check(tkLessThan);
if IsGeneric then
begin
@ -327,17 +329,30 @@ begin
end;
Expect(tkGreaterThan);
Expect(tkEquals);
if not Check(tkClass) then
raise EParseError.CreateFmt(
'Generic type must be a class at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
GD := TGenericTypeDef.Create;
GD.Line := TD.Line;
GD.Col := TD.Col;
GD.ParamNames.AddStrings(ParamNames);
GD.ClassDef.Free;
GD.ClassDef := ParseClassDef;
TD.Def := GD;
if Check(tkIntf) then
begin
GID := TGenericInterfaceDef.Create;
GID.Line := TD.Line;
GID.Col := TD.Col;
GID.ParamNames.AddStrings(ParamNames);
GID.IntfDef.Free;
GID.IntfDef := ParseInterfaceDef;
TD.Def := GID;
end
else
begin
if not Check(tkClass) then
raise EParseError.CreateFmt(
'Generic type must be a class or interface at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
GD := TGenericTypeDef.Create;
GD.Line := TD.Line;
GD.Col := TD.Col;
GD.ParamNames.AddStrings(ParamNames);
GD.ClassDef.Free;
GD.ClassDef := ParseClassDef;
TD.Def := GD;
end;
finally
ParamNames.Free;
end;
@ -380,6 +395,31 @@ begin
end;
end;
function TParser.ParseGenericName: string;
var
TypeArgs: string;
begin
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected identifier at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result := FCurrent.Value;
Advance;
if Check(tkLessThan) then
begin
Advance; { consume '<' }
TypeArgs := FCurrent.Value;
Advance;
while Check(tkComma) do
begin
Advance;
TypeArgs := TypeArgs + ',' + FCurrent.Value;
Advance;
end;
Expect(tkGreaterThan);
Result := Result + '<' + TypeArgs + '>';
end;
end;
function TParser.ParseClassDef: TClassTypeDef;
begin
Result := TClassTypeDef.Create;
@ -390,20 +430,13 @@ begin
if Check(tkLParen) then
begin
Advance;
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected parent class name at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result.ParentName := FCurrent.Value;
Advance;
{ First name may be a plain class name or a generic interface name like IFoo<T> }
Result.ParentName := ParseGenericName;
{ Additional names after a comma are implemented interface names }
while Check(tkComma) do
begin
Advance;
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected interface name at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result.ImplementsNames.Add(FCurrent.Value);
Advance;
Result.ImplementsNames.Add(ParseGenericName);
end;
Expect(tkRParen);
end;

196
compiler/src/main/pascal/uSemantic.pas
View file

@ -31,6 +31,7 @@ type
{ Generic type instantiation: resolves 'TBox<Integer>' on demand. }
function FindTypeOrInstantiate(const AName: string): TTypeDesc;
function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
function InstantiateGenericInterface(const ATypeName: string): TInterfaceTypeDesc;
function SubstTypeParam(const ATypeName: string;
AParamNames, AArgs: TStringList): string;
@ -364,7 +365,11 @@ begin
Exit;
end;
if Pos('<', AName) > 0 then
begin
Result := InstantiateGeneric(AName);
if Result = nil then
Result := InstantiateGenericInterface(AName);
end;
end;
function TSemanticAnalyser.SubstTypeParam(const ATypeName: string;
@ -435,6 +440,8 @@ begin
end;
end;
{ Bail if the template exists but is a generic interface, not a class }
if not (FTable.FindGeneric(BaseName) is TGenericTypeDef) then Exit;
Templ := TGenericTypeDef(FTable.FindGeneric(BaseName));
if Templ = nil then Exit;
if Args.Count <> Templ.ParamNames.Count then Exit;
@ -590,6 +597,87 @@ begin
end;
end;
function TSemanticAnalyser.InstantiateGenericInterface(const ATypeName: string): TInterfaceTypeDesc;
var
BracPos: Integer;
BaseName: string;
ArgsStr: string;
Args: TStringList;
Templ: TGenericInterfaceDef;
TemplObj: TObject;
I: Integer;
MDecl: TMethodDecl;
Sym: TSymbol;
GII: TGenericInterfaceInstance;
MangledName: string;
begin
Result := nil;
BracPos := Pos('<', ATypeName);
if BracPos = 0 then Exit;
BaseName := Copy(ATypeName, 1, BracPos - 1);
ArgsStr := Copy(ATypeName, BracPos + 1, Length(ATypeName) - BracPos - 1);
Args := TStringList.Create;
try
while ArgsStr <> '' do
begin
BracPos := Pos(',', ArgsStr);
if BracPos > 0 then
begin
Args.Add(Trim(Copy(ArgsStr, 1, BracPos - 1)));
ArgsStr := Trim(Copy(ArgsStr, BracPos + 1, MaxInt));
end
else
begin
Args.Add(Trim(ArgsStr));
ArgsStr := '';
end;
end;
TemplObj := FTable.FindGeneric(BaseName);
if (TemplObj = nil) or not (TemplObj is TGenericInterfaceDef) then Exit;
Templ := TGenericInterfaceDef(TemplObj);
if Args.Count <> Templ.ParamNames.Count then Exit;
{ Check if already instantiated }
Sym := FTable.Lookup(ATypeName);
if (Sym <> nil) and (Sym.TypeDesc is TInterfaceTypeDesc) then
begin
Result := TInterfaceTypeDesc(Sym.TypeDesc);
Exit;
end;
{ Build mangled name: IEqualityComparer<Integer> → IEqualityComparer_Integer }
MangledName := BaseName;
for I := 0 to Args.Count - 1 do
MangledName := MangledName + '_' + Args[I];
{ Create the concrete interface type descriptor }
Result := FTable.NewInterfaceType(ATypeName);
Sym := TSymbol.Create(ATypeName, skType, Result);
FTable.DefineGlobal(Sym);
{ Register interface method names with substituted return types }
for I := 0 to Templ.IntfDef.Methods.Count - 1 do
begin
MDecl := TMethodDecl(Templ.IntfDef.Methods[I]);
Result.AddMethod(MDecl.Name,
SubstTypeParam(MDecl.ReturnTypeName, Templ.ParamNames, Args));
end;
{ Register the instantiation for codegen }
GII := TGenericInterfaceInstance.Create;
GII.InstName := MangledName;
GII.IntfDef.Free;
GII.IntfDef := nil;
GII.TypeDesc := Result;
FProg.GenericIntfInstances.Add(GII);
finally
Args.Free;
end;
end;
function TSemanticAnalyser.InstantiateGenericFunc(const AInstName: string): TMethodDecl;
var
BracPos: Integer;
@ -764,6 +852,12 @@ begin
FTable.RegisterGeneric(TD.Name, TD.Def);
Continue;
end
else if TD.Def is TGenericInterfaceDef then
begin
{ Register as template — instantiated on demand when used as type name }
FTable.RegisterGeneric(TD.Name, TD.Def);
Continue;
end
else if TD.Def is TInterfaceTypeDef then
begin
IntfDesc := FTable.NewInterfaceType(TD.Name);
@ -796,6 +890,7 @@ begin
{ Generic templates have no concrete descriptor — skip }
if TD.Def is TGenericTypeDef then Continue;
if TD.Def is TGenericInterfaceDef then Continue;
{ Interface types: register methods and resolve optional parent }
if TD.Def is TInterfaceTypeDef then
@ -814,10 +909,12 @@ begin
IntfDesc.Parent := TInterfaceTypeDesc(Sym.TypeDesc);
{ Inherit parent methods }
for J := 0 to IntfDesc.Parent.MethodCount - 1 do
IntfDesc.AddMethod(IntfDesc.Parent.MethodName(J));
IntfDesc.AddMethod(IntfDesc.Parent.MethodName(J),
IntfDesc.Parent.MethodReturnTypeName(J));
end;
for J := 0 to ITD.Methods.Count - 1 do
IntfDesc.AddMethod(TMethodDecl(ITD.Methods[J]).Name);
IntfDesc.AddMethod(TMethodDecl(ITD.Methods[J]).Name,
TMethodDecl(ITD.Methods[J]).ReturnTypeName);
Continue;
end;
@ -834,22 +931,42 @@ begin
FieldList := TClassTypeDef(TD.Def).Fields;
MethodList := TClassTypeDef(TD.Def).Methods;
{ Copy inherited fields and vtable from parent class first }
{ Copy inherited fields and vtable from parent class first.
The parser may store a generic interface name (e.g. IFoo<T>) as ParentName
when no explicit class parent was specified — detect this and treat it as
an implements entry instead. }
if TClassTypeDef(TD.Def).ParentName <> '' then
begin
ParentSym := FTable.Lookup(TClassTypeDef(TD.Def).ParentName);
if (ParentSym = nil) or not (ParentSym.TypeDesc is TRecordTypeDesc) then
SemanticError(
Format('Unknown parent class ''%s'' for ''%s''',
[TClassTypeDef(TD.Def).ParentName, TD.Name]),
TD.Line, TD.Col);
ParentRT := TRecordTypeDesc(ParentSym.TypeDesc);
RT.Parent := ParentRT;
RT.CopyVTableFrom(ParentRT);
for K := 0 to ParentRT.Fields.Count - 1 do
ParentSym := nil;
{ If name looks generic, try instantiating as interface first }
if Pos('<', TClassTypeDef(TD.Def).ParentName) > 0 then
begin
FldInfo := TFieldInfo(ParentRT.Fields[K]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
IntfDesc := TInterfaceTypeDesc(
FindTypeOrInstantiate(TClassTypeDef(TD.Def).ParentName));
if IntfDesc <> nil then
begin
{ Treat it as an interface to implement — move to implements list }
TClassTypeDef(TD.Def).ImplementsNames.Insert(
0, TClassTypeDef(TD.Def).ParentName);
TClassTypeDef(TD.Def).ParentName := '';
end;
end;
if TClassTypeDef(TD.Def).ParentName <> '' then
begin
ParentSym := FTable.Lookup(TClassTypeDef(TD.Def).ParentName);
if (ParentSym = nil) or not (ParentSym.TypeDesc is TRecordTypeDesc) then
SemanticError(
Format('Unknown parent class ''%s'' for ''%s''',
[TClassTypeDef(TD.Def).ParentName, TD.Name]),
TD.Line, TD.Col);
ParentRT := TRecordTypeDesc(ParentSym.TypeDesc);
RT.Parent := ParentRT;
RT.CopyVTableFrom(ParentRT);
for K := 0 to ParentRT.Fields.Count - 1 do
begin
FldInfo := TFieldInfo(ParentRT.Fields[K]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
end;
end;
end;
@ -966,6 +1083,17 @@ begin
begin
IntfName := TClassTypeDef(TD.Def).ImplementsNames[L];
IntfSym := FTable.Lookup(IntfName);
if IntfSym = nil then
begin
{ May be a generic interface — try instantiation }
IntfDesc := TInterfaceTypeDesc(FindTypeOrInstantiate(IntfName));
if IntfDesc = nil then
SemanticError(
Format('Unknown interface ''%s'' in implements list of ''%s''',
[IntfName, TD.Name]),
TD.Line, TD.Col);
IntfSym := FTable.Lookup(IntfName);
end;
if (IntfSym = nil) or not (IntfSym.TypeDesc is TInterfaceTypeDesc) then
SemanticError(
Format('Unknown interface ''%s'' in implements list of ''%s''',
@ -1702,12 +1830,13 @@ end;
function TSemanticAnalyser.AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc;
var
ObjSym: TSymbol;
RT: TRecordTypeDesc;
MDecl: TMethodDecl;
Par: TMethodParam;
ArgType: TTypeDesc;
I: Integer;
ObjSym: TSymbol;
RT: TRecordTypeDesc;
MDecl: TMethodDecl;
Par: TMethodParam;
ArgType: TTypeDesc;
I: Integer;
IntfDesc: TInterfaceTypeDesc;
begin
ObjSym := FTable.Lookup(AExpr.ObjectName);
if ObjSym = nil then
@ -1718,11 +1847,32 @@ begin
SemanticError(
Format('''%s'' is not a variable', [AExpr.ObjectName]),
AExpr.Line, AExpr.Col);
if ObjSym.TypeDesc.Kind <> tyClass then
if not (ObjSym.TypeDesc.Kind in [tyClass, tyInterface]) then
SemanticError(
Format('''%s'' is not a class variable', [AExpr.ObjectName]),
Format('''%s'' is not a class or interface variable', [AExpr.ObjectName]),
AExpr.Line, AExpr.Col);
{ Interface method call expression: dispatch through itab }
if ObjSym.TypeDesc.Kind = tyInterface then
begin
IntfDesc := TInterfaceTypeDesc(ObjSym.TypeDesc);
if not IntfDesc.HasMethod(AExpr.Name) then
SemanticError(
Format('Interface ''%s'' has no method ''%s''',
[ObjSym.TypeDesc.Name, AExpr.Name]),
AExpr.Line, AExpr.Col);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args[I]));
AExpr.ResolvedClassType := ObjSym.TypeDesc;
AExpr.ResolvedMethod := nil; { nil = interface dispatch }
{ Look up return type from interface method descriptor }
Result := FindTypeOrInstantiate(
IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name)));
if Result = nil then
Result := FTable.TypeInteger; { fallback for void/unknown }
Exit;
end;
RT := TRecordTypeDesc(ObjSym.TypeDesc);
MDecl := FindMethodDecl(RT.Name, AExpr.Name);
if MDecl = nil then

30
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -119,15 +119,18 @@ type
{ Type descriptor for zero-GUID interface types (Phase 3). }
TInterfaceTypeDesc = class(TTypeDesc)
private
FMethods: TStringList; { method names, case-insensitive sorted }
FParent: TInterfaceTypeDesc; { not owned; nil if no parent }
FMethods: TStringList; { method names, case-insensitive }
FReturnTypes: TStringList; { parallel: return type name, '' = procedure }
FParent: TInterfaceTypeDesc; { not owned; nil if no parent }
public
constructor Create(const AName: string);
destructor Destroy; override;
procedure AddMethod(const AName: string);
procedure AddMethod(const AName: string;
const AReturnTypeName: string = '');
function HasMethod(const AName: string): Boolean;
function MethodCount: Integer;
function MethodName(AIndex: Integer): string;
function MethodReturnTypeName(AIndex: Integer): string;
function MethodIndex(const AName: string): Integer;
property Parent: TInterfaceTypeDesc read FParent write FParent;
end;
@ -506,22 +509,26 @@ end;
constructor TInterfaceTypeDesc.Create(const AName: string);
begin
inherited Create;
Kind := tyInterface;
Name := AName;
FMethods := TStringList.Create;
FMethods.CaseSensitive := False; { unsorted — preserves declaration order }
FParent := nil;
Kind := tyInterface;
Name := AName;
FMethods := TStringList.Create;
FMethods.CaseSensitive := False;
FReturnTypes := TStringList.Create;
FParent := nil;
end;
destructor TInterfaceTypeDesc.Destroy;
begin
FReturnTypes.Free;
FMethods.Free;
inherited Destroy;
end;
procedure TInterfaceTypeDesc.AddMethod(const AName: string);
procedure TInterfaceTypeDesc.AddMethod(const AName: string;
const AReturnTypeName: string);
begin
FMethods.Add(AName);
FReturnTypes.Add(AReturnTypeName);
end;
function TInterfaceTypeDesc.HasMethod(const AName: string): Boolean;
@ -539,6 +546,11 @@ begin
Result := FMethods[AIndex];
end;
function TInterfaceTypeDesc.MethodReturnTypeName(AIndex: Integer): string;
begin
Result := FReturnTypes[AIndex];
end;
function TInterfaceTypeDesc.MethodIndex(const AName: string): Integer;
begin
Result := FMethods.IndexOf(AName);

3
compiler/src/test/pascal/TestRunner.pas
View file

@ -34,7 +34,8 @@ uses
cp.test.properties,
cp.test.genericfuncs,
cp.test.pointers,
cp.test.tlist;
cp.test.tlist,
cp.test.genericintfs;
var
Application: TTestRunner;

373
compiler/src/test/pascal/cp.test.genericintfs.pas Normal file
View file

@ -0,0 +1,373 @@
unit cp.test.genericintfs;
{$mode objfpc}{$H+}
{ Tests for generic interfaces: IFoo<T> = interface ... end, class implements
IFoo<Integer>, and codegen for the resulting itab/typeinfo. }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TGenericIntfTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
published
{ ------------------------------------------------------------------ }
{ Parser }
{ ------------------------------------------------------------------ }
procedure TestParse_GenericIntf_IsGenericInterfaceDef;
procedure TestParse_GenericIntf_ParamName;
procedure TestParse_GenericIntf_TwoParams;
procedure TestParse_GenericIntf_MethodUsesTypeParam;
procedure TestParse_Class_ImplementsGenericIntf_InParenList;
{ ------------------------------------------------------------------ }
{ Semantic }
{ ------------------------------------------------------------------ }
procedure TestSemantic_GenericIntf_InstantiatesOnVarDecl;
procedure TestSemantic_GenericIntf_InstantiatedType_IsInterface;
procedure TestSemantic_Class_ImplementsGenericIntf_OK;
procedure TestSemantic_GenericIntf_MethodParamsSubstituted;
{ ------------------------------------------------------------------ }
{ Codegen }
{ ------------------------------------------------------------------ }
procedure TestCodegen_GenericIntf_TypeinfoEmitted;
procedure TestCodegen_GenericIntf_ItabEmitted;
procedure TestCodegen_GenericIntf_ImpllistEmitted;
procedure TestCodegen_GenericIntf_MethodDispatch_EmitsIndirectCall;
end;
implementation
{ ------------------------------------------------------------------ }
{ Source constants }
{ ------------------------------------------------------------------ }
const
SrcGenericIntfOneParam =
'program P;' + LineEnding +
'type' + LineEnding +
' IComparer<T> = interface' + LineEnding +
' function Compare(A, B: T): Integer;' + LineEnding +
' end;' + LineEnding +
'begin end.';
SrcGenericIntfTwoParams =
'program P;' + LineEnding +
'type' + LineEnding +
' IConverter<TIn, TOut> = interface' + LineEnding +
' function Convert(Value: TIn): TOut;' + LineEnding +
' end;' + LineEnding +
'begin end.';
SrcEqualityComparer =
'program P;' + LineEnding +
'type' + LineEnding +
' IEqualityComparer<T> = interface' + LineEnding +
' function Equals(A, B: T): Boolean;' + LineEnding +
' function GetHashCode(Value: T): Integer;' + LineEnding +
' end;' + LineEnding +
'var C: IEqualityComparer<Integer>;' + LineEnding +
'begin end.';
SrcClassImplementsGenericIntf =
'program P;' + LineEnding +
'type' + LineEnding +
' IEqualityComparer<T> = interface' + LineEnding +
' function Equals(A, B: T): Boolean;' + LineEnding +
' function GetHashCode(Value: T): Integer;' + LineEnding +
' end;' + LineEnding +
' TIntegerComparer = class(IEqualityComparer<Integer>)' + LineEnding +
' function Equals(A, B: Integer): Boolean;' + LineEnding +
' begin' + LineEnding +
' Result := A = B' + LineEnding +
' end;' + LineEnding +
' function GetHashCode(Value: Integer): Integer;' + LineEnding +
' begin' + LineEnding +
' Result := Value' + LineEnding +
' end;' + LineEnding +
' end;' + LineEnding +
'var' + LineEnding +
' C: IEqualityComparer<Integer>;' + LineEnding +
'begin' + LineEnding +
' C := TIntegerComparer.Create' + LineEnding +
'end.';
SrcGenericIntfDispatch =
'program P;' + LineEnding +
'type' + LineEnding +
' IEqualityComparer<T> = interface' + LineEnding +
' function Equals(A, B: T): Boolean;' + LineEnding +
' function GetHashCode(Value: T): Integer;' + LineEnding +
' end;' + LineEnding +
' TIntegerComparer = class(IEqualityComparer<Integer>)' + LineEnding +
' function Equals(A, B: Integer): Boolean;' + LineEnding +
' begin' + LineEnding +
' Result := A = B' + LineEnding +
' end;' + LineEnding +
' function GetHashCode(Value: Integer): Integer;' + LineEnding +
' begin' + LineEnding +
' Result := Value' + LineEnding +
' end;' + LineEnding +
' end;' + LineEnding +
'var' + LineEnding +
' C: IEqualityComparer<Integer>;' + LineEnding +
' OK: Boolean;' + LineEnding +
'begin' + LineEnding +
' C := TIntegerComparer.Create;' + LineEnding +
' OK := C.Equals(1, 1)' + LineEnding +
'end.';
{ ------------------------------------------------------------------ }
{ Helpers }
{ ------------------------------------------------------------------ }
function TGenericIntfTests.ParseSrc(const ASrc: string): TProgram;
var
L: TLexer;
P: TParser;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Result := P.Parse;
finally
P.Free;
L.Free;
end;
end;
function TGenericIntfTests.AnalyseSrc(const ASrc: string): TProgram;
var
SA: TSemanticAnalyser;
begin
Result := ParseSrc(ASrc);
SA := TSemanticAnalyser.Create;
try
SA.Analyse(Result);
finally
SA.Free;
end;
end;
function TGenericIntfTests.GenIR(const ASrc: string): string;
var
CG: TCodeGenQBE;
Prog: TProgram;
begin
Prog := AnalyseSrc(ASrc);
CG := TCodeGenQBE.Create;
try
CG.Generate(Prog);
Result := CG.GetOutput;
finally
CG.Free;
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Parser tests }
{ ------------------------------------------------------------------ }
procedure TGenericIntfTests.TestParse_GenericIntf_IsGenericInterfaceDef;
var
Prog: TProgram;
TD: TTypeDecl;
begin
Prog := ParseSrc(SrcGenericIntfOneParam);
try
AssertEquals('One type decl', 1, Prog.Block.TypeDecls.Count);
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
AssertTrue('Def is TGenericInterfaceDef', TD.Def is TGenericInterfaceDef);
finally
Prog.Free;
end;
end;
procedure TGenericIntfTests.TestParse_GenericIntf_ParamName;
var
Prog: TProgram;
TD: TTypeDecl;
GID: TGenericInterfaceDef;
begin
Prog := ParseSrc(SrcGenericIntfOneParam);
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
GID := TGenericInterfaceDef(TD.Def);
AssertEquals('One type param', 1, GID.ParamNames.Count);
AssertEquals('Param name is T', 'T', GID.ParamNames[0]);
finally
Prog.Free;
end;
end;
procedure TGenericIntfTests.TestParse_GenericIntf_TwoParams;
var
Prog: TProgram;
TD: TTypeDecl;
GID: TGenericInterfaceDef;
begin
Prog := ParseSrc(SrcGenericIntfTwoParams);
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
GID := TGenericInterfaceDef(TD.Def);
AssertEquals('Two type params', 2, GID.ParamNames.Count);
AssertEquals('First param', 'TIn', GID.ParamNames[0]);
AssertEquals('Second param', 'TOut', GID.ParamNames[1]);
finally
Prog.Free;
end;
end;
procedure TGenericIntfTests.TestParse_GenericIntf_MethodUsesTypeParam;
var
Prog: TProgram;
TD: TTypeDecl;
GID: TGenericInterfaceDef;
MDecl: TMethodDecl;
Par: TMethodParam;
begin
Prog := ParseSrc(SrcGenericIntfOneParam);
try
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
GID := TGenericInterfaceDef(TD.Def);
AssertEquals('One method', 1, GID.IntfDef.Methods.Count);
MDecl := TMethodDecl(GID.IntfDef.Methods[0]);
AssertEquals('Method name', 'Compare', MDecl.Name);
AssertEquals('Two params', 2, MDecl.Params.Count);
Par := TMethodParam(MDecl.Params[0]);
AssertEquals('First param type is T', 'T', Par.TypeName);
AssertEquals('Return type is Integer', 'Integer', MDecl.ReturnTypeName);
finally
Prog.Free;
end;
end;
procedure TGenericIntfTests.TestParse_Class_ImplementsGenericIntf_InParenList;
var
Prog: TProgram;
TD: TTypeDecl;
CD: TClassTypeDef;
begin
Prog := ParseSrc(SrcClassImplementsGenericIntf);
try
{ Second type decl is TIntegerComparer }
TD := TTypeDecl(Prog.Block.TypeDecls[1]);
AssertTrue('Is class', TD.Def is TClassTypeDef);
CD := TClassTypeDef(TD.Def);
{ The generic interface name should appear in implements or parent }
AssertTrue('Has IEqualityComparer<Integer>',
(CD.ParentName = 'IEqualityComparer<Integer>') or
(CD.ImplementsNames.IndexOf('IEqualityComparer<Integer>') >= 0));
finally
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Semantic tests }
{ ------------------------------------------------------------------ }
procedure TGenericIntfTests.TestSemantic_GenericIntf_InstantiatesOnVarDecl;
var
Prog: TProgram;
begin
{ 'var C: IEqualityComparer<Integer>' should trigger instantiation }
Prog := AnalyseSrc(SrcEqualityComparer);
Prog.Free;
end;
procedure TGenericIntfTests.TestSemantic_GenericIntf_InstantiatedType_IsInterface;
var
Prog: TProgram;
VD: TVarDecl;
begin
Prog := AnalyseSrc(SrcEqualityComparer);
try
VD := TVarDecl(Prog.Block.Decls[0]);
AssertEquals('Variable type is tyInterface',
Ord(tyInterface), Ord(VD.ResolvedType.Kind));
finally
Prog.Free;
end;
end;
procedure TGenericIntfTests.TestSemantic_Class_ImplementsGenericIntf_OK;
var
Prog: TProgram;
begin
{ Should not raise — TIntegerComparer correctly implements IEqualityComparer<Integer> }
Prog := AnalyseSrc(SrcClassImplementsGenericIntf);
Prog.Free;
end;
procedure TGenericIntfTests.TestSemantic_GenericIntf_MethodParamsSubstituted;
var
Prog: TProgram;
VD: TVarDecl;
IntfDesc: TInterfaceTypeDesc;
begin
Prog := AnalyseSrc(SrcEqualityComparer);
try
VD := TVarDecl(Prog.Block.Decls[0]);
IntfDesc := TInterfaceTypeDesc(VD.ResolvedType);
AssertEquals('Two methods', 2, IntfDesc.MethodCount);
AssertEquals('First method is Equals', 'Equals', IntfDesc.MethodName(0));
AssertEquals('Second method is GetHashCode', 'GetHashCode', IntfDesc.MethodName(1));
finally
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Codegen tests }
{ ------------------------------------------------------------------ }
procedure TGenericIntfTests.TestCodegen_GenericIntf_TypeinfoEmitted;
var
IR: string;
begin
IR := GenIR(SrcClassImplementsGenericIntf);
AssertTrue('Typeinfo for IEqualityComparer_Integer emitted',
Pos('typeinfo_IEqualityComparer_Integer', IR) > 0);
end;
procedure TGenericIntfTests.TestCodegen_GenericIntf_ItabEmitted;
var
IR: string;
begin
IR := GenIR(SrcClassImplementsGenericIntf);
AssertTrue('Itab for TIntegerComparer/IEqualityComparer_Integer emitted',
Pos('itab_TIntegerComparer_IEqualityComparer_Integer', IR) > 0);
end;
procedure TGenericIntfTests.TestCodegen_GenericIntf_ImpllistEmitted;
var
IR: string;
begin
IR := GenIR(SrcClassImplementsGenericIntf);
AssertTrue('Impllist for TIntegerComparer emitted',
Pos('impllist_TIntegerComparer', IR) > 0);
end;
procedure TGenericIntfTests.TestCodegen_GenericIntf_MethodDispatch_EmitsIndirectCall;
var
IR: string;
begin
IR := GenIR(SrcGenericIntfDispatch);
{ Interface method call goes through itab pointer — must be an indirect call }
AssertTrue('Interface dispatch emits indirect call', Pos('call %', IR) > 0);
end;
initialization
RegisterTest(TGenericIntfTests);
end.

35
docs/grammar.ebnf
View file

@ -163,13 +163,19 @@ TypeSection
TypeDecl
= IDENT EQUALS TypeDef SEMICOLON
| IDENT LESS TypeParamList GREATER EQUALS TypeDef SEMICOLON
;
(* The second form declares a generic type template. TypeDef must be either
* ClassDef (→ TGenericTypeDef) or InterfaceDef (→ TGenericInterfaceDef).
* The parser rejects other TypeDef kinds at that position. *)
TypeDef
= RecordDef
| ClassDef
| GenericClassDef
| InterfaceDef
| GenericInterfaceDef
;
RecordDef
@ -177,22 +183,21 @@ RecordDef
;
ClassDef
= CLASS [ LPAREN IDENT RPAREN ] (* optional parent class *)
[ ImplementsClause ]
= CLASS [ LPAREN GenericName { COMMA GenericName } RPAREN ]
FieldList
MethodDeclList
END
;
(* ImplementsClause — zero-GUID interface list, Delphi-style *)
ImplementsClause
= IDENT { COMMA IDENT } (* interface name(s) after class(Parent) *)
GenericName
= IDENT [ LESS TypeArgList GREATER ] (* plain name or generic specialisation *)
;
(* Note: the parser reads "class(Parent, IFoo, IBar)" where Parent is optional.
* The first non-interface identifier is treated as the parent class; subsequent
* identifiers that resolve to interface types are treated as the implements list.
* This is handled by semantic analysis, not the parser. *)
(* The parser stores the first name in the paren list as ParentName. During
* semantic analysis, if ParentName contains '<' it is resolved as a generic
* interface and silently moved to the ImplementsNames list. Subsequent names
* are always treated as implements entries.
* Example: class(TObject, IFoo, IBar<Integer>) *)
GenericClassDef
= CLASS LESS TypeParamList GREATER (* generic template, e.g. class<T> *)
@ -209,6 +214,18 @@ InterfaceDef
END
;
GenericInterfaceDef
= INTERFACE
[ LPAREN IDENT RPAREN ] (* optional parent interface *)
MethodSignatureList
END
;
(* GenericInterfaceDef is syntactically identical to InterfaceDef; the distinction
* is that it appears after "IDENT < TypeParamList > =" in a TypeDecl. The parser
* creates a TGenericInterfaceDef AST node wrapping the TInterfaceTypeDef body.
* Type parameters are substituted at instantiation time (e.g. IFoo<Integer>). *)
FieldList
= { FieldDecl }
;