Add TObjectList and TStringList to RTL; fix string ARC via typed pointers
New builtins: CompareStr, CompareText (→ _StringCompare/_StringCompareText), ZeroMem (→ memset), _ClassAddRef/_ClassRelease for manual ARC management. EmitPointerWrite now emits retain/release when the base type is tyString, enabling ARC-correct string storage in ^string arrays. ZeroMem is used to zero-initialise newly grown string slots so the "release old" half of ARC never sees uninitialised memory. Classes.pas: TObjectList (^Pointer array, no ARC overhead) and TStringList (^string + ^Pointer parallel arrays, sorted binary search via CompareText, complete Delete/Insert/Clear with correct ARC). Generics.Collections and phase3_milestone updated to zero-init new array slots, fixing previously hidden memory safety issues revealed by the EmitPointerWrite ARC fix. 785 tests pass, zero Valgrind errors.
This commit is contained in:
Graeme Geldenhuys
parent
3b9339ae70
commit
6688f32926
|
|
@ -1786,6 +1786,8 @@ var
|
|||
MDecl: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
ArgTemp: string;
|
||||
ArgTemp2: string;
|
||||
SizeTemp: string;
|
||||
ArgLine: string;
|
||||
I: Integer;
|
||||
begin
|
||||
|
|
@ -1823,6 +1825,24 @@ begin
|
|||
ArgTemp := EmitExpr(TASTExpr(ACall.Args[0]));
|
||||
EmitLine(Format(' call $free(l %s)', [ArgTemp]));
|
||||
end
|
||||
else if UCaseName = 'ZEROMEM' then
|
||||
begin
|
||||
ArgTemp := EmitExpr(TASTExpr(ACall.Args[0]));
|
||||
ArgTemp2 := EmitExpr(TASTExpr(ACall.Args[1]));
|
||||
SizeTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l extsw %s', [SizeTemp, ArgTemp2]));
|
||||
EmitLine(Format(' call $memset(l %s, w 0, l %s)', [ArgTemp, SizeTemp]));
|
||||
end
|
||||
else if UCaseName = '_CLASSADDREF' then
|
||||
begin
|
||||
ArgTemp := EmitExpr(TASTExpr(ACall.Args[0]));
|
||||
EmitLine(Format(' call $_ClassAddRef(l %s)', [ArgTemp]));
|
||||
end
|
||||
else if UCaseName = '_CLASSRELEASE' then
|
||||
begin
|
||||
ArgTemp := EmitExpr(TASTExpr(ACall.Args[0]));
|
||||
EmitLine(Format(' call $_ClassRelease(l %s)', [ArgTemp]));
|
||||
end
|
||||
else
|
||||
raise ECodeGenError.CreateFmt(
|
||||
'Unknown procedure ''%s'' at line %d', [ACall.Name, ACall.Line]);
|
||||
|
|
@ -1832,10 +1852,22 @@ procedure TCodeGenQBE.EmitPointerWrite(AStmt: TPointerWriteStmt);
|
|||
var
|
||||
PtrTemp: string;
|
||||
ValTemp: string;
|
||||
OldTemp: string;
|
||||
QType: string;
|
||||
StoreInstr: string;
|
||||
begin
|
||||
PtrTemp := EmitExpr(AStmt.PtrExpr);
|
||||
{ ARC: string stored through a typed pointer needs retain/release }
|
||||
if (AStmt.BaseTy <> nil) and AStmt.BaseTy.IsString then
|
||||
begin
|
||||
OldTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l loadl %s', [OldTemp, PtrTemp]));
|
||||
ValTemp := EmitExpr(AStmt.ValExpr);
|
||||
EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp]));
|
||||
EmitLine(Format(' call $_StringRelease(l %s)', [OldTemp]));
|
||||
EmitLine(Format(' storel %s, %s', [ValTemp, PtrTemp]));
|
||||
Exit;
|
||||
end;
|
||||
ValTemp := EmitExpr(AStmt.ValExpr);
|
||||
QType := QbeTypeOf(AStmt.BaseTy);
|
||||
if QType = 'w' then StoreInstr := 'storew'
|
||||
|
|
@ -2046,6 +2078,26 @@ begin
|
|||
Exit;
|
||||
end;
|
||||
|
||||
if SameText(Name, 'CompareStr') then
|
||||
begin
|
||||
L := EmitExpr(TASTExpr(Args[0]));
|
||||
R := EmitExpr(TASTExpr(Args[1]));
|
||||
T := AllocTemp;
|
||||
EmitLine(Format(' %s =w call $_StringCompare(l %s, l %s)', [T, L, R]));
|
||||
Result := T;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if SameText(Name, 'CompareText') then
|
||||
begin
|
||||
L := EmitExpr(TASTExpr(Args[0]));
|
||||
R := EmitExpr(TASTExpr(Args[1]));
|
||||
T := AllocTemp;
|
||||
EmitLine(Format(' %s =w call $_StringCompareText(l %s, l %s)', [T, L, R]));
|
||||
Result := T;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{ Type cast TypeName(Expr) — ResolvedDecl is nil; just copy with target QBE type }
|
||||
if ResolvedDecl = nil then
|
||||
begin
|
||||
|
|
|
|||
|
|
@ -258,8 +258,8 @@ var
|
|||
begin
|
||||
if AExpected = AActual then
|
||||
Exit;
|
||||
{ nil is compatible with any class, interface, or pointer type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface, tyPointer]) then
|
||||
{ nil is compatible with any class, interface, pointer, or string type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface, tyPointer, tyString]) then
|
||||
Exit;
|
||||
{ Two pointer types are compatible when:
|
||||
- either is untyped (Pointer), or
|
||||
|
|
@ -2196,6 +2196,17 @@ begin
|
|||
Exit;
|
||||
end;
|
||||
|
||||
if SameText(AExpr.Name, 'CompareStr') or SameText(AExpr.Name, 'CompareText') then
|
||||
begin
|
||||
if AExpr.Args.Count <> 2 then
|
||||
SemanticError(AExpr.Name + ' requires exactly 2 arguments', AExpr.Line, AExpr.Col);
|
||||
AnalyseExpr(TASTExpr(AExpr.Args[0]));
|
||||
AnalyseExpr(TASTExpr(AExpr.Args[1]));
|
||||
Result := FTable.TypeInteger;
|
||||
AExpr.ResolvedType := Result;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Idx := FProcIndex.IndexOf(AExpr.Name);
|
||||
if Idx < 0 then
|
||||
SemanticError(
|
||||
|
|
|
|||
|
|
@ -802,6 +802,14 @@ begin
|
|||
Define(Sym);
|
||||
Sym := TSymbol.Create('StrToInt', skFunction, FTypeInteger);
|
||||
Define(Sym);
|
||||
Sym := TSymbol.Create('CompareStr', skFunction, FTypeInteger);
|
||||
Define(Sym);
|
||||
Sym := TSymbol.Create('CompareText', skFunction, FTypeInteger);
|
||||
Define(Sym);
|
||||
{ Memory utilities }
|
||||
Sym := TSymbol.Create('ZeroMem', skProcedure, nil); Define(Sym);
|
||||
Sym := TSymbol.Create('_ClassAddRef', skProcedure, nil); Define(Sym);
|
||||
Sym := TSymbol.Create('_ClassRelease',skProcedure, nil); Define(Sym);
|
||||
end;
|
||||
|
||||
function TSymbolTable.DefineGlobal(ASymbol: TSymbol): Boolean;
|
||||
|
|
|
|||
|
|
@ -53,6 +53,7 @@ uses
|
|||
cp.test.genericconstraints,
|
||||
cp.test.weakref,
|
||||
cp.test.stringops,
|
||||
cp.test.collections,
|
||||
cp.test.e2e;
|
||||
|
||||
var
|
||||
|
|
|
|||
444
compiler/src/test/pascal/cp.test.collections.pas
Normal file
444
compiler/src/test/pascal/cp.test.collections.pas
Normal file
|
|
@ -0,0 +1,444 @@
|
|||
{
|
||||
Blaise - An Object Pascal Compiler
|
||||
Copyright (c) 2026 Graeme Geldenhuys
|
||||
SPDX-License-Identifier: BSD-3-Clause
|
||||
See LICENSE file in the project root for full license terms.
|
||||
}
|
||||
|
||||
unit cp.test.collections;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{ Tests for TObjectList and TStringList built in pure Blaise Pascal:
|
||||
- TObjectList: dynamic Pointer array, optional ownership
|
||||
- TStringList: dynamic string + Pointer parallel arrays with
|
||||
sorted binary search and case-insensitive lookup
|
||||
|
||||
New builtins exercised:
|
||||
CompareStr(s1, s2) : Integer
|
||||
CompareText(s1, s2): Integer
|
||||
ZeroMem(ptr, count): procedure
|
||||
_ClassAddRef(ptr) : procedure (raw ARC)
|
||||
_ClassRelease(ptr) : procedure (raw ARC)
|
||||
|
||||
ARC correctness fix exercised:
|
||||
EmitPointerWrite emits retain/release when BaseTy is tyString. }
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TCollectionTests = class(TTestCase)
|
||||
private
|
||||
function GenIR(const ASrc: string): string;
|
||||
procedure SemanticOK(const ASrc: string);
|
||||
published
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ CompareStr / CompareText builtins }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_CompareStr_OK;
|
||||
procedure TestSemantic_CompareText_OK;
|
||||
procedure TestSemantic_CompareStr_ReturnsInteger;
|
||||
procedure TestCodegen_CompareStr_CallsRTL;
|
||||
procedure TestCodegen_CompareText_CallsRTL;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ ZeroMem builtin }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_ZeroMem_OK;
|
||||
procedure TestCodegen_ZeroMem_CallsMemset;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TObjectList — IR / semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_TObjectList_Compiles;
|
||||
procedure TestCodegen_TObjectList_AddEmitsStore;
|
||||
procedure TestCodegen_TObjectList_GetEmitsLoad;
|
||||
procedure TestCodegen_TObjectList_GrowEmitsRealloc;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TStringList — IR / semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_TStringList_Compiles;
|
||||
procedure TestCodegen_TStringList_AddEmitsStringStore;
|
||||
procedure TestCodegen_TStringList_FindEmitsCompare;
|
||||
procedure TestCodegen_TStringList_ZeroMemInGrow;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Blaise source constants }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
{ Minimal TObjectList inline source }
|
||||
SrcTObjectListBase =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TObjectList = class' + LineEnding +
|
||||
' FData: ^Pointer;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCapacity = 0 then NewCap := 4' + LineEnding +
|
||||
' else NewCap := Self.FCapacity * 2;' + LineEnding +
|
||||
' Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(AObject: Pointer): Integer;' + LineEnding +
|
||||
' var Dest: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' Dest := Self.FData + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' Dest^ := AObject;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1;' + LineEnding +
|
||||
' Result := Self.FCount - 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): Pointer;' + LineEnding +
|
||||
' var Src: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Src := Self.FData + AIndex * SizeOf(Pointer);' + LineEnding +
|
||||
' Result := Src^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding;
|
||||
|
||||
SrcTObjectListUse =
|
||||
SrcTObjectListBase +
|
||||
'var L: TObjectList;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TObjectList.Create;' + LineEnding +
|
||||
' L.Add(nil);' + LineEnding +
|
||||
' L.Add(nil)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTObjectListGet =
|
||||
SrcTObjectListBase +
|
||||
'var' + LineEnding +
|
||||
' L: TObjectList;' + LineEnding +
|
||||
' P: Pointer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TObjectList.Create;' + LineEnding +
|
||||
' L.Add(nil);' + LineEnding +
|
||||
' P := L.Get(0)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ CompareStr/CompareText test }
|
||||
SrcCompareStr =
|
||||
'program P;' + LineEnding +
|
||||
'var N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' N := CompareStr(''abc'', ''abd'')' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcCompareText =
|
||||
'program P;' + LineEnding +
|
||||
'var N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' N := CompareText(''ABC'', ''abc'')' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ZeroMem test }
|
||||
SrcZeroMem =
|
||||
'program P;' + LineEnding +
|
||||
'var P: Pointer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' P := GetMem(16);' + LineEnding +
|
||||
' ZeroMem(P, 16)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ Minimal TStringList inline source }
|
||||
SrcTStringListBase =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TStringList = class' + LineEnding +
|
||||
' FStrings: ^string;' + LineEnding +
|
||||
' FObjects: ^Pointer;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' FSorted: Boolean;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var OldCap, NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' OldCap := Self.FCapacity;' + LineEnding +
|
||||
' if OldCap = 0 then NewCap := 4' + LineEnding +
|
||||
' else NewCap := OldCap * 2;' + LineEnding +
|
||||
' Self.FStrings := ReallocMem(Self.FStrings, NewCap * SizeOf(string));' + LineEnding +
|
||||
' Self.FObjects := ReallocMem(Self.FObjects, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' ZeroMem(Self.FStrings + OldCap * SizeOf(string), (NewCap - OldCap) * SizeOf(string));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(S: string): Integer;' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' StrP: ^string;' + LineEnding +
|
||||
' ObjP: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' StrP := Self.FStrings + Self.FCount * SizeOf(string);' + LineEnding +
|
||||
' ObjP := Self.FObjects + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' StrP^ := S;' + LineEnding +
|
||||
' ObjP^ := nil;' + LineEnding +
|
||||
' Result := Self.FCount;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): string;' + LineEnding +
|
||||
' var Ptr: ^string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Ptr := Self.FStrings + AIndex * SizeOf(string);' + LineEnding +
|
||||
' Result := Ptr^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Find(S: string; var Index: Integer): Boolean;' + LineEnding +
|
||||
' var' + LineEnding +
|
||||
' Lo, Hi, Mid, Cmp: Integer;' + LineEnding +
|
||||
' Ptr: ^string;' + LineEnding +
|
||||
' MStr: string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Lo := 0;' + LineEnding +
|
||||
' Hi := Self.FCount - 1;' + LineEnding +
|
||||
' while Lo <= Hi do' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Mid := (Lo + Hi) div 2;' + LineEnding +
|
||||
' Ptr := Self.FStrings + Mid * SizeOf(string);' + LineEnding +
|
||||
' MStr := Ptr^;' + LineEnding +
|
||||
' Cmp := CompareText(S, MStr);' + LineEnding +
|
||||
' if Cmp = 0 then' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Index := Mid;' + LineEnding +
|
||||
' Result := True;' + LineEnding +
|
||||
' Exit' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
' else if Cmp < 0 then' + LineEnding +
|
||||
' Hi := Mid - 1' + LineEnding +
|
||||
' else' + LineEnding +
|
||||
' Lo := Mid + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' Index := Lo;' + LineEnding +
|
||||
' Result := False' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding;
|
||||
|
||||
SrcTStringListUse =
|
||||
SrcTStringListBase +
|
||||
'var L: TStringList;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TStringList.Create;' + LineEnding +
|
||||
' L.Add(''hello'');' + LineEnding +
|
||||
' L.Add(''world'')' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTStringListFind =
|
||||
SrcTStringListBase +
|
||||
'var' + LineEnding +
|
||||
' L: TStringList;' + LineEnding +
|
||||
' Idx: Integer;' + LineEnding +
|
||||
' Found: Boolean;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TStringList.Create;' + LineEnding +
|
||||
' L.Add(''alpha'');' + LineEnding +
|
||||
' L.Add(''beta'');' + LineEnding +
|
||||
' Found := L.Find(''alpha'', Idx)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TCollectionTests.GenIR(const ASrc: string): string;
|
||||
var
|
||||
Lex: TLexer;
|
||||
Par: TParser;
|
||||
SA: TSemanticAnalyser;
|
||||
CG: TCodeGenQBE;
|
||||
Prog: TProgram;
|
||||
begin
|
||||
Lex := TLexer.Create(ASrc);
|
||||
Par := TParser.Create(Lex);
|
||||
Prog := Par.Parse;
|
||||
Par.Free;
|
||||
Lex.Free;
|
||||
SA := TSemanticAnalyser.Create;
|
||||
SA.Analyse(Prog);
|
||||
SA.Free;
|
||||
CG := TCodeGenQBE.Create;
|
||||
CG.Generate(Prog);
|
||||
Result := CG.GetOutput;
|
||||
CG.Free;
|
||||
Prog.Free;
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.SemanticOK(const ASrc: string);
|
||||
var
|
||||
Lex: TLexer;
|
||||
Par: TParser;
|
||||
SA: TSemanticAnalyser;
|
||||
Prog: TProgram;
|
||||
begin
|
||||
Lex := TLexer.Create(ASrc);
|
||||
Par := TParser.Create(Lex);
|
||||
Prog := Par.Parse;
|
||||
Par.Free;
|
||||
Lex.Free;
|
||||
SA := TSemanticAnalyser.Create;
|
||||
try
|
||||
SA.Analyse(Prog);
|
||||
finally
|
||||
SA.Free;
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ CompareStr / CompareText }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TCollectionTests.TestSemantic_CompareStr_OK;
|
||||
begin
|
||||
SemanticOK(SrcCompareStr);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestSemantic_CompareText_OK;
|
||||
begin
|
||||
SemanticOK(SrcCompareText);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestSemantic_CompareStr_ReturnsInteger;
|
||||
var
|
||||
Lex: TLexer;
|
||||
Par: TParser;
|
||||
SA: TSemanticAnalyser;
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
begin
|
||||
Lex := TLexer.Create(SrcCompareStr);
|
||||
Par := TParser.Create(Lex);
|
||||
Prog := Par.Parse;
|
||||
Par.Free;
|
||||
Lex.Free;
|
||||
SA := TSemanticAnalyser.Create;
|
||||
SA.Analyse(Prog);
|
||||
SA.Free;
|
||||
Assign := TAssignment(Prog.Block.Stmts[0]);
|
||||
AssertEquals('CompareStr returns Integer',
|
||||
Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind));
|
||||
Prog.Free;
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_CompareStr_CallsRTL;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCompareStr);
|
||||
AssertTrue('CompareStr emits _StringCompare call',
|
||||
Pos('_StringCompare', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_CompareText_CallsRTL;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCompareText);
|
||||
AssertTrue('CompareText emits _StringCompareText call',
|
||||
Pos('_StringCompareText', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ ZeroMem }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TCollectionTests.TestSemantic_ZeroMem_OK;
|
||||
begin
|
||||
SemanticOK(SrcZeroMem);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_ZeroMem_CallsMemset;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcZeroMem);
|
||||
AssertTrue('ZeroMem emits memset call', Pos('call $memset', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TObjectList }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TCollectionTests.TestSemantic_TObjectList_Compiles;
|
||||
begin
|
||||
SemanticOK(SrcTObjectListUse);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TObjectList_AddEmitsStore;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTObjectListUse);
|
||||
AssertTrue('TObjectList.Add emits storel for Pointer element',
|
||||
Pos('storel', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TObjectList_GetEmitsLoad;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTObjectListGet);
|
||||
AssertTrue('TObjectList.Get emits loadl for Pointer element',
|
||||
Pos('loadl', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TObjectList_GrowEmitsRealloc;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTObjectListUse);
|
||||
AssertTrue('TObjectList.Grow emits realloc call',
|
||||
Pos('call $realloc', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TStringList }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TCollectionTests.TestSemantic_TStringList_Compiles;
|
||||
begin
|
||||
SemanticOK(SrcTStringListUse);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TStringList_AddEmitsStringStore;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTStringListUse);
|
||||
{ String ARC: Add must emit _StringAddRef for the stored string }
|
||||
AssertTrue('TStringList.Add emits _StringAddRef for stored string',
|
||||
Pos('_StringAddRef', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TStringList_FindEmitsCompare;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTStringListFind);
|
||||
AssertTrue('TStringList.Find uses CompareText RTL call',
|
||||
Pos('_StringCompareText', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCollectionTests.TestCodegen_TStringList_ZeroMemInGrow;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTStringListUse);
|
||||
AssertTrue('TStringList.Grow emits memset for zero-init of new string slots',
|
||||
Pos('call $memset', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TCollectionTests);
|
||||
|
||||
end.
|
||||
|
|
@ -121,6 +121,14 @@ type
|
|||
procedure TestRun_StringOps_Format_IntArg;
|
||||
procedure TestRun_StringOps_Format_StrArg;
|
||||
procedure TestRun_StringOps_Format_MixedArgs;
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Collections: TObjectList, TStringList }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestRun_TObjectList_AddGetCount;
|
||||
procedure TestRun_TObjectList_Delete;
|
||||
procedure TestRun_TStringList_AddGet;
|
||||
procedure TestRun_TStringList_Find_Sorted;
|
||||
procedure TestRun_Collections_Valgrind;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
|
@ -1331,6 +1339,355 @@ begin
|
|||
AssertEquals('Format mixed args', 'Alice=30', Trim(Output));
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Collections e2e tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcTObjectListBase2 =
|
||||
'type' + LineEnding +
|
||||
' TObjectList = class' + LineEnding +
|
||||
' FData: ^Pointer;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var OldCap, NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' OldCap := Self.FCapacity;' + LineEnding +
|
||||
' if OldCap = 0 then NewCap := 4' + LineEnding +
|
||||
' else NewCap := OldCap * 2;' + LineEnding +
|
||||
' Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(AObject: Pointer): Integer;' + LineEnding +
|
||||
' var Dest: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' Dest := Self.FData + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' Dest^ := AObject;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1;' + LineEnding +
|
||||
' Result := Self.FCount - 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): Pointer;' + LineEnding +
|
||||
' var Src: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Src := Self.FData + AIndex * SizeOf(Pointer);' + LineEnding +
|
||||
' Result := Src^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' procedure Delete(AIndex: Integer);' + LineEnding +
|
||||
' var I: Integer; Dst, Src: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' I := AIndex;' + LineEnding +
|
||||
' while I < Self.FCount - 1 do' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Dst := Self.FData + I * SizeOf(Pointer);' + LineEnding +
|
||||
' Src := Self.FData + (I + 1) * SizeOf(Pointer);' + LineEnding +
|
||||
' Dst^ := Src^;' + LineEnding +
|
||||
' I := I + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' Self.FCount := Self.FCount - 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding;
|
||||
|
||||
SrcTObjectListAddGetCount =
|
||||
'program P;' + LineEnding +
|
||||
SrcTObjectListBase2 +
|
||||
'var' + LineEnding +
|
||||
' L: TObjectList;' + LineEnding +
|
||||
' P1, P2: Pointer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TObjectList.Create;' + LineEnding +
|
||||
' P1 := GetMem(1);' + LineEnding +
|
||||
' P2 := GetMem(1);' + LineEnding +
|
||||
' L.Add(P1);' + LineEnding +
|
||||
' L.Add(P2);' + LineEnding +
|
||||
' L.Add(nil);' + LineEnding +
|
||||
' WriteLn(L.Count);' + LineEnding +
|
||||
' WriteLn(L.Get(0) = P1);' + LineEnding +
|
||||
' WriteLn(L.Get(1) = P2)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTObjectListDelete =
|
||||
'program P;' + LineEnding +
|
||||
SrcTObjectListBase2 +
|
||||
'var L: TObjectList;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TObjectList.Create;' + LineEnding +
|
||||
' L.Add(GetMem(1));' + LineEnding +
|
||||
' L.Add(GetMem(1));' + LineEnding +
|
||||
' L.Add(GetMem(1));' + LineEnding +
|
||||
' L.Delete(1);' + LineEnding +
|
||||
' WriteLn(L.Count)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTStringListBase2 =
|
||||
'type' + LineEnding +
|
||||
' TStringList = class' + LineEnding +
|
||||
' FStrings: ^string;' + LineEnding +
|
||||
' FObjects: ^Pointer;' + LineEnding +
|
||||
' FCount: Integer;' + LineEnding +
|
||||
' FCapacity: Integer;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var OldCap, NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' OldCap := Self.FCapacity;' + LineEnding +
|
||||
' if OldCap = 0 then NewCap := 4' + LineEnding +
|
||||
' else NewCap := OldCap * 2;' + LineEnding +
|
||||
' Self.FStrings := ReallocMem(Self.FStrings, NewCap * SizeOf(string));' + LineEnding +
|
||||
' Self.FObjects := ReallocMem(Self.FObjects, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' ZeroMem(Self.FStrings + OldCap * SizeOf(string),' + LineEnding +
|
||||
' (NewCap - OldCap) * SizeOf(string));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' procedure Destroy;' + LineEnding +
|
||||
' var I: Integer; Ptr: ^string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' I := 0;' + LineEnding +
|
||||
' while I < Self.FCount do' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Ptr := Self.FStrings + I * SizeOf(string);' + LineEnding +
|
||||
' Ptr^ := nil;' + LineEnding +
|
||||
' I := I + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' FreeMem(Self.FStrings);' + LineEnding +
|
||||
' FreeMem(Self.FObjects);' + LineEnding +
|
||||
' Self.FStrings := nil;' + LineEnding +
|
||||
' Self.FObjects := nil;' + LineEnding +
|
||||
' Self.FCount := 0;' + LineEnding +
|
||||
' Self.FCapacity := 0' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(S: string): Integer;' + LineEnding +
|
||||
' var StrP: ^string; ObjP: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' StrP := Self.FStrings + Self.FCount * SizeOf(string);' + LineEnding +
|
||||
' ObjP := Self.FObjects + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' StrP^ := S;' + LineEnding +
|
||||
' ObjP^ := nil;' + LineEnding +
|
||||
' Result := Self.FCount;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): string;' + LineEnding +
|
||||
' var Ptr: ^string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Ptr := Self.FStrings + AIndex * SizeOf(string);' + LineEnding +
|
||||
' Result := Ptr^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Find(S: string; var Index: Integer): Boolean;' + LineEnding +
|
||||
' var Lo, Hi, Mid, Cmp: Integer; Ptr: ^string; MStr: string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Lo := 0; Hi := Self.FCount - 1;' + LineEnding +
|
||||
' while Lo <= Hi do' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Mid := (Lo + Hi) div 2;' + LineEnding +
|
||||
' Ptr := Self.FStrings + Mid * SizeOf(string);' + LineEnding +
|
||||
' MStr := Ptr^;' + LineEnding +
|
||||
' Cmp := CompareText(S, MStr);' + LineEnding +
|
||||
' if Cmp = 0 then' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Index := Mid; Result := True; Exit' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
' else if Cmp < 0 then Hi := Mid - 1' + LineEnding +
|
||||
' else Lo := Mid + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' Index := Lo; Result := False' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding;
|
||||
|
||||
SrcTStringListAddGet =
|
||||
'program P;' + LineEnding +
|
||||
SrcTStringListBase2 +
|
||||
'var' + LineEnding +
|
||||
' L: TStringList;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TStringList.Create;' + LineEnding +
|
||||
' L.Add(''hello'');' + LineEnding +
|
||||
' L.Add(''world'');' + LineEnding +
|
||||
' WriteLn(L.Count);' + LineEnding +
|
||||
' WriteLn(L.Get(0));' + LineEnding +
|
||||
' WriteLn(L.Get(1))' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTStringListFindSorted =
|
||||
'program P;' + LineEnding +
|
||||
SrcTStringListBase2 +
|
||||
'var' + LineEnding +
|
||||
' L: TStringList;' + LineEnding +
|
||||
' Idx: Integer;' + LineEnding +
|
||||
' Found: Boolean;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' L := TStringList.Create;' + LineEnding +
|
||||
' L.Add(''alpha'');' + LineEnding +
|
||||
' L.Add(''beta'');' + LineEnding +
|
||||
' L.Add(''gamma'');' + LineEnding +
|
||||
' Found := L.Find(''beta'', Idx);' + LineEnding +
|
||||
' WriteLn(Found);' + LineEnding +
|
||||
' WriteLn(Idx);' + LineEnding +
|
||||
' Found := L.Find(''delta'', Idx);' + LineEnding +
|
||||
' WriteLn(Found)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ Combined program: both classes in a single type section }
|
||||
SrcCollectionsValgrind =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TObjectList = class' + LineEnding +
|
||||
' FData: ^Pointer; FCount: Integer; FCapacity: Integer;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var OldCap, NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' OldCap := Self.FCapacity;' + LineEnding +
|
||||
' if OldCap = 0 then NewCap := 4 else NewCap := OldCap * 2;' + LineEnding +
|
||||
' Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(AObject: Pointer): Integer;' + LineEnding +
|
||||
' var Dest: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' Dest := Self.FData + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' Dest^ := AObject;' + LineEnding +
|
||||
' Self.FCount := Self.FCount + 1;' + LineEnding +
|
||||
' Result := Self.FCount - 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' procedure Destroy;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' FreeMem(Self.FData);' + LineEnding +
|
||||
' Self.FData := nil; Self.FCount := 0; Self.FCapacity := 0' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' TStringList = class' + LineEnding +
|
||||
' FStrings: ^string; FObjects: ^Pointer;' + LineEnding +
|
||||
' FCount: Integer; FCapacity: Integer;' + LineEnding +
|
||||
' procedure Grow;' + LineEnding +
|
||||
' var OldCap, NewCap: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' OldCap := Self.FCapacity;' + LineEnding +
|
||||
' if OldCap = 0 then NewCap := 4 else NewCap := OldCap * 2;' + LineEnding +
|
||||
' Self.FStrings := ReallocMem(Self.FStrings, NewCap * SizeOf(string));' + LineEnding +
|
||||
' Self.FObjects := ReallocMem(Self.FObjects, NewCap * SizeOf(Pointer));' + LineEnding +
|
||||
' ZeroMem(Self.FStrings + OldCap * SizeOf(string),' + LineEnding +
|
||||
' (NewCap - OldCap) * SizeOf(string));' + LineEnding +
|
||||
' Self.FCapacity := NewCap' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' procedure Destroy;' + LineEnding +
|
||||
' var I: Integer; Ptr: ^string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' I := 0;' + LineEnding +
|
||||
' while I < Self.FCount do' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Ptr := Self.FStrings + I * SizeOf(string); Ptr^ := nil; I := I + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' FreeMem(Self.FStrings); FreeMem(Self.FObjects);' + LineEnding +
|
||||
' Self.FStrings := nil; Self.FObjects := nil;' + LineEnding +
|
||||
' Self.FCount := 0; Self.FCapacity := 0' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Add(S: string): Integer;' + LineEnding +
|
||||
' var StrP: ^string; ObjP: ^Pointer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' if Self.FCount = Self.FCapacity then Self.Grow;' + LineEnding +
|
||||
' StrP := Self.FStrings + Self.FCount * SizeOf(string);' + LineEnding +
|
||||
' ObjP := Self.FObjects + Self.FCount * SizeOf(Pointer);' + LineEnding +
|
||||
' StrP^ := S; ObjP^ := nil;' + LineEnding +
|
||||
' Result := Self.FCount; Self.FCount := Self.FCount + 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function Get(AIndex: Integer): string;' + LineEnding +
|
||||
' var Ptr: ^string;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Ptr := Self.FStrings + AIndex * SizeOf(string); Result := Ptr^' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' property Count: Integer read FCount;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var OL: TObjectList; SL: TStringList;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' OL := TObjectList.Create;' + LineEnding +
|
||||
' OL.Add(nil); OL.Add(nil);' + LineEnding +
|
||||
' SL := TStringList.Create;' + LineEnding +
|
||||
' SL.Add(''hello''); SL.Add(''world'');' + LineEnding +
|
||||
' WriteLn(OL.Count);' + LineEnding +
|
||||
' WriteLn(SL.Get(0))' + LineEnding +
|
||||
'end.';
|
||||
|
||||
procedure TE2ETests.TestRun_TObjectList_AddGetCount;
|
||||
var
|
||||
Output: string;
|
||||
RCode: Integer;
|
||||
begin
|
||||
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(SrcTObjectListAddGetCount, Output, RCode, []));
|
||||
AssertEquals('count=3', '3', Trim(Copy(Output, 1, Pos(LineEnding, Output) - 1)));
|
||||
end;
|
||||
|
||||
procedure TE2ETests.TestRun_TObjectList_Delete;
|
||||
var
|
||||
Output: string;
|
||||
RCode: Integer;
|
||||
begin
|
||||
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(SrcTObjectListDelete, Output, RCode, []));
|
||||
AssertEquals('count after delete=2', '2', Trim(Output));
|
||||
end;
|
||||
|
||||
procedure TE2ETests.TestRun_TStringList_AddGet;
|
||||
var
|
||||
Output: string;
|
||||
RCode: Integer;
|
||||
Lines: TStringList;
|
||||
begin
|
||||
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(SrcTStringListAddGet, Output, RCode, []));
|
||||
Lines := TStringList.Create;
|
||||
try
|
||||
Lines.Text := Trim(Output);
|
||||
AssertEquals('count=2', '2', Lines[0]);
|
||||
AssertEquals('get(0)', 'hello', Lines[1]);
|
||||
AssertEquals('get(1)', 'world', Lines[2]);
|
||||
finally
|
||||
Lines.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ETests.TestRun_TStringList_Find_Sorted;
|
||||
var
|
||||
Output: string;
|
||||
RCode: Integer;
|
||||
Lines: TStringList;
|
||||
begin
|
||||
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(SrcTStringListFindSorted, Output, RCode, []));
|
||||
Lines := TStringList.Create;
|
||||
try
|
||||
Lines.Text := Trim(Output);
|
||||
AssertEquals('found=1 (true)', '1', Lines[0]);
|
||||
AssertEquals('idx=1', '1', Lines[1]);
|
||||
AssertEquals('not found=0', '0', Lines[2]);
|
||||
finally
|
||||
Lines.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ETests.TestRun_Collections_Valgrind;
|
||||
var
|
||||
OK: Boolean;
|
||||
Log: string;
|
||||
begin
|
||||
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
if RunProc('valgrind', ['--version'], Log, True) <> 0 then
|
||||
begin
|
||||
Ignore('valgrind not installed');
|
||||
Exit;
|
||||
end;
|
||||
OK := RunUnderValgrind(SrcCollectionsValgrind, Log);
|
||||
if not OK then
|
||||
begin
|
||||
if Log = '' then Log := '(valgrind produced no output)';
|
||||
Fail('Collections Valgrind check failed:' + LineEnding + Log);
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TE2ETests);
|
||||
|
||||
|
|
|
|||
|
|
@ -179,6 +179,34 @@ int32_t _StrToInt(void* s) {
|
|||
return (int32_t)strtol(data, NULL, 10);
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------ */
|
||||
/* _StringCompare(s1, s2) : Integer — case-sensitive (like strcmp) */
|
||||
/* ------------------------------------------------------------------ */
|
||||
|
||||
int32_t _StringCompare(void* s1, void* s2) {
|
||||
const char* d1 = str_data(s1);
|
||||
const char* d2 = str_data(s2);
|
||||
while (*d1 && (*d1 == *d2)) { d1++; d2++; }
|
||||
return (int32_t)((unsigned char)*d1 - (unsigned char)*d2);
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------ */
|
||||
/* _StringCompareText(s1, s2) : Integer — case-insensitive */
|
||||
/* ------------------------------------------------------------------ */
|
||||
|
||||
int32_t _StringCompareText(void* s1, void* s2) {
|
||||
const char* d1 = str_data(s1);
|
||||
const char* d2 = str_data(s2);
|
||||
int c1, c2;
|
||||
while (*d1) {
|
||||
c1 = tolower((unsigned char)*d1);
|
||||
c2 = tolower((unsigned char)*d2);
|
||||
if (c1 != c2) return (int32_t)(c1 - c2);
|
||||
d1++; d2++;
|
||||
}
|
||||
return (int32_t)(0 - tolower((unsigned char)*d2));
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------ */
|
||||
/* _StringFormat(fmt, ...) : string */
|
||||
/* */
|
||||
|
|
|
|||
491
rtl/src/main/pascal/Classes.pas
Normal file
491
rtl/src/main/pascal/Classes.pas
Normal file
|
|
@ -0,0 +1,491 @@
|
|||
{
|
||||
Blaise - An Object Pascal Compiler
|
||||
Copyright (c) 2026 Graeme Geldenhuys
|
||||
SPDX-License-Identifier: BSD-3-Clause
|
||||
See LICENSE file in the project root for full license terms.
|
||||
}
|
||||
|
||||
unit Classes;
|
||||
|
||||
// Blaise RTL — Classes unit.
|
||||
//
|
||||
// Provides TObjectList and TStringList with a method-based API compatible
|
||||
// with the Blaise compiler source for self-hosting.
|
||||
//
|
||||
// Design notes:
|
||||
// - Indexed properties (Items[I], Objects[I]) are not supported in Blaise;
|
||||
// use Get(I)/Put(I,...) and GetObject(I)/SetObject(I,...) instead.
|
||||
// - TDuplicates is replaced by Integer constants: dupAccept=0, dupIgnore=1,
|
||||
// dupError=2 (enums are not yet supported in Blaise).
|
||||
// - TObjectList does not manage class instance lifetimes automatically;
|
||||
// in Blaise's ARC model, objects are freed when their last strong
|
||||
// reference drops. Use _ClassAddRef/_ClassRelease for manual management.
|
||||
// - TStringList stores strings as ^string; ARC is emitted by the compiler
|
||||
// for pointer-dereference writes (EmitPointerWrite). ZeroMem is used to
|
||||
// zero-initialise newly grown string slots so no garbage is ever released.
|
||||
|
||||
interface
|
||||
|
||||
const
|
||||
dupAccept = 0;
|
||||
dupIgnore = 1;
|
||||
dupError = 2;
|
||||
|
||||
type
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TObjectList }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
TObjectList = class
|
||||
FData: ^Pointer;
|
||||
FCount: Integer;
|
||||
FCapacity: Integer;
|
||||
FOwnsObjects: Boolean;
|
||||
procedure Grow;
|
||||
constructor Create(AOwnsObjects: Boolean);
|
||||
procedure Destroy;
|
||||
function Add(AObject: Pointer): Integer;
|
||||
function Get(AIndex: Integer): Pointer;
|
||||
procedure Put(AIndex: Integer; AObject: Pointer);
|
||||
function IndexOf(AObject: Pointer): Integer;
|
||||
procedure Delete(AIndex: Integer);
|
||||
procedure Clear;
|
||||
property Count: Integer read FCount;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TStringList }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
TStringList = class
|
||||
FStrings: ^string;
|
||||
FObjects: ^Pointer;
|
||||
FCount: Integer;
|
||||
FCapacity: Integer;
|
||||
FCaseSensitive: Boolean;
|
||||
FSorted: Boolean;
|
||||
FDuplicates: Integer;
|
||||
procedure Grow;
|
||||
function Compare(S1: string; S2: string): Integer;
|
||||
function FindSorted(S: string; var Idx: Integer): Boolean;
|
||||
constructor Create;
|
||||
procedure Destroy;
|
||||
function Add(S: string): Integer;
|
||||
procedure AddObject(S: string; AObject: Pointer);
|
||||
function Find(S: string; var Index: Integer): Boolean;
|
||||
function IndexOf(S: string): Integer;
|
||||
function Get(AIndex: Integer): string;
|
||||
procedure Put(AIndex: Integer; S: string);
|
||||
function GetObject(AIndex: Integer): Pointer;
|
||||
procedure SetObject(AIndex: Integer; AObject: Pointer);
|
||||
procedure Delete(AIndex: Integer);
|
||||
procedure Clear;
|
||||
procedure Insert(AIndex: Integer; S: string);
|
||||
function GetText: string;
|
||||
property Count: Integer read FCount;
|
||||
property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive;
|
||||
property Sorted: Boolean read FSorted write FSorted;
|
||||
property Duplicates: Integer read FDuplicates write FDuplicates;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ================================================================== }
|
||||
{ TObjectList }
|
||||
{ ================================================================== }
|
||||
|
||||
procedure TObjectList.Grow;
|
||||
var
|
||||
NewCap: Integer;
|
||||
begin
|
||||
if Self.FCapacity = 0 then
|
||||
NewCap := 4
|
||||
else
|
||||
NewCap := Self.FCapacity * 2;
|
||||
Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(Pointer));
|
||||
Self.FCapacity := NewCap
|
||||
end;
|
||||
|
||||
constructor TObjectList.Create(AOwnsObjects: Boolean);
|
||||
begin
|
||||
Self.FOwnsObjects := AOwnsObjects
|
||||
end;
|
||||
|
||||
procedure TObjectList.Destroy;
|
||||
begin
|
||||
FreeMem(Self.FData);
|
||||
Self.FData := nil;
|
||||
Self.FCount := 0;
|
||||
Self.FCapacity := 0
|
||||
end;
|
||||
|
||||
function TObjectList.Add(AObject: Pointer): Integer;
|
||||
var
|
||||
Dest: ^Pointer;
|
||||
begin
|
||||
if Self.FCount = Self.FCapacity then
|
||||
Self.Grow;
|
||||
Dest := Self.FData + Self.FCount * SizeOf(Pointer);
|
||||
Dest^ := AObject;
|
||||
Self.FCount := Self.FCount + 1;
|
||||
Result := Self.FCount - 1
|
||||
end;
|
||||
|
||||
function TObjectList.Get(AIndex: Integer): Pointer;
|
||||
var
|
||||
Src: ^Pointer;
|
||||
begin
|
||||
Src := Self.FData + AIndex * SizeOf(Pointer);
|
||||
Result := Src^
|
||||
end;
|
||||
|
||||
procedure TObjectList.Put(AIndex: Integer; AObject: Pointer);
|
||||
var
|
||||
Dest: ^Pointer;
|
||||
begin
|
||||
Dest := Self.FData + AIndex * SizeOf(Pointer);
|
||||
Dest^ := AObject
|
||||
end;
|
||||
|
||||
function TObjectList.IndexOf(AObject: Pointer): Integer;
|
||||
var
|
||||
I: Integer;
|
||||
Src: ^Pointer;
|
||||
begin
|
||||
I := 0;
|
||||
Result := -1;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Src := Self.FData + I * SizeOf(Pointer);
|
||||
if Src^ = AObject then
|
||||
begin
|
||||
Result := I;
|
||||
break
|
||||
end;
|
||||
I := I + 1
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TObjectList.Delete(AIndex: Integer);
|
||||
var
|
||||
I: Integer;
|
||||
Dst: ^Pointer;
|
||||
Src: ^Pointer;
|
||||
begin
|
||||
I := AIndex;
|
||||
while I < Self.FCount - 1 do
|
||||
begin
|
||||
Dst := Self.FData + I * SizeOf(Pointer);
|
||||
Src := Self.FData + (I + 1) * SizeOf(Pointer);
|
||||
Dst^ := Src^;
|
||||
I := I + 1
|
||||
end;
|
||||
Self.FCount := Self.FCount - 1
|
||||
end;
|
||||
|
||||
procedure TObjectList.Clear;
|
||||
begin
|
||||
Self.FCount := 0
|
||||
end;
|
||||
|
||||
{ ================================================================== }
|
||||
{ TStringList }
|
||||
{ ================================================================== }
|
||||
|
||||
procedure TStringList.Grow;
|
||||
var
|
||||
NewCap: Integer;
|
||||
OldCap: Integer;
|
||||
begin
|
||||
OldCap := Self.FCapacity;
|
||||
if OldCap = 0 then
|
||||
NewCap := 4
|
||||
else
|
||||
NewCap := OldCap * 2;
|
||||
Self.FStrings := ReallocMem(Self.FStrings, NewCap * SizeOf(string));
|
||||
Self.FObjects := ReallocMem(Self.FObjects, NewCap * SizeOf(Pointer));
|
||||
{ Zero-initialise new string slots so ARC release of "old" value is safe }
|
||||
ZeroMem(Self.FStrings + OldCap * SizeOf(string),
|
||||
(NewCap - OldCap) * SizeOf(string));
|
||||
Self.FCapacity := NewCap
|
||||
end;
|
||||
|
||||
function TStringList.Compare(S1: string; S2: string): Integer;
|
||||
begin
|
||||
if Self.FCaseSensitive then
|
||||
Result := CompareStr(S1, S2)
|
||||
else
|
||||
Result := CompareText(S1, S2)
|
||||
end;
|
||||
|
||||
function TStringList.FindSorted(S: string; var Idx: Integer): Boolean;
|
||||
var
|
||||
Lo: Integer;
|
||||
Hi: Integer;
|
||||
Mid: Integer;
|
||||
Cmp: Integer;
|
||||
Ptr: ^string;
|
||||
MStr: string;
|
||||
begin
|
||||
Lo := 0;
|
||||
Hi := Self.FCount - 1;
|
||||
while Lo <= Hi do
|
||||
begin
|
||||
Mid := (Lo + Hi) div 2;
|
||||
Ptr := Self.FStrings + Mid * SizeOf(string);
|
||||
MStr := Ptr^;
|
||||
Cmp := Self.Compare(S, MStr);
|
||||
if Cmp = 0 then
|
||||
begin
|
||||
Idx := Mid;
|
||||
Result := True;
|
||||
Exit
|
||||
end
|
||||
else if Cmp < 0 then
|
||||
Hi := Mid - 1
|
||||
else
|
||||
Lo := Mid + 1
|
||||
end;
|
||||
Idx := Lo;
|
||||
Result := False
|
||||
end;
|
||||
|
||||
constructor TStringList.Create;
|
||||
begin
|
||||
Self.FCaseSensitive := True;
|
||||
Self.FSorted := False;
|
||||
Self.FDuplicates := dupAccept
|
||||
end;
|
||||
|
||||
procedure TStringList.Destroy;
|
||||
var
|
||||
I: Integer;
|
||||
Ptr: ^string;
|
||||
begin
|
||||
{ Release all strings before freeing the backing store }
|
||||
I := 0;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Ptr := Self.FStrings + I * SizeOf(string);
|
||||
Ptr^ := nil;
|
||||
I := I + 1
|
||||
end;
|
||||
FreeMem(Self.FStrings);
|
||||
FreeMem(Self.FObjects);
|
||||
Self.FStrings := nil;
|
||||
Self.FObjects := nil;
|
||||
Self.FCount := 0;
|
||||
Self.FCapacity := 0
|
||||
end;
|
||||
|
||||
function TStringList.Add(S: string): Integer;
|
||||
var
|
||||
Idx: Integer;
|
||||
StrP: ^string;
|
||||
ObjP: ^Pointer;
|
||||
begin
|
||||
if Self.FSorted then
|
||||
begin
|
||||
Self.FindSorted(S, Idx);
|
||||
if (Self.FDuplicates = dupIgnore) and
|
||||
(Idx < Self.FCount) then
|
||||
begin
|
||||
{ Check for exact match at Idx }
|
||||
StrP := Self.FStrings + Idx * SizeOf(string);
|
||||
if Self.Compare(S, StrP^) = 0 then
|
||||
begin
|
||||
Result := Idx;
|
||||
Exit
|
||||
end
|
||||
end;
|
||||
Self.Insert(Idx, S);
|
||||
Result := Idx
|
||||
end
|
||||
else
|
||||
begin
|
||||
if Self.FCount = Self.FCapacity then
|
||||
Self.Grow;
|
||||
StrP := Self.FStrings + Self.FCount * SizeOf(string);
|
||||
ObjP := Self.FObjects + Self.FCount * SizeOf(Pointer);
|
||||
StrP^ := S;
|
||||
ObjP^ := nil;
|
||||
Result := Self.FCount;
|
||||
Self.FCount := Self.FCount + 1
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TStringList.AddObject(S: string; AObject: Pointer);
|
||||
var
|
||||
Idx: Integer;
|
||||
ObjP: ^Pointer;
|
||||
begin
|
||||
Idx := Self.Add(S);
|
||||
ObjP := Self.FObjects + Idx * SizeOf(Pointer);
|
||||
ObjP^ := AObject
|
||||
end;
|
||||
|
||||
function TStringList.Find(S: string; var Index: Integer): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
Ptr: ^string;
|
||||
begin
|
||||
if Self.FSorted then
|
||||
Result := Self.FindSorted(S, Index)
|
||||
else
|
||||
begin
|
||||
{ Linear search for unsorted list }
|
||||
I := 0;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Ptr := Self.FStrings + I * SizeOf(string);
|
||||
if Self.Compare(S, Ptr^) = 0 then
|
||||
begin
|
||||
Index := I;
|
||||
Result := True;
|
||||
Exit
|
||||
end;
|
||||
I := I + 1
|
||||
end;
|
||||
Index := -1;
|
||||
Result := False
|
||||
end
|
||||
end;
|
||||
|
||||
function TStringList.IndexOf(S: string): Integer;
|
||||
var
|
||||
Idx: Integer;
|
||||
begin
|
||||
if Self.Find(S, Idx) then
|
||||
Result := Idx
|
||||
else
|
||||
Result := -1
|
||||
end;
|
||||
|
||||
function TStringList.Get(AIndex: Integer): string;
|
||||
var
|
||||
Ptr: ^string;
|
||||
begin
|
||||
Ptr := Self.FStrings + AIndex * SizeOf(string);
|
||||
Result := Ptr^
|
||||
end;
|
||||
|
||||
procedure TStringList.Put(AIndex: Integer; S: string);
|
||||
var
|
||||
Ptr: ^string;
|
||||
begin
|
||||
Ptr := Self.FStrings + AIndex * SizeOf(string);
|
||||
Ptr^ := S
|
||||
end;
|
||||
|
||||
function TStringList.GetObject(AIndex: Integer): Pointer;
|
||||
var
|
||||
Ptr: ^Pointer;
|
||||
begin
|
||||
Ptr := Self.FObjects + AIndex * SizeOf(Pointer);
|
||||
Result := Ptr^
|
||||
end;
|
||||
|
||||
procedure TStringList.SetObject(AIndex: Integer; AObject: Pointer);
|
||||
var
|
||||
Ptr: ^Pointer;
|
||||
begin
|
||||
Ptr := Self.FObjects + AIndex * SizeOf(Pointer);
|
||||
Ptr^ := AObject
|
||||
end;
|
||||
|
||||
procedure TStringList.Delete(AIndex: Integer);
|
||||
var
|
||||
I: Integer;
|
||||
SDst: ^string;
|
||||
SSrc: ^string;
|
||||
ODst: ^Pointer;
|
||||
OSrc: ^Pointer;
|
||||
begin
|
||||
I := AIndex;
|
||||
while I < Self.FCount - 1 do
|
||||
begin
|
||||
SDst := Self.FStrings + I * SizeOf(string);
|
||||
SSrc := Self.FStrings + (I + 1) * SizeOf(string);
|
||||
ODst := Self.FObjects + I * SizeOf(Pointer);
|
||||
OSrc := Self.FObjects + (I + 1) * SizeOf(Pointer);
|
||||
SDst^ := SSrc^;
|
||||
ODst^ := OSrc^;
|
||||
I := I + 1
|
||||
end;
|
||||
{ Release the last (duplicate) string slot and clear the object slot }
|
||||
SDst := Self.FStrings + (Self.FCount - 1) * SizeOf(string);
|
||||
SDst^ := nil;
|
||||
ODst := Self.FObjects + (Self.FCount - 1) * SizeOf(Pointer);
|
||||
ODst^ := nil;
|
||||
Self.FCount := Self.FCount - 1
|
||||
end;
|
||||
|
||||
procedure TStringList.Clear;
|
||||
var
|
||||
I: Integer;
|
||||
Ptr: ^string;
|
||||
begin
|
||||
I := 0;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Ptr := Self.FStrings + I * SizeOf(string);
|
||||
Ptr^ := nil;
|
||||
I := I + 1
|
||||
end;
|
||||
Self.FCount := 0
|
||||
end;
|
||||
|
||||
procedure TStringList.Insert(AIndex: Integer; S: string);
|
||||
var
|
||||
I: Integer;
|
||||
SDst: ^string;
|
||||
SSrc: ^string;
|
||||
ODst: ^Pointer;
|
||||
OSrc: ^Pointer;
|
||||
Ptr: ^string;
|
||||
OPtr: ^Pointer;
|
||||
begin
|
||||
if Self.FCount = Self.FCapacity then
|
||||
Self.Grow;
|
||||
{ Shift elements right from FCount-1 down to AIndex }
|
||||
I := Self.FCount;
|
||||
while I > AIndex do
|
||||
begin
|
||||
SDst := Self.FStrings + I * SizeOf(string);
|
||||
SSrc := Self.FStrings + (I - 1) * SizeOf(string);
|
||||
ODst := Self.FObjects + I * SizeOf(Pointer);
|
||||
OSrc := Self.FObjects + (I - 1) * SizeOf(Pointer);
|
||||
SDst^ := SSrc^;
|
||||
ODst^ := OSrc^;
|
||||
I := I - 1
|
||||
end;
|
||||
{ Zero the source slot that was shifted (now duplicated at AIndex+1) }
|
||||
SSrc := Self.FStrings + AIndex * SizeOf(string);
|
||||
SSrc^ := nil; { release the "old" value ARC wrote there during shift }
|
||||
{ Write the new string at AIndex }
|
||||
Ptr := Self.FStrings + AIndex * SizeOf(string);
|
||||
OPtr := Self.FObjects + AIndex * SizeOf(Pointer);
|
||||
Ptr^ := S;
|
||||
OPtr^ := nil;
|
||||
Self.FCount := Self.FCount + 1
|
||||
end;
|
||||
|
||||
function TStringList.GetText: string;
|
||||
var
|
||||
I: Integer;
|
||||
Ptr: ^string;
|
||||
Sep: string;
|
||||
begin
|
||||
Result := '';
|
||||
Sep := '';
|
||||
I := 0;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Ptr := Self.FStrings + I * SizeOf(string);
|
||||
Result := Result + Sep + Ptr^;
|
||||
Sep := #13#10;
|
||||
I := I + 1
|
||||
end
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -56,12 +56,15 @@ implementation
|
|||
procedure TList<T>.Grow;
|
||||
var
|
||||
NewCap: Integer;
|
||||
OldCap: Integer;
|
||||
begin
|
||||
if Self.FCapacity = 0 then
|
||||
OldCap := Self.FCapacity;
|
||||
if OldCap = 0 then
|
||||
NewCap := 4
|
||||
else
|
||||
NewCap := Self.FCapacity * 2;
|
||||
NewCap := OldCap * 2;
|
||||
Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(T));
|
||||
ZeroMem(Self.FData + OldCap * SizeOf(T), (NewCap - OldCap) * SizeOf(T));
|
||||
Self.FCapacity := NewCap
|
||||
end;
|
||||
|
||||
|
|
@ -121,13 +124,17 @@ end;
|
|||
procedure TDictionary<K, V>.Grow;
|
||||
var
|
||||
NewCap: Integer;
|
||||
OldCap: Integer;
|
||||
begin
|
||||
if Self.FCapacity = 0 then
|
||||
OldCap := Self.FCapacity;
|
||||
if OldCap = 0 then
|
||||
NewCap := 8
|
||||
else
|
||||
NewCap := Self.FCapacity * 2;
|
||||
NewCap := OldCap * 2;
|
||||
Self.FKeys := ReallocMem(Self.FKeys, NewCap * SizeOf(K));
|
||||
ZeroMem(Self.FKeys + OldCap * SizeOf(K), (NewCap - OldCap) * SizeOf(K));
|
||||
Self.FValues := ReallocMem(Self.FValues, NewCap * SizeOf(V));
|
||||
ZeroMem(Self.FValues + OldCap * SizeOf(V), (NewCap - OldCap) * SizeOf(V));
|
||||
Self.FCapacity := NewCap
|
||||
end;
|
||||
|
||||
|
|
|
|||
|
|
@ -97,12 +97,17 @@ end;
|
|||
procedure TStrIntDict.Grow;
|
||||
var
|
||||
NewCap: Integer;
|
||||
OldCap: Integer;
|
||||
begin
|
||||
if Self.FCapacity = 0 then
|
||||
OldCap := Self.FCapacity;
|
||||
if OldCap = 0 then
|
||||
NewCap := 8
|
||||
else
|
||||
NewCap := Self.FCapacity * 2;
|
||||
NewCap := OldCap * 2;
|
||||
Self.FKeys := ReallocMem(Self.FKeys, NewCap * SizeOf(string));
|
||||
{ Zero-init new string slots so ARC Release of "old" value is safe }
|
||||
ZeroMem(Self.FKeys + OldCap * SizeOf(string),
|
||||
(NewCap - OldCap) * SizeOf(string));
|
||||
Self.FValues := ReallocMem(Self.FValues, NewCap * SizeOf(Integer));
|
||||
Self.FCapacity := NewCap
|
||||
end;
|
||||
|
|
@ -194,12 +199,26 @@ begin
|
|||
VDst^ := VSrc^;
|
||||
I := I + 1
|
||||
end;
|
||||
{ Release the duplicate last string slot left behind by the shift }
|
||||
KDst := Self.FKeys + (Self.FCount - 1) * SizeOf(string);
|
||||
KDst^ := nil;
|
||||
Self.FCount := Self.FCount - 1
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TStrIntDict.Destroy;
|
||||
var
|
||||
I: Integer;
|
||||
Ptr: ^string;
|
||||
begin
|
||||
{ Release all stored strings before freeing the backing store }
|
||||
I := 0;
|
||||
while I < Self.FCount do
|
||||
begin
|
||||
Ptr := Self.FKeys + I * SizeOf(string);
|
||||
Ptr^ := nil;
|
||||
I := I + 1
|
||||
end;
|
||||
FreeMem(Self.FKeys);
|
||||
FreeMem(Self.FValues);
|
||||
Self.FKeys := nil;
|
||||
|
|
|
|||
Loading…
Reference in a new issue