paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-27 09:51:58 +01:00
Code Issues Packages Projects Releases Wiki Activity
d6ad7721e6
fpc/compiler/cclasses.pas
Jonas Maebe 7173b9dfed * fixed (harmless) range check errors 
git-svn-id: trunk@17643 -
2011-06-02 20:07:06 +00:00

2876 lines
73 KiB
ObjectPascal
Raw Blame History

{
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}
{$define CCLASSESINLINE}
{$endif}
interface
uses
{$IFNDEF USE_FAKE_SYSUTILS}
SysUtils,
{$ELSE}
fksysutl,
{$ENDIF}
globtype,
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)';
SListCapacityPower2Error = 'The capacity has to be a power of 2, but is set to %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;
procedure Put(Index: Integer; Item: Pointer);
procedure SetCapacity(NewCapacity: Integer);
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;
function IndexOf(Item: Pointer): Integer;
procedure Insert(Index: Integer; Item: Pointer);
function Last: Pointer;
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);
protected
function GetItem(Index: Integer): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
procedure SetItem(Index: Integer; AObject: TObject);
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);
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);
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;
FCapacityMask: LongWord;
{ Hash }
FHashTable : PHashTable;
FHashCapacity : Integer;
{ Strings }
FStrs : PChar;
FStrCount,
FStrCapacity : Integer;
function InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer;
protected
function Get(Index: Integer): Pointer;
procedure Put(Index: Integer; Item: Pointer);
procedure SetCapacity(NewCapacity: Integer);
procedure SetCount(NewCount: Integer);
Procedure RaiseIndexError(Index : Integer);
function AddStr(const s:shortstring): 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:shortstring;Item: Pointer): Integer;
procedure Clear;
function NameOfIndex(Index: Integer): ShortString;
function HashOfIndex(Index: Integer): LongWord;
function GetNextCollision(Index: Integer): Integer;
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:shortstring): Pointer;
function FindIndexOf(const AName:shortstring): Integer;
function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
function Rename(const AOldName,ANewName:shortstring): 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 write Put; 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:shortstring);
protected
function GetName:shortstring;virtual;
function GetHash:Longword;virtual;
public
constructor CreateNotOwned;
constructor Create(HashObjectList:TFPHashObjectList;const s:shortstring);
procedure ChangeOwner(HashObjectList:TFPHashObjectList);
procedure ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:shortstring); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure Rename(const ANewName:shortstring);
property Name:shortstring 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);
protected
function GetItem(Index: Integer): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
procedure SetItem(Index: Integer; AObject: TObject);
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:shortstring;AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
function NameOfIndex(Index: Integer): ShortString; {$ifdef CCLASSESINLINE}inline;{$endif}
function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif}
function GetNextCollision(Index: Integer): Integer; {$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:shortstring): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
function FindIndexOf(const s:shortstring): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
function Rename(const AOldName,ANewName:shortstring): 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 write SetItem; 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;
{********************************************
TCmdStrList
********************************************}
{ string containerItem }
TCmdStrListItem = class(TLinkedListItem)
FPStr : TCmdStr;
public
constructor Create(const s:TCmdStr);
destructor Destroy;override;
function GetCopy:TLinkedListItem;override;
function Str:TCmdStr; {$ifdef CCLASSESINLINE}inline;{$endif}
end;
{ string container }
TCmdStrList = 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:TCmdStr);
{ concats an Item }
procedure Concat(const s:TCmdStr);
{ deletes an Item }
procedure Remove(const s:TCmdStr);
{ Gets First Item }
function GetFirst:TCmdStr;
{ Gets last Item }
function GetLast:TCmdStr;
{ true if string is in the container, compare case sensitive }
function FindCase(const s:TCmdStr):TCmdStrListItem;
{ true if string is in the container }
function Find(const s:TCmdStr):TCmdStrListItem;
{ inserts an item }
procedure InsertItem(item:TCmdStrListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
{ concats an item }
procedure ConcatItem(item:TCmdStrListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
property Doubles:boolean read FDoubles write FDoubles;
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 : longword;
Next : pdynamicblock;
data : tdynamicblockdata;
end;
const
dynamicblockbasesize = sizeof(tdynamicblock)-sizeof(tdynamicblockdata);
type
tdynamicarray = class
private
FPosn : longword;
FPosnblock : pdynamicblock;
FCurrBlocksize,
FMaxBlocksize : longword;
FFirstblock,
FLastblock : pdynamicblock;
procedure grow;
public
constructor Create(Ablocksize:longword);
destructor Destroy;override;
procedure reset;
function size:longword;
procedure align(i:longword);
procedure seek(i:longword);
function read(var d;len:longword):longword;
procedure write(const d;len:longword);
procedure writestr(const s:string); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure readstream(f:TCStream;maxlen:longword);
procedure writestream(f:TCStream);
property CurrBlockSize : longword read FCurrBlocksize;
property FirstBlock : PDynamicBlock read FFirstBlock;
property Pos : longword read FPosn;
end;
{******************************************************************
THashSet (keys not limited to ShortString, no indexed access)
*******************************************************************}
PPHashSetItem = ^PHashSetItem;
PHashSetItem = ^THashSetItem;
THashSetItem = record
Next: PHashSetItem;
Key: Pointer;
KeyLength: Integer;
HashValue: LongWord;
Data: TObject;
end;
THashSet = class(TObject)
private
FCount: LongWord;
FBucketCount: LongWord;
FBucket: PPHashSetItem;
FOwnsObjects: Boolean;
FOwnsKeys: Boolean;
function Lookup(Key: Pointer; KeyLen: Integer; var Found: Boolean;
CanCreate: Boolean): PHashSetItem;
procedure Resize(NewCapacity: LongWord);
public
constructor Create(InitSize: Integer; OwnKeys, OwnObjects: Boolean);
destructor Destroy; override;
procedure Clear;
{ finds an entry by key }
function Find(Key: Pointer; KeyLen: Integer): PHashSetItem;
{ finds an entry, creates one if not exists }
function FindOrAdd(Key: Pointer; KeyLen: Integer;
var Found: Boolean): PHashSetItem;
{ finds an entry, creates one if not exists }
function FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;
{ returns Data by given Key }
function Get(Key: Pointer; KeyLen: Integer): TObject;
{ removes an entry, returns False if entry wasn't there }
function Remove(Entry: PHashSetItem): Boolean;
property Count: LongWord read FCount;
end;
{******************************************************************
tbitset
*******************************************************************}
tbitset = class
private
fdata: pbyte;
fdatasize: longint;
public
constructor create(initsize: longint);
constructor create_bytesize(bytesize: longint);
destructor destroy; override;
procedure clear;
procedure grow(nsize: longint);
{ sets a bit }
procedure include(index: longint);
{ clears a bit }
procedure exclude(index: longint);
{ finds an entry, creates one if not exists }
function isset(index: longint): boolean;
procedure addset(aset: tbitset);
procedure subset(aset: tbitset);
property data: pbyte read fdata;
property datasize: longint read fdatasize;
end;
function FPHash(const s:shortstring):LongWord;
function FPHash(P: PChar; Len: Integer): 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)
*****************************************************************************}
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
FillChar(Flist^[FCount], (NewCount-FCount) * sizeof(Pointer), 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;
inc(FCount);
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);
dec(FCount);
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 := Items[0]
else
Result := Nil;
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
If FCount<>0 then
Result := Items[FCount - 1]
else
Result := nil
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;
Procedure QuickSort(FList: PPointerList; L, R : Longint;Compare: TListSortCompare);
var
I, J, P: Longint;
PItem, Q : Pointer;
begin
repeat
I := L;
J := R;
P := (L + R) div 2;
repeat
PItem := FList^[P];
while Compare(PItem, FList^[i]) > 0 do
I := I + 1;
while Compare(PItem, FList^[J]) < 0 do
J := J - 1;
If I <= J then
begin
Q := FList^[I];
Flist^[I] := FList^[J];
FList^[J] := Q;
if P = I then
P := J
else if P = J then
P := I;
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 FPHash(const s:shortstring):LongWord;
Var
p,pmax : pchar;
begin
{$push}
{$q-,r-}
result:=0;
p:=@s[1];
pmax:=@s[length(s)+1];
while (p<pmax) do
begin
result:=LongWord(LongInt(result shl 5) - LongInt(result)) xor LongWord(P^);
inc(p);
end;
{$pop}
end;
function FPHash(P: PChar; Len: Integer): LongWord;
Var
pmax : pchar;
begin
{$push}
{$q-,r-}
result:=0;
pmax:=p+len;
while (p<pmax) do
begin
result:=LongWord(LongInt(result shl 5) - LongInt(result)) xor LongWord(P^);
inc(p);
end;
{$pop}
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;
procedure TFPHashList.Put(Index: Integer; Item: Pointer);
begin
if (Index < 0) or (Index >= FCount) then
RaiseIndexError(Index);
FHashList^[Index].Data:=Item;
end;
function TFPHashList.NameOfIndex(Index: Integer): shortstring;
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.GetNextCollision(Index: Integer): Integer;
begin
Result:=-1;
if ((Index > -1) and (Index < FCount)) then
Result:=FHashList^[Index].NextIndex;
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);
var
power: longint;
begin
{ use a power of two to be able to quickly calculate the hash table index }
if NewCapacity <> 0 then
NewCapacity := nextpowerof2((NewCapacity+(MaxItemsPerHash-1)) div MaxItemsPerHash, power) * MaxItemsPerHash;
if (NewCapacity < FCount) or (NewCapacity > MaxHashListSize) then
Error (SListCapacityError, NewCapacity);
if NewCapacity = FCapacity then
exit;
ReallocMem(FHashList, NewCapacity*SizeOf(THashItem));
FCapacity := NewCapacity;
{ Maybe expand hash also }
if FCapacity>FHashCapacity*MaxItemsPerHash then
SetHashCapacity(FCapacity div MaxItemsPerHash);
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
{ FCapacity is NewCount rounded up to the next power of 2 }
FillChar(FHashList^[FCount], (FCapacity-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);
var
power: longint;
begin
If (NewCapacity < 1) then
Error (SListCapacityError, NewCapacity);
if FHashCapacity=NewCapacity then
exit;
if (NewCapacity<>0) and
not ispowerof2(NewCapacity,power) then
Error(SListCapacityPower2Error, NewCapacity);
FHashCapacity:=NewCapacity;
ReallocMem(FHashTable, FHashCapacity*sizeof(Integer));
FCapacityMask:=(1 shl power)-1;
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:shortstring): 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 and FCapacityMask;
NextIndex:=FHashTable^[HashIndex];
FHashTable^[HashIndex]:=Index;
end;
end;
function TFPHashList.Add(const AName:shortstring;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);
FHashTable^[0]:=-1; // sethashcapacity does not always call rehash
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);
{ Remove from HashList }
dec(FCount);
System.Move (FHashList^[Index+1], FHashList^[Index], (FCount - Index) * Sizeof(THashItem));
{ All indexes are updated, we need to build the hashtable again }
Rehash;
{ Shrink the list if appropriate }
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
begin
FCapacity := FCapacity shr 1;
ReallocMem(FHashList, Sizeof(THashItem) * FCapacity);
end;
end;
function TFPHashList.Remove(Item: Pointer): Integer;
begin
Result := IndexOf(Item);
If Result <> -1 then
Self.Delete(Result);
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;
SetCapacity(FCapacity + IncSize);
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.InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer;
begin
prefetch(AName);
Result:=FHashTable^[AHash and FCapacityMask];
PrevIndex:=-1;
while Result<>-1 do
begin
with FHashList^[Result] do
begin
if assigned(Data) and
(HashValue=AHash) and
(AName=PShortString(@FStrs[StrIndex])^) then
exit;
PrevIndex:=Result;
Result:=NextIndex;
end;
end;
end;
function TFPHashList.Find(const AName:shortstring): 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.FindIndexOf(const AName:shortstring): Integer;
var
PrevIndex : Integer;
begin
Result:=InternalFind(FPHash(AName),AName,PrevIndex);
end;
function TFPHashList.FindWithHash(const AName:shortstring;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:shortstring): 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 and FCapacityMask]:=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:shortstring);
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:shortstring);
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:shortstring);
begin
InternalChangeOwner(HashObjectList,s);
end;
procedure TFPHashObject.Rename(const ANewName:shortstring);
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:shortstring;
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.SetItem(Index: Integer; AObject: TObject);
begin
if OwnsObjects then
TObject(FHashList[Index]).Free;
FHashList[index] := AObject;
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:shortstring;AObject: TObject): Integer;
begin
Result := FHashList.Add(AName,AObject);
end;
function TFPHashObjectList.NameOfIndex(Index: Integer): shortstring;
begin
Result := FHashList.NameOfIndex(Index);
end;
function TFPHashObjectList.HashOfIndex(Index: Integer): LongWord;
begin
Result := FHashList.HashOfIndex(Index);
end;
function TFPHashObjectList.GetNextCollision(Index: Integer): Integer;
begin
Result := FHashList.GetNextCollision(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:shortstring): TObject;
begin
result:=TObject(FHashList.Find(s));
end;
function TFPHashObjectList.FindIndexOf(const s:shortstring): Integer;
begin
result:=FHashList.FindIndexOf(s);
end;
function TFPHashObjectList.FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
begin
Result:=TObject(FHashList.FindWithHash(AName,AHash));
end;
function TFPHashObjectList.Rename(const AOldName,ANewName:shortstring): 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, Next : TLinkedListItem;
begin
NewNode:=FFirst;
while assigned(NewNode) do
begin
Next:=NewNode.Next;
prefetch(next.next);
NewNode.Free;
NewNode:=Next;
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;
{****************************************************************************
TCmdStrListItem
****************************************************************************}
constructor TCmdStrListItem.Create(const s:TCmdStr);
begin
inherited Create;
FPStr:=s;
end;
destructor TCmdStrListItem.Destroy;
begin
FPStr:='';
end;
function TCmdStrListItem.Str:TCmdStr;
begin
Str:=FPStr;
end;
function TCmdStrListItem.GetCopy:TLinkedListItem;
begin
Result:=(inherited GetCopy);
{ TLinkedListItem.GetCopy performs a "move" to copy all data -> reinit
the ansistring, so the refcount is properly increased }
Initialize(TCmdStrListItem(Result).FPStr);
TCmdStrListItem(Result).FPStr:=FPstr;
end;
{****************************************************************************
TCmdStrList
****************************************************************************}
constructor TCmdStrList.Create;
begin
inherited Create;
FDoubles:=true;
end;
constructor TCmdStrList.Create_no_double;
begin
inherited Create;
FDoubles:=false;
end;
procedure TCmdStrList.insert(const s : TCmdStr);
begin
if (s='') or
((not FDoubles) and (find(s)<>nil)) then
exit;
inherited insert(TCmdStrListItem.create(s));
end;
procedure TCmdStrList.concat(const s : TCmdStr);
begin
if (s='') or
((not FDoubles) and (find(s)<>nil)) then
exit;
inherited concat(TCmdStrListItem.create(s));
end;
procedure TCmdStrList.remove(const s : TCmdStr);
var
p : TCmdStrListItem;
begin
if s='' then
exit;
p:=find(s);
if assigned(p) then
begin
inherited Remove(p);
p.Free;
end;
end;
function TCmdStrList.GetFirst : TCmdStr;
var
p : TCmdStrListItem;
begin
p:=TCmdStrListItem(inherited GetFirst);
if p=nil then
GetFirst:=''
else
begin
GetFirst:=p.FPStr;
p.free;
end;
end;
function TCmdStrList.Getlast : TCmdStr;
var
p : TCmdStrListItem;
begin
p:=TCmdStrListItem(inherited Getlast);
if p=nil then
Getlast:=''
else
begin
Getlast:=p.FPStr;
p.free;
end;
end;
function TCmdStrList.FindCase(const s:TCmdStr):TCmdStrListItem;
var
NewNode : TCmdStrListItem;
begin
result:=nil;
if s='' then
exit;
NewNode:=TCmdStrListItem(FFirst);
while assigned(NewNode) do
begin
if NewNode.FPStr=s then
begin
result:=NewNode;
exit;
end;
NewNode:=TCmdStrListItem(NewNode.Next);
end;
end;
function TCmdStrList.Find(const s:TCmdStr):TCmdStrListItem;
var
NewNode : TCmdStrListItem;
begin
result:=nil;
if s='' then
exit;
NewNode:=TCmdStrListItem(FFirst);
while assigned(NewNode) do
begin
if SysUtils.CompareText(s, NewNode.FPStr)=0 then
begin
result:=NewNode;
exit;
end;
NewNode:=TCmdStrListItem(NewNode.Next);
end;
end;
procedure TCmdStrList.InsertItem(item:TCmdStrListItem);
begin
inherited Insert(item);
end;
procedure TCmdStrList.ConcatItem(item:TCmdStrListItem);
begin
inherited Concat(item);
end;
{****************************************************************************
tdynamicarray
****************************************************************************}
constructor tdynamicarray.create(Ablocksize:longword);
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:longword;
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:longword);
var
j : longword;
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:longword);
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:longword);
var
p : pchar;
i,j : longword;
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:longword):longword;
var
p : pchar;
i,j,res : longword;
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:longword);
var
i,left : longword;
begin
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;
{****************************************************************************
thashset
****************************************************************************}
constructor THashSet.Create(InitSize: Integer; OwnKeys, OwnObjects: Boolean);
var
I: Integer;
begin
inherited Create;
FOwnsObjects := OwnObjects;
FOwnsKeys := OwnKeys;
I := 64;
while I < InitSize do I := I shl 1;
FBucketCount := I;
FBucket := AllocMem(I * sizeof(PHashSetItem));
end;
destructor THashSet.Destroy;
begin
Clear;
FreeMem(FBucket);
inherited Destroy;
end;
procedure THashSet.Clear;
var
I: Integer;
item, next: PHashSetItem;
begin
for I := 0 to FBucketCount-1 do
begin
item := FBucket[I];
while Assigned(item) do
begin
next := item^.Next;
if FOwnsObjects then
item^.Data.Free;
if FOwnsKeys then
FreeMem(item^.Key);
Dispose(item);
item := next;
end;
end;
FillChar(FBucket^, FBucketCount * sizeof(PHashSetItem), 0);
end;
function THashSet.Find(Key: Pointer; KeyLen: Integer): PHashSetItem;
var
Dummy: Boolean;
begin
Result := Lookup(Key, KeyLen, Dummy, False);
end;
function THashSet.FindOrAdd(Key: Pointer; KeyLen: Integer;
var Found: Boolean): PHashSetItem;
begin
Result := Lookup(Key, KeyLen, Found, True);
end;
function THashSet.FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;
var
Dummy: Boolean;
begin
Result := Lookup(Key, KeyLen, Dummy, True);
end;
function THashSet.Get(Key: Pointer; KeyLen: Integer): TObject;
var
e: PHashSetItem;
Dummy: Boolean;
begin
e := Lookup(Key, KeyLen, Dummy, False);
if Assigned(e) then
Result := e^.Data
else
Result := nil;
end;
function THashSet.Lookup(Key: Pointer; KeyLen: Integer;
var Found: Boolean; CanCreate: Boolean): PHashSetItem;
var
Entry: PPHashSetItem;
h: LongWord;
begin
h := FPHash(Key, KeyLen);
Entry := @FBucket[h mod FBucketCount];
while Assigned(Entry^) and
not ((Entry^^.HashValue = h) and (Entry^^.KeyLength = KeyLen) and
(CompareByte(Entry^^.Key^, Key^, KeyLen) = 0)) do
Entry := @Entry^^.Next;
Found := Assigned(Entry^);
if Found or (not CanCreate) then
begin
Result := Entry^;
Exit;
end;
if FCount > FBucketCount then { arbitrary limit, probably too high }
begin
{ rehash and repeat search }
Resize(FBucketCount * 2);
Result := Lookup(Key, KeyLen, Found, CanCreate);
end
else
begin
New(Result);
if FOwnsKeys then
begin
GetMem(Result^.Key, KeyLen);
Move(Key^, Result^.Key^, KeyLen);
end
else
Result^.Key := Key;
Result^.KeyLength := KeyLen;
Result^.HashValue := h;
Result^.Data := nil;
Result^.Next := nil;
Inc(FCount);
Entry^ := Result;
end;
end;
procedure THashSet.Resize(NewCapacity: LongWord);
var
p, chain: PPHashSetItem;
i: Integer;
e, n: PHashSetItem;
begin
p := AllocMem(NewCapacity * sizeof(PHashSetItem));
for i := 0 to FBucketCount-1 do
begin
e := FBucket[i];
while Assigned(e) do
begin
chain := @p[e^.HashValue mod NewCapacity];
n := e^.Next;
e^.Next := chain^;
chain^ := e;
e := n;
end;
end;
FBucketCount := NewCapacity;
FreeMem(FBucket);
FBucket := p;
end;
function THashSet.Remove(Entry: PHashSetItem): Boolean;
var
chain: PPHashSetItem;
begin
chain := @FBucket[Entry^.HashValue mod FBucketCount];
while Assigned(chain^) do
begin
if chain^ = Entry then
begin
chain^ := Entry^.Next;
if FOwnsObjects then
Entry^.Data.Free;
if FOwnsKeys then
FreeMem(Entry^.Key);
Dispose(Entry);
Dec(FCount);
Result := True;
Exit;
end;
chain := @chain^^.Next;
end;
Result := False;
end;
{****************************************************************************
tbitset
****************************************************************************}
constructor tbitset.create(initsize: longint);
begin
create_bytesize((initsize+7) div 8);
end;
constructor tbitset.create_bytesize(bytesize: longint);
begin
fdatasize:=bytesize;
getmem(fdata,fdataSize);
clear;
end;
destructor tbitset.destroy;
begin
freemem(fdata,fdatasize);
inherited destroy;
end;
procedure tbitset.clear;
begin
fillchar(fdata^,fdatasize,0);
end;
procedure tbitset.grow(nsize: longint);
begin
reallocmem(fdata,nsize);
fillchar(fdata[fdatasize],nsize-fdatasize,0);
fdatasize:=nsize;
end;
procedure tbitset.include(index: longint);
var
dataindex: longint;
begin
{ don't use bitpacked array, not endian-safe }
dataindex:=index shr 3;
if (dataindex>=datasize) then
grow(dataindex+16);
fdata[dataindex]:=fdata[dataindex] or (1 shl (index and 7));
end;
procedure tbitset.exclude(index: longint);
var
dataindex: longint;
begin
dataindex:=index shr 3;
if (dataindex>=datasize) then
exit;
fdata[dataindex]:=fdata[dataindex] and not(1 shl (index and 7));
end;
function tbitset.isset(index: longint): boolean;
var
dataindex: longint;
begin
dataindex:=index shr 3;
result:=
(dataindex<datasize) and
(((fdata[dataindex] shr (index and 7)) and 1)<>0);
end;
procedure tbitset.addset(aset: tbitset);
var
i: longint;
begin
if (aset.datasize>datasize) then
grow(aset.datasize);
for i:=0 to aset.datasize-1 do
fdata[i]:=fdata[i] or aset.data[i];
end;
procedure tbitset.subset(aset: tbitset);
var
i: longint;
begin
for i:=0 to min(datasize,aset.datasize)-1 do
fdata[i]:=fdata[i] and not(aset.data[i]);
end;
end.
Reference in New Issue View Git Blame Copy Permalink