From e30757fef31175864ef4540cb15451ac8c1c8c71 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 22 Apr 2026 10:17:30 +0100 Subject: [PATCH] Add generic interface support: IFoo = interface...end MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements full generic interface support through the compiler pipeline: Parser: TGenericInterfaceDef AST node; IDENT = interface...end syntax; ParseGenericName helper for class(IFoo) 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 on demand from a template; FindTypeOrInstantiate falls through class→interface; parent-as-interface detection moves IFoo 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. --- compiler/src/main/pascal/uAST.pas | 53 +++ compiler/src/main/pascal/uCodeGenQBE.pas | 66 +++- compiler/src/main/pascal/uParser.pas | 77 ++-- compiler/src/main/pascal/uSemantic.pas | 196 +++++++-- compiler/src/main/pascal/uSymbolTable.pas | 30 +- compiler/src/test/pascal/TestRunner.pas | 3 +- .../src/test/pascal/cp.test.genericintfs.pas | 373 ++++++++++++++++++ docs/grammar.ebnf | 35 +- 8 files changed, 761 insertions(+), 72 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.genericintfs.pas diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 1b5cd22..fc3f032 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -334,6 +334,26 @@ type destructor Destroy; override; end; + { Generic interface template: type IFoo = 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; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 96e522d..1f684e4 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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 diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 12b882a..85ba6e5 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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 or TPair } + { Check for generic type parameters: TBox, TPair, IFoo } 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 } + 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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 8a7649e..2981431 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -31,6 +31,7 @@ type { Generic type instantiation: resolves 'TBox' 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 → 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) 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 diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index bca4cb5..6c0b524 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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); diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 7371103..e7496cd 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.genericintfs.pas b/compiler/src/test/pascal/cp.test.genericintfs.pas new file mode 100644 index 0000000..60612e4 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.genericintfs.pas @@ -0,0 +1,373 @@ +unit cp.test.genericintfs; + +{$mode objfpc}{$H+} + +{ Tests for generic interfaces: IFoo = interface ... end, class implements + IFoo, 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 = interface' + LineEnding + + ' function Compare(A, B: T): Integer;' + LineEnding + + ' end;' + LineEnding + + 'begin end.'; + + SrcGenericIntfTwoParams = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IConverter = interface' + LineEnding + + ' function Convert(Value: TIn): TOut;' + LineEnding + + ' end;' + LineEnding + + 'begin end.'; + + SrcEqualityComparer = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IEqualityComparer = interface' + LineEnding + + ' function Equals(A, B: T): Boolean;' + LineEnding + + ' function GetHashCode(Value: T): Integer;' + LineEnding + + ' end;' + LineEnding + + 'var C: IEqualityComparer;' + LineEnding + + 'begin end.'; + + SrcClassImplementsGenericIntf = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IEqualityComparer = interface' + LineEnding + + ' function Equals(A, B: T): Boolean;' + LineEnding + + ' function GetHashCode(Value: T): Integer;' + LineEnding + + ' end;' + LineEnding + + ' TIntegerComparer = class(IEqualityComparer)' + 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;' + LineEnding + + 'begin' + LineEnding + + ' C := TIntegerComparer.Create' + LineEnding + + 'end.'; + + SrcGenericIntfDispatch = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IEqualityComparer = interface' + LineEnding + + ' function Equals(A, B: T): Boolean;' + LineEnding + + ' function GetHashCode(Value: T): Integer;' + LineEnding + + ' end;' + LineEnding + + ' TIntegerComparer = class(IEqualityComparer)' + 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;' + 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', + (CD.ParentName = 'IEqualityComparer') or + (CD.ImplementsNames.IndexOf('IEqualityComparer') >= 0)); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Semantic tests } +{ ------------------------------------------------------------------ } + +procedure TGenericIntfTests.TestSemantic_GenericIntf_InstantiatesOnVarDecl; +var + Prog: TProgram; +begin + { 'var C: IEqualityComparer' 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 } + 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. diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index 98cb3a7..40558e6 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -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) *) GenericClassDef = CLASS LESS TypeParamList GREATER (* generic template, e.g. class *) @@ -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). *) + FieldList = { FieldDecl } ;