Add const blocks, fix ParseBlock ordering, and stub blaise-compiler.pas
const: TConstDecl AST node; ParseConstBlock (integer and string literal values); AnalyseConstDecls (registers each as skConstant in symbol table). Enables CHR_* character constants and dupAccept/dupIgnore/dupError in self-hosting source. ParseBlock: add tkConst to the multi-section loop. Blaise now supports: case, enum, const, multi-type/var blocks, all file I/O builtins — the complete language surface needed for the source migration. 834 tests pass.
This commit is contained in:
Graeme Geldenhuys
parent
fb89879f86
commit
926b594516
|
|
@ -445,16 +445,26 @@ type
|
||||||
destructor Destroy; override;
|
destructor Destroy; override;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{ Constant declaration: const Name = Value; — integer or string literal }
|
||||||
|
TConstDecl = class(TASTNode)
|
||||||
|
public
|
||||||
|
Name: string;
|
||||||
|
IntVal: Int64; { used when IsString = False }
|
||||||
|
StrVal: string; { used when IsString = True }
|
||||||
|
IsString: Boolean;
|
||||||
|
end;
|
||||||
|
|
||||||
{ ------------------------------------------------------------------ }
|
{ ------------------------------------------------------------------ }
|
||||||
{ Block and Program }
|
{ Block and Program }
|
||||||
{ ------------------------------------------------------------------ }
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
TBlock = class(TASTNode)
|
TBlock = class(TASTNode)
|
||||||
public
|
public
|
||||||
TypeDecls: TObjectList; { owned TTypeDecl }
|
TypeDecls: TObjectList; { owned TTypeDecl }
|
||||||
Decls: TObjectList; { owned TVarDecl }
|
ConstDecls: TObjectList; { owned TConstDecl }
|
||||||
ProcDecls: TObjectList; { owned TMethodDecl — standalone procs/funcs }
|
Decls: TObjectList; { owned TVarDecl }
|
||||||
Stmts: TObjectList; { owned TASTStmt }
|
ProcDecls: TObjectList; { owned TMethodDecl — standalone procs/funcs }
|
||||||
|
Stmts: TObjectList; { owned TASTStmt }
|
||||||
constructor Create;
|
constructor Create;
|
||||||
destructor Destroy; override;
|
destructor Destroy; override;
|
||||||
end;
|
end;
|
||||||
|
|
@ -918,15 +928,17 @@ end;
|
||||||
constructor TBlock.Create;
|
constructor TBlock.Create;
|
||||||
begin
|
begin
|
||||||
inherited Create;
|
inherited Create;
|
||||||
TypeDecls := TObjectList.Create(True);
|
TypeDecls := TObjectList.Create(True);
|
||||||
Decls := TObjectList.Create(True);
|
ConstDecls := TObjectList.Create(True);
|
||||||
ProcDecls := TObjectList.Create(True);
|
Decls := TObjectList.Create(True);
|
||||||
Stmts := TObjectList.Create(True);
|
ProcDecls := TObjectList.Create(True);
|
||||||
|
Stmts := TObjectList.Create(True);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
destructor TBlock.Destroy;
|
destructor TBlock.Destroy;
|
||||||
begin
|
begin
|
||||||
TypeDecls.Free;
|
TypeDecls.Free;
|
||||||
|
ConstDecls.Free;
|
||||||
Decls.Free;
|
Decls.Free;
|
||||||
ProcDecls.Free;
|
ProcDecls.Free;
|
||||||
Stmts.Free;
|
Stmts.Free;
|
||||||
|
|
|
||||||
|
|
@ -63,6 +63,7 @@ type
|
||||||
tkInherited,
|
tkInherited,
|
||||||
tkCase,
|
tkCase,
|
||||||
tkOf,
|
tkOf,
|
||||||
|
tkConst,
|
||||||
{ Identifier }
|
{ Identifier }
|
||||||
tkIdent,
|
tkIdent,
|
||||||
{ Arithmetic operators }
|
{ Arithmetic operators }
|
||||||
|
|
@ -164,6 +165,7 @@ begin
|
||||||
else if AUpper = 'BREAK' then Result := tkBreak
|
else if AUpper = 'BREAK' then Result := tkBreak
|
||||||
else if AUpper = 'CASE' then Result := tkCase
|
else if AUpper = 'CASE' then Result := tkCase
|
||||||
else if AUpper = 'OF' then Result := tkOf
|
else if AUpper = 'OF' then Result := tkOf
|
||||||
|
else if AUpper = 'CONST' then Result := tkConst
|
||||||
else if AUpper = 'INHERITED' then Result := tkInherited
|
else if AUpper = 'INHERITED' then Result := tkInherited
|
||||||
else
|
else
|
||||||
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
|
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
|
||||||
|
|
@ -239,6 +241,7 @@ begin
|
||||||
else if text = 'BREAK' then Result.Kind := tkBreak
|
else if text = 'BREAK' then Result.Kind := tkBreak
|
||||||
else if text = 'CASE' then Result.Kind := tkCase
|
else if text = 'CASE' then Result.Kind := tkCase
|
||||||
else if text = 'OF' then Result.Kind := tkOf
|
else if text = 'OF' then Result.Kind := tkOf
|
||||||
|
else if text = 'CONST' then Result.Kind := tkConst
|
||||||
else Result.Kind := tkIdent;
|
else Result.Kind := tkIdent;
|
||||||
Result.Value := FTok.TokenText;
|
Result.Value := FTok.TokenText;
|
||||||
end;
|
end;
|
||||||
|
|
|
||||||
|
|
@ -64,6 +64,7 @@ type
|
||||||
function ParseBlock: TBlock;
|
function ParseBlock: TBlock;
|
||||||
procedure ParseTypeSection(ABlock: TBlock);
|
procedure ParseTypeSection(ABlock: TBlock);
|
||||||
procedure ParseTypeDecl(ABlock: TBlock);
|
procedure ParseTypeDecl(ABlock: TBlock);
|
||||||
|
procedure ParseConstBlock(ABlock: TBlock);
|
||||||
function ParseEnumDef: TEnumTypeDef;
|
function ParseEnumDef: TEnumTypeDef;
|
||||||
function ParseRecordDef: TRecordTypeDef;
|
function ParseRecordDef: TRecordTypeDef;
|
||||||
function ParseGenericName: string; { reads IDENT optionally followed by '<' TypeArgs '>' }
|
function ParseGenericName: string; { reads IDENT optionally followed by '<' TypeArgs '>' }
|
||||||
|
|
@ -277,12 +278,15 @@ begin
|
||||||
|
|
||||||
{ Accept any number of type/var/procedure/function sections in any order,
|
{ Accept any number of type/var/procedure/function sections in any order,
|
||||||
as required when concatenating multiple Pascal units into one file. }
|
as required when concatenating multiple Pascal units into one file. }
|
||||||
while Check(tkType) or Check(tkVar) or Check(tkProcedure) or Check(tkFunction) do
|
while Check(tkType) or Check(tkVar) or Check(tkProcedure) or
|
||||||
|
Check(tkFunction) or Check(tkConst) do
|
||||||
begin
|
begin
|
||||||
if Check(tkType) then
|
if Check(tkType) then
|
||||||
ParseTypeSection(Result)
|
ParseTypeSection(Result)
|
||||||
else if Check(tkVar) then
|
else if Check(tkVar) then
|
||||||
ParseVarBlock(Result)
|
ParseVarBlock(Result)
|
||||||
|
else if Check(tkConst) then
|
||||||
|
ParseConstBlock(Result)
|
||||||
else
|
else
|
||||||
ParseStandaloneDecl(Result);
|
ParseStandaloneDecl(Result);
|
||||||
end;
|
end;
|
||||||
|
|
@ -435,6 +439,50 @@ begin
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TParser.ParseConstBlock(ABlock: TBlock);
|
||||||
|
var
|
||||||
|
CD: TConstDecl;
|
||||||
|
begin
|
||||||
|
Expect(tkConst);
|
||||||
|
while Check(tkIdent) do
|
||||||
|
begin
|
||||||
|
CD := TConstDecl.Create;
|
||||||
|
CD.Line := FCurrent.Line;
|
||||||
|
CD.Col := FCurrent.Col;
|
||||||
|
CD.Name := FCurrent.Value;
|
||||||
|
Advance;
|
||||||
|
Expect(tkEquals);
|
||||||
|
if Check(tkMinus) then
|
||||||
|
begin
|
||||||
|
Advance;
|
||||||
|
if not Check(tkIntLit) then
|
||||||
|
raise EParseError.CreateFmt('Expected integer after minus in const at line %d col %d',
|
||||||
|
[FCurrent.Line, FCurrent.Col]);
|
||||||
|
CD.IntVal := -StrToInt(FCurrent.Value);
|
||||||
|
CD.IsString := False;
|
||||||
|
Advance;
|
||||||
|
end
|
||||||
|
else if Check(tkIntLit) then
|
||||||
|
begin
|
||||||
|
CD.IntVal := StrToInt(FCurrent.Value);
|
||||||
|
CD.IsString := False;
|
||||||
|
Advance;
|
||||||
|
end
|
||||||
|
else if Check(tkStringLit) then
|
||||||
|
begin
|
||||||
|
CD.StrVal := FCurrent.Value;
|
||||||
|
CD.IsString := True;
|
||||||
|
Advance;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
raise EParseError.CreateFmt(
|
||||||
|
'Expected integer or string constant at line %d col %d',
|
||||||
|
[FCurrent.Line, FCurrent.Col]);
|
||||||
|
Expect(tkSemicolon);
|
||||||
|
ABlock.ConstDecls.Add(CD);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
function TParser.ParseEnumDef: TEnumTypeDef;
|
function TParser.ParseEnumDef: TEnumTypeDef;
|
||||||
begin
|
begin
|
||||||
Result := TEnumTypeDef.Create;
|
Result := TEnumTypeDef.Create;
|
||||||
|
|
|
||||||
|
|
@ -48,6 +48,7 @@ type
|
||||||
function InstantiateGenericFunc(const AInstName: string): TMethodDecl;
|
function InstantiateGenericFunc(const AInstName: string): TMethodDecl;
|
||||||
|
|
||||||
procedure AnalyseBlock(ABlock: TBlock);
|
procedure AnalyseBlock(ABlock: TBlock);
|
||||||
|
procedure AnalyseConstDecls(ABlock: TBlock);
|
||||||
procedure AnalyseTypeDecls(ABlock: TBlock);
|
procedure AnalyseTypeDecls(ABlock: TBlock);
|
||||||
procedure LinkClassMethodImpls(ABlock: TBlock);
|
procedure LinkClassMethodImpls(ABlock: TBlock);
|
||||||
procedure LinkGenericClassMethodImpls(ABlock: TBlock);
|
procedure LinkGenericClassMethodImpls(ABlock: TBlock);
|
||||||
|
|
@ -998,6 +999,7 @@ begin
|
||||||
{ Type declarations are registered in the outer scope so they remain visible
|
{ Type declarations are registered in the outer scope so they remain visible
|
||||||
after the block scope is popped — needed for var declarations and the
|
after the block scope is popped — needed for var declarations and the
|
||||||
transferred symbol table used by codegen. }
|
transferred symbol table used by codegen. }
|
||||||
|
AnalyseConstDecls(ABlock);
|
||||||
AnalyseTypeDecls(ABlock);
|
AnalyseTypeDecls(ABlock);
|
||||||
{ Link standalone TTypeName.MethodName implementations to their class method
|
{ Link standalone TTypeName.MethodName implementations to their class method
|
||||||
declarations, transferring the body so AnalyseMethodBodies can process it. }
|
declarations, transferring the body so AnalyseMethodBodies can process it. }
|
||||||
|
|
@ -1017,6 +1019,27 @@ begin
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TSemanticAnalyser.AnalyseConstDecls(ABlock: TBlock);
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
CD: TConstDecl;
|
||||||
|
Sym: TSymbol;
|
||||||
|
TD: TTypeDesc;
|
||||||
|
begin
|
||||||
|
for I := 0 to ABlock.ConstDecls.Count - 1 do
|
||||||
|
begin
|
||||||
|
CD := TConstDecl(ABlock.ConstDecls[I]);
|
||||||
|
if CD.IsString then
|
||||||
|
TD := FTable.TypeString
|
||||||
|
else
|
||||||
|
TD := FTable.TypeInteger;
|
||||||
|
Sym := TSymbol.Create(CD.Name, skConstant, TD);
|
||||||
|
Sym.ConstValue := CD.IntVal;
|
||||||
|
if not FTable.Define(Sym) then
|
||||||
|
Sym.Free; { duplicate const — silently ignore }
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock);
|
procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock);
|
||||||
var
|
var
|
||||||
I, J, K: Integer;
|
I, J, K: Integer;
|
||||||
|
|
|
||||||
582
tests/blaise-compiler.pas
Normal file
582
tests/blaise-compiler.pas
Normal file
|
|
@ -0,0 +1,582 @@
|
||||||
|
{
|
||||||
|
Blaise - An Object Pascal Compiler
|
||||||
|
Copyright (c) 2026 Graeme Geldenhuys
|
||||||
|
SPDX-License-Identifier: BSD-3-Clause
|
||||||
|
|
||||||
|
blaise-compiler.pas — Self-hosting compiler source.
|
||||||
|
Generated by concatenating the compiler units in dependency order:
|
||||||
|
uPasTokeniser → uLexer → uSymbolTable → uAST → uParser →
|
||||||
|
uSemantic → uCodeGenQBE → main
|
||||||
|
}
|
||||||
|
|
||||||
|
program BlaiseCompiler;
|
||||||
|
|
||||||
|
{ ================================================================== }
|
||||||
|
{ Character code constants (replaces FPC char literals in tokeniser) }
|
||||||
|
{ ================================================================== }
|
||||||
|
|
||||||
|
const
|
||||||
|
CHR_QUOTE = 39; { ' single-quote }
|
||||||
|
CHR_HASH = 35; { # }
|
||||||
|
CHR_DOLLAR = 36; { $ }
|
||||||
|
CHR_LF = 10; { line feed }
|
||||||
|
CHR_CR = 13; { carriage return }
|
||||||
|
CHR_TAB = 9; { tab }
|
||||||
|
CHR_SPACE = 32; { space }
|
||||||
|
CHR_0 = 48; { digit 0 }
|
||||||
|
CHR_9 = 57; { digit 9 }
|
||||||
|
CHR_A_UP = 65; { uppercase A }
|
||||||
|
CHR_F_UP = 70; { uppercase F }
|
||||||
|
CHR_Z_UP = 90; { uppercase Z }
|
||||||
|
CHR_a_LO = 97; { lowercase a }
|
||||||
|
CHR_f_LO = 102; { lowercase f }
|
||||||
|
CHR_z_LO = 122; { lowercase z }
|
||||||
|
CHR_UNDER = 95; { _ underscore }
|
||||||
|
CHR_CARET = 94; { ^ caret }
|
||||||
|
CHR_DOT = 46; { . dot }
|
||||||
|
CHR_AT = 64; { @ at }
|
||||||
|
CHR_LT = 60; { < less-than }
|
||||||
|
CHR_GT = 62; { > greater-than }
|
||||||
|
CHR_EQ = 61; { = equals }
|
||||||
|
CHR_PLUS = 43; { + }
|
||||||
|
CHR_MINUS = 45; { - }
|
||||||
|
CHR_STAR = 42; { * }
|
||||||
|
CHR_SLASH = 47; { / }
|
||||||
|
CHR_LPAREN = 40; { ( }
|
||||||
|
CHR_RPAREN = 41; { ) }
|
||||||
|
CHR_LBRACE = 123; { { }
|
||||||
|
CHR_RBRACE = 125; { } }
|
||||||
|
CHR_SEMI = 59; { ; }
|
||||||
|
CHR_COLON = 58; { : }
|
||||||
|
CHR_LBRACKET = 91; { [ }
|
||||||
|
CHR_RBRACKET = 93; { ] }
|
||||||
|
CHR_e_LO = 101; { e }
|
||||||
|
CHR_E_UP = 69; { E }
|
||||||
|
CHR_DQUOTE = 34; { " double-quote }
|
||||||
|
|
||||||
|
{ ================================================================== }
|
||||||
|
{ Exception hierarchy }
|
||||||
|
{ ================================================================== }
|
||||||
|
|
||||||
|
type
|
||||||
|
Exception = class
|
||||||
|
FMessage: string;
|
||||||
|
constructor Create(AMessage: string);
|
||||||
|
constructor CreateFmt(const AFmt: string; AArg1: Integer);
|
||||||
|
constructor CreateFmt(const AFmt: string; AArg2: string);
|
||||||
|
property Message: string read FMessage;
|
||||||
|
end;
|
||||||
|
|
||||||
|
EParseError = class(Exception);
|
||||||
|
ESemanticError = class(Exception);
|
||||||
|
ECodeGenError = class(Exception);
|
||||||
|
EExcFrame = class(Exception);
|
||||||
|
|
||||||
|
constructor Exception.Create(AMessage: string);
|
||||||
|
begin
|
||||||
|
Self.FMessage := AMessage
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor Exception.CreateFmt(const AFmt: string; AArg1: Integer);
|
||||||
|
begin
|
||||||
|
Self.FMessage := Format(AFmt, AArg1)
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor Exception.CreateFmt(const AFmt: string; AArg2: string);
|
||||||
|
begin
|
||||||
|
Self.FMessage := Format(AFmt, AArg2)
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ================================================================== }
|
||||||
|
{ RTL: TObjectList and TStringList }
|
||||||
|
{ ================================================================== }
|
||||||
|
|
||||||
|
{
|
||||||
|
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.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
// 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.
|
||||||
|
|
||||||
|
|
||||||
|
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;
|
||||||
|
|
||||||
|
|
||||||
|
{ ================================================================== }
|
||||||
|
{ 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;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in a new issue