paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 18:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix tw3930 after r37927

Browse Source 
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 -
This commit is contained in:
Jonas Maebe 2020-09-05 12:25:09 +00:00
parent c45e56bc91
commit cc315e0ac7
7 changed files with 124 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compiler/ncgrtti.pas
View File

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

25
compiler/ncgvmt.pas
View File

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

12
compiler/pdecl.pas
View File

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

41
compiler/symdef.pas
View File

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

4
compiler/symtable.pas
View File

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

59
tests/webtbs/tw29367.pp
View File

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

7
tests/webtbs/tw8180.pp
View File

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