paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 10:40:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

* implemented TFPGInterfacedObjectList. it's the same as TFPGObjectList but ref counted.

Browse Source 
git-svn-id: trunk@13102 -
This commit is contained in:
ivost 2009-05-05 12:26:42 +00:00
parent 71ecb3e83b
commit f38c6c609d
1 changed files with 134 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
rtl/objpas/fgl.pp
View File

@ -136,7 +136,37 @@ type
function IndexOf(const Item: T): Integer;
procedure Insert(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
function Last: T; {$ifdef CLASSESINLINE} inline; {$endif}
{$info FIXME: bug #10479: implement TFPGList<T>.Assign(TFPGList) to work somehow}
{$info FIXME: bug #10479: implement TFPGObjectList<T>.Assign(TFPGList) to work somehow}
{procedure Assign(Source: TFPGList);}
function Remove(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
procedure Sort(Compare: TCompareFunc);
property Items[Index: Integer]: T read Get write Put; default;
property List: PTypeList read GetList;
end;
generic TFPGInterfacedObjectList<T> = class(TFPSList)
type public
TCompareFunc = function(const Item1, Item2: T): Integer;
TTypeList = array[0..MaxGListSize] of T;
PTypeList = ^TTypeList;
PT = ^T;
var protected
FOnCompare: TCompareFunc;
procedure CopyItem(Src, Dest: Pointer); override;
procedure Deref(Item: Pointer); override;
function Get(Index: Integer): T; {$ifdef CLASSESINLINE} inline; {$endif}
function GetList: PTypeList; {$ifdef CLASSESINLINE} inline; {$endif}
function ItemPtrCompare(Item1, Item2: Pointer): Integer;
procedure Put(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
public
constructor Create;
function Add(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Extract(const Item: T): T; {$ifdef CLASSESINLINE} inline; {$endif}
function First: T; {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOf(const Item: T): Integer;
procedure Insert(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
function Last: T; {$ifdef CLASSESINLINE} inline; {$endif}
{$info FIXME: bug #10479: implement TFPGInterfacedObjectList<T>.Assign(TFPGList) to work somehow}
{procedure Assign(Source: TFPGList);}
function Remove(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
procedure Sort(Compare: TCompareFunc);
@ -685,11 +715,16 @@ end;
procedure TFPGObjectList.CopyItem(Src, Dest: Pointer);
begin
T(Dest^) := T(Src^);
{if TObject(Dest^) is TInterfacedObject then
T(Dest^)._AddRef;}
end;
procedure TFPGObjectList.Deref(Item: Pointer);
begin
T(Item^).Free;
{if TObject(Item^) is TInterfacedObject then
T(Item^)._Release
else}
T(Item^).Free;
end;
function TFPGObjectList.Get(Index: Integer): T;
@ -766,6 +801,103 @@ begin
inherited Sort(@ItemPtrCompare);
end;
{****************************************************************************}
{* TFPGInterfacedObjectList *}
{****************************************************************************}
constructor TFPGInterfacedObjectList.Create;
begin
inherited Create;
end;
procedure TFPGInterfacedObjectList.CopyItem(Src, Dest: Pointer);
begin
T(Dest^) := T(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
inherited Put(Index, @Item);
end;
function TFPGInterfacedObjectList.Add(const Item: T): Integer;
begin
Result := inherited Add(@Item);
end;
function TFPGInterfacedObjectList.Extract(const Item: T): T;
var
ResPtr: Pointer;
begin
ResPtr := inherited Extract(@Item);
if ResPtr <> nil then
Result := T(ResPtr^)
else
FillByte(Result, 0, sizeof(T));
end;
function TFPGInterfacedObjectList.First: T;
begin
Result := T(inherited First^);
end;
function TFPGInterfacedObjectList.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 TFPGInterfacedObjectList.Insert(Index: Integer; const Item: T);
begin
T(inherited Insert(Index)^) := Item;
end;
function TFPGInterfacedObjectList.Last: T;
begin
Result := T(inherited Last^);
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;
{$endif}
{****************************************************************************