mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 19:28:38 +02:00
2115 lines
59 KiB
ObjectPascal
2115 lines
59 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2006 by Micha Nelissen
|
|
member of the Free Pascal development team
|
|
|
|
It contains the Free Pascal generics library
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
{$mode objfpc}
|
|
|
|
{$define FGLINLINE}
|
|
|
|
{$ifdef FGLINLINE}
|
|
{$inline on}
|
|
{$endif FGLINLINE}
|
|
|
|
{$IFNDEF FPC_DOTTEDUNITS}
|
|
unit fgl;
|
|
{$ENDIF FPC_DOTTEDUNITS}
|
|
|
|
interface
|
|
|
|
{$IFDEF FPC_DOTTEDUNITS}
|
|
uses
|
|
System.Types, System.SysUtils, System.SortBase;
|
|
{$ELSE FPC_DOTTEDUNITS}
|
|
uses
|
|
types, sysutils, sortbase;
|
|
{$ENDIF FPC_DOTTEDUNITS}
|
|
|
|
const
|
|
MaxListSize = Maxint div 16;
|
|
|
|
type
|
|
EListError = class(Exception);
|
|
|
|
TFPSList = class;
|
|
TFPSListCompareFunc = function(Key1, Key2: Pointer): Integer of object;
|
|
|
|
{ TFPSList }
|
|
|
|
TFPSList = class(TObject)
|
|
protected
|
|
FList: PByte;
|
|
FCount: Integer;
|
|
FCapacity: Integer; { list has room for capacity+1 items, contains room for a temporary item }
|
|
FItemSize: Integer;
|
|
procedure CopyItem(Src, Dest: Pointer); virtual;
|
|
procedure CopyItems(Src, Dest: Pointer; aCount : Integer); virtual;
|
|
procedure Deref(Item: Pointer); virtual; overload;
|
|
procedure Deref(FromIndex, ToIndex: Integer); overload;
|
|
function Get(Index: Integer): Pointer;
|
|
procedure InternalExchange(Index1, Index2: Integer);
|
|
function InternalGet(Index: Integer): Pointer; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure InternalPut(Index: Integer; NewItem: Pointer);
|
|
procedure Put(Index: Integer; Item: Pointer);
|
|
procedure QuickSort(L, R: Integer; Compare: TFPSListCompareFunc);
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
procedure SetCount(NewCount: Integer);
|
|
procedure RaiseIndexError(Index : Integer);
|
|
property InternalItems[Index: Integer]: Pointer read InternalGet write InternalPut;
|
|
function GetLast: Pointer;
|
|
procedure SetLast(const Value: Pointer);
|
|
function GetFirst: Pointer;
|
|
procedure SetFirst(const Value: Pointer);
|
|
Procedure CheckIndex(AIndex : Integer); inline;
|
|
public
|
|
constructor Create(AItemSize: Integer = sizeof(Pointer));
|
|
destructor Destroy; override;
|
|
class Function ItemIsManaged : Boolean; virtual;
|
|
function Add(Item: Pointer): Integer;
|
|
procedure Clear;
|
|
procedure Delete(Index: Integer);
|
|
procedure DeleteRange(IndexFrom, IndexTo : Integer);
|
|
class procedure Error(const Msg: string; Data: PtrInt);
|
|
procedure Exchange(Index1, Index2: Integer);
|
|
function Expand: TFPSList;
|
|
procedure Extract(Item: Pointer; ResultPtr: Pointer);
|
|
function IndexOf(Item: Pointer): Integer;
|
|
procedure Insert(Index: Integer; Item: Pointer);
|
|
function Insert(Index: Integer): Pointer;
|
|
procedure Move(CurIndex, NewIndex: Integer);
|
|
procedure Assign(Obj: TFPSList);
|
|
procedure AddList(Obj: TFPSList);
|
|
function Remove(Item: Pointer): Integer;
|
|
procedure Pack;
|
|
procedure Sort(Compare: TFPSListCompareFunc);
|
|
procedure Sort(Compare: TFPSListCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
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 ItemSize: Integer read FItemSize;
|
|
property List: PByte read FList;
|
|
property First: Pointer read GetFirst write SetFirst;
|
|
property Last: Pointer read GetLast write SetLast;
|
|
end;
|
|
|
|
const
|
|
{$ifdef cpu16}
|
|
MaxGListSize = {MaxInt div} 1024 deprecated;
|
|
{$else cpu16}
|
|
MaxGListSize = MaxInt div 1024 deprecated;
|
|
{$endif cpu16}
|
|
|
|
type
|
|
generic TFPGListEnumerator<T> = class(TObject)
|
|
protected
|
|
FList: TFPSList;
|
|
FPosition: Integer;
|
|
function GetCurrent: T;
|
|
public
|
|
constructor Create(AList: TFPSList);
|
|
function MoveNext: Boolean;
|
|
property Current: T read GetCurrent;
|
|
end;
|
|
|
|
{ TFPGList }
|
|
|
|
generic TFPGList<T> = class(TFPSList)
|
|
private
|
|
type
|
|
TCompareFunc = function(const Item1, Item2: T): Integer;
|
|
PT = ^T;
|
|
TTypeList = PT;
|
|
PTypeList = ^TTypeList;
|
|
protected
|
|
var
|
|
FOnCompare: TCompareFunc;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
function Get(Index: Integer): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetList: PTypeList; {$ifdef FGLINLINE} inline; {$endif}
|
|
function ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
procedure Put(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetLast: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetLast(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetFirst: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetFirst(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
public
|
|
Type
|
|
TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>;
|
|
constructor Create;
|
|
|
|
class Function ItemIsManaged : Boolean; override;
|
|
function Add(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Extract(const Item: T): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
property First: T read GetFirst write SetFirst;
|
|
function GetEnumerator: TFPGListEnumeratorSpec; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const Item: T): Integer;
|
|
procedure Insert(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
property Last: T read GetLast write SetLast;
|
|
procedure Assign(Source: TFPGList);
|
|
procedure AddList(Source: TFPGList);
|
|
function Remove(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure Sort(Compare: TCompareFunc);
|
|
procedure Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
property Items[Index: Integer]: T read Get write Put; default;
|
|
property List: PTypeList read GetList;
|
|
end;
|
|
|
|
generic TFPGObjectList<T: TObject> = class(TFPSList)
|
|
private
|
|
type
|
|
TCompareFunc = function(const Item1, Item2: T): Integer;
|
|
PT = ^T;
|
|
TTypeList = PT;
|
|
PTypeList = ^TTypeList;
|
|
TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>;
|
|
protected
|
|
var
|
|
FOnCompare: TCompareFunc;
|
|
FFreeObjects: Boolean;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
function Get(Index: Integer): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetList: PTypeList; {$ifdef FGLINLINE} inline; {$endif}
|
|
function ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
procedure Put(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetLast: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetLast(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetFirst: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetFirst(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
public
|
|
constructor Create(FreeObjects: Boolean = True);
|
|
function Add(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Extract(const Item: T): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
property First: T read GetFirst write SetFirst;
|
|
function GetEnumerator: TFPGListEnumeratorSpec; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const Item: T): Integer;
|
|
procedure Insert(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
property Last: T read GetLast write SetLast;
|
|
procedure AddList(Source: TFPGObjectList);
|
|
procedure Assign(Source: TFPGObjectList);
|
|
function Remove(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure Sort(Compare: TCompareFunc);
|
|
procedure Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
property Items[Index: Integer]: T read Get write Put; default;
|
|
property List: PTypeList read GetList;
|
|
property FreeObjects: Boolean read FFreeObjects write FFreeObjects;
|
|
end;
|
|
|
|
generic TFPGInterfacedObjectList<T> = class(TFPSList)
|
|
private
|
|
type
|
|
TCompareFunc = function(const Item1, Item2: T): Integer;
|
|
PT = ^T;
|
|
TTypeList = PT;
|
|
PTypeList = ^TTypeList;
|
|
TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>;
|
|
protected
|
|
var
|
|
FOnCompare: TCompareFunc;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
function Get(Index: Integer): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetList: PTypeList; {$ifdef FGLINLINE} inline; {$endif}
|
|
function ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
procedure Put(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetLast: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetLast(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetFirst: T; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetFirst(const Value: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
public
|
|
constructor Create;
|
|
function Add(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Extract(const Item: T): T; {$ifdef FGLINLINE} inline; {$endif}
|
|
property First: T read GetFirst write SetFirst;
|
|
function GetEnumerator: TFPGListEnumeratorSpec; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const Item: T): Integer;
|
|
procedure Insert(Index: Integer; const Item: T); {$ifdef FGLINLINE} inline; {$endif}
|
|
property Last: T read GetLast write SetLast;
|
|
procedure Assign(Source: TFPGInterfacedObjectList);
|
|
procedure AddList(Source: TFPGInterfacedObjectList);
|
|
function Remove(const Item: T): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure Sort(Compare: TCompareFunc);
|
|
procedure Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
property Items[Index: Integer]: T read Get write Put; default;
|
|
property List: PTypeList read GetList;
|
|
end;
|
|
|
|
TFPSMap = class(TFPSList)
|
|
private
|
|
FKeySize: Integer;
|
|
FDataSize: Integer;
|
|
FDuplicates: TDuplicates;
|
|
FSorted: Boolean;
|
|
FOnKeyPtrCompare: TFPSListCompareFunc;
|
|
FOnDataPtrCompare: TFPSListCompareFunc;
|
|
procedure SetSorted(Value: Boolean);
|
|
protected
|
|
function BinaryCompareKey(Key1, Key2: Pointer): Integer;
|
|
function BinaryCompareData(Data1, Data2: Pointer): Integer;
|
|
procedure SetOnKeyPtrCompare(Proc: TFPSListCompareFunc);
|
|
procedure SetOnDataPtrCompare(Proc: TFPSListCompareFunc);
|
|
procedure InitOnPtrCompare; virtual;
|
|
procedure CopyKey(Src, Dest: Pointer); virtual;
|
|
procedure CopyData(Src, Dest: Pointer); virtual;
|
|
function GetKey(Index: Integer): Pointer;
|
|
function GetKeyData(AKey: Pointer): Pointer;
|
|
function GetData(Index: Integer): Pointer;
|
|
function LinearIndexOf(AKey: Pointer): Integer;
|
|
procedure PutKey(Index: Integer; AKey: Pointer);
|
|
procedure PutKeyData(AKey: Pointer; NewData: Pointer);
|
|
procedure PutData(Index: Integer; AData: Pointer);
|
|
public
|
|
constructor Create(AKeySize: Integer = sizeof(Pointer);
|
|
ADataSize: integer = sizeof(Pointer));
|
|
function Add(AKey, AData: Pointer): Integer;
|
|
function Add(AKey: Pointer): Integer;
|
|
function Find(AKey: Pointer; out Index: Integer): Boolean;
|
|
function IndexOf(AKey: Pointer): Integer;
|
|
function IndexOfData(AData: Pointer): Integer;
|
|
function Insert(Index: Integer): Pointer;
|
|
procedure Insert(Index: Integer; out AKey, AData: Pointer);
|
|
procedure InsertKey(Index: Integer; AKey: Pointer);
|
|
procedure InsertKeyData(Index: Integer; AKey, AData: Pointer);
|
|
function Remove(AKey: Pointer): Integer;
|
|
procedure Sort;
|
|
procedure Sort(SortingAlgorithm: PSortingAlgorithm);
|
|
property Duplicates: TDuplicates read FDuplicates write FDuplicates;
|
|
property KeySize: Integer read FKeySize;
|
|
property DataSize: Integer read FDataSize;
|
|
property Keys[Index: Integer]: Pointer read GetKey write PutKey;
|
|
property Data[Index: Integer]: Pointer read GetData write PutData;
|
|
property KeyData[Key: Pointer]: Pointer read GetKeyData write PutKeyData; default;
|
|
property Sorted: Boolean read FSorted write SetSorted;
|
|
property OnPtrCompare: TFPSListCompareFunc read FOnKeyPtrCompare write SetOnKeyPtrCompare; //deprecated;
|
|
property OnKeyPtrCompare: TFPSListCompareFunc read FOnKeyPtrCompare write SetOnKeyPtrCompare;
|
|
property OnDataPtrCompare: TFPSListCompareFunc read FOnDataPtrCompare write SetOnDataPtrCompare;
|
|
end;
|
|
|
|
generic TFPGMap<TKey, TData> = class(TFPSMap)
|
|
private
|
|
type
|
|
TKeyCompareFunc = function(const Key1, Key2: TKey): Integer;
|
|
TDataCompareFunc = function(const Data1, Data2: TData): Integer;
|
|
PKey = ^TKey;
|
|
// unsed PData = ^TData;
|
|
protected
|
|
var
|
|
FOnKeyCompare: TKeyCompareFunc;
|
|
FOnDataCompare: TDataCompareFunc;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure CopyKey(Src, Dest: Pointer); override;
|
|
procedure CopyData(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
procedure InitOnPtrCompare; override;
|
|
function GetKey(Index: Integer): TKey; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetKeyData(const AKey: TKey): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetData(Index: Integer): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function KeyCompare(Key1, Key2: Pointer): Integer;
|
|
function KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
//function DataCompare(Data1, Data2: Pointer): Integer;
|
|
function DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
procedure PutKey(Index: Integer; const NewKey: TKey); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutKeyData(const AKey: TKey; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutData(Index: Integer; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
procedure SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
public
|
|
constructor Create;
|
|
function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Add(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOfData(const AData: TData): Integer;
|
|
procedure InsertKey(Index: Integer; const AKey: TKey);
|
|
procedure InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
function Remove(const AKey: TKey): Integer;
|
|
property Keys[Index: Integer]: TKey read GetKey write PutKey;
|
|
property Data[Index: Integer]: TData read GetData write PutData;
|
|
property KeyData[const AKey: TKey]: TData read GetKeyData write PutKeyData; default;
|
|
property OnCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare; //deprecated;
|
|
property OnKeyCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare;
|
|
property OnDataCompare: TDataCompareFunc read FOnDataCompare write SetOnDataCompare;
|
|
end;
|
|
|
|
generic TFPGMapObject<TKey; TData: TObject> = class(TFPSMap)
|
|
private
|
|
type
|
|
TKeyCompareFunc = function(const Key1, Key2: TKey): Integer;
|
|
TDataCompareFunc = function(const Data1, Data2: TData): Integer;
|
|
PKey = ^TKey;
|
|
// unsed PData = ^TData;
|
|
protected
|
|
var
|
|
FOnKeyCompare: TKeyCompareFunc;
|
|
FOnDataCompare: TDataCompareFunc;
|
|
FFreeObjects: Boolean;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure CopyKey(Src, Dest: Pointer); override;
|
|
procedure CopyData(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
procedure InitOnPtrCompare; override;
|
|
function GetKey(Index: Integer): TKey; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetKeyData(const AKey: TKey): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetData(Index: Integer): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function KeyCompare(Key1, Key2: Pointer): Integer;
|
|
function KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
//function DataCompare(Data1, Data2: Pointer): Integer;
|
|
function DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
procedure PutKey(Index: Integer; const NewKey: TKey); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutKeyData(const AKey: TKey; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutData(Index: Integer; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
procedure SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
public
|
|
constructor Create(AFreeObjects: Boolean);
|
|
constructor Create;
|
|
function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Add(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOfData(const AData: TData): Integer;
|
|
procedure InsertKey(Index: Integer; const AKey: TKey);
|
|
procedure InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
function Remove(const AKey: TKey): Integer;
|
|
property Keys[Index: Integer]: TKey read GetKey write PutKey;
|
|
property Data[Index: Integer]: TData read GetData write PutData;
|
|
property KeyData[const AKey: TKey]: TData read GetKeyData write PutKeyData; default;
|
|
property OnCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare; //deprecated;
|
|
property OnKeyCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare;
|
|
property OnDataCompare: TDataCompareFunc read FOnDataCompare write SetOnDataCompare;
|
|
end;
|
|
|
|
generic TFPGMapInterfacedObjectData<TKey, TData> = class(TFPSMap)
|
|
private
|
|
type
|
|
TKeyCompareFunc = function(const Key1, Key2: TKey): Integer;
|
|
TDataCompareFunc = function(const Data1, Data2: TData): Integer;
|
|
PKey = ^TKey;
|
|
// unsed PData = ^TData;
|
|
protected
|
|
var
|
|
FOnKeyCompare: TKeyCompareFunc;
|
|
FOnDataCompare: TDataCompareFunc;
|
|
procedure CopyItem(Src, Dest: Pointer); override;
|
|
procedure CopyKey(Src, Dest: Pointer); override;
|
|
procedure CopyData(Src, Dest: Pointer); override;
|
|
procedure Deref(Item: Pointer); override;
|
|
procedure InitOnPtrCompare; override;
|
|
function GetKey(Index: Integer): TKey; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetKeyData(const AKey: TKey): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function GetData(Index: Integer): TData; {$ifdef FGLINLINE} inline; {$endif}
|
|
function KeyCompare(Key1, Key2: Pointer): Integer;
|
|
function KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
//function DataCompare(Data1, Data2: Pointer): Integer;
|
|
function DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
procedure PutKey(Index: Integer; const NewKey: TKey); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutKeyData(const AKey: TKey; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure PutData(Index: Integer; const NewData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
procedure SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
public
|
|
constructor Create;
|
|
function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Add(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef FGLINLINE} inline; {$endif}
|
|
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOf(const AKey: TKey): Integer; {$ifdef FGLINLINE} inline; {$endif}
|
|
function IndexOfData(const AData: TData): Integer;
|
|
procedure InsertKey(Index: Integer; const AKey: TKey);
|
|
procedure InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
function Remove(const AKey: TKey): Integer;
|
|
property Keys[Index: Integer]: TKey read GetKey write PutKey;
|
|
property Data[Index: Integer]: TData read GetData write PutData;
|
|
property KeyData[const AKey: TKey]: TData read GetKeyData write PutKeyData; default;
|
|
property OnCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare; //deprecated;
|
|
property OnKeyCompare: TKeyCompareFunc read FOnKeyCompare write SetOnKeyCompare;
|
|
property OnDataCompare: TDataCompareFunc read FOnDataCompare write SetOnDataCompare;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{$IFDEF FPC_DOTTEDUNITS}
|
|
uses
|
|
System.RtlConsts;
|
|
{$ELSE FPC_DOTTEDUNITS}
|
|
uses
|
|
rtlconsts;
|
|
{$ENDIF FPC_DOTTEDUNITS}
|
|
|
|
{****************************************************************************
|
|
TFPSList
|
|
****************************************************************************}
|
|
|
|
constructor TFPSList.Create(AItemSize: integer);
|
|
begin
|
|
inherited Create;
|
|
FItemSize := AItemSize;
|
|
end;
|
|
|
|
destructor TFPSList.Destroy;
|
|
begin
|
|
Clear;
|
|
// Clear() does not clear the whole list; there is always a single temp entry
|
|
// at the end which is never freed. Take care of that one here.
|
|
FreeMem(FList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFPSList.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
System.Move(Src^, Dest^, FItemSize);
|
|
end;
|
|
|
|
procedure TFPSList.CopyItems(Src, Dest: Pointer; aCount: Integer);
|
|
begin
|
|
System.Move(Src^, Dest^, FItemSize*aCount);
|
|
end;
|
|
|
|
procedure TFPSList.RaiseIndexError(Index : Integer);
|
|
begin
|
|
Error(SListIndexError, Index);
|
|
end;
|
|
|
|
function TFPSList.InternalGet(Index: Integer): Pointer;
|
|
begin
|
|
Result:=FList+Index*ItemSize;
|
|
end;
|
|
|
|
procedure TFPSList.InternalPut(Index: Integer; NewItem: Pointer);
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
ListItem := InternalItems[Index];
|
|
CopyItem(NewItem, ListItem);
|
|
end;
|
|
|
|
function TFPSList.Get(Index: Integer): Pointer;
|
|
begin
|
|
CheckIndex(Index);
|
|
Result := InternalItems[Index];
|
|
end;
|
|
|
|
procedure TFPSList.Put(Index: Integer; Item: Pointer);
|
|
var p : Pointer;
|
|
begin
|
|
CheckIndex(Index);
|
|
p:=InternalItems[Index];
|
|
if assigned(p) then
|
|
DeRef(p);
|
|
InternalItems[Index] := Item;
|
|
end;
|
|
|
|
procedure TFPSList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
|
|
Error(SListCapacityError, NewCapacity);
|
|
if NewCapacity = FCapacity then
|
|
exit;
|
|
ReallocMem(FList, (NewCapacity+1) * FItemSize);
|
|
FillChar(InternalItems[FCapacity]^, (NewCapacity+1-FCapacity) * FItemSize, #0);
|
|
FCapacity := NewCapacity;
|
|
end;
|
|
|
|
procedure TFPSList.Deref(Item: Pointer);
|
|
begin
|
|
end;
|
|
|
|
procedure TFPSList.Deref(FromIndex, ToIndex: Integer);
|
|
var
|
|
ListItem, ListItemLast: Pointer;
|
|
begin
|
|
ListItem := InternalItems[FromIndex];
|
|
ListItemLast := InternalItems[ToIndex];
|
|
repeat
|
|
Deref(ListItem);
|
|
if ListItem = ListItemLast then
|
|
break;
|
|
ListItem := PByte(ListItem) + ItemSize;
|
|
until false;
|
|
end;
|
|
|
|
procedure TFPSList.SetCount(NewCount: Integer);
|
|
begin
|
|
if (NewCount < 0) or (NewCount > MaxListSize) then
|
|
Error(SListCountError, NewCount);
|
|
if NewCount > FCapacity then
|
|
SetCapacity(NewCount);
|
|
if NewCount > FCount then
|
|
FillByte(InternalItems[FCount]^, (NewCount-FCount) * FItemSize, 0)
|
|
else if NewCount < FCount then
|
|
Deref(NewCount, FCount-1);
|
|
FCount := NewCount;
|
|
end;
|
|
|
|
function TFPSList.Add(Item: Pointer): Integer;
|
|
begin
|
|
if FCount = FCapacity then
|
|
Self.Expand;
|
|
CopyItem(Item, InternalItems[FCount]);
|
|
Result := FCount;
|
|
Inc(FCount);
|
|
end;
|
|
|
|
procedure TFPSList.CheckIndex(AIndex : Integer);
|
|
|
|
begin
|
|
if (AIndex < 0) or (AIndex >= FCount) then
|
|
Error(SListIndexError, AIndex);
|
|
end;
|
|
|
|
class function TFPSList.ItemIsManaged: Boolean;
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
|
|
procedure TFPSList.Clear;
|
|
begin
|
|
if Assigned(FList) then
|
|
begin
|
|
SetCount(0);
|
|
SetCapacity(0);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPSList.Delete(Index: Integer);
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
CheckIndex(Index);
|
|
Dec(FCount);
|
|
ListItem := InternalItems[Index];
|
|
Deref(ListItem);
|
|
System.Move(InternalItems[Index+1]^, ListItem^, (FCount - Index) * FItemSize);
|
|
// Shrink the list if appropriate
|
|
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
|
begin
|
|
FCapacity := FCapacity shr 1;
|
|
ReallocMem(FList, (FCapacity+1) * FItemSize);
|
|
end;
|
|
{ Keep the ending of the list filled with zeros, don't leave garbage data
|
|
there. Otherwise, we could accidentally have there a copy of some item
|
|
on the list, and accidentally Deref it too soon.
|
|
See http://bugs.freepascal.org/view.php?id=20005. }
|
|
FillChar(InternalItems[FCount]^, FItemSize, #0);
|
|
end;
|
|
|
|
procedure TFPSList.DeleteRange(IndexFrom, IndexTo : Integer);
|
|
var
|
|
ListItem: Pointer;
|
|
I: Integer;
|
|
OldCnt : Integer;
|
|
begin
|
|
CheckIndex(IndexTo);
|
|
CheckIndex(IndexFrom);
|
|
OldCnt:=FCount;
|
|
Dec(FCount,IndexTo-IndexFrom+1);
|
|
For I :=IndexFrom To Indexto Do
|
|
begin
|
|
ListItem := InternalItems[I];
|
|
Deref(ListItem);
|
|
end;
|
|
System.Move(InternalItems[IndexTo+1]^, InternalItems[IndexFrom]^, (OldCnt - IndexTo-1) * FItemSize);
|
|
// Shrink the list if appropriate
|
|
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
|
begin
|
|
FCapacity := FCapacity shr 1;
|
|
ReallocMem(FList, (FCapacity+1) * FItemSize);
|
|
end;
|
|
{ Keep the ending of the list filled with zeros, don't leave garbage data
|
|
there. Otherwise, we could accidentally have there a copy of some item
|
|
on the list, and accidentally Deref it too soon.
|
|
See http://bugs.freepascal.org/view.php?id=20005. }
|
|
FillChar(InternalItems[FCount]^, (FCapacity+1-FCount) * FItemSize, #0);
|
|
end;
|
|
|
|
procedure TFPSList.Extract(Item: Pointer; ResultPtr: Pointer);
|
|
var
|
|
i : Integer;
|
|
ListItemPtr : Pointer;
|
|
begin
|
|
i := IndexOf(Item);
|
|
if i >= 0 then
|
|
begin
|
|
ListItemPtr := InternalItems[i];
|
|
System.Move(ListItemPtr^, ResultPtr^, FItemSize);
|
|
{ fill with zeros, to avoid freeing/decreasing reference on following Delete }
|
|
System.FillByte(ListItemPtr^, FItemSize, 0);
|
|
Delete(i);
|
|
end else
|
|
System.FillByte(ResultPtr^, FItemSize, 0);
|
|
end;
|
|
|
|
class procedure TFPSList.Error(const Msg: string; Data: PtrInt);
|
|
begin
|
|
raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame);
|
|
end;
|
|
|
|
procedure TFPSList.Exchange(Index1, Index2: Integer);
|
|
begin
|
|
CheckIndex(Index1);
|
|
CheckIndex(Index2);
|
|
InternalExchange(Index1, Index2);
|
|
end;
|
|
|
|
procedure TFPSList.InternalExchange(Index1, Index2: Integer);
|
|
begin
|
|
System.Move(InternalItems[Index1]^, InternalItems[FCapacity]^, FItemSize);
|
|
System.Move(InternalItems[Index2]^, InternalItems[Index1]^, FItemSize);
|
|
System.Move(InternalItems[FCapacity]^, InternalItems[Index2]^, FItemSize);
|
|
end;
|
|
|
|
function TFPSList.Expand: TFPSList;
|
|
var
|
|
IncSize : Longint;
|
|
begin
|
|
Result := Self;
|
|
if FCount < FCapacity then
|
|
exit;
|
|
if FCapacity > 127 then
|
|
IncSize:=FCapacity shr 2
|
|
else if FCapacity > 8 then
|
|
IncSize := 16
|
|
else if FCapacity > 3 then
|
|
IncSize := 8
|
|
else
|
|
IncSize := 4;
|
|
// If we were at max capacity already, force error.
|
|
If IncSize<=0 then
|
|
IncSize:=1; // Will trigger error
|
|
SetCapacity(FCapacity + IncSize);
|
|
end;
|
|
|
|
function TFPSList.GetFirst: Pointer;
|
|
begin
|
|
If FCount = 0 then
|
|
Result := Nil
|
|
else
|
|
Result := InternalItems[0];
|
|
end;
|
|
|
|
procedure TFPSList.SetFirst(const Value: Pointer);
|
|
begin
|
|
Put(0, Value);
|
|
end;
|
|
|
|
function TFPSList.IndexOf(Item: Pointer): Integer;
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
Result := 0;
|
|
ListItem := First;
|
|
while (Result < FCount) and (CompareByte(ListItem^, Item^, FItemSize) <> 0) do
|
|
begin
|
|
Inc(Result);
|
|
ListItem := PByte(ListItem)+FItemSize;
|
|
end;
|
|
if Result = FCount then Result := -1;
|
|
end;
|
|
|
|
function TFPSList.Insert(Index: Integer): Pointer;
|
|
begin
|
|
if (Index < 0) or (Index > FCount) then
|
|
Error(SListIndexError, Index);
|
|
if FCount = FCapacity then Self.Expand;
|
|
Result := InternalItems[Index];
|
|
if Index<FCount then
|
|
begin
|
|
System.Move(Result^, (Result+FItemSize)^, (FCount - Index) * FItemSize);
|
|
{ clear for compiler assisted types }
|
|
System.FillByte(Result^, FItemSize, 0);
|
|
end;
|
|
Inc(FCount);
|
|
end;
|
|
|
|
procedure TFPSList.Insert(Index: Integer; Item: Pointer);
|
|
begin
|
|
CopyItem(Item, Insert(Index));
|
|
end;
|
|
|
|
function TFPSList.GetLast: Pointer;
|
|
begin
|
|
if FCount = 0 then
|
|
Result := nil
|
|
else
|
|
Result := InternalItems[FCount - 1];
|
|
end;
|
|
|
|
procedure TFPSList.SetLast(const Value: Pointer);
|
|
begin
|
|
Put(FCount - 1, Value);
|
|
end;
|
|
|
|
procedure TFPSList.Move(CurIndex, NewIndex: Integer);
|
|
var
|
|
CurItem, NewItem, TmpItem, Src, Dest: Pointer;
|
|
MoveCount: Integer;
|
|
begin
|
|
CheckIndex(CurIndex);
|
|
CheckIndex(NewIndex);
|
|
if CurIndex = NewIndex then
|
|
exit;
|
|
CurItem := InternalItems[CurIndex];
|
|
NewItem := InternalItems[NewIndex];
|
|
TmpItem := InternalItems[FCapacity];
|
|
System.Move(CurItem^, TmpItem^, FItemSize);
|
|
if NewIndex > CurIndex then
|
|
begin
|
|
Src := InternalItems[CurIndex+1];
|
|
Dest := CurItem;
|
|
MoveCount := NewIndex - CurIndex;
|
|
end else begin
|
|
Src := NewItem;
|
|
Dest := InternalItems[NewIndex+1];
|
|
MoveCount := CurIndex - NewIndex;
|
|
end;
|
|
System.Move(Src^, Dest^, MoveCount * FItemSize);
|
|
System.Move(TmpItem^, NewItem^, FItemSize);
|
|
end;
|
|
|
|
function TFPSList.Remove(Item: Pointer): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result <> -1 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
const LocalThreshold = 64;
|
|
|
|
procedure TFPSList.Pack;
|
|
var
|
|
LItemSize : integer;
|
|
NewCount,
|
|
i : integer;
|
|
pdest,
|
|
psrc : Pointer;
|
|
localnul : array[0..LocalThreshold-1] of byte;
|
|
pnul : pointer;
|
|
begin
|
|
LItemSize:=FItemSize;
|
|
pnul:=@localnul;
|
|
if LItemSize>Localthreshold then
|
|
getmem(pnul,LItemSize);
|
|
fillchar(pnul^,LItemSize,#0);
|
|
NewCount:=0;
|
|
psrc:=First;
|
|
pdest:=psrc;
|
|
|
|
For I:=0 To FCount-1 Do
|
|
begin
|
|
if not CompareMem(psrc,pnul,LItemSize) then
|
|
begin
|
|
System.Move(psrc^, pdest^, LItemSize);
|
|
inc(pdest,LItemSIze);
|
|
inc(NewCount);
|
|
end
|
|
else
|
|
deref(psrc);
|
|
inc(psrc,LitemSize);
|
|
end;
|
|
if LItemSize>Localthreshold then
|
|
FreeMem(pnul,LItemSize);
|
|
|
|
FCount:=NewCount;
|
|
end;
|
|
|
|
procedure TFPSList.Sort(Compare: TFPSListCompareFunc);
|
|
begin
|
|
Sort(Compare, {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}SortBase.DefaultSortingAlgorithm);
|
|
end;
|
|
|
|
type
|
|
PFPSList_Sort_Comparer_Context = ^TFPSList_Sort_Comparer_Context;
|
|
TFPSList_Sort_Comparer_Context = record
|
|
Compare: TFPSListCompareFunc;
|
|
end;
|
|
|
|
function TFPSList_Sort_Comparer(Item1, Item2, Context: Pointer): Integer;
|
|
begin
|
|
Result := PFPSList_Sort_Comparer_Context(Context)^.Compare(Item1, Item2);
|
|
end;
|
|
|
|
procedure TFPSList.Sort(Compare: TFPSListCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
var
|
|
Context: TFPSList_Sort_Comparer_Context;
|
|
begin
|
|
Context.Compare := Compare;
|
|
SortingAlgorithm^.ItemListSorter_ContextComparer(FList, FCount, FItemSize, @TFPSList_Sort_Comparer, @Context);
|
|
end;
|
|
|
|
procedure TFPSList.QuickSort(L, R: Integer; Compare: TFPSListCompareFunc);
|
|
var
|
|
Context: TFPSList_Sort_Comparer_Context;
|
|
SortingAlgorithm: PSortingAlgorithm;
|
|
begin
|
|
if (R > L) and (L >= 0) then
|
|
begin
|
|
Context.Compare := Compare;
|
|
SortingAlgorithm := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}SortBase.DefaultSortingAlgorithm;
|
|
SortingAlgorithm^.ItemListSorter_ContextComparer(FList + FItemSize*L, R-L+1, FItemSize, @TFPSList_Sort_Comparer, @Context);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPSList.AddList(Obj: TFPSList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Obj.ItemSize <> FItemSize then
|
|
Error(SListItemSizeError, 0);
|
|
// Do this now.
|
|
Capacity:=Capacity+Obj.Count;
|
|
if ItemIsManaged then
|
|
begin
|
|
// nothing for it, need to do it manually to give deref a chance.
|
|
For I:=0 to Obj.Count-1 do
|
|
Add(Obj[i])
|
|
end
|
|
else
|
|
begin
|
|
if Obj.Count=0 then
|
|
exit;
|
|
CopyItems(Obj.InternalItems[0],InternalItems[FCount],Obj.Count);
|
|
FCount:=FCount+Obj.Count;
|
|
end
|
|
end;
|
|
|
|
procedure TFPSList.Assign(Obj: TFPSList);
|
|
|
|
begin
|
|
// We must do this check here, to avoid clearing the list.
|
|
if Obj.ItemSize <> FItemSize then
|
|
Error(SListItemSizeError, 0);
|
|
Clear;
|
|
AddList(Obj);
|
|
end;
|
|
|
|
{****************************************************************************}
|
|
{* TFPGListEnumerator *}
|
|
{****************************************************************************}
|
|
|
|
function TFPGListEnumerator.GetCurrent: T;
|
|
begin
|
|
Result := T(FList.Items[FPosition]^);
|
|
end;
|
|
|
|
constructor TFPGListEnumerator.Create(AList: TFPSList);
|
|
begin
|
|
inherited Create;
|
|
FList := AList;
|
|
FPosition := -1;
|
|
end;
|
|
|
|
function TFPGListEnumerator.MoveNext: Boolean;
|
|
begin
|
|
inc(FPosition);
|
|
Result := FPosition < FList.Count;
|
|
end;
|
|
|
|
{****************************************************************************}
|
|
{* TFPGList *}
|
|
{****************************************************************************}
|
|
|
|
constructor TFPGList.Create;
|
|
begin
|
|
inherited Create(sizeof(T));
|
|
end;
|
|
|
|
procedure TFPGList.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
T(Dest^) := T(Src^);
|
|
end;
|
|
|
|
procedure TFPGList.Deref(Item: Pointer);
|
|
begin
|
|
Finalize(T(Item^));
|
|
end;
|
|
|
|
function TFPGList.Get(Index: Integer): T;
|
|
begin
|
|
Result := T(inherited Get(Index)^);
|
|
end;
|
|
|
|
function TFPGList.GetList: PTypeList;
|
|
begin
|
|
Result := PTypeList(@FList);
|
|
end;
|
|
|
|
function TFPGList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := FOnCompare(T(Item1^), T(Item2^));
|
|
end;
|
|
|
|
procedure TFPGList.Put(Index: Integer; const Item: T);
|
|
begin
|
|
inherited Put(Index, @Item);
|
|
end;
|
|
|
|
function TFPGList.Add(const Item: T): Integer;
|
|
begin
|
|
Result := inherited Add(@Item);
|
|
end;
|
|
|
|
function TFPGList.Extract(const Item: T): T;
|
|
begin
|
|
inherited Extract(@Item, @Result);
|
|
end;
|
|
|
|
function TFPGList.GetFirst: T;
|
|
begin
|
|
if FCount<>0 then
|
|
Result := T(inherited GetFirst^)
|
|
else
|
|
Result:=Default(T);
|
|
end;
|
|
|
|
procedure TFPGList.SetFirst(const Value: T);
|
|
begin
|
|
inherited SetFirst(@Value);
|
|
end;
|
|
|
|
class function TFPGList.ItemIsManaged: Boolean;
|
|
begin
|
|
Result:=IsManagedType(T);
|
|
end;
|
|
|
|
function TFPGList.GetEnumerator: TFPGListEnumeratorSpec;
|
|
begin
|
|
Result := TFPGListEnumeratorSpec.Create(Self);
|
|
end;
|
|
|
|
function TFPGList.IndexOf(const Item: T): Integer;
|
|
begin
|
|
Result := 0;
|
|
{$info TODO: fix inlining to work! InternalItems[Result]^}
|
|
while (Result < FCount) and (PT(FList)[Result] <> Item) do
|
|
Inc(Result);
|
|
if Result = FCount then
|
|
Result := -1;
|
|
end;
|
|
|
|
procedure TFPGList.Insert(Index: Integer; const Item: T);
|
|
begin
|
|
T(inherited Insert(Index)^) := Item;
|
|
end;
|
|
|
|
function TFPGList.GetLast: T;
|
|
begin
|
|
if FCount<>0 then
|
|
Result := T(inherited GetLast^)
|
|
else
|
|
result:=Default(T);
|
|
end;
|
|
|
|
procedure TFPGList.SetLast(const Value: T);
|
|
begin
|
|
inherited SetLast(@Value);
|
|
end;
|
|
|
|
procedure TFPGList.AddList(Source: TFPGList);
|
|
|
|
var
|
|
i: Integer;
|
|
|
|
begin
|
|
if ItemIsManaged then
|
|
begin
|
|
Capacity:=Capacity+Source.Count;
|
|
for I := 0 to Source.Count - 1 do
|
|
Add(Source[i]);
|
|
end
|
|
else
|
|
Inherited AddList(TFPSList(source))
|
|
end;
|
|
|
|
procedure TFPGList.Assign(Source: TFPGList);
|
|
begin
|
|
if ItemIsManaged then
|
|
begin
|
|
Clear;
|
|
AddList(Source);
|
|
end
|
|
else
|
|
Inherited Assign(TFPSList(source))
|
|
end;
|
|
|
|
function TFPGList.Remove(const Item: T): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result >= 0 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
procedure TFPGList.Sort(Compare: TCompareFunc);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare);
|
|
end;
|
|
|
|
procedure TFPGList.Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare, SortingAlgorithm);
|
|
end;
|
|
|
|
|
|
{****************************************************************************}
|
|
{* TFPGObjectList *}
|
|
{****************************************************************************}
|
|
|
|
constructor TFPGObjectList.Create(FreeObjects: Boolean);
|
|
begin
|
|
inherited Create;
|
|
FFreeObjects := FreeObjects;
|
|
end;
|
|
|
|
procedure TFPGObjectList.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
T(Dest^) := T(Src^);
|
|
end;
|
|
|
|
procedure TFPGObjectList.Deref(Item: Pointer);
|
|
begin
|
|
if FFreeObjects then
|
|
T(Item^).Free;
|
|
end;
|
|
|
|
function TFPGObjectList.Get(Index: Integer): T;
|
|
begin
|
|
Result := T(inherited Get(Index)^);
|
|
end;
|
|
|
|
function TFPGObjectList.GetList: PTypeList;
|
|
begin
|
|
Result := PTypeList(@FList);
|
|
end;
|
|
|
|
function TFPGObjectList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := FOnCompare(T(Item1^), T(Item2^));
|
|
end;
|
|
|
|
procedure TFPGObjectList.Put(Index: Integer; const Item: T);
|
|
begin
|
|
inherited Put(Index, @Item);
|
|
end;
|
|
|
|
function TFPGObjectList.Add(const Item: T): Integer;
|
|
begin
|
|
Result := inherited Add(@Item);
|
|
end;
|
|
|
|
function TFPGObjectList.Extract(const Item: T): T;
|
|
begin
|
|
inherited Extract(@Item, @Result);
|
|
end;
|
|
|
|
function TFPGObjectList.GetFirst: T;
|
|
begin
|
|
if FCount<>0 then
|
|
Result := T(inherited GetFirst^)
|
|
else
|
|
Result := Default(T)
|
|
end;
|
|
|
|
procedure TFPGObjectList.SetFirst(const Value: T);
|
|
begin
|
|
inherited SetFirst(@Value);
|
|
end;
|
|
|
|
function TFPGObjectList.GetEnumerator: TFPGListEnumeratorSpec;
|
|
begin
|
|
Result := TFPGListEnumeratorSpec.Create(Self);
|
|
end;
|
|
|
|
function TFPGObjectList.IndexOf(const Item: T): Integer;
|
|
begin
|
|
Result :=
|
|
{$if sizeof(pointer) = sizeof(word)}
|
|
IndexWord
|
|
{$elseif sizeof(pointer) = sizeof(dword)}
|
|
IndexDWord
|
|
{$elseif sizeof(pointer) = sizeof(qword)}
|
|
IndexQWord
|
|
{$else}
|
|
{$error unknown pointer size}
|
|
{$endif}
|
|
(FList^, FCount, PtrUint(Pointer(Item)));
|
|
end;
|
|
|
|
procedure TFPGObjectList.Insert(Index: Integer; const Item: T);
|
|
begin
|
|
T(inherited Insert(Index)^) := Item;
|
|
end;
|
|
|
|
function TFPGObjectList.GetLast: T;
|
|
begin
|
|
if FCount<>0 then
|
|
Result := T(inherited GetLast^)
|
|
else
|
|
Result :=Default(T);
|
|
end;
|
|
|
|
procedure TFPGObjectList.SetLast(const Value: T);
|
|
begin
|
|
inherited SetLast(@Value);
|
|
end;
|
|
|
|
procedure TFPGObjectList.AddList(Source: TFPGObjectList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for I := 0 to Source.Count - 1 do
|
|
Add(Source[i]);
|
|
end;
|
|
|
|
procedure TFPGObjectList.Assign(Source: TFPGObjectList);
|
|
begin
|
|
Clear;
|
|
AddList(Source);
|
|
end;
|
|
|
|
function TFPGObjectList.Remove(const Item: T): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result >= 0 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
procedure TFPGObjectList.Sort(Compare: TCompareFunc);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare);
|
|
end;
|
|
|
|
procedure TFPGObjectList.Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare, SortingAlgorithm);
|
|
end;
|
|
|
|
|
|
{****************************************************************************}
|
|
{* TFPGInterfacedObjectList *}
|
|
{****************************************************************************}
|
|
|
|
constructor TFPGInterfacedObjectList.Create;
|
|
begin
|
|
inherited Create;
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
if Assigned(Pointer(Dest^)) then
|
|
T(Dest^)._Release;
|
|
Pointer(Dest^) := Pointer(Src^);
|
|
if Assigned(Pointer(Dest^)) then
|
|
T(Dest^)._AddRef;
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Deref(Item: Pointer);
|
|
begin
|
|
if Assigned(Pointer(Item^)) then
|
|
T(Item^)._Release;
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.Get(Index: Integer): T;
|
|
begin
|
|
Result := T(inherited Get(Index)^);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.GetList: PTypeList;
|
|
begin
|
|
Result := PTypeList(@FList);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := FOnCompare(T(Item1^), T(Item2^));
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Put(Index: Integer; const Item: T);
|
|
begin
|
|
CheckIndex(Index);
|
|
InternalItems[Index] := @Item; // eventually calls copyitem()
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.Add(const Item: T): Integer;
|
|
begin
|
|
Result := inherited Add(@Item);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.Extract(const Item: T): T;
|
|
begin
|
|
inherited Extract(@Item, @Result);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.GetFirst: T;
|
|
begin
|
|
Result := T(inherited GetFirst^);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.SetFirst(const Value: T);
|
|
begin
|
|
inherited SetFirst(@Value);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.GetEnumerator: TFPGListEnumeratorSpec;
|
|
begin
|
|
Result := TFPGListEnumeratorSpec.Create(Self);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.IndexOf(const Item: T): Integer;
|
|
begin
|
|
Result :=
|
|
{$if sizeof(pointer) = sizeof(word)}
|
|
IndexWord
|
|
{$elseif sizeof(pointer) = sizeof(dword)}
|
|
IndexDWord
|
|
{$elseif sizeof(pointer) = sizeof(qword)}
|
|
IndexQWord
|
|
{$else}
|
|
{$error unknown pointer size}
|
|
{$endif}
|
|
(FList^, FCount, PtrUint(Pointer(Item)));
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Insert(Index: Integer; const Item: T);
|
|
begin
|
|
T(inherited Insert(Index)^) := Item;
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.GetLast: T;
|
|
begin
|
|
Result := T(inherited GetLast^);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.SetLast(const Value: T);
|
|
begin
|
|
inherited SetLast(@Value);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Assign(Source: TFPGInterfacedObjectList);
|
|
|
|
begin
|
|
Clear;
|
|
AddList(Source);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.AddList(Source: TFPGInterfacedObjectList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for I := 0 to Source.Count - 1 do
|
|
Add(Source[i]);
|
|
end;
|
|
|
|
function TFPGInterfacedObjectList.Remove(const Item: T): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result >= 0 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Sort(Compare: TCompareFunc);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare);
|
|
end;
|
|
|
|
procedure TFPGInterfacedObjectList.Sort(Compare: TCompareFunc; SortingAlgorithm: PSortingAlgorithm);
|
|
begin
|
|
FOnCompare := Compare;
|
|
inherited Sort(@ItemPtrCompare, SortingAlgorithm);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TFPSMap
|
|
****************************************************************************}
|
|
|
|
constructor TFPSMap.Create(AKeySize: Integer; ADataSize: integer);
|
|
begin
|
|
inherited Create(AKeySize+ADataSize);
|
|
FKeySize := AKeySize;
|
|
FDataSize := ADataSize;
|
|
InitOnPtrCompare;
|
|
end;
|
|
|
|
procedure TFPSMap.CopyKey(Src, Dest: Pointer);
|
|
begin
|
|
System.Move(Src^, Dest^, FKeySize);
|
|
end;
|
|
|
|
procedure TFPSMap.CopyData(Src, Dest: Pointer);
|
|
begin
|
|
System.Move(Src^, Dest^, FDataSize);
|
|
end;
|
|
|
|
function TFPSMap.GetKey(Index: Integer): Pointer;
|
|
begin
|
|
Result := Items[Index];
|
|
end;
|
|
|
|
function TFPSMap.GetData(Index: Integer): Pointer;
|
|
begin
|
|
Result := PByte(Items[Index])+FKeySize;
|
|
end;
|
|
|
|
function TFPSMap.GetKeyData(AKey: Pointer): Pointer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := IndexOf(AKey);
|
|
if I >= 0 then
|
|
Result := InternalItems[I]+FKeySize
|
|
else
|
|
Error(SMapKeyError, PtrUInt(AKey));
|
|
end;
|
|
|
|
function TFPSMap.BinaryCompareKey(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
Result := CompareByte(Key1^, Key2^, FKeySize);
|
|
end;
|
|
|
|
function TFPSMap.BinaryCompareData(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
Result := CompareByte(Data1^, Data2^, FDataSize);
|
|
end;
|
|
|
|
procedure TFPSMap.SetOnKeyPtrCompare(Proc: TFPSListCompareFunc);
|
|
begin
|
|
if Proc <> nil then
|
|
FOnKeyPtrCompare := Proc
|
|
else
|
|
FOnKeyPtrCompare := @BinaryCompareKey;
|
|
end;
|
|
|
|
procedure TFPSMap.SetOnDataPtrCompare(Proc: TFPSListCompareFunc);
|
|
begin
|
|
if Proc <> nil then
|
|
FOnDataPtrCompare := Proc
|
|
else
|
|
FOnDataPtrCompare := @BinaryCompareData;
|
|
end;
|
|
|
|
procedure TFPSMap.InitOnPtrCompare;
|
|
begin
|
|
SetOnKeyPtrCompare(nil);
|
|
SetOnDataPtrCompare(nil);
|
|
end;
|
|
|
|
procedure TFPSMap.PutKey(Index: Integer; AKey: Pointer);
|
|
begin
|
|
if FSorted then
|
|
Error(SSortedListError, 0);
|
|
CopyKey(AKey, Items[Index]);
|
|
end;
|
|
|
|
procedure TFPSMap.PutData(Index: Integer; AData: Pointer);
|
|
begin
|
|
CopyData(AData, PByte(Items[Index])+FKeySize);
|
|
end;
|
|
|
|
procedure TFPSMap.PutKeyData(AKey: Pointer; NewData: Pointer);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := IndexOf(AKey);
|
|
if I >= 0 then
|
|
Data[I] := NewData
|
|
else
|
|
Add(AKey, NewData);
|
|
end;
|
|
|
|
procedure TFPSMap.SetSorted(Value: Boolean);
|
|
begin
|
|
if Value = FSorted then exit;
|
|
FSorted := Value;
|
|
if Value then Sort;
|
|
end;
|
|
|
|
function TFPSMap.Add(AKey: Pointer): Integer;
|
|
begin
|
|
if Sorted then
|
|
begin
|
|
if Find(AKey, Result) then
|
|
case Duplicates of
|
|
dupIgnore: exit;
|
|
dupError: Error(SDuplicateItem, 0)
|
|
end;
|
|
end else
|
|
Result := Count;
|
|
CopyKey(AKey, inherited Insert(Result));
|
|
end;
|
|
|
|
function TFPSMap.Add(AKey, AData: Pointer): Integer;
|
|
begin
|
|
Result := Add(AKey);
|
|
Data[Result] := AData;
|
|
end;
|
|
|
|
function TFPSMap.Find(AKey: Pointer; out Index: Integer): Boolean;
|
|
{ Searches for the first item <= Key, returns True if exact match,
|
|
sets index to the index of the found string. }
|
|
var
|
|
I,L,R,Dir: Integer;
|
|
begin
|
|
Result := false;
|
|
Index := -1;
|
|
if not Sorted then
|
|
raise EListError.Create(SErrFindNeedsSortedList);
|
|
// Use binary search.
|
|
L := 0;
|
|
R := FCount-1;
|
|
while L<=R do
|
|
begin
|
|
I := L + (R - L) div 2;
|
|
Dir := FOnKeyPtrCompare(Items[I], AKey);
|
|
if Dir < 0 then
|
|
L := I+1
|
|
else begin
|
|
R := I-1;
|
|
if Dir = 0 then
|
|
begin
|
|
Result := true;
|
|
if Duplicates <> dupAccept then
|
|
L := I;
|
|
end;
|
|
end;
|
|
end;
|
|
Index := L;
|
|
end;
|
|
|
|
function TFPSMap.LinearIndexOf(AKey: Pointer): Integer;
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
Result := 0;
|
|
ListItem := First;
|
|
while (Result < FCount) and (FOnKeyPtrCompare(ListItem, AKey) <> 0) do
|
|
begin
|
|
Inc(Result);
|
|
ListItem := PByte(ListItem)+FItemSize;
|
|
end;
|
|
if Result = FCount then Result := -1;
|
|
end;
|
|
|
|
function TFPSMap.IndexOf(AKey: Pointer): Integer;
|
|
begin
|
|
if Sorted then
|
|
begin
|
|
if not Find(AKey, Result) then
|
|
Result := -1;
|
|
end else
|
|
Result := LinearIndexOf(AKey);
|
|
end;
|
|
|
|
function TFPSMap.IndexOfData(AData: Pointer): Integer;
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
Result := 0;
|
|
ListItem := First+FKeySize;
|
|
while (Result < FCount) and (FOnDataPtrCompare(ListItem, AData) <> 0) do
|
|
begin
|
|
Inc(Result);
|
|
ListItem := PByte(ListItem)+FItemSize;
|
|
end;
|
|
if Result = FCount then Result := -1;
|
|
end;
|
|
|
|
function TFPSMap.Insert(Index: Integer): Pointer;
|
|
begin
|
|
if FSorted then
|
|
Error(SSortedListError, 0);
|
|
Result := inherited Insert(Index);
|
|
end;
|
|
|
|
procedure TFPSMap.Insert(Index: Integer; out AKey, AData: Pointer);
|
|
begin
|
|
AKey := Insert(Index);
|
|
AData := PByte(AKey) + FKeySize;
|
|
end;
|
|
|
|
procedure TFPSMap.InsertKey(Index: Integer; AKey: Pointer);
|
|
begin
|
|
CopyKey(AKey, Insert(Index));
|
|
end;
|
|
|
|
procedure TFPSMap.InsertKeyData(Index: Integer; AKey, AData: Pointer);
|
|
var
|
|
ListItem: Pointer;
|
|
begin
|
|
ListItem := Insert(Index);
|
|
CopyKey(AKey, ListItem);
|
|
CopyData(AData, PByte(ListItem)+FKeySize);
|
|
end;
|
|
|
|
function TFPSMap.Remove(AKey: Pointer): Integer;
|
|
begin
|
|
Result := IndexOf(AKey);
|
|
if Result >= 0 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
procedure TFPSMap.Sort;
|
|
begin
|
|
inherited Sort(FOnKeyPtrCompare);
|
|
end;
|
|
|
|
procedure TFPSMap.Sort(SortingAlgorithm: PSortingAlgorithm);
|
|
begin
|
|
inherited Sort(FOnKeyPtrCompare, SortingAlgorithm);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TFPGMap
|
|
****************************************************************************}
|
|
|
|
constructor TFPGMap.Create;
|
|
begin
|
|
inherited Create(SizeOf(TKey), SizeOf(TData));
|
|
end;
|
|
|
|
procedure TFPGMap.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
CopyKey(Src, Dest);
|
|
CopyData(PByte(Src)+KeySize, PByte(Dest)+KeySize);
|
|
end;
|
|
|
|
procedure TFPGMap.CopyKey(Src, Dest: Pointer);
|
|
begin
|
|
TKey(Dest^) := TKey(Src^);
|
|
end;
|
|
|
|
procedure TFPGMap.CopyData(Src, Dest: Pointer);
|
|
begin
|
|
TData(Dest^) := TData(Src^);
|
|
end;
|
|
|
|
procedure TFPGMap.Deref(Item: Pointer);
|
|
begin
|
|
Finalize(TKey(Item^));
|
|
Finalize(TData(Pointer(PByte(Item)+KeySize)^));
|
|
end;
|
|
|
|
function TFPGMap.GetKey(Index: Integer): TKey;
|
|
begin
|
|
Result := TKey(inherited GetKey(Index)^);
|
|
end;
|
|
|
|
function TFPGMap.GetData(Index: Integer): TData;
|
|
begin
|
|
Result := TData(inherited GetData(Index)^);
|
|
end;
|
|
|
|
function TFPGMap.GetKeyData(const AKey: TKey): TData;
|
|
begin
|
|
Result := TData(inherited GetKeyData(@AKey)^);
|
|
end;
|
|
|
|
function TFPGMap.KeyCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
if PKey(Key1)^ < PKey(Key2)^ then
|
|
Result := -1
|
|
else if PKey(Key1)^ > PKey(Key2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{function TFPGMap.DataCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
if PData(Data1)^ < PData(Data2)^ then
|
|
Result := -1
|
|
else if PData(Data1)^ > PData(Data2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;}
|
|
|
|
function TFPGMap.KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
Result := FOnKeyCompare(TKey(Key1^), TKey(Key2^));
|
|
end;
|
|
|
|
function TFPGMap.DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
Result := FOnDataCompare(TData(Data1^), TData(Data2^));
|
|
end;
|
|
|
|
procedure TFPGMap.SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
begin
|
|
FOnKeyCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnKeyPtrCompare := @KeyCustomCompare
|
|
else
|
|
OnKeyPtrCompare := @KeyCompare;
|
|
end;
|
|
|
|
procedure TFPGMap.SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
begin
|
|
FOnDataCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnDataPtrCompare := @DataCustomCompare
|
|
else
|
|
OnDataPtrCompare := nil;
|
|
end;
|
|
|
|
procedure TFPGMap.InitOnPtrCompare;
|
|
begin
|
|
SetOnKeyCompare(nil);
|
|
SetOnDataCompare(nil);
|
|
end;
|
|
|
|
procedure TFPGMap.PutKey(Index: Integer; const NewKey: TKey);
|
|
begin
|
|
inherited PutKey(Index, @NewKey);
|
|
end;
|
|
|
|
procedure TFPGMap.PutData(Index: Integer; const NewData: TData);
|
|
begin
|
|
inherited PutData(Index, @NewData);
|
|
end;
|
|
|
|
procedure TFPGMap.PutKeyData(const AKey: TKey; const NewData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @NewData);
|
|
end;
|
|
|
|
function TFPGMap.Add(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey);
|
|
end;
|
|
|
|
function TFPGMap.Add(const AKey: TKey; const AData: TData): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMap.Find(const AKey: TKey; out Index: Integer): Boolean;
|
|
begin
|
|
Result := inherited Find(@AKey, Index);
|
|
end;
|
|
|
|
function TFPGMap.TryGetData(const AKey: TKey; out AData: TData): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := IndexOf(AKey);
|
|
Result := (I >= 0);
|
|
if Result then
|
|
AData := TData(inherited GetData(I)^)
|
|
else
|
|
AData := Default(TData);
|
|
end;
|
|
|
|
procedure TFPGMap.AddOrSetData(const AKey: TKey; const AData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMap.IndexOf(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited IndexOf(@AKey);
|
|
end;
|
|
|
|
function TFPGMap.IndexOfData(const AData: TData): Integer;
|
|
begin
|
|
{ TODO: loop ? }
|
|
Result := inherited IndexOfData(@AData);
|
|
end;
|
|
|
|
procedure TFPGMap.InsertKey(Index: Integer; const AKey: TKey);
|
|
begin
|
|
inherited InsertKey(Index, @AKey);
|
|
end;
|
|
|
|
procedure TFPGMap.InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
begin
|
|
inherited InsertKeyData(Index, @AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMap.Remove(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Remove(@AKey);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TFPGMapObject
|
|
****************************************************************************}
|
|
|
|
constructor TFPGMapObject.Create(AFreeObjects: Boolean);
|
|
begin
|
|
inherited Create(SizeOf(TKey), SizeOf(TData));
|
|
FFreeObjects := AFreeObjects;
|
|
end;
|
|
|
|
constructor TFPGMapObject.Create;
|
|
begin
|
|
Create(True);
|
|
end;
|
|
|
|
procedure TFPGMapObject.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
CopyKey(Src, Dest);
|
|
CopyData(PByte(Src)+KeySize, PByte(Dest)+KeySize);
|
|
end;
|
|
|
|
procedure TFPGMapObject.CopyKey(Src, Dest: Pointer);
|
|
begin
|
|
TKey(Dest^) := TKey(Src^);
|
|
end;
|
|
|
|
procedure TFPGMapObject.CopyData(Src, Dest: Pointer);
|
|
begin
|
|
if Assigned(Pointer(Dest^)) And FFreeObjects then
|
|
TData(Dest^).Free;
|
|
TData(Dest^) := TData(Src^);
|
|
end;
|
|
|
|
procedure TFPGMapObject.Deref(Item: Pointer);
|
|
begin
|
|
Finalize(TKey(Item^));
|
|
if Assigned(PPointer(PByte(Item)+KeySize)^) and FFreeObjects then
|
|
TData(Pointer(PByte(Item)+KeySize)^).Free;
|
|
end;
|
|
|
|
function TFPGMapObject.GetKey(Index: Integer): TKey;
|
|
begin
|
|
Result := TKey(inherited GetKey(Index)^);
|
|
end;
|
|
|
|
function TFPGMapObject.GetData(Index: Integer): TData;
|
|
begin
|
|
Result := TData(inherited GetData(Index)^);
|
|
end;
|
|
|
|
function TFPGMapObject.GetKeyData(const AKey: TKey): TData;
|
|
begin
|
|
Result := TData(inherited GetKeyData(@AKey)^);
|
|
end;
|
|
|
|
function TFPGMapObject.KeyCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
if PKey(Key1)^ < PKey(Key2)^ then
|
|
Result := -1
|
|
else if PKey(Key1)^ > PKey(Key2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{function TFPGMapObject.DataCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
if PData(Data1)^ < PData(Data2)^ then
|
|
Result := -1
|
|
else if PData(Data1)^ > PData(Data2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;}
|
|
|
|
function TFPGMapObject.KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
Result := FOnKeyCompare(TKey(Key1^), TKey(Key2^));
|
|
end;
|
|
|
|
function TFPGMapObject.DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
Result := FOnDataCompare(TData(Data1^), TData(Data2^));
|
|
end;
|
|
|
|
procedure TFPGMapObject.SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
begin
|
|
FOnKeyCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnKeyPtrCompare := @KeyCustomCompare
|
|
else
|
|
OnKeyPtrCompare := @KeyCompare;
|
|
end;
|
|
|
|
procedure TFPGMapObject.SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
begin
|
|
FOnDataCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnDataPtrCompare := @DataCustomCompare
|
|
else
|
|
OnDataPtrCompare := nil;
|
|
end;
|
|
|
|
procedure TFPGMapObject.InitOnPtrCompare;
|
|
begin
|
|
SetOnKeyCompare(nil);
|
|
SetOnDataCompare(nil);
|
|
end;
|
|
|
|
procedure TFPGMapObject.PutKey(Index: Integer; const NewKey: TKey);
|
|
begin
|
|
inherited PutKey(Index, @NewKey);
|
|
end;
|
|
|
|
procedure TFPGMapObject.PutData(Index: Integer; const NewData: TData);
|
|
begin
|
|
inherited PutData(Index, @NewData);
|
|
end;
|
|
|
|
procedure TFPGMapObject.PutKeyData(const AKey: TKey; const NewData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @NewData);
|
|
end;
|
|
|
|
function TFPGMapObject.Add(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey);
|
|
end;
|
|
|
|
function TFPGMapObject.Add(const AKey: TKey; const AData: TData): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapObject.Find(const AKey: TKey; out Index: Integer): Boolean;
|
|
begin
|
|
Result := inherited Find(@AKey, Index);
|
|
end;
|
|
|
|
function TFPGMapObject.TryGetData(const AKey: TKey; out AData: TData): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := IndexOf(AKey);
|
|
Result := (I >= 0);
|
|
if Result then
|
|
AData := TData(inherited GetData(I)^)
|
|
else
|
|
AData := Default(TData);
|
|
end;
|
|
|
|
procedure TFPGMapObject.AddOrSetData(const AKey: TKey; const AData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapObject.IndexOf(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited IndexOf(@AKey);
|
|
end;
|
|
|
|
function TFPGMapObject.IndexOfData(const AData: TData): Integer;
|
|
begin
|
|
{ TODO: loop ? }
|
|
Result := inherited IndexOfData(@AData);
|
|
end;
|
|
|
|
procedure TFPGMapObject.InsertKey(Index: Integer; const AKey: TKey);
|
|
begin
|
|
inherited InsertKey(Index, @AKey);
|
|
end;
|
|
|
|
procedure TFPGMapObject.InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
begin
|
|
inherited InsertKeyData(Index, @AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapObject.Remove(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Remove(@AKey);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TFPGMapInterfacedObjectData
|
|
****************************************************************************}
|
|
|
|
constructor TFPGMapInterfacedObjectData.Create;
|
|
begin
|
|
inherited Create(SizeOf(TKey), SizeOf(TData));
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.CopyItem(Src, Dest: Pointer);
|
|
begin
|
|
CopyKey(Src, Dest);
|
|
CopyData(PByte(Src)+KeySize, PByte(Dest)+KeySize);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.CopyKey(Src, Dest: Pointer);
|
|
begin
|
|
TKey(Dest^) := TKey(Src^);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.CopyData(Src, Dest: Pointer);
|
|
begin
|
|
if Assigned(Pointer(Dest^)) then
|
|
TData(Dest^)._Release;
|
|
TData(Dest^) := TData(Src^);
|
|
if Assigned(Pointer(Dest^)) then
|
|
TData(Dest^)._AddRef;
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.Deref(Item: Pointer);
|
|
begin
|
|
Finalize(TKey(Item^));
|
|
if Assigned(PPointer(PByte(Item)+KeySize)^) then
|
|
TData(Pointer(PByte(Item)+KeySize)^)._Release;
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.GetKey(Index: Integer): TKey;
|
|
begin
|
|
Result := TKey(inherited GetKey(Index)^);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.GetData(Index: Integer): TData;
|
|
begin
|
|
Result := TData(inherited GetData(Index)^);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.GetKeyData(const AKey: TKey): TData;
|
|
begin
|
|
Result := TData(inherited GetKeyData(@AKey)^);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.KeyCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
if PKey(Key1)^ < PKey(Key2)^ then
|
|
Result := -1
|
|
else if PKey(Key1)^ > PKey(Key2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{function TFPGMapInterfacedObjectData.DataCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
if PData(Data1)^ < PData(Data2)^ then
|
|
Result := -1
|
|
else if PData(Data1)^ > PData(Data2)^ then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;}
|
|
|
|
function TFPGMapInterfacedObjectData.KeyCustomCompare(Key1, Key2: Pointer): Integer;
|
|
begin
|
|
Result := FOnKeyCompare(TKey(Key1^), TKey(Key2^));
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.DataCustomCompare(Data1, Data2: Pointer): Integer;
|
|
begin
|
|
Result := FOnDataCompare(TData(Data1^), TData(Data2^));
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.SetOnKeyCompare(NewCompare: TKeyCompareFunc);
|
|
begin
|
|
FOnKeyCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnKeyPtrCompare := @KeyCustomCompare
|
|
else
|
|
OnKeyPtrCompare := @KeyCompare;
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.SetOnDataCompare(NewCompare: TDataCompareFunc);
|
|
begin
|
|
FOnDataCompare := NewCompare;
|
|
if NewCompare <> nil then
|
|
OnDataPtrCompare := @DataCustomCompare
|
|
else
|
|
OnDataPtrCompare := nil;
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.InitOnPtrCompare;
|
|
begin
|
|
SetOnKeyCompare(nil);
|
|
SetOnDataCompare(nil);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.PutKey(Index: Integer; const NewKey: TKey);
|
|
begin
|
|
inherited PutKey(Index, @NewKey);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.PutData(Index: Integer; const NewData: TData);
|
|
begin
|
|
inherited PutData(Index, @NewData);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.PutKeyData(const AKey: TKey; const NewData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @NewData);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.Add(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.Add(const AKey: TKey; const AData: TData): Integer;
|
|
begin
|
|
Result := inherited Add(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.Find(const AKey: TKey; out Index: Integer): Boolean;
|
|
begin
|
|
Result := inherited Find(@AKey, Index);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.TryGetData(const AKey: TKey; out AData: TData): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := IndexOf(AKey);
|
|
Result := (I >= 0);
|
|
if Result then
|
|
AData := TData(inherited GetData(I)^)
|
|
else
|
|
AData := Default(TData);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.AddOrSetData(const AKey: TKey;
|
|
const AData: TData);
|
|
begin
|
|
inherited PutKeyData(@AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.IndexOf(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited IndexOf(@AKey);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.IndexOfData(const AData: TData): Integer;
|
|
begin
|
|
{ TODO: loop ? }
|
|
Result := inherited IndexOfData(@AData);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.InsertKey(Index: Integer; const AKey: TKey);
|
|
begin
|
|
inherited InsertKey(Index, @AKey);
|
|
end;
|
|
|
|
procedure TFPGMapInterfacedObjectData.InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
|
|
begin
|
|
inherited InsertKeyData(Index, @AKey, @AData);
|
|
end;
|
|
|
|
function TFPGMapInterfacedObjectData.Remove(const AKey: TKey): Integer;
|
|
begin
|
|
Result := inherited Remove(@AKey);
|
|
end;
|
|
|
|
end.
|