mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 01:29:29 +02:00
+ initial commit, derived from tfplist, draft, non working yet, needs more compiler support
git-svn-id: trunk@4484 -
This commit is contained in:
florian
parent
01da5f44fd
commit
3b152ad791
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -4630,6 +4630,7 @@ rtl/objpas/cvarutil.inc svneol=native#text/plain
|
||||
rtl/objpas/dateutil.inc svneol=native#text/plain
|
||||
rtl/objpas/dateutil.pp svneol=native#text/plain
|
||||
rtl/objpas/dateutils.pp svneol=native#text/plain
|
||||
rtl/objpas/fgl.pp svneol=native#text/plain
|
||||
rtl/objpas/freebidi.pp svneol=native#text/plain
|
||||
rtl/objpas/math.pp svneol=native#text/plain
|
||||
rtl/objpas/objpas.pp svneol=native#text/plain
|
||||
|
||||
402
rtl/objpas/fgl.pp
Normal file
402
rtl/objpas/fgl.pp
Normal file
@ -0,0 +1,402 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2006 by Florian Klaempfl
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
member of the Free Pascal development team
|
||||
|
||||
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}
|
||||
|
||||
{ be aware, this unit is a prototype and subject to be changed heavily }
|
||||
unit fgl;
|
||||
|
||||
interface
|
||||
|
||||
type
|
||||
{ TFPList class }
|
||||
generic TGList<TG> = class(TObject)
|
||||
type
|
||||
PTGList = ^TPointerList;
|
||||
TTGList = array[0..MaxListSize - 1] of TG;
|
||||
TListSortCompare = function (Item1, Item2: TG): Integer;
|
||||
TListCallback = procedure(data,arg: TG) of object;
|
||||
TListStaticCallback = procedure(data,arg: TG);
|
||||
private
|
||||
FList: PTGList;
|
||||
FCount: Integer;
|
||||
FCapacity: Integer;
|
||||
protected
|
||||
function Get(Index: Integer): TG; inline;
|
||||
procedure Put(Index: Integer; Item: TG); inline;
|
||||
procedure SetCapacity(NewCapacity: Integer);
|
||||
procedure SetCount(NewCount: Integer);
|
||||
Procedure RaiseIndexError(Index : Integer);
|
||||
public
|
||||
destructor Destroy; override;
|
||||
function Add(const Item: TG): Integer; inline;
|
||||
procedure Clear;
|
||||
procedure Delete(Index: Integer); inline;
|
||||
class procedure Error(const Msg: string; Data: PtrInt);
|
||||
procedure Exchange(Index1, Index2: Integer);
|
||||
function Expand: TGList; inline;
|
||||
function Extract(const item: TG): TG;
|
||||
function First: TG;
|
||||
function IndexOf(const Item: TG): Integer;
|
||||
procedure Insert(Index: Integer; Item: TG); inline;
|
||||
function Last: TG;
|
||||
procedure Move(CurIndex, NewIndex: Integer);
|
||||
procedure Assign(Obj:TGList);
|
||||
function Remove(const Item: TG): Integer;
|
||||
procedure Pack;
|
||||
procedure Sort(Compare: TListSortCompare);
|
||||
procedure ForEachCall(proc2call:TListCallback;arg:pointer);
|
||||
procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
||||
property Capacity: Integer read FCapacity write SetCapacity;
|
||||
property Count: Integer read FCount write SetCount;
|
||||
property Items[Index: Integer]: TG read Get write Put; default;
|
||||
property List: PTGList read FList;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{****************************************************************************}
|
||||
{* TGList *}
|
||||
{****************************************************************************}
|
||||
|
||||
procedure TGList.RaiseIndexError(Index : Integer);
|
||||
begin
|
||||
Error(SListIndexError, Index);
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Get(Index: Integer): Pointer; inline;
|
||||
begin
|
||||
If (Index < 0) or (Index >= FCount) then
|
||||
RaiseIndexError(Index);
|
||||
Result:=FList^[Index];
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Put(Index: Integer; Item: Pointer); inline;
|
||||
begin
|
||||
if (Index < 0) or (Index >= FCount) then
|
||||
RaiseIndexError(Index);
|
||||
Flist^[Index] := Item;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Extract(item: Pointer): Pointer;
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
result := nil;
|
||||
i := IndexOf(item);
|
||||
if i >= 0 then
|
||||
begin
|
||||
Result := item;
|
||||
FList^[i] := nil;
|
||||
Delete(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.SetCapacity(NewCapacity: Integer);
|
||||
begin
|
||||
If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
|
||||
Error (SListCapacityError, NewCapacity);
|
||||
if NewCapacity = FCapacity then
|
||||
exit;
|
||||
ReallocMem(FList, SizeOf(Pointer)*NewCapacity);
|
||||
FCapacity := NewCapacity;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.SetCount(NewCount: Integer);
|
||||
Const
|
||||
// Ratio of Pointer and Word Size.
|
||||
WordRatio = SizeOf(TG) Div SizeOf(Word);
|
||||
|
||||
begin
|
||||
if (NewCount < 0) or (NewCount > MaxListSize)then
|
||||
Error(SListCountError, NewCount);
|
||||
If NewCount > FCount then
|
||||
begin
|
||||
If NewCount > FCapacity then
|
||||
SetCapacity(NewCount);
|
||||
If FCount < NewCount then
|
||||
FillWord(Flist^[FCount], (NewCount-FCount) * WordRatio, 0);
|
||||
end;
|
||||
FCount := Newcount;
|
||||
end;
|
||||
|
||||
|
||||
destructor TGList.Destroy;
|
||||
begin
|
||||
Self.Clear;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Add(Item: Pointer): Integer; inline;
|
||||
begin
|
||||
if FCount = FCapacity then
|
||||
Self.Expand;
|
||||
FList^[FCount] := Item;
|
||||
Result := FCount;
|
||||
FCount := FCount + 1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Clear;
|
||||
begin
|
||||
if Assigned(FList) then
|
||||
begin
|
||||
SetCount(0);
|
||||
SetCapacity(0);
|
||||
FList := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Delete(Index: Integer); inline;
|
||||
begin
|
||||
If (Index<0) or (Index>=FCount) then
|
||||
Error (SListIndexError, Index);
|
||||
FCount := FCount-1;
|
||||
System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
|
||||
// Shrink the list if appropriate
|
||||
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
||||
begin
|
||||
FCapacity := FCapacity shr 1;
|
||||
ReallocMem(FList, SizeOf(Pointer) * FCapacity);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
class procedure TGList.Error(const Msg: string; Data: PtrInt);
|
||||
begin
|
||||
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Exchange(Index1, Index2: Integer);
|
||||
var
|
||||
Temp : Pointer;
|
||||
begin
|
||||
If ((Index1 >= FCount) or (Index1 < 0)) then
|
||||
Error(SListIndexError, Index1);
|
||||
If ((Index2 >= FCount) or (Index2 < 0)) then
|
||||
Error(SListIndexError, Index2);
|
||||
Temp := FList^[Index1];
|
||||
FList^[Index1] := FList^[Index2];
|
||||
FList^[Index2] := Temp;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Expand: TGList; inline;
|
||||
var
|
||||
IncSize : Longint;
|
||||
begin
|
||||
if FCount < FCapacity then exit;
|
||||
IncSize := 4;
|
||||
if FCapacity > 3 then IncSize := IncSize + 4;
|
||||
if FCapacity > 8 then IncSize := IncSize+8;
|
||||
if FCapacity > 127 then Inc(IncSize, FCapacity shr 2);
|
||||
SetCapacity(FCapacity + IncSize);
|
||||
Result := Self;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.First: Pointer;
|
||||
begin
|
||||
If FCount = 0 then
|
||||
Result := Nil
|
||||
else
|
||||
Result := Items[0];
|
||||
end;
|
||||
|
||||
|
||||
function TGList.IndexOf(Item: Pointer): Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
while(Result < FCount) and (Flist^[Result] <> Item) do Result := Result + 1;
|
||||
If Result = FCount then Result := -1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Insert(Index: Integer; Item: Pointer); inline;
|
||||
begin
|
||||
if (Index < 0) or (Index > FCount )then
|
||||
Error(SlistIndexError, Index);
|
||||
iF FCount = FCapacity then Self.Expand;
|
||||
if Index<FCount then
|
||||
System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer));
|
||||
FList^[Index] := Item;
|
||||
FCount := FCount + 1;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Last: Pointer;
|
||||
begin
|
||||
{ Wouldn't it be better to return nil if the count is zero ?}
|
||||
If FCount = 0 then
|
||||
Result := nil
|
||||
else
|
||||
Result := Items[FCount - 1];
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Move(CurIndex, NewIndex: Integer);
|
||||
var
|
||||
Temp : Pointer;
|
||||
begin
|
||||
if ((CurIndex < 0) or (CurIndex > Count - 1)) then
|
||||
Error(SListIndexError, CurIndex);
|
||||
if (NewINdex < 0) then
|
||||
Error(SlistIndexError, NewIndex);
|
||||
Temp := FList^[CurIndex];
|
||||
FList^[CurIndex] := nil;
|
||||
Self.Delete(CurIndex);
|
||||
Self.Insert(NewIndex, nil);
|
||||
FList^[NewIndex] := Temp;
|
||||
end;
|
||||
|
||||
|
||||
function TGList.Remove(Item: Pointer): Integer;
|
||||
begin
|
||||
Result := IndexOf(Item);
|
||||
If Result <> -1 then
|
||||
Self.Delete(Result);
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Pack;
|
||||
Var
|
||||
{Last,I,J,}
|
||||
Runner : Longint;
|
||||
begin
|
||||
// Not the fastest; but surely correct
|
||||
for Runner := Fcount - 1 downto 0 do
|
||||
if Items[Runner] = Nil then
|
||||
Self.Delete(Runner);
|
||||
{ The following may be faster in case of large and defragmented lists
|
||||
If count=0 then exit;
|
||||
Runner:=0;I:=0;
|
||||
TheLast:=Count;
|
||||
while runner<count do
|
||||
begin
|
||||
// Find first Nil
|
||||
While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
|
||||
if Runner<Count do
|
||||
begin
|
||||
// Start searching for non-nil from last known nil+1
|
||||
if i<Runner then I:=Runner+1;
|
||||
While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
|
||||
// Start looking for last non-nil of block.
|
||||
J:=I+1;
|
||||
While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
|
||||
// Move block and zero out
|
||||
Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
|
||||
FillWord (Flist^[I],(J-I)*WordRatio,0);
|
||||
// Update Runner and Last to point behind last block
|
||||
TheLast:=Runner+(J-I);
|
||||
If J=Count then
|
||||
begin
|
||||
// Shortcut, when J=Count we checked all pointers
|
||||
Runner:=Count
|
||||
else
|
||||
begin
|
||||
Runner:=TheLast;
|
||||
I:=j;
|
||||
end;
|
||||
end;
|
||||
Count:=TheLast;
|
||||
}
|
||||
end;
|
||||
|
||||
// Needed by Sort method.
|
||||
|
||||
Procedure QuickSort(FList: PPointerList; L, R : Longint;
|
||||
Compare: TListSortCompare);
|
||||
var
|
||||
I, J : Longint;
|
||||
P, Q : Pointer;
|
||||
begin
|
||||
repeat
|
||||
I := L;
|
||||
J := R;
|
||||
P := FList^[ (L + R) div 2 ];
|
||||
repeat
|
||||
while Compare(P, FList^[i]) > 0 do
|
||||
I := I + 1;
|
||||
while Compare(P, FList^[J]) < 0 do
|
||||
J := J - 1;
|
||||
If I <= J then
|
||||
begin
|
||||
Q := FList^[I];
|
||||
Flist^[I] := FList^[J];
|
||||
FList^[J] := Q;
|
||||
I := I + 1;
|
||||
J := J - 1;
|
||||
end;
|
||||
until I > J;
|
||||
if L < J then
|
||||
QuickSort(FList, L, J, Compare);
|
||||
L := I;
|
||||
until I >= R;
|
||||
end;
|
||||
|
||||
procedure TGList.Sort(Compare: TListSortCompare);
|
||||
begin
|
||||
if Not Assigned(FList) or (FCount < 2) then exit;
|
||||
QuickSort(Flist, 0, FCount-1, Compare);
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.Assign(Obj: TGList);
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Clear;
|
||||
for I := 0 to Obj.Count - 1 do
|
||||
Add(Obj[i]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.ForEachCall(proc2call:TListCallback;arg:pointer);
|
||||
var
|
||||
i : integer;
|
||||
p : pointer;
|
||||
begin
|
||||
For I:=0 To Count-1 Do
|
||||
begin
|
||||
p:=FList^[i];
|
||||
if assigned(p) then
|
||||
proc2call(p,arg);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
||||
var
|
||||
i : integer;
|
||||
p : pointer;
|
||||
begin
|
||||
For I:=0 To Count-1 Do
|
||||
begin
|
||||
p:=FList^[i];
|
||||
if assigned(p) then
|
||||
proc2call(p,arg);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user