Fix for Mantis #21051. Correctly handle specializations that occur during the specialization of methods.

cclasses.pas:
  + TFPHashList & TFPHashObjectList: add WhileEachCall methods that walk the list like ForEachCall does, but uses a while-loop instead of a for-loop
psub.pas, generate_specialization_procs:
  * use WhileEachCall instead of ForEachCall as new defs can be added during the specialization that need to be specialized as well

+ added test

git-svn-id: trunk@25577 -
This commit is contained in:
svenbarth 2013-09-26 08:15:58 +00:00
parent b45c092186
commit 68a3827539
4 changed files with 105 additions and 2 deletions

1
.gitattributes vendored
View File

@ -13404,6 +13404,7 @@ tests/webtbs/tw20996.pp svneol=native#text/pascal
tests/webtbs/tw20998.pp svneol=native#text/pascal
tests/webtbs/tw21029.pp svneol=native#text/plain
tests/webtbs/tw21044.pp svneol=native#text/pascal
tests/webtbs/tw21051.pp svneol=native#text/pascal
tests/webtbs/tw21064a.pp svneol=native#text/pascal
tests/webtbs/tw21064b.pp svneol=native#text/pascal
tests/webtbs/tw21073.pp svneol=native#text/plain

View File

@ -237,6 +237,8 @@ type
procedure ShowStatistics;
procedure ForEachCall(proc2call:TListCallback;arg:pointer);
procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
procedure WhileEachCall(proc2call:TListCallback;arg:pointer);
procedure WhileEachCall(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;
@ -309,6 +311,8 @@ type
procedure ShowStatistics; {$ifdef CCLASSESINLINE}inline;{$endif}
procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure WhileEachCall(proc2call:TObjectListCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure WhileEachCall(proc2call:TObjectListStaticCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif}
property Capacity: Integer read GetCapacity write SetCapacity;
property Count: Integer read GetCount write SetCount;
property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
@ -1661,6 +1665,38 @@ begin
end;
procedure TFPHashList.WhileEachCall(proc2call:TListCallback;arg:pointer);
var
i : integer;
p : pointer;
begin
i:=0;
while i<count do
begin
p:=FHashList^[i].Data;
if assigned(p) then
proc2call(p,arg);
inc(i);
end;
end;
procedure TFPHashList.WhileEachCall(proc2call:TListStaticCallback;arg:pointer);
var
i : integer;
p : pointer;
begin
i:=0;
while i<count do
begin
p:=FHashList^[i].Data;
if assigned(p) then
proc2call(p,arg);
inc(i);
end;
end;
{*****************************************************************************
TFPHashObject
*****************************************************************************}
@ -1915,6 +1951,18 @@ begin
end;
procedure TFPHashObjectList.WhileEachCall(proc2call:TObjectListCallback;arg:pointer);
begin
FHashList.WhileEachCall(TListCallBack(proc2call),arg);
end;
procedure TFPHashObjectList.WhileEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
begin
FHashList.WhileEachCall(TListStaticCallBack(proc2call),arg);
end;
{****************************************************************************
TLinkedListItem
****************************************************************************}

View File

@ -2343,9 +2343,9 @@ implementation
procedure generate_specialization_procs;
begin
if assigned(current_module.globalsymtable) then
current_module.globalsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
current_module.globalsymtable.SymList.WhileEachCall(@specialize_objectdefs,nil);
if assigned(current_module.localsymtable) then
current_module.localsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
current_module.localsymtable.SymList.WhileEachCall(@specialize_objectdefs,nil);
end;
end.

54
tests/webtbs/tw21051.pp Normal file
View File

@ -0,0 +1,54 @@
{ %NORUN }
program tw21051;
{$mode Delphi}{$H+}
type
TCustomInner<T> = class abstract
protected
function SomeMethod: T; virtual; abstract;
end;
TContainer<T> = class
public
function GetInner: TCustomInner<T>;
end;
TInner<T> = class(TCustomInner<T>)
private
FContainer: TContainer<T>;
protected
function SomeMethod: T; override;
public
constructor Create(AContainer: TContainer<T>);
end;
function TContainer<T>.GetInner: TCustomInner<T>;
type
InnerClass = TInner<T>;
begin
Result := InnerClass.Create(Self);
end;
function TInner<T>.SomeMethod: T;
begin
end;
constructor TInner<T>.Create(AContainer: TContainer<T>);
begin
FContainer := AContainer;
end;
procedure Test;
var
C: TContainer<string>;
begin
C := TContainer<string>.Create;
end;
begin
Test;
end.