paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-09 10:19:33 +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 # Parser
# #
# 03248 is the last used one # 03250 is the last used one
# #
% \section{Parser messages} % \section{Parser messages}
% This section lists all parser messages. The parser takes care of the % 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 parser_e_forward_mismatch=03249_E_Forward type definition does not match
% Classes and interfaces being defined forward must have the same type % Classes and interfaces being defined forward must have the same type
% when being implemented. A forward interface can not be changed into a class. % 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} % \end{description}
# #
# Type Checking # Type Checking

5
compiler/msgidx.inc
View File

@ -337,6 +337,7 @@ const
parser_e_cant_export_var_different_name=03247; parser_e_cant_export_var_different_name=03247;
parser_e_weak_external_not_supported=03248; parser_e_weak_external_not_supported=03248;
parser_e_forward_mismatch=03249; parser_e_forward_mismatch=03249;
parser_n_ignore_lower_visibility=03250;
type_e_mismatch=04000; type_e_mismatch=04000;
type_e_incompatible_types=04001; type_e_incompatible_types=04001;
type_e_not_equal_types=04002; type_e_not_equal_types=04002;
@ -757,9 +758,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 47627; MsgTxtSize = 47709;
MsgIdxMax : array[1..20] of longint=( 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 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 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 TVMTBuilder=class
private private
_Class : tobjectdef; _Class : tobjectdef;
VMTSymEntryList : TFPHashObjectList; function is_new_vmt_entry(pd:tprocdef):boolean;
has_constructor, procedure add_new_vmt_entry(pd:tprocdef);
has_virtual_method : boolean;
function is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean;
procedure add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef);
procedure add_vmt_entries(objdef:tobjectdef);
function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef; function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
procedure intf_get_procdefs_recursive(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 TVMTBuilder
*****************************************************************************} *****************************************************************************}
@ -165,281 +124,199 @@ implementation
begin begin
inherited Create; inherited Create;
_Class:=c; _Class:=c;
VMTSymEntryList:=TFPHashObjectList.Create;
end; end;
destructor TVMTBuilder.destroy; destructor TVMTBuilder.destroy;
begin begin
VMTSymEntryList.free;
end; end;
procedure TVMTBuilder.add_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef); procedure TVMTBuilder.add_new_vmt_entry(pd:tprocdef);
var var
procdefcoll : pprocdefentry;
i : longint; i : longint;
oldpd : tprocdef; vmtentry : pvmtentry;
vmtpd : tprocdef;
begin begin
if (_class=pd._class) then { new entry is needed, override was not possible }
begin if (po_overridingmethod in pd.procoptions) then
{ new entry is needed, override was not possible } MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
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 } { check that all methods have overload directive }
if not(m_fpc in current_settings.modeswitches) then if not(m_fpc in current_settings.modeswitches) then
begin
for i:=0 to _class.vmtentries.count-1 do
begin 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 begin
oldpd:=pprocdefentry(VMTSymentry.ProcdefList[i])^.data; MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
if (oldpd._class=pd._class) and { recover }
(not(po_overload in pd.procoptions) or include(vmtpd.procoptions,po_overload);
not(po_overload in oldpd.procoptions)) then include(pd.procoptions,po_overload);
begin
MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
{ recover }
include(oldpd.procoptions,po_overload);
include(pd.procoptions,po_overload);
end;
end; end;
end; 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 } { Register virtual method and give it a number }
if (po_virtualmethod in pd.procoptions) then if (po_virtualmethod in pd.procoptions) then
begin begin
if not assigned(_class.VMTEntries) then { store vmt entry number in procdef }
_class.VMTEntries:=TFPObjectList.Create(false); if (pd.extnumber<>$ffff) and
if pd.extnumber=$ffff then (pd.extnumber<>_class.VMTEntries.Count) then
pd.extnumber:=_class.VMTEntries.Count internalerror(200810283);
else pd.extnumber:=_class.VMTEntries.Count;
begin new(vmtentry);
if pd.extnumber<>_class.VMTEntries.Count then vmtentry^.procdef:=pd;
internalerror(200611081); vmtentry^.procdefderef.reset;
end; vmtentry^.visibility:=pd.visibility;
_class.VMTEntries.Add(pd); _class.VMTEntries.Add(vmtentry);
has_virtual_method:=true;
end; end;
if (pd.proctypeoption=potype_constructor) then
has_constructor:=true;
end; end;
function TVMTBuilder.is_new_vmt_entry(VMTSymEntry:TVMTSymEntry;pd:tprocdef):boolean; function TVMTBuilder.is_new_vmt_entry(pd:tprocdef):boolean;
const const
po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint, po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var var
i : longint; i : longint;
is_visible, hasequalpara,
hasoverloads, hasoverloads,
pdoverload : boolean; pdoverload : boolean;
procdefcoll : pprocdefentry; vmtentry : pvmtentry;
vmtpd : tprocdef;
begin begin
result:=false; 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 } { Load other values for easier readability }
hasoverloads:=(tprocsym(pd.procsym).ProcdefList.Count>1); hasoverloads:=(tprocsym(pd.procsym).ProcdefList.Count>1);
pdoverload:=(po_overload in pd.procoptions); pdoverload:=(po_overload in pd.procoptions);
{ compare with all stored definitions } { compare with all stored definitions }
for i:=0 to VMTSymEntry.ProcdefList.Count-1 do for i:=0 to _class.vmtentries.Count-1 do
begin begin
procdefcoll:=pprocdefentry(VMTSymEntry.ProcdefList[i]); vmtentry:=pvmtentry(_class.vmtentries[i]);
{ skip definitions that are already hidden } vmtpd:=tprocdef(vmtentry^.procdef);
if procdefcoll^.hidden then
{ ignore hidden entries (e.g. virtual overridden by a static) that are not visible anymore }
if vmtentry^.visibility=vis_hidden then
continue; continue;
{ check if one of the two methods has virtual } { ignore different names }
if (po_virtualmethod in procdefcoll^.data.procoptions) or if vmtpd.procsym.name<>pd.procsym.name then
(po_virtualmethod in pd.procoptions) 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 begin
{ if the current definition has no virtual then hide the include(pd.procoptions,po_overload);
old virtual if the new definition has the same arguments or pdoverload:=true;
when it has no overload directive and no overloads } end;
if not(po_virtualmethod in pd.procoptions) then
{ 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 begin
if procdefcoll^.visible and if not(po_reintroduce in pd.procoptions) then
( MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
not(pdoverload or hasoverloads) or { disable/hide old VMT entry }
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) vmtentry^.visibility:=vis_hidden;
) 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;
end; end;
end end
else { both are virtual? }
else if (po_virtualmethod in pd.procoptions) and
(po_virtualmethod in vmtpd.procoptions) then
begin begin
{ both are static, we hide the old one if the new defintion { same parameter and return types (parameter specifiers will be checked below) }
has not the overload directive } if hasequalpara and
if is_visible and compatible_childmethod_resultdef(vmtpd.returndef,pd.returndef) then
( begin
not(pdoverload or hasoverloads) or { inherite calling convention when it was explicit and the
(compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) current definition has none explicit set }
) then if (po_hascallingconvention in vmtpd.procoptions) and
procdefcoll^.hidden:=true; not(po_hascallingconvention in pd.procoptions) then
end; 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; end;
{ No entry found, we need to create a new entry } { No entry found, we need to create a new entry }
result:=true; result:=true;
end; 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; function TVMTBuilder.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
const const
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint, po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
@ -666,16 +543,36 @@ implementation
procedure TVMTBuilder.generate_vmt; procedure TVMTBuilder.generate_vmt;
var var
i : longint; i : longint;
def : tdef;
ImplIntf : TImplementedInterface; ImplIntf : TImplementedInterface;
old_current_objectdef : tobjectdef;
begin begin
{ Find VMT entries } old_current_objectdef:=current_objectdef;
has_constructor:=false; current_objectdef:=_class;
has_virtual_method:=false;
add_vmt_entries(_class); _class.resetvmtentries;
if not(is_interface(_class)) and
has_virtual_method and { inherit (copy) VMT from parent object }
not(has_constructor) then if assigned(_class.childof) then
Message1(parser_w_virtual_without_constructor,_class.objrealname^); 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 } { Find Procdefs implementing the interfaces }
if assigned(_class.ImplementedInterfaces) then if assigned(_class.ImplementedInterfaces) then
@ -691,6 +588,8 @@ implementation
{ Allocate interface tables } { Allocate interface tables }
intf_allocate_vtbls; intf_allocate_vtbls;
end; end;
current_objectdef:=old_current_objectdef;
end; end;
@ -1294,7 +1193,8 @@ implementation
procedure TVMTWriter.writevirtualmethods(List:TAsmList); procedure TVMTWriter.writevirtualmethods(List:TAsmList);
var var
pd : tprocdef; vmtpd : tprocdef;
vmtentry : pvmtentry;
i : longint; i : longint;
procname : string; procname : string;
{$ifdef vtentry} {$ifdef vtentry}
@ -1305,24 +1205,23 @@ implementation
exit; exit;
for i:=0 to _class.VMTEntries.Count-1 do for i:=0 to _class.VMTEntries.Count-1 do
begin begin
pd:=tprocdef(_class.VMTEntries[i]); vmtentry:=pvmtentry(_class.vmtentries[i]);
if not(po_virtualmethod in pd.procoptions) then vmtpd:=vmtentry^.procdef;
{ safety checks }
if not(po_virtualmethod in vmtpd.procoptions) then
internalerror(200611082); internalerror(200611082);
if pd.extnumber<>i then if vmtpd.extnumber<>i then
internalerror(200611083); internalerror(200611083);
if (po_abstractmethod in pd.procoptions) then if (po_abstractmethod in vmtpd.procoptions) then
procname:='FPC_ABSTRACTERROR' procname:='FPC_ABSTRACTERROR'
else else
procname:=pd.mangledname; procname:=vmtpd.mangledname;
List.concat(Tai_const.createname(procname,0)); List.concat(Tai_const.createname(procname,0));
{$ifdef vtentry} {$ifdef vtentry}
hs:='VTENTRY'+'_'+_class.vmt_mangledname+'$$'+tostr(_class.vmtmethodoffset(i) div sizeof(pint)); 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)); current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0));
{$endif vtentry} {$endif vtentry}
end; end;
{ release VMTEntries, we don't need them anymore }
_class.VMTEntries.free;
_class.VMTEntries:=nil;
end; end;

4
compiler/pdecobj.pas
View File

@ -720,6 +720,10 @@ implementation
) then ) then
current_objectdef.insertvmt; 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 if is_interface(current_objectdef) then
setinterfacemethodoptions; setinterfacemethodoptions;

2
compiler/ppu.pas
View File

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

82
compiler/symdef.pas
View File

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