paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-31 21:30:51 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r31381 into '.':

Browse Source 
U    rtl/objpas/fgl.pp
--- Recording mergeinfo for merge of r31381 into '.':
 U   .
--- Merging r32942 into '.':
G    rtl/objpas/fgl.pp
--- Recording mergeinfo for merge of r32942 into '.':
 G   .
--- Merging r32947 into '.':
G    rtl/objpas/fgl.pp
--- Recording mergeinfo for merge of r32947 into '.':
 G   .
--- Merging r32959 into '.':
G    rtl/objpas/fgl.pp
--- Recording mergeinfo for merge of r32959 into '.':
 G   .
--- Merging r32987 into '.':
G    rtl/objpas/fgl.pp
--- Recording mergeinfo for merge of r32987 into '.':
 G   .
--- Merging r33098 into '.':
U    packages/fcl-stl/src/garrayutils.pp
--- Recording mergeinfo for merge of r33098 into '.':
 G   .
--- Merging r33311 into '.':
U    packages/fcl-stl/fpmake.pp
A    packages/fcl-stl/tests/glinkedlisttest.pp
A    packages/fcl-stl/src/glinkedlist.pp
--- Recording mergeinfo for merge of r33311 into '.':
 G   .
--- Merging r33341 into '.':
U    packages/fcl-stl/src/ghashmap.pp
--- Recording mergeinfo for merge of r33341 into '.':
 G   .

# revisions: 31381,32942,32947,32959,32987,33098,33311,33341

git-svn-id: branches/fixes_3_0@33403 -
This commit is contained in:
marco 2016-04-01 09:44:15 +00:00
parent b5913b75d0
commit 8256d24725
7 changed files with 987 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2835,6 +2835,7 @@ packages/fcl-stl/src/garrayutils.pp svneol=native#text/plain
packages/fcl-stl/src/gdeque.pp svneol=native#text/plain
packages/fcl-stl/src/ghashmap.pp svneol=native#text/plain
packages/fcl-stl/src/ghashset.pp svneol=native#text/plain
packages/fcl-stl/src/glinkedlist.pp svneol=native#text/plain
packages/fcl-stl/src/gmap.pp svneol=native#text/plain
packages/fcl-stl/src/gpriorityqueue.pp svneol=native#text/plain
packages/fcl-stl/src/gqueue.pp svneol=native#text/plain
@ -2849,6 +2850,7 @@ packages/fcl-stl/tests/gcompositetest.pp svneol=native#text/plain
packages/fcl-stl/tests/gdequetest.pp svneol=native#text/plain
packages/fcl-stl/tests/ghashmaptest.pp svneol=native#text/plain
packages/fcl-stl/tests/ghashsettest.pp svneol=native#text/plain
packages/fcl-stl/tests/glinkedlisttest.pp svneol=native#text/plain
packages/fcl-stl/tests/gmaptest.pp svneol=native#text/plain
packages/fcl-stl/tests/gmaptestzal.pp svneol=native#text/plain
packages/fcl-stl/tests/gpriorityqueuetest.pp svneol=native#text/plain

1
packages/fcl-stl/fpmake.pp
View File

@ -48,6 +48,7 @@ begin
AddUnit('gdeque');
end;
T:=P.Targets.AddUnit('gset.pp');
T:=P.Targets.AddUnit('glinkedlist.pp');
T:=P.Targets.AddUnit('gtree.pp');
T:=P.Targets.AddUnit('gstack.pp');
with T.Dependencies do

2
packages/fcl-stl/src/garrayutils.pp
View File

@ -85,7 +85,7 @@ begin
end;
class procedure TOrderingArrayUtils.Sortrange(var Arr:TArr; Start,Fin,d:SizeUInt);
var pivot,temp:Tvalue; i,j,k,l:SizeUInt;
var pivot,temp:Tvalue; i,j,k,l:SizeInt;
begin
if (Fin-Start) <= InsertSortThreshold then
begin

230
packages/fcl-stl/src/ghashmap.pp
View File

@ -12,15 +12,26 @@
**********************************************************************}
{$mode objfpc}
{ $define STL_INTERFACE_EXT}
unit ghashmap;
interface
uses gvector, gutil, garrayutils;
const baseFDataSize = 8;
const
baseFDataSize = 8; // must be > 0
maxLoadingFactor = 1.0;
{Thash should have one class function hash(a:TKey, n:longint):longint which return uniformly distributed
value in range <0,n-1> base only on arguments, n will be always power of 2}
{
THash should have the class functions
hash(a: TKey, n: SizeUInt): SizeUInt;
return uniformly distributed i value in range <0,n-1> base only on arguments,
n will be always power of 2
equal(const AKey1, AKey2: TKey): Boolean; [when STL_INTERFACE_EXT is defined]
return the boolean test for equality of the two keys. Typically this is operator=,
but it doesn't have to be (e.g. case-insensitive string comparison)
}
type
generic THashmapIterator<TKey, TValue, T, TTable>=class
@ -30,6 +41,7 @@
Fh,Fp:SizeUInt;
FData:TTable;
function Next:boolean;inline;
function Prev:boolean;inline;
function GetData:T;inline;
function GetKey:TKey;inline;
function GetValue:TValue;inline;
@ -66,17 +78,19 @@
function contains(key:TKey):boolean;inline;
function size:SizeUInt;inline;
procedure delete(key:TKey);inline;
procedure erase(iter:TIterator);inline;
function IsEmpty:boolean;inline;
function GetData(key:TKey):TValue;inline;
function GetValue(key:TKey;out value:TValue):boolean;inline;
property Items[i : TKey]: TValue read GetData write Insert; default;
function Iterator:TIterator;
function Iterator:TIterator;
end;
implementation
function THashmap.Size:SizeUInt;inline;
function THashmap.Size: SizeUInt;
begin
Size:=FDataSize;
end;
@ -84,36 +98,43 @@ end;
destructor THashmap.Destroy;
var i:SizeUInt;
begin
for i:=0 to FData.size-1 do
i:=0;
while i < FData.size do
begin
(FData[i]).Destroy;
inc(i);
end;
FData.Destroy;
end;
function THashmap.IsEmpty():boolean;inline;
function THashmap.IsEmpty(): boolean;
begin
if Size()=0 then
IsEmpty:=true
else
IsEmpty:=false;
IsEmpty := Size()=0;
end;
procedure THashmap.EnlargeTable;
var i,j,h,oldDataSize:SizeUInt;
curbucket:TContainer;
value:TPair;
begin
//Assert(oldDataSize>0);
oldDataSize:=FData.size;
FData.resize(FData.size*2);
for i:=oldDataSize to FData.size-1 do
FData[i] := TContainer.create;
for i:=oldDataSize-1 downto 0 do begin
curbucket:=FData[i];
j := 0;
while j < (FData[i]).size do begin
value := (FData[i])[j];
h:=Thash.hash(value.key,FData.size);
while j < curbucket.size do begin
h:=THash.hash(curbucket[j].key,FData.size);
if (h <> i) then begin
(FData[i])[j] := (FData[i]).back;
(FData[i]).popback;
(FData[h]).pushback(value);
if (j+1) < curbucket.size then begin
value:=curbucket[j];
curbucket[j]:= curbucket.back;
(FData[h]).pushback(value);
end else
(FData[h]).pushback(curbucket[j]);
curbucket.popback;
end else
inc(j);
end;
@ -121,7 +142,7 @@ begin
end;
constructor THashmap.create;
var i:longint;
var i: SizeUInt;
begin
FDataSize:=0;
FData:=TTable.create;
@ -130,56 +151,107 @@ begin
FData[i]:=TContainer.create;
end;
function THashmap.contains(key:TKey):boolean;inline;
var i,h,bs:longint;
function THashmap.contains(key: TKey): boolean;
var i,bs:SizeUInt;
curbucket:TContainer;
begin
h:=Thash.hash(key,FData.size);
bs:=(FData[h]).size;
for i:=0 to bs-1 do begin
if (((FData[h])[i]).Key=key) then exit(true);
curbucket:=FData[THash.hash(key,FData.size)];
bs:=curbucket.size;
i:=0;
while i < bs do begin
{$ifdef STL_INTERFACE_EXT}
if THash.equal(curbucket[i].Key, key) then exit(true);
{$else}
if (curbucket[i].Key = key) then exit(true);
{$endif}
inc(i);
end;
exit(false);
end;
function THashmap.GetData(key:TKey):TValue;inline;
var i,h,bs:longint;
function THashmap.GetData(key: TKey): TValue;
var i,bs:SizeUInt;
curbucket:TContainer;
begin
h:=Thash.hash(key,FData.size);
bs:=(FData[h]).size;
for i:=0 to bs-1 do begin
if (((FData[h])[i]).Key=key) then exit(((FData[h])[i]).Value);
curbucket:=FData[THash.hash(key,FData.size)];
bs:=curbucket.size;
i:=0;
while i < bs do begin
{$ifdef STL_INTERFACE_EXT}
if THash.equal(curbucket[i].Key, key) then exit(curbucket[i].Value);
{$else}
if (curbucket[i].Key = key) then exit(curbucket[i].Value);
{$endif}
inc(i);
end;
// exception?
end;
procedure THashmap.insert(key:TKey;value:TValue);inline;
var pair:TPair; i,h,bs:longint;
function THashmap.GetValue(key: TKey; out value: TValue): boolean;
var i,bs:SizeUInt;
curbucket:TContainer;
begin
h:=Thash.hash(key,FData.size);
bs:=(FData[h]).size;
for i:=0 to bs-1 do begin
if (((FData[h])[i]).Key=key) then begin
((FData[h]).mutable[i])^.value := value;
curbucket:=FData[THash.hash(key,FData.size)];
bs:=curbucket.size;
i:=0;
while i < bs do begin
{$ifdef STL_INTERFACE_EXT}
if THash.equal(curbucket[i].Key, key) then begin
{$else}
if (curbucket[i].Key = key) then begin
{$endif}
value:=curbucket[i].Value;
exit(true);
end;
inc(i);
end;
exit(false);
end;
procedure THashmap.insert(key: TKey; value: TValue);
var pair:TPair;
i,bs:SizeUInt;
curbucket:TContainer;
begin
curbucket:=FData[THash.hash(key,FData.size)];
bs:=curbucket.size;
i:=0;
while i < bs do begin
{$ifdef STL_INTERFACE_EXT}
if THash.equal(curbucket[i].Key, key) then begin
{$else}
if (curbucket[i].Key = key) then begin
{$endif}
(curbucket.mutable[i])^.value := value;
exit;
end;
inc(i);
end;
pair.Key := key;
pair.Value := value;
inc(FDataSize);
(FData[h]).pushback(pair);
curbucket.pushback(pair);
if (FDataSize > 5*FData.size) then
if (FDataSize > maxLoadingFactor*FData.size) then
EnlargeTable;
end;
procedure THashmap.delete(key:TKey);inline;
var h,i:SizeUInt;
procedure THashmap.delete(key: TKey);
var i,bs:SizeUInt;
curbucket:TContainer;
begin
h:=Thash.hash(key,FData.size);
curbucket:=FData[THash.hash(key,FData.size)];
bs:=curbucket.size;
i:=0;
while i < (FData[h]).size do begin
if (((FData[h])[i]).key=key) then begin
(FData[h])[i] := (FData[h]).back;
(FData[h]).popback;
while i < bs do begin
{$ifdef STL_INTERFACE_EXT}
if THash.equal(curbucket[i].Key, key) then begin
{$else}
if (curbucket[i].Key = key) then begin
{$endif}
//if (i+1) < bs then
curbucket[i] := curbucket.back;
curbucket.popback;
dec(FDataSize);
exit;
end;
@ -187,26 +259,58 @@ begin
end;
end;
function THashmapIterator.Next:boolean;
procedure THashmap.erase(iter: TIterator);
var curbucket:TContainer;
begin
inc(Fp);
if (Fp = (FData[Fh]).size) then begin
Fp:=0; inc(Fh);
while Fh < FData.size do begin
if ((FData[Fh]).size > 0) then break;
inc(Fh);
end;
if (Fh = FData.size) then exit(false);
end;
Next := true;
curbucket:=FData[iter.Fh];
//if (iter.Fp+1) < curbucket.size then
curbucket[iter.Fp] := curbucket.back;
curbucket.popback;
dec(FDataSize);
iter.Prev;
end;
function THashmapIterator.GetData:T;
function THashmapIterator.Next: boolean;
begin
Assert(Fh < FData.size); // assumes FData.size>0 (i.e. buckets don't shrink) and cannot call Next again after reaching end
inc(Fp);
if (Fp < (FData[Fh]).size) then
exit(true);
Fp:=0; Inc(Fh);
while Fh < FData.size do begin
if ((FData[Fh]).size > 0) then
exit(true);
Inc(Fh);
end;
//Assert((Fp = 0) and (Fh = FData.size));
exit(false);
end;
function THashmapIterator.Prev: boolean;
var bs:SizeUInt;
begin
if (Fp > 0) then begin
dec(Fp);
exit(true);
end;
while Fh > 0 do begin
Dec(Fh);
bs:=(FData[Fh]).size;
if (bs > 0) then begin
Fp:=bs-1;
exit(true);
end;
end;
//Assert((Fp = 0) and (Fh = 0));
exit(false);
end;
function THashmapIterator.GetData: T;
begin
GetData:=(FData[Fh])[Fp];
end;
function THashmap.Iterator:TIterator;
function THashmap.Iterator: TIterator;
var h,p:SizeUInt;
begin
h:=0;
@ -222,22 +326,22 @@ begin
Iterator.FData := FData;
end;
function THashmapIterator.GetKey:TKey;inline;
function THashmapIterator.GetKey: TKey;
begin
GetKey:=((FData[Fh])[Fp]).Key;
end;
function THashmapIterator.GetValue:TValue;inline;
function THashmapIterator.GetValue: TValue;
begin
GetValue:=((FData[Fh])[Fp]).Value;
end;
function THashmapIterator.GetMutable:PValue;inline;
function THashmapIterator.GetMutable: PValue;
begin
GetMutable:=@((FData[Fh]).Mutable[Fp]^.Value);
end;
procedure THashmapIterator.SetValue(value:TValue);inline;
procedure THashmapIterator.SetValue(value:TValue);
begin
((FData[Fh]).mutable[Fp])^.Value := value;
end;

360
packages/fcl-stl/src/glinkedlist.pp Normal file
View File

@ -0,0 +1,360 @@
{
This file is part of the Free Pascal FCL library.
Donated in 2013 by Denis Volodarsky
This unit implements a generic double linked list for FPC.
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.
**********************************************************************}
{
}
unit glinkedlist;
{$MODE DELPHI}
interface
type
// Delphi compatible types.
TCollectionNotification = (cnAdded, cnRemoved, cnExtracted);
TCollectionNotifyEvent<T> = procedure(Sender: TObject; const Item: T;
Action: TCollectionNotification) of object;
type
{ TLinkedList }
TLinkedList<T> = class
type
PItem = ^TItem;
TItem = record
private
List: TLinkedList<T>; // owner
public
Data: T;
Prev: PItem;
Next: PItem;
function IsFirst: boolean; inline;
function IsLast: boolean; inline;
function IsSingle: boolean; inline;
function InsertAfter(const Value: T): PItem; inline;
function InsertBefore(const Value: T): PItem; inline;
end;
TTraverseFunc = function(Item: PItem; ud: pointer): boolean;
private
FCount: integer;
FFirst, FLast: PItem;
FOnNotify: TCollectionNotifyEvent<T>;
protected
procedure DoNotify(const Item: T; Action: TCollectionNotification);
procedure Traverse(cb: TTraverseFunc; ud: pointer);
// Following Link/Unlink functions do not modify Count or call Notification.
procedure LinkAfter(Pos, Item: PItem); inline;
procedure LinkBefore(Pos, Item: PItem); inline;
procedure Unlink(Item: PItem); inline;
public
destructor Destroy; override;
procedure Clear;
procedure Delete(Item: PItem);
// Insert Value to start of the list.
function InsertFirst(const Value: T): PItem;
// Insert Value to end of the list.
function InsertLast(const Value: T): PItem;
function InsertAfter(Item: PItem; const Value: T): PItem;
function InsertBefore(Item: PItem; const Value: T): PItem;
// First item moved to end.
procedure RotateLeft;
// Last item moved to begin.
procedure RotateRight;
property Count: integer read FCount;
property First: PItem read FFirst;
property Last: PItem read FLast;
property OnNotify: TCollectionNotifyEvent<T> read FOnNotify write FOnNotify;
type
{ TEnumerator }
TEnumerator = class
private
FList: TLinkedList<T>;
FCurrent: PItem;
protected
function DoGetCurrent: T;
function DoMoveNext: boolean;
public
constructor Create(AList: TLinkedList<T>);
function MoveNext: boolean;
property Current: T read DoGetCurrent;
end;
function GetEnumerator: TEnumerator; reintroduce;
end;
implementation
{ TLinkedList<T>.TItem }
function TLinkedList<T>.TItem.InsertAfter(const Value: T): PItem;
begin
Result := List.InsertAfter(@self, Value);
end;
function TLinkedList<T>.TItem.InsertBefore(const Value: T): PItem;
begin
Result := List.InsertBefore(@self, Value);
end;
function TLinkedList<T>.TItem.IsFirst: boolean;
begin
Result := not Assigned(Prev);
end;
function TLinkedList<T>.TItem.IsLast: boolean;
begin
Result := not Assigned(Next);
end;
function TLinkedList<T>.TItem.IsSingle: boolean;
begin
Result := IsFirst and IsLast;
end;
{ TLinkedList<T> }
destructor TLinkedList<T>.Destroy;
begin
Clear;
Inherited;
end;
procedure TLinkedList<T>.DoNotify(const Item: T; Action: TCollectionNotification);
begin
if Assigned(FOnNotify) then
FOnNotify(self, Item, Action);
end;
procedure TLinkedList<T>.Clear;
var
Next: PItem;
OldValue: T;
begin
if (FCount <> 0) then
begin
while Assigned(FFirst) do
begin
OldValue := FFirst^.Data;
Next := FFirst^.Next;
Dispose(FFirst);
FFirst := Next;
if FFirst = nil then
FLast := nil;
dec(FCount);
DoNotify(OldValue, cnRemoved);
end;
end;
end;
procedure TLinkedList<T>.Delete(Item: PItem);
begin
if Assigned(Item) then
begin
Unlink(Item);
Dec(FCount);
DoNotify(Item^.Data, cnRemoved);
Dispose(Item);
end;
end;
procedure TLinkedList<T>.Traverse(cb: TTraverseFunc; ud: pointer);
var
Cur, Next: PItem;
begin
if Assigned(cb) then
begin
Cur := First;
while Assigned(Cur) do
begin
Next := Cur^.Next;
if not cb(Cur, ud) then
break;
Cur := Next;
end;
end;
end;
procedure TLinkedList<T>.Unlink(Item: PItem);
begin
if Item^.IsFirst then
FFirst := Item^.Next
else
Item^.Prev^.Next := Item^.Next;
if Item^.IsLast then
FLast := Item^.Prev
else
Item^.Next^.Prev := Item^.Prev;
end;
function TLinkedList<T>.InsertFirst(const Value: T): PItem;
begin
if FCount <> 0 then
Exit(InsertBefore(FFirst, Value));
// List is empty: add first item.
new(Result);
Result^.List := self;
Result^.Data := Value;
Result^.Prev := nil;
Result^.Next := nil;
FFirst := Result;
FLast := Result;
inc(FCount);
DoNotify(Value, cnAdded);
end;
function TLinkedList<T>.InsertAfter(Item: PItem; const Value: T): PItem;
begin
if Assigned(Item) then
begin
new(Result);
Result^.List := self;
Result^.Data := Value;
LinkAfter(Item, Result);
inc(FCount);
DoNotify(Value, cnAdded);
Exit;
end;
Exit(nil);
end;
function TLinkedList<T>.InsertBefore(Item: PItem; const Value: T): PItem;
begin
if Assigned(Item) then
begin
new(Result);
Result^.List := self;
Result^.Data := Value;
LinkBefore(Item, Result);
inc(FCount);
DoNotify(Value, cnAdded);
Exit;
end;
Exit(nil);
end;
function TLinkedList<T>.InsertLast(const Value: T): PItem;
begin
if FCount = 0 then
Result := InsertFirst(Value)
else
Result := InsertAfter(FLast, Value);
end;
procedure TLinkedList<T>.LinkAfter(Pos, Item: PItem);
var
PosNext: PItem;
begin
PosNext := Pos^.Next;
Pos^.Next := Item;
if Assigned(PosNext) then
PosNext^.Prev := Item
else
FLast := Item;
Item^.Prev := Pos;
Item^.Next := PosNext;
end;
procedure TLinkedList<T>.LinkBefore(Pos, Item: PItem);
var
PosPrev: PItem;
begin
PosPrev := Pos^.Prev;
Pos^.Prev := Item;
if Assigned(PosPrev) then
PosPrev^.Next := Item
else
FFirst := Item;
Item^.Prev := PosPrev;
Item^.Next := Pos;
end;
procedure TLinkedList<T>.RotateLeft;
var
tmp: PItem;
begin
if FCount > 1 then
begin
tmp := FFirst;
Unlink(tmp);
LinkAfter(FLast, tmp);
end;
end;
procedure TLinkedList<T>.RotateRight;
var
tmp: PItem;
begin
if FCount > 1 then
begin
tmp := FLast;
Unlink(tmp);
LinkBefore(FFirst, tmp);
end;
end;
constructor TLinkedList<T>.TEnumerator.Create(AList: TLinkedList<T>);
begin
inherited Create;
FList := AList;
FCurrent := nil;
end;
function TLinkedList<T>.TEnumerator.MoveNext: boolean;
begin
Result := DoMoveNext;
end;
function TLinkedList<T>.TEnumerator.DoGetCurrent: T;
begin
Result := FCurrent.Data;
end;
function TLinkedList<T>.TEnumerator.DoMoveNext: boolean;
begin
if not Assigned(FCurrent) then
begin
FCurrent := FList.First;
Result := Assigned(FCurrent);
Exit;
end;
Result := Assigned(FCurrent.Next);
if Result then
FCurrent := FCurrent.Next;
end;
function TLinkedList<T>.GetEnumerator: TEnumerator;
begin
Result := TEnumerator.Create(self);
end;
end.

176
packages/fcl-stl/tests/glinkedlisttest.pp Normal file
View File

@ -0,0 +1,176 @@
program LLTest;
{$apptype console}
uses
glinkedlist;
type
IMyIntf = interface
function GetName: string;
property Name: string read GetName;
end;
{ TMyClass }
TMyClass = class(TInterfacedObject, IMyIntf)
protected
FName: string;
public
constructor Create(const AName: string);
function GetName: string;
end;
TIntfLL = specialize TLinkedList<IMyIntf>;
{ TTest }
TTest = class
FList: TIntfLL;
procedure Notification(Sender: TObject; const Item: IMyIntf; Action: TCollectionNotification);
procedure SetupItems;
procedure PrintList;
function Main: TTest;
end;
operator :=(const AValue: string): IMyIntf;
begin
Result := TMyClass.Create(AValue);
end;
{ TTest }
procedure TTest.Notification(Sender: TObject; const Item: IMyIntf;
Action: TCollectionNotification);
var
LL: TIntfLL;
begin
LL := (Sender as TIntfLL);
case Action of
cnAdded:
write('added');
cnRemoved:
write('removed');
end;
write(' "', Item.GetName, '"; ');
write('count=', LL.Count, '; ');
write('first=');
if LL.First = nil then
write('nil')
else
write('"' + LL.First^.Data.Name, '"');
write(' ');
write('last=');
if LL.Last = nil then
write('nil')
else
write('"' + LL.Last^.Data.Name, '" ');
writeln;
end;
procedure TTest.SetupItems;
begin
// add items "1" to "8"
FList.InsertLast('4')^.InsertAfter('5')^.InsertAfter('6');
FList.InsertFirst('3')^.InsertBefore('2')^.InsertBefore('1');
FList.Last^.InsertAfter('7')^.InsertAfter('8');
end;
procedure TTest.PrintList;
var
i: IMyIntf;
begin
write('"');
for i in FList do
write(i.GetName, ' ');
writeln('"');
end;
function TTest.Main: TTest;
var
i: integer;
item: TIntfLL.PItem;
begin
FList := TIntfLL.Create;
try
FList.OnNotify := @Notification;
// setup and print items
SetupItems;
PrintList;
WriteLn;
// print ROL
for i := 1 to 8 do
begin
FList.RotateLeft;
PrintList;
end;
WriteLn;
// print ROR
for i := 1 to 8 do
begin
FList.RotateRight;
PrintList;
end;
WriteLn;
// print deleting first item
for i := 1 to 8 do
begin
FList.Delete(FList.First);
PrintList;
end;
WriteLn;
// print deleting last item
SetupItems;
for i := 1 to 8 do
begin
FList.Delete(FList.Last);
PrintList;
end;
WriteLn;
// delete some item from middle
SetupItems;
PrintList;
item := FList.First^.Next^.Next^.Next;
WriteLn(item^.data.GetName);
FList.Delete(item);
PrintList;
WriteLn;
// clear all items
FList.Clear;
PrintList;
WriteLn;
finally
FList.Free;
end;
Result:=Self;
end;
{ TMyClass }
constructor TMyClass.Create(const AName: string);
begin
inherited Create;
FName := AName;
end;
function TMyClass.GetName: string;
begin
Result := FName;
end;
begin
With TTest.Create do
try
Main;
finally
Free;
end;
end.

281
rtl/objpas/fgl.pp
View File

@ -305,6 +305,57 @@ type
function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Add(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOf(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} 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> = class(TFPSMap)
private
type
TKeyCompareFunc = function(const Key1, Key2: TKey): Integer;
TDataCompareFunc = function(const Data1, Data2: TData): Integer;
PKey = ^TKey;
// unsed PData = ^TData;
{$ifndef OldSyntax}protected var{$else}var protected{$endif}
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 CLASSESINLINE} inline; {$endif}
function GetKeyData(const AKey: TKey): TData; {$ifdef CLASSESINLINE} inline; {$endif}
function GetData(Index: Integer): TData; {$ifdef CLASSESINLINE} 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 CLASSESINLINE} inline; {$endif}
procedure PutKeyData(const AKey: TKey; const NewData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
procedure PutData(Index: Integer; const NewData: TData); {$ifdef CLASSESINLINE} 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 CLASSESINLINE} inline; {$endif}
function Add(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOf(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOfData(const AData: TData): Integer;
procedure InsertKey(Index: Integer; const AKey: TKey);
@ -350,6 +401,8 @@ type
function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Add(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function Find(const AKey: TKey; out Index: Integer): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
function TryGetData(const AKey: TKey; out AData: TData): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
procedure AddOrSetData(const AKey: TKey; const AData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOf(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
function IndexOfData(const AData: TData): Integer;
procedure InsertKey(Index: Integer; const AKey: TKey);
@ -1257,7 +1310,7 @@ begin
R := FCount-1;
while L<=R do
begin
I := (L+R) div 2;
I := L + (R - L) div 2;
Dir := FOnKeyPtrCompare(Items[I], AKey);
if Dir < 0 then
L := I+1
@ -1481,6 +1534,26 @@ begin
Result := inherited Find(@AKey, Index);
end;
function TFPGMap.TryGetData(const AKey: TKey; out AData: TData): Boolean;
var
I: Integer;
begin
Result := inherited Find(@AKey, I);
if Result then
AData := TData(inherited GetData(I)^)
else
{$IFDEF VER2_6}
FillChar(AData,SizeOf(TData),0);
{$ELSE}
AData := Default(TData);
{$ENDIF}
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);
@ -1507,6 +1580,191 @@ 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^)) 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
Result := inherited Find(@AKey, I);
if Result then
AData := TData(inherited GetData(I)^)
else
{$IFDEF VER2_6}
FillChar(AData,SizeOf(TData),0);
{$ELSE}
AData := Default(TData);
{$ENDIF}
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
****************************************************************************}
@ -1642,6 +1900,27 @@ begin
Result := inherited Find(@AKey, Index);
end;
function TFPGMapInterfacedObjectData.TryGetData(const AKey: TKey; out AData: TData): Boolean;
var
I: Integer;
begin
Result := inherited Find(@AKey, I);
if Result then
AData := TData(inherited GetData(I)^)
else
{$IFDEF VER2_6}
FillChar(AData,SizeOf(TData),0);
{$ELSE}
AData := Default(TData);
{$ENDIF}
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);