mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-15 07:19:35 +02:00
* refactor implemented interfaces
git-svn-id: trunk@5134 -
This commit is contained in:
peter
parent
72ff9d9f3e
commit
136d3e8d46
@ -133,10 +133,10 @@ interface
|
||||
function RefAsmSymbol(const s : string) : tasmsymbol;
|
||||
function getasmsymbol(const s : string) : tasmsymbol;
|
||||
{ create new assembler label }
|
||||
procedure getlabel(var l : tasmlabel;alt:tasmlabeltype);
|
||||
procedure getjumplabel(var l : tasmlabel);
|
||||
procedure getaddrlabel(var l : tasmlabel);
|
||||
procedure getdatalabel(var l : tasmlabel);
|
||||
procedure getlabel(out l : tasmlabel;alt:tasmlabeltype);
|
||||
procedure getjumplabel(out l : tasmlabel);
|
||||
procedure getaddrlabel(out l : tasmlabel);
|
||||
procedure getdatalabel(out l : tasmlabel);
|
||||
{ generate an alternative (duplicate) symbol }
|
||||
procedure GenerateAltSymbol(p:tasmsymbol);
|
||||
procedure ResetAltSymbols;
|
||||
@ -386,7 +386,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure TAsmData.getlabel(var l : tasmlabel;alt:tasmlabeltype);
|
||||
procedure TAsmData.getlabel(out l : tasmlabel;alt:tasmlabeltype);
|
||||
begin
|
||||
l:=tasmlabel.createlocal(FNextLabelNr[alt],alt);
|
||||
inc(FNextLabelNr[alt]);
|
||||
@ -394,7 +394,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure TAsmData.getjumplabel(var l : tasmlabel);
|
||||
procedure TAsmData.getjumplabel(out l : tasmlabel);
|
||||
begin
|
||||
l:=tasmlabel.createlocal(FNextLabelNr[alt_jump],alt_jump);
|
||||
inc(FNextLabelNr[alt_jump]);
|
||||
@ -402,7 +402,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure TAsmData.getdatalabel(var l : tasmlabel);
|
||||
procedure TAsmData.getdatalabel(out l : tasmlabel);
|
||||
begin
|
||||
l:=tasmlabel.createglobal(name,FNextLabelNr[alt_data],alt_data);
|
||||
inc(FNextLabelNr[alt_data]);
|
||||
@ -410,7 +410,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure TAsmData.getaddrlabel(var l : tasmlabel);
|
||||
procedure TAsmData.getaddrlabel(out l : tasmlabel);
|
||||
begin
|
||||
l:=tasmlabel.createlocal(FNextLabelNr[alt_addr],alt_addr);
|
||||
inc(FNextLabelNr[alt_addr]);
|
||||
|
||||
@ -2658,11 +2658,11 @@ end;
|
||||
end;
|
||||
|
||||
{ add implemented interfaces }
|
||||
if assigned(def.implementedinterfaces) then
|
||||
for n := 1 to def.implementedinterfaces.count do
|
||||
if assigned(def.ImplementedInterfaces) then
|
||||
for n := 0 to def.ImplementedInterfaces.count-1 do
|
||||
begin
|
||||
append_entry(DW_TAG_inheritance,false,[]);
|
||||
append_labelentry_ref(DW_AT_type,def_dwarf_lab(def.implementedinterfaces.interfaces(n)));
|
||||
append_labelentry_ref(DW_AT_type,def_dwarf_lab(TImplementedInterface(def.ImplementedInterfaces[n]).IntfDef));
|
||||
finish_entry;
|
||||
end;
|
||||
|
||||
|
||||
@ -166,7 +166,7 @@ implementation
|
||||
subeq,eq : tequaltype;
|
||||
hd1,hd2 : tdef;
|
||||
hct : tconverttype;
|
||||
hd3 : tobjectdef;
|
||||
hobjdef : tobjectdef;
|
||||
hpd : tprocdef;
|
||||
begin
|
||||
eq:=te_incompatible;
|
||||
@ -1149,21 +1149,21 @@ implementation
|
||||
end
|
||||
{ classes can be assigned to interfaces }
|
||||
else if is_interface(def_to) and
|
||||
is_class(def_from) and
|
||||
assigned(tobjectdef(def_from).implementedinterfaces) then
|
||||
is_class(def_from) and
|
||||
assigned(tobjectdef(def_from).ImplementedInterfaces) then
|
||||
begin
|
||||
{ we've to search in parent classes as well }
|
||||
hd3:=tobjectdef(def_from);
|
||||
while assigned(hd3) do
|
||||
hobjdef:=tobjectdef(def_from);
|
||||
while assigned(hobjdef) do
|
||||
begin
|
||||
if hd3.implementedinterfaces.searchintf(def_to)<>-1 then
|
||||
if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then
|
||||
begin
|
||||
doconv:=tc_class_2_intf;
|
||||
{ don't prefer this over objectdef->objectdef }
|
||||
eq:=te_convert_l2;
|
||||
break;
|
||||
end;
|
||||
hd3:=hd3.childof;
|
||||
hobjdef:=hobjdef.childof;
|
||||
end;
|
||||
end
|
||||
{ Interface 2 GUID handling }
|
||||
|
||||
@ -448,6 +448,7 @@ interface
|
||||
var
|
||||
l1 : tasmlabel;
|
||||
hd : tobjectdef;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
location_reset(location,LOC_REGISTER,OS_ADDR);
|
||||
case left.location.loc of
|
||||
@ -473,14 +474,13 @@ interface
|
||||
hd:=tobjectdef(left.resultdef);
|
||||
while assigned(hd) do
|
||||
begin
|
||||
if hd.implementedinterfaces.searchintf(resultdef)<>-1 then
|
||||
begin
|
||||
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR,
|
||||
hd.implementedinterfaces.ioffsets(
|
||||
hd.implementedinterfaces.searchintf(resultdef)),location.register);
|
||||
break;
|
||||
end;
|
||||
hd:=hd.childof;
|
||||
ImplIntf:=hd.find_implemented_interface(tobjectdef(resultdef));
|
||||
if assigned(ImplIntf) then
|
||||
begin
|
||||
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR,ImplIntf.ioffset,location.register);
|
||||
break;
|
||||
end;
|
||||
hd:=hd.childof;
|
||||
end;
|
||||
if hd=nil then
|
||||
internalerror(2002081301);
|
||||
|
||||
@ -2722,25 +2722,26 @@ implementation
|
||||
|
||||
procedure gen_intf_wrapper(list:TAsmList;_class:tobjectdef);
|
||||
var
|
||||
i,j,
|
||||
proccount : longint;
|
||||
i,j : longint;
|
||||
tmps : string;
|
||||
pd : TProcdef;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
for i:=1 to _class.implementedinterfaces.count do
|
||||
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
||||
begin
|
||||
{ only if implemented by this class }
|
||||
if _class.implementedinterfaces.implindex(i)=i then
|
||||
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
if (ImplIntf=ImplIntf.VtblImplIntf) and
|
||||
assigned(ImplIntf.ProcDefs) then
|
||||
begin
|
||||
proccount:=_class.implementedinterfaces.implproccount(i);
|
||||
for j:=1 to proccount do
|
||||
for j:=0 to ImplIntf.ProcDefs.Count-1 do
|
||||
begin
|
||||
pd:=TProcdef(ImplIntf.ProcDefs[j]);
|
||||
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+
|
||||
_class.implementedinterfaces.interfaces(i).objname^+'_$_'+
|
||||
tostr(j)+'_$_'+_class.implementedinterfaces.implprocs(i,j).mangledname);
|
||||
ImplIntf.IntfDef.objname^+'_$_'+tostr(j)+'_$_'+pd.mangledname);
|
||||
{ create wrapper code }
|
||||
new_section(list,sec_code,lower(tmps),0);
|
||||
new_section(list,sec_code,tmps,0);
|
||||
cg.init_register_allocators;
|
||||
cg.g_intf_wrapper(list,_class.implementedinterfaces.implprocs(i,j),tmps,_class.implementedinterfaces.ioffsets(i));
|
||||
cg.g_intf_wrapper(list,pd,tmps,ImplIntf.ioffset);
|
||||
cg.done_register_allocators;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -2766,9 +2766,8 @@ implementation
|
||||
{ left is a class }
|
||||
if is_class(left.resultdef) then
|
||||
begin
|
||||
{ the operands must be related }
|
||||
if not(assigned(tobjectdef(left.resultdef).implementedinterfaces) and
|
||||
(tobjectdef(left.resultdef).implementedinterfaces.searchintf(right.resultdef)<>-1)) then
|
||||
{ the class must implement the interface }
|
||||
if tobjectdef(left.resultdef).find_implemented_interface(tobjectdef(right.resultdef))=nil then
|
||||
CGMessage2(type_e_classes_not_related,
|
||||
FullTypeName(left.resultdef,right.resultdef),
|
||||
FullTypeName(right.resultdef,left.resultdef))
|
||||
|
||||
@ -95,14 +95,14 @@ interface
|
||||
procedure writevirtualmethods(List:TAsmList);
|
||||
private
|
||||
{ interface tables }
|
||||
function gintfgetvtbllabelname(intfindex: integer): string;
|
||||
procedure gintfcreatevtbl(intfindex: integer; rawdata: TAsmList);
|
||||
procedure gintfgenentry(intfindex, contintfindex: integer; rawdata: TAsmList);
|
||||
procedure gintfoptimizevtbls;
|
||||
procedure gintfwritedata;
|
||||
function gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
|
||||
procedure gintfdoonintf(intf: tobjectdef; intfindex: longint);
|
||||
procedure gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
|
||||
function intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
|
||||
procedure intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
||||
procedure intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
||||
procedure intf_optimize_vtbls;
|
||||
procedure intf_write_data;
|
||||
function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
|
||||
procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
||||
procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
||||
public
|
||||
constructor create(c:tobjectdef);
|
||||
destructor destroy;override;
|
||||
@ -129,7 +129,7 @@ implementation
|
||||
uses
|
||||
SysUtils,
|
||||
globals,verbose,systems,
|
||||
symtable,symconst,symtype,defcmp,defutil,
|
||||
symtable,symconst,symtype,defcmp,
|
||||
dbgbase
|
||||
;
|
||||
|
||||
@ -256,7 +256,7 @@ implementation
|
||||
procedure tclassheader.writenames(p : pprocdeftree);
|
||||
var
|
||||
ca : pchar;
|
||||
len : longint;
|
||||
len : byte;
|
||||
begin
|
||||
current_asmdata.getdatalabel(p^.nl);
|
||||
if assigned(p^.l) then
|
||||
@ -290,7 +290,6 @@ implementation
|
||||
|
||||
function tclassheader.genstrmsgtab : tasmlabel;
|
||||
var
|
||||
r : tasmlabel;
|
||||
count : aint;
|
||||
begin
|
||||
root:=nil;
|
||||
@ -303,10 +302,9 @@ implementation
|
||||
writenames(root);
|
||||
|
||||
{ now start writing of the message string table }
|
||||
current_asmdata.getdatalabel(r);
|
||||
current_asmdata.getdatalabel(result);
|
||||
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(r));
|
||||
genstrmsgtab:=r;
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(result));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(count));
|
||||
if assigned(root) then
|
||||
begin
|
||||
@ -859,60 +857,58 @@ implementation
|
||||
Interface tables
|
||||
**************************************}
|
||||
|
||||
function tclassheader.gintfgetvtbllabelname(intfindex: integer): string;
|
||||
function tclassheader.intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
|
||||
begin
|
||||
gintfgetvtbllabelname:=make_mangledname('VTBL',_class.owner,_class.objname^+
|
||||
'_$_'+_class.implementedinterfaces.interfaces(intfindex).objname^);
|
||||
result:=make_mangledname('VTBL',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^);
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata: TAsmList);
|
||||
procedure tclassheader.intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
||||
var
|
||||
implintf: timplementedinterfaces;
|
||||
curintf: tobjectdef;
|
||||
proccount: integer;
|
||||
tmps: string;
|
||||
i: longint;
|
||||
pd : tprocdef;
|
||||
vtblstr,
|
||||
hs : string;
|
||||
i : longint;
|
||||
begin
|
||||
implintf:=_class.implementedinterfaces;
|
||||
curintf:=implintf.interfaces(intfindex);
|
||||
|
||||
section_symbol_start(rawdata,gintfgetvtbllabelname(intfindex),AT_DATA,true,sec_data,const_align(sizeof(aint)));
|
||||
proccount:=implintf.implproccount(intfindex);
|
||||
for i:=1 to proccount do
|
||||
vtblstr:=intf_get_vtbl_name(AImplIntf);
|
||||
section_symbol_start(rawdata,vtblstr,AT_DATA,true,sec_data,const_align(sizeof(aint)));
|
||||
if assigned(AImplIntf.procdefs) then
|
||||
begin
|
||||
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+curintf.objname^+'_$_'+
|
||||
tostr(i)+'_$_'+
|
||||
implintf.implprocs(intfindex,i).mangledname);
|
||||
{ create reference }
|
||||
rawdata.concat(Tai_const.Createname(tmps,0));
|
||||
end;
|
||||
section_symbol_end(rawdata,gintfgetvtbllabelname(intfindex));
|
||||
for i:=0 to AImplIntf.procdefs.count-1 do
|
||||
begin
|
||||
pd:=tprocdef(AImplIntf.procdefs[i]);
|
||||
hs:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+
|
||||
tostr(i)+'_$_'+pd.mangledname);
|
||||
{ create reference }
|
||||
rawdata.concat(Tai_const.Createname(hs,0));
|
||||
end;
|
||||
end;
|
||||
section_symbol_end(rawdata,vtblstr);
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfgenentry(intfindex, contintfindex: integer; rawdata: TAsmList);
|
||||
procedure tclassheader.intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
||||
var
|
||||
implintf: timplementedinterfaces;
|
||||
curintf: tobjectdef;
|
||||
tmplabel: tasmlabel;
|
||||
iidlabel,
|
||||
guidlabel : tasmlabel;
|
||||
i: longint;
|
||||
begin
|
||||
implintf:=_class.implementedinterfaces;
|
||||
curintf:=implintf.interfaces(intfindex);
|
||||
{ GUID }
|
||||
if curintf.objecttype in [odt_interfacecom] then
|
||||
if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
|
||||
begin
|
||||
{ label for GUID }
|
||||
current_asmdata.getdatalabel(tmplabel);
|
||||
current_asmdata.getdatalabel(guidlabel);
|
||||
rawdata.concat(cai_align.create(const_align(sizeof(aint))));
|
||||
rawdata.concat(Tai_label.Create(tmplabel));
|
||||
rawdata.concat(Tai_const.Create_32bit(longint(curintf.iidguid^.D1)));
|
||||
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D2));
|
||||
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D3));
|
||||
for i:=Low(curintf.iidguid^.D4) to High(curintf.iidguid^.D4) do
|
||||
rawdata.concat(Tai_const.Create_8bit(curintf.iidguid^.D4[i]));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(tmplabel));
|
||||
rawdata.concat(Tai_label.Create(guidlabel));
|
||||
with AImplIntf.IntfDef.iidguid^ do
|
||||
begin
|
||||
rawdata.concat(Tai_const.Create_32bit(longint(D1)));
|
||||
rawdata.concat(Tai_const.Create_16bit(D2));
|
||||
rawdata.concat(Tai_const.Create_16bit(D3));
|
||||
for i:=Low(D4) to High(D4) do
|
||||
rawdata.concat(Tai_const.Create_8bit(D4[i]));
|
||||
end;
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(guidlabel));
|
||||
end
|
||||
else
|
||||
begin
|
||||
@ -920,73 +916,77 @@ implementation
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
||||
end;
|
||||
{ VTable }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(gintfgetvtbllabelname(contintfindex),0));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0));
|
||||
{ IOffset field }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(implintf.ioffsets(contintfindex)));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.ioffset));
|
||||
{ IIDStr }
|
||||
current_asmdata.getdatalabel(tmplabel);
|
||||
current_asmdata.getdatalabel(iidlabel);
|
||||
rawdata.concat(cai_align.create(const_align(sizeof(aint))));
|
||||
rawdata.concat(Tai_label.Create(tmplabel));
|
||||
rawdata.concat(Tai_const.Create_8bit(length(curintf.iidstr^)));
|
||||
if curintf.objecttype=odt_interfacecom then
|
||||
rawdata.concat(Tai_string.Create(upper(curintf.iidstr^)))
|
||||
rawdata.concat(Tai_label.Create(iidlabel));
|
||||
rawdata.concat(Tai_const.Create_8bit(length(AImplIntf.IntfDef.iidstr^)));
|
||||
if AImplIntf.IntfDef.objecttype=odt_interfacecom then
|
||||
rawdata.concat(Tai_string.Create(upper(AImplIntf.IntfDef.iidstr^)))
|
||||
else
|
||||
rawdata.concat(Tai_string.Create(curintf.iidstr^));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(tmplabel));
|
||||
rawdata.concat(Tai_string.Create(AImplIntf.IntfDef.iidstr^));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(iidlabel));
|
||||
{ EntryType }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(integer(curintf.iitype)));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.IntfDef.iitype)));
|
||||
{ EntryOffset }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(integer(curintf.iioffset)));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.IntfDef.iioffset)));
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfoptimizevtbls;
|
||||
procedure tclassheader.intf_optimize_vtbls;
|
||||
type
|
||||
tcompintfentry = record
|
||||
weight: longint;
|
||||
compintf: longint;
|
||||
end;
|
||||
{ Max 1000 interface in the class header interfaces it's enough imho }
|
||||
tcompintfs = array[1..1000] of tcompintfentry;
|
||||
tcompintfs = array[0..1000] of tcompintfentry;
|
||||
pcompintfs = ^tcompintfs;
|
||||
tequals = array[1..1000] of longint;
|
||||
tequals = array[0..1000] of longint;
|
||||
pequals = ^tequals;
|
||||
timpls = array[1..1000] of longint;
|
||||
timpls = array[0..1000] of longint;
|
||||
pimpls = ^timpls;
|
||||
var
|
||||
max: longint;
|
||||
equals: pequals;
|
||||
compats: pcompintfs;
|
||||
impls: pimpls;
|
||||
ImplIntfCount,
|
||||
w,i,j,k: longint;
|
||||
ImplIntfI,
|
||||
ImplIntfJ : TImplementedInterface;
|
||||
cij: boolean;
|
||||
cji: boolean;
|
||||
begin
|
||||
max:=_class.implementedinterfaces.count;
|
||||
if max>High(tequals) then
|
||||
ImplIntfCount:=_class.ImplementedInterfaces.count;
|
||||
if ImplIntfCount>=High(tequals) then
|
||||
Internalerror(200006135);
|
||||
getmem(compats,sizeof(tcompintfentry)*max);
|
||||
getmem(equals,sizeof(longint)*max);
|
||||
getmem(impls,sizeof(longint)*max);
|
||||
fillchar(compats^,sizeof(tcompintfentry)*max,0);
|
||||
fillchar(equals^,sizeof(longint)*max,0);
|
||||
fillchar(impls^,sizeof(longint)*max,0);
|
||||
getmem(compats,sizeof(tcompintfentry)*ImplIntfCount);
|
||||
getmem(equals,sizeof(longint)*ImplIntfCount);
|
||||
getmem(impls,sizeof(longint)*ImplIntfCount);
|
||||
filldword(compats^,(sizeof(tcompintfentry) div sizeof(dword))*ImplIntfCount,dword(-1));
|
||||
filldword(equals^,ImplIntfCount,dword(-1));
|
||||
filldword(impls^,ImplIntfCount,dword(-1));
|
||||
{ ismergepossible is a containing relation
|
||||
meaning of ismergepossible(a,b,w) =
|
||||
if implementorfunction map of a is contained implementorfunction map of b
|
||||
imp(a,b) and imp(b,c) => imp(a,c) ; imp(a,b) and imp(b,a) => a == b
|
||||
}
|
||||
{ the order is very important for correct allocation }
|
||||
for i:=1 to max do
|
||||
for i:=0 to ImplIntfCount-1 do
|
||||
begin
|
||||
for j:=i+1 to max do
|
||||
for j:=i+1 to ImplIntfCount-1 do
|
||||
begin
|
||||
cij:=_class.implementedinterfaces.isimplmergepossible(i,j,w);
|
||||
cji:=_class.implementedinterfaces.isimplmergepossible(j,i,w);
|
||||
ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
ImplIntfJ:=TImplementedInterface(_class.ImplementedInterfaces[j]);
|
||||
cij:=ImplIntfI.IsImplMergePossible(ImplIntfJ,w);
|
||||
cji:=ImplIntfJ.IsImplMergePossible(ImplIntfI,w);
|
||||
if cij and cji then { i equal j }
|
||||
begin
|
||||
{ get minimum index of equal }
|
||||
if equals^[j]=0 then
|
||||
if equals^[j]=-1 then
|
||||
equals^[j]:=i;
|
||||
end
|
||||
else if cij then
|
||||
@ -1010,7 +1010,7 @@ implementation
|
||||
end;
|
||||
end;
|
||||
{ Reset, no replacements by default }
|
||||
for i:=1 to max do
|
||||
for i:=0 to ImplIntfCount-1 do
|
||||
impls^[i]:=i;
|
||||
{ Replace vtbls when equal or compat, repeat
|
||||
until there are no replacements possible anymore. This is
|
||||
@ -1020,64 +1020,70 @@ implementation
|
||||
}
|
||||
repeat
|
||||
k:=0;
|
||||
for i:=1 to max do
|
||||
for i:=0 to ImplIntfCount-1 do
|
||||
begin
|
||||
if compats^[impls^[i]].compintf<>0 then
|
||||
if compats^[impls^[i]].compintf<>-1 then
|
||||
impls^[i]:=compats^[impls^[i]].compintf
|
||||
else if equals^[impls^[i]]<>0 then
|
||||
else if equals^[impls^[i]]<>-1 then
|
||||
impls^[i]:=equals^[impls^[i]]
|
||||
else
|
||||
inc(k);
|
||||
end;
|
||||
until k=max;
|
||||
{ Update the implindex }
|
||||
for i:=1 to max do
|
||||
_class.implementedinterfaces.setimplindex(i,impls^[i]);
|
||||
until k=ImplIntfCount;
|
||||
{ Update the VtblImplIntf }
|
||||
for i:=0 to ImplIntfCount-1 do
|
||||
begin
|
||||
ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
ImplIntfI.VtblImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[impls^[i]]);
|
||||
end;
|
||||
freemem(compats);
|
||||
freemem(equals);
|
||||
freemem(impls);
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfwritedata;
|
||||
procedure tclassheader.intf_write_data;
|
||||
var
|
||||
rawdata: TAsmList;
|
||||
max,i,j : smallint;
|
||||
rawdata : TAsmList;
|
||||
i : longint;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
max:=_class.implementedinterfaces.count;
|
||||
|
||||
rawdata:=TAsmList.Create;
|
||||
{ Two pass, one for allocation and vtbl creation }
|
||||
for i:=1 to max do
|
||||
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
||||
begin
|
||||
if _class.implementedinterfaces.implindex(i)=i then { if implement itself }
|
||||
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
{ if it implements itself }
|
||||
if ImplIntf.VtblImplIntf=ImplIntf then
|
||||
begin
|
||||
{ allocate a pointer in the object memory }
|
||||
with tobjectsymtable(_class.symtable) do
|
||||
begin
|
||||
datasize:=align(datasize,sizeof(aint));
|
||||
_class.implementedinterfaces.setioffsets(i,datasize);
|
||||
ImplIntf.Ioffset:=datasize;
|
||||
inc(datasize,sizeof(aint));
|
||||
end;
|
||||
{ write vtbl }
|
||||
gintfcreatevtbl(i,rawdata);
|
||||
intf_create_vtbl(rawdata,ImplIntf);
|
||||
end;
|
||||
end;
|
||||
{ second pass: for fill interfacetable and remained ioffsets }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(max));
|
||||
for i:=1 to max do
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(_class.ImplementedInterfaces.count));
|
||||
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
||||
begin
|
||||
j:=_class.implementedinterfaces.implindex(i);
|
||||
if j<>i then
|
||||
_class.implementedinterfaces.setioffsets(i,_class.implementedinterfaces.ioffsets(j));
|
||||
gintfgenentry(i,j,rawdata);
|
||||
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
{ Update ioffset of current interface with the ioffset from
|
||||
the interface that is reused to implements this interface }
|
||||
if ImplIntf.VtblImplIntf<>ImplIntf then
|
||||
ImplIntf.Ioffset:=ImplIntf.VtblImplIntf.Ioffset;
|
||||
intf_gen_intf_ref(rawdata,ImplIntf);
|
||||
end;
|
||||
current_asmdata.asmlists[al_globals].concatlist(rawdata);
|
||||
rawdata.free;
|
||||
end;
|
||||
|
||||
|
||||
function tclassheader.gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
|
||||
function tclassheader.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
|
||||
const
|
||||
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
|
||||
po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
|
||||
@ -1086,7 +1092,7 @@ implementation
|
||||
implprocdef : Tprocdef;
|
||||
i: cardinal;
|
||||
begin
|
||||
gintfgetcprocdef:=nil;
|
||||
result:=nil;
|
||||
|
||||
sym:=tsym(search_class_member(_class,name));
|
||||
if assigned(sym) and
|
||||
@ -1108,7 +1114,7 @@ implementation
|
||||
(proc.proctypeoption=implprocdef.proctypeoption) and
|
||||
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
|
||||
begin
|
||||
gintfgetcprocdef:=implprocdef;
|
||||
result:=implprocdef;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
@ -1116,35 +1122,35 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfdoonintf(intf: tobjectdef; intfindex: longint);
|
||||
procedure tclassheader.intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
||||
var
|
||||
def: tdef;
|
||||
hs,
|
||||
prefix,
|
||||
mappedname: string;
|
||||
nextexist: pointer;
|
||||
implprocdef: tprocdef;
|
||||
begin
|
||||
prefix:=_class.implementedinterfaces.interfaces(intfindex).symtable.name^+'.';
|
||||
def:=tdef(intf.symtable.defindex.first);
|
||||
prefix:=ImplIntf.IntfDef.symtable.name^+'.';
|
||||
def:=tdef(IntfDef.symtable.defindex.first);
|
||||
while assigned(def) do
|
||||
begin
|
||||
if def.deftype=procdef then
|
||||
begin
|
||||
{ Find implementing procdef
|
||||
1. Check for mapped name
|
||||
2. Use symbol name }
|
||||
implprocdef:=nil;
|
||||
nextexist:=nil;
|
||||
repeat
|
||||
hs:=prefix+tprocdef(def).procsym.name;
|
||||
mappedname:=_class.implementedinterfaces.getmappings(intfindex,hs,nextexist);
|
||||
if mappedname<>'' then
|
||||
implprocdef:=gintfgetcprocdef(tprocdef(def),mappedname);
|
||||
until assigned(implprocdef) or not assigned(nextexist);
|
||||
hs:=prefix+tprocdef(def).procsym.name;
|
||||
mappedname:=ImplIntf.GetMapping(hs);
|
||||
if mappedname<>'' then
|
||||
implprocdef:=intf_search_procdef_by_name(tprocdef(def),mappedname);
|
||||
if not assigned(implprocdef) then
|
||||
implprocdef:=gintfgetcprocdef(tprocdef(def),tprocdef(def).procsym.name);
|
||||
implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
|
||||
{ Add procdef to the implemented interface }
|
||||
if assigned(implprocdef) then
|
||||
_class.implementedinterfaces.addimplproc(intfindex,implprocdef)
|
||||
ImplIntf.AddImplProc(implprocdef)
|
||||
else
|
||||
if _class.implementedinterfaces.interfaces(intfindex).iitype = etStandard then
|
||||
if ImplIntf.IntfDef.iitype = etStandard then
|
||||
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
|
||||
end;
|
||||
def:=tdef(def.indexnext);
|
||||
@ -1152,33 +1158,33 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure tclassheader.gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
|
||||
procedure tclassheader.intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
||||
begin
|
||||
if assigned(intf.childof) then
|
||||
gintfwalkdowninterface(intf.childof,intfindex);
|
||||
gintfdoonintf(intf,intfindex);
|
||||
if assigned(IntfDef.childof) then
|
||||
intf_get_procdefs_recursive(ImplIntf,IntfDef.childof);
|
||||
intf_get_procdefs(ImplIntf,IntfDef);
|
||||
end;
|
||||
|
||||
|
||||
function tclassheader.genintftable: tasmlabel;
|
||||
var
|
||||
intfindex: longint;
|
||||
curintf: tobjectdef;
|
||||
intftable: tasmlabel;
|
||||
ImplIntf : TImplementedInterface;
|
||||
intftable : tasmlabel;
|
||||
i : longint;
|
||||
begin
|
||||
{ 1. step collect implementor functions into the implementedinterfaces.implprocs }
|
||||
for intfindex:=1 to _class.implementedinterfaces.count do
|
||||
{ 1. step collect implementor functions into the tImplementedInterface.procdefs }
|
||||
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
||||
begin
|
||||
curintf:=_class.implementedinterfaces.interfaces(intfindex);
|
||||
gintfwalkdowninterface(curintf,intfindex);
|
||||
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||||
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
|
||||
end;
|
||||
{ 2. Optimize interface tables to reuse wrappers }
|
||||
gintfoptimizevtbls;
|
||||
intf_optimize_vtbls;
|
||||
{ 3. Calculate offsets in object map and Write interface tables }
|
||||
current_asmdata.getdatalabel(intftable);
|
||||
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftable));
|
||||
gintfwritedata;
|
||||
intf_write_data;
|
||||
genintftable:=intftable;
|
||||
end;
|
||||
|
||||
@ -1283,7 +1289,7 @@ implementation
|
||||
new_section(current_asmdata.asmlists[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(aint)));
|
||||
|
||||
{ interface table }
|
||||
if _class.implementedinterfaces.count>0 then
|
||||
if _class.ImplementedInterfaces.count>0 then
|
||||
interfacetable:=genintftable;
|
||||
|
||||
methodnametable:=genpublishedmethodstable;
|
||||
@ -1355,7 +1361,7 @@ implementation
|
||||
{ auto table }
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
||||
{ interface table }
|
||||
if _class.implementedinterfaces.count>0 then
|
||||
if _class.ImplementedInterfaces.count>0 then
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(interfacetable))
|
||||
else
|
||||
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
||||
|
||||
@ -271,8 +271,8 @@ implementation
|
||||
(((block_type=bt_type) and typecanbeforward) or
|
||||
not(m_delphi in current_settings.modeswitches)) then
|
||||
begin
|
||||
{ a hack, but it's easy to handle }
|
||||
{ class reference type }
|
||||
{ a hack, but it's easy to handle
|
||||
class reference type }
|
||||
consume(_OF);
|
||||
single_type(hdef,typecanbeforward);
|
||||
|
||||
@ -322,28 +322,27 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure handleimplementedinterface(implintf : tobjectdef);
|
||||
procedure handleImplementedInterface(intfdef : tobjectdef);
|
||||
|
||||
begin
|
||||
if not is_interface(implintf) then
|
||||
if not is_interface(intfdef) then
|
||||
begin
|
||||
Message1(type_e_interface_type_expected,implintf.typename);
|
||||
Message1(type_e_interface_type_expected,intfdef.typename);
|
||||
exit;
|
||||
end;
|
||||
if aktobjectdef.implementedinterfaces.searchintf(implintf)<>-1 then
|
||||
Message1(sym_e_duplicate_id,implintf.name)
|
||||
if aktobjectdef.find_implemented_interface(intfdef)<>nil then
|
||||
Message1(sym_e_duplicate_id,intfdef.name)
|
||||
else
|
||||
begin
|
||||
{ allocate and prepare the GUID only if the class
|
||||
implements some interfaces.
|
||||
}
|
||||
if aktobjectdef.implementedinterfaces.count = 0 then
|
||||
aktobjectdef.prepareguid;
|
||||
aktobjectdef.implementedinterfaces.addintf(implintf);
|
||||
{ allocate and prepare the GUID only if the class
|
||||
implements some interfaces. }
|
||||
if aktobjectdef.ImplementedInterfaces.count = 0 then
|
||||
aktobjectdef.prepareguid;
|
||||
aktobjectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readimplementedinterfaces;
|
||||
procedure readImplementedInterfaces;
|
||||
var
|
||||
hdef : tdef;
|
||||
begin
|
||||
@ -355,7 +354,7 @@ implementation
|
||||
Message1(type_e_interface_type_expected,hdef.typename);
|
||||
continue;
|
||||
end;
|
||||
handleimplementedinterface(tobjectdef(hdef));
|
||||
handleImplementedInterface(tobjectdef(hdef));
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -473,8 +472,8 @@ implementation
|
||||
if aktobjectdef.objecttype=odt_class then
|
||||
begin
|
||||
if assigned(intfchildof) then
|
||||
handleimplementedinterface(intfchildof);
|
||||
readimplementedinterfaces;
|
||||
handleImplementedInterface(intfchildof);
|
||||
readImplementedInterfaces;
|
||||
end;
|
||||
consume(_RKLAMMER);
|
||||
end;
|
||||
|
||||
@ -630,6 +630,7 @@ implementation
|
||||
st : tsymtable;
|
||||
aprocsym : tprocsym;
|
||||
popclass : boolean;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
{ Save the position where this procedure really starts }
|
||||
procstartfilepos:=current_tokenpos;
|
||||
@ -652,8 +653,8 @@ implementation
|
||||
|
||||
{ examine interface map: function/procedure iname.functionname=locfuncname }
|
||||
if assigned(aclass) and
|
||||
assigned(aclass.implementedinterfaces) and
|
||||
(aclass.implementedinterfaces.count>0) and
|
||||
assigned(aclass.ImplementedInterfaces) and
|
||||
(aclass.ImplementedInterfaces.count>0) and
|
||||
try_to_consume(_POINT) then
|
||||
begin
|
||||
storepos:=current_tokenpos;
|
||||
@ -667,20 +668,19 @@ implementation
|
||||
end;
|
||||
current_tokenpos:=storepos;
|
||||
{ qualifier is interface? }
|
||||
ImplIntf:=nil;
|
||||
if (srsym.typ=typesym) and
|
||||
(ttypesym(srsym).typedef.deftype=objectdef) then
|
||||
i:=aclass.implementedinterfaces.searchintf(ttypesym(srsym).typedef)
|
||||
else
|
||||
i:=-1;
|
||||
if (i=-1) then
|
||||
ImplIntf:=aclass.find_implemented_interface(tobjectdef(ttypesym(srsym).typedef));
|
||||
if ImplIntf=nil then
|
||||
Message(parser_e_interface_id_expected);
|
||||
consume(_ID);
|
||||
{ Create unique name <interface>.<method> }
|
||||
hs:=sp+'.'+pattern;
|
||||
consume(_EQUAL);
|
||||
if (i<>-1) and
|
||||
if assigned(ImplIntf) and
|
||||
(token=_ID) then
|
||||
aclass.implementedinterfaces.addmappings(i,hs,pattern);
|
||||
ImplIntf.AddMapping(hs,pattern);
|
||||
consume(_ID);
|
||||
result:=true;
|
||||
exit;
|
||||
|
||||
@ -222,7 +222,8 @@ implementation
|
||||
sc : TFPObjectList;
|
||||
paranr : word;
|
||||
i : longint;
|
||||
intfidx: longint;
|
||||
ImplIntf : TImplementedInterface;
|
||||
found : boolean;
|
||||
hreadparavs,
|
||||
hparavs : tparavarsym;
|
||||
storedprocdef,
|
||||
@ -609,38 +610,33 @@ implementation
|
||||
end;
|
||||
{ Parse possible "implements" keyword }
|
||||
if try_to_consume(_IMPLEMENTS) then
|
||||
begin
|
||||
consume(_ID);
|
||||
{$message warn unlocalized string}
|
||||
if not is_interface(p.propdef) then
|
||||
begin
|
||||
writeln('Implements property must have interface type');
|
||||
Message1(sym_e_illegal_field, pattern);
|
||||
end;
|
||||
if pattern <> p.propdef.mangledparaname() then
|
||||
begin
|
||||
writeln('Implements-property must implement interface of correct type');
|
||||
Message1(sym_e_illegal_field, pattern);
|
||||
end;
|
||||
intfidx := 0;
|
||||
with aclass.implementedinterfaces do
|
||||
begin
|
||||
for i := 1 to count do
|
||||
if interfaces(i).objname^ = pattern then
|
||||
consume(_ID);
|
||||
if not is_interface(p.propdef) then
|
||||
begin
|
||||
intfidx := i;
|
||||
break;
|
||||
Comment(V_Error,'Implements property must have interface type');
|
||||
end;
|
||||
if intfidx > 0 then
|
||||
begin
|
||||
interfaces(intfidx).iitype := etFieldValue;
|
||||
interfaces(intfidx).iioffset := tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset;
|
||||
end else
|
||||
begin
|
||||
writeln('Implements-property used on unimplemented interface');
|
||||
Message1(sym_e_illegal_field, pattern);
|
||||
end;
|
||||
end;
|
||||
if pattern <> p.propdef.mangledparaname() then
|
||||
begin
|
||||
Comment(V_Error,'Implements-property must implement interface of correct type');
|
||||
end;
|
||||
found:=false;
|
||||
for i:=0 to aclass.ImplementedInterfaces.Count-1 do
|
||||
begin
|
||||
ImplIntf:=TImplementedInterface(aclass.ImplementedInterfaces[i]);
|
||||
if ImplIntf.IntfDef.Objname^=pattern then
|
||||
begin
|
||||
found:=true;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
if found then
|
||||
begin
|
||||
ImplIntf.IntfDef.iitype := etFieldValue;
|
||||
ImplIntf.IntfDef.iioffset := tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset;
|
||||
end
|
||||
else
|
||||
Comment(V_Error,'Implements-property used on unimplemented interface');
|
||||
end;
|
||||
|
||||
{ remove temporary procvardefs }
|
||||
|
||||
@ -213,19 +213,29 @@ interface
|
||||
|
||||
tprocdef = class;
|
||||
tobjectdef = class;
|
||||
timplementedinterfaces = class;
|
||||
|
||||
timplintfentry = class(TNamedIndexItem)
|
||||
intf : tobjectdef;
|
||||
intfderef : tderef;
|
||||
ioffset : longint;
|
||||
implindex : longint;
|
||||
namemappings : tdictionary;
|
||||
procdefs : TIndexArray;
|
||||
{ TImplementedInterface }
|
||||
|
||||
TImplementedInterface = class
|
||||
IntfDef : tobjectdef;
|
||||
IntfDefDeref : tderef;
|
||||
IOffset : longint;
|
||||
VtblImplIntf : TImplementedInterface;
|
||||
NameMappings : TFPHashList;
|
||||
ProcDefs : TFPObjectList;
|
||||
constructor create(aintf: tobjectdef);
|
||||
constructor create_deref(d:tderef);
|
||||
destructor destroy; override;
|
||||
function getcopy:TImplementedInterface;
|
||||
procedure buildderef;
|
||||
procedure deref;
|
||||
procedure AddMapping(const origname, newname: string);
|
||||
function GetMapping(const origname: string):string;
|
||||
procedure AddImplProc(pd:tprocdef);
|
||||
function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
|
||||
end;
|
||||
|
||||
{ tobjectdef }
|
||||
|
||||
tobjectdef = class(tabstractrecorddef)
|
||||
private
|
||||
@ -236,23 +246,23 @@ interface
|
||||
procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
|
||||
procedure writefields(sym:tnamedindexitem;arg:pointer);
|
||||
public
|
||||
childof : tobjectdef;
|
||||
childofderef : tderef;
|
||||
childof : tobjectdef;
|
||||
childofderef : tderef;
|
||||
objname,
|
||||
objrealname : pshortstring;
|
||||
objectoptions : tobjectoptions;
|
||||
objrealname : pshortstring;
|
||||
objectoptions : tobjectoptions;
|
||||
{ to be able to have a variable vmt position }
|
||||
{ and no vmt field for objects without virtuals }
|
||||
vmt_offset : longint;
|
||||
vmt_offset : longint;
|
||||
writing_class_record_dbginfo : boolean;
|
||||
objecttype : tobjectdeftype;
|
||||
iidguid: pguid;
|
||||
iidstr: pshortstring;
|
||||
iitype: tinterfaceentrytype;
|
||||
iioffset: longint;
|
||||
objecttype : tobjectdeftype;
|
||||
iidguid : pguid;
|
||||
iidstr : pshortstring;
|
||||
iitype : tinterfaceentrytype;
|
||||
iioffset : longint;
|
||||
lastvtableindex: longint;
|
||||
{ store implemented interfaces defs and name mappings }
|
||||
implementedinterfaces: timplementedinterfaces;
|
||||
ImplementedInterfaces : TFPObjectList;
|
||||
constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
|
||||
constructor ppuload(ppufile:tcompilerppufile);
|
||||
destructor destroy;override;
|
||||
@ -266,6 +276,7 @@ interface
|
||||
function alignment:shortint;override;
|
||||
function vmtmethodoffset(index:longint):longint;
|
||||
function members_need_inittable : boolean;
|
||||
function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
|
||||
{ this should be called when this class implements an interface }
|
||||
procedure prepareguid;
|
||||
function is_publishable : boolean;override;
|
||||
@ -283,41 +294,6 @@ interface
|
||||
function generate_field_table : tasmlabel;
|
||||
end;
|
||||
|
||||
timplementedinterfaces = class
|
||||
constructor create;
|
||||
destructor destroy; override;
|
||||
|
||||
function count: longint;
|
||||
function interfaces(intfindex: longint): tobjectdef;
|
||||
function interfacesderef(intfindex: longint): tderef;
|
||||
function ioffsets(intfindex: longint): longint;
|
||||
procedure setioffsets(intfindex,iofs:longint);
|
||||
function implindex(intfindex:longint):longint;
|
||||
procedure setimplindex(intfindex,implidx:longint);
|
||||
function searchintf(def: tdef): longint;
|
||||
procedure addintf(def: tdef);
|
||||
|
||||
procedure buildderef;
|
||||
procedure deref;
|
||||
{ add interface reference loaded from ppu }
|
||||
procedure addintf_deref(const d:tderef;iofs:longint);
|
||||
procedure addintf_ioffset(d:tdef;iofs:longint);
|
||||
|
||||
procedure clearmappings;
|
||||
procedure addmappings(intfindex: longint; const origname, newname: string);
|
||||
function getmappings(intfindex: longint; const origname: string; var nextexist: pointer): string;
|
||||
|
||||
procedure addimplproc(intfindex: longint; procdef: tprocdef);
|
||||
function implproccount(intfindex: longint): longint;
|
||||
function implprocs(intfindex: longint; procindex: longint): tprocdef;
|
||||
function isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
|
||||
|
||||
private
|
||||
finterfaces: tindexarray;
|
||||
procedure checkindex(intfindex: longint);
|
||||
end;
|
||||
|
||||
|
||||
tclassrefdef = class(tabstractpointerdef)
|
||||
constructor create(def:tdef);
|
||||
constructor ppuload(ppufile:tcompilerppufile);
|
||||
@ -4380,9 +4356,9 @@ implementation
|
||||
prepareguid;
|
||||
{ setup implemented interfaces }
|
||||
if objecttype in [odt_class,odt_interfacecorba] then
|
||||
implementedinterfaces:=timplementedinterfaces.create
|
||||
ImplementedInterfaces:=TFPObjectList.Create(true)
|
||||
else
|
||||
implementedinterfaces:=nil;
|
||||
ImplementedInterfaces:=nil;
|
||||
writing_class_record_dbginfo:=false;
|
||||
iitype := etStandard;
|
||||
end;
|
||||
@ -4390,8 +4366,10 @@ implementation
|
||||
|
||||
constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
|
||||
var
|
||||
i,implintfcount: longint;
|
||||
i,
|
||||
implintfcount : longint;
|
||||
d : tderef;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
inherited ppuload(objectdef,ppufile);
|
||||
objecttype:=tobjectdeftype(ppufile.getbyte);
|
||||
@ -4418,16 +4396,18 @@ implementation
|
||||
{ load implemented interfaces }
|
||||
if objecttype in [odt_class,odt_interfacecorba] then
|
||||
begin
|
||||
implementedinterfaces:=timplementedinterfaces.create;
|
||||
ImplementedInterfaces:=TFPObjectList.Create(true);
|
||||
implintfcount:=ppufile.getlongint;
|
||||
for i:=1 to implintfcount do
|
||||
for i:=0 to implintfcount-1 do
|
||||
begin
|
||||
ppufile.getderef(d);
|
||||
implementedinterfaces.addintf_deref(d,ppufile.getlongint);
|
||||
ppufile.getderef(d);
|
||||
ImplIntf:=TImplementedInterface.Create_deref(d);
|
||||
ImplIntf.IOffset:=ppufile.getlongint;
|
||||
ImplementedInterfaces.Add(ImplIntf);
|
||||
end;
|
||||
end
|
||||
else
|
||||
implementedinterfaces:=nil;
|
||||
ImplementedInterfaces:=nil;
|
||||
|
||||
tobjectsymtable(symtable).ppuload(ppufile);
|
||||
|
||||
@ -4455,8 +4435,8 @@ implementation
|
||||
stringdispose(objrealname);
|
||||
if assigned(iidstr) then
|
||||
stringdispose(iidstr);
|
||||
if assigned(implementedinterfaces) then
|
||||
implementedinterfaces.free;
|
||||
if assigned(ImplementedInterfaces) then
|
||||
ImplementedInterfaces.free;
|
||||
if assigned(iidguid) then
|
||||
dispose(iidguid);
|
||||
inherited destroy;
|
||||
@ -4465,8 +4445,7 @@ implementation
|
||||
|
||||
function tobjectdef.getcopy : tstoreddef;
|
||||
var
|
||||
i,
|
||||
implintfcount : longint;
|
||||
i : longint;
|
||||
begin
|
||||
result:=tobjectdef.create(objecttype,objname^,childof);
|
||||
tobjectdef(result).symtable:=symtable.getcopy;
|
||||
@ -4484,22 +4463,18 @@ implementation
|
||||
if assigned(iidstr) then
|
||||
tobjectdef(result).iidstr:=stringdup(iidstr^);
|
||||
tobjectdef(result).lastvtableindex:=lastvtableindex;
|
||||
if assigned(implementedinterfaces) then
|
||||
if assigned(ImplementedInterfaces) then
|
||||
begin
|
||||
implintfcount:=implementedinterfaces.count;
|
||||
for i:=1 to implintfcount do
|
||||
begin
|
||||
tobjectdef(result).implementedinterfaces.addintf_ioffset(implementedinterfaces.interfaces(i),
|
||||
implementedinterfaces.ioffsets(i));
|
||||
end;
|
||||
for i:=0 to ImplementedInterfaces.count-1 do
|
||||
tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
|
||||
var
|
||||
implintfcount : longint;
|
||||
i : longint;
|
||||
ImplIntf : TImplementedInterface;
|
||||
begin
|
||||
inherited ppuwrite(ppufile);
|
||||
ppufile.putbyte(byte(objecttype));
|
||||
@ -4519,13 +4494,13 @@ implementation
|
||||
|
||||
if objecttype in [odt_class,odt_interfacecorba] then
|
||||
begin
|
||||
implintfcount:=implementedinterfaces.count;
|
||||
ppufile.putlongint(implintfcount);
|
||||
for i:=1 to implintfcount do
|
||||
begin
|
||||
ppufile.putderef(implementedinterfaces.interfacesderef(i));
|
||||
ppufile.putlongint(implementedinterfaces.ioffsets(i));
|
||||
end;
|
||||
ppufile.putlongint(ImplementedInterfaces.Count);
|
||||
for i:=0 to ImplementedInterfaces.Count-1 do
|
||||
begin
|
||||
ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
|
||||
ppufile.putderef(ImplIntf.intfdefderef);
|
||||
ppufile.putlongint(ImplIntf.Ioffset);
|
||||
end;
|
||||
end;
|
||||
|
||||
ppufile.writeentry(ibobjectdef);
|
||||
@ -4549,6 +4524,7 @@ implementation
|
||||
|
||||
procedure tobjectdef.buildderef;
|
||||
var
|
||||
i : longint;
|
||||
oldrecsyms : tsymtable;
|
||||
begin
|
||||
inherited buildderef;
|
||||
@ -4558,12 +4534,16 @@ implementation
|
||||
tstoredsymtable(symtable).buildderef;
|
||||
aktrecordsymtable:=oldrecsyms;
|
||||
if objecttype in [odt_class,odt_interfacecorba] then
|
||||
implementedinterfaces.buildderef;
|
||||
begin
|
||||
for i:=0 to ImplementedInterfaces.count-1 do
|
||||
TImplementedInterface(ImplementedInterfaces[i]).buildderef;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure tobjectdef.deref;
|
||||
var
|
||||
i : longint;
|
||||
oldrecsyms : tsymtable;
|
||||
begin
|
||||
inherited deref;
|
||||
@ -4573,7 +4553,10 @@ implementation
|
||||
tstoredsymtable(symtable).deref;
|
||||
aktrecordsymtable:=oldrecsyms;
|
||||
if objecttype in [odt_class,odt_interfacecorba] then
|
||||
implementedinterfaces.deref;
|
||||
begin
|
||||
for i:=0 to ImplementedInterfaces.count-1 do
|
||||
TImplementedInterface(ImplementedInterfaces[i]).deref;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -4796,6 +4779,26 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
|
||||
var
|
||||
ImplIntf : TImplementedInterface;
|
||||
i : longint;
|
||||
begin
|
||||
result:=nil;
|
||||
if not assigned(ImplementedInterfaces) then
|
||||
exit;
|
||||
for i:=0 to ImplementedInterfaces.Count-1 do
|
||||
begin
|
||||
ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
|
||||
if ImplIntf.intfdef=aintfdef then
|
||||
begin
|
||||
result:=ImplIntf;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure tobjectdef.collect_published_properties(sym:tnamedindexitem;arg:pointer);
|
||||
var
|
||||
hp : tpropnamelistitem;
|
||||
@ -5199,301 +5202,133 @@ implementation
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
TIMPLEMENTEDINTERFACES
|
||||
TImplementedInterface
|
||||
****************************************************************************}
|
||||
type
|
||||
tnamemap = class(TNamedIndexItem)
|
||||
listnext : TNamedIndexItem;
|
||||
newname: pshortstring;
|
||||
constructor create(const aname, anewname: string);
|
||||
destructor destroy; override;
|
||||
end;
|
||||
|
||||
constructor tnamemap.create(const aname, anewname: string);
|
||||
begin
|
||||
inherited createname(aname);
|
||||
newname:=stringdup(anewname);
|
||||
end;
|
||||
|
||||
destructor tnamemap.destroy;
|
||||
begin
|
||||
stringdispose(newname);
|
||||
inherited destroy;
|
||||
end;
|
||||
|
||||
|
||||
type
|
||||
tprocdefstore = class(TNamedIndexItem)
|
||||
procdef: tprocdef;
|
||||
constructor create(aprocdef: tprocdef);
|
||||
end;
|
||||
|
||||
constructor tprocdefstore.create(aprocdef: tprocdef);
|
||||
constructor TImplementedInterface.create(aintf: tobjectdef);
|
||||
begin
|
||||
inherited create;
|
||||
procdef:=aprocdef;
|
||||
end;
|
||||
|
||||
|
||||
constructor timplintfentry.create(aintf: tobjectdef);
|
||||
begin
|
||||
inherited create;
|
||||
intf:=aintf;
|
||||
intfdef:=aintf;
|
||||
ioffset:=-1;
|
||||
namemappings:=nil;
|
||||
NameMappings:=nil;
|
||||
procdefs:=nil;
|
||||
end;
|
||||
|
||||
|
||||
constructor timplintfentry.create_deref(d:tderef);
|
||||
constructor TImplementedInterface.create_deref(d:tderef);
|
||||
begin
|
||||
inherited create;
|
||||
intf:=nil;
|
||||
intfderef:=d;
|
||||
intfdef:=nil;
|
||||
intfdefderef:=d;
|
||||
ioffset:=-1;
|
||||
namemappings:=nil;
|
||||
NameMappings:=nil;
|
||||
procdefs:=nil;
|
||||
end;
|
||||
|
||||
|
||||
destructor timplintfentry.destroy;
|
||||
destructor TImplementedInterface.destroy;
|
||||
var
|
||||
i : longint;
|
||||
mappedname : pshortstring;
|
||||
begin
|
||||
if assigned(namemappings) then
|
||||
namemappings.free;
|
||||
if assigned(NameMappings) then
|
||||
begin
|
||||
for i:=0 to NameMappings.Count-1 do
|
||||
begin
|
||||
mappedname:=pshortstring(NameMappings[i]);
|
||||
stringdispose(mappedname);
|
||||
end;
|
||||
NameMappings.free;
|
||||
end;
|
||||
if assigned(procdefs) then
|
||||
procdefs.free;
|
||||
inherited destroy;
|
||||
end;
|
||||
|
||||
|
||||
constructor timplementedinterfaces.create;
|
||||
procedure TImplementedInterface.buildderef;
|
||||
begin
|
||||
finterfaces:=tindexarray.create(1);
|
||||
end;
|
||||
|
||||
destructor timplementedinterfaces.destroy;
|
||||
begin
|
||||
finterfaces.destroy;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.count: longint;
|
||||
begin
|
||||
count:=finterfaces.count;
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.checkindex(intfindex: longint);
|
||||
begin
|
||||
if (intfindex<1) or (intfindex>count) then
|
||||
InternalError(200006123);
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.interfacesderef(intfindex: longint): tderef;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
interfacesderef:=timplintfentry(finterfaces.search(intfindex)).intfderef;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.ioffsets(intfindex: longint): longint;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
ioffsets:=timplintfentry(finterfaces.search(intfindex)).ioffset;
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.setioffsets(intfindex,iofs:longint);
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
timplintfentry(finterfaces.search(intfindex)).ioffset:=iofs;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.implindex(intfindex:longint):longint;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
result:=timplintfentry(finterfaces.search(intfindex)).implindex;
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.setimplindex(intfindex,implidx:longint);
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
timplintfentry(finterfaces.search(intfindex)).implindex:=implidx;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.searchintf(def: tdef): longint;
|
||||
begin
|
||||
for result := 1 to count do
|
||||
if tdef(interfaces(result)) = def then
|
||||
exit;
|
||||
result := -1;
|
||||
intfdefderef.build(intfdef);
|
||||
end;
|
||||
|
||||
|
||||
procedure timplementedinterfaces.buildderef;
|
||||
procedure TImplementedInterface.deref;
|
||||
begin
|
||||
intfdef:=tobjectdef(intfdefderef.resolve);
|
||||
end;
|
||||
|
||||
|
||||
procedure TImplementedInterface.AddMapping(const origname,newname: string);
|
||||
begin
|
||||
if not assigned(NameMappings) then
|
||||
NameMappings:=TFPHashList.Create;
|
||||
NameMappings.Add(origname,stringdup(newname));
|
||||
end;
|
||||
|
||||
|
||||
function TImplementedInterface.GetMapping(const origname: string):string;
|
||||
var
|
||||
i: longint;
|
||||
mappedname : pshortstring;
|
||||
begin
|
||||
for i:=1 to count do
|
||||
with timplintfentry(finterfaces.search(i)) do
|
||||
intfderef.build(intf);
|
||||
result:='';
|
||||
if not assigned(NameMappings) then
|
||||
exit;
|
||||
mappedname:=PShortstring(NameMappings.Find(origname));
|
||||
if assigned(mappedname) then
|
||||
result:=mappedname^;
|
||||
end;
|
||||
|
||||
|
||||
procedure timplementedinterfaces.deref;
|
||||
var
|
||||
i: longint;
|
||||
begin
|
||||
for i:=1 to count do
|
||||
with timplintfentry(finterfaces.search(i)) do
|
||||
intf:=tobjectdef(intfderef.resolve);
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.addintf_deref(const d:tderef;iofs:longint);
|
||||
var
|
||||
hintf : timplintfentry;
|
||||
begin
|
||||
hintf:=timplintfentry.create_deref(d);
|
||||
hintf.ioffset:=iofs;
|
||||
finterfaces.insert(hintf);
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.addintf_ioffset(d:tdef;iofs:longint);
|
||||
var
|
||||
hintf : timplintfentry;
|
||||
begin
|
||||
hintf:=timplintfentry.create(tobjectdef(d));
|
||||
hintf.ioffset:=iofs;
|
||||
finterfaces.insert(hintf);
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.addintf(def: tdef);
|
||||
begin
|
||||
if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
|
||||
not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
|
||||
internalerror(200006124);
|
||||
finterfaces.insert(timplintfentry.create(tobjectdef(def)));
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.clearmappings;
|
||||
var
|
||||
i: longint;
|
||||
begin
|
||||
for i:=1 to count do
|
||||
with timplintfentry(finterfaces.search(i)) do
|
||||
begin
|
||||
if assigned(namemappings) then
|
||||
namemappings.free;
|
||||
namemappings:=nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.addmappings(intfindex: longint; const origname, newname: string);
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
with timplintfentry(finterfaces.search(intfindex)) do
|
||||
begin
|
||||
if not assigned(namemappings) then
|
||||
namemappings:=tdictionary.create;
|
||||
namemappings.insert(tnamemap.create(origname,newname));
|
||||
end;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.getmappings(intfindex: longint; const origname: string; var nextexist: pointer): string;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
if not assigned(nextexist) then
|
||||
with timplintfentry(finterfaces.search(intfindex)) do
|
||||
begin
|
||||
if assigned(namemappings) then
|
||||
nextexist:=namemappings.search(origname)
|
||||
else
|
||||
nextexist:=nil;
|
||||
end;
|
||||
if assigned(nextexist) then
|
||||
begin
|
||||
getmappings:=tnamemap(nextexist).newname^;
|
||||
nextexist:=tnamemap(nextexist).listnext;
|
||||
end
|
||||
else
|
||||
getmappings:='';
|
||||
end;
|
||||
|
||||
procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
|
||||
procedure TImplementedInterface.AddImplProc(pd:tprocdef);
|
||||
var
|
||||
i : longint;
|
||||
found : boolean;
|
||||
i : longint;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
with timplintfentry(finterfaces.search(intfindex)) do
|
||||
begin
|
||||
if not assigned(procdefs) then
|
||||
procdefs:=tindexarray.create(4);
|
||||
{ No duplicate entries of the same procdef }
|
||||
found:=false;
|
||||
for i:=1 to procdefs.count do
|
||||
if tprocdefstore(procdefs.search(i)).procdef=procdef then
|
||||
begin
|
||||
found:=true;
|
||||
break;
|
||||
end;
|
||||
if not found then
|
||||
procdefs.insert(tprocdefstore.create(procdef));
|
||||
end;
|
||||
if not assigned(procdefs) then
|
||||
procdefs:=TFPObjectList.Create(false);
|
||||
{ No duplicate entries of the same procdef }
|
||||
found:=false;
|
||||
for i:=0 to procdefs.count-1 do
|
||||
if tprocdef(procdefs[i])=pd then
|
||||
begin
|
||||
found:=true;
|
||||
break;
|
||||
end;
|
||||
if not found then
|
||||
procdefs.Add(pd);
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.implproccount(intfindex: longint): longint;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
with timplintfentry(finterfaces.search(intfindex)) do
|
||||
if assigned(procdefs) then
|
||||
implproccount:=procdefs.count
|
||||
else
|
||||
implproccount:=0;
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
with timplintfentry(finterfaces.search(intfindex)) do
|
||||
if assigned(procdefs) then
|
||||
implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
|
||||
else
|
||||
internalerror(200006131);
|
||||
end;
|
||||
|
||||
function timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
|
||||
function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
|
||||
var
|
||||
possible: boolean;
|
||||
i: longint;
|
||||
iiep1: TIndexArray;
|
||||
iiep2: TIndexArray;
|
||||
i : longint;
|
||||
begin
|
||||
checkindex(intfindex);
|
||||
checkindex(remainindex);
|
||||
iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
|
||||
iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
|
||||
if not assigned(iiep1) then { empty interface is mergeable :-) }
|
||||
result:=false;
|
||||
weight:=0;
|
||||
{ empty interface is mergeable }
|
||||
if ProcDefs.Count=0 then
|
||||
begin
|
||||
possible:=true;
|
||||
weight:=0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
|
||||
i:=1;
|
||||
while (possible) and (i<=iiep1.count) do
|
||||
begin
|
||||
possible:=
|
||||
(tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
|
||||
inc(i);
|
||||
end;
|
||||
if possible then
|
||||
weight:=iiep1.count;
|
||||
result:=true;
|
||||
exit;
|
||||
end;
|
||||
isimplmergepossible:=possible;
|
||||
{ The interface to merge must at least the number of
|
||||
procedures of this interface }
|
||||
if MergingIntf.ProcDefs.Count<ProcDefs.Count then
|
||||
exit;
|
||||
for i:=0 to ProcDefs.Count-1 do
|
||||
begin
|
||||
if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
|
||||
exit;
|
||||
end;
|
||||
weight:=ProcDefs.Count;
|
||||
result:=true;
|
||||
end;
|
||||
|
||||
|
||||
function TImplementedInterface.getcopy:TImplementedInterface;
|
||||
begin
|
||||
Result:=TImplementedInterface.Create(nil);
|
||||
Move(pointer(self)^,pointer(result)^,InstanceSize);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user