paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-03 01:09:40 +01:00
Code Issues Packages Projects Releases Wiki Activity

* store vmt entries in ppu

Browse Source 
* give a note if the visibility of a vmt entry is lower than
    the previous (parent) entry
  * refactor vmt method collection using the new always available
    vmt entries

git-svn-id: trunk@12159 -
This commit is contained in:
peter 2008-11-18 18:49:27 +00:00
parent 80ff09c6f4
commit 2a952c89a5
7 changed files with 565 additions and 581 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/msg/errore.msg
View File

@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
#
# Parser
#
# 03248 is the last used one
# 03250 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -1172,7 +1172,10 @@ parser_e_weak_external_not_supported=03248_E_Weak external symbols are not suppo
parser_e_forward_mismatch=03249_E_Forward type definition does not match
% Classes and interfaces being defined forward must have the same type
% when being implemented. A forward interface can not be changed into a class.
%
parser_n_ignore_lower_visibility=03250_N_Virtual method "$1" has a lower visibility ($2) than parent class $3 ($4)
% The virtual method overrides an method that is declared with a higher visibility. This might give
% unexpected results. In case the new visibility is private than it might be that a call to inherited in a
% new child class will call the higher visible method in a parent class and ignores the private method.
% \end{description}
#
# Type Checking

5
compiler/msgidx.inc
View File

@ -337,6 +337,7 @@ const
parser_e_cant_export_var_different_name=03247;
parser_e_weak_external_not_supported=03248;
parser_e_forward_mismatch=03249;
parser_n_ignore_lower_visibility=03250;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -757,9 +758,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 47627;
MsgTxtSize = 47709;
MsgIdxMax : array[1..20] of longint=(
24,87,250,84,65,50,108,22,201,61,
24,87,251,84,65,50,108,22,201,61,
44,1,1,1,1,1,1,1,1,1
);

583
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

463
compiler/nobj.pas
View File

@ -34,30 +34,11 @@ interface
;
type
pprocdefentry = ^tprocdefentry;
tprocdefentry = record
data : tprocdef;
hidden : boolean;
visible : boolean;
end;
{ tvmtsymentry }
tvmtsymentry = class(TFPHashObject)
procdeflist : TFPList;
constructor Create(AList:TFPHashObjectList;const AName:shortstring);
destructor Destroy;override;
end;
TVMTBuilder=class
private
_Class : tobjectdef;
VMTSymEntryList : TFPHashObjectList;
has_constructor,
has_virtual_method : boolean;
function is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean;
procedure add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef);
procedure add_vmt_entries(objdef:tobjectdef);
function is_new_vmt_entry(pd:tprocdef):boolean;
procedure add_new_vmt_entry(pd:tprocdef);
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);
@ -135,28 +116,6 @@ implementation
;
{*****************************************************************************
TVMTSymEntry
*****************************************************************************}
constructor tvmtsymentry.Create(AList:TFPHashObjectList;const AName:shortstring);
begin
inherited Create(AList,AName);
procdeflist:=TFPList.Create;
end;
destructor TVMTSymEntry.Destroy;
var
i : longint;
begin
for i:=0 to procdeflist.Count-1 do
Dispose(pprocdefentry(procdeflist[i]));
procdeflist.free;
inherited Destroy;
end;
{*****************************************************************************
TVMTBuilder
*****************************************************************************}
@ -165,281 +124,199 @@ implementation
begin
inherited Create;
_Class:=c;
VMTSymEntryList:=TFPHashObjectList.Create;
end;
destructor TVMTBuilder.destroy;
begin
VMTSymEntryList.free;
end;
procedure TVMTBuilder.add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef);
procedure TVMTBuilder.add_new_vmt_entry(pd:tprocdef);
var
procdefcoll : pprocdefentry;
i : longint;
oldpd : tprocdef;
vmtentry : pvmtentry;
vmtpd : tprocdef;
begin
if (_class=pd._class) then
begin
{ new entry is needed, override was not possible }
if (po_overridingmethod in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
{ new entry is needed, override was not possible }
if (po_overridingmethod in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
{ check that all methods have overload directive }
if not(m_fpc in current_settings.modeswitches) then
{ 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
for i:=0 to VMTSymentry.ProcdefList.Count-1 do
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
oldpd:=pprocdefentry(VMTSymentry.ProcdefList[i])^.data;
if (oldpd._class=pd._class) and
(not(po_overload in pd.procoptions) or
not(po_overload in oldpd.procoptions)) then
begin
MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
{ recover }
include(oldpd.procoptions,po_overload);
include(pd.procoptions,po_overload);
end;
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;
{ generate new entry }
new(procdefcoll);
procdefcoll^.data:=pd;
procdefcoll^.hidden:=false;
procdefcoll^.visible:=is_visible_for_object(pd,_class);
VMTSymEntry.ProcdefList.Add(procdefcoll);
{ Register virtual method and give it a number }
if (po_virtualmethod in pd.procoptions) then
begin
if not assigned(_class.VMTEntries) then
_class.VMTEntries:=TFPObjectList.Create(false);
if pd.extnumber=$ffff then
pd.extnumber:=_class.VMTEntries.Count
else
begin
if pd.extnumber<>_class.VMTEntries.Count then
internalerror(200611081);
end;
_class.VMTEntries.Add(pd);
has_virtual_method:=true;
{ 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;
if (pd.proctypeoption=potype_constructor) then
has_constructor:=true;
end;
function TVMTBuilder.is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean;
function TVMTBuilder.is_new_vmt_entry(pd:tprocdef):boolean;
const
po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var
i : longint;
is_visible,
hasequalpara,
hasoverloads,
pdoverload : boolean;
procdefcoll : pprocdefentry;
vmtentry : pvmtentry;
vmtpd : tprocdef;
begin
result:=false;
{ is this procdef visible from the class that we are
generating. This will be used to hide the other procdefs.
When the symbol is not visible we don't hide the other
procdefs, because they can be reused in the next class.
The check to skip the invisible methods that are in the
list is futher down in the code }
is_visible:=is_visible_for_object(pd,_class);
{ Load other values for easier readability }
hasoverloads:=(tprocsym(pd.procsym).ProcdefList.Count>1);
pdoverload:=(po_overload in pd.procoptions);
{ compare with all stored definitions }
for i:=0 to VMTSymEntry.ProcdefList.Count-1 do
for i:=0 to _class.vmtentries.Count-1 do
begin
procdefcoll:=pprocdefentry(VMTSymEntry.ProcdefList[i]);
{ skip definitions that are already hidden }
if procdefcoll^.hidden then
vmtentry:=pvmtentry(_class.vmtentries[i]);
vmtpd:=tprocdef(vmtentry^.procdef);
{ ignore hidden entries (e.g. virtual overridden by a static) that are not visible anymore }
if vmtentry^.visibility=vis_hidden then
continue;
{ check if one of the two methods has virtual }
if (po_virtualmethod in procdefcoll^.data.procoptions) or
(po_virtualmethod in pd.procoptions) then
{ ignore different names }
if vmtpd.procsym.name<>pd.procsym.name then
continue;
{ 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,vmtentry^.visibility,_class) then
continue;
{ inherit overload }
if (po_overload in vmtpd.procoptions) then
begin
{ if the current definition has no virtual then hide the
old virtual if the new definition has the same arguments or
when it has no overload directive and no overloads }
if not(po_virtualmethod in pd.procoptions) then
include(pd.procoptions,po_overload);
pdoverload:=true;
end;
{ compare parameter types only, no specifiers yet }
hasequalpara:=(compare_paras(vmtpd.paras,pd.paras,cp_none,[])>=te_equal);
{ 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 has not override }
(is_class_or_interface(_class) and not(po_overridingmethod in pd.procoptions))
) then
begin
if (
not(pdoverload or hasoverloads) or
hasequalpara
) then
begin
if procdefcoll^.visible and
(
not(pdoverload or hasoverloads) or
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
) then
begin
if is_visible then
procdefcoll^.hidden:=true;
if (pd._class=procdefcoll^.data._class) then
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
end;
end
{ if both are virtual we check the header }
else if (po_virtualmethod in pd.procoptions) and
(po_virtualmethod in procdefcoll^.data.procoptions) then
begin
{ new one has not override }
if is_class_or_interface(_class) and
not(po_overridingmethod in pd.procoptions) then
begin
{ we start a new virtual tree, hide the old }
if (not(pdoverload or hasoverloads) or
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) and
(procdefcoll^.visible) then
begin
if is_visible then
procdefcoll^.hidden:=true;
if (pd._class=procdefcoll^.data._class) then
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
end;
end
{ same parameter and return types (parameter specifiers will be checked below) }
else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_none,[])>=te_equal) and
compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
begin
{ overload is inherited }
if (po_overload in procdefcoll^.data.procoptions) then
include(pd.procoptions,po_overload);
{ inherite calling convention when it was force and the
current definition has none force }
if (po_hascallingconvention in procdefcoll^.data.procoptions) and
not(po_hascallingconvention in pd.procoptions) then
begin
pd.proccalloption:=procdefcoll^.data.proccalloption;
include(pd.procoptions,po_hascallingconvention);
end;
{ All parameter specifiers and some procedure the flags have to match
except abstract and override }
if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])<te_equal) or
(procdefcoll^.data.proccalloption<>pd.proccalloption) or
(procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
((procdefcoll^.data.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
begin
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
end;
{ check if the method to override is visible, check is only needed
for the current parsed class. Parent classes are already validated and
need to include all virtual methods including the ones not visible in the
current class }
if (_class=pd._class) and
(po_overridingmethod in pd.procoptions) and
(not procdefcoll^.visible) then
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
{ override old virtual method in VMT }
if (procdefcoll^.data.extnumber>=_class.VMTEntries.Count) or
(_class.VMTEntries[procdefcoll^.data.extnumber]<>procdefcoll^.data) then
internalerror(200611084);
_class.VMTEntries[procdefcoll^.data.extnumber]:=pd;
pd.extnumber:=procdefcoll^.data.extnumber;
procdefcoll^.data:=pd;
if is_visible then
procdefcoll^.visible:=true;
exit;
end
{ different parameters }
else
begin
{ when we got an override directive then can search futher for
the procedure to override.
If we are starting a new virtual tree then hide the old tree }
if not(po_overridingmethod in pd.procoptions) and
not (pdoverload or hasoverloads) then
begin
if is_visible then
procdefcoll^.hidden:=true;
if (pd._class=procdefcoll^.data._class) then
MessagePos(pd.fileinfo,parser_e_overloaded_have_same_parameters)
else if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
if not is_object(_class) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else
{ objects don't allow starting a new virtual tree }
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,procdefcoll^.data.fullprocname(false));
end;
end;
end
else
begin
{ the new definition is virtual and the old static, we hide the old one
if the new defintion has not the overload directive }
if is_visible and
(
(not(pdoverload or hasoverloads)) or
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
) then
procdefcoll^.hidden:=true;
if not(po_reintroduce in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
{ disable/hide old VMT entry }
vmtentry^.visibility:=vis_hidden;
end;
end
else
{ both are virtual? }
else if (po_virtualmethod in pd.procoptions) and
(po_virtualmethod in vmtpd.procoptions) then
begin
{ both are static, we hide the old one if the new defintion
has not the overload directive }
if is_visible and
(
not(pdoverload or hasoverloads) or
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)
) then
procdefcoll^.hidden:=true;
end;
{ 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,[])<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;
{ Give a note if the new visibility is lower. For a higher
visibility update the vmt info }
if vmtentry^.visibility>pd.visibility then
MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,pd.fullprocname(false),
visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentry^.visibility])
else if pd.visibility>vmtentry^.visibility then
vmtentry^.visibility:=pd.visibility;
{ override old virtual method in VMT }
if (vmtpd.extnumber<>i) then
internalerror(200611084);
pd.extnumber:=vmtpd.extnumber;
vmtentry^.procdef:=pd;
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) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else
{ objects don't allow starting a new virtual tree }
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,vmtpd.fullprocname(false));
end;
{ disable/hide old VMT entry }
vmtentry^.visibility:=vis_hidden;
end;
end;
end;
end;
{ No entry found, we need to create a new entry }
result:=true;
end;
procedure TVMTBuilder.add_vmt_entries(objdef:tobjectdef);
var
def : tdef;
pd : tprocdef;
i : longint;
VMTSymEntry : TVMTSymEntry;
begin
{ start with the base class }
if assigned(objdef.childof) then
add_vmt_entries(objdef.childof);
{ process all procdefs, we must process the defs to
keep the same order as that is written in the source
to be compatible with the indexes in the interface vtable (PFV) }
for i:=0 to objdef.symtable.DefList.Count-1 do
begin
def:=tdef(objdef.symtable.DefList[i]);
if def.typ=procdef then
begin
pd:=tprocdef(def);
{ Find VMT procsym }
VMTSymEntry:=TVMTSymEntry(VMTSymEntryList.Find(pd.procsym.name));
if not assigned(VMTSymEntry) then
VMTSymEntry:=TVMTSymEntry.Create(VMTSymEntryList,pd.procsym.name);
{ VMT entry }
if is_new_vmt_entry(VMTSymEntry,pd) then
add_new_vmt_entry(VMTSymEntry,pd);
end;
end;
end;
function TVMTBuilder.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
const
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
@ -666,16 +543,36 @@ implementation
procedure TVMTBuilder.generate_vmt;
var
i : longint;
def : tdef;
ImplIntf : TImplementedInterface;
old_current_objectdef : tobjectdef;
begin
{ Find VMT entries }
has_constructor:=false;
has_virtual_method:=false;
add_vmt_entries(_class);
if not(is_interface(_class)) and
has_virtual_method and
not(has_constructor) then
Message1(parser_w_virtual_without_constructor,_class.objrealname^);
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)) then
add_new_vmt_entry(tprocdef(def));
end;
end;
{ Find Procdefs implementing the interfaces }
if assigned(_class.ImplementedInterfaces) then
@ -691,6 +588,8 @@ implementation
{ Allocate interface tables }
intf_allocate_vtbls;
end;
current_objectdef:=old_current_objectdef;
end;
@ -1294,7 +1193,8 @@ implementation
procedure TVMTWriter.writevirtualmethods(List:TAsmList);
var
pd : tprocdef;
vmtpd : tprocdef;
vmtentry : pvmtentry;
i : longint;
procname : string;
{$ifdef vtentry}
@ -1305,24 +1205,23 @@ implementation
exit;
for i:=0 to _class.VMTEntries.Count-1 do
begin
pd:=tprocdef(_class.VMTEntries[i]);
if not(po_virtualmethod in pd.procoptions) then
vmtentry:=pvmtentry(_class.vmtentries[i]);
vmtpd:=vmtentry^.procdef;
{ safety checks }
if not(po_virtualmethod in vmtpd.procoptions) then
internalerror(200611082);
if pd.extnumber<>i then
if vmtpd.extnumber<>i then
internalerror(200611083);
if (po_abstractmethod in pd.procoptions) then
if (po_abstractmethod in vmtpd.procoptions) then
procname:='FPC_ABSTRACTERROR'
else
procname:=pd.mangledname;
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;
{ release VMTEntries, we don't need them anymore }
_class.VMTEntries.free;
_class.VMTEntries:=nil;
end;

4
compiler/pdecobj.pas
View File

@ -720,6 +720,10 @@ implementation
) then
current_objectdef.insertvmt;
if (oo_has_vmt in current_objectdef.objectoptions) and
not(oo_has_constructor in current_objectdef.objectoptions) then
Message1(parser_w_virtual_without_constructor,current_objectdef.objrealname^);
if is_interface(current_objectdef) then
setinterfacemethodoptions;

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 93;
CurrentPPUVersion = 94;
{ buffer sizes }
maxentrysize = 1024;

82
compiler/symdef.pas
View File

@ -221,6 +221,14 @@ interface
function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
end;
{ tvmtentry }
tvmtentry = record
procdef : tprocdef;
procdefderef : tderef;
visibility : tvisibility;
end;
pvmtentry = ^tvmtentry;
{ tobjectdef }
tobjectdef = class(tabstractrecorddef)
@ -234,7 +242,7 @@ interface
objectoptions : tobjectoptions;
{ to be able to have a variable vmt position }
{ and no vmt field for objects without virtuals }
vmtentries : TFPObjectList;
vmtentries : TFPList;
vmt_offset : longint;
writing_class_record_dbginfo : boolean;
objecttype : tobjecttyp;
@ -252,6 +260,8 @@ interface
procedure deref;override;
procedure buildderefimpl;override;
procedure derefimpl;override;
procedure resetvmtentries;
procedure copyvmtentries(objdef:tobjectdef);
function getparentdef:tdef;override;
function size : aint;override;
function alignment:shortint;override;
@ -3620,7 +3630,7 @@ implementation
childof:=nil;
symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
{ create space for vmt !! }
vmtentries:=nil;
vmtentries:=TFPList.Create;
vmt_offset:=0;
set_parent(c);
objname:=stringdup(upper(n));
@ -3642,6 +3652,7 @@ implementation
implintfcount : longint;
d : tderef;
ImplIntf : TImplementedInterface;
vmtentry : pvmtentry;
begin
inherited ppuload(objectdef,ppufile);
objecttype:=tobjecttyp(ppufile.getbyte);
@ -3652,7 +3663,6 @@ implementation
tObjectSymtable(symtable).fieldalignment:=ppufile.getbyte;
tObjectSymtable(symtable).recordalignment:=ppufile.getbyte;
vmt_offset:=ppufile.getlongint;
vmtentries:=nil;
ppufile.getderef(childofderef);
ppufile.getsmallset(objectoptions);
@ -3665,6 +3675,18 @@ implementation
iidstr:=stringdup(ppufile.getstring);
end;
vmtentries:=TFPList.Create;
vmtentries.count:=ppufile.getlongint;
for i:=0 to vmtentries.count-1 do
begin
ppufile.getderef(d);
new(vmtentry);
vmtentry^.procdef:=nil;
vmtentry^.procdefderef:=d;
vmtentry^.visibility:=tvisibility(ppufile.getbyte);
vmtentries[i]:=vmtentry;
end;
{ load implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba] then
begin
@ -3723,6 +3745,7 @@ implementation
end;
if assigned(vmtentries) then
begin
resetvmtentries;
vmtentries.free;
vmtentries:=nil;
end;
@ -3759,8 +3782,8 @@ implementation
end;
if assigned(vmtentries) then
begin
tobjectdef(result).vmtentries:=TFPobjectList.Create(false);
tobjectdef(result).vmtentries.Assign(vmtentries);
tobjectdef(result).vmtentries:=TFPList.Create;
tobjectdef(result).copyvmtentries(self);
end;
end;
@ -3768,6 +3791,7 @@ implementation
procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
var
i : longint;
vmtentry : pvmtentry;
ImplIntf : TImplementedInterface;
begin
inherited ppuwrite(ppufile);
@ -3785,6 +3809,15 @@ implementation
ppufile.putstring(iidstr^);
end;
ppufile.putlongint(vmtentries.count);
for i:=0 to vmtentries.count-1 do
begin
vmtentry:=pvmtentry(vmtentries[i]);
ppufile.putderef(vmtentry^.procdefderef);
ppufile.putbyte(byte(vmtentry^.visibility));
end;
if assigned(ImplementedInterfaces) then
begin
ppufile.putlongint(ImplementedInterfaces.Count);
@ -3822,6 +3855,7 @@ implementation
procedure tobjectdef.buildderef;
var
i : longint;
vmtentry : pvmtentry;
begin
inherited buildderef;
childofderef.build(childof);
@ -3830,6 +3864,12 @@ implementation
else
tstoredsymtable(symtable).buildderef;
for i:=0 to vmtentries.count-1 do
begin
vmtentry:=pvmtentry(vmtentries[i]);
vmtentry^.procdefderef.build(vmtentry^.procdef);
end;
if assigned(ImplementedInterfaces) then
begin
for i:=0 to ImplementedInterfaces.count-1 do
@ -3841,6 +3881,7 @@ implementation
procedure tobjectdef.deref;
var
i : longint;
vmtentry : pvmtentry;
begin
inherited deref;
childof:=tobjectdef(childofderef.resolve);
@ -3851,6 +3892,11 @@ implementation
end
else
tstoredsymtable(symtable).deref;
for i:=0 to vmtentries.count-1 do
begin
vmtentry:=pvmtentry(vmtentries[i]);
vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
end;
if assigned(ImplementedInterfaces) then
begin
for i:=0 to ImplementedInterfaces.count-1 do
@ -3875,6 +3921,32 @@ implementation
end;
procedure tobjectdef.resetvmtentries;
var
i : longint;
begin
for i:=0 to vmtentries.Count-1 do
Dispose(pvmtentry(vmtentries[i]));
vmtentries.clear;
end;
procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
var
i : longint;
vmtentry : pvmtentry;
begin
resetvmtentries;
vmtentries.count:=objdef.vmtentries.count;
for i:=0 to objdef.vmtentries.count-1 do
begin
new(vmtentry);
vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
vmtentries[i]:=vmtentry;
end;
end;
function tobjectdef.getparentdef:tdef;
begin
{ TODO: Remove getparentdef hack}