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

Implement standalone generic function monomorphization

Browse source 
Adds demand-driven instantiation for 'function Name<T>(Param: T): T' syntax.
Templates registered on declaration; concrete instances created on first call
site (e.g. Identity<Integer>) with substituted param/return types, shared
body analysis, and QBE-mangled emission ('Identity_Integer'). 14 new tests,
541 total.
This commit is contained in:
Graeme Geldenhuys 2026-04-21 23:26:52 +01:00
parent 80c2b21d6c
commit a3a57df8a7
6 changed files with 597 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -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<Integer>' }
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;

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

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

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

@ -444,6 +444,27 @@ begin
[FCurrent.Line, FCurrent.Col]);
Result.Name := FCurrent.Value;
Advance;
{ Generic function: 'function Identity<T>(...)' — 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

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

@ -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<Integer>' on demand. }
function FindTypeOrInstantiate(const AName: string): TTypeDesc;
function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
{ Generic function instantiation: resolves 'Identity<Integer>' 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<Integer>' → 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]),

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

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

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

@ -0,0 +1,373 @@
unit cp.test.genericfuncs;
{$mode objfpc}{$H+}
{ Tests for standalone generic function monomorphization.
Syntax: function Name<T>(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<T>(Val: T): T;' + LineEnding +
'begin' + LineEnding +
' Result := Val' + LineEnding +
'end;' + LineEnding +
'begin' + LineEnding +
'end.';
{ Two type params }
SrcGenericFuncTwoParams =
'program P;' + LineEnding +
'function Swap<A, B>(X: A; Y: B): A;' + LineEnding +
'begin' + LineEnding +
' Result := X' + LineEnding +
'end;' + LineEnding +
'begin' + LineEnding +
'end.';
{ Usage — instantiates Identity<Integer> }
SrcGenericFuncUsage =
'program P;' + LineEnding +
'function Identity<T>(Val: T): T;' + LineEnding +
'begin' + LineEnding +
' Result := Val' + LineEnding +
'end;' + LineEnding +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := Identity<Integer>(42)' + LineEnding +
'end.';
{ Call-site source for parser test only (semantics not needed) }
SrcGenericFuncCallSite =
'program P;' + LineEnding +
'function Identity<T>(Val: T): T;' + LineEnding +
'begin' + LineEnding +
' Result := Val' + LineEnding +
'end;' + LineEnding +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := Identity<Integer>(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<Integer>', 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.