paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-25 18:01:53 +02:00
Code Issues Packages Projects Releases Wiki Activity

* refactor implemented interfaces

Browse Source 
git-svn-id: trunk@5134 -
This commit is contained in:
peter 2006-10-31 22:38:49 +00:00
parent 72ff9d9f3e
commit 136d3e8d46
11 changed files with 402 additions and 566 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/aasmdata.pas
View File

@ -133,10 +133,10 @@ interface
function RefAsmSymbol(const s : string) : tasmsymbol; function RefAsmSymbol(const s : string) : tasmsymbol;
function getasmsymbol(const s : string) : tasmsymbol; function getasmsymbol(const s : string) : tasmsymbol;
{ create new assembler label } { create new assembler label }
procedure getlabel(var l : tasmlabel;alt:tasmlabeltype); procedure getlabel(out l : tasmlabel;alt:tasmlabeltype);
procedure getjumplabel(var l : tasmlabel); procedure getjumplabel(out l : tasmlabel);
procedure getaddrlabel(var l : tasmlabel); procedure getaddrlabel(out l : tasmlabel);
procedure getdatalabel(var l : tasmlabel); procedure getdatalabel(out l : tasmlabel);
{ generate an alternative (duplicate) symbol } { generate an alternative (duplicate) symbol }
procedure GenerateAltSymbol(p:tasmsymbol); procedure GenerateAltSymbol(p:tasmsymbol);
procedure ResetAltSymbols; procedure ResetAltSymbols;
@ -386,7 +386,7 @@ implementation
end; end;
procedure TAsmData.getlabel(var l : tasmlabel;alt:tasmlabeltype); procedure TAsmData.getlabel(out l : tasmlabel;alt:tasmlabeltype);
begin begin
l:=tasmlabel.createlocal(FNextLabelNr[alt],alt); l:=tasmlabel.createlocal(FNextLabelNr[alt],alt);
inc(FNextLabelNr[alt]); inc(FNextLabelNr[alt]);
@ -394,7 +394,7 @@ implementation
end; end;
procedure TAsmData.getjumplabel(var l : tasmlabel); procedure TAsmData.getjumplabel(out l : tasmlabel);
begin begin
l:=tasmlabel.createlocal(FNextLabelNr[alt_jump],alt_jump); l:=tasmlabel.createlocal(FNextLabelNr[alt_jump],alt_jump);
inc(FNextLabelNr[alt_jump]); inc(FNextLabelNr[alt_jump]);
@ -402,7 +402,7 @@ implementation
end; end;
procedure TAsmData.getdatalabel(var l : tasmlabel); procedure TAsmData.getdatalabel(out l : tasmlabel);
begin begin
l:=tasmlabel.createglobal(name,FNextLabelNr[alt_data],alt_data); l:=tasmlabel.createglobal(name,FNextLabelNr[alt_data],alt_data);
inc(FNextLabelNr[alt_data]); inc(FNextLabelNr[alt_data]);
@ -410,7 +410,7 @@ implementation
end; end;
procedure TAsmData.getaddrlabel(var l : tasmlabel); procedure TAsmData.getaddrlabel(out l : tasmlabel);
begin begin
l:=tasmlabel.createlocal(FNextLabelNr[alt_addr],alt_addr); l:=tasmlabel.createlocal(FNextLabelNr[alt_addr],alt_addr);
inc(FNextLabelNr[alt_addr]); inc(FNextLabelNr[alt_addr]);

6
compiler/dbgdwarf.pas
View File

@ -2658,11 +2658,11 @@ end;
end; end;
{ add implemented interfaces } { add implemented interfaces }
if assigned(def.implementedinterfaces) then if assigned(def.ImplementedInterfaces) then
for n := 1 to def.implementedinterfaces.count do for n := 0 to def.ImplementedInterfaces.count-1 do
begin begin
append_entry(DW_TAG_inheritance,false,[]); 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; finish_entry;
end; end;

14
compiler/defcmp.pas
View File

@ -166,7 +166,7 @@ implementation
subeq,eq : tequaltype; subeq,eq : tequaltype;
hd1,hd2 : tdef; hd1,hd2 : tdef;
hct : tconverttype; hct : tconverttype;
hd3 : tobjectdef; hobjdef : tobjectdef;
hpd : tprocdef; hpd : tprocdef;
begin begin
eq:=te_incompatible; eq:=te_incompatible;
@ -1149,21 +1149,21 @@ implementation
end end
{ classes can be assigned to interfaces } { classes can be assigned to interfaces }
else if is_interface(def_to) and else if is_interface(def_to) and
is_class(def_from) and is_class(def_from) and
assigned(tobjectdef(def_from).implementedinterfaces) then assigned(tobjectdef(def_from).ImplementedInterfaces) then
begin begin
{ we've to search in parent classes as well } { we've to search in parent classes as well }
hd3:=tobjectdef(def_from); hobjdef:=tobjectdef(def_from);
while assigned(hd3) do while assigned(hobjdef) do
begin begin
if hd3.implementedinterfaces.searchintf(def_to)<>-1 then if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then
begin begin
doconv:=tc_class_2_intf; doconv:=tc_class_2_intf;
{ don't prefer this over objectdef->objectdef } { don't prefer this over objectdef->objectdef }
eq:=te_convert_l2; eq:=te_convert_l2;
break; break;
end; end;
hd3:=hd3.childof; hobjdef:=hobjdef.childof;
end; end;
end end
{ Interface 2 GUID handling } { Interface 2 GUID handling }

16
compiler/ncgcnv.pas
View File

@ -448,6 +448,7 @@ interface
var var
l1 : tasmlabel; l1 : tasmlabel;
hd : tobjectdef; hd : tobjectdef;
ImplIntf : TImplementedInterface;
begin begin
location_reset(location,LOC_REGISTER,OS_ADDR); location_reset(location,LOC_REGISTER,OS_ADDR);
case left.location.loc of case left.location.loc of
@ -473,14 +474,13 @@ interface
hd:=tobjectdef(left.resultdef); hd:=tobjectdef(left.resultdef);
while assigned(hd) do while assigned(hd) do
begin begin
if hd.implementedinterfaces.searchintf(resultdef)<>-1 then ImplIntf:=hd.find_implemented_interface(tobjectdef(resultdef));
begin if assigned(ImplIntf) then
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR, begin
hd.implementedinterfaces.ioffsets( cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR,ImplIntf.ioffset,location.register);
hd.implementedinterfaces.searchintf(resultdef)),location.register); break;
break; end;
end; hd:=hd.childof;
hd:=hd.childof;
end; end;
if hd=nil then if hd=nil then
internalerror(2002081301); internalerror(2002081301);

23
compiler/ncgutil.pas
View File

@ -2722,25 +2722,26 @@ implementation
procedure gen_intf_wrapper(list:TAsmList;_class:tobjectdef); procedure gen_intf_wrapper(list:TAsmList;_class:tobjectdef);
var var
i,j, i,j : longint;
proccount : longint;
tmps : string; tmps : string;
pd : TProcdef;
ImplIntf : TImplementedInterface;
begin begin
for i:=1 to _class.implementedinterfaces.count do for i:=0 to _class.ImplementedInterfaces.count-1 do
begin begin
{ only if implemented by this class } ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
if _class.implementedinterfaces.implindex(i)=i then if (ImplIntf=ImplIntf.VtblImplIntf) and
assigned(ImplIntf.ProcDefs) then
begin begin
proccount:=_class.implementedinterfaces.implproccount(i); for j:=0 to ImplIntf.ProcDefs.Count-1 do
for j:=1 to proccount do
begin begin
pd:=TProcdef(ImplIntf.ProcDefs[j]);
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+ tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+
_class.implementedinterfaces.interfaces(i).objname^+'_$_'+ ImplIntf.IntfDef.objname^+'_$_'+tostr(j)+'_$_'+pd.mangledname);
tostr(j)+'_$_'+_class.implementedinterfaces.implprocs(i,j).mangledname);
{ create wrapper code } { create wrapper code }
new_section(list,sec_code,lower(tmps),0); new_section(list,sec_code,tmps,0);
cg.init_register_allocators; 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; cg.done_register_allocators;
end; end;
end; end;

5
compiler/ncnv.pas
View File

@ -2766,9 +2766,8 @@ implementation
{ left is a class } { left is a class }
if is_class(left.resultdef) then if is_class(left.resultdef) then
begin begin
{ the operands must be related } { the class must implement the interface }
if not(assigned(tobjectdef(left.resultdef).implementedinterfaces) and if tobjectdef(left.resultdef).find_implemented_interface(tobjectdef(right.resultdef))=nil then
(tobjectdef(left.resultdef).implementedinterfaces.searchintf(right.resultdef)<>-1)) then
CGMessage2(type_e_classes_not_related, CGMessage2(type_e_classes_not_related,
FullTypeName(left.resultdef,right.resultdef), FullTypeName(left.resultdef,right.resultdef),
FullTypeName(right.resultdef,left.resultdef)) FullTypeName(right.resultdef,left.resultdef))

276
compiler/nobj.pas
View File

@ -95,14 +95,14 @@ interface
procedure writevirtualmethods(List:TAsmList); procedure writevirtualmethods(List:TAsmList);
private private
{ interface tables } { interface tables }
function gintfgetvtbllabelname(intfindex: integer): string; function intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
procedure gintfcreatevtbl(intfindex: integer; rawdata: TAsmList); procedure intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface);
procedure gintfgenentry(intfindex, contintfindex: integer; rawdata: TAsmList); procedure intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
procedure gintfoptimizevtbls; procedure intf_optimize_vtbls;
procedure gintfwritedata; procedure intf_write_data;
function gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef; function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
procedure gintfdoonintf(intf: tobjectdef; intfindex: longint); procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
procedure gintfwalkdowninterface(intf: tobjectdef; intfindex: longint); procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
public public
constructor create(c:tobjectdef); constructor create(c:tobjectdef);
destructor destroy;override; destructor destroy;override;
@ -129,7 +129,7 @@ implementation
uses uses
SysUtils, SysUtils,
globals,verbose,systems, globals,verbose,systems,
symtable,symconst,symtype,defcmp,defutil, symtable,symconst,symtype,defcmp,
dbgbase dbgbase
; ;
@ -256,7 +256,7 @@ implementation
procedure tclassheader.writenames(p : pprocdeftree); procedure tclassheader.writenames(p : pprocdeftree);
var var
ca : pchar; ca : pchar;
len : longint; len : byte;
begin begin
current_asmdata.getdatalabel(p^.nl); current_asmdata.getdatalabel(p^.nl);
if assigned(p^.l) then if assigned(p^.l) then
@ -290,7 +290,6 @@ implementation
function tclassheader.genstrmsgtab : tasmlabel; function tclassheader.genstrmsgtab : tasmlabel;
var var
r : tasmlabel;
count : aint; count : aint;
begin begin
root:=nil; root:=nil;
@ -303,10 +302,9 @@ implementation
writenames(root); writenames(root);
{ now start writing of the message string table } { 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(cai_align.create(const_align(sizeof(aint))));
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(r)); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(result));
genstrmsgtab:=r;
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(count)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(count));
if assigned(root) then if assigned(root) then
begin begin
@ -859,60 +857,58 @@ implementation
Interface tables Interface tables
**************************************} **************************************}
function tclassheader.gintfgetvtbllabelname(intfindex: integer): string; function tclassheader.intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
begin begin
gintfgetvtbllabelname:=make_mangledname('VTBL',_class.owner,_class.objname^+ result:=make_mangledname('VTBL',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^);
'_$_'+_class.implementedinterfaces.interfaces(intfindex).objname^);
end; end;
procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata: TAsmList); procedure tclassheader.intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface);
var var
implintf: timplementedinterfaces; pd : tprocdef;
curintf: tobjectdef; vtblstr,
proccount: integer; hs : string;
tmps: string; i : longint;
i: longint;
begin begin
implintf:=_class.implementedinterfaces; vtblstr:=intf_get_vtbl_name(AImplIntf);
curintf:=implintf.interfaces(intfindex); section_symbol_start(rawdata,vtblstr,AT_DATA,true,sec_data,const_align(sizeof(aint)));
if assigned(AImplIntf.procdefs) then
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
begin begin
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+curintf.objname^+'_$_'+ for i:=0 to AImplIntf.procdefs.count-1 do
tostr(i)+'_$_'+ begin
implintf.implprocs(intfindex,i).mangledname); pd:=tprocdef(AImplIntf.procdefs[i]);
{ create reference } hs:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+
rawdata.concat(Tai_const.Createname(tmps,0)); tostr(i)+'_$_'+pd.mangledname);
end; { create reference }
section_symbol_end(rawdata,gintfgetvtbllabelname(intfindex)); rawdata.concat(Tai_const.Createname(hs,0));
end;
end;
section_symbol_end(rawdata,vtblstr);
end; end;
procedure tclassheader.gintfgenentry(intfindex, contintfindex: integer; rawdata: TAsmList); procedure tclassheader.intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
var var
implintf: timplementedinterfaces; iidlabel,
curintf: tobjectdef; guidlabel : tasmlabel;
tmplabel: tasmlabel;
i: longint; i: longint;
begin begin
implintf:=_class.implementedinterfaces;
curintf:=implintf.interfaces(intfindex);
{ GUID } { GUID }
if curintf.objecttype in [odt_interfacecom] then if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
begin begin
{ label for GUID } { label for GUID }
current_asmdata.getdatalabel(tmplabel); current_asmdata.getdatalabel(guidlabel);
rawdata.concat(cai_align.create(const_align(sizeof(aint)))); rawdata.concat(cai_align.create(const_align(sizeof(aint))));
rawdata.concat(Tai_label.Create(tmplabel)); rawdata.concat(Tai_label.Create(guidlabel));
rawdata.concat(Tai_const.Create_32bit(longint(curintf.iidguid^.D1))); with AImplIntf.IntfDef.iidguid^ do
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D2)); begin
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D3)); rawdata.concat(Tai_const.Create_32bit(longint(D1)));
for i:=Low(curintf.iidguid^.D4) to High(curintf.iidguid^.D4) do rawdata.concat(Tai_const.Create_16bit(D2));
rawdata.concat(Tai_const.Create_8bit(curintf.iidguid^.D4[i])); rawdata.concat(Tai_const.Create_16bit(D3));
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(tmplabel)); 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 end
else else
begin begin
@ -920,73 +916,77 @@ implementation
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
end; end;
{ VTable } { 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 } { 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 } { IIDStr }
current_asmdata.getdatalabel(tmplabel); current_asmdata.getdatalabel(iidlabel);
rawdata.concat(cai_align.create(const_align(sizeof(aint)))); rawdata.concat(cai_align.create(const_align(sizeof(aint))));
rawdata.concat(Tai_label.Create(tmplabel)); rawdata.concat(Tai_label.Create(iidlabel));
rawdata.concat(Tai_const.Create_8bit(length(curintf.iidstr^))); rawdata.concat(Tai_const.Create_8bit(length(AImplIntf.IntfDef.iidstr^)));
if curintf.objecttype=odt_interfacecom then if AImplIntf.IntfDef.objecttype=odt_interfacecom then
rawdata.concat(Tai_string.Create(upper(curintf.iidstr^))) rawdata.concat(Tai_string.Create(upper(AImplIntf.IntfDef.iidstr^)))
else else
rawdata.concat(Tai_string.Create(curintf.iidstr^)); rawdata.concat(Tai_string.Create(AImplIntf.IntfDef.iidstr^));
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(tmplabel)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(iidlabel));
{ EntryType } { 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 } { 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; end;
procedure tclassheader.gintfoptimizevtbls; procedure tclassheader.intf_optimize_vtbls;
type type
tcompintfentry = record tcompintfentry = record
weight: longint; weight: longint;
compintf: longint; compintf: longint;
end; end;
{ Max 1000 interface in the class header interfaces it's enough imho } { 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; pcompintfs = ^tcompintfs;
tequals = array[1..1000] of longint; tequals = array[0..1000] of longint;
pequals = ^tequals; pequals = ^tequals;
timpls = array[1..1000] of longint; timpls = array[0..1000] of longint;
pimpls = ^timpls; pimpls = ^timpls;
var var
max: longint;
equals: pequals; equals: pequals;
compats: pcompintfs; compats: pcompintfs;
impls: pimpls; impls: pimpls;
ImplIntfCount,
w,i,j,k: longint; w,i,j,k: longint;
ImplIntfI,
ImplIntfJ : TImplementedInterface;
cij: boolean; cij: boolean;
cji: boolean; cji: boolean;
begin begin
max:=_class.implementedinterfaces.count; ImplIntfCount:=_class.ImplementedInterfaces.count;
if max>High(tequals) then if ImplIntfCount>=High(tequals) then
Internalerror(200006135); Internalerror(200006135);
getmem(compats,sizeof(tcompintfentry)*max); getmem(compats,sizeof(tcompintfentry)*ImplIntfCount);
getmem(equals,sizeof(longint)*max); getmem(equals,sizeof(longint)*ImplIntfCount);
getmem(impls,sizeof(longint)*max); getmem(impls,sizeof(longint)*ImplIntfCount);
fillchar(compats^,sizeof(tcompintfentry)*max,0); filldword(compats^,(sizeof(tcompintfentry) div sizeof(dword))*ImplIntfCount,dword(-1));
fillchar(equals^,sizeof(longint)*max,0); filldword(equals^,ImplIntfCount,dword(-1));
fillchar(impls^,sizeof(longint)*max,0); filldword(impls^,ImplIntfCount,dword(-1));
{ ismergepossible is a containing relation { ismergepossible is a containing relation
meaning of ismergepossible(a,b,w) = meaning of ismergepossible(a,b,w) =
if implementorfunction map of a is contained implementorfunction map of b 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 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 } { the order is very important for correct allocation }
for i:=1 to max do for i:=0 to ImplIntfCount-1 do
begin begin
for j:=i+1 to max do for j:=i+1 to ImplIntfCount-1 do
begin begin
cij:=_class.implementedinterfaces.isimplmergepossible(i,j,w); ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]);
cji:=_class.implementedinterfaces.isimplmergepossible(j,i,w); ImplIntfJ:=TImplementedInterface(_class.ImplementedInterfaces[j]);
cij:=ImplIntfI.IsImplMergePossible(ImplIntfJ,w);
cji:=ImplIntfJ.IsImplMergePossible(ImplIntfI,w);
if cij and cji then { i equal j } if cij and cji then { i equal j }
begin begin
{ get minimum index of equal } { get minimum index of equal }
if equals^[j]=0 then if equals^[j]=-1 then
equals^[j]:=i; equals^[j]:=i;
end end
else if cij then else if cij then
@ -1010,7 +1010,7 @@ implementation
end; end;
end; end;
{ Reset, no replacements by default } { Reset, no replacements by default }
for i:=1 to max do for i:=0 to ImplIntfCount-1 do
impls^[i]:=i; impls^[i]:=i;
{ Replace vtbls when equal or compat, repeat { Replace vtbls when equal or compat, repeat
until there are no replacements possible anymore. This is until there are no replacements possible anymore. This is
@ -1020,64 +1020,70 @@ implementation
} }
repeat repeat
k:=0; k:=0;
for i:=1 to max do for i:=0 to ImplIntfCount-1 do
begin begin
if compats^[impls^[i]].compintf<>0 then if compats^[impls^[i]].compintf<>-1 then
impls^[i]:=compats^[impls^[i]].compintf 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]] impls^[i]:=equals^[impls^[i]]
else else
inc(k); inc(k);
end; end;
until k=max; until k=ImplIntfCount;
{ Update the implindex } { Update the VtblImplIntf }
for i:=1 to max do for i:=0 to ImplIntfCount-1 do
_class.implementedinterfaces.setimplindex(i,impls^[i]); begin
ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]);
ImplIntfI.VtblImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[impls^[i]]);
end;
freemem(compats); freemem(compats);
freemem(equals); freemem(equals);
freemem(impls); freemem(impls);
end; end;
procedure tclassheader.gintfwritedata; procedure tclassheader.intf_write_data;
var var
rawdata: TAsmList; rawdata : TAsmList;
max,i,j : smallint; i : longint;
ImplIntf : TImplementedInterface;
begin begin
max:=_class.implementedinterfaces.count;
rawdata:=TAsmList.Create; rawdata:=TAsmList.Create;
{ Two pass, one for allocation and vtbl creation } { Two pass, one for allocation and vtbl creation }
for i:=1 to max do for i:=0 to _class.ImplementedInterfaces.count-1 do
begin 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 begin
{ allocate a pointer in the object memory } { allocate a pointer in the object memory }
with tobjectsymtable(_class.symtable) do with tobjectsymtable(_class.symtable) do
begin begin
datasize:=align(datasize,sizeof(aint)); datasize:=align(datasize,sizeof(aint));
_class.implementedinterfaces.setioffsets(i,datasize); ImplIntf.Ioffset:=datasize;
inc(datasize,sizeof(aint)); inc(datasize,sizeof(aint));
end; end;
{ write vtbl } { write vtbl }
gintfcreatevtbl(i,rawdata); intf_create_vtbl(rawdata,ImplIntf);
end; end;
end; end;
{ second pass: for fill interfacetable and remained ioffsets } { second pass: for fill interfacetable and remained ioffsets }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(max)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(_class.ImplementedInterfaces.count));
for i:=1 to max do for i:=0 to _class.ImplementedInterfaces.count-1 do
begin begin
j:=_class.implementedinterfaces.implindex(i); ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
if j<>i then { Update ioffset of current interface with the ioffset from
_class.implementedinterfaces.setioffsets(i,_class.implementedinterfaces.ioffsets(j)); the interface that is reused to implements this interface }
gintfgenentry(i,j,rawdata); if ImplIntf.VtblImplIntf<>ImplIntf then
ImplIntf.Ioffset:=ImplIntf.VtblImplIntf.Ioffset;
intf_gen_intf_ref(rawdata,ImplIntf);
end; end;
current_asmdata.asmlists[al_globals].concatlist(rawdata); current_asmdata.asmlists[al_globals].concatlist(rawdata);
rawdata.free; rawdata.free;
end; end;
function tclassheader.gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef; function tclassheader.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
const const
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint, po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
@ -1086,7 +1092,7 @@ implementation
implprocdef : Tprocdef; implprocdef : Tprocdef;
i: cardinal; i: cardinal;
begin begin
gintfgetcprocdef:=nil; result:=nil;
sym:=tsym(search_class_member(_class,name)); sym:=tsym(search_class_member(_class,name));
if assigned(sym) and if assigned(sym) and
@ -1108,7 +1114,7 @@ implementation
(proc.proctypeoption=implprocdef.proctypeoption) and (proc.proctypeoption=implprocdef.proctypeoption) and
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
begin begin
gintfgetcprocdef:=implprocdef; result:=implprocdef;
exit; exit;
end; end;
end; end;
@ -1116,35 +1122,35 @@ implementation
end; end;
procedure tclassheader.gintfdoonintf(intf: tobjectdef; intfindex: longint); procedure tclassheader.intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
var var
def: tdef; def: tdef;
hs, hs,
prefix, prefix,
mappedname: string; mappedname: string;
nextexist: pointer;
implprocdef: tprocdef; implprocdef: tprocdef;
begin begin
prefix:=_class.implementedinterfaces.interfaces(intfindex).symtable.name^+'.'; prefix:=ImplIntf.IntfDef.symtable.name^+'.';
def:=tdef(intf.symtable.defindex.first); def:=tdef(IntfDef.symtable.defindex.first);
while assigned(def) do while assigned(def) do
begin begin
if def.deftype=procdef then if def.deftype=procdef then
begin begin
{ Find implementing procdef
1. Check for mapped name
2. Use symbol name }
implprocdef:=nil; implprocdef:=nil;
nextexist:=nil; hs:=prefix+tprocdef(def).procsym.name;
repeat mappedname:=ImplIntf.GetMapping(hs);
hs:=prefix+tprocdef(def).procsym.name; if mappedname<>'' then
mappedname:=_class.implementedinterfaces.getmappings(intfindex,hs,nextexist); implprocdef:=intf_search_procdef_by_name(tprocdef(def),mappedname);
if mappedname<>'' then
implprocdef:=gintfgetcprocdef(tprocdef(def),mappedname);
until assigned(implprocdef) or not assigned(nextexist);
if not assigned(implprocdef) then 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 if assigned(implprocdef) then
_class.implementedinterfaces.addimplproc(intfindex,implprocdef) ImplIntf.AddImplProc(implprocdef)
else 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)); Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
end; end;
def:=tdef(def.indexnext); def:=tdef(def.indexnext);
@ -1152,33 +1158,33 @@ implementation
end; end;
procedure tclassheader.gintfwalkdowninterface(intf: tobjectdef; intfindex: longint); procedure tclassheader.intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
begin begin
if assigned(intf.childof) then if assigned(IntfDef.childof) then
gintfwalkdowninterface(intf.childof,intfindex); intf_get_procdefs_recursive(ImplIntf,IntfDef.childof);
gintfdoonintf(intf,intfindex); intf_get_procdefs(ImplIntf,IntfDef);
end; end;
function tclassheader.genintftable: tasmlabel; function tclassheader.genintftable: tasmlabel;
var var
intfindex: longint; ImplIntf : TImplementedInterface;
curintf: tobjectdef; intftable : tasmlabel;
intftable: tasmlabel; i : longint;
begin begin
{ 1. step collect implementor functions into the implementedinterfaces.implprocs } { 1. step collect implementor functions into the tImplementedInterface.procdefs }
for intfindex:=1 to _class.implementedinterfaces.count do for i:=0 to _class.ImplementedInterfaces.count-1 do
begin begin
curintf:=_class.implementedinterfaces.interfaces(intfindex); ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
gintfwalkdowninterface(curintf,intfindex); intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
end; end;
{ 2. Optimize interface tables to reuse wrappers } { 2. Optimize interface tables to reuse wrappers }
gintfoptimizevtbls; intf_optimize_vtbls;
{ 3. Calculate offsets in object map and Write interface tables } { 3. Calculate offsets in object map and Write interface tables }
current_asmdata.getdatalabel(intftable); current_asmdata.getdatalabel(intftable);
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint)))); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftable)); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftable));
gintfwritedata; intf_write_data;
genintftable:=intftable; genintftable:=intftable;
end; end;
@ -1283,7 +1289,7 @@ implementation
new_section(current_asmdata.asmlists[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(aint))); new_section(current_asmdata.asmlists[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(aint)));
{ interface table } { interface table }
if _class.implementedinterfaces.count>0 then if _class.ImplementedInterfaces.count>0 then
interfacetable:=genintftable; interfacetable:=genintftable;
methodnametable:=genpublishedmethodstable; methodnametable:=genpublishedmethodstable;
@ -1355,7 +1361,7 @@ implementation
{ auto table } { auto table }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
{ interface table } { 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)) current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(interfacetable))
else else
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));

33
compiler/pdecobj.pas
View File

@ -271,8 +271,8 @@ implementation
(((block_type=bt_type) and typecanbeforward) or (((block_type=bt_type) and typecanbeforward) or
not(m_delphi in current_settings.modeswitches)) then not(m_delphi in current_settings.modeswitches)) then
begin begin
{ a hack, but it's easy to handle } { a hack, but it's easy to handle
{ class reference type } class reference type }
consume(_OF); consume(_OF);
single_type(hdef,typecanbeforward); single_type(hdef,typecanbeforward);
@ -322,28 +322,27 @@ implementation
end; end;
end; end;
procedure handleimplementedinterface(implintf : tobjectdef); procedure handleImplementedInterface(intfdef : tobjectdef);
begin begin
if not is_interface(implintf) then if not is_interface(intfdef) then
begin begin
Message1(type_e_interface_type_expected,implintf.typename); Message1(type_e_interface_type_expected,intfdef.typename);
exit; exit;
end; end;
if aktobjectdef.implementedinterfaces.searchintf(implintf)<>-1 then if aktobjectdef.find_implemented_interface(intfdef)<>nil then
Message1(sym_e_duplicate_id,implintf.name) Message1(sym_e_duplicate_id,intfdef.name)
else else
begin begin
{ allocate and prepare the GUID only if the class { allocate and prepare the GUID only if the class
implements some interfaces. implements some interfaces. }
} if aktobjectdef.ImplementedInterfaces.count = 0 then
if aktobjectdef.implementedinterfaces.count = 0 then aktobjectdef.prepareguid;
aktobjectdef.prepareguid; aktobjectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
aktobjectdef.implementedinterfaces.addintf(implintf);
end; end;
end; end;
procedure readimplementedinterfaces; procedure readImplementedInterfaces;
var var
hdef : tdef; hdef : tdef;
begin begin
@ -355,7 +354,7 @@ implementation
Message1(type_e_interface_type_expected,hdef.typename); Message1(type_e_interface_type_expected,hdef.typename);
continue; continue;
end; end;
handleimplementedinterface(tobjectdef(hdef)); handleImplementedInterface(tobjectdef(hdef));
end; end;
end; end;
@ -473,8 +472,8 @@ implementation
if aktobjectdef.objecttype=odt_class then if aktobjectdef.objecttype=odt_class then
begin begin
if assigned(intfchildof) then if assigned(intfchildof) then
handleimplementedinterface(intfchildof); handleImplementedInterface(intfchildof);
readimplementedinterfaces; readImplementedInterfaces;
end; end;
consume(_RKLAMMER); consume(_RKLAMMER);
end; end;

16
compiler/pdecsub.pas
View File

@ -630,6 +630,7 @@ implementation
st : tsymtable; st : tsymtable;
aprocsym : tprocsym; aprocsym : tprocsym;
popclass : boolean; popclass : boolean;
ImplIntf : TImplementedInterface;
begin begin
{ Save the position where this procedure really starts } { Save the position where this procedure really starts }
procstartfilepos:=current_tokenpos; procstartfilepos:=current_tokenpos;
@ -652,8 +653,8 @@ implementation
{ examine interface map: function/procedure iname.functionname=locfuncname } { examine interface map: function/procedure iname.functionname=locfuncname }
if assigned(aclass) and if assigned(aclass) and
assigned(aclass.implementedinterfaces) and assigned(aclass.ImplementedInterfaces) and
(aclass.implementedinterfaces.count>0) and (aclass.ImplementedInterfaces.count>0) and
try_to_consume(_POINT) then try_to_consume(_POINT) then
begin begin
storepos:=current_tokenpos; storepos:=current_tokenpos;
@ -667,20 +668,19 @@ implementation
end; end;
current_tokenpos:=storepos; current_tokenpos:=storepos;
{ qualifier is interface? } { qualifier is interface? }
ImplIntf:=nil;
if (srsym.typ=typesym) and if (srsym.typ=typesym) and
(ttypesym(srsym).typedef.deftype=objectdef) then (ttypesym(srsym).typedef.deftype=objectdef) then
i:=aclass.implementedinterfaces.searchintf(ttypesym(srsym).typedef) ImplIntf:=aclass.find_implemented_interface(tobjectdef(ttypesym(srsym).typedef));
else if ImplIntf=nil then
i:=-1;
if (i=-1) then
Message(parser_e_interface_id_expected); Message(parser_e_interface_id_expected);
consume(_ID); consume(_ID);
{ Create unique name <interface>.<method> } { Create unique name <interface>.<method> }
hs:=sp+'.'+pattern; hs:=sp+'.'+pattern;
consume(_EQUAL); consume(_EQUAL);
if (i<>-1) and if assigned(ImplIntf) and
(token=_ID) then (token=_ID) then
aclass.implementedinterfaces.addmappings(i,hs,pattern); ImplIntf.AddMapping(hs,pattern);
consume(_ID); consume(_ID);
result:=true; result:=true;
exit; exit;

56
compiler/pdecvar.pas
View File

@ -222,7 +222,8 @@ implementation
sc : TFPObjectList; sc : TFPObjectList;
paranr : word; paranr : word;
i : longint; i : longint;
intfidx: longint; ImplIntf : TImplementedInterface;
found : boolean;
hreadparavs, hreadparavs,
hparavs : tparavarsym; hparavs : tparavarsym;
storedprocdef, storedprocdef,
@ -609,38 +610,33 @@ implementation
end; end;
{ Parse possible "implements" keyword } { Parse possible "implements" keyword }
if try_to_consume(_IMPLEMENTS) then if try_to_consume(_IMPLEMENTS) then
begin
consume(_ID);
{$message warn unlocalized string}
if not is_interface(p.propdef) then
begin begin
writeln('Implements property must have interface type'); consume(_ID);
Message1(sym_e_illegal_field, pattern); if not is_interface(p.propdef) then
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
begin begin
intfidx := i; Comment(V_Error,'Implements property must have interface type');
break;
end; end;
if intfidx > 0 then if pattern <> p.propdef.mangledparaname() then
begin begin
interfaces(intfidx).iitype := etFieldValue; Comment(V_Error,'Implements-property must implement interface of correct type');
interfaces(intfidx).iioffset := tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset; end;
end else found:=false;
begin for i:=0 to aclass.ImplementedInterfaces.Count-1 do
writeln('Implements-property used on unimplemented interface'); begin
Message1(sym_e_illegal_field, pattern); ImplIntf:=TImplementedInterface(aclass.ImplementedInterfaces[i]);
end; if ImplIntf.IntfDef.Objname^=pattern then
end; 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; end;
{ remove temporary procvardefs } { remove temporary procvardefs }

507
compiler/symdef.pas
View File

@ -213,20 +213,30 @@ interface
tprocdef = class; tprocdef = class;
tobjectdef = class; tobjectdef = class;
timplementedinterfaces = class;
timplintfentry = class(TNamedIndexItem) { TImplementedInterface }
intf : tobjectdef;
intfderef : tderef; TImplementedInterface = class
ioffset : longint; IntfDef : tobjectdef;
implindex : longint; IntfDefDeref : tderef;
namemappings : tdictionary; IOffset : longint;
procdefs : TIndexArray; VtblImplIntf : TImplementedInterface;
NameMappings : TFPHashList;
ProcDefs : TFPObjectList;
constructor create(aintf: tobjectdef); constructor create(aintf: tobjectdef);
constructor create_deref(d:tderef); constructor create_deref(d:tderef);
destructor destroy; override; 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; end;
{ tobjectdef }
tobjectdef = class(tabstractrecorddef) tobjectdef = class(tabstractrecorddef)
private private
procedure count_published_properties(sym:tnamedindexitem;arg:pointer); procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
@ -236,23 +246,23 @@ interface
procedure count_published_fields(sym:tnamedindexitem;arg:pointer); procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
procedure writefields(sym:tnamedindexitem;arg:pointer); procedure writefields(sym:tnamedindexitem;arg:pointer);
public public
childof : tobjectdef; childof : tobjectdef;
childofderef : tderef; childofderef : tderef;
objname, objname,
objrealname : pshortstring; objrealname : pshortstring;
objectoptions : tobjectoptions; objectoptions : tobjectoptions;
{ to be able to have a variable vmt position } { to be able to have a variable vmt position }
{ and no vmt field for objects without virtuals } { and no vmt field for objects without virtuals }
vmt_offset : longint; vmt_offset : longint;
writing_class_record_dbginfo : boolean; writing_class_record_dbginfo : boolean;
objecttype : tobjectdeftype; objecttype : tobjectdeftype;
iidguid: pguid; iidguid : pguid;
iidstr: pshortstring; iidstr : pshortstring;
iitype: tinterfaceentrytype; iitype : tinterfaceentrytype;
iioffset: longint; iioffset : longint;
lastvtableindex: longint; lastvtableindex: longint;
{ store implemented interfaces defs and name mappings } { store implemented interfaces defs and name mappings }
implementedinterfaces: timplementedinterfaces; ImplementedInterfaces : TFPObjectList;
constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef); constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
constructor ppuload(ppufile:tcompilerppufile); constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override; destructor destroy;override;
@ -266,6 +276,7 @@ interface
function alignment:shortint;override; function alignment:shortint;override;
function vmtmethodoffset(index:longint):longint; function vmtmethodoffset(index:longint):longint;
function members_need_inittable : boolean; function members_need_inittable : boolean;
function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
{ this should be called when this class implements an interface } { this should be called when this class implements an interface }
procedure prepareguid; procedure prepareguid;
function is_publishable : boolean;override; function is_publishable : boolean;override;
@ -283,41 +294,6 @@ interface
function generate_field_table : tasmlabel; function generate_field_table : tasmlabel;
end; 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) tclassrefdef = class(tabstractpointerdef)
constructor create(def:tdef); constructor create(def:tdef);
constructor ppuload(ppufile:tcompilerppufile); constructor ppuload(ppufile:tcompilerppufile);
@ -4380,9 +4356,9 @@ implementation
prepareguid; prepareguid;
{ setup implemented interfaces } { setup implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba] then if objecttype in [odt_class,odt_interfacecorba] then
implementedinterfaces:=timplementedinterfaces.create ImplementedInterfaces:=TFPObjectList.Create(true)
else else
implementedinterfaces:=nil; ImplementedInterfaces:=nil;
writing_class_record_dbginfo:=false; writing_class_record_dbginfo:=false;
iitype := etStandard; iitype := etStandard;
end; end;
@ -4390,8 +4366,10 @@ implementation
constructor tobjectdef.ppuload(ppufile:tcompilerppufile); constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
var var
i,implintfcount: longint; i,
implintfcount : longint;
d : tderef; d : tderef;
ImplIntf : TImplementedInterface;
begin begin
inherited ppuload(objectdef,ppufile); inherited ppuload(objectdef,ppufile);
objecttype:=tobjectdeftype(ppufile.getbyte); objecttype:=tobjectdeftype(ppufile.getbyte);
@ -4418,16 +4396,18 @@ implementation
{ load implemented interfaces } { load implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba] then if objecttype in [odt_class,odt_interfacecorba] then
begin begin
implementedinterfaces:=timplementedinterfaces.create; ImplementedInterfaces:=TFPObjectList.Create(true);
implintfcount:=ppufile.getlongint; implintfcount:=ppufile.getlongint;
for i:=1 to implintfcount do for i:=0 to implintfcount-1 do
begin begin
ppufile.getderef(d); ppufile.getderef(d);
implementedinterfaces.addintf_deref(d,ppufile.getlongint); ImplIntf:=TImplementedInterface.Create_deref(d);
ImplIntf.IOffset:=ppufile.getlongint;
ImplementedInterfaces.Add(ImplIntf);
end; end;
end end
else else
implementedinterfaces:=nil; ImplementedInterfaces:=nil;
tobjectsymtable(symtable).ppuload(ppufile); tobjectsymtable(symtable).ppuload(ppufile);
@ -4455,8 +4435,8 @@ implementation
stringdispose(objrealname); stringdispose(objrealname);
if assigned(iidstr) then if assigned(iidstr) then
stringdispose(iidstr); stringdispose(iidstr);
if assigned(implementedinterfaces) then if assigned(ImplementedInterfaces) then
implementedinterfaces.free; ImplementedInterfaces.free;
if assigned(iidguid) then if assigned(iidguid) then
dispose(iidguid); dispose(iidguid);
inherited destroy; inherited destroy;
@ -4465,8 +4445,7 @@ implementation
function tobjectdef.getcopy : tstoreddef; function tobjectdef.getcopy : tstoreddef;
var var
i, i : longint;
implintfcount : longint;
begin begin
result:=tobjectdef.create(objecttype,objname^,childof); result:=tobjectdef.create(objecttype,objname^,childof);
tobjectdef(result).symtable:=symtable.getcopy; tobjectdef(result).symtable:=symtable.getcopy;
@ -4484,22 +4463,18 @@ implementation
if assigned(iidstr) then if assigned(iidstr) then
tobjectdef(result).iidstr:=stringdup(iidstr^); tobjectdef(result).iidstr:=stringdup(iidstr^);
tobjectdef(result).lastvtableindex:=lastvtableindex; tobjectdef(result).lastvtableindex:=lastvtableindex;
if assigned(implementedinterfaces) then if assigned(ImplementedInterfaces) then
begin begin
implintfcount:=implementedinterfaces.count; for i:=0 to ImplementedInterfaces.count-1 do
for i:=1 to implintfcount do tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
begin
tobjectdef(result).implementedinterfaces.addintf_ioffset(implementedinterfaces.interfaces(i),
implementedinterfaces.ioffsets(i));
end;
end; end;
end; end;
procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile); procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
var var
implintfcount : longint;
i : longint; i : longint;
ImplIntf : TImplementedInterface;
begin begin
inherited ppuwrite(ppufile); inherited ppuwrite(ppufile);
ppufile.putbyte(byte(objecttype)); ppufile.putbyte(byte(objecttype));
@ -4519,13 +4494,13 @@ implementation
if objecttype in [odt_class,odt_interfacecorba] then if objecttype in [odt_class,odt_interfacecorba] then
begin begin
implintfcount:=implementedinterfaces.count; ppufile.putlongint(ImplementedInterfaces.Count);
ppufile.putlongint(implintfcount); for i:=0 to ImplementedInterfaces.Count-1 do
for i:=1 to implintfcount do begin
begin ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
ppufile.putderef(implementedinterfaces.interfacesderef(i)); ppufile.putderef(ImplIntf.intfdefderef);
ppufile.putlongint(implementedinterfaces.ioffsets(i)); ppufile.putlongint(ImplIntf.Ioffset);
end; end;
end; end;
ppufile.writeentry(ibobjectdef); ppufile.writeentry(ibobjectdef);
@ -4549,6 +4524,7 @@ implementation
procedure tobjectdef.buildderef; procedure tobjectdef.buildderef;
var var
i : longint;
oldrecsyms : tsymtable; oldrecsyms : tsymtable;
begin begin
inherited buildderef; inherited buildderef;
@ -4558,12 +4534,16 @@ implementation
tstoredsymtable(symtable).buildderef; tstoredsymtable(symtable).buildderef;
aktrecordsymtable:=oldrecsyms; aktrecordsymtable:=oldrecsyms;
if objecttype in [odt_class,odt_interfacecorba] then 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; end;
procedure tobjectdef.deref; procedure tobjectdef.deref;
var var
i : longint;
oldrecsyms : tsymtable; oldrecsyms : tsymtable;
begin begin
inherited deref; inherited deref;
@ -4573,7 +4553,10 @@ implementation
tstoredsymtable(symtable).deref; tstoredsymtable(symtable).deref;
aktrecordsymtable:=oldrecsyms; aktrecordsymtable:=oldrecsyms;
if objecttype in [odt_class,odt_interfacecorba] then 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; end;
@ -4796,6 +4779,26 @@ implementation
end; 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); procedure tobjectdef.collect_published_properties(sym:tnamedindexitem;arg:pointer);
var var
hp : tpropnamelistitem; 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); constructor TImplementedInterface.create(aintf: tobjectdef);
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);
begin begin
inherited create; inherited create;
procdef:=aprocdef; intfdef:=aintf;
end;
constructor timplintfentry.create(aintf: tobjectdef);
begin
inherited create;
intf:=aintf;
ioffset:=-1; ioffset:=-1;
namemappings:=nil; NameMappings:=nil;
procdefs:=nil; procdefs:=nil;
end; end;
constructor timplintfentry.create_deref(d:tderef); constructor TImplementedInterface.create_deref(d:tderef);
begin begin
inherited create; inherited create;
intf:=nil; intfdef:=nil;
intfderef:=d; intfdefderef:=d;
ioffset:=-1; ioffset:=-1;
namemappings:=nil; NameMappings:=nil;
procdefs:=nil; procdefs:=nil;
end; end;
destructor timplintfentry.destroy; destructor TImplementedInterface.destroy;
var
i : longint;
mappedname : pshortstring;
begin begin
if assigned(namemappings) then if assigned(NameMappings) then
namemappings.free; begin
for i:=0 to NameMappings.Count-1 do
begin
mappedname:=pshortstring(NameMappings[i]);
stringdispose(mappedname);
end;
NameMappings.free;
end;
if assigned(procdefs) then if assigned(procdefs) then
procdefs.free; procdefs.free;
inherited destroy; inherited destroy;
end; end;
constructor timplementedinterfaces.create; procedure TImplementedInterface.buildderef;
begin begin
finterfaces:=tindexarray.create(1); intfdefderef.build(intfdef);
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;
end; 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 var
i: longint; mappedname : pshortstring;
begin begin
for i:=1 to count do result:='';
with timplintfentry(finterfaces.search(i)) do if not assigned(NameMappings) then
intfderef.build(intf); exit;
mappedname:=PShortstring(NameMappings.Find(origname));
if assigned(mappedname) then
result:=mappedname^;
end; end;
procedure timplementedinterfaces.deref; procedure TImplementedInterface.AddImplProc(pd:tprocdef);
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);
var var
i : longint;
found : boolean; found : boolean;
i : longint;
begin begin
checkindex(intfindex); if not assigned(procdefs) then
with timplintfentry(finterfaces.search(intfindex)) do procdefs:=TFPObjectList.Create(false);
begin { No duplicate entries of the same procdef }
if not assigned(procdefs) then found:=false;
procdefs:=tindexarray.create(4); for i:=0 to procdefs.count-1 do
{ No duplicate entries of the same procdef } if tprocdef(procdefs[i])=pd then
found:=false; begin
for i:=1 to procdefs.count do found:=true;
if tprocdefstore(procdefs.search(i)).procdef=procdef then break;
begin end;
found:=true; if not found then
break; procdefs.Add(pd);
end;
if not found then
procdefs.insert(tprocdefstore.create(procdef));
end;
end; 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; function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
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;
var var
possible: boolean; i : longint;
i: longint;
iiep1: TIndexArray;
iiep2: TIndexArray;
begin begin
checkindex(intfindex); result:=false;
checkindex(remainindex); weight:=0;
iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs; { empty interface is mergeable }
iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs; if ProcDefs.Count=0 then
if not assigned(iiep1) then { empty interface is mergeable :-) }
begin begin
possible:=true; result:=true;
weight:=0; exit;
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;
end; 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; end;