mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-19 07:49:10 +02:00
Merged revisions 3068,3070,3114 via svnmerge from
svn+ssh://peter@www.freepascal.org/FPC/svn/fpc/branches/linker/compiler r3068 | peter | 2006-03-28 15:02:06 +0100 (Tue, 28 Mar 2006) | 2 lines * Add new TFPHashList and TFPHashObjectList r3070 | peter | 2006-03-29 07:39:04 +0100 (Wed, 29 Mar 2006) | 2 lines * fix compile r3114 | peter | 2006-04-01 23:47:50 +0100 (Sat, 01 Apr 2006) | 3 lines * remove debug writelns * enable vtable optimizer with -Xv git-svn-id: trunk@3116 -
This commit is contained in:
parent
be88cd47b2
commit
fc6e4adf74
@ -48,17 +48,18 @@ interface
|
||||
end;
|
||||
|
||||
{*******************************************************
|
||||
TFPObjectList (From rtl/objpas/classes/classesh.inc)
|
||||
TFPList (From rtl/objpas/classes/classesh.inc)
|
||||
********************************************************}
|
||||
|
||||
const
|
||||
MaxListSize = Maxint div 16;
|
||||
SListIndexError = 'List index exceeds bounds (%d)';
|
||||
SListCapacityError = 'The maximum list capacity is reached (%d)';
|
||||
SListCountError = 'List count too large (%d)';
|
||||
type
|
||||
EListError = class(Exception);
|
||||
|
||||
const
|
||||
MaxListSize = Maxint div 16;
|
||||
type
|
||||
PPointerList = ^TPointerList;
|
||||
TPointerList = array[0..MaxListSize - 1] of Pointer;
|
||||
@ -103,6 +104,7 @@ type
|
||||
property List: PPointerList read FList;
|
||||
end;
|
||||
|
||||
|
||||
{*******************************************************
|
||||
TFPObjectList (From fcl/inc/contnrs.pp)
|
||||
********************************************************}
|
||||
@ -150,6 +152,125 @@ type
|
||||
property List: TFPList read FList;
|
||||
end;
|
||||
|
||||
type
|
||||
THashItem=record
|
||||
HashValue : LongWord;
|
||||
StrIndex : Integer;
|
||||
NextIndex : Integer;
|
||||
Data : Pointer;
|
||||
end;
|
||||
|
||||
const
|
||||
MaxHashListSize = Maxint div 16;
|
||||
MaxHashStrSize = Maxint;
|
||||
MaxHashTableSize = Maxint div 4;
|
||||
MaxItemsPerHash = 3;
|
||||
|
||||
type
|
||||
PHashItemList = ^THashItemList;
|
||||
THashItemList = array[0..MaxHashListSize - 1] of THashItem;
|
||||
PHashTable = ^THashTable;
|
||||
THashTable = array[0..MaxHashTableSize - 1] of Integer;
|
||||
|
||||
TFPHashList = class(TObject)
|
||||
private
|
||||
{ ItemList }
|
||||
FHashList : PHashItemList;
|
||||
FCount,
|
||||
FCapacity : Integer;
|
||||
{ Hash }
|
||||
FHashTable : PHashTable;
|
||||
FHashCapacity : Integer;
|
||||
{ Strings }
|
||||
FStrs : PChar;
|
||||
FStrCount,
|
||||
FStrCapacity : Integer;
|
||||
protected
|
||||
function Get(Index: Integer): Pointer;
|
||||
procedure SetCapacity(NewCapacity: Integer);
|
||||
procedure SetCount(NewCount: Integer);
|
||||
Procedure RaiseIndexError(Index : Integer);
|
||||
function AddStr(const s:string): Integer;
|
||||
procedure AddToHashTable(Index: Integer);
|
||||
procedure StrExpand(MinIncSize:Integer);
|
||||
procedure SetStrCapacity(NewCapacity: Integer);
|
||||
procedure SetHashCapacity(NewCapacity: Integer);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
function Add(const AName:string;Item: Pointer): Integer;
|
||||
procedure Clear;
|
||||
function NameOfIndex(Index: Integer): String;
|
||||
procedure Delete(Index: Integer);
|
||||
class procedure Error(const Msg: string; Data: PtrInt);
|
||||
function Expand: TFPHashList;
|
||||
function Extract(item: Pointer): Pointer;
|
||||
function IndexOf(Item: Pointer): Integer;
|
||||
function Find(const s:string): Pointer;
|
||||
function Remove(Item: Pointer): Integer;
|
||||
procedure Pack;
|
||||
procedure ShowStatistics;
|
||||
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; default;
|
||||
property List: PHashItemList read FHashList;
|
||||
end;
|
||||
|
||||
|
||||
{*******************************************************
|
||||
TFPHashObjectList (From fcl/inc/contnrs.pp)
|
||||
********************************************************}
|
||||
|
||||
TFPHashObjectList = class;
|
||||
|
||||
TFPHashObject = class
|
||||
private
|
||||
FOwner : TFPHashObjectList;
|
||||
FIndex : Integer;
|
||||
protected
|
||||
function GetName:string;
|
||||
public
|
||||
constructor Create(HashObjectList:TFPHashObjectList;const s:string);
|
||||
property Name:string read GetName;
|
||||
end;
|
||||
|
||||
TFPHashObjectList = class(TObject)
|
||||
private
|
||||
FFreeObjects : Boolean;
|
||||
FHashList: TFPHashList;
|
||||
function GetCount: integer;
|
||||
procedure SetCount(const AValue: integer);
|
||||
protected
|
||||
function GetItem(Index: Integer): TObject;
|
||||
procedure SetCapacity(NewCapacity: Integer);
|
||||
function GetCapacity: integer;
|
||||
public
|
||||
constructor Create(FreeObjects : boolean = True);
|
||||
destructor Destroy; override;
|
||||
procedure Clear;
|
||||
function Add(const AName:string;AObject: TObject): Integer;
|
||||
function NameOfIndex(Index: Integer): String;
|
||||
procedure Delete(Index: Integer);
|
||||
function Expand: TFPHashObjectList;
|
||||
function Extract(Item: TObject): TObject;
|
||||
function Remove(AObject: TObject): Integer;
|
||||
function IndexOf(AObject: TObject): Integer;
|
||||
function Find(const s:string): TObject;
|
||||
function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
|
||||
procedure Pack;
|
||||
procedure ShowStatistics;
|
||||
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; default;
|
||||
property List: TFPHashList read FHashList;
|
||||
end;
|
||||
|
||||
|
||||
{********************************************
|
||||
TLinkedList
|
||||
********************************************}
|
||||
@ -947,6 +1068,543 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
TFPHashList
|
||||
*****************************************************************************}
|
||||
|
||||
function FPHash1(const s:string):LongWord;
|
||||
Var
|
||||
g : LongWord;
|
||||
p,pmax : pchar;
|
||||
begin
|
||||
result:=0;
|
||||
p:=@s[1];
|
||||
pmax:=@s[length(s)+1];
|
||||
while (p<pmax) do
|
||||
begin
|
||||
result:=result shl 4 + LongWord(p^);
|
||||
g:=result and LongWord($F0000000);
|
||||
if g<>0 then
|
||||
result:=result xor (g shr 24) xor g;
|
||||
inc(p);
|
||||
end;
|
||||
If result=0 then
|
||||
result:=$ffffffff;
|
||||
end;
|
||||
|
||||
function FPHash(const s:string):LongWord;
|
||||
Var
|
||||
p,pmax : pchar;
|
||||
begin
|
||||
result:=0;
|
||||
p:=@s[1];
|
||||
pmax:=@s[length(s)+1];
|
||||
while (p<pmax) do
|
||||
begin
|
||||
result:=((result shl 5) - result) xor LongWord(P^);
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.RaiseIndexError(Index : Integer);
|
||||
begin
|
||||
Error(SListIndexError, Index);
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashList.Get(Index: Integer): Pointer;
|
||||
begin
|
||||
If (Index < 0) or (Index >= FCount) then
|
||||
RaiseIndexError(Index);
|
||||
Result:=FHashList^[Index].Data;
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashList.NameOfIndex(Index: Integer): String;
|
||||
begin
|
||||
If (Index < 0) or (Index >= FCount) then
|
||||
RaiseIndexError(Index);
|
||||
Result:=PShortString(@FStrs[FHashList^[Index].StrIndex])^;
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashList.Extract(item: Pointer): Pointer;
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
result := nil;
|
||||
i := IndexOf(item);
|
||||
if i >= 0 then
|
||||
begin
|
||||
Result := item;
|
||||
Delete(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.SetCapacity(NewCapacity: Integer);
|
||||
begin
|
||||
If (NewCapacity < FCount) or (NewCapacity > MaxHashListSize) then
|
||||
Error (SListCapacityError, NewCapacity);
|
||||
if NewCapacity = FCapacity then
|
||||
exit;
|
||||
ReallocMem(FHashList, NewCapacity*SizeOf(THashItem));
|
||||
FCapacity := NewCapacity;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.SetCount(NewCount: Integer);
|
||||
begin
|
||||
if (NewCount < 0) or (NewCount > MaxHashListSize)then
|
||||
Error(SListCountError, NewCount);
|
||||
If NewCount > FCount then
|
||||
begin
|
||||
If NewCount > FCapacity then
|
||||
SetCapacity(NewCount);
|
||||
If FCount < NewCount then
|
||||
FillChar(FHashList^[FCount], (NewCount-FCount) div Sizeof(THashItem), 0);
|
||||
end;
|
||||
FCount := Newcount;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.SetStrCapacity(NewCapacity: Integer);
|
||||
begin
|
||||
If (NewCapacity < FStrCount) or (NewCapacity > MaxHashStrSize) then
|
||||
Error (SListCapacityError, NewCapacity);
|
||||
if NewCapacity = FStrCapacity then
|
||||
exit;
|
||||
ReallocMem(FStrs, NewCapacity);
|
||||
FStrCapacity := NewCapacity;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.SetHashCapacity(NewCapacity: Integer);
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
If (NewCapacity < 1) then
|
||||
Error (SListCapacityError, NewCapacity);
|
||||
if FHashCapacity=NewCapacity then
|
||||
exit;
|
||||
FHashCapacity:=NewCapacity;
|
||||
ReallocMem(FHashTable, FHashCapacity*sizeof(Integer));
|
||||
{ Rehash }
|
||||
FillDword(FHashTable^,FHashCapacity,LongWord(-1));
|
||||
For i:=0 To FCount-1 Do
|
||||
AddToHashTable(i);
|
||||
end;
|
||||
|
||||
|
||||
constructor TFPHashList.Create;
|
||||
begin
|
||||
SetHashCapacity(1);
|
||||
end;
|
||||
|
||||
|
||||
destructor TFPHashList.Destroy;
|
||||
begin
|
||||
Clear;
|
||||
if assigned(FHashTable) then
|
||||
FreeMem(FHashTable);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashList.AddStr(const s:string): Integer;
|
||||
var
|
||||
Len : Integer;
|
||||
begin
|
||||
len:=length(s)+1;
|
||||
if FStrCount+Len >= FStrCapacity then
|
||||
StrExpand(Len);
|
||||
System.Move(s[0],FStrs[FStrCount],Len);
|
||||
result:=FStrCount;
|
||||
inc(FStrCount,Len);
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.AddToHashTable(Index: Integer);
|
||||
var
|
||||
HashIndex : Integer;
|
||||
begin
|
||||
with FHashList^[Index] do
|
||||
begin
|
||||
if not assigned(Data) then
|
||||
exit;
|
||||
HashIndex:=HashValue mod LongWord(FHashCapacity);
|
||||
NextIndex:=FHashTable^[HashIndex];
|
||||
FHashTable^[HashIndex]:=Index;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashList.Add(const AName:string;Item: Pointer): Integer;
|
||||
begin
|
||||
if FCount = FCapacity then
|
||||
Expand;
|
||||
with FHashList^[FCount] do
|
||||
begin
|
||||
HashValue:=FPHash(AName);
|
||||
Data:=Item;
|
||||
StrIndex:=AddStr(AName);
|
||||
end;
|
||||
AddToHashTable(FCount);
|
||||
Result := FCount;
|
||||
inc(FCount);
|
||||
end;
|
||||
|
||||
procedure TFPHashList.Clear;
|
||||
begin
|
||||
if Assigned(FHashList) then
|
||||
begin
|
||||
FCount:=0;
|
||||
SetCapacity(0);
|
||||
FHashList := nil;
|
||||
end;
|
||||
SetHashCapacity(1);
|
||||
if Assigned(FStrs) then
|
||||
begin
|
||||
FStrCount:=0;
|
||||
SetStrCapacity(0);
|
||||
FStrs := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPHashList.Delete(Index: Integer);
|
||||
begin
|
||||
If (Index<0) or (Index>=FCount) then
|
||||
Error (SListIndexError, Index);
|
||||
FHashList^[Index].Data:=nil;
|
||||
end;
|
||||
|
||||
class procedure TFPHashList.Error(const Msg: string; Data: PtrInt);
|
||||
begin
|
||||
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
|
||||
end;
|
||||
|
||||
function TFPHashList.Expand: TFPHashList;
|
||||
var
|
||||
IncSize : Longint;
|
||||
begin
|
||||
Result := Self;
|
||||
if FCount < FCapacity then
|
||||
exit;
|
||||
IncSize := 4;
|
||||
if FCapacity > 127 then
|
||||
Inc(IncSize, FCapacity shr 2)
|
||||
else if FCapacity > 8 then
|
||||
inc(IncSize,8)
|
||||
else if FCapacity > 3 then
|
||||
inc(IncSize,4);
|
||||
SetCapacity(FCapacity + IncSize);
|
||||
{ Maybe expand hash also }
|
||||
if FCount>FHashCapacity*MaxItemsPerHash then
|
||||
SetHashCapacity(FCount div MaxItemsPerHash);
|
||||
end;
|
||||
|
||||
procedure TFPHashList.StrExpand(MinIncSize:Integer);
|
||||
var
|
||||
IncSize : Longint;
|
||||
begin
|
||||
if FStrCount+MinIncSize < FStrCapacity then
|
||||
exit;
|
||||
IncSize := 64+MinIncSize;
|
||||
if FStrCapacity > 255 then
|
||||
Inc(IncSize, FStrCapacity shr 2);
|
||||
SetStrCapacity(FStrCapacity + IncSize);
|
||||
end;
|
||||
|
||||
function TFPHashList.IndexOf(Item: Pointer): Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
while(Result < FCount) and (FHashList^[Result].Data <> Item) do Result := Result + 1;
|
||||
If Result = FCount then Result := -1;
|
||||
end;
|
||||
|
||||
function TFPHashList.Find(const s:string): Pointer;
|
||||
var
|
||||
CurrHash : LongWord;
|
||||
Index,
|
||||
HashIndex : Integer;
|
||||
Len,
|
||||
LastChar : Char;
|
||||
begin
|
||||
CurrHash:=FPHash(s);
|
||||
HashIndex:=CurrHash mod LongWord(FHashCapacity);
|
||||
Index:=FHashTable^[HashIndex];
|
||||
Len:=Char(Length(s));
|
||||
LastChar:=s[Byte(Len)];
|
||||
while Index<>-1 do
|
||||
begin
|
||||
with FHashList^[Index] do
|
||||
begin
|
||||
if assigned(Data) and
|
||||
(HashValue=CurrHash) and
|
||||
(Len=FStrs[StrIndex]) and
|
||||
(LastChar=FStrs[StrIndex+Byte(Len)]) and
|
||||
(s=PShortString(@FStrs[StrIndex])^) then
|
||||
begin
|
||||
Result:=Data;
|
||||
exit;
|
||||
end;
|
||||
Index:=NextIndex;
|
||||
end;
|
||||
end;
|
||||
Result:=nil;
|
||||
end;
|
||||
|
||||
function TFPHashList.Remove(Item: Pointer): Integer;
|
||||
begin
|
||||
Result := IndexOf(Item);
|
||||
If Result <> -1 then
|
||||
Self.Delete(Result);
|
||||
end;
|
||||
|
||||
procedure TFPHashList.Pack;
|
||||
begin
|
||||
SetCapacity(FCount);
|
||||
SetStrCapacity(FStrCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.ShowStatistics;
|
||||
var
|
||||
HashMean,
|
||||
HashStdDev : Double;
|
||||
Index,
|
||||
i,j : Integer;
|
||||
begin
|
||||
{ Calculate Mean and StdDev }
|
||||
HashMean:=0;
|
||||
HashStdDev:=0;
|
||||
for i:=0 to FHashCapacity-1 do
|
||||
begin
|
||||
j:=0;
|
||||
Index:=FHashTable^[i];
|
||||
while (Index<>-1) do
|
||||
begin
|
||||
inc(j);
|
||||
Index:=FHashList^[Index].NextIndex;
|
||||
end;
|
||||
HashMean:=HashMean+j;
|
||||
HashStdDev:=HashStdDev+Sqr(j);
|
||||
end;
|
||||
HashMean:=HashMean/FHashCapacity;
|
||||
HashStdDev:=(HashStdDev-FHashCapacity*Sqr(HashMean));
|
||||
If FHashCapacity>1 then
|
||||
HashStdDev:=Sqrt(HashStdDev/(FHashCapacity-1))
|
||||
else
|
||||
HashStdDev:=0;
|
||||
{ Print info to stdout }
|
||||
Writeln('HashSize : ',FHashCapacity);
|
||||
Writeln('HashMean : ',HashMean:1:4);
|
||||
Writeln('HashStdDev : ',HashStdDev:1:4);
|
||||
Writeln('ListSize : ',FCount,'/',FCapacity);
|
||||
Writeln('StringSize : ',FStrCount,'/',FStrCapacity);
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.ForEachCall(proc2call:TListCallback;arg:pointer);
|
||||
var
|
||||
i : integer;
|
||||
p : pointer;
|
||||
begin
|
||||
For I:=0 To Count-1 Do
|
||||
begin
|
||||
p:=FHashList^[i].Data;
|
||||
if assigned(p) then
|
||||
proc2call(p,arg);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
|
||||
var
|
||||
i : integer;
|
||||
p : pointer;
|
||||
begin
|
||||
For I:=0 To Count-1 Do
|
||||
begin
|
||||
p:=FHashList^[i].Data;
|
||||
if assigned(p) then
|
||||
proc2call(p,arg);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
TFPHashObject
|
||||
*****************************************************************************}
|
||||
|
||||
constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:string);
|
||||
begin
|
||||
FOwner:=HashObjectList;
|
||||
FIndex:=HashObjectList.Add(s,Self);
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashObject.GetName:string;
|
||||
begin
|
||||
Result:=FOwner.NameOfIndex(FIndex);
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
TFPHashObjectList (Copied from rtl/objpas/classes/lists.inc)
|
||||
*****************************************************************************}
|
||||
|
||||
constructor TFPHashObjectList.Create(FreeObjects : boolean = True);
|
||||
begin
|
||||
inherited Create;
|
||||
FHashList := TFPHashList.Create;
|
||||
FFreeObjects := Freeobjects;
|
||||
end;
|
||||
|
||||
destructor TFPHashObjectList.Destroy;
|
||||
begin
|
||||
if (FHashList <> nil) then
|
||||
begin
|
||||
Clear;
|
||||
FHashList.Destroy;
|
||||
end;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TFPHashObjectList.Clear;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
if FFreeObjects then
|
||||
for i := 0 to FHashList.Count - 1 do
|
||||
TObject(FHashList[i]).Free;
|
||||
FHashList.Clear;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.GetCount: integer;
|
||||
begin
|
||||
Result := FHashList.Count;
|
||||
end;
|
||||
|
||||
procedure TFPHashObjectList.SetCount(const AValue: integer);
|
||||
begin
|
||||
if FHashList.Count <> AValue then
|
||||
FHashList.Count := AValue;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.GetItem(Index: Integer): TObject;
|
||||
begin
|
||||
Result := TObject(FHashList[Index]);
|
||||
end;
|
||||
|
||||
procedure TFPHashObjectList.SetCapacity(NewCapacity: Integer);
|
||||
begin
|
||||
FHashList.Capacity := NewCapacity;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.GetCapacity: integer;
|
||||
begin
|
||||
Result := FHashList.Capacity;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.Add(const AName:string;AObject: TObject): Integer;
|
||||
begin
|
||||
Result := FHashList.Add(AName,AObject);
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.NameOfIndex(Index: Integer): String;
|
||||
begin
|
||||
Result := FHashList.NameOfIndex(Index);
|
||||
end;
|
||||
|
||||
procedure TFPHashObjectList.Delete(Index: Integer);
|
||||
begin
|
||||
if OwnsObjects then
|
||||
TObject(FHashList[Index]).Free;
|
||||
FHashList.Delete(Index);
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.Expand: TFPHashObjectList;
|
||||
begin
|
||||
FHashList.Expand;
|
||||
Result := Self;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.Extract(Item: TObject): TObject;
|
||||
begin
|
||||
Result := TObject(FHashList.Extract(Item));
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.Remove(AObject: TObject): Integer;
|
||||
begin
|
||||
Result := IndexOf(AObject);
|
||||
if (Result <> -1) then
|
||||
begin
|
||||
if OwnsObjects then
|
||||
TObject(FHashList[Result]).Free;
|
||||
FHashList.Delete(Result);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPHashObjectList.IndexOf(AObject: TObject): Integer;
|
||||
begin
|
||||
Result := FHashList.IndexOf(Pointer(AObject));
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashObjectList.Find(const s:string): TObject;
|
||||
begin
|
||||
result:=TObject(FHashList.Find(s));
|
||||
end;
|
||||
|
||||
|
||||
function TFPHashObjectList.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;
|
||||
|
||||
|
||||
procedure TFPHashObjectList.Pack;
|
||||
begin
|
||||
FHashList.Pack;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashObjectList.ShowStatistics;
|
||||
begin
|
||||
FHashList.ShowStatistics;
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
|
||||
begin
|
||||
FHashList.ForEachCall(TListCallBack(proc2call),arg);
|
||||
end;
|
||||
|
||||
|
||||
procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
|
||||
begin
|
||||
FHashList.ForEachCall(TListStaticCallBack(proc2call),arg);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
TLinkedListItem
|
||||
****************************************************************************}
|
||||
|
@ -2258,7 +2258,7 @@ end;
|
||||
initmodeswitches:=fpcmodeswitches;
|
||||
initlocalswitches:=[cs_check_io,cs_typed_const_writable];
|
||||
initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
|
||||
initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
|
||||
initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal{$endif}];
|
||||
initoptimizerswitches:=[];
|
||||
initsourcecodepage:='8859-1';
|
||||
initpackenum:=4;
|
||||
|
@ -133,7 +133,8 @@ than 255 characters. That's why using Ansi Strings}
|
||||
cs_asm_regalloc,cs_asm_tempalloc,cs_asm_nodes,
|
||||
{ linking }
|
||||
cs_link_extern,cs_link_static,cs_link_smart,cs_link_shared,cs_link_deffile,
|
||||
cs_link_strip,cs_link_staticflag,cs_link_on_target,cs_link_internal,
|
||||
cs_link_strip,cs_link_staticflag,cs_link_on_target,cs_link_internal,cs_link_opt_vtable,
|
||||
cs_link_opt_used_sections,
|
||||
cs_link_map,cs_link_pthread
|
||||
);
|
||||
tglobalswitches = set of tglobalswitch;
|
||||
|
@ -1119,7 +1119,6 @@ implementation
|
||||
procedure TExeVTable.AddChild(vt:TExeVTable);
|
||||
begin
|
||||
ChildList.Add(vt);
|
||||
writeln(ExeSymbol.Name,'-',vt.ExeSymbol.Name);
|
||||
end;
|
||||
|
||||
|
||||
@ -1163,7 +1162,6 @@ writeln(ExeSymbol.Name,'-',vt.ExeSymbol.Name);
|
||||
CheckIdx(VTableIdx);
|
||||
if EntryArray[VTableIdx].Used then
|
||||
exit;
|
||||
writeln(ExeSymbol.Name,'(',VTableIdx,')');
|
||||
{ Restore relocation if available }
|
||||
if assigned(EntryArray[VTableIdx].ObjRelocation) then
|
||||
begin
|
||||
@ -1600,19 +1598,22 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
|
||||
VTENTRY and VTINHERIT symbols }
|
||||
if objsym.bind=AB_LOCAL then
|
||||
begin
|
||||
hs:=objsym.name;
|
||||
if (hs[1]='V') then
|
||||
if cs_link_opt_vtable in aktglobalswitches then
|
||||
begin
|
||||
if Copy(hs,1,5)='VTREF' then
|
||||
hs:=objsym.name;
|
||||
if (hs[1]='V') then
|
||||
begin
|
||||
if not assigned(objsym.ObjSection.VTRefList) then
|
||||
objsym.ObjSection.VTRefList:=TFPObjectList.Create(false);
|
||||
objsym.ObjSection.VTRefList.Add(objsym);
|
||||
end
|
||||
else if Copy(hs,1,7)='VTENTRY' then
|
||||
VTEntryList.Add(objsym)
|
||||
else if Copy(hs,1,9)='VTINHERIT' then
|
||||
VTInheritList.Add(objsym);
|
||||
if Copy(hs,1,5)='VTREF' then
|
||||
begin
|
||||
if not assigned(objsym.ObjSection.VTRefList) then
|
||||
objsym.ObjSection.VTRefList:=TFPObjectList.Create(false);
|
||||
objsym.ObjSection.VTRefList.Add(objsym);
|
||||
end
|
||||
else if Copy(hs,1,7)='VTENTRY' then
|
||||
VTEntryList.Add(objsym)
|
||||
else if Copy(hs,1,9)='VTINHERIT' then
|
||||
VTInheritList.Add(objsym);
|
||||
end;
|
||||
end;
|
||||
continue;
|
||||
end;
|
||||
@ -1697,7 +1698,8 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
|
||||
Comment(V_Error,'Entrypoint '+EntryName+' not defined');
|
||||
|
||||
{ Generate VTable tree }
|
||||
BuildVTableTree(VTInheritList,VTEntryList);
|
||||
if cs_link_opt_vtable in aktglobalswitches then
|
||||
BuildVTableTree(VTInheritList,VTEntryList);
|
||||
VTInheritList.Free;
|
||||
VTEntryList.Free;
|
||||
end;
|
||||
@ -2085,23 +2087,26 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
|
||||
DoReloc(TObjRelocation(objsec.ObjRelocations[i]));
|
||||
|
||||
{ Process Virtual Entry calls }
|
||||
for i:=0 to objsec.VTRefList.count-1 do
|
||||
if cs_link_opt_vtable in aktglobalswitches then
|
||||
begin
|
||||
objsym:=TObjSymbol(objsec.VTRefList[i]);
|
||||
hs:=objsym.name;
|
||||
Delete(hs,1,Pos('_',hs));
|
||||
k:=Pos('$$',hs);
|
||||
if k=0 then
|
||||
internalerror(200603314);
|
||||
vtableexesym:=texesymbol(FExeSymbolDict.search(Copy(hs,1,k-1)));
|
||||
val(Copy(hs,k+2,length(hs)-k-1),vtableidx,code);
|
||||
if (code<>0) then
|
||||
internalerror(200603317);
|
||||
if not assigned(vtableexesym) then
|
||||
internalerror(200603315);
|
||||
if not assigned(vtableexesym.vtable) then
|
||||
internalerror(200603316);
|
||||
DoVTableRef(vtableexesym.vtable,vtableidx);
|
||||
for i:=0 to objsec.VTRefList.count-1 do
|
||||
begin
|
||||
objsym:=TObjSymbol(objsec.VTRefList[i]);
|
||||
hs:=objsym.name;
|
||||
Delete(hs,1,Pos('_',hs));
|
||||
k:=Pos('$$',hs);
|
||||
if k=0 then
|
||||
internalerror(200603314);
|
||||
vtableexesym:=texesymbol(FExeSymbolDict.search(Copy(hs,1,k-1)));
|
||||
val(Copy(hs,k+2,length(hs)-k-1),vtableidx,code);
|
||||
if (code<>0) then
|
||||
internalerror(200603317);
|
||||
if not assigned(vtableexesym) then
|
||||
internalerror(200603315);
|
||||
if not assigned(vtableexesym.vtable) then
|
||||
internalerror(200603316);
|
||||
DoVTableRef(vtableexesym.vtable,vtableidx);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
ObjSectionWorkList.Free;
|
||||
|
@ -1251,6 +1251,13 @@ begin
|
||||
'c' : Cshared:=TRUE;
|
||||
't' :
|
||||
include(initglobalswitches,cs_link_staticflag);
|
||||
'v' :
|
||||
begin
|
||||
If UnsetBool(More, j) then
|
||||
exclude(initglobalswitches,cs_link_opt_vtable)
|
||||
else
|
||||
include(initglobalswitches,cs_link_opt_vtable);
|
||||
end;
|
||||
'D' :
|
||||
begin
|
||||
def_system_macro('FPC_LINK_DYNAMIC');
|
||||
|
Loading…
Reference in New Issue
Block a user