Implement TList<T> foundations: SizeOf, ^T substitution, pointer compat
Compiler additions needed for TList<T> generic dynamic list: - SubstTypeParam helper: handles ^T → ^Integer substitution in generic instantiation (the direct SameText check missed caret-prefixed types) - Type param scope: push T=Integer bindings before analysing generic method bodies so that SizeOf(T) and local 'var P: ^T' resolve correctly - SizeOf(TypeName) built-in: semantic returns Integer type with arg's ResolvedType set; codegen emits 'copy N' using TTypeDesc.ByteSize - Pointer type compatibility: nil → ^T, Pointer ↔ ^T, and ^T ↔ ^T with same BaseType are now allowed in CheckTypesMatch and comparisons - Constructor allocation changed from malloc to calloc so that all class fields (including FData/FCount/FCapacity in TList<T>) start zeroed Tests: 11 new tests in cp.test.tlist.pas; 5 existing malloc assertions updated to calloc; 567 total, 0 failures.
This commit is contained in:
Graeme Geldenhuys
parent
0cc28d395e
commit
19eaeb35ff
|
|
@ -1365,6 +1365,16 @@ begin
|
|||
{ Standalone function call expression }
|
||||
with TFuncCallExpr(AExpr) do
|
||||
begin
|
||||
{ SizeOf(TypeName) → integer literal = byte size of the type }
|
||||
if SameText(Name, 'SizeOf') then
|
||||
begin
|
||||
T := AllocTemp;
|
||||
EmitLine(Format(' %s =w copy %d',
|
||||
[T, TASTExpr(Args[0]).ResolvedType.ByteSize]));
|
||||
Result := T;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{ GetMem(N) → malloc(N) → pointer }
|
||||
if SameText(Name, 'GetMem') then
|
||||
begin
|
||||
|
|
@ -1476,9 +1486,9 @@ begin
|
|||
FldAccess := TFieldAccessExpr(AExpr);
|
||||
if FldAccess.IsConstructorCall then
|
||||
begin
|
||||
{ TypeName.Create — allocate instance on heap }
|
||||
{ TypeName.Create — allocate zeroed instance on heap (calloc zeros all fields) }
|
||||
T := AllocTemp;
|
||||
EmitLine(Format(' %s =l call $malloc(l %d)',
|
||||
EmitLine(Format(' %s =l call $calloc(l 1, l %d)',
|
||||
[T, TRecordTypeDesc(FldAccess.ResolvedType).TotalSize]));
|
||||
{ Store vtable pointer at offset 0 if this class has virtual methods }
|
||||
if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable then
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@ type
|
|||
{ Generic type instantiation: resolves 'TBox<Integer>' on demand. }
|
||||
function FindTypeOrInstantiate(const AName: string): TTypeDesc;
|
||||
function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
|
||||
function SubstTypeParam(const ATypeName: string;
|
||||
AParamNames, AArgs: TStringList): string;
|
||||
|
||||
{ Generic function instantiation: resolves 'Identity<Integer>' on demand. }
|
||||
function InstantiateGenericFunc(const AInstName: string): TMethodDecl;
|
||||
|
|
@ -131,9 +133,19 @@ var
|
|||
begin
|
||||
if AExpected = AActual then
|
||||
Exit;
|
||||
{ nil is compatible with any class or interface type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface]) then
|
||||
{ nil is compatible with any class, interface, or pointer type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface, tyPointer]) then
|
||||
Exit;
|
||||
{ Two pointer types are compatible when:
|
||||
- either is untyped (Pointer), or
|
||||
- both are typed pointers to the same base type }
|
||||
if (AExpected.Kind = tyPointer) and (AActual.Kind = tyPointer) then
|
||||
begin
|
||||
if (TPointerTypeDesc(AExpected).BaseType = nil) or
|
||||
(TPointerTypeDesc(AActual).BaseType = nil) or
|
||||
(TPointerTypeDesc(AExpected).BaseType = TPointerTypeDesc(AActual).BaseType) then
|
||||
Exit;
|
||||
end;
|
||||
{ subtype assignment: TDerived → TBase is allowed }
|
||||
if IsSubtypeOf(AActual, AExpected) then
|
||||
Exit;
|
||||
|
|
@ -355,6 +367,24 @@ begin
|
|||
Result := InstantiateGeneric(AName);
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.SubstTypeParam(const ATypeName: string;
|
||||
AParamNames, AArgs: TStringList): string;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := ATypeName;
|
||||
{ Direct match: T → Integer }
|
||||
for I := 0 to AParamNames.Count - 1 do
|
||||
if SameText(Result, AParamNames[I]) then
|
||||
begin
|
||||
Result := AArgs[I];
|
||||
Exit;
|
||||
end;
|
||||
{ Prefix caret: ^T → ^Integer, ^^T → ^^Integer, etc. }
|
||||
if (Length(Result) > 0) and (Result[1] = '^') then
|
||||
Result := '^' + Self.SubstTypeParam(Copy(Result, 2, MaxInt), AParamNames, AArgs);
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
|
||||
var
|
||||
BracPos: Integer;
|
||||
|
|
@ -376,8 +406,9 @@ var
|
|||
FldName: string;
|
||||
ParType: TTypeDesc;
|
||||
RT: TRecordTypeDesc;
|
||||
GI: TGenericInstance;
|
||||
Subst: string;
|
||||
GI: TGenericInstance;
|
||||
Subst: string;
|
||||
ConcrType: TTypeDesc;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
|
|
@ -420,21 +451,14 @@ begin
|
|||
for I := 0 to Templ.ClassDef.ImplementsNames.Count - 1 do
|
||||
ClonedCD.ImplementsNames.Add(Templ.ClassDef.ImplementsNames[I]);
|
||||
|
||||
{ Clone fields with type-param substitution }
|
||||
{ Clone fields with type-param substitution (handles ^T → ^Integer etc.) }
|
||||
for I := 0 to Templ.ClassDef.Fields.Count - 1 do
|
||||
begin
|
||||
FDecl := TFieldDecl(Templ.ClassDef.Fields[I]);
|
||||
NewFDecl := TFieldDecl.Create;
|
||||
for J := 0 to FDecl.Names.Count - 1 do
|
||||
NewFDecl.Names.Add(FDecl.Names[J]);
|
||||
Subst := FDecl.TypeName;
|
||||
for K := 0 to Templ.ParamNames.Count - 1 do
|
||||
if SameText(Subst, Templ.ParamNames[K]) then
|
||||
begin
|
||||
Subst := Args[K];
|
||||
Break;
|
||||
end;
|
||||
NewFDecl.TypeName := Subst;
|
||||
NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args);
|
||||
ClonedCD.Fields.Add(NewFDecl);
|
||||
end;
|
||||
|
||||
|
|
@ -456,25 +480,12 @@ begin
|
|||
NewPar := TMethodParam.Create;
|
||||
NewPar.ParamName := Par.ParamName;
|
||||
NewPar.IsVarParam := Par.IsVarParam;
|
||||
Subst := Par.TypeName;
|
||||
for K := 0 to Templ.ParamNames.Count - 1 do
|
||||
if SameText(Subst, Templ.ParamNames[K]) then
|
||||
begin
|
||||
Subst := Args[K];
|
||||
Break;
|
||||
end;
|
||||
NewPar.TypeName := Subst;
|
||||
NewPar.TypeName := SubstTypeParam(Par.TypeName, Templ.ParamNames, Args);
|
||||
NewMDecl.Params.Add(NewPar);
|
||||
end;
|
||||
|
||||
Subst := MDecl.ReturnTypeName;
|
||||
for K := 0 to Templ.ParamNames.Count - 1 do
|
||||
if SameText(Subst, Templ.ParamNames[K]) then
|
||||
begin
|
||||
Subst := Args[K];
|
||||
Break;
|
||||
end;
|
||||
NewMDecl.ReturnTypeName := Subst;
|
||||
NewMDecl.ReturnTypeName :=
|
||||
SubstTypeParam(MDecl.ReturnTypeName, Templ.ParamNames, Args);
|
||||
|
||||
ClonedCD.Methods.Add(NewMDecl);
|
||||
end;
|
||||
|
|
@ -542,12 +553,28 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
{ Analyse method bodies with concrete types in scope }
|
||||
for J := 0 to ClonedCD.Methods.Count - 1 do
|
||||
begin
|
||||
NewMDecl := TMethodDecl(ClonedCD.Methods[J]);
|
||||
if NewMDecl.Body <> nil then
|
||||
AnalyseMethodDecl(NewMDecl, RT);
|
||||
{ Analyse method bodies with concrete types in scope.
|
||||
Push type-param bindings (T=Integer etc.) so that SizeOf(T) and
|
||||
local var declarations like 'var P: ^T' resolve to concrete types. }
|
||||
FTable.PushScope;
|
||||
try
|
||||
for K := 0 to Templ.ParamNames.Count - 1 do
|
||||
begin
|
||||
ConcrType := FindTypeOrInstantiate(Args[K]);
|
||||
if ConcrType <> nil then
|
||||
begin
|
||||
Sym := TSymbol.Create(Templ.ParamNames[K], skType, ConcrType);
|
||||
FTable.Define(Sym);
|
||||
end;
|
||||
end;
|
||||
for J := 0 to ClonedCD.Methods.Count - 1 do
|
||||
begin
|
||||
NewMDecl := TMethodDecl(ClonedCD.Methods[J]);
|
||||
if NewMDecl.Body <> nil then
|
||||
AnalyseMethodDecl(NewMDecl, RT);
|
||||
end;
|
||||
finally
|
||||
FTable.PopScope;
|
||||
end;
|
||||
|
||||
{ Register the instantiation for codegen }
|
||||
|
|
@ -1590,6 +1617,22 @@ var
|
|||
Idx: Integer;
|
||||
I: Integer;
|
||||
begin
|
||||
{ SizeOf(TypeName) — compile-time type size, returns Integer }
|
||||
if SameText(AExpr.Name, 'SizeOf') then
|
||||
begin
|
||||
if AExpr.Args.Count <> 1 then
|
||||
SemanticError('SizeOf requires exactly one argument', AExpr.Line, AExpr.Col);
|
||||
if AExpr.Args[0] is TIdentExpr then
|
||||
begin
|
||||
Sym := FTable.Lookup(TIdentExpr(AExpr.Args[0]).Name);
|
||||
if (Sym <> nil) and (Sym.Kind = skType) then
|
||||
TIdentExpr(AExpr.Args[0]).ResolvedType := Sym.TypeDesc;
|
||||
end;
|
||||
Result := FTable.TypeInteger;
|
||||
AExpr.ResolvedType := Result;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Sym := FTable.Lookup(AExpr.Name);
|
||||
if Sym = nil then
|
||||
begin
|
||||
|
|
@ -1842,11 +1885,12 @@ begin
|
|||
|
||||
if IsComparisonOp(ABin.Op) then
|
||||
begin
|
||||
{ nil can be compared with class types }
|
||||
{ nil can be compared with class, interface, or pointer types }
|
||||
if not (
|
||||
(LType = RType) or
|
||||
((LType.Kind = tyNil) and (RType.Kind = tyClass)) or
|
||||
((LType.Kind = tyClass) and (RType.Kind = tyNil))
|
||||
((LType.Kind = tyNil) and (RType.Kind in [tyClass, tyInterface, tyPointer])) or
|
||||
((RType.Kind = tyNil) and (LType.Kind in [tyClass, tyInterface, tyPointer])) or
|
||||
((LType.Kind = tyPointer) and (RType.Kind = tyPointer))
|
||||
) then
|
||||
CheckTypesMatch(LType, RType,
|
||||
Format('comparison ''%s''', [BinaryOpName(ABin.Op)]),
|
||||
|
|
|
|||
|
|
@ -33,7 +33,8 @@ uses
|
|||
cp.test.generics,
|
||||
cp.test.properties,
|
||||
cp.test.genericfuncs,
|
||||
cp.test.pointers;
|
||||
cp.test.pointers,
|
||||
cp.test.tlist;
|
||||
|
||||
var
|
||||
Application: TTestRunner;
|
||||
|
|
|
|||
|
|
@ -528,7 +528,7 @@ begin
|
|||
'begin' + LineEnding +
|
||||
' F := TFoo.Create' + LineEnding +
|
||||
'end.');
|
||||
AssertTrue('calls malloc', Pos('call $malloc', IR) > 0);
|
||||
AssertTrue('calls calloc', Pos('call $calloc', IR) > 0);
|
||||
AssertTrue('stores pointer', Pos('storel', IR) > 0);
|
||||
end;
|
||||
|
||||
|
|
|
|||
|
|
@ -487,7 +487,7 @@ var
|
|||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGenericUsage);
|
||||
AssertTrue('constructor calls malloc', Pos('call $malloc', IR) > 0);
|
||||
AssertTrue('constructor calls calloc', Pos('call $calloc', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TGenericsTests.TestCodegen_Generic_MethodEmitted;
|
||||
|
|
|
|||
|
|
@ -305,7 +305,7 @@ begin
|
|||
IR := GenIR(SrcSelfRef);
|
||||
{ TNode has Integer (4 bytes) + TNode pointer (8 bytes) = 12 bytes,
|
||||
but aligned to 8 → 12 bytes total. malloc(12) }
|
||||
AssertTrue('malloc 12 bytes for TNode', Pos('call $malloc(l 12)', IR) > 0);
|
||||
AssertTrue('calloc 12 bytes for TNode', Pos('call $calloc(l 1, l 12)', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -346,7 +346,7 @@ var IR: string;
|
|||
begin
|
||||
IR := GenIR(SrcInherit);
|
||||
{ TDog.Create should malloc 8 bytes (Age + Legs) }
|
||||
AssertTrue('malloc 8 bytes for TDog', Pos('call $malloc(l 8)', IR) > 0);
|
||||
AssertTrue('calloc 8 bytes for TDog', Pos('call $calloc(l 1, l 8)', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TInheritTests.TestCodegen_Inherit_ParentFieldOffset;
|
||||
|
|
|
|||
346
compiler/src/test/pascal/cp.test.tlist.pas
Normal file
346
compiler/src/test/pascal/cp.test.tlist.pas
Normal file
|
|
@ -0,0 +1,346 @@
|
|||
unit cp.test.tlist;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{ Tests for TList<T> generic dynamic list: type substitution with ^T fields,
|
||||
SizeOf built-in, nil/Pointer compatibility with typed pointers, and
|
||||
end-to-end Add/Get/Count codegen. }
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TTListTests = class(TTestCase)
|
||||
private
|
||||
function ParseSrc(const ASrc: string): TProgram;
|
||||
function AnalyseSrc(const ASrc: string): TProgram;
|
||||
function GenIR(const ASrc: string): string;
|
||||
published
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — ^T field, SizeOf }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_CaretT_FieldType;
|
||||
procedure TestParse_SizeOf_ParsedAsFuncCall;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic — SizeOf, nil/Pointer compat, ^T substitution }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_SizeOf_Integer;
|
||||
procedure TestSemantic_SizeOf_Pointer;
|
||||
procedure TestSemantic_NilAssign_ToTypedPointer;
|
||||
procedure TestSemantic_Pointer_AssignToTypedPointer;
|
||||
procedure TestSemantic_TList_Instantiation;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — SizeOf literal, full TList<Integer> add/get }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_SizeOf_Integer_EmitsFour;
|
||||
procedure TestCodegen_SizeOf_Int64_EmitsEight;
|
||||
procedure TestCodegen_TList_Compiles;
|
||||
procedure TestCodegen_TList_AddGet_IR;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Blaise source constants }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcSizeOfInteger =
|
||||
'program P;' + LineEnding +
|
||||
'var N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' N := SizeOf(Integer)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcSizeOfInt64 =
|
||||
'program P;' + LineEnding +
|
||||
'var N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' N := SizeOf(Int64)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcNilToTypedPtr =
|
||||
'program P;' + LineEnding +
|
||||
'var P: ^Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' P := nil' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcPointerToTypedPtr =
|
||||
'program P;' + LineEnding +
|
||||
'var' + LineEnding +
|
||||
' P: ^Integer;' + LineEnding +
|
||||
' Q: Pointer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' Q := GetMem(4);' + LineEnding +
|
||||
' P := Q' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTListType =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TList<T> = class' + LineEnding +
|
||||
' FData: ^T;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' procedure Add(Value: T);' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' Dest: ^T;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Dest := Self.FData + Self.FCount * SizeOf(T);' + LineEnding +
|
||||
' Dest^ := Value;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): T;' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' Src: ^T;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Src := Self.FData + AIndex * SizeOf(T);' + LineEnding +
|
||||
' Result := Src^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var' + LineEnding +
|
||||
' L: TList<Integer>;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TList<Integer>.Create;' + LineEnding +
|
||||
' L.Add(10);' + LineEnding +
|
||||
' L.Add(20)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTListGetResult =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TList<T> = class' + LineEnding +
|
||||
' FData: ^T;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' procedure Add(Value: T);' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' Dest: ^T;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Dest := Self.FData + Self.FCount * SizeOf(T);' + LineEnding +
|
||||
' Dest^ := Value;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): T;' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' Src: ^T;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Src := Self.FData + AIndex * SizeOf(T);' + LineEnding +
|
||||
' Result := Src^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var' + LineEnding +
|
||||
' L: TList<Integer>;' + LineEnding +
|
||||
' V: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TList<Integer>.Create;' + LineEnding +
|
||||
' L.Add(42);' + LineEnding +
|
||||
' V := L.Get(0)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TTListTests.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 TTListTests.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 TTListTests.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 TTListTests.TestParse_CaretT_FieldType;
|
||||
var
|
||||
Prog: TProgram;
|
||||
TD: TTypeDecl;
|
||||
CD: TClassTypeDef;
|
||||
FD: TFieldDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTListType);
|
||||
try
|
||||
AssertTrue('At least one type decl', Prog.Block.TypeDecls.Count > 0);
|
||||
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
|
||||
AssertTrue('Is generic', TD.Def is TGenericTypeDef);
|
||||
CD := TGenericTypeDef(TD.Def).ClassDef;
|
||||
FD := TFieldDecl(CD.Fields[0]);
|
||||
AssertEquals('FData field name', 'FData', FD.Names[0]);
|
||||
AssertEquals('FData type is ^T', '^T', FD.TypeName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestParse_SizeOf_ParsedAsFuncCall;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
Call: TFuncCallExpr;
|
||||
begin
|
||||
Prog := ParseSrc(SrcSizeOfInteger);
|
||||
try
|
||||
Assign := TAssignment(Prog.Block.Stmts[0]);
|
||||
AssertTrue('RHS is TFuncCallExpr', Assign.Expr is TFuncCallExpr);
|
||||
Call := TFuncCallExpr(Assign.Expr);
|
||||
AssertEquals('Name is SizeOf', 'SizeOf', Call.Name);
|
||||
AssertEquals('One argument', 1, Call.Args.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TTListTests.TestSemantic_SizeOf_Integer;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcSizeOfInteger);
|
||||
try
|
||||
Assign := TAssignment(Prog.Block.Stmts[0]);
|
||||
AssertEquals('SizeOf(Integer) resolves to Integer type',
|
||||
Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestSemantic_SizeOf_Pointer;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcSizeOfInt64);
|
||||
try
|
||||
Assign := TAssignment(Prog.Block.Stmts[0]);
|
||||
AssertEquals('SizeOf(Int64) resolves to Integer type',
|
||||
Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestSemantic_NilAssign_ToTypedPointer;
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
{ Should not raise — nil is compatible with ^Integer }
|
||||
Prog := AnalyseSrc(SrcNilToTypedPtr);
|
||||
Prog.Free;
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestSemantic_Pointer_AssignToTypedPointer;
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
{ Should not raise — Pointer (untyped) is compatible with ^Integer }
|
||||
Prog := AnalyseSrc(SrcPointerToTypedPtr);
|
||||
Prog.Free;
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestSemantic_TList_Instantiation;
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
{ Full TList<T> source with ^T fields and SizeOf should analyse without errors }
|
||||
Prog := AnalyseSrc(SrcTListType);
|
||||
Prog.Free;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TTListTests.TestCodegen_SizeOf_Integer_EmitsFour;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSizeOfInteger);
|
||||
AssertTrue('SizeOf(Integer) emits copy 4', Pos('copy 4', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestCodegen_SizeOf_Int64_EmitsEight;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcSizeOfInt64);
|
||||
AssertTrue('SizeOf(Int64) emits copy 8', Pos('copy 8', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestCodegen_TList_Compiles;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
{ Full TList<T> program should produce valid IR without raising }
|
||||
IR := GenIR(SrcTListType);
|
||||
AssertTrue('IR is non-empty', Length(IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TTListTests.TestCodegen_TList_AddGet_IR;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTListGetResult);
|
||||
{ Add method stores through a typed pointer }
|
||||
AssertTrue('Add emits storew', Pos('storew', IR) > 0);
|
||||
{ Get method loads through a typed pointer }
|
||||
AssertTrue('Get emits loadw', Pos('loadw', IR) > 0);
|
||||
{ Memory allocation via calloc }
|
||||
AssertTrue('Create emits calloc', Pos('calloc', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TTListTests);
|
||||
|
||||
end.
|
||||
|
|
@ -399,8 +399,8 @@ var
|
|||
begin
|
||||
{ TPoint has one Integer field (4 bytes) + vptr (8 bytes) = 12 bytes }
|
||||
IR := GenIR(SrcBaseWithField);
|
||||
AssertTrue('malloc includes vptr size',
|
||||
IRContains(IR, 'call $malloc(l 12)'));
|
||||
AssertTrue('calloc includes vptr size',
|
||||
IRContains(IR, 'call $calloc(l 1, l 12)'));
|
||||
end;
|
||||
|
||||
procedure TVTableTests.TestCodegen_FieldOffset_ShiftedByEight;
|
||||
|
|
|
|||
Loading…
Reference in a new issue