mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-14 19:33:18 +02:00
f36e5411af
a) cpu64bitaddr, which means that we are generating a compiler which
will generate code for targets with a 64 bit address space/abi
b) cpu64bitalu, which means that we are generating a compiler which
will generate code for a cpu with support for 64 bit integer
operations (possibly running in a 32 bit address space, depending
on the cpu64bitaddr define)
All cpus which had cpu64bit set now have both the above defines set,
and none of the 32 bit cpus have cpu64bitalu set (and none will
compile with it currently)
+ pint and puint types, similar to aint/aword (not pword because that
that conflicts with pword=^word)
* several changes from aint/aword to pint/pword
* some changes of tcgsize2size[OS_INT] to sizeof(pint)
git-svn-id: trunk@10320 -
1447 lines
56 KiB
ObjectPascal
1447 lines
56 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,
|
|
symbase,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 parameter and return types (parameter specifiers will be checked below) }
|
|
else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_none,[])>=te_equal) and
|
|
compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) 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;
|
|
|
|
{ All parameter specifiers and some procedure the flags have to match
|
|
except abstract and override }
|
|
if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])<te_equal) or
|
|
(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;
|
|
|
|
{ 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
|
|
if not is_object(_class) then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
|
|
else
|
|
{ objects don't allow starting a new virtual tree }
|
|
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,procdefcoll^.data.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
|
|
implprocdef : Tprocdef;
|
|
i: cardinal;
|
|
hclass : tobjectdef;
|
|
hashedid : THashedIDString;
|
|
srsym : tsym;
|
|
begin
|
|
result:=nil;
|
|
hashedid.id:=name;
|
|
hclass:=_class;
|
|
while assigned(hclass) do
|
|
begin
|
|
srsym:=tsym(hclass.symtable.FindWithHash(hashedid));
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do
|
|
begin
|
|
implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
|
|
if (implprocdef.procsym=tprocsym(srsym)) and
|
|
(compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])>=te_equal) and
|
|
compatible_childmethod_resultdef(proc.returndef,implprocdef.returndef) 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;
|
|
hclass:=hclass.childof;
|
|
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
|
|
ImplIntf.AddImplProc(implprocdef)
|
|
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(pint));
|
|
ImplIntf.Ioffset:=datasize;
|
|
datasize:=datasize+sizeof(pint);
|
|
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(pint))));
|
|
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(pint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(result));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(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(pint))));
|
|
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(pint))));
|
|
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(pint))));
|
|
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(pint))));
|
|
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(pint)));
|
|
|
|
{ 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(pint)));
|
|
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_pint(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(pint))));
|
|
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(pint)));
|
|
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(pint))));
|
|
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_pint(AImplIntf.VtblImplIntf.IOffset))
|
|
else
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.FieldOffset));
|
|
{ IIDStr }
|
|
current_asmdata.getdatalabel(iidlabel);
|
|
rawdata.concat(cai_align.create(const_align(sizeof(pint))));
|
|
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_pint(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(pint))));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftablelab));
|
|
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(_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(pint)));
|
|
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(pint));
|
|
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(pint)));
|
|
|
|
{ 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(pint)));
|
|
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.
|