paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 01:19:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix creating thunk class when inherited interfaces are used

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-05-04 15:56:02 +02:00
parent 1e9e533e6c
commit 312cf246ad
4 changed files with 81 additions and 21 deletions

11
compiler/pmodules.pas
View File

@ -1203,6 +1203,11 @@ type
exit;
end;
{ we need to be able to reference these in descendants,
so they must be generated and included in the interface }
if (target_cpu=tsystemcpu.cpu_wasm32) then
add_synthetic_interface_classes_for_st(curr.globalsymtable,true,false);
{ Our interface is compiled, generate CRC and switch to implementation }
if not(cs_compilesystem in current_settings.moduleswitches) and
(Errorcount=0) then
@ -1476,8 +1481,8 @@ type
// This needs to be done before we generate the VMTs
if (target_cpu=tsystemcpu.cpu_wasm32) then
begin
add_synthetic_interface_classes_for_st(module.globalsymtable);
add_synthetic_interface_classes_for_st(module.localsymtable);
add_synthetic_interface_classes_for_st(module.globalsymtable,false,true);
add_synthetic_interface_classes_for_st(module.localsymtable,true,true);
end;
{ generate construction functions for all attributes in the unit:
@ -2542,7 +2547,7 @@ type
{ This needs to be done before we generate the VMTs }
if (target_cpu=tsystemcpu.cpu_wasm32) then
add_synthetic_interface_classes_for_st(curr.localsymtable);
add_synthetic_interface_classes_for_st(curr.localsymtable,true,true);
{ Generate VMTs }
if Errorcount=0 then

1
compiler/symconst.pas
View File

@ -1004,6 +1004,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
{$endif not jvm}
objecttypes_with_helpers=[odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
objecttypes_with_thunk=[odt_interfacecorba,odt_interfacecom];
{ !! Be sure to keep these in sync with ones in rtl/inc/varianth.inc }
varempty = 0;

63
compiler/symcreat.pas
View File

@ -130,7 +130,7 @@ interface
{ Generate the hidden thunk class for interfaces,
so we can use them in TVirtualInterface on platforms that do not allow
generating executable code in memory at runtime.}
procedure add_synthetic_interface_classes_for_st(st : tsymtable);
procedure add_synthetic_interface_classes_for_st(st : tsymtable; gen_intf, gen_impl : boolean);
implementation
@ -318,8 +318,10 @@ implementation
function str_parse_objecttypedef(typename : shortstring;str: ansistring): tobjectdef;
var
b,oldparse_only: boolean;
i : integer;
tmpstr: ansistring;
flags : tread_proc_flags;
o : TObject;
begin
result:=nil;
@ -333,9 +335,18 @@ implementation
current_scanner.substitutemacro('hidden_interface_class_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index,true);
current_scanner.readtoken(false);
type_dec(b);
if (current_module.DefList.Last is tobjectdef) and
(tobjectdef(current_module.DefList.Last).GetTypeName=typename) then
result:=tobjectdef(current_module.DefList.Last);
// In the interface part, the object def is not necessarily the last one, the methods also generate defs.
i:=current_module.DefList.count-1;
While (result=nil) and (i>=0) do
begin
O:=current_module.DefList[i];
if (o is tobjectdef) then
if (tobjectdef(o).GetTypeName=typename) then
result:=tobjectdef(o);
dec(i);
end;
if result=nil then
internalerror(2024050401);
parse_only:=oldparse_only;
{ remove the temporary macro input file again }
current_scanner.closeinputfile;
@ -1537,19 +1548,40 @@ implementation
result:=offs;
end;
// return parent Interface def, but skip iunknown.
function getparent_interface_def(odef : tobjectdef) : tobjectdef;
begin
if (odef.getparentdef is tobjectdef) then
begin
result:=odef.getparentdef as tobjectdef;
if result=interface_iunknown then
result:=Nil;
end
else
result:=nil;
end;
procedure implement_interface_thunkclass_decl(cn : shortstring; objdef : tobjectdef);
var
str : ansistring;
parentname,str : ansistring;
sym : tsym;
proc : tprocsym absolute sym;
pd : tprocdef;
def : tobjectdef;
odef,def : tobjectdef;
offs,argcount,i,j : integer;
begin
str:='type '#10;
str:=str+cn+' = class(TInterfaceThunk,'+objdef.GetTypeName+')'#10;
odef:=getparent_interface_def(objdef);
if (oDef=Nil) or (oDef.hiddenclassdef=Nil) then
parentname:='TInterfaceThunk'
else
parentname:=odef.hiddenclassdef.GetTypeName;
str:=str+cn+' = class('+parentname+','+objdef.GetTypeName+')'#10;
str:=str+' protected '#10;
for I:=0 to objdef.symtable.symList.Count-1 do
begin
@ -1583,6 +1615,9 @@ implementation
if assigned(def) then
begin
def.created_in_current_module:=true;
if not def.typesym.is_registered then
def.typesym.register_sym;
def.buildderef;
include(def.objectoptions,oo_can_have_published);
end;
objdef.hiddenclassdef:=def;
@ -1738,7 +1773,7 @@ implementation
end;
end;
procedure add_synthetic_interface_classes_for_st(st : tsymtable);
procedure add_synthetic_interface_classes_for_st(st : tsymtable; gen_intf, gen_impl : boolean);
var
i : longint;
@ -1759,14 +1794,16 @@ implementation
def:=tdef(st.deflist[i]);
if (def.typ<>objectdef) then
continue;
if not (objdef.objecttype in [odt_interfacecorba,odt_interfacecom]) then
if not (objdef.objecttype in objecttypes_with_thunk) then
continue;
if not (oo_can_have_published in objdef.objectoptions) then
continue;
// need to add here extended rtti check when it is available
cn:=generate_thunkclass_name(i,objdef);
implement_interface_thunkclass_decl(cn,objdef);
implement_interface_thunkclass_impl(cn,objdef);
if gen_intf then
implement_interface_thunkclass_decl(cn,objdef);
if gen_impl then
implement_interface_thunkclass_impl(cn,objdef);
end;
restore_scanner(sstate);
// Recurse for interfaces defined in a type section of a class/record.
@ -1774,9 +1811,9 @@ implementation
begin
def:=tdef(st.deflist[i]);
if (def.typ=objectdef) and (objdef.objecttype=odt_class) then
add_synthetic_interface_classes_for_st(objdef.symtable)
add_synthetic_interface_classes_for_st(objdef.symtable,gen_intf,gen_impl)
else if (def.typ=recorddef) and (m_advanced_records in current_settings.modeswitches) then
add_synthetic_interface_classes_for_st(recdef.symtable);
add_synthetic_interface_classes_for_st(recdef.symtable,gen_intf,gen_impl);
end;
end;

27
compiler/symdef.pas
View File

@ -516,10 +516,12 @@ interface
objecttype : tobjecttyp;
{ for interfaces that can be invoked using Invoke(),
this is the definition of the hidden class that is generated by the compiler.
we need this definition to reference it in the RTTI, only during compilation of unit.
so no need to write it to the .ppu file.
we need this definition to reference it in the RTTI.
Since interfaces can inherit, so can these hidden classes,
so we need to write this to the ppu to be able to reference the parents.
}
hiddenclassdef : tobjectdef;
hiddenclassdefref : tderef;
constructor create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);virtual;
constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override;
@ -1645,7 +1647,7 @@ implementation
function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
var
s,
s,t,
prefix : TSymStr;
hash : qword;
begin
@ -1691,8 +1693,11 @@ implementation
prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
st:=st.defowner.owner;
end;
{ local classes & interfaces are possible (because of closures) }
if st.symtabletype<>localsymtable then
{ local classes & interfaces are possible (because of closures)
or parasymtable for this case:
class function Trace<TResult>(const Func: TFunc<TLogToken, TResult>): TResult;
}
if not (st.symtabletype in [localsymtable,parasymtable]) then
break;
prefix:='$'+prefix;
until false;
@ -7858,6 +7863,8 @@ implementation
childof:=nil;
childofderef.reset;
vmt_fieldderef.reset;
hiddenclassdefref.reset;
extendeddefderef.reset;
cloneddefderef.reset;
if objecttype=odt_helper then
@ -7945,6 +7952,8 @@ implementation
else
ImplementedInterfaces:=nil;
if (target_cpu=tsystemcpu.cpu_wasm32) and (objecttype in objecttypes_with_thunk) then
ppufile.getderef(hiddenclassdefref);
if df_copied_def in defoptions then
begin
ppufile.getderef(cloneddefderef);
@ -8143,6 +8152,9 @@ implementation
end;
end;
if (target_cpu=tsystemcpu.cpu_wasm32) and (objecttype in objecttypes_with_thunk) then
ppufile.putderef(hiddenclassdefref);
if df_copied_def in defoptions then
ppufile.putderef(cloneddefderef);
@ -8176,6 +8188,9 @@ implementation
inherited buildderef;
vmt_fieldderef.build(vmt_field);
childofderef.build(childof);
if (target_cpu=tsystemcpu.cpu_wasm32) and (objecttype in objecttypes_with_thunk) then
hiddenclassdefref.build(hiddenclassdef);
if df_copied_def in defoptions then
cloneddefderef.build(symtable.defowner)
else
@ -8206,6 +8221,8 @@ implementation
inherited deref;
vmt_field:=tsym(vmt_fieldderef.resolve);
childof:=tobjectdef(childofderef.resolve);
if (target_cpu=tsystemcpu.cpu_wasm32) and (objecttype in objecttypes_with_thunk) then
hiddenclassdef:=tobjectdef(hiddenclassdefref.resolve);
if df_copied_def in defoptions then
begin
cloneddef:=tobjectdef(cloneddefderef.resolve);