From cc315e0ac7d0022197a7b49f4473ab219c3aa6b7 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sat, 5 Sep 2020 12:25:09 +0000 Subject: [PATCH] * 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 | 3 +++ compiler/ncgvmt.pas | 25 ++++++++++++----- compiler/pdecl.pas | 12 ++++++--- compiler/symdef.pas | 41 +++++++++++++++++++++------- compiler/symtable.pas | 4 +++ tests/webtbs/tw29367.pp | 59 ++++++++++++++++++++++++++++++++++++----- tests/webtbs/tw8180.pp | 7 +++++ 7 files changed, 124 insertions(+), 27 deletions(-) diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index aad03c9e9e..6551b9585e 100644 --- a/compiler/ncgrtti.pas +++ b/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 : diff --git a/compiler/ncgvmt.pas b/compiler/ncgvmt.pas index b1e3b67752..2353ce7bc9 100644 --- a/compiler/ncgvmt.pas +++ b/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 diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 5147ad0d29..6268ec4960 100644 --- a/compiler/pdecl.pas +++ b/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)); diff --git a/compiler/symdef.pas b/compiler/symdef.pas index e4741ae336..e42c9cb92a 100644 --- a/compiler/symdef.pas +++ b/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); - vmttypesym:=where.Find('vmtdef$'+mangledparaname); - if not assigned(vmttypesym) or - (vmttypesym.typ<>symconst.typesym) or - (ttypesym(vmttypesym).typedef.typ<>recorddef) then - internalerror(2015052501); - result:=trecorddef(ttypesym(vmttypesym).typedef); + if not is_unique_objpasdef then + begin + where:=get_top_level_symtable(true); + vmttypesym:=where.Find('vmtdef$'+mangledparaname); + if not assigned(vmttypesym) or + (vmttypesym.typ<>symconst.typesym) or + (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 diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 5bcbdd9f26..f27efe4fbe 100644 --- a/compiler/symtable.pas +++ b/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 diff --git a/tests/webtbs/tw29367.pp b/tests/webtbs/tw29367.pp index 1bc777bb2a..9405b15314 100644 --- a/tests/webtbs/tw29367.pp +++ b/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); - if tbar.classname<>'TBar' then - halt(3); + begin + writeln('error 2'); + 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. diff --git a/tests/webtbs/tw8180.pp b/tests/webtbs/tw8180.pp index 40934cdd45..0f0272d071 100644 --- a/tests/webtbs/tw8180.pp +++ b/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.