Allow the usage of a generic's name without type arguments inside of nested classes inside the generic. This fixes Mantis #19499, but also Mantis #18688.

* symtable.pas:
    + add function "get_generic_in_hierarchy_by_name" which returns a def with the name of the symbol in the given object/record hierarchy (useful only in non-Delphi modes)
    + add function "return_specialization_of_generic" which returns the specialization def of a given class inside the given object/record hierarchy
* pexpr.pas, factor, factor_read_id: instead of checking whether the names of the found symbol and the current_structdef are equal, check whether the generic appears in hierarchy of current_structdef
* ptype.pas:
    * id_type: check whether the found symbol is a generic dummy and we are currently parsing a generic then return the correct def of the generic instead of the dummy one
    * single_type: when using the generic type without type parameters the def must resolve to the specialized def when specializing the class instead of the generic def which the dummy symbol points to
    * read_named_type, expr_type: like in "single_type" we need to resolve the use of the parameterless type name to the correct specialization def instead of the generic def
* pdecobj.pas, object_dec: also set the typesym of the current_structdef as otherwise some assumptions about generics with the above mentioned changes aren't valid anymore (like the def the typesym is unset again afterwards)
+ add tests for both bug reports (the one for 19499 is slightly modified so that it does not contain any errors)

git-svn-id: trunk@21361 -

.gitattributes

@@ -12445,6 +12445,7 @@ tests/webtbs/tw1862.pp svneol=native#text/plain
 tests/webtbs/tw18620.pp svneol=native#text/pascal
 tests/webtbs/tw1863.pp svneol=native#text/plain
 tests/webtbs/tw1867.pp svneol=native#text/plain
+tests/webtbs/tw18688.pp svneol=native#text/pascal
 tests/webtbs/tw18690.pp svneol=native#text/plain
 tests/webtbs/tw18702.pp svneol=native#text/pascal
 tests/webtbs/tw18704.pp svneol=native#text/pascal
@@ -12484,6 +12485,7 @@ tests/webtbs/tw19368.pp svneol=native#text/pascal
 tests/webtbs/tw1938.pp svneol=native#text/plain
 tests/webtbs/tw1948.pp svneol=native#text/plain
 tests/webtbs/tw19498.pp svneol=native#text/pascal
+tests/webtbs/tw19499.pp svneol=native#text/pascal
 tests/webtbs/tw1950.pp svneol=native#text/plain
 tests/webtbs/tw19500.pp svneol=native#text/pascal
 tests/webtbs/tw19511.pp svneol=native#text/pascal

compiler/pdecobj.pas

@@ -1431,6 +1431,7 @@ implementation
               begin
                 olddef:=ttypesym(objsym).typedef;
                 ttypesym(objsym).typedef:=current_structdef;
+                current_structdef.typesym:=objsym;
               end
             else
               olddef:=nil;
@@ -1439,7 +1440,10 @@ implementation
             parse_object_members;
 
             if assigned(olddef) then
-              ttypesym(objsym).typedef:=olddef;
+              begin
+                ttypesym(objsym).typedef:=olddef;
+                current_structdef.typesym:=nil;
+              end;
 
           if not(oo_is_external in current_structdef.objectoptions) then
             begin

compiler/pexpr.pas

@@ -2177,7 +2177,7 @@ implementation
                      assigned(current_structdef) and
                      (df_generic in current_structdef.defoptions) and
                      not (m_delphi in current_settings.modeswitches) and
-                     (upper(srsym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
+                     assigned(get_generic_in_hierarchy_by_name(srsym,current_structdef))
                    )) and
                    { it could be a rename of a generic para }
                    { Note: if this generates false positives we'll need to

compiler/ptype.pas

@@ -339,6 +339,20 @@ implementation
             def:=generrordef;
             exit;
           end;
+         { In non-Delphi modes the class/record name of a generic might be used
+           in the declaration of sub types without type parameters; in that case
+           we need to check by name as the link from the dummy symbol to the
+           current type is not yet established }
+         if (sp_generic_dummy in srsym.symoptions) and
+             assigned(current_structdef) and
+             (df_generic in current_structdef.defoptions) and
+             (ttypesym(srsym).typedef.typ=undefineddef) and
+             not (m_delphi in current_settings.modeswitches) then
+           begin
+             def:=get_generic_in_hierarchy_by_name(srsym,current_structdef);
+             if assigned(def) then
+               exit;
+           end;
         def:=ttypesym(srsym).typedef;
       end;
 
@@ -423,6 +437,17 @@ implementation
               begin
                 def:=current_genericdef
               end
+            { when parsing a nested specialization in non-Delphi mode it might
+              use the name of the topmost generic without type paramaters, thus
+              def will contain the generic definition, but we need a reference
+              to the specialization of that generic }
+            { TODO : only in non-Delphi modes? }
+            else if assigned(current_structdef) and
+                (df_specialization in current_structdef.defoptions) and
+                return_specialization_of_generic(current_structdef,def,t2) then
+              begin
+                def:=t2
+              end
             else if (df_generic in def.defoptions) and
                 not
                   (
@@ -794,6 +819,7 @@ implementation
            lv,hv   : TConstExprInt;
            old_block_type : tblock_type;
            dospecialize : boolean;
+           newdef  : tdef;
         begin
            old_block_type:=block_type;
            dospecialize:=false;
@@ -866,6 +892,7 @@ implementation
                      { in non-Delphi modes we might get a inline specialization
                        without "specialize" or "<T>" of the same type we're
                        currently parsing, so we need to handle that special }
+                     newdef:=nil;
                      if not dospecialize and
                          assigned(ttypenode(pt1).typesym) and
                          (ttypenode(pt1).typesym.typ=typesym) and
@@ -879,15 +906,25 @@ implementation
                              (ttypesym(ttypenode(pt1).typesym).typedef.owner=current_structdef.owner) and
                              (upper(ttypenode(pt1).typesym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
                            ) or (
+                             { this could be a nested specialization which uses
+                               the type name of a surrounding generic to
+                               reference the specialization of said surrounding
+                               class }
                              (df_specialization in current_structdef.defoptions) and
-                             (ttypesym(ttypenode(pt1).typesym).typedef=current_structdef.genericdef)
+                             return_specialization_of_generic(current_structdef,ttypesym(ttypenode(pt1).typesym).typedef,newdef)
                            )
                          )
                          then
                        begin
-                         def:=current_structdef;
-                         { handle nested types }
-                         post_comp_expr_gendef(def);
+                         if assigned(newdef) then
+                           def:=newdef
+                         else
+                           def:=current_structdef;
+                         if assigned(def) then
+                           { handle nested types }
+                           post_comp_expr_gendef(def)
+                         else
+                           def:=generrordef;
                        end;
                    if dospecialize then
                      begin

compiler/symtable.pas

@@ -227,6 +227,8 @@ interface
     function  is_owned_by(childdef,ownerdef:tdef):boolean;
     function  sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
     function  defs_belong_to_same_generic(def1,def2:tdef):boolean;
+    function  get_generic_in_hierarchy_by_name(srsym:tsym;def:tdef):tdef;
+    function  return_specialization_of_generic(nesteddef,genericdef:tdef;out resultdef:tdef):boolean;
     function  is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
     function  is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
     function  is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
@@ -1922,6 +1924,43 @@ implementation
       result:=def1=def2;
     end;
 
+    function get_generic_in_hierarchy_by_name(srsym: tsym; def: tdef): tdef;
+      var
+        uname : string;
+      begin
+        { TODO : check regarding arrays and records declared as their type }
+        if not (def.typ in [recorddef,objectdef]) then
+          internalerror(2012051501);
+        uname:=upper(srsym.realname);
+        repeat
+          if uname=copy(tabstractrecorddef(def).objname^,1,pos('$',tabstractrecorddef(def).objname^)-1) then
+            begin
+              result:=def;
+              exit;
+            end;
+          def:=tdef(def.owner.defowner);
+        until not (def.typ in [recorddef,objectdef]);
+        result:=nil;
+      end;
+
+    function return_specialization_of_generic(nesteddef,genericdef:tdef; out resultdef:tdef):boolean;
+      begin
+        { TODO : check regarding arrays and records declared as their type }
+        if not (nesteddef.typ in [recorddef,objectdef]) then
+          internalerror(2012051601);
+        repeat
+          if tstoreddef(nesteddef).genericdef=genericdef then
+            begin
+              resultdef:=nesteddef;
+              result:=true;
+              exit;
+            end;
+          nesteddef:=tdef(nesteddef.owner.defowner);
+        until not assigned(nesteddef) or not (nesteddef.typ in [recorddef,objectdef]);
+        resultdef:=nil;
+        result:=false;
+      end;
+
     function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
       var
         symownerdef : tabstractrecorddef;

tests/webtbs/tw18688.pp

@@ -0,0 +1,102 @@
+unit tw18688;
+
+{$mode delphi}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+
+  IValueHolder<T> = interface
+    function GetT:T;
+    procedure SetT(NewValue:T);
+  end;
+
+  TValueHolder <T> = class (TInterfacedObject, IValueHolder<T>)
+  private
+    FValue: T;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function GetT:T;
+    procedure SetT(NewValue:T);
+  end;
+
+  RValueHolder<T> = record
+  private
+    type
+      _IValueHolder = IValueHolder<T>;
+      _TValueHolder = TValueHolder<T>;
+    var
+    Ptr: _IValueHolder;
+
+    function GetImpl: _IValueHolder;
+  public
+
+    class operator Implicit (a:RValueHolder<T>):T; inline;
+    class operator Implicit (a:T):RValueHolder<T>; inline;
+
+    function GetValue:T; inline;
+    property V:T read GetValue;
+  end;
+
+  //TObjectValue = TValueHolder<TObject> ;    // works if not commented
+  TObjectValue2 = RValueHolder<TObject> ;
+
+
+implementation
+
+constructor TValueHolder <T>.Create;
+begin
+  FValue := nil
+end;
+
+destructor TValueHolder <T>.Destroy;
+begin
+  FreeAndNil(FValue);
+  inherited;
+end;
+
+
+function TValueHolder <T>.GetT:T;
+begin
+  Result := FValue;
+end;
+
+procedure TValueHolder <T>.SetT(NewValue:T);
+begin
+  if FValue <> NewValue then
+  begin
+    FreeAndNil(FValue);
+    FValue := NewValue;
+  end;
+end;
+
+function RValueHolder<T>.GetImpl: _IValueHolder;
+begin
+  if Pointer(Ptr) = nil then
+  begin
+    Ptr := _TValueHolder.Create;
+  end;
+  Result := Ptr;
+end;
+
+class operator RValueHolder<T>.Implicit (a:RValueHolder<T>):T;
+begin
+  Result:=a.V;
+end;
+
+class operator RValueHolder<T>.Implicit (a:T):RValueHolder<T>;
+begin
+  Result.GetImpl.SetT(a);
+end;
+
+function RValueHolder<T>.GetValue:T;
+begin
+  Result := GetImpl.GetT;
+end;
+
+end.
+

tests/webtbs/tw19499.pp

@@ -0,0 +1,71 @@
+{$MODE OBJFPC} { -*- text -*- }
+program tw19499;
+
+{$apptype console}
+
+type
+   generic THashTable <TKey, TValue> = class
+     type
+      THashTableEnumerator = class
+       private
+         FOwner: THashTable;
+         function GetCurrent(): TValue;
+       public
+         constructor Create(Owner: THashTable);
+         function MoveNext(): Boolean;
+         property Current: TValue read GetCurrent;
+      end;
+      function GetEnumerator(): THashTableEnumerator;
+     // note that this works:
+     var
+      Foo: THashTable;
+      procedure Bar(Arg: THashTable);
+   end;
+
+function THashTable.THashTableEnumerator.GetCurrent(): TValue;
+begin
+// this did not compile in the original test
+//   Result := TValue(nil);
+   Result := Default(TValue);
+end;
+
+constructor THashTable.THashTableEnumerator.Create(Owner: THashTable);
+begin
+   FOwner := Owner;
+end;
+
+function THashTable.THashTableEnumerator.MoveNext(): Boolean;
+begin
+   Result := False;
+end;
+
+function THashTable.GetEnumerator(): THashTableEnumerator;
+begin
+   Result := THashTableEnumerator.Create(Self);
+end;
+
+procedure THashTable.Bar(Arg: THashTable);
+var
+   Quux: THashTable; // this works also
+begin
+end;
+
+type
+   TIntegerToStringHashTable = specialize THashTable<Integer, AnsiString>;
+
+var
+   Test: TIntegerToStringHashTable;
+   S: AnsiString;
+
+begin
+   // this was incorrect in the original test
+   //Test.Create();
+   Test := TIntegerToStringHashTable.Create();
+   try
+      for S in Test do
+         Writeln(S);
+   finally
+      Test.Destroy();
+   end;
+   Writeln('PASS');
+end.