mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-28 19:46:03 +02:00
472 lines
9.2 KiB
PHP
472 lines
9.2 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 1999-2000 by 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.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************}
|
|
{* TList *}
|
|
{****************************************************************************}
|
|
|
|
{ TList = class(TObject)
|
|
private
|
|
FList: PPointerList;
|
|
FCount: Integer;
|
|
FCapacity: Integer;
|
|
}
|
|
Const
|
|
// Ratio of Pointer and Word Size.
|
|
WordRatio = SizeOf(Pointer) Div SizeOf(Word);
|
|
|
|
function TList.Get(Index: Integer): Pointer;
|
|
|
|
begin
|
|
If (Index<0) or (Index>=FCount) then
|
|
Error(SListIndexError,Index);
|
|
Result:=FList^[Index];
|
|
end;
|
|
|
|
|
|
|
|
procedure TList.Grow;
|
|
|
|
begin
|
|
// Only for compatibility with Delphi. Not needed.
|
|
end;
|
|
|
|
|
|
|
|
procedure TList.Put(Index: Integer; Item: Pointer);
|
|
|
|
begin
|
|
if (Index<0) or (Index>=FCount) then
|
|
Error(SListIndexError,Index);
|
|
Flist^[Index]:=Item;
|
|
end;
|
|
|
|
|
|
function TList.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);
|
|
Notify(Result,lnExtracted);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TList.Notify(Ptr: Pointer; Action: TListNotification);
|
|
begin
|
|
end;
|
|
|
|
|
|
procedure TList.SetCapacity(NewCapacity: Integer);
|
|
|
|
Var NewList,ToFree : PPointerList;
|
|
|
|
begin
|
|
If (NewCapacity<0) or (NewCapacity>MaxListSize) then
|
|
Error (SListCapacityError,NewCapacity);
|
|
if NewCapacity=FCapacity then
|
|
exit;
|
|
ReallocMem(FList,SizeOf(Pointer)*NewCapacity);
|
|
FCapacity:=NewCapacity;
|
|
end;
|
|
|
|
|
|
|
|
procedure TList.SetCount(NewCount: Integer);
|
|
|
|
begin
|
|
If (NewCount<0) or (NewCount>MaxListSize)then
|
|
Error(SListCountError,NewCount);
|
|
If NewCount<FCount then
|
|
FCount:=NewCount
|
|
else If NewCount>FCount then
|
|
begin
|
|
If NewCount>FCapacity then
|
|
SetCapacity (NewCount);
|
|
If FCount<NewCount then
|
|
FillWord (Flist^[FCount],(NewCount-FCount)* WordRatio ,0);
|
|
FCount:=Newcount;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
destructor TList.Destroy;
|
|
|
|
begin
|
|
Self.Clear;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
Function TList.Add(Item: Pointer): Integer;
|
|
|
|
begin
|
|
Self.Insert (Count,Item);
|
|
Result:=Count-1;
|
|
end;
|
|
|
|
|
|
|
|
Procedure TList.Clear;
|
|
|
|
begin
|
|
If Assigned(FList) then
|
|
begin
|
|
FreeMem (Flist,FCapacity*SizeOf(Pointer));
|
|
FList:=Nil;
|
|
FCapacity:=0;
|
|
FCount:=0;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
Procedure TList.Delete(Index: Integer);
|
|
|
|
Var
|
|
OldPointer :Pointer;
|
|
|
|
begin
|
|
If (Index<0) or (Index>=FCount) then
|
|
Error (SListIndexError,Index);
|
|
FCount:=FCount-1;
|
|
OldPointer:=Flist^[Index];
|
|
System.Move (FList^[Index+1],FList^[Index],(FCount-Index)*SizeOf(Pointer));
|
|
// Shrink the list if appropiate
|
|
if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
|
begin
|
|
FCapacity := FCapacity shr 1;
|
|
ReallocMem(FList, SizeOf(Pointer) * FCapacity);
|
|
end;
|
|
If OldPointer<>nil then
|
|
Notify(OldPointer,lnDeleted);
|
|
end;
|
|
|
|
|
|
class procedure TList.Error(const Msg: string; Data: Integer);
|
|
|
|
begin
|
|
{$ifdef VER1_0}
|
|
Raise EListError.CreateFmt(Msg,[Data]) at longint(get_caller_addr(get_frame));
|
|
{$else VER1_0}
|
|
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
|
{$endif VER1_0}
|
|
end;
|
|
|
|
procedure TList.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 TList.Expand: TList;
|
|
|
|
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 TList.First: Pointer;
|
|
|
|
begin
|
|
If FCount=0 then
|
|
Result:=Nil
|
|
else
|
|
Result:=Items[0];
|
|
end;
|
|
|
|
|
|
|
|
function TList.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 TList.Insert(Index: Integer; Item: Pointer);
|
|
|
|
begin
|
|
If (Index<0) or (Index>FCount )then
|
|
Error(SlistIndexError,Index);
|
|
IF FCount=FCapacity Then Self.Expand;
|
|
If Index<FCount then
|
|
System.Move (Flist^[Index],Flist^[Index+1],(FCount-Index)*SizeOf(Pointer));
|
|
FList^[Index]:=Item;
|
|
FCount:=FCount+1;
|
|
If Item<>NIl then
|
|
Notify(Item,lnAdded);
|
|
end;
|
|
|
|
|
|
|
|
function TList.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 TList.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);
|
|
// ?? If NewIndex>CurIndex then NewIndex:=NewIndex-1;
|
|
// Newindex changes when deleting ??
|
|
Self.Insert (NewIndex,Nil);
|
|
FList^[NewIndex]:=Temp;
|
|
end;
|
|
|
|
|
|
function TList.Remove(Item: Pointer): Integer;
|
|
|
|
begin
|
|
Result:=IndexOf(Item);
|
|
If Result<>-1 then
|
|
Self.Delete (Result);
|
|
end;
|
|
|
|
|
|
|
|
Procedure TList.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 TList.Sort(Compare: TListSortCompare);
|
|
|
|
begin
|
|
If Not Assigned(FList) or (FCount<2) then exit;
|
|
QuickSort (Flist, 0, FCount-1,Compare);
|
|
end;
|
|
|
|
procedure TList.Assign(Obj:TList);
|
|
// Principle copied from TCollection
|
|
|
|
var i : Integer;
|
|
begin
|
|
Clear;
|
|
For I:=0 To Obj.Count-1 Do
|
|
Add(Obj[i]);
|
|
end;
|
|
|
|
{****************************************************************************}
|
|
{* TThreadList *}
|
|
{****************************************************************************}
|
|
|
|
|
|
constructor TThreadList.Create;
|
|
begin
|
|
inherited Create;
|
|
//InitializeCriticalSection(FLock);
|
|
FList := TList.Create;
|
|
end;
|
|
|
|
|
|
|
|
destructor TThreadList.Destroy;
|
|
begin
|
|
LockList;
|
|
try
|
|
FList.Free;
|
|
inherited Destroy;
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure TThreadList.Add(Item: Pointer);
|
|
begin
|
|
Locklist;
|
|
try
|
|
//make sure it's not already in the list
|
|
if FList.indexof(Item) = -1 then
|
|
FList.Add(Item);
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TThreadList.Clear;
|
|
begin
|
|
Locklist;
|
|
try
|
|
FList.Clear;
|
|
finally
|
|
UnLockList;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
function TThreadList.LockList: TList;
|
|
|
|
|
|
begin
|
|
Result := FList;
|
|
end;
|
|
|
|
|
|
|
|
procedure TThreadList.Remove(Item: Pointer);
|
|
begin
|
|
LockList;
|
|
try
|
|
FList.Remove(Item);
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure TThreadList.UnlockList;
|
|
begin
|
|
|
|
end;
|
|
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.2 2003-10-07 14:30:57 marco
|
|
* 1.0 version of assign
|
|
|
|
Revision 1.1 2003/10/06 20:33:58 peter
|
|
* classes moved to rtl for 1.1
|
|
* classes .inc and classes.pp files moved to fcl/classes for
|
|
backwards 1.0.x compatiblity to have it in the fcl
|
|
|
|
Revision 1.9 2002/09/07 15:15:24 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.8 2002/08/16 10:04:58 michael
|
|
+ Notify correctly implemented
|
|
|
|
Revision 1.7 2002/07/16 14:00:55 florian
|
|
* raise takes now a void pointer as at and frame address
|
|
instead of a longint, fixed
|
|
|
|
}
|