Fix for Mantis #21064.

* pgenutil.pas: factor out the reading of generic specialization parameters (parse_generic_specialization_types) and the generation of a generic type name (generate_generic_name)
* pdecsub.pas, parse_proc_head:
    * also allow an interface alias declaration if an identifier is followed by a "<" (which starts a specialization)
    + add a procedure "consume_generic_interface" which parses such a specialization (by using "parse_generic_specialization_types") - this is needed, because "consume_generic_type_parameter" can (and should not!) handle "ISomeIntf<Integer, T>" or (somewhen in the future) "ISomeIntf<TSomeOtherGeneric<T>>" - and finds the correct symbol for the interface (by utilizing the "generate_generic_name" function)
    * generate the correct mapping entry (for the generic it's only needed for checking (if any), but for a specialization it's essential that we reference the correct specialization)

+ add tests which were included with the issue and also two additional ones

Note: In non-Delphi modes an interface alias can be done like in Delphi mode; "specialization" is not necessary and furthermore not even allowed!

git-svn-id: trunk@21656 -

.gitattributes

@@ -10717,6 +10717,8 @@ tests/test/tgeneric74.pp svneol=native#text/pascal
 tests/test/tgeneric75.pp svneol=native#text/pascal
 tests/test/tgeneric76.pp svneol=native#text/pascal
 tests/test/tgeneric77.pp svneol=native#text/pascal
+tests/test/tgeneric78.pp svneol=native#text/pascal
+tests/test/tgeneric79.pp svneol=native#text/pascal
 tests/test/tgeneric8.pp svneol=native#text/plain
 tests/test/tgeneric9.pp svneol=native#text/plain
 tests/test/tgoto.pp svneol=native#text/plain
@@ -12591,6 +12593,8 @@ tests/webtbs/tw20995b.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/tw21064a.pp svneol=native#text/pascal
+tests/webtbs/tw21064b.pp svneol=native#text/pascal
 tests/webtbs/tw21073.pp svneol=native#text/plain
 tests/webtbs/tw2109.pp svneol=native#text/plain
 tests/webtbs/tw21091.pp svneol=native#text/pascal

compiler/pdecsub.pas

@@ -106,7 +106,7 @@ implementation
        objcutil,
        { parser }
        scanner,
-       pbase,pexpr,ptype,pdecl,pparautl
+       pbase,pexpr,ptype,pdecl,pparautl,pgenutil
 {$ifdef jvm}
        ,pjvm
 {$endif}
@@ -680,8 +680,44 @@ implementation
                     Message1(type_e_generic_declaration_does_not_match,genname);
                     srsym:=nil;
                     exit;
+                  end
+              end;
+          end;
+
+        procedure consume_generic_interface;
+          var
+            genparalist : tfpobjectlist;
+            prettyname,
+            specializename : ansistring;
+            genname,
+            ugenname : tidstring;
+            gencount : string;
+          begin
+            consume(_LSHARPBRACKET);
+            genparalist:=tfpobjectlist.create(false);
+
+            if not parse_generic_specialization_types(genparalist,prettyname,specializename,nil) then
+              srsym:=generrorsym
+            else
+              begin
+                str(genparalist.count,gencount);
+                genname:=sp+'$'+gencount;
+                if not parse_generic then
+                  genname:=generate_generic_name(genname,specializename);
+                ugenname:=upper(genname);
+
+                srsym:=search_object_name(ugenname,false);
+
+                if not assigned(srsym) then
+                  begin
+                    Message1(type_e_generic_declaration_does_not_match,sp+'<'+prettyname+'>');
+                    srsym:=nil;
+                    exit;
                   end;
               end;
+
+            genparalist.free;
+            consume(_RSHARPBRACKET);
           end;
 
       begin
@@ -700,16 +736,35 @@ implementation
            (astruct.typ=objectdef) and
            assigned(tobjectdef(astruct).ImplementedInterfaces) and
            (tobjectdef(astruct).ImplementedInterfaces.count>0) and
-           try_to_consume(_POINT) then
+           (
+             (token = _POINT) or
+             (token = _LSHARPBRACKET)
+           ) then
          begin
-           srsym:=search_object_name(sp,true);
+           if token = _POINT then
+             begin
+               consume(_POINT);
+               srsym:=search_object_name(sp,true);
+             end
+           else
+             begin
+               consume_generic_interface;
+               consume(_POINT);
+               { srsym is now either an interface def or generrordef }
+             end;
            { qualifier is interface? }
            ImplIntf:=nil;
            if (srsym.typ=typesym) and
               (ttypesym(srsym).typedef.typ=objectdef) then
              ImplIntf:=tobjectdef(astruct).find_implemented_interface(tobjectdef(ttypesym(srsym).typedef));
            if ImplIntf=nil then
-             Message(parser_e_interface_id_expected);
+             Message(parser_e_interface_id_expected)
+           else
+             { in case of a generic or specialized interface we need to use the
+               name of the def instead of the symbol, so that always the correct
+               name is used }
+             if [df_generic,df_specialization]*ttypesym(srsym).typedef.defoptions<>[] then
+               sp:=tobjectdef(ttypesym(srsym).typedef).objname^;
            { must be a directly implemented interface }
            if Assigned(ImplIntf.ImplementsGetter) then
              Message2(parser_e_implements_no_mapping,ImplIntf.IntfDef.typename,astruct.objrealname^);

compiler/pgenutil.pas

@@ -36,8 +36,10 @@ uses
 
     procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string);
     function parse_generic_parameters:TFPObjectList;
+    function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean;
     procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
     procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist);
+    function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring;
 
     type
       tspecializationstate = record
@@ -190,59 +192,7 @@ uses
         genericdeflist:=TFPObjectList.Create(false);
 
         { Parse type parameters }
-        err:=false;
-        { set the block type to type, so that the parsed type are returned as
-          ttypenode (e.g. classes are in non type-compatible blocks returned as
-          tloadvmtaddrnode) }
-        old_block_type:=block_type;
-        { if parsedtype is set, then the first type identifer was already parsed
-          (happens in inline specializations) and thus we only need to parse
-          the remaining types and do as if the first one was already given }
-        first:=not assigned(parsedtype);
-        if assigned(parsedtype) then
-          begin
-            genericdeflist.Add(parsedtype);
-            specializename:='$'+parsedtype.typename;
-            prettyname:=parsedtype.typesym.prettyname;
-          end
-        else
-          begin
-            specializename:='';
-            prettyname:='';
-          end;
-        while not (token in [_GT,_RSHARPBRACKET]) do
-          begin
-            { "first" is set to false at the end of the loop! }
-            if not first then
-              consume(_COMMA);
-            block_type:=bt_type;
-            pt2:=factor(false,true);
-            if pt2.nodetype=typen then
-              begin
-                if df_generic in pt2.resultdef.defoptions then
-                  Message(parser_e_no_generics_as_params);
-                genericdeflist.Add(pt2.resultdef);
-                if not assigned(pt2.resultdef.typesym) then
-                  message(type_e_generics_cannot_reference_itself)
-                else
-                  begin
-                    specializename:=specializename+'$'+pt2.resultdef.typename;
-                    if first then
-                      prettyname:=prettyname+pt2.resultdef.typesym.prettyname
-                    else
-                      prettyname:=prettyname+','+pt2.resultdef.typesym.prettyname;
-                  end;
-              end
-            else
-              begin
-                Message(type_e_type_id_expected);
-                err:=true;
-              end;
-            pt2.free;
-            first:=false;
-          end;
-        block_type:=old_block_type;
-
+        err:=not parse_generic_specialization_types(genericdeflist,prettyname,specializename,parsedtype);
         if err then
           begin
             try_to_consume(_RSHARPBRACKET);
@@ -305,8 +255,7 @@ uses
         genericdef:=tstoreddef(ttypesym(srsym).typedef);
 
         { build the new type's name }
-        crc:=UpdateCrc32(0,specializename[1],length(specializename));
-        finalspecializename:=genname+'$crc'+hexstr(crc,8);
+        finalspecializename:=generate_generic_name(genname,specializename);
         ufinalspecializename:=upper(finalspecializename);
         prettyname:=genericdef.typesym.prettyname+'<'+prettyname+'>';
 
@@ -570,6 +519,67 @@ uses
         until not try_to_consume(_COMMA) ;
       end;
 
+    function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean;
+      var
+        old_block_type : tblock_type;
+        first : boolean;
+        typeparam : tnode;
+      begin
+        result:=true;
+        if genericdeflist=nil then
+          internalerror(2012061401);
+        { set the block type to type, so that the parsed type are returned as
+          ttypenode (e.g. classes are in non type-compatible blocks returned as
+          tloadvmtaddrnode) }
+        old_block_type:=block_type;
+        { if parsedtype is set, then the first type identifer was already parsed
+          (happens in inline specializations) and thus we only need to parse
+          the remaining types and do as if the first one was already given }
+        first:=not assigned(parsedtype);
+        if assigned(parsedtype) then
+          begin
+            genericdeflist.Add(parsedtype);
+            specializename:='$'+parsedtype.typename;
+            prettyname:=parsedtype.typesym.prettyname;
+          end
+        else
+          begin
+            specializename:='';
+            prettyname:='';
+          end;
+        while not (token in [_GT,_RSHARPBRACKET]) do
+          begin
+            { "first" is set to false at the end of the loop! }
+            if not first then
+              consume(_COMMA);
+            block_type:=bt_type;
+            typeparam:=factor(false,true);
+            if typeparam.nodetype=typen then
+              begin
+                if df_generic in typeparam.resultdef.defoptions then
+                  Message(parser_e_no_generics_as_params);
+                genericdeflist.Add(typeparam.resultdef);
+                if not assigned(typeparam.resultdef.typesym) then
+                  message(type_e_generics_cannot_reference_itself)
+                else
+                  begin
+                    specializename:=specializename+'$'+typeparam.resultdef.typename;
+                    if first then
+                      prettyname:=prettyname+typeparam.resultdef.typesym.prettyname
+                    else
+                      prettyname:=prettyname+','+typeparam.resultdef.typesym.prettyname;
+                  end;
+              end
+            else
+              begin
+                Message(type_e_type_id_expected);
+                result:=false;
+              end;
+            typeparam.free;
+            first:=false;
+          end;
+        block_type:=old_block_type;
+      end;
 
     procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
       var
@@ -634,6 +644,17 @@ uses
           end;
       end;
 
+    function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring;
+    var
+      crc : cardinal;
+    begin
+      if specializename='' then
+        internalerror(2012061901);
+      { build the new type's name }
+      crc:=UpdateCrc32(0,specializename[1],length(specializename));
+      result:=name+'$crc'+hexstr(crc,8);
+    end;
+
     procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
     var
       pu : tused_unit;

tests/test/tgeneric78.pp

@@ -0,0 +1,27 @@
+{ %NORUN }
+
+{ additional test based on 21064 }
+program tgeneric78;
+
+{$mode delphi}
+
+type
+  IGenericIntf<T> = interface
+    function SomeMethod: T;
+  end;
+
+  TGenericClass<T> = class(TInterfacedObject, IGenericIntf<LongInt>)
+  private
+  protected
+    function GenericIntf_SomeMethod: LongInt;
+    function IGenericIntf<LongInt>.SomeMethod = GenericIntf_SomeMethod;
+  end;
+
+function TGenericClass<T>.GenericIntf_SomeMethod: LongInt;
+begin
+end;
+
+type
+  TGenericClassLongInt = TGenericClass<String>;
+begin
+end.

tests/test/tgeneric79.pp

@@ -0,0 +1,27 @@
+{ %NORUN }
+
+{ additional test based on 21064 }
+program tgeneric79;
+
+{$mode objfpc}
+
+type
+  generic IGenericIntf<T> = interface
+    function SomeMethod: T;
+  end;
+
+  generic TGenericClass<T> = class(TInterfacedObject, specialize IGenericIntf<LongInt>)
+  private
+  protected
+    function GenericIntf_SomeMethod: LongInt;
+    function IGenericIntf<LongInt>.SomeMethod = GenericIntf_SomeMethod;
+  end;
+
+function TGenericClass.GenericIntf_SomeMethod: LongInt;
+begin
+end;
+
+type
+  TGenericClassLongInt = specialize TGenericClass<String>;
+begin
+end.

tests/webtbs/tw21064a.pp

@@ -0,0 +1,26 @@
+{ %NORUN }
+
+program tw21064a;
+
+{$mode delphi}
+
+type
+  IGenericIntf<T> = interface
+    function SomeMethod: T;
+  end;
+
+  TGenericClass<T> = class(TInterfacedObject, IGenericIntf<T>)
+  private
+  protected
+    function GenericIntf_SomeMethod: T;
+    function IGenericIntf<T>.SomeMethod = GenericIntf_SomeMethod;
+  end;
+
+function TGenericClass<T>.GenericIntf_SomeMethod: T;
+begin
+end;
+
+type
+  TGenericClassLongInt = TGenericClass<LongInt>;
+begin
+end.

tests/webtbs/tw21064b.pp

@@ -0,0 +1,28 @@
+{ %NORUN }
+
+program tw21064b;
+
+{$mode delphi}
+
+type
+  IGenericIntf<T> = interface
+    function SomeMethod: T;
+  end;
+
+  TGenericClass<T> = class(TInterfacedObject, IGenericIntf<T>)
+  private
+    type
+      IntfType = IGenericIntf<T>;
+  protected
+    function GenericIntf_SomeMethod: T;
+    function IntfType.SomeMethod = GenericIntf_SomeMethod;
+  end;
+
+function TGenericClass<T>.GenericIntf_SomeMethod: T;
+begin
+end;
+
+type
+  TGenericClassLongInt = TGenericClass<LongInt>;
+begin
+end.