mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 01:51:49 +01:00
4c1d540a21
a target flag, since some kernels may be able to handle alignment
problems, and the alignment requirements may not be absolute (e.g. on
ppc64, only 8 byte values need alignment, and only to 4 byte boundaries)
-> linux/ppc64 has tf_requires_proper_alignment set in its target flags,
darwin/ppc64 hasn't
git-svn-id: trunk@6745 -
1459 lines
57 KiB
ObjectPascal
1459 lines
57 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2002 by Florian Klaempfl
|
|
|
|
Routines for the code generation of data structures
|
|
like VMT, Messages, VTables, Interfaces descs
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit nobj;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
cutils,cclasses,
|
|
globtype,
|
|
symdef,symsym,
|
|
aasmbase,aasmtai,aasmdata
|
|
;
|
|
|
|
type
|
|
pprocdefentry = ^tprocdefentry;
|
|
tprocdefentry = record
|
|
data : tprocdef;
|
|
hidden : boolean;
|
|
visible : boolean;
|
|
end;
|
|
|
|
{ tvmtsymentry }
|
|
|
|
tvmtsymentry = class(TFPHashObject)
|
|
procdeflist : TFPList;
|
|
constructor Create(AList:TFPHashObjectList;const AName:shortstring);
|
|
destructor Destroy;override;
|
|
end;
|
|
|
|
TVMTBuilder=class
|
|
private
|
|
_Class : tobjectdef;
|
|
VMTSymEntryList : TFPHashObjectList;
|
|
has_constructor,
|
|
has_virtual_method : boolean;
|
|
function is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean;
|
|
procedure add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef);
|
|
procedure add_vmt_entries(objdef:tobjectdef);
|
|
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);
|
|
procedure intf_optimize_vtbls;
|
|
procedure intf_allocate_vtbls;
|
|
public
|
|
constructor create(c:tobjectdef);
|
|
destructor destroy;override;
|
|
procedure generate_vmt;
|
|
end;
|
|
|
|
type
|
|
pprocdeftree = ^tprocdeftree;
|
|
tprocdeftree = record
|
|
data : tprocdef;
|
|
nl : tasmlabel;
|
|
l,r : pprocdeftree;
|
|
end;
|
|
|
|
TVMTWriter=class
|
|
private
|
|
_Class : tobjectdef;
|
|
{ message tables }
|
|
root : pprocdeftree;
|
|
procedure disposeprocdeftree(p : pprocdeftree);
|
|
procedure insertmsgint(p:TObject;arg:pointer);
|
|
procedure insertmsgstr(p:TObject;arg:pointer);
|
|
procedure insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint);
|
|
procedure insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint);
|
|
procedure writenames(p : pprocdeftree);
|
|
procedure writeintentry(p : pprocdeftree);
|
|
procedure writestrentry(p : pprocdeftree);
|
|
{$ifdef WITHDMT}
|
|
{ dmt }
|
|
procedure insertdmtentry(p:TObject;arg:pointer);
|
|
procedure writedmtindexentry(p : pprocdeftree);
|
|
procedure writedmtaddressentry(p : pprocdeftree);
|
|
{$endif}
|
|
{ published methods }
|
|
procedure do_count_published_methods(p:TObject;arg:pointer);
|
|
procedure do_gen_published_methods(p:TObject;arg:pointer);
|
|
{ virtual methods }
|
|
procedure writevirtualmethods(List:TAsmList);
|
|
{ interface tables }
|
|
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);
|
|
function intf_write_table:TAsmLabel;
|
|
{ generates the message tables for a class }
|
|
function genstrmsgtab : tasmlabel;
|
|
function genintmsgtab : tasmlabel;
|
|
function genpublishedmethodstable : tasmlabel;
|
|
function generate_field_table : tasmlabel;
|
|
{$ifdef WITHDMT}
|
|
{ generates a DMT for _class }
|
|
function gendmt : tasmlabel;
|
|
{$endif WITHDMT}
|
|
public
|
|
constructor create(c:tobjectdef);
|
|
destructor destroy;override;
|
|
{ write the VMT to al_globals }
|
|
procedure writevmt;
|
|
procedure writeinterfaceids;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils,
|
|
globals,verbose,systems,
|
|
symtable,symconst,symtype,defcmp,
|
|
dbgbase,
|
|
ncgrtti
|
|
;
|
|
|
|
|
|
{*****************************************************************************
|
|
TVMTSymEntry
|
|
*****************************************************************************}
|
|
|
|
constructor tvmtsymentry.Create(AList:TFPHashObjectList;const AName:shortstring);
|
|
begin
|
|
inherited Create(AList,AName);
|
|
procdeflist:=TFPList.Create;
|
|
end;
|
|
|
|
|
|
destructor TVMTSymEntry.Destroy;
|
|
var
|
|
i : longint;
|
|
begin
|
|
for i:=0 to procdeflist.Count-1 do
|
|
Dispose(pprocdefentry(procdeflist[i]));
|
|
procdeflist.free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TVMTBuilder
|
|
*****************************************************************************}
|
|
|
|
constructor TVMTBuilder.create(c:tobjectdef);
|
|
begin
|
|
inherited Create;
|
|
_Class:=c;
|
|
VMTSymEntryList:=TFPHashObjectList.Create;
|
|
end;
|
|
|
|
|
|
destructor TVMTBuilder.destroy;
|
|
begin
|
|
VMTSymEntryList.free;
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef);
|
|
var
|
|
procdefcoll : pprocdefentry;
|
|
i : longint;
|
|
oldpd : tprocdef;
|
|
begin
|
|
if (_class=pd._class) then
|
|
begin
|
|
{ new entry is needed, override was not possible }
|
|
if (po_overridingmethod in pd.procoptions) then
|
|
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
|
|
|
|
{ check that all methods have overload directive }
|
|
if not(m_fpc in current_settings.modeswitches) then
|
|
begin
|
|
for i:=0 to VMTSymentry.ProcdefList.Count-1 do
|
|
begin
|
|
oldpd:=pprocdefentry(VMTSymentry.ProcdefList[i])^.data;
|
|
if (oldpd._class=pd._class) and
|
|
(not(po_overload in pd.procoptions) or
|
|
not(po_overload in oldpd.procoptions)) then
|
|
begin
|
|
MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
|
|
{ recover }
|
|
include(oldpd.procoptions,po_overload);
|
|
include(pd.procoptions,po_overload);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ generate new entry }
|
|
new(procdefcoll);
|
|
procdefcoll^.data:=pd;
|
|
procdefcoll^.hidden:=false;
|
|
procdefcoll^.visible:=pd.is_visible_for_object(_class,nil);
|
|
VMTSymEntry.ProcdefList.Add(procdefcoll);
|
|
|
|
{ Register virtual method and give it a number }
|
|
if (po_virtualmethod in pd.procoptions) then
|
|
begin
|
|
if not assigned(_class.VMTEntries) then
|
|
_class.VMTEntries:=TFPObjectList.Create(false);
|
|
if pd.extnumber=$ffff then
|
|
pd.extnumber:=_class.VMTEntries.Count
|
|
else
|
|
begin
|
|
if pd.extnumber<>_class.VMTEntries.Count then
|
|
internalerror(200611081);
|
|
end;
|
|
_class.VMTEntries.Add(pd);
|
|
has_virtual_method:=true;
|
|
end;
|
|
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
has_constructor:=true;
|
|
end;
|
|
|
|
|
|
function TVMTBuilder.is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean;
|
|
const
|
|
po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
|
|
po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
|
|
var
|
|
i : longint;
|
|
is_visible,
|
|
hasoverloads,
|
|
pdoverload : boolean;
|
|
procdefcoll : pprocdefentry;
|
|
begin
|
|
result:=false;
|
|
{ is this procdef visible from the class that we are
|
|
generating. This will be used to hide the other procdefs.
|
|
When the symbol is not visible we don't hide the other
|
|
procdefs, because they can be reused in the next class.
|
|
The check to skip the invisible methods that are in the
|
|
list is futher down in the code }
|
|
is_visible:=pd.is_visible_for_object(_class,nil);
|
|
{ Load other values for easier readability }
|
|
hasoverloads:=(tprocsym(pd.procsym).ProcdefList.Count>1);
|
|
pdoverload:=(po_overload in pd.procoptions);
|
|
|
|
{ compare with all stored definitions }
|
|
for i:=0 to VMTSymEntry.ProcdefList.Count-1 do
|
|
begin
|
|
procdefcoll:=pprocdefentry(VMTSymEntry.ProcdefList[i]);
|
|
{ skip definitions that are already hidden }
|
|
if procdefcoll^.hidden then
|
|
continue;
|
|
|
|
{ check if one of the two methods has virtual }
|
|
if (po_virtualmethod in procdefcoll^.data.procoptions) or
|
|
(po_virtualmethod in pd.procoptions) then
|
|
begin
|
|
{ if the current definition has no virtual then hide the
|
|
old virtual if the new definition has the same arguments or
|
|
when it has no overload directive and no overloads }
|
|
if not(po_virtualmethod in pd.procoptions) then
|
|
begin
|
|
if procdefcoll^.visible and
|
|
(
|
|
not(pdoverload or hasoverloads) or
|
|
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
|
|
) then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if (pd._class=procdefcoll^.data._class) then
|
|
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
|
|
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
|
|
end;
|
|
end
|
|
{ if both are virtual we check the header }
|
|
else if (po_virtualmethod in pd.procoptions) and
|
|
(po_virtualmethod in procdefcoll^.data.procoptions) then
|
|
begin
|
|
{ new one has not override }
|
|
if is_class(_class) and
|
|
not(po_overridingmethod in pd.procoptions) then
|
|
begin
|
|
{ we start a new virtual tree, hide the old }
|
|
if (not(pdoverload or hasoverloads) or
|
|
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) and
|
|
(procdefcoll^.visible) then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if (pd._class=procdefcoll^.data._class) then
|
|
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
|
|
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
|
|
end;
|
|
end
|
|
{ same parameters }
|
|
else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) then
|
|
begin
|
|
{ overload is inherited }
|
|
if (po_overload in procdefcoll^.data.procoptions) then
|
|
include(pd.procoptions,po_overload);
|
|
|
|
{ inherite calling convention when it was force and the
|
|
current definition has none force }
|
|
if (po_hascallingconvention in procdefcoll^.data.procoptions) and
|
|
not(po_hascallingconvention in pd.procoptions) then
|
|
begin
|
|
pd.proccalloption:=procdefcoll^.data.proccalloption;
|
|
include(pd.procoptions,po_hascallingconvention);
|
|
end;
|
|
|
|
{ the flags have to match except abstract and override }
|
|
{ only if both are virtual !! }
|
|
if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
|
|
(procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
|
|
((procdefcoll^.data.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
|
|
begin
|
|
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
|
|
tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
|
|
end;
|
|
|
|
{ error, if the return types aren't equal }
|
|
if not compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
|
|
begin
|
|
if not((m_delphi in current_settings.modeswitches) and
|
|
is_interface(_class)) then
|
|
Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
|
|
procdefcoll^.data.fullprocname(false))
|
|
else
|
|
{ Delphi allows changing the result type of interface methods from anything to
|
|
anything (JM) }
|
|
Message2(parser_w_overridden_methods_not_same_ret,pd.fullprocname(false),
|
|
procdefcoll^.data.fullprocname(false));
|
|
end;
|
|
{ check if the method to override is visible, check is only needed
|
|
for the current parsed class. Parent classes are already validated and
|
|
need to include all virtual methods including the ones not visible in the
|
|
current class }
|
|
if (_class=pd._class) and
|
|
(po_overridingmethod in pd.procoptions) and
|
|
(not procdefcoll^.visible) then
|
|
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
|
|
|
|
{ override old virtual method in VMT }
|
|
if (procdefcoll^.data.extnumber>=_class.VMTEntries.Count) or
|
|
(_class.VMTEntries[procdefcoll^.data.extnumber]<>procdefcoll^.data) then
|
|
internalerror(200611084);
|
|
_class.VMTEntries[procdefcoll^.data.extnumber]:=pd;
|
|
pd.extnumber:=procdefcoll^.data.extnumber;
|
|
procdefcoll^.data:=pd;
|
|
if is_visible then
|
|
procdefcoll^.visible:=true;
|
|
|
|
exit;
|
|
end
|
|
{ different parameters }
|
|
else
|
|
begin
|
|
{ when we got an override directive then can search futher for
|
|
the procedure to override.
|
|
If we are starting a new virtual tree then hide the old tree }
|
|
if not(po_overridingmethod in pd.procoptions) and
|
|
not (pdoverload or hasoverloads) then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if (pd._class=procdefcoll^.data._class) then
|
|
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
|
|
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ the new definition is virtual and the old static, we hide the old one
|
|
if the new defintion has not the overload directive }
|
|
if is_visible and
|
|
(
|
|
(not(pdoverload or hasoverloads)) or
|
|
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
|
|
) then
|
|
procdefcoll^.hidden:=true;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ both are static, we hide the old one if the new defintion
|
|
has not the overload directive }
|
|
if is_visible and
|
|
(
|
|
not(pdoverload or hasoverloads) or
|
|
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
|
|
) then
|
|
procdefcoll^.hidden:=true;
|
|
end;
|
|
end;
|
|
{ No entry found, we need to create a new entry }
|
|
result:=true;
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.add_vmt_entries(objdef:tobjectdef);
|
|
var
|
|
def : tdef;
|
|
pd : tprocdef;
|
|
i : longint;
|
|
VMTSymEntry : TVMTSymEntry;
|
|
begin
|
|
{ start with the base class }
|
|
if assigned(objdef.childof) then
|
|
add_vmt_entries(objdef.childof);
|
|
{ process all procdefs, we must process the defs to
|
|
keep the same order as that is written in the source
|
|
to be compatible with the indexes in the interface vtable (PFV) }
|
|
for i:=0 to objdef.symtable.DefList.Count-1 do
|
|
begin
|
|
def:=tdef(objdef.symtable.DefList[i]);
|
|
if def.typ=procdef then
|
|
begin
|
|
pd:=tprocdef(def);
|
|
{ Find VMT procsym }
|
|
VMTSymEntry:=TVMTSymEntry(VMTSymEntryList.Find(pd.procsym.name));
|
|
if not assigned(VMTSymEntry) then
|
|
VMTSymEntry:=TVMTSymEntry.Create(VMTSymEntryList,pd.procsym.name);
|
|
{ VMT entry }
|
|
if is_new_vmt_entry(VMTSymEntry,pd) then
|
|
add_new_vmt_entry(VMTSymEntry,pd);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TVMTBuilder.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];
|
|
var
|
|
sym: tsym;
|
|
implprocdef : Tprocdef;
|
|
i: cardinal;
|
|
begin
|
|
result:=nil;
|
|
|
|
sym:=tsym(search_class_member(_class,name));
|
|
if assigned(sym) and
|
|
(sym.typ=procsym) then
|
|
begin
|
|
{ when the definition has overload directive set, we search for
|
|
overloaded definitions in the class, this only needs to be done once
|
|
for class entries as the tree keeps always the same }
|
|
if (not tprocsym(sym).overloadchecked) and
|
|
(po_overload in tprocdef(tprocsym(sym).ProcdefList[0]).procoptions) and
|
|
(tprocsym(sym).owner.symtabletype=ObjectSymtable) then
|
|
search_class_overloads(tprocsym(sym));
|
|
|
|
for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
|
|
begin
|
|
implprocdef:=tprocdef(Tprocsym(sym).ProcdefList[i]);
|
|
if (compare_paras(proc.paras,implprocdef.paras,cp_none,[])>=te_equal) and
|
|
(proc.proccalloption=implprocdef.proccalloption) and
|
|
(proc.proctypeoption=implprocdef.proctypeoption) and
|
|
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
|
|
begin
|
|
result:=implprocdef;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
|
var
|
|
i : longint;
|
|
def : tdef;
|
|
hs,
|
|
prefix,
|
|
mappedname: string;
|
|
implprocdef: tprocdef;
|
|
begin
|
|
prefix:=ImplIntf.IntfDef.symtable.name^+'.';
|
|
for i:=0 to IntfDef.symtable.DefList.Count-1 do
|
|
begin
|
|
def:=tdef(IntfDef.symtable.DefList[i]);
|
|
if assigned(def) and
|
|
(def.typ=procdef) then
|
|
begin
|
|
{ Find implementing procdef
|
|
1. Check for mapped name
|
|
2. Use symbol name }
|
|
implprocdef:=nil;
|
|
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:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
|
|
{ Add procdef to the implemented interface }
|
|
if assigned(implprocdef) then
|
|
begin
|
|
if (compare_paras(tprocdef(def).paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])<te_equal) or
|
|
not compatible_childmethod_resultdef(tprocdef(def).returndef,implprocdef.returndef) then
|
|
MessagePos1(tprocdef(implprocdef).fileinfo,parser_e_header_dont_match_forward,
|
|
tprocdef(def).fullprocname(false));
|
|
ImplIntf.AddImplProc(implprocdef)
|
|
end
|
|
else
|
|
if ImplIntf.IType = etStandard then
|
|
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
|
|
begin
|
|
if assigned(IntfDef.childof) then
|
|
intf_get_procdefs_recursive(ImplIntf,IntfDef.childof);
|
|
intf_get_procdefs(ImplIntf,IntfDef);
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.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[0..1000] of tcompintfentry;
|
|
pcompintfs = ^tcompintfs;
|
|
tequals = array[0..1000] of longint;
|
|
pequals = ^tequals;
|
|
timpls = array[0..1000] of longint;
|
|
pimpls = ^timpls;
|
|
var
|
|
equals: pequals;
|
|
compats: pcompintfs;
|
|
impls: pimpls;
|
|
ImplIntfCount,
|
|
w,i,j,k: longint;
|
|
ImplIntfI,
|
|
ImplIntfJ : TImplementedInterface;
|
|
cij: boolean;
|
|
cji: boolean;
|
|
begin
|
|
ImplIntfCount:=_class.ImplementedInterfaces.count;
|
|
if ImplIntfCount>=High(tequals) then
|
|
Internalerror(200006135);
|
|
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:=0 to ImplIntfCount-1 do
|
|
begin
|
|
for j:=i+1 to ImplIntfCount-1 do
|
|
begin
|
|
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]=-1 then
|
|
equals^[j]:=i;
|
|
end
|
|
else if cij then
|
|
begin
|
|
{ get minimum index of maximum weight }
|
|
if compats^[i].weight<w then
|
|
begin
|
|
compats^[i].weight:=w;
|
|
compats^[i].compintf:=j;
|
|
end;
|
|
end
|
|
else if cji then
|
|
begin
|
|
{ get minimum index of maximum weight }
|
|
if (compats^[j].weight<w) then
|
|
begin
|
|
compats^[j].weight:=w;
|
|
compats^[j].compintf:=i;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
{ Reset, no replacements by default }
|
|
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
|
|
needed for the cases like:
|
|
First loop: 2->3, 3->1
|
|
Second loop: 2->1 (because 3 was replaced with 1)
|
|
}
|
|
repeat
|
|
k:=0;
|
|
for i:=0 to ImplIntfCount-1 do
|
|
begin
|
|
if compats^[impls^[i]].compintf<>-1 then
|
|
impls^[i]:=compats^[impls^[i]].compintf
|
|
else if equals^[impls^[i]]<>-1 then
|
|
impls^[i]:=equals^[impls^[i]]
|
|
else
|
|
inc(k);
|
|
end;
|
|
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 TVMTBuilder.intf_allocate_vtbls;
|
|
var
|
|
i : longint;
|
|
ImplIntf : TImplementedInterface;
|
|
begin
|
|
{ Allocation vtbl space }
|
|
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
|
begin
|
|
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));
|
|
ImplIntf.Ioffset:=datasize;
|
|
inc(datasize,sizeof(aint));
|
|
end;
|
|
end;
|
|
end;
|
|
{ Update ioffset of current interface with the ioffset from
|
|
the interface that is reused to implements this interface }
|
|
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
|
begin
|
|
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
|
if ImplIntf.VtblImplIntf<>ImplIntf then
|
|
ImplIntf.Ioffset:=ImplIntf.VtblImplIntf.Ioffset;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTBuilder.generate_vmt;
|
|
var
|
|
i : longint;
|
|
ImplIntf : TImplementedInterface;
|
|
begin
|
|
{ Find VMT entries }
|
|
has_constructor:=false;
|
|
has_virtual_method:=false;
|
|
add_vmt_entries(_class);
|
|
if not(is_interface(_class)) and
|
|
has_virtual_method and
|
|
not(has_constructor) then
|
|
Message1(parser_w_virtual_without_constructor,_class.objrealname^);
|
|
|
|
{ Find Procdefs implementing the interfaces }
|
|
if assigned(_class.ImplementedInterfaces) then
|
|
begin
|
|
{ Collect implementor functions into the tImplementedInterface.procdefs }
|
|
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
|
begin
|
|
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
|
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
|
|
end;
|
|
{ Optimize interface tables to reuse wrappers }
|
|
intf_optimize_vtbls;
|
|
{ Allocate interface tables }
|
|
intf_allocate_vtbls;
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TVMTWriter
|
|
*****************************************************************************}
|
|
|
|
constructor TVMTWriter.create(c:tobjectdef);
|
|
begin
|
|
inherited Create;
|
|
_Class:=c;
|
|
end;
|
|
|
|
|
|
destructor TVMTWriter.destroy;
|
|
begin
|
|
end;
|
|
|
|
|
|
{**************************************
|
|
Message Tables
|
|
**************************************}
|
|
|
|
procedure TVMTWriter.disposeprocdeftree(p : pprocdeftree);
|
|
begin
|
|
if assigned(p^.l) then
|
|
disposeprocdeftree(p^.l);
|
|
if assigned(p^.r) then
|
|
disposeprocdeftree(p^.r);
|
|
dispose(p);
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint);
|
|
|
|
begin
|
|
if at=nil then
|
|
begin
|
|
at:=p;
|
|
inc(count);
|
|
end
|
|
else
|
|
begin
|
|
if p^.data.messageinf.i<at^.data.messageinf.i then
|
|
insertint(p,at^.l,count)
|
|
else if p^.data.messageinf.i>at^.data.messageinf.i then
|
|
insertint(p,at^.r,count)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,tostr(p^.data.messageinf.i));
|
|
end;
|
|
end;
|
|
|
|
procedure TVMTWriter.insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint);
|
|
|
|
var
|
|
i : integer;
|
|
|
|
begin
|
|
if at=nil then
|
|
begin
|
|
at:=p;
|
|
inc(count);
|
|
end
|
|
else
|
|
begin
|
|
i:=CompareStr(p^.data.messageinf.str^,at^.data.messageinf.str^);
|
|
if i<0 then
|
|
insertstr(p,at^.l,count)
|
|
else if i>0 then
|
|
insertstr(p,at^.r,count)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,p^.data.messageinf.str^);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.insertmsgint(p:TObject;arg:pointer);
|
|
var
|
|
i : longint;
|
|
pd : Tprocdef;
|
|
pt : pprocdeftree;
|
|
begin
|
|
if tsym(p).typ<>procsym then
|
|
exit;
|
|
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
|
|
begin
|
|
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
|
|
if po_msgint in pd.procoptions then
|
|
begin
|
|
new(pt);
|
|
pt^.data:=pd;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertint(pt,root,plongint(arg)^);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.insertmsgstr(p:TObject;arg:pointer);
|
|
var
|
|
i : longint;
|
|
pd : Tprocdef;
|
|
pt : pprocdeftree;
|
|
begin
|
|
if tsym(p).typ<>procsym then
|
|
exit;
|
|
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
|
|
begin
|
|
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
|
|
if po_msgstr in pd.procoptions then
|
|
begin
|
|
new(pt);
|
|
pt^.data:=pd;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertstr(pt,root,plongint(arg)^);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.writenames(p : pprocdeftree);
|
|
var
|
|
ca : pchar;
|
|
len : byte;
|
|
begin
|
|
current_asmdata.getdatalabel(p^.nl);
|
|
if assigned(p^.l) then
|
|
writenames(p^.l);
|
|
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(p^.nl));
|
|
len:=length(p^.data.messageinf.str^);
|
|
current_asmdata.asmlists[al_globals].concat(tai_const.create_8bit(len));
|
|
getmem(ca,len+1);
|
|
move(p^.data.messageinf.str[1],ca^,len);
|
|
ca[len]:=#0;
|
|
current_asmdata.asmlists[al_globals].concat(Tai_string.Create_pchar(ca,len));
|
|
if assigned(p^.r) then
|
|
writenames(p^.r);
|
|
end;
|
|
|
|
procedure TVMTWriter.writestrentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writestrentry(p^.l);
|
|
|
|
{ write name label }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(p^.nl));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(p^.data.mangledname,0));
|
|
|
|
if assigned(p^.r) then
|
|
writestrentry(p^.r);
|
|
end;
|
|
|
|
|
|
function TVMTWriter.genstrmsgtab : tasmlabel;
|
|
var
|
|
count : aint;
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
{ insert all message handlers into a tree, sorted by name }
|
|
_class.symtable.SymList.ForEachCall(@insertmsgstr,@count);
|
|
|
|
{ write all names }
|
|
if assigned(root) then
|
|
writenames(root);
|
|
|
|
{ now start writing of the message string table }
|
|
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(result));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(count));
|
|
if assigned(root) then
|
|
begin
|
|
writestrentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.writeintentry(p : pprocdeftree);
|
|
begin
|
|
if assigned(p^.l) then
|
|
writeintentry(p^.l);
|
|
|
|
{ write name label }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(p^.data.messageinf.i));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(p^.data.mangledname,0));
|
|
|
|
if assigned(p^.r) then
|
|
writeintentry(p^.r);
|
|
end;
|
|
|
|
|
|
function TVMTWriter.genintmsgtab : tasmlabel;
|
|
var
|
|
r : tasmlabel;
|
|
count : longint;
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
{ insert all message handlers into a tree, sorted by name }
|
|
_class.symtable.SymList.ForEachCall(@insertmsgint,@count);
|
|
|
|
{ now start writing of the message string table }
|
|
current_asmdata.getdatalabel(r);
|
|
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(r));
|
|
genintmsgtab:=r;
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(count));
|
|
if assigned(root) then
|
|
begin
|
|
writeintentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef WITHDMT}
|
|
|
|
{**************************************
|
|
DMT
|
|
**************************************}
|
|
|
|
procedure TVMTWriter.insertdmtentry(p:TObject;arg:pointer);
|
|
|
|
var
|
|
hp : tprocdef;
|
|
pt : pprocdeftree;
|
|
|
|
begin
|
|
if tsym(p).typ=procsym then
|
|
begin
|
|
hp:=tprocsym(p).definition;
|
|
while assigned(hp) do
|
|
begin
|
|
if (po_msgint in hp.procoptions) then
|
|
begin
|
|
new(pt);
|
|
pt^.p:=hp;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertint(pt,root);
|
|
end;
|
|
hp:=hp.nextoverloaded;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TVMTWriter.writedmtindexentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtindexentry(p^.l);
|
|
al_globals.concat(Tai_const.Create_32bit(p^.data.messageinf.i));
|
|
if assigned(p^.r) then
|
|
writedmtindexentry(p^.r);
|
|
end;
|
|
|
|
procedure TVMTWriter.writedmtaddressentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtaddressentry(p^.l);
|
|
al_globals.concat(Tai_const_symbol.Createname(p^.data.mangledname,0));
|
|
if assigned(p^.r) then
|
|
writedmtaddressentry(p^.r);
|
|
end;
|
|
|
|
function TVMTWriter.gendmt : tasmlabel;
|
|
|
|
var
|
|
r : tasmlabel;
|
|
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
gendmt:=nil;
|
|
{ insert all message handlers into a tree, sorted by number }
|
|
_class.symtable.SymList.ForEachCall(insertdmtentry);
|
|
|
|
if count>0 then
|
|
begin
|
|
current_asmdata.getdatalabel(r);
|
|
gendmt:=r;
|
|
al_globals.concat(cai_align.create(const_align(sizeof(aint))));
|
|
al_globals.concat(Tai_label.Create(r));
|
|
{ entries for caching }
|
|
al_globals.concat(Tai_const.Create_ptr(0));
|
|
al_globals.concat(Tai_const.Create_ptr(0));
|
|
|
|
al_globals.concat(Tai_const.Create_32bit(count));
|
|
if assigned(root) then
|
|
begin
|
|
writedmtindexentry(root);
|
|
writedmtaddressentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$endif WITHDMT}
|
|
|
|
{**************************************
|
|
Published Methods
|
|
**************************************}
|
|
|
|
procedure TVMTWriter.do_count_published_methods(p:TObject;arg:pointer);
|
|
var
|
|
i : longint;
|
|
pd : tprocdef;
|
|
begin
|
|
if (tsym(p).typ<>procsym) then
|
|
exit;
|
|
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
|
|
begin
|
|
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
|
|
if (pd.procsym=tsym(p)) and
|
|
(sp_published in pd.symoptions) then
|
|
inc(plongint(arg)^);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.do_gen_published_methods(p:TObject;arg:pointer);
|
|
var
|
|
i : longint;
|
|
l : tasmlabel;
|
|
pd : tprocdef;
|
|
begin
|
|
if (tsym(p).typ<>procsym) then
|
|
exit;
|
|
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
|
|
begin
|
|
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
|
|
if (pd.procsym=tsym(p)) and
|
|
(sp_published in pd.symoptions) then
|
|
begin
|
|
current_asmdata.getdatalabel(l);
|
|
|
|
current_asmdata.asmlists[al_typedconsts].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(l));
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(length(tsym(p).realname)));
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create(tsym(p).realname));
|
|
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(l));
|
|
if po_abstractmethod in pd.procoptions then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(pd.mangledname,0));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TVMTWriter.genpublishedmethodstable : tasmlabel;
|
|
|
|
var
|
|
l : tasmlabel;
|
|
count : longint;
|
|
|
|
begin
|
|
count:=0;
|
|
_class.symtable.SymList.ForEachCall(@do_count_published_methods,@count);
|
|
if count>0 then
|
|
begin
|
|
current_asmdata.getdatalabel(l);
|
|
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(l));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(count));
|
|
_class.symtable.SymList.ForEachCall(@do_gen_published_methods,nil);
|
|
genpublishedmethodstable:=l;
|
|
end
|
|
else
|
|
genpublishedmethodstable:=nil;
|
|
end;
|
|
|
|
|
|
function TVMTWriter.generate_field_table : tasmlabel;
|
|
var
|
|
i : longint;
|
|
sym : tsym;
|
|
fieldtable,
|
|
classtable : tasmlabel;
|
|
classindex,
|
|
fieldcount : longint;
|
|
classtablelist : TFPList;
|
|
begin
|
|
classtablelist:=TFPList.Create;
|
|
current_asmdata.getdatalabel(fieldtable);
|
|
current_asmdata.getdatalabel(classtable);
|
|
maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
|
|
new_section(current_asmdata.asmlists[al_rtti],sec_rodata,classtable.name,const_align(sizeof(aint)));
|
|
|
|
{ retrieve field info fields }
|
|
fieldcount:=0;
|
|
for i:=0 to _class.symtable.SymList.Count-1 do
|
|
begin
|
|
sym:=tsym(_class.symtable.SymList[i]);
|
|
if (tsym(sym).typ=fieldvarsym) and
|
|
(sp_published in tsym(sym).symoptions) then
|
|
begin
|
|
if tfieldvarsym(sym).vardef.typ<>objectdef then
|
|
internalerror(200611032);
|
|
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
|
|
if classindex=-1 then
|
|
classtablelist.Add(tfieldvarsym(sym).vardef);
|
|
inc(fieldcount);
|
|
end;
|
|
end;
|
|
|
|
{ write fields }
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(fieldtable));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(fieldcount));
|
|
if (tf_requires_proper_alignment in target_info.flags) then
|
|
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(classtable));
|
|
for i:=0 to _class.symtable.SymList.Count-1 do
|
|
begin
|
|
sym:=tsym(_class.symtable.SymList[i]);
|
|
if (tsym(sym).typ=fieldvarsym) and
|
|
(sp_published in tsym(sym).symoptions) then
|
|
begin
|
|
if (tf_requires_proper_alignment in target_info.flags) then
|
|
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(AInt)));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset));
|
|
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
|
|
if classindex=-1 then
|
|
internalerror(200611033);
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classindex+1));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname)));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tfieldvarsym(sym).realname));
|
|
end;
|
|
end;
|
|
|
|
{ generate the class table }
|
|
current_asmdata.asmlists[al_rtti].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(classtable));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classtablelist.count));
|
|
if (tf_requires_proper_alignment in target_info.flags) then
|
|
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
|
|
for i:=0 to classtablelist.Count-1 do
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tobjectdef(classtablelist[i]).vmt_mangledname,0));
|
|
|
|
classtablelist.free;
|
|
result:=fieldtable;
|
|
end;
|
|
|
|
|
|
{**************************************
|
|
Interface tables
|
|
**************************************}
|
|
|
|
function TVMTWriter.intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
|
|
begin
|
|
result:=make_mangledname('VTBL',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^);
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
|
var
|
|
pd : tprocdef;
|
|
vtblstr,
|
|
hs : string;
|
|
i : longint;
|
|
begin
|
|
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
|
|
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 TVMTWriter.intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
|
var
|
|
iidlabel,
|
|
guidlabel : tasmlabel;
|
|
i: longint;
|
|
begin
|
|
{ GUID }
|
|
if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
|
|
begin
|
|
{ label for GUID }
|
|
current_asmdata.getdatalabel(guidlabel);
|
|
rawdata.concat(cai_align.create(const_align(sizeof(aint))));
|
|
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
|
|
{ nil for Corba interfaces }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
end;
|
|
{ VTable }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0));
|
|
{ IOffset field }
|
|
if AImplIntf.VtblImplIntf.IType = etStandard then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.IOffset))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.FieldOffset));
|
|
{ IIDStr }
|
|
current_asmdata.getdatalabel(iidlabel);
|
|
rawdata.concat(cai_align.create(const_align(sizeof(aint))));
|
|
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(AImplIntf.IntfDef.iidstr^));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(iidlabel));
|
|
{ IType }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.VtblImplIntf.IType)));
|
|
end;
|
|
|
|
|
|
function TVMTWriter.intf_write_table:TAsmLabel;
|
|
var
|
|
rawdata : TAsmList;
|
|
i : longint;
|
|
ImplIntf : TImplementedInterface;
|
|
intftablelab : tasmlabel;
|
|
begin
|
|
current_asmdata.getdatalabel(intftablelab);
|
|
current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftablelab));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(_class.ImplementedInterfaces.count));
|
|
rawdata:=TAsmList.Create;
|
|
{ Write vtbls }
|
|
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
|
begin
|
|
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
|
if ImplIntf.VtblImplIntf=ImplIntf then
|
|
intf_create_vtbl(rawdata,ImplIntf);
|
|
end;
|
|
{ Write vtbl references }
|
|
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
|
begin
|
|
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
|
intf_gen_intf_ref(rawdata,ImplIntf);
|
|
end;
|
|
{ Write interface table }
|
|
current_asmdata.asmlists[al_globals].concatlist(rawdata);
|
|
rawdata.free;
|
|
result:=intftablelab;
|
|
end;
|
|
|
|
|
|
{ Write interface identifiers to the data section }
|
|
procedure TVMTWriter.writeinterfaceids;
|
|
var
|
|
i : longint;
|
|
s : string;
|
|
begin
|
|
if assigned(_class.iidguid) then
|
|
begin
|
|
s:=make_mangledname('IID',_class.owner,_class.objname^);
|
|
maybe_new_object_file(current_asmdata.asmlists[al_globals]);
|
|
new_section(current_asmdata.asmlists[al_globals],sec_rodata,s,const_align(sizeof(aint)));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(longint(_class.iidguid^.D1)));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D2));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D3));
|
|
for i:=Low(_class.iidguid^.D4) to High(_class.iidguid^.D4) do
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(_class.iidguid^.D4[i]));
|
|
end;
|
|
maybe_new_object_file(current_asmdata.asmlists[al_globals]);
|
|
s:=make_mangledname('IIDSTR',_class.owner,_class.objname^);
|
|
new_section(current_asmdata.asmlists[al_globals],sec_rodata,s,0);
|
|
current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.iidstr^)));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_string.Create(_class.iidstr^));
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.writevirtualmethods(List:TAsmList);
|
|
var
|
|
pd : tprocdef;
|
|
i : longint;
|
|
procname : string;
|
|
{$ifdef vtentry}
|
|
hs : string;
|
|
{$endif vtentry}
|
|
begin
|
|
if not assigned(_class.VMTEntries) then
|
|
exit;
|
|
for i:=0 to _class.VMTEntries.Count-1 do
|
|
begin
|
|
pd:=tprocdef(_class.VMTEntries[i]);
|
|
if not(po_virtualmethod in pd.procoptions) then
|
|
internalerror(200611082);
|
|
if pd.extnumber<>i then
|
|
internalerror(200611083);
|
|
if (po_abstractmethod in pd.procoptions) then
|
|
procname:='FPC_ABSTRACTERROR'
|
|
else
|
|
procname:=pd.mangledname;
|
|
List.concat(Tai_const.createname(procname,0));
|
|
{$ifdef vtentry}
|
|
hs:='VTENTRY'+'_'+_class.vmt_mangledname+'$$'+tostr(_class.vmtmethodoffset(i) div sizeof(aint));
|
|
current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0));
|
|
{$endif vtentry}
|
|
end;
|
|
{ release VMTEntries, we don't need them anymore }
|
|
_class.VMTEntries.free;
|
|
_class.VMTEntries:=nil;
|
|
end;
|
|
|
|
|
|
procedure TVMTWriter.writevmt;
|
|
var
|
|
methodnametable,intmessagetable,
|
|
strmessagetable,classnamelabel,
|
|
fieldtablelabel : tasmlabel;
|
|
{$ifdef WITHDMT}
|
|
dmtlabel : tasmlabel;
|
|
{$endif WITHDMT}
|
|
interfacetable : tasmlabel;
|
|
{$ifdef vtentry}
|
|
hs: string;
|
|
{$endif vtentry}
|
|
begin
|
|
{$ifdef WITHDMT}
|
|
dmtlabel:=gendmt;
|
|
{$endif WITHDMT}
|
|
|
|
{ write tables for classes, this must be done before the actual
|
|
class is written, because we need the labels defined }
|
|
if is_class(_class) then
|
|
begin
|
|
current_asmdata.getdatalabel(classnamelabel);
|
|
maybe_new_object_file(current_asmdata.asmlists[al_globals]);
|
|
new_section(current_asmdata.asmlists[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(aint)));
|
|
|
|
{ interface table }
|
|
if _class.ImplementedInterfaces.count>0 then
|
|
interfacetable:=intf_write_table;
|
|
|
|
methodnametable:=genpublishedmethodstable;
|
|
fieldtablelabel:=generate_field_table;
|
|
{ write class name }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(classnamelabel));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.objrealname^)));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_string.Create(_class.objrealname^));
|
|
|
|
{ generate message and dynamic tables }
|
|
if (oo_has_msgstr in _class.objectoptions) then
|
|
strmessagetable:=genstrmsgtab;
|
|
if (oo_has_msgint in _class.objectoptions) then
|
|
intmessagetable:=genintmsgtab;
|
|
end;
|
|
|
|
{ write debug info }
|
|
maybe_new_object_file(current_asmdata.asmlists[al_globals]);
|
|
new_section(current_asmdata.asmlists[al_globals],sec_rodata,_class.vmt_mangledname,const_align(sizeof(aint)));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(_class.vmt_mangledname,AT_DATA,0));
|
|
|
|
{ determine the size with symtable.datasize, because }
|
|
{ size gives back 4 for classes }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create(aitconst_ptr,tObjectSymtable(_class.symtable).datasize));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create(aitconst_ptr,-int64(tObjectSymtable(_class.symtable).datasize)));
|
|
{$ifdef WITHDMT}
|
|
if _class.classtype=ct_object then
|
|
begin
|
|
if assigned(dmtlabel) then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const_symbol.Create(dmtlabel)))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_ptr(0));
|
|
end;
|
|
{$endif WITHDMT}
|
|
{ write pointer to parent VMT, this isn't implemented in TP }
|
|
{ but this is not used in FPC ? (PM) }
|
|
{ it's not used yet, but the delphi-operators as and is need it (FK) }
|
|
{ it is not written for parents that don't have any vmt !! }
|
|
if assigned(_class.childof) and
|
|
(oo_has_vmt in _class.childof.objectoptions) then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(_class.childof.vmt_mangledname,0))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
|
|
{ write extended info for classes, for the order see rtl/inc/objpash.inc }
|
|
if is_class(_class) then
|
|
begin
|
|
{ pointer to class name string }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(classnamelabel));
|
|
{ pointer to dynamic table or nil }
|
|
if (oo_has_msgint in _class.objectoptions) then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(intmessagetable))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
{ pointer to method table or nil }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(methodnametable));
|
|
{ pointer to field table }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(fieldtablelabel));
|
|
{ pointer to type info of published section }
|
|
if (oo_can_have_published in _class.objectoptions) then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,fullrtti)))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
{ inittable for con-/destruction }
|
|
if _class.members_need_inittable then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,initrtti)))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
{ auto table }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
{ interface table }
|
|
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));
|
|
{ table for string messages }
|
|
if (oo_has_msgstr in _class.objectoptions) then
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(strmessagetable))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
|
|
end;
|
|
{ write virtual methods }
|
|
writevirtualmethods(current_asmdata.asmlists[al_globals]);
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.create(aitconst_ptr,0));
|
|
{ write the size of the VMT }
|
|
current_asmdata.asmlists[al_globals].concat(Tai_symbol_end.Createname(_class.vmt_mangledname));
|
|
{$ifdef vtentry}
|
|
{ write vtinherit symbol to notify the linker of the class inheritance tree }
|
|
hs:='VTINHERIT'+'_'+_class.vmt_mangledname+'$$';
|
|
if assigned(_class.childof) then
|
|
hs:=hs+_class.childof.vmt_mangledname
|
|
else
|
|
hs:=hs+_class.vmt_mangledname;
|
|
current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0));
|
|
{$endif vtentry}
|
|
end;
|
|
|
|
|
|
end.
|