|
@@ -26,7 +26,8 @@ unit cclasses;
|
|
|
interface
|
|
|
|
|
|
uses
|
|
|
- cutils,cstreams;
|
|
|
+ SysUtils,
|
|
|
+ CUtils,CStreams;
|
|
|
|
|
|
{********************************************
|
|
|
TMemDebug
|
|
@@ -47,7 +48,7 @@ interface
|
|
|
end;
|
|
|
|
|
|
{*******************************************************
|
|
|
- TList (Copied from FCL, exception handling stripped)
|
|
|
+ TFPObjectList (From rtl/objpas/classes/classesh.inc)
|
|
|
********************************************************}
|
|
|
|
|
|
const
|
|
@@ -56,51 +57,98 @@ const
|
|
|
SListCapacityError = 'The maximum list capacity is reached (%d)';
|
|
|
SListCountError = 'List count too large (%d)';
|
|
|
type
|
|
|
-{ TList class }
|
|
|
-
|
|
|
- PPointerList = ^TPointerList;
|
|
|
- TPointerList = array[0..MaxListSize - 1] of Pointer;
|
|
|
- TListSortCompare = function (Item1, Item2: Pointer): Integer;
|
|
|
-
|
|
|
- TListCallback = procedure(data,arg:pointer) of object;
|
|
|
- TListStaticCallback = procedure(data,arg:pointer);
|
|
|
-
|
|
|
- TList = class(TObject)
|
|
|
- private
|
|
|
- FList: PPointerList;
|
|
|
- FCount: Integer;
|
|
|
- FCapacity: Integer;
|
|
|
- protected
|
|
|
- function Get(Index: Integer): Pointer;
|
|
|
- procedure Grow; virtual;
|
|
|
- procedure Put(Index: Integer; Item: Pointer);
|
|
|
- procedure SetCapacity(NewCapacity: Integer);
|
|
|
- procedure SetCount(NewCount: Integer);
|
|
|
- public
|
|
|
- destructor Destroy; override;
|
|
|
- function Add(Item: Pointer): Integer;
|
|
|
- procedure Clear; dynamic;
|
|
|
- procedure Delete(Index: Integer);
|
|
|
- class procedure Error(const Msg: string; Data: Integer); virtual;
|
|
|
- procedure Exchange(Index1, Index2: Integer);
|
|
|
- function Expand: TList;
|
|
|
- function Extract(item: Pointer): Pointer;
|
|
|
- function First: Pointer;
|
|
|
- procedure Assign(Obj:TList);
|
|
|
- function IndexOf(Item: Pointer): Integer;
|
|
|
- procedure Insert(Index: Integer; Item: Pointer);
|
|
|
- function Last: Pointer;
|
|
|
- procedure Move(CurIndex, NewIndex: Integer);
|
|
|
- function Remove(Item: Pointer): Integer;
|
|
|
- procedure Pack;
|
|
|
- procedure Sort(Compare: TListSortCompare);
|
|
|
- procedure foreach(proc2call:TListCallback;arg:pointer);
|
|
|
- procedure foreach_static(proc2call:TListStaticCallback;arg:pointer);
|
|
|
- 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 List: PPointerList read FList;
|
|
|
- end;
|
|
|
+ EListError = class(Exception);
|
|
|
+
|
|
|
+type
|
|
|
+ PPointerList = ^TPointerList;
|
|
|
+ TPointerList = array[0..MaxListSize - 1] of Pointer;
|
|
|
+ TListSortCompare = function (Item1, Item2: Pointer): Integer;
|
|
|
+ TListCallback = procedure(data,arg:pointer) of object;
|
|
|
+ TListStaticCallback = procedure(data,arg:pointer);
|
|
|
+
|
|
|
+ TFPList = class(TObject)
|
|
|
+ private
|
|
|
+ FList: PPointerList;
|
|
|
+ FCount: Integer;
|
|
|
+ FCapacity: Integer;
|
|
|
+ protected
|
|
|
+ function Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ procedure Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ procedure SetCapacity(NewCapacity: Integer);
|
|
|
+ procedure SetCount(NewCount: Integer);
|
|
|
+ Procedure RaiseIndexError(Index : Integer);
|
|
|
+ public
|
|
|
+ destructor Destroy; override;
|
|
|
+ function Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ procedure Clear;
|
|
|
+ procedure Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ class procedure Error(const Msg: string; Data: PtrInt);
|
|
|
+ procedure Exchange(Index1, Index2: Integer);
|
|
|
+ function Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ function Extract(item: Pointer): Pointer;
|
|
|
+ function First: Pointer;
|
|
|
+ function IndexOf(Item: Pointer): Integer;
|
|
|
+ procedure Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+ function Last: Pointer;
|
|
|
+ procedure Move(CurIndex, NewIndex: Integer);
|
|
|
+ procedure Assign(Obj:TFPList);
|
|
|
+ function Remove(Item: Pointer): 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]: Pointer read Get write Put; default;
|
|
|
+ property List: PPointerList read FList;
|
|
|
+ end;
|
|
|
+
|
|
|
+{*******************************************************
|
|
|
+ TFPObjectList (From fcl/inc/contnrs.pp)
|
|
|
+********************************************************}
|
|
|
+
|
|
|
+ TObjectListCallback = procedure(data:TObject;arg:pointer) of object;
|
|
|
+ TObjectListStaticCallback = procedure(data:TObject;arg:pointer);
|
|
|
+
|
|
|
+ TFPObjectList = class(TObject)
|
|
|
+ private
|
|
|
+ FFreeObjects : Boolean;
|
|
|
+ FList: TFPList;
|
|
|
+ function GetCount: integer;
|
|
|
+ procedure SetCount(const AValue: integer);
|
|
|
+ protected
|
|
|
+ function GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+ procedure SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+ procedure SetCapacity(NewCapacity: Integer);
|
|
|
+ function GetCapacity: integer;
|
|
|
+ public
|
|
|
+ constructor Create;
|
|
|
+ constructor Create(FreeObjects : Boolean);
|
|
|
+ destructor Destroy; override;
|
|
|
+ procedure Clear;
|
|
|
+ function Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+ procedure Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+ procedure Exchange(Index1, Index2: Integer);
|
|
|
+ function Expand: TFPObjectList;
|
|
|
+ function Extract(Item: TObject): TObject;
|
|
|
+ function Remove(AObject: TObject): Integer;
|
|
|
+ function IndexOf(AObject: TObject): Integer;
|
|
|
+ function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
|
|
|
+ procedure Insert(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+ function First: TObject;
|
|
|
+ function Last: TObject;
|
|
|
+ procedure Move(CurIndex, NewIndex: Integer);
|
|
|
+ procedure Assign(Obj:TFPObjectList);
|
|
|
+ procedure Pack;
|
|
|
+ procedure Sort(Compare: TListSortCompare);
|
|
|
+ procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer);
|
|
|
+ procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
|
|
|
+ property Capacity: Integer read GetCapacity write SetCapacity;
|
|
|
+ property Count: Integer read GetCount write SetCount;
|
|
|
+ property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
|
|
|
+ property Items[Index: Integer]: TObject read GetItem write SetItem; default;
|
|
|
+ property List: TFPList read FList;
|
|
|
+ end;
|
|
|
|
|
|
{********************************************
|
|
|
TLinkedList
|
|
@@ -404,371 +452,500 @@ implementation
|
|
|
|
|
|
|
|
|
{*****************************************************************************
|
|
|
- TList
|
|
|
+ TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
|
|
|
*****************************************************************************}
|
|
|
|
|
|
Const
|
|
|
- // Ratio of Pointer and Word Size.
|
|
|
- WordRatio = SizeOf(Pointer) Div SizeOf(Word);
|
|
|
-
|
|
|
-function TList.Get(Index: Integer): Pointer;
|
|
|
+ // Ratio of Pointer and Word Size.
|
|
|
+ WordRatio = SizeOf(Pointer) Div SizeOf(Word);
|
|
|
|
|
|
+procedure TFPList.RaiseIndexError(Index : Integer);
|
|
|
begin
|
|
|
- If (Index<0) or (Index>=FCount) then
|
|
|
- Error(SListIndexError,Index);
|
|
|
- Result:=FList^[Index];
|
|
|
+ Error(SListIndexError, Index);
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-
|
|
|
-procedure TList.Grow;
|
|
|
-
|
|
|
+function TFPList.Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
begin
|
|
|
- // Only for compatibility with Delphi. Not needed.
|
|
|
+ If (Index < 0) or (Index >= FCount) then
|
|
|
+ RaiseIndexError(Index);
|
|
|
+ Result:=FList^[Index];
|
|
|
end;
|
|
|
|
|
|
+procedure TFPList.Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+begin
|
|
|
+ if (Index < 0) or (Index >= FCount) then
|
|
|
+ RaiseIndexError(Index);
|
|
|
+ Flist^[Index] := Item;
|
|
|
+end;
|
|
|
|
|
|
-
|
|
|
-procedure TList.Put(Index: Integer; Item: Pointer);
|
|
|
-
|
|
|
+function TFPList.Extract(item: Pointer): Pointer;
|
|
|
+var
|
|
|
+ i : Integer;
|
|
|
begin
|
|
|
- if (Index<0) or (Index>=FCount) then
|
|
|
- Error(SListIndexError,Index);
|
|
|
- Flist^[Index]:=Item;
|
|
|
+ result := nil;
|
|
|
+ i := IndexOf(item);
|
|
|
+ if i >= 0 then
|
|
|
+ begin
|
|
|
+ Result := item;
|
|
|
+ FList^[i] := nil;
|
|
|
+ Delete(i);
|
|
|
+ end;
|
|
|
end;
|
|
|
|
|
|
+procedure TFPList.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;
|
|
|
|
|
|
-function TList.Extract(item: Pointer): Pointer;
|
|
|
-var
|
|
|
- i : Integer;
|
|
|
+procedure TFPList.SetCount(NewCount: Integer);
|
|
|
begin
|
|
|
- result:=nil;
|
|
|
- i:=IndexOf(item);
|
|
|
- if i>=0 then
|
|
|
+ if (NewCount < 0) or (NewCount > MaxListSize)then
|
|
|
+ Error(SListCountError, NewCount);
|
|
|
+ If NewCount > FCount then
|
|
|
begin
|
|
|
- Result:=item;
|
|
|
- FList^[i]:=nil;
|
|
|
- Delete(i);
|
|
|
+ If NewCount > FCapacity then
|
|
|
+ SetCapacity(NewCount);
|
|
|
+ If FCount < NewCount then
|
|
|
+ FillWord(Flist^[FCount], (NewCount-FCount) * WordRatio, 0);
|
|
|
end;
|
|
|
+ FCount := Newcount;
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-procedure TList.SetCapacity(NewCapacity: Integer);
|
|
|
+destructor TFPList.Destroy;
|
|
|
begin
|
|
|
- If (NewCapacity<0) or (NewCapacity>MaxListSize) then
|
|
|
- Error (SListCapacityError,NewCapacity);
|
|
|
- if NewCapacity=FCapacity then
|
|
|
- exit;
|
|
|
- ReallocMem(FList,SizeOf(Pointer)*NewCapacity);
|
|
|
- if NewCapacity > FCapacity then
|
|
|
- FillChar (FList^ [FCapacity],
|
|
|
- (NewCapacity - FCapacity) * SizeOf (pointer), 0);
|
|
|
- FCapacity:=NewCapacity;
|
|
|
+ Self.Clear;
|
|
|
+ inherited Destroy;
|
|
|
end;
|
|
|
|
|
|
+function TFPList.Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+begin
|
|
|
+ if FCount = FCapacity then
|
|
|
+ Self.Expand;
|
|
|
+ FList^[FCount] := Item;
|
|
|
+ Result := FCount;
|
|
|
+ FCount := FCount + 1;
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPList.Clear;
|
|
|
+begin
|
|
|
+ if Assigned(FList) then
|
|
|
+ begin
|
|
|
+ SetCount(0);
|
|
|
+ SetCapacity(0);
|
|
|
+ FList := nil;
|
|
|
+ end;
|
|
|
+end;
|
|
|
|
|
|
-procedure TList.SetCount(NewCount: Integer);
|
|
|
+procedure TFPList.Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+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 TFPList.Error(const Msg: string; Data: PtrInt);
|
|
|
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;
|
|
|
+ Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
|
|
end;
|
|
|
|
|
|
+procedure TFPList.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 TFPList.Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+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;
|
|
|
|
|
|
-destructor TList.Destroy;
|
|
|
+function TFPList.First: Pointer;
|
|
|
+begin
|
|
|
+ If FCount = 0 then
|
|
|
+ Result := Nil
|
|
|
+ else
|
|
|
+ Result := Items[0];
|
|
|
+end;
|
|
|
|
|
|
+function TFPList.IndexOf(Item: Pointer): Integer;
|
|
|
begin
|
|
|
- Self.Clear;
|
|
|
- inherited Destroy;
|
|
|
+ Result := 0;
|
|
|
+ while(Result < FCount) and (Flist^[Result] <> Item) do Result := Result + 1;
|
|
|
+ If Result = FCount then Result := -1;
|
|
|
end;
|
|
|
|
|
|
+procedure TFPList.Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
|
|
+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 TList.Add(Item: Pointer): Integer;
|
|
|
+function TFPList.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 TFPList.Move(CurIndex, NewIndex: Integer);
|
|
|
+var
|
|
|
+ Temp : Pointer;
|
|
|
begin
|
|
|
- Self.Insert (Count,Item);
|
|
|
- Result:=Count-1;
|
|
|
+ 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 TFPList.Remove(Item: Pointer): Integer;
|
|
|
+begin
|
|
|
+ Result := IndexOf(Item);
|
|
|
+ If Result <> -1 then
|
|
|
+ Self.Delete(Result);
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPList.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;
|
|
|
|
|
|
-Procedure TList.Clear;
|
|
|
+// Needed by Sort method.
|
|
|
|
|
|
+Procedure QuickSort(FList: PPointerList; L, R : Longint;
|
|
|
+ Compare: TListSortCompare);
|
|
|
+var
|
|
|
+ I, J : Longint;
|
|
|
+ P, Q : Pointer;
|
|
|
begin
|
|
|
- If Assigned(FList) then
|
|
|
+ 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
|
|
|
- FreeMem (Flist,FCapacity*SizeOf(Pointer));
|
|
|
- FList:=Nil;
|
|
|
- FCapacity:=0;
|
|
|
- FCount:=0;
|
|
|
+ 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.Delete(Index: Integer);
|
|
|
+procedure TFPList.Sort(Compare: TListSortCompare);
|
|
|
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 appropiate
|
|
|
- if (FCapacity > 256) and (FCount < FCapacity shr 2) then
|
|
|
- begin
|
|
|
- FCapacity := FCapacity shr 1;
|
|
|
- ReallocMem(FList, SizeOf(Pointer) * FCapacity);
|
|
|
- end;
|
|
|
+ if Not Assigned(FList) or (FCount < 2) then exit;
|
|
|
+ QuickSort(Flist, 0, FCount-1, Compare);
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-class procedure TList.Error(const Msg: string; Data: Integer);
|
|
|
-{$ifdef EXTDEBUG}
|
|
|
+procedure TFPList.Assign(Obj: TFPList);
|
|
|
var
|
|
|
- s : string;
|
|
|
-{$endif EXTDEBUG}
|
|
|
+ i: Integer;
|
|
|
begin
|
|
|
-{$ifdef EXTDEBUG}
|
|
|
- s:=Msg;
|
|
|
- Replace(s,'%d',ToStr(Data));
|
|
|
- writeln(s);
|
|
|
-{$endif EXTDEBUG}
|
|
|
- internalerrorproc(200411151);
|
|
|
+ Clear;
|
|
|
+ for I := 0 to Obj.Count - 1 do
|
|
|
+ Add(Obj[i]);
|
|
|
end;
|
|
|
|
|
|
-procedure TList.Exchange(Index1, Index2: Integer);
|
|
|
-
|
|
|
-var Temp : Pointer;
|
|
|
|
|
|
+procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
|
|
|
+var
|
|
|
+ i : integer;
|
|
|
+ p : 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;
|
|
|
+ For I:=0 To Count-1 Do
|
|
|
+ begin
|
|
|
+ p:=FList^[i];
|
|
|
+ if assigned(p) then
|
|
|
+ proc2call(p,arg);
|
|
|
+ end;
|
|
|
end;
|
|
|
|
|
|
|
|
|
-
|
|
|
-function TList.Expand: TList;
|
|
|
-
|
|
|
-Var IncSize : Longint;
|
|
|
-
|
|
|
+procedure TFPList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
|
|
+var
|
|
|
+ i : integer;
|
|
|
+ p : pointer;
|
|
|
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;
|
|
|
+ For I:=0 To Count-1 Do
|
|
|
+ begin
|
|
|
+ p:=FList^[i];
|
|
|
+ if assigned(p) then
|
|
|
+ proc2call(p,arg);
|
|
|
+ end;
|
|
|
end;
|
|
|
|
|
|
|
|
|
-function TList.First: Pointer;
|
|
|
+{*****************************************************************************
|
|
|
+ TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
|
|
|
+*****************************************************************************}
|
|
|
|
|
|
+constructor TFPObjectList.Create(FreeObjects : boolean);
|
|
|
begin
|
|
|
- If FCount=0 then
|
|
|
- Result:=Nil
|
|
|
- else
|
|
|
- Result:=Items[0];
|
|
|
+ Create;
|
|
|
+ FFreeObjects := Freeobjects;
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-
|
|
|
-function TList.IndexOf(Item: Pointer): Integer;
|
|
|
-
|
|
|
+destructor TFPObjectList.Destroy;
|
|
|
begin
|
|
|
- Result:=0;
|
|
|
- While (Result<FCount) and (Flist^[Result]<>Item) do Result:=Result+1;
|
|
|
- If Result=FCount then Result:=-1;
|
|
|
+ if (FList <> nil) then
|
|
|
+ begin
|
|
|
+ Clear;
|
|
|
+ FList.Destroy;
|
|
|
+ end;
|
|
|
+ inherited Destroy;
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-
|
|
|
-procedure TList.Insert(Index: Integer; Item: Pointer);
|
|
|
-
|
|
|
+procedure TFPObjectList.Clear;
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
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 FFreeObjects then
|
|
|
+ for i := 0 to FList.Count - 1 do
|
|
|
+ TObject(FList[i]).Free;
|
|
|
+ FList.Clear;
|
|
|
end;
|
|
|
|
|
|
-
|
|
|
-
|
|
|
-function TList.Last: Pointer;
|
|
|
-
|
|
|
+constructor TFPObjectList.Create;
|
|
|
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];
|
|
|
+ inherited Create;
|
|
|
+ FList := TFPList.Create;
|
|
|
+ FFreeObjects := True;
|
|
|
end;
|
|
|
|
|
|
+function TFPObjectList.GetCount: integer;
|
|
|
+begin
|
|
|
+ Result := FList.Count;
|
|
|
+end;
|
|
|
|
|
|
-procedure TList.Move(CurIndex, NewIndex: Integer);
|
|
|
+procedure TFPObjectList.SetCount(const AValue: integer);
|
|
|
+begin
|
|
|
+ if FList.Count <> AValue then
|
|
|
+ FList.Count := AValue;
|
|
|
+end;
|
|
|
|
|
|
-Var Temp : Pointer;
|
|
|
+function TFPObjectList.GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ Result := TObject(FList[Index]);
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPObjectList.SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
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;
|
|
|
+ if OwnsObjects then
|
|
|
+ TObject(FList[Index]).Free;
|
|
|
+ FList[index] := AObject;
|
|
|
end;
|
|
|
|
|
|
+procedure TFPObjectList.SetCapacity(NewCapacity: Integer);
|
|
|
+begin
|
|
|
+ FList.Capacity := NewCapacity;
|
|
|
+end;
|
|
|
|
|
|
-function TList.Remove(Item: Pointer): Integer;
|
|
|
+function TFPObjectList.GetCapacity: integer;
|
|
|
+begin
|
|
|
+ Result := FList.Capacity;
|
|
|
+end;
|
|
|
|
|
|
+function TFPObjectList.Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
begin
|
|
|
- Result:=IndexOf(Item);
|
|
|
- If Result<>-1 then
|
|
|
- Self.Delete (Result);
|
|
|
+ Result := FList.Add(AObject);
|
|
|
end;
|
|
|
|
|
|
+procedure TFPObjectList.Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ if OwnsObjects then
|
|
|
+ TObject(FList[Index]).Free;
|
|
|
+ FList.Delete(Index);
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPObjectList.Exchange(Index1, Index2: Integer);
|
|
|
+begin
|
|
|
+ FList.Exchange(Index1, Index2);
|
|
|
+end;
|
|
|
|
|
|
-Procedure TList.Pack;
|
|
|
+function TFPObjectList.Expand: TFPObjectList;
|
|
|
+begin
|
|
|
+ FList.Expand;
|
|
|
+ Result := Self;
|
|
|
+end;
|
|
|
|
|
|
-Var {Last,I,J,}Runner : Longint;
|
|
|
+function TFPObjectList.Extract(Item: TObject): TObject;
|
|
|
+begin
|
|
|
+ Result := TObject(FList.Extract(Item));
|
|
|
+end;
|
|
|
|
|
|
+function TFPObjectList.Remove(AObject: TObject): Integer;
|
|
|
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;
|
|
|
-}
|
|
|
+ Result := IndexOf(AObject);
|
|
|
+ if (Result <> -1) then
|
|
|
+ begin
|
|
|
+ if OwnsObjects then
|
|
|
+ TObject(FList[Result]).Free;
|
|
|
+ FList.Delete(Result);
|
|
|
+ end;
|
|
|
end;
|
|
|
|
|
|
-// Needed by Sort method.
|
|
|
+function TFPObjectList.IndexOf(AObject: TObject): Integer;
|
|
|
+begin
|
|
|
+ Result := FList.IndexOf(Pointer(AObject));
|
|
|
+end;
|
|
|
|
|
|
-Procedure QuickSort (Flist : PPointerList; L,R : Longint;
|
|
|
- Compare : TListSortCompare);
|
|
|
+function TFPObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer;
|
|
|
+var
|
|
|
+ I : Integer;
|
|
|
+begin
|
|
|
+ I:=AStartAt;
|
|
|
+ Result:=-1;
|
|
|
+ If AExact then
|
|
|
+ while (I<Count) and (Result=-1) do
|
|
|
+ If Items[i].ClassType=AClass then
|
|
|
+ Result:=I
|
|
|
+ else
|
|
|
+ Inc(I)
|
|
|
+ else
|
|
|
+ while (I<Count) and (Result=-1) do
|
|
|
+ If Items[i].InheritsFrom(AClass) then
|
|
|
+ Result:=I
|
|
|
+ else
|
|
|
+ Inc(I);
|
|
|
+end;
|
|
|
|
|
|
-Var I,J : Longint;
|
|
|
- P,Q : Pointer;
|
|
|
+procedure TFPObjectList.Insert(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ FList.Insert(Index, Pointer(AObject));
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPObjectList.Move(CurIndex, NewIndex: Integer);
|
|
|
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;
|
|
|
+ FList.Move(CurIndex, NewIndex);
|
|
|
end;
|
|
|
|
|
|
-procedure TList.Sort(Compare: TListSortCompare);
|
|
|
+procedure TFPObjectList.Assign(Obj: TFPObjectList);
|
|
|
+var
|
|
|
+ i: Integer;
|
|
|
+begin
|
|
|
+ Clear;
|
|
|
+ for I := 0 to Obj.Count - 1 do
|
|
|
+ Add(Obj[i]);
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPObjectList.Pack;
|
|
|
begin
|
|
|
- If Not Assigned(FList) or (FCount<2) then exit;
|
|
|
- QuickSort (Flist, 0, FCount-1,Compare);
|
|
|
+ FList.Pack;
|
|
|
end;
|
|
|
|
|
|
-procedure TList.Assign(Obj:TList);
|
|
|
-// Principle copied from TCollection
|
|
|
+procedure TFPObjectList.Sort(Compare: TListSortCompare);
|
|
|
+begin
|
|
|
+ FList.Sort(Compare);
|
|
|
+end;
|
|
|
|
|
|
-var i : Integer;
|
|
|
+function TFPObjectList.First: TObject;
|
|
|
begin
|
|
|
- Clear;
|
|
|
- For I:=0 To Obj.Count-1 Do
|
|
|
- Add(Obj[i]);
|
|
|
+ Result := TObject(FList.First);
|
|
|
end;
|
|
|
|
|
|
+function TFPObjectList.Last: TObject;
|
|
|
+begin
|
|
|
+ Result := TObject(FList.Last);
|
|
|
+end;
|
|
|
|
|
|
- procedure TList.foreach(proc2call:TListCallback;arg:pointer);
|
|
|
- var
|
|
|
- i : longint;
|
|
|
- p : pointer;
|
|
|
- begin
|
|
|
- For I:=0 To Count-1 Do
|
|
|
- begin
|
|
|
- p:=FList^[i];
|
|
|
- if assigned(p) then
|
|
|
- proc2call(p,arg);
|
|
|
- end;
|
|
|
- end;
|
|
|
+procedure TFPObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
|
|
|
+begin
|
|
|
+ FList.ForEachCall(TListCallBack(proc2call),arg);
|
|
|
+end;
|
|
|
|
|
|
+procedure TFPObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
|
|
|
+begin
|
|
|
+ FList.ForEachCall(TListStaticCallBack(proc2call),arg);
|
|
|
+end;
|
|
|
|
|
|
- procedure TList.foreach_static(proc2call:TListStaticCallback;arg:pointer);
|
|
|
- var
|
|
|
- i : longint;
|
|
|
- p : pointer;
|
|
|
- begin
|
|
|
- For I:=0 To Count-1 Do
|
|
|
- begin
|
|
|
- p:=FList^[i];
|
|
|
- if assigned(p) then
|
|
|
- proc2call(p,arg);
|
|
|
- end;
|
|
|
- end;
|
|
|
|
|
|
{****************************************************************************
|
|
|
TLinkedListItem
|