diff --git a/compiler/aasmdata.pas b/compiler/aasmdata.pas index 5db9d94851..fb63f5a8d3 100644 --- a/compiler/aasmdata.pas +++ b/compiler/aasmdata.pas @@ -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]); diff --git a/compiler/dbgdwarf.pas b/compiler/dbgdwarf.pas index 9bdba5cee8..3cfc981b9f 100644 --- a/compiler/dbgdwarf.pas +++ b/compiler/dbgdwarf.pas @@ -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; diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 9c0326ca4c..5f43debfee 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -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 } diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas index 4b435a192b..3a0bf6040b 100644 --- a/compiler/ncgcnv.pas +++ b/compiler/ncgcnv.pas @@ -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); diff --git a/compiler/ncgutil.pas b/compiler/ncgutil.pas index 84d1082fc6..92a03e3b78 100644 --- a/compiler/ncgutil.pas +++ b/compiler/ncgutil.pas @@ -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; diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 1fa574717e..d84dceae0f 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -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)) diff --git a/compiler/nobj.pas b/compiler/nobj.pas index 3be150af97..2c5086f3be 100644 --- a/compiler/nobj.pas +++ b/compiler/nobj.pas @@ -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)); diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas index b0e4fba874..dbcbc55a50 100644 --- a/compiler/pdecobj.pas +++ b/compiler/pdecobj.pas @@ -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; diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index bd348de7d4..ae83053fd6 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -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 . } 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; diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 37923c0e77..190871c49d 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -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 } diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 0243c26fe8..fe29a3f2a1 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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.CountProcDefs[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;