paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 16:31:36 +01:00
Code Issues Packages Projects Releases Wiki Activity
8b0301409a
fpc/compiler/nobj.pas
Jonas Maebe 92a53a9cf1 * moved initialisation of overridesclasshelper "out" parameter to correct 
place (was in a nested procedure instead of in the main one, fix for
    r16035)

git-svn-id: trunk@16039 -
2010-09-24 23:48:14 +00:00

1579 lines
62 KiB
ObjectPascal
Raw Blame History

{
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
TVMTBuilder=class
private
_Class : tobjectdef;
handledprotocols: tfpobjectlist;
function is_new_vmt_entry(pd:tprocdef; out overridesclasshelper: boolean):boolean;
procedure add_new_vmt_entry(pd:tprocdef; allowoverridingmethod: boolean);
function check_msg_str(vmtpd, pd: tprocdef):boolean;
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 prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef);
procedure intf_optimize_vtbls;
procedure intf_allocate_vtbls;
public
constructor create(c:tobjectdef);
destructor destroy;override;
procedure generate_vmt;
procedure build_interface_mappings;
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,
node,
symbase,symtable,symconst,symtype,defcmp,
dbgbase,
ncgrtti,
wpobase
;
{*****************************************************************************
TVMTBuilder
*****************************************************************************}
constructor TVMTBuilder.create(c:tobjectdef);
begin
inherited Create;
_Class:=c;
end;
destructor TVMTBuilder.destroy;
begin
end;
procedure TVMTBuilder.add_new_vmt_entry(pd:tprocdef; allowoverridingmethod: boolean);
var
i : longint;
vmtentry : pvmtentry;
vmtpd : tprocdef;
begin
{ new entry is needed, override was not possible }
{ Allowed when overriding a category method for a parent class in a
descendent Objective-C class }
if not allowoverridingmethod and
(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 _class.vmtentries.count-1 do
begin
vmtentry:=pvmtentry(_class.vmtentries[i]);
vmtpd:=tprocdef(vmtentry^.procdef);
if (vmtpd.procsym=pd.procsym) and
(not(po_overload in pd.procoptions) or
not(po_overload in vmtpd.procoptions)) then
begin
MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
{ recover }
include(vmtpd.procoptions,po_overload);
include(pd.procoptions,po_overload);
end;
end;
end;
{ Register virtual method and give it a number }
if (po_virtualmethod in pd.procoptions) then
begin
{ store vmt entry number in procdef }
if (pd.extnumber<>$ffff) and
(pd.extnumber<>_class.VMTEntries.Count) then
internalerror(200810283);
pd.extnumber:=_class.VMTEntries.Count;
new(vmtentry);
vmtentry^.procdef:=pd;
vmtentry^.procdefderef.reset;
vmtentry^.visibility:=pd.visibility;
_class.VMTEntries.Add(vmtentry);
end;
end;
function TVMTBuilder.check_msg_str(vmtpd, pd: tprocdef): boolean;
begin
result:=true;
if not(is_objc_class_or_protocol(_class)) then
begin
{ the only requirement for normal methods is that both either
have a message string or not (the value is irrelevant) }
if ((pd.procoptions * [po_msgstr]) <> (vmtpd.procoptions * [po_msgstr])) then
begin
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
tprocsym(vmtpd.procsym).write_parameter_lists(pd);
result:=false;
end
end
else
begin
{ the compiler should have ensured that the protocol or parent
class method has a message name specified }
if not(po_msgstr in vmtpd.procoptions) then
internalerror(2009070601);
if not(po_msgstr in pd.procoptions) then
begin
{ copy the protocol's/parent class' message name to the one in
the class if none has been specified there }
include(pd.procoptions,po_msgstr);
pd.messageinf.str:=stringdup(vmtpd.messageinf.str^);
end
else
begin
{ if both have a message name, make sure they are equal }
if (vmtpd.messageinf.str^<>pd.messageinf.str^) then
begin
MessagePos2(pd.fileinfo,parser_e_objc_message_name_changed,vmtpd.messageinf.str^,pd.messageinf.str^);
result:=false;
end;
end;
end;
end;
function TVMTBuilder.is_new_vmt_entry(pd:tprocdef; out overridesclasshelper: boolean):boolean;
const
po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var
i : longint;
hasequalpara,
hasoverloads,
pdoverload : boolean;
vmtpd : tprocdef;
srsym : tsym;
st : tsymtable;
// returns true if we can stop checking, false if we have to continue
function found_entry(var vmtpd: tprocdef; var vmtentryvis: tvisibility; updatevalues: boolean): boolean;
begin
result:=false;
{ ignore hidden entries (e.g. virtual overridden by a static) that are not visible anymore }
if vmtentryvis=vis_hidden then
exit;
{ ignore different names }
if vmtpd.procsym.name<>pd.procsym.name then
exit;
{ hide private methods that are not visible anymore. For this check we
must override the visibility with the highest value in the override chain.
This is required for case (see tw3292) with protected-private-protected where the
same vmtentry is used (PFV) }
if not is_visible_for_object(vmtpd.owner,vmtentryvis,_class) then
exit;
{ inherit overload }
if (po_overload in vmtpd.procoptions) then
begin
include(pd.procoptions,po_overload);
pdoverload:=true;
end;
{ compare parameter types only, no specifiers yet }
hasequalpara:=(compare_paras(vmtpd.paras,pd.paras,cp_none,[cpo_ignoreuniv])>=te_equal);
{ check that we are not trying to override a final method }
if (po_finalmethod in vmtpd.procoptions) and
hasequalpara and (po_overridingmethod in pd.procoptions) and is_class(_class) then
MessagePos1(pd.fileinfo,parser_e_final_can_no_be_overridden,pd.fullprocname(false))
else
{ old definition has virtual
new definition has no virtual or override }
if (po_virtualmethod in vmtpd.procoptions) and
(
not(po_virtualmethod in pd.procoptions) or
(
{ new one does not have reintroduce in case of an objccategory }
(is_objccategory(_class) and not(po_reintroduce in pd.procoptions)) or
{ new one does not have override in case of objpas/objc class/intf/proto }
(is_class_or_interface_or_objc(_class) and not is_objccategory(_class) and not(po_overridingmethod in pd.procoptions))
)
) then
begin
if (
not(pdoverload or hasoverloads) or
hasequalpara
) then
begin
if not(po_reintroduce in pd.procoptions) then
if not(is_objc_class_or_protocol(_class)) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else
begin
{ In Objective-C, you cannot create a new VMT entry to
start a new inheritance tree. We therefore give an
error when the class is implemented in Pascal, to
avoid confusion due to things working differently
with Object Pascal classes.
In case of external classes, we only give a hint,
because requiring override everywhere may make
automated header translation tools too complex. }
if not(oo_is_external in _class.objectoptions) then
if not is_objccategory(_class) then
MessagePos1(pd.fileinfo,parser_e_must_use_override_objc,FullTypeName(tdef(vmtpd.owner.defowner),nil))
else
MessagePos1(pd.fileinfo,parser_e_must_use_reintroduce_objc,FullTypeName(tdef(vmtpd.owner.defowner),nil))
{ there may be a lot of these in auto-translated
heaeders, so only calculate the fulltypename if
the hint will be shown }
else if CheckVerbosity(V_Hint) then
if not is_objccategory(_class) then
MessagePos1(pd.fileinfo,parser_h_should_use_override_objc,FullTypeName(tdef(vmtpd.owner.defowner),nil))
else
MessagePos1(pd.fileinfo,parser_h_should_use_reintroduce_objc,FullTypeName(tdef(vmtpd.owner.defowner),nil));
{ no new entry, but copy the message name if any from
the procdef in the parent class }
check_msg_str(vmtpd,pd);
result:=true;
exit;
end;
{ disable/hide old VMT entry }
if updatevalues then
vmtentryvis:=vis_hidden;
end;
end
{ both are virtual? }
else if (po_virtualmethod in pd.procoptions) and
(po_virtualmethod in vmtpd.procoptions) then
begin
{ same parameter and return types (parameter specifiers will be checked below) }
if hasequalpara and
compatible_childmethod_resultdef(vmtpd.returndef,pd.returndef) then
begin
{ inherite calling convention when it was explicit and the
current definition has none explicit set }
if (po_hascallingconvention in vmtpd.procoptions) and
not(po_hascallingconvention in pd.procoptions) then
begin
pd.proccalloption:=vmtpd.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(vmtpd.paras,pd.paras,cp_all,[cpo_ignoreuniv])<te_equal) or
(vmtpd.proccalloption<>pd.proccalloption) or
(vmtpd.proctypeoption<>pd.proctypeoption) or
((vmtpd.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
begin
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
tprocsym(vmtpd.procsym).write_parameter_lists(pd);
end;
check_msg_str(vmtpd,pd);
{ Give a note if the new visibility is lower. For a higher
visibility update the vmt info }
if vmtentryvis>pd.visibility then
MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,pd.fullprocname(false),
visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentryvis])
else if pd.visibility>vmtentryvis then
begin
if updatevalues then
vmtentryvis:=pd.visibility;
end;
{ override old virtual method in VMT }
if updatevalues then
begin
if (vmtpd.extnumber<>i) then
internalerror(200611084);
pd.extnumber:=vmtpd.extnumber;
vmtpd:=pd;
end;
result:=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 not(po_reintroduce in pd.procoptions) then
begin
if not is_object(_class) and
not is_objc_class_or_protocol(_class) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else
{ objects don't allow starting a new virtual tree
and neither does Objective-C }
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,vmtpd.fullprocname(false));
end;
{ disable/hide old VMT entry }
if updatevalues then
vmtentryvis:=vis_hidden;
end;
end;
end;
end;
function found_category_method(st: tsymtable): boolean;
var
entrycount, procdefcount: longint;
cat: tobjectdef;
vmtpd: tprocdef;
vmtvis: tvisibility;
begin
result:=false;
if is_objccategory(tdef(st.defowner)) then
begin
cat:=tobjectdef(st.defowner);
{ go through all of the category's methods to find the
vmtentry corresponding to the procdef we are handling }
for entrycount:=0 to cat.vmtentries.Count-1 do
begin
vmtpd:=pvmtentry(cat.vmtentries[entrycount])^.procdef;
vmtvis:=pvmtentry(cat.vmtentries[entrycount])^.visibility;
{ don't change the vmtentry of the category }
if found_entry(vmtpd,vmtvis,false) then
begin
result:=true;
exit;
end;
end;
end;
end;
begin
result:=false;
overridesclasshelper:=false;
{ 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 _class.vmtentries.Count-1 do
begin
if found_entry(pvmtentry(_class.vmtentries[i])^.procdef, pvmtentry(_class.vmtentries[i])^.visibility,true) then
exit;
end;
{ in case of Objective-C, also check the categories that apply to this
class' *parent* for methods to override (don't allow class X to
"override" a method added by a category to class X itself, since in
that case the category method will in fact replace class X'
"overriding" method }
if is_objcclass(_class) and
assigned(_class.childof) and
search_class_helper(_class.childof,pd.procsym.name,srsym,st) then
begin
overridesclasshelper:=found_category_method(st);
end;
{ No entry found, we need to create a new entry }
result:=true;
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_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,cpo_ignoreuniv])>=te_equal) and
(compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
(proc.proccalloption=implprocdef.proccalloption) and
(proc.proctypeoption=implprocdef.proctypeoption) and
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) and
check_msg_str(proc,implprocdef) 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
begin
if (implprocdef._class.objecttype<>odt_objcclass) then
ImplIntf.AddImplProc(implprocdef)
else
begin
{ If no message name has been specified for the method
in the objcclass, copy it from the protocol
definition. }
if not(po_msgstr in tprocdef(def).procoptions) then
begin
include(tprocdef(def).procoptions,po_msgstr);
implprocdef.messageinf.str:=stringdup(tprocdef(def).messageinf.str^);
end
else
begin
{ If a message name has been specified in the
objcclass, it has to match the message name in the
protocol definition. }
if (implprocdef.messageinf.str^<>tprocdef(def).messageinf.str^) then
MessagePos2(implprocdef.fileinfo,parser_e_objc_message_name_changed,tprocdef(def).messageinf.str^,implprocdef.messageinf.str^);
end;
end;
end
else
if (ImplIntf.IType=etStandard) and
not(po_optional in tprocdef(def).procoptions) then
MessagePos1(_Class.typesym.fileinfo,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.prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef);
var
i: longint;
begin
{ don't check the same protocol twice }
if handledprotocols.IndexOf(ProtDef)<>-1 then
exit;
handledprotocols.add(ProtDef);
for i:=0 to ProtDef.ImplementedInterfaces.count-1 do
prot_get_procdefs_recursive(ImplProt,TImplementedInterface(ProtDef.ImplementedInterfaces[i]).intfdef);
intf_get_procdefs(ImplProt,ProtDef);
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
aequals: 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(aequals,sizeof(longint)*ImplIntfCount);
getmem(impls,sizeof(longint)*ImplIntfCount);
filldword(compats^,(sizeof(tcompintfentry) div sizeof(dword))*ImplIntfCount,dword(-1));
filldword(aequals^,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 aequals^[j]=-1 then
aequals^[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 aequals^[impls^[i]]<>-1 then
impls^[i]:=aequals^[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(aequals);
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 and if it's not implemented by delegation }
if (ImplIntf.VtblImplIntf=ImplIntf) and (ImplIntf.IType=etStandard) 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;
def : tdef;
old_current_objectdef : tobjectdef;
overridesclasshelper : boolean;
begin
old_current_objectdef:=current_objectdef;
current_objectdef:=_class;
_class.resetvmtentries;
{ inherit (copy) VMT from parent object }
if assigned(_class.childof) then
begin
if not assigned(_class.childof.vmtentries) then
internalerror(200810281);
_class.copyvmtentries(_class.childof);
end;
{ 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 _class.symtable.DefList.Count-1 do
begin
def:=tdef(_class.symtable.DefList[i]);
if def.typ=procdef then
begin
{ VMT entry }
if is_new_vmt_entry(tprocdef(def),overridesclasshelper) then
add_new_vmt_entry(tprocdef(def),overridesclasshelper);
end;
end;
build_interface_mappings;
if assigned(_class.ImplementedInterfaces) and
not(is_objc_class_or_protocol(_class)) then
begin
{ Optimize interface tables to reuse wrappers }
intf_optimize_vtbls;
{ Allocate interface tables }
intf_allocate_vtbls;
end;
current_objectdef:=old_current_objectdef;
end;
procedure TVMTBuilder.build_interface_mappings;
var
ImplIntf : TImplementedInterface;
i: longint;
begin
{ Find Procdefs implementing the interfaces }
if assigned(_class.ImplementedInterfaces) and
(_class.objecttype<>odt_objcprotocol) then
begin
{ Collect implementor functions into the tImplementedInterface.procdefs }
case _class.objecttype of
odt_class:
begin
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef)
end;
end;
odt_objcclass:
begin
{ Object Pascal interfaces are afterwards optimized via the
intf_optimize_vtbls() method, but we can't do this for
protocols -> check for duplicates here already. }
handledprotocols:=tfpobjectlist.create(false);
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
prot_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
end;
handledprotocols.free;
end
else
internalerror(2009091801);
end
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
(pd.visibility=vis_published) 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
(pd.visibility=vis_published) 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 (sym.typ=fieldvarsym) and
(sym.visibility=vis_published) 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 (sym.typ=fieldvarsym) and
(sym.visibility=vis_published) 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;
pd: tprocdef;
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 }
case AImplIntf.VtblImplIntf.IType of
etFieldValue, etFieldValueClass,
etStandard:
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset));
etStaticMethodResult, etStaticMethodClass:
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(
tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef).mangledname,
0
));
etVirtualMethodResult, etVirtualMethodClass:
begin
pd := tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef);
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(pd._class.vmtmethodoffset(pd.extnumber)));
end;
else
internalerror(200802162);
end;
{ 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
vmtpd : tprocdef;
vmtentry : pvmtentry;
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
vmtentry:=pvmtentry(_class.vmtentries[i]);
vmtpd:=vmtentry^.procdef;
{ safety checks }
if not(po_virtualmethod in vmtpd.procoptions) then
internalerror(200611082);
if vmtpd.extnumber<>i then
internalerror(200611083);
if (po_abstractmethod in vmtpd.procoptions) then
procname:='FPC_ABSTRACTERROR'
else if not wpoinfomanager.optimized_name_for_vmt(_class,vmtpd,procname) then
procname:=vmtpd.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;
end;
procedure TVMTWriter.writevmt;
var
methodnametable,intmessagetable,
strmessagetable,classnamelabel,
fieldtablelabel : tasmlabel;
hs: string;
{$ifdef WITHDMT}
dmtlabel : tasmlabel;
{$endif WITHDMT}
interfacetable : tasmlabel;
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));
hs:=_class.RttiName;
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(hs)));
current_asmdata.asmlists[al_globals].concat(Tai_string.Create(hs));
{ 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 }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,fullrtti)));
{ 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 if _class.implements_any_interfaces then
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil))
else
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol('FPC_EMPTYINTF')));
{ 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.
Reference in New Issue View Git Blame Copy Permalink