From a3a57df8a757e60e919ba62d8df0d75bdbcf52f3 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 21 Apr 2026 23:26:52 +0100 Subject: [PATCH] Implement standalone generic function monomorphization Adds demand-driven instantiation for 'function Name(Param: T): T' syntax. Templates registered on declaration; concrete instances created on first call site (e.g. Identity) with substituted param/return types, shared body analysis, and QBE-mangled emission ('Identity_Integer'). 14 new tests, 541 total. --- compiler/src/main/pascal/uAST.pas | 44 ++- compiler/src/main/pascal/uCodeGenQBE.pas | 15 +- compiler/src/main/pascal/uParser.pas | 27 +- compiler/src/main/pascal/uSemantic.pas | 164 +++++++- compiler/src/test/pascal/TestRunner.pas | 3 +- .../src/test/pascal/cp.test.genericfuncs.pas | 373 ++++++++++++++++++ 6 files changed, 597 insertions(+), 29 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.genericfuncs.pas diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 040c603..2243663 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -244,6 +244,7 @@ type IsVirtual: Boolean; { declared with 'virtual' directive } IsOverride: Boolean; { declared with 'override' directive } VTableSlot: Integer; { -1 = static; >=0 = vtable index (set by uSemantic) } + TypeParams: TStringList; { non-nil = generic function template; owns param names } constructor Create; destructor Destroy; override; end; @@ -288,6 +289,16 @@ type destructor Destroy; override; end; + { One concrete instantiation of a standalone generic function — stored on TProgram. + Codegen iterates this list to emit function bodies. } + TGenericFuncInstance = class + public + InstName: string; { raw name e.g. 'Identity' } + MethodDecl: TMethodDecl; { owned — concrete method decl with substituted types } + constructor Create; + destructor Destroy; override; + end; + { One concrete instantiation produced by monomorphization — stored on TProgram. Codegen iterates this list to emit typeinfo, vtables, and method bodies. } TGenericInstance = class @@ -330,11 +341,12 @@ type TProgram = class(TASTNode) public - Name: string; - UsedUnits: TStringList; { owned } - Block: TBlock; { owned } - SymbolTable: TSymbolTable; { owned after semantic analysis; nil before } - GenericInstances: TObjectList; { owned TGenericInstance — populated by uSemantic } + Name: string; + UsedUnits: TStringList; { owned } + Block: TBlock; { owned } + SymbolTable: TSymbolTable; { owned after semantic analysis; nil before } + GenericInstances: TObjectList; { owned TGenericInstance — populated by uSemantic } + GenericFuncInstances: TObjectList; { owned TGenericFuncInstance — populated by uSemantic } constructor Create; destructor Destroy; override; end; @@ -583,6 +595,7 @@ end; destructor TMethodDecl.Destroy; begin Params.Free; + TypeParams.Free; if OwnBody then Body.Free; inherited Destroy; end; @@ -653,6 +666,21 @@ end; { TGenericInstance } +{ TGenericFuncInstance } + +constructor TGenericFuncInstance.Create; +begin + inherited Create; +end; + +destructor TGenericFuncInstance.Destroy; +begin + MethodDecl.Free; + inherited Destroy; +end; + +{ TGenericInstance } + constructor TGenericInstance.Create; begin inherited Create; @@ -698,12 +726,14 @@ end; constructor TProgram.Create; begin inherited Create; - UsedUnits := TStringList.Create; - GenericInstances := TObjectList.Create(True); + UsedUnits := TStringList.Create; + GenericInstances := TObjectList.Create(True); + GenericFuncInstances := TObjectList.Create(True); end; destructor TProgram.Destroy; begin + GenericFuncInstances.Free; GenericInstances.Free; SymbolTable.Free; UsedUnits.Free; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 5c47530..13c4f3e 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -1095,7 +1095,7 @@ var ValTemp: string; Prefix: string; begin - FuncName := '$' + ADecl.Name; + FuncName := '$' + QBEMangle(ADecl.Name); IsFunc := ADecl.ResolvedReturnType <> nil; if AExported then Prefix := 'export ' else Prefix := ''; @@ -1216,11 +1216,16 @@ begin for I := 0 to AProg.Block.ProcDecls.Count - 1 do begin Decl := TMethodDecl(AProg.Block.ProcDecls[I]); - { Class method impls (OwnerTypeName != '') had their body transferred to the - class method decl — skip them here; EmitMethodDefs handles them. } + { Class method impls had their body transferred — skip here. } if Decl.OwnerTypeName <> '' then Continue; + { Generic templates — concrete instances are emitted via GenericFuncInstances. } + if Decl.TypeParams <> nil then Continue; EmitStandaloneDef(Decl); end; + { Emit each concrete generic function instance } + for I := 0 to AProg.GenericFuncInstances.Count - 1 do + EmitStandaloneDef( + TGenericFuncInstance(AProg.GenericFuncInstances[I]).MethodDecl); end; procedure TCodeGenQBE.EmitProcCall(ACall: TProcCall); @@ -1251,7 +1256,7 @@ begin ArgLine := ArgLine + Format('%s %s', [QbeTypeOf(Par.ResolvedType), ArgTemp]); end; end; - EmitLine(Format(' call $%s(%s)', [ACall.Name, ArgLine])); + EmitLine(Format(' call $%s(%s)', [QBEMangle(ACall.Name), ArgLine])); Exit; end; @@ -1331,7 +1336,7 @@ begin begin MDecl := TMethodDecl(ResolvedDecl); QType := QbeTypeOf(MDecl.ResolvedReturnType); - FuncName := '$' + Name; + FuncName := '$' + QBEMangle(Name); ArgLine := ''; for I := 0 to Args.Count - 1 do begin diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 7318489..6a2a346 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -444,6 +444,27 @@ begin [FCurrent.Line, FCurrent.Col]); Result.Name := FCurrent.Value; Advance; + { Generic function: 'function Identity(...)' — parse type param list } + if Check(tkLessThan) and (PeekKind = tkIdent) then + begin + Result.TypeParams := TStringList.Create; + Advance; { consume '<' } + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected type parameter name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.TypeParams.Add(FCurrent.Value); + Advance; + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected type parameter name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.TypeParams.Add(FCurrent.Value); + Advance; + end; + Expect(tkGreaterThan); + end; { Qualified name: TypeName.MethodName (standalone class method implementation) } if Check(tkDot) then begin @@ -1286,10 +1307,10 @@ begin end; Expect(tkGreaterThan); Name := Name + '>'; - { Generic type args must be followed by '.' (constructor or class method) } - if not Check(tkDot) then + { Generic type args must be followed by '.' (type access) or '(' (generic func call) } + if not (Check(tkDot) or Check(tkLParen)) then raise EParseError.CreateFmt( - 'Expected ''.'' after generic type arguments at line %d col %d', + 'Expected ''.'' or ''('' after generic type arguments at line %d col %d', [FCurrent.Line, FCurrent.Col]); end; if Check(tkDot) then diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index a4dd397..11cb47d 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -22,15 +22,19 @@ type TSemanticAnalyser = class private - FTable: TSymbolTable; - FProg: TProgram; { current program being analysed; set in Analyse } - FMethodIndex: TStringList; { 'TypeName.MethodName' → TMethodDecl (not owned) } - FProcIndex: TStringList; { 'ProcName' → TMethodDecl (not owned) } + FTable: TSymbolTable; + FProg: TProgram; { current program being analysed; set in Analyse } + FMethodIndex: TStringList; { 'TypeName.MethodName' → TMethodDecl (not owned) } + FProcIndex: TStringList; { 'ProcName' → TMethodDecl (not owned) } + FGenericFuncTemplates: TStringList; { base name → TMethodDecl template (not owned) } { Generic type instantiation: resolves 'TBox' on demand. } function FindTypeOrInstantiate(const AName: string): TTypeDesc; function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc; + { Generic function instantiation: resolves 'Identity' on demand. } + function InstantiateGenericFunc(const AInstName: string): TMethodDecl; + procedure AnalyseBlock(ABlock: TBlock); procedure AnalyseTypeDecls(ABlock: TBlock); procedure LinkClassMethodImpls(ABlock: TBlock); @@ -74,15 +78,18 @@ implementation constructor TSemanticAnalyser.Create; begin inherited Create; - FTable := TSymbolTable.Create; - FMethodIndex := TStringList.Create; + FTable := TSymbolTable.Create; + FMethodIndex := TStringList.Create; FMethodIndex.CaseSensitive := False; - FProcIndex := TStringList.Create; + FProcIndex := TStringList.Create; FProcIndex.CaseSensitive := False; + FGenericFuncTemplates := TStringList.Create; + FGenericFuncTemplates.CaseSensitive := False; end; destructor TSemanticAnalyser.Destroy; begin + FGenericFuncTemplates.Free; FProcIndex.Free; FMethodIndex.Free; FTable.Free; @@ -534,6 +541,115 @@ begin end; end; +function TSemanticAnalyser.InstantiateGenericFunc(const AInstName: string): TMethodDecl; +var + BracPos: Integer; + BaseName: string; + ArgsStr: string; + Args: TStringList; + Templ: TMethodDecl; + TemplIdx: Integer; + NewMDecl: TMethodDecl; + NewPar: TMethodParam; + OldPar: TMethodParam; + ParTypeName: string; + RetTypeName: string; + SubstType: TTypeDesc; + I, J: Integer; + Sym: TSymbol; + GFI: TGenericFuncInstance; +begin + Result := nil; + + { Parse 'Identity' → BaseName='Identity', ArgsStr='Integer' } + BracPos := Pos('<', AInstName); + if BracPos = 0 then Exit; + + BaseName := Copy(AInstName, 1, BracPos - 1); + ArgsStr := Copy(AInstName, BracPos + 1, Length(AInstName) - BracPos - 1); + + TemplIdx := FGenericFuncTemplates.IndexOf(BaseName); + if TemplIdx < 0 then Exit; { not a known generic function template } + + Templ := TMethodDecl(FGenericFuncTemplates.Objects[TemplIdx]); + + Args := TStringList.Create; + try + Args.StrictDelimiter := True; + Args.Delimiter := ','; + Args.DelimitedText := ArgsStr; + for I := 0 to Args.Count - 1 do + Args[I] := Trim(Args[I]); + + if Args.Count <> Templ.TypeParams.Count then + SemanticError( + Format('Generic function ''%s'' expects %d type parameter(s) but got %d', + [BaseName, Templ.TypeParams.Count, Args.Count]), + 0, 0); + + NewMDecl := TMethodDecl.Create; + NewMDecl.Name := AInstName; + NewMDecl.OwnBody := False; { share the template body } + NewMDecl.Body := Templ.Body; + + { Substitute return type } + RetTypeName := Templ.ReturnTypeName; + for I := 0 to Templ.TypeParams.Count - 1 do + if SameText(RetTypeName, Templ.TypeParams[I]) then + RetTypeName := Args[I]; + NewMDecl.ReturnTypeName := RetTypeName; + if RetTypeName <> '' then + begin + SubstType := FindTypeOrInstantiate(RetTypeName); + if SubstType = nil then + SemanticError(Format('Unknown type ''%s'' in generic function instance ''%s''', + [RetTypeName, AInstName]), 0, 0); + NewMDecl.ResolvedReturnType := SubstType; + end; + + { Clone params with substituted types } + for I := 0 to Templ.Params.Count - 1 do + begin + OldPar := TMethodParam(Templ.Params[I]); + NewPar := TMethodParam.Create; + NewPar.ParamName := OldPar.ParamName; + NewPar.IsVarParam := OldPar.IsVarParam; + ParTypeName := OldPar.TypeName; + for J := 0 to Templ.TypeParams.Count - 1 do + if SameText(ParTypeName, Templ.TypeParams[J]) then + ParTypeName := Args[J]; + NewPar.TypeName := ParTypeName; + SubstType := FindTypeOrInstantiate(ParTypeName); + if SubstType = nil then + SemanticError(Format('Unknown type ''%s'' for parameter ''%s'' in ''%s''', + [ParTypeName, NewPar.ParamName, AInstName]), 0, 0); + NewPar.ResolvedType := SubstType; + NewMDecl.Params.Add(NewPar); + end; + + { Analyse the shared body with concrete types in scope } + AnalyseStandaloneDecl(NewMDecl); + + { Register in proc index and global symbol table } + FProcIndex.AddObject(AInstName, NewMDecl); + if NewMDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(AInstName, skFunction, NewMDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(AInstName, skProcedure, nil); + FTable.DefineGlobal(Sym); + + { Store for codegen } + GFI := TGenericFuncInstance.Create; + GFI.InstName := AInstName; + GFI.MethodDecl := NewMDecl; + FProg.GenericFuncInstances.Add(GFI); + + Result := NewMDecl; + finally + Args.Free; + end; +end; + procedure TSemanticAnalyser.AnalyseBlock(ABlock: TBlock); begin { Type declarations are registered in the outer scope so they remain visible @@ -953,6 +1069,12 @@ begin ADecl := TMethodDecl(ABlock.ProcDecls[I]); { Class method implementations have their body transferred; skip them here } if ADecl.OwnerTypeName <> '' then Continue; + { Generic function templates — registered for on-demand instantiation } + if ADecl.TypeParams <> nil then + begin + FGenericFuncTemplates.AddObject(ADecl.Name, ADecl); + Continue; + end; { Resolve parameter types } for J := 0 to ADecl.Params.Count - 1 do @@ -1046,6 +1168,8 @@ begin ADecl := TMethodDecl(ABlock.ProcDecls[I]); { Class method implementations have their body transferred; skip them here } if ADecl.OwnerTypeName <> '' then Continue; + { Generic templates are instantiated on demand — skip until first call } + if ADecl.TypeParams <> nil then Continue; AnalyseStandaloneDecl(ADecl); end; end; @@ -1374,9 +1498,16 @@ var begin Sym := FTable.Lookup(ACall.Name); if Sym = nil then - SemanticError( - Format('Undeclared procedure ''%s''', [ACall.Name]), - ACall.Line, ACall.Col); + begin + { Try on-demand instantiation of a generic function } + if Pos('<', ACall.Name) > 0 then + InstantiateGenericFunc(ACall.Name); + Sym := FTable.Lookup(ACall.Name); + if Sym = nil then + SemanticError( + Format('Undeclared procedure ''%s''', [ACall.Name]), + ACall.Line, ACall.Col); + end; if not (Sym.Kind in [skProcedure, skFunction]) then SemanticError( Format('''%s'' is not a procedure or function', [ACall.Name]), @@ -1437,9 +1568,16 @@ var begin Sym := FTable.Lookup(AExpr.Name); if Sym = nil then - SemanticError( - Format('Undeclared function ''%s''', [AExpr.Name]), - AExpr.Line, AExpr.Col); + begin + { Try on-demand instantiation of a generic function } + if Pos('<', AExpr.Name) > 0 then + InstantiateGenericFunc(AExpr.Name); + Sym := FTable.Lookup(AExpr.Name); + if Sym = nil then + SemanticError( + Format('Undeclared function ''%s''', [AExpr.Name]), + AExpr.Line, AExpr.Col); + end; if Sym.Kind <> skFunction then SemanticError( Format('''%s'' is not a function', [AExpr.Name]), diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index f84e271..803fb28 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -31,7 +31,8 @@ uses cp.test.typetests, cp.test.interfaces, cp.test.generics, - cp.test.properties; + cp.test.properties, + cp.test.genericfuncs; var Application: TTestRunner; diff --git a/compiler/src/test/pascal/cp.test.genericfuncs.pas b/compiler/src/test/pascal/cp.test.genericfuncs.pas new file mode 100644 index 0000000..a1bfd09 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.genericfuncs.pas @@ -0,0 +1,373 @@ +unit cp.test.genericfuncs; + +{$mode objfpc}{$H+} + +{ Tests for standalone generic function monomorphization. + Syntax: function Name(Param: T): T — demand-driven instantiation on first call. } + +interface + +uses + Classes, SysUtils, StrUtils, fpcunit, testregistry, + uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE; + +type + TGenericFuncTests = class(TTestCase) + private + function ParseSrc(const ASrc: string): TProgram; + function AnalyseSrc(const ASrc: string): TProgram; + function GenIR(const ASrc: string): string; + published + { ------------------------------------------------------------------ } + { Parser — generic function declarations } + { ------------------------------------------------------------------ } + procedure TestParse_GenericFunc_HasTypeParams; + procedure TestParse_GenericFunc_TypeParamName; + procedure TestParse_GenericFunc_TwoTypeParams; + procedure TestParse_GenericFunc_ParamUsesTypeParam; + procedure TestParse_GenericFunc_ReturnUsesTypeParam; + + { ------------------------------------------------------------------ } + { Parser — generic function call sites } + { ------------------------------------------------------------------ } + procedure TestParse_GenericFunc_CallSite_IsFuncCallExpr; + procedure TestParse_GenericFunc_CallSite_Name; + procedure TestParse_GenericFunc_CallSite_ArgCount; + + { ------------------------------------------------------------------ } + { Semantic — instantiation on use } + { ------------------------------------------------------------------ } + procedure TestSemantic_GenericFunc_TemplateNotInstantiatedWithoutUse; + procedure TestSemantic_GenericFunc_Usage_CreatesInstance; + procedure TestSemantic_GenericFunc_ReturnType_IsInteger; + procedure TestSemantic_GenericFunc_ParamType_IsInteger; + + { ------------------------------------------------------------------ } + { Codegen — mangled names and emission } + { ------------------------------------------------------------------ } + procedure TestCodegen_GenericFunc_BodyEmitted; + procedure TestCodegen_GenericFunc_CallEmitted; + end; + +implementation + +{ ------------------------------------------------------------------ } +{ Source constants } +{ ------------------------------------------------------------------ } + +const + { Generic function declaration only — no usage } + SrcGenericFuncDecl = + 'program P;' + LineEnding + + 'function Identity(Val: T): T;' + LineEnding + + 'begin' + LineEnding + + ' Result := Val' + LineEnding + + 'end;' + LineEnding + + 'begin' + LineEnding + + 'end.'; + + { Two type params } + SrcGenericFuncTwoParams = + 'program P;' + LineEnding + + 'function Swap(X: A; Y: B): A;' + LineEnding + + 'begin' + LineEnding + + ' Result := X' + LineEnding + + 'end;' + LineEnding + + 'begin' + LineEnding + + 'end.'; + + { Usage — instantiates Identity } + SrcGenericFuncUsage = + 'program P;' + LineEnding + + 'function Identity(Val: T): T;' + LineEnding + + 'begin' + LineEnding + + ' Result := Val' + LineEnding + + 'end;' + LineEnding + + 'var X: Integer;' + LineEnding + + 'begin' + LineEnding + + ' X := Identity(42)' + LineEnding + + 'end.'; + + { Call-site source for parser test only (semantics not needed) } + SrcGenericFuncCallSite = + 'program P;' + LineEnding + + 'function Identity(Val: T): T;' + LineEnding + + 'begin' + LineEnding + + ' Result := Val' + LineEnding + + 'end;' + LineEnding + + 'var X: Integer;' + LineEnding + + 'begin' + LineEnding + + ' X := Identity(42)' + LineEnding + + 'end.'; + +{ ------------------------------------------------------------------ } +{ Helpers } +{ ------------------------------------------------------------------ } + +function TGenericFuncTests.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 TGenericFuncTests.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 TGenericFuncTests.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 — generic function declarations } +{ ------------------------------------------------------------------ } + +procedure TGenericFuncTests.TestParse_GenericFunc_HasTypeParams; +var + Prog: TProgram; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcGenericFuncDecl); + try + AssertEquals('one proc decl', 1, Prog.Block.ProcDecls.Count); + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertNotNull('TypeParams not nil', MD.TypeParams); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_TypeParamName; +var + Prog: TProgram; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcGenericFuncDecl); + try + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertEquals('one type param', 1, MD.TypeParams.Count); + AssertEquals('param name T', 'T', MD.TypeParams[0]); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_TwoTypeParams; +var + Prog: TProgram; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcGenericFuncTwoParams); + try + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertNotNull('TypeParams not nil', MD.TypeParams); + AssertEquals('two type params', 2, MD.TypeParams.Count); + AssertEquals('first param A', 'A', MD.TypeParams[0]); + AssertEquals('second param B', 'B', MD.TypeParams[1]); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_ParamUsesTypeParam; +var + Prog: TProgram; + MD: TMethodDecl; + Par: TMethodParam; +begin + Prog := ParseSrc(SrcGenericFuncDecl); + try + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertEquals('one param', 1, MD.Params.Count); + Par := TMethodParam(MD.Params[0]); + AssertEquals('param name Val', 'Val', Par.ParamName); + AssertEquals('param type T', 'T', Par.TypeName); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_ReturnUsesTypeParam; +var + Prog: TProgram; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcGenericFuncDecl); + try + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertEquals('return type T', 'T', MD.ReturnTypeName); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Parser — generic function call sites } +{ ------------------------------------------------------------------ } + +procedure TGenericFuncTests.TestParse_GenericFunc_CallSite_IsFuncCallExpr; +var + Prog: TProgram; + Assign: TAssignment; +begin + Prog := ParseSrc(SrcGenericFuncCallSite); + try + AssertEquals('one stmt', 1, Prog.Block.Stmts.Count); + AssertTrue('assign stmt', Prog.Block.Stmts[0] is TAssignment); + Assign := TAssignment(Prog.Block.Stmts[0]); + AssertTrue('rhs is TFuncCallExpr', Assign.Expr is TFuncCallExpr); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_CallSite_Name; +var + Prog: TProgram; + Assign: TAssignment; + FCall: TFuncCallExpr; +begin + Prog := ParseSrc(SrcGenericFuncCallSite); + try + Assign := TAssignment(Prog.Block.Stmts[0]); + FCall := TFuncCallExpr(Assign.Expr); + AssertEquals('call name', 'Identity', FCall.Name); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestParse_GenericFunc_CallSite_ArgCount; +var + Prog: TProgram; + Assign: TAssignment; + FCall: TFuncCallExpr; +begin + Prog := ParseSrc(SrcGenericFuncCallSite); + try + Assign := TAssignment(Prog.Block.Stmts[0]); + FCall := TFuncCallExpr(Assign.Expr); + AssertEquals('one arg', 1, FCall.Args.Count); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Semantic — instantiation on use } +{ ------------------------------------------------------------------ } + +procedure TGenericFuncTests.TestSemantic_GenericFunc_TemplateNotInstantiatedWithoutUse; +var + Prog: TProgram; +begin + { Declaration without use: no instance created } + Prog := AnalyseSrc(SrcGenericFuncDecl); + try + AssertEquals('no instances', 0, Prog.GenericFuncInstances.Count); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestSemantic_GenericFunc_Usage_CreatesInstance; +var + Prog: TProgram; +begin + Prog := AnalyseSrc(SrcGenericFuncUsage); + try + AssertEquals('one instance', 1, Prog.GenericFuncInstances.Count); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestSemantic_GenericFunc_ReturnType_IsInteger; +var + Prog: TProgram; + GFI: TGenericFuncInstance; +begin + Prog := AnalyseSrc(SrcGenericFuncUsage); + try + GFI := TGenericFuncInstance(Prog.GenericFuncInstances[0]); + AssertNotNull('return type not nil', GFI.MethodDecl.ResolvedReturnType); + AssertEquals('return type is Integer', Ord(tyInteger), + Ord(GFI.MethodDecl.ResolvedReturnType.Kind)); + finally + Prog.Free; + end; +end; + +procedure TGenericFuncTests.TestSemantic_GenericFunc_ParamType_IsInteger; +var + Prog: TProgram; + GFI: TGenericFuncInstance; + Par: TMethodParam; +begin + Prog := AnalyseSrc(SrcGenericFuncUsage); + try + GFI := TGenericFuncInstance(Prog.GenericFuncInstances[0]); + AssertEquals('one param', 1, GFI.MethodDecl.Params.Count); + Par := TMethodParam(GFI.MethodDecl.Params[0]); + AssertNotNull('param type not nil', Par.ResolvedType); + AssertEquals('param type is Integer', Ord(tyInteger), Ord(Par.ResolvedType.Kind)); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Codegen — mangled names and emission } +{ ------------------------------------------------------------------ } + +procedure TGenericFuncTests.TestCodegen_GenericFunc_BodyEmitted; +var + IR: string; +begin + IR := GenIR(SrcGenericFuncUsage); + AssertTrue('body emitted with mangled name', + Pos('$Identity_Integer', IR) > 0); +end; + +procedure TGenericFuncTests.TestCodegen_GenericFunc_CallEmitted; +var + IR: string; +begin + IR := GenIR(SrcGenericFuncUsage); + AssertTrue('call emitted with mangled name', + Pos('call $Identity_Integer', IR) > 0); +end; + +initialization + RegisterTest(TGenericFuncTests); +end.