mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 13:20:19 +01:00
2588 lines
65 KiB
ObjectPascal
2588 lines
65 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
|
|
|
|
This module provides some basic classes
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit cclasses;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
{$ifndef VER2_0}
|
|
{ Disabled for now, gives an IE 200311075 when compiling the IDE }
|
|
{ $define CCLASSESINLINE}
|
|
{$endif}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF USE_FAKE_SYSUTILS}
|
|
SysUtils,
|
|
{$ELSE}
|
|
fksysutl,
|
|
{$ENDIF}
|
|
CUtils,CStreams;
|
|
|
|
{********************************************
|
|
TMemDebug
|
|
********************************************}
|
|
|
|
type
|
|
tmemdebug = class
|
|
private
|
|
totalmem,
|
|
startmem : integer;
|
|
infostr : string[40];
|
|
public
|
|
constructor Create(const s:string);
|
|
destructor Destroy;override;
|
|
procedure show;
|
|
procedure start;
|
|
procedure stop;
|
|
end;
|
|
|
|
{*******************************************************
|
|
TFPList (From rtl/objpas/classes/classesh.inc)
|
|
********************************************************}
|
|
|
|
const
|
|
SListIndexError = 'List index exceeds bounds (%d)';
|
|
SListCapacityError = 'The maximum list capacity is reached (%d)';
|
|
SListCountError = 'List count too large (%d)';
|
|
type
|
|
EListError = class(Exception);
|
|
|
|
const
|
|
MaxListSize = Maxint div 16;
|
|
type
|
|
PPointerList = ^TPointerList;
|
|
TPointerList = array[0..MaxListSize - 1] of Pointer;
|
|
TListSortCompare = function (Item1, Item2: Pointer): Integer;
|
|
TListCallback = procedure(data,arg:pointer) of object;
|
|
TListStaticCallback = procedure(data,arg:pointer);
|
|
|
|
TFPList = class(TObject)
|
|
private
|
|
FList: PPointerList;
|
|
FCount: Integer;
|
|
FCapacity: Integer;
|
|
protected
|
|
function Get(Index: Integer): Pointer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Put(Index: Integer; Item: Pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCapacity(NewCapacity: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCount(NewCount: Integer);
|
|
Procedure RaiseIndexError(Index : Integer);
|
|
public
|
|
destructor Destroy; override;
|
|
function Add(Item: Pointer): Integer;
|
|
procedure Clear;
|
|
procedure Delete(Index: Integer);
|
|
class procedure Error(const Msg: string; Data: PtrInt);
|
|
procedure Exchange(Index1, Index2: Integer);
|
|
function Expand: TFPList;
|
|
function Extract(item: Pointer): Pointer;
|
|
function First: Pointer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function IndexOf(Item: Pointer): Integer;
|
|
procedure Insert(Index: Integer; Item: Pointer);
|
|
function Last: Pointer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Move(CurIndex, NewIndex: Integer);
|
|
procedure Assign(Obj:TFPList);
|
|
function Remove(Item: Pointer): Integer;
|
|
procedure Pack;
|
|
procedure Sort(Compare: TListSortCompare);
|
|
procedure ForEachCall(proc2call:TListCallback;arg:pointer);
|
|
procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
|
property Capacity: Integer read FCapacity write SetCapacity;
|
|
property Count: Integer read FCount write SetCount;
|
|
property Items[Index: Integer]: Pointer read Get write Put; default;
|
|
property List: PPointerList read FList;
|
|
end;
|
|
|
|
|
|
{*******************************************************
|
|
TFPObjectList (From fcl/inc/contnrs.pp)
|
|
********************************************************}
|
|
|
|
TObjectListCallback = procedure(data:TObject;arg:pointer) of object;
|
|
TObjectListStaticCallback = procedure(data:TObject;arg:pointer);
|
|
|
|
TFPObjectList = class(TObject)
|
|
private
|
|
FFreeObjects : Boolean;
|
|
FList: TFPList;
|
|
function GetCount: integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCount(const AValue: integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
protected
|
|
function GetItem(Index: Integer): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetItem(Index: Integer; AObject: TObject); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCapacity(NewCapacity: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function GetCapacity: integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
public
|
|
constructor Create;
|
|
constructor Create(FreeObjects : Boolean);
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
function Add(AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Delete(Index: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Exchange(Index1, Index2: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Expand: TFPObjectList;{$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Extract(Item: TObject): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Remove(AObject: TObject): Integer;
|
|
function IndexOf(AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
|
|
procedure Insert(Index: Integer; AObject: TObject); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function First: TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Last: TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Move(CurIndex, NewIndex: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Assign(Obj:TFPObjectList); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Pack; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Sort(Compare: TListSortCompare); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
property Capacity: Integer read GetCapacity write SetCapacity;
|
|
property Count: Integer read GetCount write SetCount;
|
|
property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
|
|
property Items[Index: Integer]: TObject read GetItem write SetItem; default;
|
|
property List: TFPList read FList;
|
|
end;
|
|
|
|
type
|
|
THashItem=record
|
|
HashValue : LongWord;
|
|
StrIndex : Integer;
|
|
NextIndex : Integer;
|
|
Data : Pointer;
|
|
end;
|
|
PHashItem=^THashItem;
|
|
|
|
const
|
|
MaxHashListSize = Maxint div 16;
|
|
MaxHashStrSize = Maxint;
|
|
MaxHashTableSize = Maxint div 4;
|
|
MaxItemsPerHash = 3;
|
|
|
|
type
|
|
PHashItemList = ^THashItemList;
|
|
THashItemList = array[0..MaxHashListSize - 1] of THashItem;
|
|
PHashTable = ^THashTable;
|
|
THashTable = array[0..MaxHashTableSize - 1] of Integer;
|
|
|
|
TFPHashList = class(TObject)
|
|
private
|
|
{ ItemList }
|
|
FHashList : PHashItemList;
|
|
FCount,
|
|
FCapacity : Integer;
|
|
{ Hash }
|
|
FHashTable : PHashTable;
|
|
FHashCapacity : Integer;
|
|
{ Strings }
|
|
FStrs : PChar;
|
|
FStrCount,
|
|
FStrCapacity : Integer;
|
|
function InternalFind(AHash:LongWord;const AName:string;out PrevIndex:Integer):Integer;
|
|
protected
|
|
function Get(Index: Integer): Pointer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
procedure SetCount(NewCount: Integer);
|
|
Procedure RaiseIndexError(Index : Integer);
|
|
function AddStr(const s:string): Integer;
|
|
procedure AddToHashTable(Index: Integer);
|
|
procedure StrExpand(MinIncSize:Integer);
|
|
procedure SetStrCapacity(NewCapacity: Integer);
|
|
procedure SetHashCapacity(NewCapacity: Integer);
|
|
procedure ReHash;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add(const AName:string;Item: Pointer): Integer;
|
|
procedure Clear;
|
|
function NameOfIndex(Index: Integer): String; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Delete(Index: Integer);
|
|
class procedure Error(const Msg: string; Data: PtrInt);
|
|
function Expand: TFPHashList;
|
|
function Extract(item: Pointer): Pointer;
|
|
function IndexOf(Item: Pointer): Integer;
|
|
function Find(const AName:string): Pointer;
|
|
function FindWithHash(const AName:string;AHash:LongWord): Pointer;
|
|
function Rename(const AOldName,ANewName:string): Integer;
|
|
function Remove(Item: Pointer): Integer;
|
|
procedure Pack;
|
|
procedure ShowStatistics;
|
|
procedure ForEachCall(proc2call:TListCallback;arg:pointer);
|
|
procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
|
property Capacity: Integer read FCapacity write SetCapacity;
|
|
property Count: Integer read FCount write SetCount;
|
|
property Items[Index: Integer]: Pointer read Get; default;
|
|
property List: PHashItemList read FHashList;
|
|
property Strs: PChar read FStrs;
|
|
end;
|
|
|
|
|
|
{*******************************************************
|
|
TFPHashObjectList (From fcl/inc/contnrs.pp)
|
|
********************************************************}
|
|
|
|
TFPHashObjectList = class;
|
|
|
|
{ TFPHashObject }
|
|
|
|
TFPHashObject = class
|
|
private
|
|
FOwner : TFPHashObjectList;
|
|
FCachedStr : pshortstring;
|
|
FStrIndex : Integer;
|
|
procedure InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:string);
|
|
protected
|
|
function GetName:string;virtual;
|
|
function GetHash:Longword;virtual;
|
|
public
|
|
constructor CreateNotOwned;
|
|
constructor Create(HashObjectList:TFPHashObjectList;const s:string);
|
|
procedure ChangeOwner(HashObjectList:TFPHashObjectList); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:string); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Rename(const ANewName:string);
|
|
property Name:string read GetName;
|
|
property Hash:Longword read GetHash;
|
|
end;
|
|
|
|
TFPHashObjectList = class(TObject)
|
|
private
|
|
FFreeObjects : Boolean;
|
|
FHashList: TFPHashList;
|
|
function GetCount: integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCount(const AValue: integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
protected
|
|
function GetItem(Index: Integer): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure SetCapacity(NewCapacity: Integer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function GetCapacity: integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
public
|
|
constructor Create(FreeObjects : boolean = True);
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
function Add(const AName:string;AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function NameOfIndex(Index: Integer): String; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure Delete(Index: Integer);
|
|
function Expand: TFPHashObjectList; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Extract(Item: TObject): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Remove(AObject: TObject): Integer;
|
|
function IndexOf(AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function Find(const s:string): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function FindWithHash(const AName:string;AHash:LongWord): Pointer;
|
|
function Rename(const AOldName,ANewName:string): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
|
|
procedure Pack; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ShowStatistics; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
property Capacity: Integer read GetCapacity write SetCapacity;
|
|
property Count: Integer read GetCount write SetCount;
|
|
property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
|
|
property Items[Index: Integer]: TObject read GetItem; default;
|
|
property List: TFPHashList read FHashList;
|
|
end;
|
|
|
|
|
|
{********************************************
|
|
TLinkedList
|
|
********************************************}
|
|
|
|
type
|
|
TLinkedListItem = class
|
|
public
|
|
Previous,
|
|
Next : TLinkedListItem;
|
|
Constructor Create;
|
|
Destructor Destroy;override;
|
|
Function GetCopy:TLinkedListItem;virtual;
|
|
end;
|
|
|
|
TLinkedListItemClass = class of TLinkedListItem;
|
|
|
|
TLinkedList = class
|
|
private
|
|
FCount : integer;
|
|
FFirst,
|
|
FLast : TLinkedListItem;
|
|
FNoClear : boolean;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy;override;
|
|
{ true when the List is empty }
|
|
function Empty:boolean; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
{ deletes all Items }
|
|
procedure Clear;
|
|
{ inserts an Item }
|
|
procedure Insert(Item:TLinkedListItem);
|
|
{ inserts an Item before Loc }
|
|
procedure InsertBefore(Item,Loc : TLinkedListItem);
|
|
{ inserts an Item after Loc }
|
|
procedure InsertAfter(Item,Loc : TLinkedListItem);virtual;
|
|
{ concats an Item }
|
|
procedure Concat(Item:TLinkedListItem);
|
|
{ deletes an Item }
|
|
procedure Remove(Item:TLinkedListItem);
|
|
{ Gets First Item }
|
|
function GetFirst:TLinkedListItem;
|
|
{ Gets last Item }
|
|
function GetLast:TLinkedListItem;
|
|
{ inserts another List at the begin and make this List empty }
|
|
procedure insertList(p : TLinkedList);
|
|
{ inserts another List before the provided item and make this List empty }
|
|
procedure insertListBefore(Item:TLinkedListItem;p : TLinkedList);
|
|
{ inserts another List after the provided item and make this List empty }
|
|
procedure insertListAfter(Item:TLinkedListItem;p : TLinkedList);
|
|
{ concats another List at the end and make this List empty }
|
|
procedure concatList(p : TLinkedList);
|
|
{ concats another List at the start and makes a copy
|
|
the list is ordered in reverse.
|
|
}
|
|
procedure insertListcopy(p : TLinkedList);
|
|
{ concats another List at the end and makes a copy }
|
|
procedure concatListcopy(p : TLinkedList);
|
|
property First:TLinkedListItem read FFirst;
|
|
property Last:TLinkedListItem read FLast;
|
|
property Count:Integer read FCount;
|
|
property NoClear:boolean write FNoClear;
|
|
end;
|
|
|
|
{********************************************
|
|
TStringList
|
|
********************************************}
|
|
|
|
{ string containerItem }
|
|
TStringListItem = class(TLinkedListItem)
|
|
FPStr : pshortstring;
|
|
public
|
|
constructor Create(const s:string);
|
|
destructor Destroy;override;
|
|
function GetCopy:TLinkedListItem;override;
|
|
function Str:string; {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
end;
|
|
|
|
{ string container }
|
|
TStringList = class(TLinkedList)
|
|
private
|
|
FDoubles : boolean; { if this is set to true, doubles are allowed }
|
|
public
|
|
constructor Create;
|
|
constructor Create_No_Double;
|
|
{ inserts an Item }
|
|
procedure Insert(const s:string);
|
|
{ concats an Item }
|
|
procedure Concat(const s:string);
|
|
{ deletes an Item }
|
|
procedure Remove(const s:string);
|
|
{ Gets First Item }
|
|
function GetFirst:string;
|
|
{ Gets last Item }
|
|
function GetLast:string;
|
|
{ true if string is in the container, compare case sensitive }
|
|
function FindCase(const s:string):TStringListItem;
|
|
{ true if string is in the container }
|
|
function Find(const s:string):TStringListItem;
|
|
{ inserts an item }
|
|
procedure InsertItem(item:TStringListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
{ concats an item }
|
|
procedure ConcatItem(item:TStringListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
property Doubles:boolean read FDoubles write FDoubles;
|
|
procedure readstream(f:TCStream);
|
|
procedure writestream(f:TCStream);
|
|
end;
|
|
|
|
|
|
{********************************************
|
|
DynamicArray
|
|
********************************************}
|
|
|
|
type
|
|
{ can't use sizeof(integer) because it crashes gdb }
|
|
tdynamicblockdata=array[0..1024*1024-1] of byte;
|
|
|
|
pdynamicblock = ^tdynamicblock;
|
|
tdynamicblock = record
|
|
pos,
|
|
size,
|
|
used : integer;
|
|
Next : pdynamicblock;
|
|
data : tdynamicblockdata;
|
|
end;
|
|
|
|
const
|
|
dynamicblockbasesize = sizeof(tdynamicblock)-sizeof(tdynamicblockdata);
|
|
|
|
type
|
|
tdynamicarray = class
|
|
private
|
|
FPosn : integer;
|
|
FPosnblock : pdynamicblock;
|
|
FCurrBlocksize,
|
|
FMaxBlocksize : integer;
|
|
FFirstblock,
|
|
FLastblock : pdynamicblock;
|
|
procedure grow;
|
|
public
|
|
constructor Create(Ablocksize:integer);
|
|
destructor Destroy;override;
|
|
procedure reset;
|
|
function size:integer;
|
|
procedure align(i:integer);
|
|
procedure seek(i:integer);
|
|
function read(var d;len:integer):integer;
|
|
procedure write(const d;len:integer);
|
|
procedure writestr(const s:string); {$ifdef CCLASSESINLINE}inline;{$endif}
|
|
procedure readstream(f:TCStream;maxlen:longint);
|
|
procedure writestream(f:TCStream);
|
|
property CurrBlockSize : integer read FCurrBlocksize;
|
|
property FirstBlock : PDynamicBlock read FFirstBlock;
|
|
property Pos : integer read FPosn;
|
|
end;
|
|
|
|
|
|
function FPHash(const s:string):LongWord;
|
|
|
|
|
|
implementation
|
|
|
|
{*****************************************************************************
|
|
Memory debug
|
|
*****************************************************************************}
|
|
|
|
constructor tmemdebug.create(const s:string);
|
|
begin
|
|
infostr:=s;
|
|
totalmem:=0;
|
|
Start;
|
|
end;
|
|
|
|
|
|
procedure tmemdebug.start;
|
|
|
|
var
|
|
status : TFPCHeapStatus;
|
|
|
|
begin
|
|
status:=GetFPCHeapStatus;
|
|
startmem:=status.CurrHeapUsed;
|
|
end;
|
|
|
|
|
|
procedure tmemdebug.stop;
|
|
var
|
|
status : TFPCHeapStatus;
|
|
begin
|
|
if startmem<>0 then
|
|
begin
|
|
status:=GetFPCHeapStatus;
|
|
inc(TotalMem,startmem-status.CurrHeapUsed);
|
|
startmem:=0;
|
|
end;
|
|
end;
|
|
|
|
|
|
destructor tmemdebug.destroy;
|
|
begin
|
|
Stop;
|
|
show;
|
|
end;
|
|
|
|
|
|
procedure tmemdebug.show;
|
|
begin
|
|
write('memory [',infostr,'] ');
|
|
if TotalMem>0 then
|
|
writeln(DStr(TotalMem shr 10),' Kb released')
|
|
else
|
|
writeln(DStr((-TotalMem) shr 10),' Kb allocated');
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
|
|
*****************************************************************************}
|
|
|
|
Const
|
|
// Ratio of Pointer and Word Size.
|
|
WordRatio = SizeOf(Pointer) Div SizeOf(Word);
|
|
|
|
procedure TFPList.RaiseIndexError(Index : Integer);
|
|
begin
|
|
Error(SListIndexError, Index);
|
|
end;
|
|
|
|
function TFPList.Get(Index: Integer): Pointer;
|
|
begin
|
|
If (Index < 0) or (Index >= FCount) then
|
|
RaiseIndexError(Index);
|
|
Result:=FList^[Index];
|
|
end;
|
|
|
|
procedure TFPList.Put(Index: Integer; Item: Pointer);
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then
|
|
RaiseIndexError(Index);
|
|
Flist^[Index] := Item;
|
|
end;
|
|
|
|
function TFPList.Extract(item: Pointer): Pointer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
result := nil;
|
|
i := IndexOf(item);
|
|
if i >= 0 then
|
|
begin
|
|
Result := item;
|
|
FList^[i] := nil;
|
|
Delete(i);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
|
|
Error (SListCapacityError, NewCapacity);
|
|
if NewCapacity = FCapacity then
|
|
exit;
|
|
ReallocMem(FList, SizeOf(Pointer)*NewCapacity);
|
|
FCapacity := NewCapacity;
|
|
end;
|
|
|
|
procedure TFPList.SetCount(NewCount: Integer);
|
|
begin
|
|
if (NewCount < 0) or (NewCount > MaxListSize)then
|
|
Error(SListCountError, NewCount);
|
|
If NewCount > FCount then
|
|
begin
|
|
If NewCount > FCapacity then
|
|
SetCapacity(NewCount);
|
|
If FCount < NewCount then
|
|
FillWord(Flist^[FCount], (NewCount-FCount) * WordRatio, 0);
|
|
end;
|
|
FCount := Newcount;
|
|
end;
|
|
|
|
destructor TFPList.Destroy;
|
|
begin
|
|
Self.Clear;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TFPList.Add(Item: Pointer): Integer;
|
|
begin
|
|
if FCount = FCapacity then
|
|
Self.Expand;
|
|
FList^[FCount] := Item;
|
|
Result := FCount;
|
|
FCount := FCount + 1;
|
|
end;
|
|
|
|
procedure TFPList.Clear;
|
|
begin
|
|
if Assigned(FList) then
|
|
begin
|
|
SetCount(0);
|
|
SetCapacity(0);
|
|
FList := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TFPList.Delete(Index: Integer);
|
|
begin
|
|
If (Index<0) or (Index>=FCount) then
|
|
Error (SListIndexError, Index);
|
|
FCount := FCount-1;
|
|
System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
|
|
// Shrink the list if appropriate
|
|
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
|
begin
|
|
FCapacity := FCapacity shr 1;
|
|
ReallocMem(FList, SizeOf(Pointer) * FCapacity);
|
|
end;
|
|
end;
|
|
|
|
class procedure TFPList.Error(const Msg: string; Data: PtrInt);
|
|
begin
|
|
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
|
end;
|
|
|
|
procedure TFPList.Exchange(Index1, Index2: Integer);
|
|
var
|
|
Temp : Pointer;
|
|
begin
|
|
If ((Index1 >= FCount) or (Index1 < 0)) then
|
|
Error(SListIndexError, Index1);
|
|
If ((Index2 >= FCount) or (Index2 < 0)) then
|
|
Error(SListIndexError, Index2);
|
|
Temp := FList^[Index1];
|
|
FList^[Index1] := FList^[Index2];
|
|
FList^[Index2] := Temp;
|
|
end;
|
|
|
|
function TFPList.Expand: TFPList;
|
|
var
|
|
IncSize : Longint;
|
|
begin
|
|
Result := Self;
|
|
if FCount < FCapacity then
|
|
exit;
|
|
IncSize := sizeof(ptrint)*2;
|
|
if FCapacity > 127 then
|
|
Inc(IncSize, FCapacity shr 2)
|
|
else if FCapacity > sizeof(ptrint)*4 then
|
|
Inc(IncSize, FCapacity shr 1)
|
|
else if FCapacity >= sizeof(ptrint) then
|
|
inc(IncSize,sizeof(ptrint));
|
|
SetCapacity(FCapacity + IncSize);
|
|
end;
|
|
|
|
function TFPList.First: Pointer;
|
|
begin
|
|
If FCount = 0 then
|
|
Result := Nil
|
|
else
|
|
Result := Items[0];
|
|
end;
|
|
|
|
function TFPList.IndexOf(Item: Pointer): Integer;
|
|
var
|
|
psrc : PPointer;
|
|
Index : Integer;
|
|
begin
|
|
Result:=-1;
|
|
psrc:=@FList^[0];
|
|
For Index:=0 To FCount-1 Do
|
|
begin
|
|
if psrc^=Item then
|
|
begin
|
|
Result:=Index;
|
|
exit;
|
|
end;
|
|
inc(psrc);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPList.Insert(Index: Integer; Item: Pointer);
|
|
begin
|
|
if (Index < 0) or (Index > FCount )then
|
|
Error(SlistIndexError, Index);
|
|
iF FCount = FCapacity then Self.Expand;
|
|
if Index<FCount then
|
|
System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer));
|
|
FList^[Index] := Item;
|
|
FCount := FCount + 1;
|
|
end;
|
|
|
|
function TFPList.Last: Pointer;
|
|
begin
|
|
{ Wouldn't it be better to return nil if the count is zero ?}
|
|
If FCount = 0 then
|
|
Result := nil
|
|
else
|
|
Result := Items[FCount - 1];
|
|
end;
|
|
|
|
procedure TFPList.Move(CurIndex, NewIndex: Integer);
|
|
var
|
|
Temp : Pointer;
|
|
begin
|
|
if ((CurIndex < 0) or (CurIndex > Count - 1)) then
|
|
Error(SListIndexError, CurIndex);
|
|
if (NewINdex < 0) then
|
|
Error(SlistIndexError, NewIndex);
|
|
Temp := FList^[CurIndex];
|
|
FList^[CurIndex] := nil;
|
|
Self.Delete(CurIndex);
|
|
Self.Insert(NewIndex, nil);
|
|
FList^[NewIndex] := Temp;
|
|
end;
|
|
|
|
function TFPList.Remove(Item: Pointer): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
If Result <> -1 then
|
|
Self.Delete(Result);
|
|
end;
|
|
|
|
procedure TFPList.Pack;
|
|
var
|
|
NewCount,
|
|
i : integer;
|
|
pdest,
|
|
psrc : PPointer;
|
|
begin
|
|
NewCount:=0;
|
|
psrc:=@FList^[0];
|
|
pdest:=psrc;
|
|
For I:=0 To FCount-1 Do
|
|
begin
|
|
if assigned(psrc^) then
|
|
begin
|
|
pdest^:=psrc^;
|
|
inc(pdest);
|
|
inc(NewCount);
|
|
end;
|
|
inc(psrc);
|
|
end;
|
|
FCount:=NewCount;
|
|
end;
|
|
|
|
// Needed by Sort method.
|
|
|
|
Procedure QuickSort(FList: PPointerList; L, R : Longint;
|
|
Compare: TListSortCompare);
|
|
var
|
|
I, J : Longint;
|
|
P, Q : Pointer;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
P := FList^[ (L + R) div 2 ];
|
|
repeat
|
|
while Compare(P, FList^[i]) > 0 do
|
|
I := I + 1;
|
|
while Compare(P, FList^[J]) < 0 do
|
|
J := J - 1;
|
|
If I <= J then
|
|
begin
|
|
Q := FList^[I];
|
|
Flist^[I] := FList^[J];
|
|
FList^[J] := Q;
|
|
I := I + 1;
|
|
J := J - 1;
|
|
end;
|
|
until I > J;
|
|
if L < J then
|
|
QuickSort(FList, L, J, Compare);
|
|
L := I;
|
|
until I >= R;
|
|
end;
|
|
|
|
procedure TFPList.Sort(Compare: TListSortCompare);
|
|
begin
|
|
if Not Assigned(FList) or (FCount < 2) then exit;
|
|
QuickSort(Flist, 0, FCount-1, Compare);
|
|
end;
|
|
|
|
procedure TFPList.Assign(Obj: TFPList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Clear;
|
|
for I := 0 to Obj.Count - 1 do
|
|
Add(Obj[i]);
|
|
end;
|
|
|
|
|
|
procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
|
|
var
|
|
i : integer;
|
|
p : pointer;
|
|
begin
|
|
For I:=0 To Count-1 Do
|
|
begin
|
|
p:=FList^[i];
|
|
if assigned(p) then
|
|
proc2call(p,arg);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFPList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
|
var
|
|
i : integer;
|
|
p : pointer;
|
|
begin
|
|
For I:=0 To Count-1 Do
|
|
begin
|
|
p:=FList^[i];
|
|
if assigned(p) then
|
|
proc2call(p,arg);
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
|
|
*****************************************************************************}
|
|
|
|
constructor TFPObjectList.Create(FreeObjects : boolean);
|
|
begin
|
|
Create;
|
|
FFreeObjects := Freeobjects;
|
|
end;
|
|
|
|
destructor TFPObjectList.Destroy;
|
|
begin
|
|
if (FList <> nil) then
|
|
begin
|
|
Clear;
|
|
FList.Destroy;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFPObjectList.Clear;
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FFreeObjects then
|
|
for i := 0 to FList.Count - 1 do
|
|
TObject(FList[i]).Free;
|
|
FList.Clear;
|
|
end;
|
|
|
|
constructor TFPObjectList.Create;
|
|
begin
|
|
inherited Create;
|
|
FList := TFPList.Create;
|
|
FFreeObjects := True;
|
|
end;
|
|
|
|
function TFPObjectList.GetCount: integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
procedure TFPObjectList.SetCount(const AValue: integer);
|
|
begin
|
|
if FList.Count <> AValue then
|
|
FList.Count := AValue;
|
|
end;
|
|
|
|
function TFPObjectList.GetItem(Index: Integer): TObject;
|
|
begin
|
|
Result := TObject(FList[Index]);
|
|
end;
|
|
|
|
procedure TFPObjectList.SetItem(Index: Integer; AObject: TObject);
|
|
begin
|
|
if OwnsObjects then
|
|
TObject(FList[Index]).Free;
|
|
FList[index] := AObject;
|
|
end;
|
|
|
|
procedure TFPObjectList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
FList.Capacity := NewCapacity;
|
|
end;
|
|
|
|
function TFPObjectList.GetCapacity: integer;
|
|
begin
|
|
Result := FList.Capacity;
|
|
end;
|
|
|
|
function TFPObjectList.Add(AObject: TObject): Integer;
|
|
begin
|
|
Result := FList.Add(AObject);
|
|
end;
|
|
|
|
procedure TFPObjectList.Delete(Index: Integer);
|
|
begin
|
|
if OwnsObjects then
|
|
TObject(FList[Index]).Free;
|
|
FList.Delete(Index);
|
|
end;
|
|
|
|
procedure TFPObjectList.Exchange(Index1, Index2: Integer);
|
|
begin
|
|
FList.Exchange(Index1, Index2);
|
|
end;
|
|
|
|
function TFPObjectList.Expand: TFPObjectList;
|
|
begin
|
|
FList.Expand;
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFPObjectList.Extract(Item: TObject): TObject;
|
|
begin
|
|
Result := TObject(FList.Extract(Item));
|
|
end;
|
|
|
|
function TFPObjectList.Remove(AObject: TObject): Integer;
|
|
begin
|
|
Result := IndexOf(AObject);
|
|
if (Result <> -1) then
|
|
begin
|
|
if OwnsObjects then
|
|
TObject(FList[Result]).Free;
|
|
FList.Delete(Result);
|
|
end;
|
|
end;
|
|
|
|
function TFPObjectList.IndexOf(AObject: TObject): Integer;
|
|
begin
|
|
Result := FList.IndexOf(Pointer(AObject));
|
|
end;
|
|
|
|
function TFPObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer;
|
|
var
|
|
I : Integer;
|
|
begin
|
|
I:=AStartAt;
|
|
Result:=-1;
|
|
If AExact then
|
|
while (I<Count) and (Result=-1) do
|
|
If Items[i].ClassType=AClass then
|
|
Result:=I
|
|
else
|
|
Inc(I)
|
|
else
|
|
while (I<Count) and (Result=-1) do
|
|
If Items[i].InheritsFrom(AClass) then
|
|
Result:=I
|
|
else
|
|
Inc(I);
|
|
end;
|
|
|
|
procedure TFPObjectList.Insert(Index: Integer; AObject: TObject);
|
|
begin
|
|
FList.Insert(Index, Pointer(AObject));
|
|
end;
|
|
|
|
procedure TFPObjectList.Move(CurIndex, NewIndex: Integer);
|
|
begin
|
|
FList.Move(CurIndex, NewIndex);
|
|
end;
|
|
|
|
procedure TFPObjectList.Assign(Obj: TFPObjectList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Clear;
|
|
for I := 0 to Obj.Count - 1 do
|
|
Add(Obj[i]);
|
|
end;
|
|
|
|
procedure TFPObjectList.Pack;
|
|
begin
|
|
FList.Pack;
|
|
end;
|
|
|
|
procedure TFPObjectList.Sort(Compare: TListSortCompare);
|
|
begin
|
|
FList.Sort(Compare);
|
|
end;
|
|
|
|
function TFPObjectList.First: TObject;
|
|
begin
|
|
Result := TObject(FList.First);
|
|
end;
|
|
|
|
function TFPObjectList.Last: TObject;
|
|
begin
|
|
Result := TObject(FList.Last);
|
|
end;
|
|
|
|
procedure TFPObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
|
|
begin
|
|
FList.ForEachCall(TListCallBack(proc2call),arg);
|
|
end;
|
|
|
|
procedure TFPObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
|
|
begin
|
|
FList.ForEachCall(TListStaticCallBack(proc2call),arg);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TFPHashList
|
|
*****************************************************************************}
|
|
|
|
function FPHash1(const s:string):LongWord;
|
|
Var
|
|
g : LongWord;
|
|
p,pmax : pchar;
|
|
begin
|
|
result:=0;
|
|
p:=@s[1];
|
|
pmax:=@s[length(s)+1];
|
|
while (p<pmax) do
|
|
begin
|
|
result:=result shl 4 + LongWord(p^);
|
|
g:=result and LongWord($F0000000);
|
|
if g<>0 then
|
|
result:=result xor (g shr 24) xor g;
|
|
inc(p);
|
|
end;
|
|
If result=0 then
|
|
result:=$ffffffff;
|
|
end;
|
|
|
|
function FPHash(const s:string):LongWord;
|
|
Var
|
|
p,pmax : pchar;
|
|
begin
|
|
{$ifopt Q+}
|
|
{$define overflowon}
|
|
{$Q-}
|
|
{$endif}
|
|
result:=0;
|
|
p:=@s[1];
|
|
pmax:=@s[length(s)+1];
|
|
while (p<pmax) do
|
|
begin
|
|
result:=LongWord((result shl 5) - result) xor LongWord(P^);
|
|
inc(p);
|
|
end;
|
|
{$ifdef overflowon}
|
|
{$Q+}
|
|
{$undef overflowon}
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.RaiseIndexError(Index : Integer);
|
|
begin
|
|
Error(SListIndexError, Index);
|
|
end;
|
|
|
|
|
|
function TFPHashList.Get(Index: Integer): Pointer;
|
|
begin
|
|
If (Index < 0) or (Index >= FCount) then
|
|
RaiseIndexError(Index);
|
|
Result:=FHashList^[Index].Data;
|
|
end;
|
|
|
|
|
|
function TFPHashList.NameOfIndex(Index: Integer): String;
|
|
begin
|
|
If (Index < 0) or (Index >= FCount) then
|
|
RaiseIndexError(Index);
|
|
with FHashList^[Index] do
|
|
begin
|
|
if StrIndex>=0 then
|
|
Result:=PShortString(@FStrs[StrIndex])^
|
|
else
|
|
Result:='';
|
|
end;
|
|
end;
|
|
|
|
|
|
function TFPHashList.HashOfIndex(Index: Integer): LongWord;
|
|
begin
|
|
If (Index < 0) or (Index >= FCount) then
|
|
RaiseIndexError(Index);
|
|
Result:=FHashList^[Index].HashValue;
|
|
end;
|
|
|
|
|
|
function TFPHashList.Extract(item: Pointer): Pointer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
result := nil;
|
|
i := IndexOf(item);
|
|
if i >= 0 then
|
|
begin
|
|
Result := item;
|
|
Delete(i);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
If (NewCapacity < FCount) or (NewCapacity > MaxHashListSize) then
|
|
Error (SListCapacityError, NewCapacity);
|
|
if NewCapacity = FCapacity then
|
|
exit;
|
|
ReallocMem(FHashList, NewCapacity*SizeOf(THashItem));
|
|
FCapacity := NewCapacity;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.SetCount(NewCount: Integer);
|
|
begin
|
|
if (NewCount < 0) or (NewCount > MaxHashListSize)then
|
|
Error(SListCountError, NewCount);
|
|
If NewCount > FCount then
|
|
begin
|
|
If NewCount > FCapacity then
|
|
SetCapacity(NewCount);
|
|
If FCount < NewCount then
|
|
FillChar(FHashList^[FCount], (NewCount-FCount) div Sizeof(THashItem), 0);
|
|
end;
|
|
FCount := Newcount;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.SetStrCapacity(NewCapacity: Integer);
|
|
begin
|
|
If (NewCapacity < FStrCount) or (NewCapacity > MaxHashStrSize) then
|
|
Error (SListCapacityError, NewCapacity);
|
|
if NewCapacity = FStrCapacity then
|
|
exit;
|
|
ReallocMem(FStrs, NewCapacity);
|
|
FStrCapacity := NewCapacity;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.SetHashCapacity(NewCapacity: Integer);
|
|
begin
|
|
If (NewCapacity < 1) then
|
|
Error (SListCapacityError, NewCapacity);
|
|
if FHashCapacity=NewCapacity then
|
|
exit;
|
|
FHashCapacity:=NewCapacity;
|
|
ReallocMem(FHashTable, FHashCapacity*sizeof(Integer));
|
|
ReHash;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.ReHash;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
FillDword(FHashTable^,FHashCapacity,LongWord(-1));
|
|
For i:=0 To FCount-1 Do
|
|
AddToHashTable(i);
|
|
end;
|
|
|
|
|
|
constructor TFPHashList.Create;
|
|
begin
|
|
SetHashCapacity(1);
|
|
end;
|
|
|
|
|
|
destructor TFPHashList.Destroy;
|
|
begin
|
|
Clear;
|
|
if assigned(FHashTable) then
|
|
FreeMem(FHashTable);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
function TFPHashList.AddStr(const s:string): Integer;
|
|
var
|
|
Len : Integer;
|
|
begin
|
|
len:=length(s)+1;
|
|
if FStrCount+Len >= FStrCapacity then
|
|
StrExpand(Len);
|
|
System.Move(s[0],FStrs[FStrCount],Len);
|
|
result:=FStrCount;
|
|
inc(FStrCount,Len);
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.AddToHashTable(Index: Integer);
|
|
var
|
|
HashIndex : Integer;
|
|
begin
|
|
with FHashList^[Index] do
|
|
begin
|
|
if not assigned(Data) then
|
|
exit;
|
|
HashIndex:=HashValue mod LongWord(FHashCapacity);
|
|
NextIndex:=FHashTable^[HashIndex];
|
|
FHashTable^[HashIndex]:=Index;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TFPHashList.Add(const AName:string;Item: Pointer): Integer;
|
|
begin
|
|
if FCount = FCapacity then
|
|
Expand;
|
|
with FHashList^[FCount] do
|
|
begin
|
|
HashValue:=FPHash(AName);
|
|
Data:=Item;
|
|
StrIndex:=AddStr(AName);
|
|
end;
|
|
AddToHashTable(FCount);
|
|
Result := FCount;
|
|
inc(FCount);
|
|
end;
|
|
|
|
procedure TFPHashList.Clear;
|
|
begin
|
|
if Assigned(FHashList) then
|
|
begin
|
|
FCount:=0;
|
|
SetCapacity(0);
|
|
FHashList := nil;
|
|
end;
|
|
SetHashCapacity(1);
|
|
if Assigned(FStrs) then
|
|
begin
|
|
FStrCount:=0;
|
|
SetStrCapacity(0);
|
|
FStrs := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TFPHashList.Delete(Index: Integer);
|
|
begin
|
|
If (Index<0) or (Index>=FCount) then
|
|
Error (SListIndexError, Index);
|
|
with FHashList^[Index] do
|
|
begin
|
|
Data:=nil;
|
|
StrIndex:=-1;
|
|
end;
|
|
end;
|
|
|
|
class procedure TFPHashList.Error(const Msg: string; Data: PtrInt);
|
|
begin
|
|
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
|
end;
|
|
|
|
function TFPHashList.Expand: TFPHashList;
|
|
var
|
|
IncSize : Longint;
|
|
begin
|
|
Result := Self;
|
|
if FCount < FCapacity then
|
|
exit;
|
|
IncSize := sizeof(ptrint)*2;
|
|
if FCapacity > 127 then
|
|
Inc(IncSize, FCapacity shr 2)
|
|
else if FCapacity > sizeof(ptrint)*3 then
|
|
Inc(IncSize, FCapacity shr 1)
|
|
else if FCapacity >= sizeof(ptrint) then
|
|
inc(IncSize,sizeof(ptrint));
|
|
SetCapacity(FCapacity + IncSize);
|
|
{ Maybe expand hash also }
|
|
if FCount>FHashCapacity*MaxItemsPerHash then
|
|
SetHashCapacity(FCount div MaxItemsPerHash);
|
|
end;
|
|
|
|
procedure TFPHashList.StrExpand(MinIncSize:Integer);
|
|
var
|
|
IncSize : Longint;
|
|
begin
|
|
if FStrCount+MinIncSize < FStrCapacity then
|
|
exit;
|
|
IncSize := 64;
|
|
if FStrCapacity > 255 then
|
|
Inc(IncSize, FStrCapacity shr 2);
|
|
SetStrCapacity(FStrCapacity + IncSize + MinIncSize);
|
|
end;
|
|
|
|
function TFPHashList.IndexOf(Item: Pointer): Integer;
|
|
var
|
|
psrc : PHashItem;
|
|
Index : integer;
|
|
begin
|
|
Result:=-1;
|
|
psrc:=@FHashList^[0];
|
|
For Index:=0 To FCount-1 Do
|
|
begin
|
|
if psrc^.Data=Item then
|
|
begin
|
|
Result:=Index;
|
|
exit;
|
|
end;
|
|
inc(psrc);
|
|
end;
|
|
end;
|
|
|
|
function TFPHashList.Remove(Item: Pointer): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
If Result <> -1 then
|
|
Self.Delete(Result);
|
|
end;
|
|
|
|
function TFPHashList.InternalFind(AHash:LongWord;const AName:string;out PrevIndex:Integer):Integer;
|
|
var
|
|
HashIndex : Integer;
|
|
Len,
|
|
LastChar : Char;
|
|
begin
|
|
HashIndex:=AHash mod LongWord(FHashCapacity);
|
|
Result:=FHashTable^[HashIndex];
|
|
Len:=Char(Length(AName));
|
|
LastChar:=AName[Byte(Len)];
|
|
PrevIndex:=-1;
|
|
while Result<>-1 do
|
|
begin
|
|
with FHashList^[Result] do
|
|
begin
|
|
if assigned(Data) and
|
|
(HashValue=AHash) and
|
|
(Len=FStrs[StrIndex]) and
|
|
(LastChar=FStrs[StrIndex+Byte(Len)]) and
|
|
(AName=PShortString(@FStrs[StrIndex])^) then
|
|
exit;
|
|
PrevIndex:=Result;
|
|
Result:=NextIndex;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TFPHashList.Find(const AName:string): Pointer;
|
|
var
|
|
Index,
|
|
PrevIndex : Integer;
|
|
begin
|
|
Result:=nil;
|
|
Index:=InternalFind(FPHash(AName),AName,PrevIndex);
|
|
if Index=-1 then
|
|
exit;
|
|
Result:=FHashList^[Index].Data;
|
|
end;
|
|
|
|
|
|
function TFPHashList.FindWithHash(const AName:string;AHash:LongWord): Pointer;
|
|
var
|
|
Index,
|
|
PrevIndex : Integer;
|
|
begin
|
|
Result:=nil;
|
|
Index:=InternalFind(AHash,AName,PrevIndex);
|
|
if Index=-1 then
|
|
exit;
|
|
Result:=FHashList^[Index].Data;
|
|
end;
|
|
|
|
|
|
function TFPHashList.Rename(const AOldName,ANewName:string): Integer;
|
|
var
|
|
PrevIndex,
|
|
Index : Integer;
|
|
OldHash : LongWord;
|
|
begin
|
|
Result:=-1;
|
|
OldHash:=FPHash(AOldName);
|
|
Index:=InternalFind(OldHash,AOldName,PrevIndex);
|
|
if Index=-1 then
|
|
exit;
|
|
{ Remove from current Hash }
|
|
if PrevIndex<>-1 then
|
|
FHashList^[PrevIndex].NextIndex:=FHashList^[Index].NextIndex
|
|
else
|
|
FHashTable^[OldHash mod LongWord(FHashCapacity)]:=FHashList^[Index].NextIndex;
|
|
{ Set new name and hash }
|
|
with FHashList^[Index] do
|
|
begin
|
|
HashValue:=FPHash(ANewName);
|
|
StrIndex:=AddStr(ANewName);
|
|
end;
|
|
{ Insert back in Hash }
|
|
AddToHashTable(Index);
|
|
{ Return Index }
|
|
Result:=Index;
|
|
end;
|
|
|
|
procedure TFPHashList.Pack;
|
|
var
|
|
NewCount,
|
|
i : integer;
|
|
pdest,
|
|
psrc : PHashItem;
|
|
begin
|
|
NewCount:=0;
|
|
psrc:=@FHashList^[0];
|
|
pdest:=psrc;
|
|
For I:=0 To FCount-1 Do
|
|
begin
|
|
if assigned(psrc^.Data) then
|
|
begin
|
|
pdest^:=psrc^;
|
|
inc(pdest);
|
|
inc(NewCount);
|
|
end;
|
|
inc(psrc);
|
|
end;
|
|
FCount:=NewCount;
|
|
{ We need to ReHash to update the IndexNext }
|
|
ReHash;
|
|
{ Release over-capacity }
|
|
SetCapacity(FCount);
|
|
SetStrCapacity(FStrCount);
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.ShowStatistics;
|
|
var
|
|
HashMean,
|
|
HashStdDev : Double;
|
|
Index,
|
|
i,j : Integer;
|
|
begin
|
|
{ Calculate Mean and StdDev }
|
|
HashMean:=0;
|
|
HashStdDev:=0;
|
|
for i:=0 to FHashCapacity-1 do
|
|
begin
|
|
j:=0;
|
|
Index:=FHashTable^[i];
|
|
while (Index<>-1) do
|
|
begin
|
|
inc(j);
|
|
Index:=FHashList^[Index].NextIndex;
|
|
end;
|
|
HashMean:=HashMean+j;
|
|
HashStdDev:=HashStdDev+Sqr(j);
|
|
end;
|
|
HashMean:=HashMean/FHashCapacity;
|
|
HashStdDev:=(HashStdDev-FHashCapacity*Sqr(HashMean));
|
|
If FHashCapacity>1 then
|
|
HashStdDev:=Sqrt(HashStdDev/(FHashCapacity-1))
|
|
else
|
|
HashStdDev:=0;
|
|
{ Print info to stdout }
|
|
Writeln('HashSize : ',FHashCapacity);
|
|
Writeln('HashMean : ',HashMean:1:4);
|
|
Writeln('HashStdDev : ',HashStdDev:1:4);
|
|
Writeln('ListSize : ',FCount,'/',FCapacity);
|
|
Writeln('StringSize : ',FStrCount,'/',FStrCapacity);
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.ForEachCall(proc2call:TListCallback;arg:pointer);
|
|
var
|
|
i : integer;
|
|
p : pointer;
|
|
begin
|
|
For I:=0 To Count-1 Do
|
|
begin
|
|
p:=FHashList^[i].Data;
|
|
if assigned(p) then
|
|
proc2call(p,arg);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TFPHashList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
|
var
|
|
i : integer;
|
|
p : pointer;
|
|
begin
|
|
For I:=0 To Count-1 Do
|
|
begin
|
|
p:=FHashList^[i].Data;
|
|
if assigned(p) then
|
|
proc2call(p,arg);
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TFPHashObject
|
|
*****************************************************************************}
|
|
|
|
procedure TFPHashObject.InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:string);
|
|
var
|
|
Index : integer;
|
|
begin
|
|
FOwner:=HashObjectList;
|
|
Index:=HashObjectList.Add(s,Self);
|
|
FStrIndex:=HashObjectList.List.List^[Index].StrIndex;
|
|
FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
|
|
end;
|
|
|
|
|
|
constructor TFPHashObject.CreateNotOwned;
|
|
begin
|
|
FStrIndex:=-1;
|
|
end;
|
|
|
|
|
|
constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:string);
|
|
begin
|
|
InternalChangeOwner(HashObjectList,s);
|
|
end;
|
|
|
|
|
|
procedure TFPHashObject.ChangeOwner(HashObjectList:TFPHashObjectList);
|
|
begin
|
|
InternalChangeOwner(HashObjectList,PShortString(@FOwner.List.Strs[FStrIndex])^);
|
|
end;
|
|
|
|
|
|
procedure TFPHashObject.ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:string);
|
|
begin
|
|
InternalChangeOwner(HashObjectList,s);
|
|
end;
|
|
|
|
|
|
procedure TFPHashObject.Rename(const ANewName:string);
|
|
var
|
|
Index : integer;
|
|
begin
|
|
Index:=FOwner.Rename(PShortString(@FOwner.List.Strs[FStrIndex])^,ANewName);
|
|
if Index<>-1 then
|
|
begin
|
|
FStrIndex:=FOwner.List.List^[Index].StrIndex;
|
|
FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
|
|
end;
|
|
end;
|
|
|
|
|
|
function TFPHashObject.GetName:string;
|
|
begin
|
|
if FOwner<>nil then
|
|
begin
|
|
FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
|
|
Result:=FCachedStr^;
|
|
end
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
|
|
function TFPHashObject.GetHash:Longword;
|
|
begin
|
|
if FOwner<>nil then
|
|
Result:=FPHash(PShortString(@FOwner.List.Strs[FStrIndex])^)
|
|
else
|
|
Result:=$ffffffff;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TFPHashObjectList (Copied from rtl/objpas/classes/lists.inc)
|
|
*****************************************************************************}
|
|
|
|
constructor TFPHashObjectList.Create(FreeObjects : boolean = True);
|
|
begin
|
|
inherited Create;
|
|
FHashList := TFPHashList.Create;
|
|
FFreeObjects := Freeobjects;
|
|
end;
|
|
|
|
destructor TFPHashObjectList.Destroy;
|
|
begin
|
|
if (FHashList <> nil) then
|
|
begin
|
|
Clear;
|
|
FHashList.Destroy;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFPHashObjectList.Clear;
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FFreeObjects then
|
|
for i := 0 to FHashList.Count - 1 do
|
|
TObject(FHashList[i]).Free;
|
|
FHashList.Clear;
|
|
end;
|
|
|
|
function TFPHashObjectList.GetCount: integer;
|
|
begin
|
|
Result := FHashList.Count;
|
|
end;
|
|
|
|
procedure TFPHashObjectList.SetCount(const AValue: integer);
|
|
begin
|
|
if FHashList.Count <> AValue then
|
|
FHashList.Count := AValue;
|
|
end;
|
|
|
|
function TFPHashObjectList.GetItem(Index: Integer): TObject;
|
|
begin
|
|
Result := TObject(FHashList[Index]);
|
|
end;
|
|
|
|
procedure TFPHashObjectList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
FHashList.Capacity := NewCapacity;
|
|
end;
|
|
|
|
function TFPHashObjectList.GetCapacity: integer;
|
|
begin
|
|
Result := FHashList.Capacity;
|
|
end;
|
|
|
|
function TFPHashObjectList.Add(const AName:string;AObject: TObject): Integer;
|
|
begin
|
|
Result := FHashList.Add(AName,AObject);
|
|
end;
|
|
|
|
function TFPHashObjectList.NameOfIndex(Index: Integer): String;
|
|
begin
|
|
Result := FHashList.NameOfIndex(Index);
|
|
end;
|
|
|
|
function TFPHashObjectList.HashOfIndex(Index: Integer): LongWord;
|
|
begin
|
|
Result := FHashList.HashOfIndex(Index);
|
|
end;
|
|
|
|
procedure TFPHashObjectList.Delete(Index: Integer);
|
|
begin
|
|
if OwnsObjects then
|
|
TObject(FHashList[Index]).Free;
|
|
FHashList.Delete(Index);
|
|
end;
|
|
|
|
function TFPHashObjectList.Expand: TFPHashObjectList;
|
|
begin
|
|
FHashList.Expand;
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFPHashObjectList.Extract(Item: TObject): TObject;
|
|
begin
|
|
Result := TObject(FHashList.Extract(Item));
|
|
end;
|
|
|
|
function TFPHashObjectList.Remove(AObject: TObject): Integer;
|
|
begin
|
|
Result := IndexOf(AObject);
|
|
if (Result <> -1) then
|
|
begin
|
|
if OwnsObjects then
|
|
TObject(FHashList[Result]).Free;
|
|
FHashList.Delete(Result);
|
|
end;
|
|
end;
|
|
|
|
function TFPHashObjectList.IndexOf(AObject: TObject): Integer;
|
|
begin
|
|
Result := FHashList.IndexOf(Pointer(AObject));
|
|
end;
|
|
|
|
|
|
function TFPHashObjectList.Find(const s:string): TObject;
|
|
begin
|
|
result:=TObject(FHashList.Find(s));
|
|
end;
|
|
|
|
|
|
function TFPHashObjectList.FindWithHash(const AName:string;AHash:LongWord): Pointer;
|
|
begin
|
|
Result:=TObject(FHashList.FindWithHash(AName,AHash));
|
|
end;
|
|
|
|
|
|
function TFPHashObjectList.Rename(const AOldName,ANewName:string): Integer;
|
|
begin
|
|
Result:=FHashList.Rename(AOldName,ANewName);
|
|
end;
|
|
|
|
|
|
function TFPHashObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer;
|
|
var
|
|
I : Integer;
|
|
begin
|
|
I:=AStartAt;
|
|
Result:=-1;
|
|
If AExact then
|
|
while (I<Count) and (Result=-1) do
|
|
If Items[i].ClassType=AClass then
|
|
Result:=I
|
|
else
|
|
Inc(I)
|
|
else
|
|
while (I<Count) and (Result=-1) do
|
|
If Items[i].InheritsFrom(AClass) then
|
|
Result:=I
|
|
else
|
|
Inc(I);
|
|
end;
|
|
|
|
|
|
procedure TFPHashObjectList.Pack;
|
|
begin
|
|
FHashList.Pack;
|
|
end;
|
|
|
|
|
|
procedure TFPHashObjectList.ShowStatistics;
|
|
begin
|
|
FHashList.ShowStatistics;
|
|
end;
|
|
|
|
|
|
procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
|
|
begin
|
|
FHashList.ForEachCall(TListCallBack(proc2call),arg);
|
|
end;
|
|
|
|
|
|
procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
|
|
begin
|
|
FHashList.ForEachCall(TListStaticCallBack(proc2call),arg);
|
|
end;
|
|
|
|
|
|
|
|
{****************************************************************************
|
|
TLinkedListItem
|
|
****************************************************************************}
|
|
|
|
constructor TLinkedListItem.Create;
|
|
begin
|
|
Previous:=nil;
|
|
Next:=nil;
|
|
end;
|
|
|
|
|
|
destructor TLinkedListItem.Destroy;
|
|
begin
|
|
end;
|
|
|
|
|
|
function TLinkedListItem.GetCopy:TLinkedListItem;
|
|
var
|
|
p : TLinkedListItem;
|
|
l : integer;
|
|
begin
|
|
p:=TLinkedListItemClass(ClassType).Create;
|
|
l:=InstanceSize;
|
|
Move(pointer(self)^,pointer(p)^,l);
|
|
Result:=p;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TLinkedList
|
|
****************************************************************************}
|
|
|
|
constructor TLinkedList.Create;
|
|
begin
|
|
FFirst:=nil;
|
|
Flast:=nil;
|
|
FCount:=0;
|
|
FNoClear:=False;
|
|
end;
|
|
|
|
|
|
destructor TLinkedList.destroy;
|
|
begin
|
|
if not FNoClear then
|
|
Clear;
|
|
end;
|
|
|
|
|
|
function TLinkedList.empty:boolean;
|
|
begin
|
|
Empty:=(FFirst=nil);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.Insert(Item:TLinkedListItem);
|
|
begin
|
|
if FFirst=nil then
|
|
begin
|
|
FLast:=Item;
|
|
Item.Previous:=nil;
|
|
Item.Next:=nil;
|
|
end
|
|
else
|
|
begin
|
|
FFirst.Previous:=Item;
|
|
Item.Previous:=nil;
|
|
Item.Next:=FFirst;
|
|
end;
|
|
FFirst:=Item;
|
|
inc(FCount);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.InsertBefore(Item,Loc : TLinkedListItem);
|
|
begin
|
|
Item.Previous:=Loc.Previous;
|
|
Item.Next:=Loc;
|
|
Loc.Previous:=Item;
|
|
if assigned(Item.Previous) then
|
|
Item.Previous.Next:=Item
|
|
else
|
|
{ if we've no next item, we've to adjust FFist }
|
|
FFirst:=Item;
|
|
inc(FCount);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.InsertAfter(Item,Loc : TLinkedListItem);
|
|
begin
|
|
Item.Next:=Loc.Next;
|
|
Loc.Next:=Item;
|
|
Item.Previous:=Loc;
|
|
if assigned(Item.Next) then
|
|
Item.Next.Previous:=Item
|
|
else
|
|
{ if we've no next item, we've to adjust FLast }
|
|
FLast:=Item;
|
|
inc(FCount);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.Concat(Item:TLinkedListItem);
|
|
begin
|
|
if FFirst=nil then
|
|
begin
|
|
FFirst:=Item;
|
|
Item.Previous:=nil;
|
|
Item.Next:=nil;
|
|
end
|
|
else
|
|
begin
|
|
Flast.Next:=Item;
|
|
Item.Previous:=Flast;
|
|
Item.Next:=nil;
|
|
end;
|
|
Flast:=Item;
|
|
inc(FCount);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.remove(Item:TLinkedListItem);
|
|
begin
|
|
if Item=nil then
|
|
exit;
|
|
if (FFirst=Item) and (Flast=Item) then
|
|
begin
|
|
FFirst:=nil;
|
|
Flast:=nil;
|
|
end
|
|
else if FFirst=Item then
|
|
begin
|
|
FFirst:=Item.Next;
|
|
if assigned(FFirst) then
|
|
FFirst.Previous:=nil;
|
|
end
|
|
else if Flast=Item then
|
|
begin
|
|
Flast:=Flast.Previous;
|
|
if assigned(Flast) then
|
|
Flast.Next:=nil;
|
|
end
|
|
else
|
|
begin
|
|
Item.Previous.Next:=Item.Next;
|
|
Item.Next.Previous:=Item.Previous;
|
|
end;
|
|
Item.Next:=nil;
|
|
Item.Previous:=nil;
|
|
dec(FCount);
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.clear;
|
|
var
|
|
NewNode : TLinkedListItem;
|
|
begin
|
|
NewNode:=FFirst;
|
|
while assigned(NewNode) do
|
|
begin
|
|
FFirst:=NewNode.Next;
|
|
NewNode.Free;
|
|
NewNode:=FFirst;
|
|
end;
|
|
FLast:=nil;
|
|
FFirst:=nil;
|
|
FCount:=0;
|
|
end;
|
|
|
|
|
|
function TLinkedList.GetFirst:TLinkedListItem;
|
|
begin
|
|
if FFirst=nil then
|
|
GetFirst:=nil
|
|
else
|
|
begin
|
|
GetFirst:=FFirst;
|
|
if FFirst=FLast then
|
|
FLast:=nil;
|
|
FFirst:=FFirst.Next;
|
|
dec(FCount);
|
|
end;
|
|
end;
|
|
|
|
|
|
function TLinkedList.GetLast:TLinkedListItem;
|
|
begin
|
|
if FLast=nil then
|
|
Getlast:=nil
|
|
else
|
|
begin
|
|
Getlast:=FLast;
|
|
if FLast=FFirst then
|
|
FFirst:=nil;
|
|
FLast:=FLast.Previous;
|
|
dec(FCount);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.insertList(p : TLinkedList);
|
|
begin
|
|
{ empty List ? }
|
|
if (p.FFirst=nil) then
|
|
exit;
|
|
p.Flast.Next:=FFirst;
|
|
{ we have a double Linked List }
|
|
if assigned(FFirst) then
|
|
FFirst.Previous:=p.Flast;
|
|
FFirst:=p.FFirst;
|
|
if (FLast=nil) then
|
|
Flast:=p.Flast;
|
|
inc(FCount,p.FCount);
|
|
{ p becomes empty }
|
|
p.FFirst:=nil;
|
|
p.Flast:=nil;
|
|
p.FCount:=0;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.insertListBefore(Item:TLinkedListItem;p : TLinkedList);
|
|
begin
|
|
{ empty List ? }
|
|
if (p.FFirst=nil) then
|
|
exit;
|
|
if (Item=nil) then
|
|
begin
|
|
{ Insert at begin }
|
|
InsertList(p);
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
p.FLast.Next:=Item;
|
|
p.FFirst.Previous:=Item.Previous;
|
|
if assigned(Item.Previous) then
|
|
Item.Previous.Next:=p.FFirst
|
|
else
|
|
FFirst:=p.FFirst;
|
|
Item.Previous:=p.FLast;
|
|
inc(FCount,p.FCount);
|
|
end;
|
|
{ p becomes empty }
|
|
p.FFirst:=nil;
|
|
p.Flast:=nil;
|
|
p.FCount:=0;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.insertListAfter(Item:TLinkedListItem;p : TLinkedList);
|
|
begin
|
|
{ empty List ? }
|
|
if (p.FFirst=nil) then
|
|
exit;
|
|
if (Item=nil) then
|
|
begin
|
|
{ Insert at begin }
|
|
InsertList(p);
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
p.FFirst.Previous:=Item;
|
|
p.FLast.Next:=Item.Next;
|
|
if assigned(Item.Next) then
|
|
Item.Next.Previous:=p.FLast
|
|
else
|
|
FLast:=p.FLast;
|
|
Item.Next:=p.FFirst;
|
|
inc(FCount,p.FCount);
|
|
end;
|
|
{ p becomes empty }
|
|
p.FFirst:=nil;
|
|
p.Flast:=nil;
|
|
p.FCount:=0;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.concatList(p : TLinkedList);
|
|
begin
|
|
if (p.FFirst=nil) then
|
|
exit;
|
|
if FFirst=nil then
|
|
FFirst:=p.FFirst
|
|
else
|
|
begin
|
|
FLast.Next:=p.FFirst;
|
|
p.FFirst.Previous:=Flast;
|
|
end;
|
|
Flast:=p.Flast;
|
|
inc(FCount,p.FCount);
|
|
{ make p empty }
|
|
p.Flast:=nil;
|
|
p.FFirst:=nil;
|
|
p.FCount:=0;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.insertListcopy(p : TLinkedList);
|
|
var
|
|
NewNode,NewNode2 : TLinkedListItem;
|
|
begin
|
|
NewNode:=p.Last;
|
|
while assigned(NewNode) do
|
|
begin
|
|
NewNode2:=NewNode.Getcopy;
|
|
if assigned(NewNode2) then
|
|
Insert(NewNode2);
|
|
NewNode:=NewNode.Previous;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TLinkedList.concatListcopy(p : TLinkedList);
|
|
var
|
|
NewNode,NewNode2 : TLinkedListItem;
|
|
begin
|
|
NewNode:=p.First;
|
|
while assigned(NewNode) do
|
|
begin
|
|
NewNode2:=NewNode.Getcopy;
|
|
if assigned(NewNode2) then
|
|
Concat(NewNode2);
|
|
NewNode:=NewNode.Next;
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TStringListItem
|
|
****************************************************************************}
|
|
|
|
constructor TStringListItem.Create(const s:string);
|
|
begin
|
|
inherited Create;
|
|
FPStr:=stringdup(s);
|
|
end;
|
|
|
|
|
|
destructor TStringListItem.Destroy;
|
|
begin
|
|
stringdispose(FPStr);
|
|
end;
|
|
|
|
|
|
function TStringListItem.Str:string;
|
|
begin
|
|
Str:=FPStr^;
|
|
end;
|
|
|
|
|
|
function TStringListItem.GetCopy:TLinkedListItem;
|
|
begin
|
|
Result:=(inherited GetCopy);
|
|
TStringListItem(Result).FPStr:=stringdup(FPstr^);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TSTRINGList
|
|
****************************************************************************}
|
|
|
|
constructor tstringList.Create;
|
|
begin
|
|
inherited Create;
|
|
FDoubles:=true;
|
|
end;
|
|
|
|
|
|
constructor tstringList.Create_no_double;
|
|
begin
|
|
inherited Create;
|
|
FDoubles:=false;
|
|
end;
|
|
|
|
|
|
procedure tstringList.insert(const s : string);
|
|
begin
|
|
if (s='') or
|
|
((not FDoubles) and (find(s)<>nil)) then
|
|
exit;
|
|
inherited insert(tstringListItem.create(s));
|
|
end;
|
|
|
|
|
|
procedure tstringList.concat(const s : string);
|
|
begin
|
|
if (s='') or
|
|
((not FDoubles) and (find(s)<>nil)) then
|
|
exit;
|
|
inherited concat(tstringListItem.create(s));
|
|
end;
|
|
|
|
|
|
procedure tstringList.remove(const s : string);
|
|
var
|
|
p : tstringListItem;
|
|
begin
|
|
if s='' then
|
|
exit;
|
|
p:=find(s);
|
|
if assigned(p) then
|
|
begin
|
|
inherited Remove(p);
|
|
p.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tstringList.GetFirst : string;
|
|
var
|
|
p : tstringListItem;
|
|
begin
|
|
p:=tstringListItem(inherited GetFirst);
|
|
if p=nil then
|
|
GetFirst:=''
|
|
else
|
|
begin
|
|
GetFirst:=p.FPStr^;
|
|
p.free;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tstringList.Getlast : string;
|
|
var
|
|
p : tstringListItem;
|
|
begin
|
|
p:=tstringListItem(inherited Getlast);
|
|
if p=nil then
|
|
Getlast:=''
|
|
else
|
|
begin
|
|
Getlast:=p.FPStr^;
|
|
p.free;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tstringList.FindCase(const s:string):TstringListItem;
|
|
var
|
|
NewNode : tstringListItem;
|
|
begin
|
|
result:=nil;
|
|
if s='' then
|
|
exit;
|
|
NewNode:=tstringListItem(FFirst);
|
|
while assigned(NewNode) do
|
|
begin
|
|
if NewNode.FPStr^=s then
|
|
begin
|
|
result:=NewNode;
|
|
exit;
|
|
end;
|
|
NewNode:=tstringListItem(NewNode.Next);
|
|
end;
|
|
end;
|
|
|
|
|
|
function tstringList.Find(const s:string):TstringListItem;
|
|
var
|
|
NewNode : tstringListItem;
|
|
ups : string;
|
|
begin
|
|
result:=nil;
|
|
if s='' then
|
|
exit;
|
|
ups:=upper(s);
|
|
NewNode:=tstringListItem(FFirst);
|
|
while assigned(NewNode) do
|
|
begin
|
|
if upper(NewNode.FPStr^)=ups then
|
|
begin
|
|
result:=NewNode;
|
|
exit;
|
|
end;
|
|
NewNode:=tstringListItem(NewNode.Next);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TStringList.InsertItem(item:TStringListItem);
|
|
begin
|
|
inherited Insert(item);
|
|
end;
|
|
|
|
|
|
procedure TStringList.ConcatItem(item:TStringListItem);
|
|
begin
|
|
inherited Concat(item);
|
|
end;
|
|
|
|
|
|
procedure TStringList.readstream(f:TCStream);
|
|
const
|
|
BufSize = 16384;
|
|
var
|
|
Hsp,
|
|
p,maxp,
|
|
Buf : PChar;
|
|
Prev : Char;
|
|
HsPos,
|
|
ReadLen,
|
|
BufPos,
|
|
BufEnd : Longint;
|
|
hs : string;
|
|
|
|
procedure ReadBuf;
|
|
begin
|
|
if BufPos<BufEnd then
|
|
begin
|
|
Move(Buf[BufPos],Buf[0],BufEnd-BufPos);
|
|
Dec(BufEnd,BufPos);
|
|
BufPos:=0;
|
|
end;
|
|
ReadLen:=f.Read(buf[BufEnd],BufSize-BufEnd);
|
|
inc(BufEnd,ReadLen);
|
|
end;
|
|
|
|
begin
|
|
Getmem(Buf,Bufsize);
|
|
BufPos:=0;
|
|
BufEnd:=0;
|
|
HsPos:=1;
|
|
ReadBuf;
|
|
repeat
|
|
hsp:=@hs[hsPos];
|
|
p:=@Buf[BufPos];
|
|
maxp:=@Buf[BufEnd];
|
|
while (p<maxp) and not(P^ in [#10,#13]) do
|
|
begin
|
|
hsp^:=p^;
|
|
inc(p);
|
|
if hsp-@hs[1]<255 then
|
|
inc(hsp);
|
|
end;
|
|
inc(BufPos,maxp-p);
|
|
inc(HsPos,maxp-p);
|
|
prev:=p^;
|
|
inc(BufPos);
|
|
{ no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, }
|
|
{ #13#10 = Dos), so if we've got #10, we can safely exit }
|
|
if (prev<>#10) then
|
|
begin
|
|
if (BufPos>=BufEnd) then
|
|
begin
|
|
ReadBuf;
|
|
if BufPos>=BufEnd then
|
|
break;
|
|
end;
|
|
{ is there also a #10 after it? }
|
|
if prev=#13 then
|
|
begin
|
|
if (Buf[BufPos]=#10) then
|
|
inc(BufPos);
|
|
prev:=#10;
|
|
end;
|
|
end;
|
|
if prev=#10 then
|
|
begin
|
|
hs[0]:=char(hsp-@hs[1]);
|
|
Concat(hs);
|
|
HsPos:=1;
|
|
end;
|
|
until BufPos>=BufEnd;
|
|
hs[0]:=char(hsp-@hs[1]);
|
|
Concat(hs);
|
|
freemem(buf);
|
|
end;
|
|
|
|
|
|
procedure TStringList.writestream(f:TCStream);
|
|
var
|
|
Node : TStringListItem;
|
|
LineEnd : string[2];
|
|
begin
|
|
Case DefaultTextLineBreakStyle Of
|
|
tlbsLF: LineEnd := #10;
|
|
tlbsCRLF: LineEnd := #13#10;
|
|
tlbsCR: LineEnd := #13;
|
|
End;
|
|
Node:=tstringListItem(FFirst);
|
|
while assigned(Node) do
|
|
begin
|
|
f.Write(Node.FPStr^[1],Length(Node.FPStr^));
|
|
f.Write(LineEnd[1],length(LineEnd));
|
|
Node:=tstringListItem(Node.Next);
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
tdynamicarray
|
|
****************************************************************************}
|
|
|
|
constructor tdynamicarray.create(Ablocksize:integer);
|
|
begin
|
|
FPosn:=0;
|
|
FPosnblock:=nil;
|
|
FFirstblock:=nil;
|
|
FLastblock:=nil;
|
|
FCurrBlockSize:=0;
|
|
FMaxBlockSize:=Ablocksize;
|
|
grow;
|
|
end;
|
|
|
|
|
|
destructor tdynamicarray.destroy;
|
|
var
|
|
hp : pdynamicblock;
|
|
begin
|
|
while assigned(FFirstblock) do
|
|
begin
|
|
hp:=FFirstblock;
|
|
FFirstblock:=FFirstblock^.Next;
|
|
Freemem(hp);
|
|
end;
|
|
end;
|
|
|
|
|
|
function tdynamicarray.size:integer;
|
|
begin
|
|
if assigned(FLastblock) then
|
|
size:=FLastblock^.pos+FLastblock^.used
|
|
else
|
|
size:=0;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.reset;
|
|
var
|
|
hp : pdynamicblock;
|
|
begin
|
|
while assigned(FFirstblock) do
|
|
begin
|
|
hp:=FFirstblock;
|
|
FFirstblock:=FFirstblock^.Next;
|
|
Freemem(hp);
|
|
end;
|
|
FPosn:=0;
|
|
FPosnblock:=nil;
|
|
FFirstblock:=nil;
|
|
FLastblock:=nil;
|
|
grow;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.grow;
|
|
var
|
|
nblock : pdynamicblock;
|
|
OptBlockSize,
|
|
IncSize : integer;
|
|
begin
|
|
if CurrBlockSize<FMaxBlocksize then
|
|
begin
|
|
IncSize := sizeof(ptrint)*8;
|
|
if FCurrBlockSize > 255 then
|
|
Inc(IncSize, FCurrBlockSize shr 2);
|
|
inc(FCurrBlockSize,IncSize);
|
|
end;
|
|
if CurrBlockSize>FMaxBlocksize then
|
|
FCurrBlockSize:=FMaxBlocksize;
|
|
{ Calculate the most optimal size so there is no alignment overhead
|
|
lost in the heap manager }
|
|
OptBlockSize:=cutils.Align(CurrBlockSize+dynamicblockbasesize,16)-dynamicblockbasesize-sizeof(ptrint);
|
|
Getmem(nblock,OptBlockSize+dynamicblockbasesize);
|
|
if not assigned(FFirstblock) then
|
|
begin
|
|
FFirstblock:=nblock;
|
|
FPosnblock:=nblock;
|
|
nblock^.pos:=0;
|
|
end
|
|
else
|
|
begin
|
|
FLastblock^.Next:=nblock;
|
|
nblock^.pos:=FLastblock^.pos+FLastblock^.size;
|
|
end;
|
|
nblock^.used:=0;
|
|
nblock^.size:=OptBlockSize;
|
|
nblock^.Next:=nil;
|
|
fillchar(nblock^.data,nblock^.size,0);
|
|
FLastblock:=nblock;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.align(i:integer);
|
|
var
|
|
j : integer;
|
|
begin
|
|
j:=(FPosn mod i);
|
|
if j<>0 then
|
|
begin
|
|
j:=i-j;
|
|
if FPosnblock^.used+j>FPosnblock^.size then
|
|
begin
|
|
dec(j,FPosnblock^.size-FPosnblock^.used);
|
|
FPosnblock^.used:=FPosnblock^.size;
|
|
grow;
|
|
FPosnblock:=FLastblock;
|
|
end;
|
|
inc(FPosnblock^.used,j);
|
|
inc(FPosn,j);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.seek(i:integer);
|
|
begin
|
|
if (i<FPosnblock^.pos) or (i>=FPosnblock^.pos+FPosnblock^.size) then
|
|
begin
|
|
{ set FPosnblock correct if the size is bigger then
|
|
the current block }
|
|
if FPosnblock^.pos>i then
|
|
FPosnblock:=FFirstblock;
|
|
while assigned(FPosnblock) do
|
|
begin
|
|
if FPosnblock^.pos+FPosnblock^.size>i then
|
|
break;
|
|
FPosnblock:=FPosnblock^.Next;
|
|
end;
|
|
{ not found ? then increase blocks }
|
|
if not assigned(FPosnblock) then
|
|
begin
|
|
repeat
|
|
{ the current FLastblock is now also fully used }
|
|
FLastblock^.used:=FLastblock^.size;
|
|
grow;
|
|
FPosnblock:=FLastblock;
|
|
until FPosnblock^.pos+FPosnblock^.size>=i;
|
|
end;
|
|
end;
|
|
FPosn:=i;
|
|
if FPosn-FPosnblock^.pos>FPosnblock^.used then
|
|
FPosnblock^.used:=FPosn-FPosnblock^.pos;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.write(const d;len:integer);
|
|
var
|
|
p : pchar;
|
|
i,j : integer;
|
|
begin
|
|
p:=pchar(@d);
|
|
while (len>0) do
|
|
begin
|
|
i:=FPosn-FPosnblock^.pos;
|
|
if i+len>=FPosnblock^.size then
|
|
begin
|
|
j:=FPosnblock^.size-i;
|
|
move(p^,FPosnblock^.data[i],j);
|
|
inc(p,j);
|
|
inc(FPosn,j);
|
|
dec(len,j);
|
|
FPosnblock^.used:=FPosnblock^.size;
|
|
if assigned(FPosnblock^.Next) then
|
|
FPosnblock:=FPosnblock^.Next
|
|
else
|
|
begin
|
|
grow;
|
|
FPosnblock:=FLastblock;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
move(p^,FPosnblock^.data[i],len);
|
|
inc(p,len);
|
|
inc(FPosn,len);
|
|
i:=FPosn-FPosnblock^.pos;
|
|
if i>FPosnblock^.used then
|
|
FPosnblock^.used:=i;
|
|
len:=0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.writestr(const s:string);
|
|
begin
|
|
write(s[1],length(s));
|
|
end;
|
|
|
|
|
|
function tdynamicarray.read(var d;len:integer):integer;
|
|
var
|
|
p : pchar;
|
|
i,j,res : integer;
|
|
begin
|
|
res:=0;
|
|
p:=pchar(@d);
|
|
while (len>0) do
|
|
begin
|
|
i:=FPosn-FPosnblock^.pos;
|
|
if i+len>=FPosnblock^.used then
|
|
begin
|
|
j:=FPosnblock^.used-i;
|
|
move(FPosnblock^.data[i],p^,j);
|
|
inc(p,j);
|
|
inc(FPosn,j);
|
|
inc(res,j);
|
|
dec(len,j);
|
|
if assigned(FPosnblock^.Next) then
|
|
FPosnblock:=FPosnblock^.Next
|
|
else
|
|
break;
|
|
end
|
|
else
|
|
begin
|
|
move(FPosnblock^.data[i],p^,len);
|
|
inc(p,len);
|
|
inc(FPosn,len);
|
|
inc(res,len);
|
|
len:=0;
|
|
end;
|
|
end;
|
|
read:=res;
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.readstream(f:TCStream;maxlen:longint);
|
|
var
|
|
i,left : integer;
|
|
begin
|
|
if maxlen=-1 then
|
|
maxlen:=maxlongint;
|
|
repeat
|
|
left:=FPosnblock^.size-FPosnblock^.used;
|
|
if left>maxlen then
|
|
left:=maxlen;
|
|
i:=f.Read(FPosnblock^.data[FPosnblock^.used],left);
|
|
dec(maxlen,i);
|
|
inc(FPosnblock^.used,i);
|
|
if FPosnblock^.used=FPosnblock^.size then
|
|
begin
|
|
if assigned(FPosnblock^.Next) then
|
|
FPosnblock:=FPosnblock^.Next
|
|
else
|
|
begin
|
|
grow;
|
|
FPosnblock:=FLastblock;
|
|
end;
|
|
end;
|
|
until (i<left) or (maxlen=0);
|
|
end;
|
|
|
|
|
|
procedure tdynamicarray.writestream(f:TCStream);
|
|
var
|
|
hp : pdynamicblock;
|
|
begin
|
|
hp:=FFirstblock;
|
|
while assigned(hp) do
|
|
begin
|
|
f.Write(hp^.data,hp^.used);
|
|
hp:=hp^.Next;
|
|
end;
|
|
end;
|
|
|
|
end.
|