mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-10 13:59:34 +02:00
4aa05f5133
JVM target, since Java bytecode itself has no support for properties and
hence exposing properties to external Java code can only be done through
getters/setters. Use the new parameters to do so:
-CTautogetterprefix=XXX
-CTautosetterprefix=YYY
The getter/setter will get the same visibility as the property. If a
getter/setter with the same naming convention was already specified for a
property and this getter/setter is declared in the same class as the
property, then the visibility of this existing getter/setter is
modified and no new routine is generated.
Newly generated getters/setters are virtual methods, because that is
the only way in Java bytecode to allow redefining these getters/setters
in child classes. However, that also means that using these switches can
change the behvaviour of code, since normally the used property definition
is only determined by the declared type of its associated class instance,
and not by the actual instance type. The compiler will therefore warn when
such an automatically generated getter/setter is overridden by another
automatically generated getter/setter in a child class.
git-svn-id: trunk@22959 -
1697 lines
68 KiB
ObjectPascal
1697 lines
68 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
|
||
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);
|
||
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(list : TAsmList;p : pprocdeftree);
|
||
procedure writeintentry(list : TAsmList;p : pprocdeftree);
|
||
procedure writestrentry(list : TAsmList;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(list : TAsmList):TAsmLabel;
|
||
{ generates the message tables for a class }
|
||
function genstrmsgtab(list : TAsmList) : tasmlabel;
|
||
function genintmsgtab(list : TAsmList) : tasmlabel;
|
||
function genpublishedmethodstable(list : TAsmList) : tasmlabel;
|
||
function generate_field_table(list : TAsmList) : tasmlabel;
|
||
{$ifdef WITHDMT}
|
||
{ generates a DMT for _class }
|
||
function gendmt : tasmlabel;
|
||
{$endif WITHDMT}
|
||
public
|
||
constructor create(c:tobjectdef);
|
||
{ write the VMT to al_globals }
|
||
procedure writevmt;
|
||
procedure writeinterfaceids;
|
||
end;
|
||
|
||
implementation
|
||
|
||
uses
|
||
SysUtils,
|
||
globals,verbose,systems,
|
||
node,procinfo,
|
||
symbase,symtable,symconst,symtype,defcmp,
|
||
dbgbase,
|
||
ncgrtti,
|
||
wpobase
|
||
;
|
||
|
||
|
||
{*****************************************************************************
|
||
TVMTBuilder
|
||
*****************************************************************************}
|
||
|
||
constructor TVMTBuilder.create(c:tobjectdef);
|
||
begin
|
||
inherited Create;
|
||
_Class:=c;
|
||
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;
|
||
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;
|
||
{$ifdef jvm}
|
||
var
|
||
javanewtreeok: boolean;
|
||
{$endif jvm}
|
||
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,cpo_ignorehidden])>=te_equal);
|
||
|
||
{ check that we are not trying to override a final method }
|
||
{ in Java, new virtual inheritance trees can never be started ->
|
||
treat all methods as "overriding" in the context of this check
|
||
(Java does check whether the mangled names are identical, so if they
|
||
are not we can stil get away with it) }
|
||
if (po_finalmethod in vmtpd.procoptions) and
|
||
hasequalpara and
|
||
((po_overridingmethod in pd.procoptions) or
|
||
(is_javaclass(_class) and
|
||
(pd.mangledname=vmtpd.mangledname))) and
|
||
(is_class(_class) or is_objectpascal_helper(_class) or is_javaclass(_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/java class/intf/proto }
|
||
((is_class_or_interface_or_objc_or_java(_class) or is_objectpascal_helper(_class)) and
|
||
not is_objccategory(_class) and
|
||
not(po_overridingmethod in pd.procoptions)
|
||
)
|
||
)
|
||
) then
|
||
begin
|
||
if (
|
||
not(pdoverload or hasoverloads) or
|
||
hasequalpara
|
||
) then
|
||
begin
|
||
{$ifdef jvm}
|
||
{ if the mangled names are different, the inheritance trees
|
||
are different too in Java; exception: when the parent method
|
||
is a virtual class method or virtual constructor, because
|
||
those are looked up dynamicall by name }
|
||
javanewtreeok:=
|
||
is_java_class_or_interface(_class) and
|
||
(pd.jvmmangledbasename(false)<>vmtpd.jvmmangledbasename(false)) and
|
||
((vmtpd.proctypeoption<>potype_constructor) and
|
||
not(po_staticmethod in vmtpd.procoptions));
|
||
{$endif}
|
||
if not(po_reintroduce in pd.procoptions) and
|
||
not(po_java_nonvirtual in vmtpd.procoptions) then
|
||
if not(is_objc_class_or_protocol(_class))
|
||
{$ifdef jvm}
|
||
and (not is_java_class_or_interface(_class) or
|
||
javanewtreeok)
|
||
{$endif jvm}
|
||
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.
|
||
|
||
The same goes for Java. }
|
||
{$ifndef jvm}
|
||
if hasequalpara then
|
||
{$endif}
|
||
begin
|
||
if not(oo_is_external in _class.objectoptions) then
|
||
if not is_objccategory(_class) then
|
||
MessagePos1(pd.fileinfo,parser_e_must_use_override,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
|
||
headers, 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,FullTypeName(tdef(vmtpd.owner.defowner),nil))
|
||
else
|
||
MessagePos1(pd.fileinfo,parser_h_should_use_reintroduce_objc,FullTypeName(tdef(vmtpd.owner.defowner),nil));
|
||
end;
|
||
{ no new entry, but copy the message name if any from
|
||
the procdef in the parent class }
|
||
if not is_objc_class_or_protocol(_class) or
|
||
hasequalpara then
|
||
check_msg_str(vmtpd,pd);
|
||
if updatevalues then
|
||
begin
|
||
{ in case of Java, copy the real name from the parent,
|
||
since overriding "Destroy" with "destroy" is not
|
||
going to work very well }
|
||
if is_java_class_or_interface(_class) and
|
||
(pd.procsym.realname<>vmtpd.procsym.realname) then
|
||
pd.procsym.realname:=vmtpd.procsym.realname;
|
||
{ in case we are overriding an abstract method,
|
||
decrease the number of abstract methods in this class }
|
||
if (po_abstractmethod in vmtpd.procoptions) then
|
||
dec(tobjectdef(pd.owner.defowner).abstractcnt);
|
||
if (vmtpd.extnumber<>i) then
|
||
internalerror(2011083101);
|
||
pd.extnumber:=vmtpd.extnumber;
|
||
vmtpd:=pd;
|
||
end;
|
||
result:=true;
|
||
exit;
|
||
{$ifdef jvm}
|
||
end
|
||
else
|
||
if not javanewtreeok and
|
||
is_java_class_or_interface(_class) then
|
||
begin
|
||
{ mangled names are the same -> can only override }
|
||
MessagePos1(pd.fileinfo,parser_e_must_use_override,FullTypeName(tdef(vmtpd.owner.defowner),nil))
|
||
{$endif jvm}
|
||
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,cpo_ignorehidden])<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
|
||
begin
|
||
if po_auto_raised_visibility in vmtpd.procoptions then
|
||
begin
|
||
if updatevalues then
|
||
pd.visibility:=vmtentryvis;
|
||
end
|
||
else
|
||
{$ifdef jvm}
|
||
MessagePos4(pd.fileinfo,parser_e_method_lower_visibility,
|
||
{$else jvm}
|
||
MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,
|
||
{$endif jvm}
|
||
pd.fullprocname(false),
|
||
visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentryvis])
|
||
end
|
||
else if pd.visibility>vmtentryvis then
|
||
begin
|
||
if updatevalues then
|
||
vmtentryvis:=pd.visibility;
|
||
end;
|
||
|
||
{ override old virtual method in VMT }
|
||
if updatevalues then
|
||
begin
|
||
{ in case we are overriding an abstract method,
|
||
decrease the number of abstract methods in this class }
|
||
if (po_overridingmethod in pd.procoptions) and
|
||
(po_abstractmethod in vmtpd.procoptions) then
|
||
dec(tobjectdef(pd.owner.defowner).abstractcnt);
|
||
|
||
if (vmtpd.extnumber<>i) then
|
||
internalerror(200611084);
|
||
pd.extnumber:=vmtpd.extnumber;
|
||
{ in case of Java, copy the real name from the parent,
|
||
since overriding "Destroy" with "destroy" is not
|
||
going to work very well }
|
||
if is_java_class_or_interface(_class) and
|
||
(pd.procsym.realname<>vmtpd.procsym.realname) then
|
||
pd.procsym.realname:=vmtpd.procsym.realname;
|
||
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) and
|
||
not is_java_class_or_interface(_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 do Objective-C or Java }
|
||
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: 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_objc_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_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
|
||
{ does the interface increase the visibility of the
|
||
implementing method? }
|
||
if implprocdef.visibility<proc.visibility then
|
||
{$ifdef jvm}
|
||
MessagePos2(implprocdef.fileinfo,type_e_interface_lower_visibility,proc.fullprocname(false),implprocdef.fullprocname(false));
|
||
{$else}
|
||
MessagePos2(implprocdef.fileinfo,type_w_interface_lower_visibility,proc.fullprocname(false),implprocdef.fullprocname(false));
|
||
{$endif}
|
||
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, but only if there's no mapping,
|
||
or we're processing ancestor of interface.
|
||
When modifying this code, ensure that webtbs/tw11862, webtbs/tw4950
|
||
and webtbf/tw19591 stay correct. }
|
||
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
|
||
if (mappedname='') or (ImplIntf.IntfDef<>IntfDef) 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 (tobjectdef(implprocdef.struct).objecttype<>odt_objcclass) then
|
||
begin
|
||
{ in case of Java, copy the real name from the parent,
|
||
since overriding "Destroy" with "destroy" is not
|
||
going to work very well }
|
||
if is_javaclass(implprocdef.struct) and
|
||
(implprocdef.procsym.realname<>tprocdef(def).procsym.realname) then
|
||
implprocdef.procsym.realname:=tprocdef(def).procsym.realname;
|
||
ImplIntf.AddImplProc(implprocdef);
|
||
end
|
||
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_structdef : tabstractrecorddef;
|
||
overridesclasshelper : boolean;
|
||
begin
|
||
old_current_structdef:=current_structdef;
|
||
current_structdef:=_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)) and
|
||
not(is_java_class_or_interface(_class)) then
|
||
begin
|
||
{ Optimize interface tables to reuse wrappers }
|
||
intf_optimize_vtbls;
|
||
{ Allocate interface tables }
|
||
intf_allocate_vtbls;
|
||
end;
|
||
|
||
current_structdef:=old_current_structdef;
|
||
end;
|
||
|
||
|
||
procedure TVMTBuilder.build_interface_mappings;
|
||
var
|
||
ImplIntf : TImplementedInterface;
|
||
i: longint;
|
||
begin
|
||
{ Find Procdefs implementing the interfaces (both Objective-C protocols
|
||
and Java interfaces can have multiple parent interfaces, but in that
|
||
case obviously no implementations are required) }
|
||
if assigned(_class.ImplementedInterfaces) and
|
||
not(_class.objecttype in [odt_objcprotocol,odt_interfacejava]) and
|
||
// abstract java classes do not have to implement all interface
|
||
// methods. todo: check that non-abstract descendents do!
|
||
not((_class.objecttype=odt_javaclass) and (oo_is_abstract in _class.objectoptions)) 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,
|
||
odt_javaclass:
|
||
begin
|
||
{ Object Pascal interfaces are afterwards optimized via the
|
||
intf_optimize_vtbls() method, but we can't do this for
|
||
protocols/Java interfaces -> 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;
|
||
|
||
|
||
{**************************************
|
||
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(list : TAsmList;p : pprocdeftree);
|
||
var
|
||
ca : pchar;
|
||
len : byte;
|
||
begin
|
||
current_asmdata.getdatalabel(p^.nl);
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
if assigned(p^.l) then
|
||
writenames(list,p^.l);
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(p^.nl));
|
||
len:=length(p^.data.messageinf.str^);
|
||
list.concat(tai_const.create_8bit(len));
|
||
getmem(ca,len+1);
|
||
move(p^.data.messageinf.str^[1],ca^,len);
|
||
ca[len]:=#0;
|
||
list.concat(Tai_string.Create_pchar(ca,len));
|
||
if assigned(p^.r) then
|
||
writenames(list,p^.r);
|
||
end;
|
||
|
||
procedure TVMTWriter.writestrentry(list : TAsmList;p : pprocdeftree);
|
||
|
||
begin
|
||
if assigned(p^.l) then
|
||
writestrentry(list,p^.l);
|
||
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
{ write name label }
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_const.Create_sym(p^.nl));
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_const.Createname(p^.data.mangledname,0));
|
||
|
||
if assigned(p^.r) then
|
||
writestrentry(list,p^.r);
|
||
end;
|
||
|
||
|
||
function TVMTWriter.genstrmsgtab(list : TAsmList) : tasmlabel;
|
||
var
|
||
count : longint;
|
||
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(list,root);
|
||
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
{ now start writing of the message string table }
|
||
current_asmdata.getlabel(result,alt_data);
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(result));
|
||
list.concat(cai_align.create(const_align(sizeof(longint))));
|
||
list.concat(Tai_const.Create_32bit(count));
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
if assigned(root) then
|
||
begin
|
||
writestrentry(list,root);
|
||
disposeprocdeftree(root);
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TVMTWriter.writeintentry(list : TAsmList;p : pprocdeftree);
|
||
begin
|
||
if assigned(p^.l) then
|
||
writeintentry(list,p^.l);
|
||
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
{ write name label }
|
||
list.concat(cai_align.create(const_align(sizeof(longint))));
|
||
list.concat(Tai_const.Create_32bit(p^.data.messageinf.i));
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_const.Createname(p^.data.mangledname,0));
|
||
|
||
if assigned(p^.r) then
|
||
writeintentry(list,p^.r);
|
||
end;
|
||
|
||
|
||
function TVMTWriter.genintmsgtab(list : TAsmList) : 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);
|
||
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
{ now start writing of the message string table }
|
||
current_asmdata.getlabel(r,alt_data);
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(r));
|
||
genintmsgtab:=r;
|
||
list.concat(cai_align.create(const_align(sizeof(longint))));
|
||
list.concat(Tai_const.Create_32bit(count));
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
if assigned(root) then
|
||
begin
|
||
writeintentry(list,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;
|
||
lists: ^TAsmList absolute arg;
|
||
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.getlabel(l,alt_data);
|
||
lists[1].concat(cai_align.Create(const_align(sizeof(pint))));
|
||
lists[1].concat(Tai_label.Create(l));
|
||
lists[1].concat(Tai_const.Create_8bit(length(tsym(p).realname)));
|
||
lists[1].concat(Tai_string.Create(tsym(p).realname));
|
||
|
||
lists[0].concat(Tai_const.Create_sym(l));
|
||
if po_abstractmethod in pd.procoptions then
|
||
lists[0].concat(Tai_const.Create_sym(nil))
|
||
else
|
||
lists[0].concat(Tai_const.Createname(pd.mangledname,0));
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TVMTWriter.genpublishedmethodstable(list : TAsmList) : tasmlabel;
|
||
|
||
var
|
||
l : tasmlabel;
|
||
count : longint;
|
||
lists : array[0..1] of TAsmList;
|
||
begin
|
||
count:=0;
|
||
_class.symtable.SymList.ForEachCall(@do_count_published_methods,@count);
|
||
if count>0 then
|
||
begin
|
||
lists[0]:=list;
|
||
lists[1]:=TAsmList.Create;
|
||
current_asmdata.getlabel(l,alt_data);
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(l));
|
||
list.concat(Tai_const.Create_32bit(count));
|
||
_class.symtable.SymList.ForEachCall(@do_gen_published_methods,@lists);
|
||
list.concatlist(lists[1]);
|
||
lists[1].Free;
|
||
genpublishedmethodstable:=l;
|
||
end
|
||
else
|
||
genpublishedmethodstable:=nil;
|
||
end;
|
||
|
||
|
||
function TVMTWriter.generate_field_table(list : TAsmList) : tasmlabel;
|
||
var
|
||
i : longint;
|
||
sym : tsym;
|
||
fieldtable,
|
||
classtable : tasmlabel;
|
||
classindex,
|
||
fieldcount : longint;
|
||
classtablelist : TFPList;
|
||
begin
|
||
classtablelist:=TFPList.Create;
|
||
{ 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;
|
||
|
||
if fieldcount>0 then
|
||
begin
|
||
current_asmdata.getlabel(fieldtable,alt_data);
|
||
current_asmdata.getlabel(classtable,alt_data);
|
||
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
{ write fields }
|
||
list.concat(Tai_label.Create(fieldtable));
|
||
list.concat(Tai_const.Create_16bit(fieldcount));
|
||
if (tf_requires_proper_alignment in target_info.flags) then
|
||
list.concat(cai_align.Create(sizeof(TConstPtrUInt)));
|
||
list.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
|
||
list.concat(cai_align.Create(sizeof(pint)));
|
||
list.concat(Tai_const.Create_pint(tfieldvarsym(sym).fieldoffset));
|
||
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
|
||
if classindex=-1 then
|
||
internalerror(200611033);
|
||
list.concat(Tai_const.Create_16bit(classindex+1));
|
||
list.concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname)));
|
||
list.concat(Tai_string.Create(tfieldvarsym(sym).realname));
|
||
end;
|
||
end;
|
||
|
||
{ generate the class table }
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(classtable));
|
||
list.concat(Tai_const.Create_16bit(classtablelist.count));
|
||
if (tf_requires_proper_alignment in target_info.flags) then
|
||
list.concat(cai_align.Create(sizeof(TConstPtrUInt)));
|
||
for i:=0 to classtablelist.Count-1 do
|
||
list.concat(Tai_const.Createname(tobjectdef(classtablelist[i]).vmt_mangledname,0));
|
||
result:=fieldtable;
|
||
end
|
||
else
|
||
result:=nil;
|
||
|
||
classtablelist.free;
|
||
end;
|
||
|
||
|
||
{**************************************
|
||
Interface tables
|
||
**************************************}
|
||
|
||
function TVMTWriter.intf_get_vtbl_name(AImplIntf:TImplementedInterface): string;
|
||
begin
|
||
result:=make_mangledname('VTBL',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^);
|
||
if (cs_create_pic in current_settings.moduleswitches) and
|
||
assigned(current_procinfo) then
|
||
include(current_procinfo.flags,pi_needs_got);
|
||
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);
|
||
rawdata.concat(cai_align.create(const_align(sizeof(pint))));
|
||
rawdata.concat(tai_symbol.createname(vtblstr,AT_DATA,0));
|
||
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;
|
||
rawdata.concat(tai_symbol_end.createname(vtblstr));
|
||
end;
|
||
|
||
|
||
procedure TVMTWriter.intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface);
|
||
var
|
||
pd: tprocdef;
|
||
begin
|
||
{ GUID (or nil for Corba interfaces) }
|
||
if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
|
||
rawdata.concat(Tai_const.CreateName(
|
||
make_mangledname('IID',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^),0))
|
||
else
|
||
rawdata.concat(Tai_const.Create_sym(nil));
|
||
|
||
{ VTable }
|
||
rawdata.concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0));
|
||
{ IOffset field }
|
||
case AImplIntf.VtblImplIntf.IType of
|
||
etFieldValue, etFieldValueClass,
|
||
etStandard:
|
||
rawdata.concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset));
|
||
etStaticMethodResult, etStaticMethodClass:
|
||
rawdata.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);
|
||
rawdata.concat(Tai_const.Create_pint(tobjectdef(pd.struct).vmtmethodoffset(pd.extnumber)));
|
||
end;
|
||
else
|
||
internalerror(200802162);
|
||
end;
|
||
|
||
{ IIDStr }
|
||
rawdata.concat(Tai_const.CreateName(
|
||
make_mangledname('IIDSTR',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^),0));
|
||
{ IType }
|
||
rawdata.concat(Tai_const.Create_pint(aint(AImplIntf.VtblImplIntf.IType)));
|
||
end;
|
||
|
||
|
||
function TVMTWriter.intf_write_table(list : TAsmList):TAsmLabel;
|
||
var
|
||
i : longint;
|
||
ImplIntf : TImplementedInterface;
|
||
begin
|
||
current_asmdata.getlabel(result,alt_data);
|
||
list.concat(cai_align.create(const_align(sizeof(pint))));
|
||
list.concat(Tai_label.Create(result));
|
||
list.concat(Tai_const.Create_pint(_class.ImplementedInterfaces.count));
|
||
{ Write vtbl references }
|
||
for i:=0 to _class.ImplementedInterfaces.count-1 do
|
||
begin
|
||
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
|
||
intf_gen_intf_ref(list,ImplIntf);
|
||
end;
|
||
|
||
{ 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(list,ImplIntf);
|
||
end;
|
||
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,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_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;
|
||
templist : TAsmList;
|
||
begin
|
||
{$ifdef WITHDMT}
|
||
dmtlabel:=gendmt;
|
||
{$endif WITHDMT}
|
||
templist:=TAsmList.Create;
|
||
|
||
{ 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
|
||
{ write class name }
|
||
current_asmdata.getlabel(classnamelabel,alt_data);
|
||
templist.concat(cai_align.create(const_align(sizeof(pint))));
|
||
templist.concat(Tai_label.Create(classnamelabel));
|
||
hs:=_class.RttiName;
|
||
templist.concat(Tai_const.Create_8bit(length(hs)));
|
||
templist.concat(Tai_string.Create(hs));
|
||
|
||
{ interface table }
|
||
if _class.ImplementedInterfaces.count>0 then
|
||
interfacetable:=intf_write_table(templist);
|
||
|
||
methodnametable:=genpublishedmethodstable(templist);
|
||
fieldtablelabel:=generate_field_table(templist);
|
||
|
||
{ generate message and dynamic tables }
|
||
if (oo_has_msgstr in _class.objectoptions) then
|
||
strmessagetable:=genstrmsgtab(templist);
|
||
if (oo_has_msgint in _class.objectoptions) then
|
||
intmessagetable:=genintmsgtab(templist);
|
||
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}
|
||
if is_class(_class) then
|
||
current_asmdata.asmlists[al_globals].concatlist(templist);
|
||
templist.Free;
|
||
end;
|
||
|
||
|
||
end.
|