* fix tw3930 after r37927

o "unique" class (and interface) type aliases should actually not exist at
     all except for overload resolution. All the rest (VMT, UUID, RTTI, ...)
     should be taken from the aliased class/interface
   o there is one Delphi-incompatibily left after this change, but it shouldn't
     matter: tw8180 does not compile if you change the declaration to
     "tcl=class(TInterfacedObject,XStr,iinterface)", while Kylix does compile
     that. It doesn't really matter though, because in Kylix this actually
     adds iinterface twice as implemented interface, so there is no point
     in accepting this.

git-svn-id: trunk@46773 -

compiler/ncgrtti.pas

@@ -133,6 +133,9 @@ implementation
                   { Skip forward defs }
                   if (oo_is_forward in tobjectdef(def).objectoptions) then
                     continue;
+                  { skip unique type aliases, they use the RTTI from the parent class }
+                  if tobjectdef(def).is_unique_objpasdef then
+                    continue;
                   write_persistent_type_info(tobjectdef(def).symtable,is_global);
                 end;
               procdef :

compiler/ncgvmt.pas

@@ -699,11 +699,16 @@ implementation
 
     function CreateWrapperName(_class : tobjectdef;AImplIntf : TImplementedInterface;i : longint;pd : tprocdef) : string;
       var
+        realintfdef: tobjectdef;
         tmpstr : AnsiString;
         hs : string;
         crc : DWord;
       begin
-        tmpstr:=_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+tostr(i)+'_$_'+pd.mangledname;
+        realintfdef:=AImplIntf.IntfDef;
+        while realintfdef.is_unique_objpasdef do
+          realintfdef:=realintfdef.childof;
+
+        tmpstr:=_class.objname^+'_$_'+realintfdef.objname^+'_$_'+tostr(i)+'_$_'+pd.mangledname;
         if length(tmpstr)>100 then
           begin
             crc:=0;
@@ -749,14 +754,18 @@ implementation
         pd: tprocdef;
         siid,
         siidstr: tsymstr;
+        nonuniqueintf: tobjectdef;
       begin
+        nonuniqueintf:=AImplIntf.IntfDef;
+        while nonuniqueintf.is_unique_objpasdef do
+          nonuniqueintf:=nonuniqueintf.childof;
         tcb.maybe_begin_aggregate(interfaceentrydef);
         { GUID (or nil for Corba interfaces) }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('IIDREF') as tfieldvarsym;
         siid:='';
-        if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
+        if nonuniqueintf.objecttype in [odt_interfacecom] then
           begin
-            siid:=make_mangledname('IID',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^);
+            siid:=make_mangledname('IID',nonuniqueintf.owner,nonuniqueintf.objname^);
             tcb.emit_tai(Tai_const.Create_sym_offset(
               current_asmdata.RefAsmSymbol(siid,AT_DATA,true),0),cpointerdef.getreusable(rec_tguid));
           end
@@ -766,7 +775,7 @@ implementation
         { VTable }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('VTABLE') as tfieldvarsym;
         tcb.queue_init(voidpointertype);
-        tcb.queue_emit_asmsym(fintfvtablelabels[intfindex],AImplIntf.VtblImplIntf.IntfDef);
+        tcb.queue_emit_asmsym(fintfvtablelabels[intfindex],nonuniqueintf);
         { IOffset field }
         case AImplIntf.VtblImplIntf.IType of
           etFieldValue, etFieldValueClass,
@@ -792,20 +801,20 @@ implementation
 
         { IIDStr }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('IIDSTRREF') as tfieldvarsym;
-        siidstr:=make_mangledname('IIDSTR',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^);
+        siidstr:=make_mangledname('IIDSTR',nonuniqueintf.owner,nonuniqueintf.objname^);
         tcb.queue_init(cpointerdef.getreusable(cshortstringtype));
         tcb.queue_emit_asmsym(
           current_asmdata.RefAsmSymbol(
             siidstr,
             AT_DATA,
             true),
-          cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(AImplIntf.IntfDef.iidstr^)+1)));
+          cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(nonuniqueintf.iidstr^)+1)));
         { IType }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('ITYPE') as tfieldvarsym;
         tcb.emit_ord_const(aint(AImplIntf.VtblImplIntf.IType),interfaceentrytypedef);
         tcb.maybe_end_aggregate(interfaceentrydef);
 
-        if findunitsymtable(AImplIntf.IntfDef.owner).moduleid<>findunitsymtable(_Class.owner).moduleid then
+        if findunitsymtable(nonuniqueintf.owner).moduleid<>findunitsymtable(_Class.owner).moduleid then
           begin
             if siid<>'' then
               current_module.add_extern_asmsym(siid,AB_EXTERNAL,AT_DATA);
@@ -1300,6 +1309,8 @@ implementation
                   if ([df_generic,df_genconstraint]*def.defoptions<>[]) or
                      (oo_is_forward in tobjectdef(def).objectoptions) then
                     continue;
+                  if tobjectdef(def).is_unique_objpasdef then
+                    continue;
                   do_write_vmts(tobjectdef(def).symtable,is_global);
                   { Write also VMT if not done yet }
                   if not(ds_vmt_written in def.defstates) then

compiler/pdecl.pas

@@ -674,7 +674,8 @@ implementation
          gentypename,genorgtypename : TIDString;
          newtype  : ttypesym;
          sym      : tsym;
-         hdef     : tdef;
+         hdef,
+         hdef2    : tdef;
          defpos,storetokenpos : tfileposinfo;
          old_block_type : tblock_type;
          old_checkforwarddefs: TFPObjectList;
@@ -927,9 +928,11 @@ implementation
                       if is_object(hdef) or
                          is_class_or_interface_or_dispinterface(hdef) then
                         begin
-                          { just create a child class type; this is
+                          { just create a copy that is a child of the original class class type; this is
                             Delphi-compatible }
-                          hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
+                          hdef2:=tstoreddef(hdef).getcopy;
+                          tobjectdef(hdef2).childof:=tobjectdef(hdef);
+                          hdef:=hdef2;
                         end
                       else
                         begin
@@ -959,6 +962,7 @@ implementation
                              (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then
                             current_module.checkforwarddefs.add(hdef);
                         end;
+
                       include(hdef.defoptions,df_unique);
                     end;
                   if not assigned(hdef.typesym) then
@@ -1114,7 +1118,7 @@ implementation
                       finalize_class_external_status(tobjectdef(hdef));
 
                     { Build VMT indexes, skip for type renaming and forward classes }
-                    if (hdef.typesym=newtype) and
+                    if not istyperenaming and
                        not(oo_is_forward in tobjectdef(hdef).objectoptions) then
                       build_vmt(tobjectdef(hdef));
 

compiler/symdef.pas

@@ -511,6 +511,7 @@ interface
           function  needs_separate_initrtti : boolean;override;
           function  has_non_trivial_init_child(check_parent:boolean):boolean;override;
           function  rtti_mangledname(rt:trttitype):TSymStr;override;
+          function  is_unique_objpasdef: boolean;
           function  vmt_mangledname : TSymStr;
           function  vmt_def: trecorddef;
           procedure check_forwards; override;
@@ -3900,6 +3901,8 @@ implementation
 
     constructor tclassrefdef.create(def:tdef);
       begin
+         while tobjectdef(def).is_unique_objpasdef do
+           def:=tobjectdef(def).childof;
          inherited create(classrefdef,def);
          if df_specialization in tstoreddef(def).defoptions then
            genericdef:=cclassrefdef.create(tstoreddef(def).genericdef);
@@ -7890,7 +7893,10 @@ implementation
       begin
         if not(oo_has_vmt in objectoptions) then
           Message1(parser_n_object_has_no_vmt,objrealname^);
-        vmt_mangledname:=make_mangledname('VMT',owner,objname^);
+        if not is_unique_objpasdef then
+          vmt_mangledname:=make_mangledname('VMT',owner,objname^)
+        else
+          vmt_mangledname:=childof.vmt_mangledname;
       end;
 
 
@@ -7899,13 +7905,18 @@ implementation
         where: tsymtable;
         vmttypesym: tsymentry;
       begin
-        where:=get_top_level_symtable(true);
+        if not is_unique_objpasdef then
-        vmttypesym:=where.Find('vmtdef$'+mangledparaname);
+          begin
-        if not assigned(vmttypesym) or
+            where:=get_top_level_symtable(true);
-           (vmttypesym.typ<>symconst.typesym) or
+            vmttypesym:=where.Find('vmtdef$'+mangledparaname);
-           (ttypesym(vmttypesym).typedef.typ<>recorddef) then
+            if not assigned(vmttypesym) or
-          internalerror(2015052501);
+               (vmttypesym.typ<>symconst.typesym) or
-        result:=trecorddef(ttypesym(vmttypesym).typedef);
+               (ttypesym(vmttypesym).typedef.typ<>recorddef) then
+              internalerror(2015052501);
+            result:=trecorddef(ttypesym(vmttypesym).typedef);
+          end
+        else
+          result:=childof.vmt_def;
       end;
 
 
@@ -7971,7 +7982,12 @@ implementation
     function tobjectdef.rtti_mangledname(rt: trttitype): TSymStr;
       begin
         if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
-          result:=inherited rtti_mangledname(rt)
+          begin
+            if not is_unique_objpasdef then
+              result:=inherited rtti_mangledname(rt)
+            else
+              result:=childof.rtti_mangledname(rt)
+          end
         else
           begin
             { necessary in case of a dynamic array of nsobject, or
@@ -8054,6 +8070,13 @@ implementation
           end;
       end;
 
+    function tobjectdef.is_unique_objpasdef: boolean;
+        begin
+          result:=
+            (df_unique in defoptions) and
+            is_class_or_interface_or_dispinterface(self)
+        end;
+
 
     function tobjectdef.members_need_inittable : boolean;
       begin

compiler/symtable.pas

@@ -3607,6 +3607,10 @@ implementation
         formalnameptr,
         foundnameptr: pshortstring;
       begin
+        while pd.is_unique_objpasdef do
+          begin
+            pd:=pd.childof;
+          end;
         { not a formal definition -> return it }
         if not(oo_is_formal in pd.objectoptions) then
           begin

tests/webtbs/tw29367.pp

@@ -13,18 +13,63 @@ type
   end;
 
 constructor TFoo.create;
-begin end;
+begin
+  writeln('TFoo.create');
+end;
 
 constructor TBaz.create;
-begin end;
+begin
+  inherited;
+  writeln('TBaz.create');
+end;
 
+var
+  test1tbar: boolean;
+
+procedure test1(o: TFoo; error: longint); overload;
+begin
+  writeln('test1 tfoo');
+  o.free;
+  if test1tbar then
+    halt(error);
+end;
+
+procedure test1(o: TBar; error: longint); overload;
+begin
+  writeln('test1 tbar');
+  o.free;
+  if not test1tbar then
+    halt(error);
+end;
+
+var
+  b: tbar;
 begin
   if not tbar.inheritsfrom(tfoo) then
-    halt(1);
+    begin
+      writeln('error 1');
+      halt(1);
+    end;
   if not tbaz.inheritsfrom(tbar) then
-    halt(2);
+    begin
-  if tbar.classname<>'TBar' then
+      writeln('error 2');
-    halt(3);
+      halt(2);
+   end;
+  if tbar.classname<>'TFoo' then
+    begin
+      writeln('error 3');
+      halt(3);
+    end;
   if tfoo.classname<>'TFoo' then
-    halt(4);
+    begin
+      writeln('error 4');
+      halt(4);
+    end;
+  TBaz.create.free;
+  test1tbar:=false;
+  test1(tfoo.create,5);
+  test1(tbar.create,6);
+  b:=tbar.create;
+  test1tbar:=true;
+  test1(b,7);
 end.

tests/webtbs/tw8180.pp

@@ -10,7 +10,14 @@ type
 
 var
   x : tcl;
+  p: pointer;
+  i: iunknown;
 begin
   x:=tcl.create;
   x._Addref;
+  i:=x as iunknown;
+  if (x as iunknown).queryinterface(xstr,p) <> S_OK then
+    halt(1);
+  if (x as iunknown).queryinterface(iinterface,p) <> S_OK then
+    halt(2);
 end.