Ver código fonte

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 -
svenbarth 12 anos atrás
pai
commit
68a3827539
4 arquivos alterados com 105 adições e 2 exclusões
  1. 1 0
      .gitattributes
  2. 48 0
      compiler/cclasses.pas
  3. 2 2
      compiler/psub.pas
  4. 54 0
      tests/webtbs/tw21051.pp

+ 1 - 0
.gitattributes

@@ -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

+ 48 - 0
compiler/cclasses.pas

@@ -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
  ****************************************************************************}

+ 2 - 2
compiler/psub.pas

@@ -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 - 0
tests/webtbs/tw21051.pp

@@ -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.