From 6688f329264fc2c8e3c09e09dbfde988d83a6b90 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 23 Apr 2026 12:32:59 +0100 Subject: [PATCH] Add TObjectList and TStringList to RTL; fix string ARC via typed pointers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- compiler/src/main/pascal/uCodeGenQBE.pas | 52 ++ compiler/src/main/pascal/uSemantic.pas | 15 +- compiler/src/main/pascal/uSymbolTable.pas | 8 + compiler/src/test/pascal/TestRunner.pas | 1 + .../src/test/pascal/cp.test.collections.pas | 444 ++++++++++++++++ compiler/src/test/pascal/cp.test.e2e.pas | 357 +++++++++++++ rtl/src/main/c/blaise_str.c | 28 + rtl/src/main/pascal/Classes.pas | 491 ++++++++++++++++++ rtl/src/main/pascal/Generics.Collections.pas | 15 +- tests/phase3_milestone.pas | 23 +- 10 files changed, 1426 insertions(+), 8 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.collections.pas create mode 100644 rtl/src/main/pascal/Classes.pas diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 8e6e7bc..784f427 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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 diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index daf0a44..60786e0 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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( diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index b5bbe5f..1aa1d5a 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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; diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 55b104e..6c918e8 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -53,6 +53,7 @@ uses cp.test.genericconstraints, cp.test.weakref, cp.test.stringops, + cp.test.collections, cp.test.e2e; var diff --git a/compiler/src/test/pascal/cp.test.collections.pas b/compiler/src/test/pascal/cp.test.collections.pas new file mode 100644 index 0000000..3535415 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.collections.pas @@ -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. diff --git a/compiler/src/test/pascal/cp.test.e2e.pas b/compiler/src/test/pascal/cp.test.e2e.pas index b4363e1..3e2c9f9 100644 --- a/compiler/src/test/pascal/cp.test.e2e.pas +++ b/compiler/src/test/pascal/cp.test.e2e.pas @@ -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); diff --git a/rtl/src/main/c/blaise_str.c b/rtl/src/main/c/blaise_str.c index 07b221b..c739e78 100644 --- a/rtl/src/main/c/blaise_str.c +++ b/rtl/src/main/c/blaise_str.c @@ -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 */ /* */ diff --git a/rtl/src/main/pascal/Classes.pas b/rtl/src/main/pascal/Classes.pas new file mode 100644 index 0000000..155b131 --- /dev/null +++ b/rtl/src/main/pascal/Classes.pas @@ -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. diff --git a/rtl/src/main/pascal/Generics.Collections.pas b/rtl/src/main/pascal/Generics.Collections.pas index 283ed67..d461ea2 100644 --- a/rtl/src/main/pascal/Generics.Collections.pas +++ b/rtl/src/main/pascal/Generics.Collections.pas @@ -56,12 +56,15 @@ implementation procedure TList.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.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; diff --git a/tests/phase3_milestone.pas b/tests/phase3_milestone.pas index 31bed02..dad8bd0 100644 --- a/tests/phase3_milestone.pas +++ b/tests/phase3_milestone.pas @@ -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;