paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 14:09:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed generation of rtti for virtualmethods

Browse Source
This commit is contained in:
peter 2001-10-20 17:20:13 +00:00
parent 3dfc2332cb
commit e417ee0e7f
2 changed files with 76 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
compiler/nobj.pas
View File

@ -86,6 +86,7 @@ interface
has_virtual_method : boolean; has_virtual_method : boolean;
procedure eachsym(sym : tnamedindexitem); procedure eachsym(sym : tnamedindexitem);
procedure disposevmttree; procedure disposevmttree;
procedure writevirtualmethods(List:TAAsmoutput);
private private
{ interface tables } { interface tables }
function gintfgetvtbllabelname(intfindex: integer): string; function gintfgetvtbllabelname(intfindex: integer): string;
@ -100,19 +101,20 @@ interface
procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract; procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract;
public public
constructor create(c:tobjectdef); constructor create(c:tobjectdef);
destructor destroy;override;
{ generates the message tables for a class } { generates the message tables for a class }
function genstrmsgtab : tasmlabel; function genstrmsgtab : tasmlabel;
function genintmsgtab : tasmlabel; function genintmsgtab : tasmlabel;
function genpublishedmethodstable : tasmlabel; function genpublishedmethodstable : tasmlabel;
{ generates a VMT entries }
procedure genvmt;
{$ifdef WITHDMT} {$ifdef WITHDMT}
{ generates a DMT for _class } { generates a DMT for _class }
function gendmt : tasmlabel; function gendmt : tasmlabel;
{$endif WITHDMT} {$endif WITHDMT}
{ generates a VMT for _class }
procedure genvmt(list : TAAsmoutput);
{ interfaces } { interfaces }
function genintftable: tasmlabel; function genintftable: tasmlabel;
{ write the VMT to datasegment }
procedure writevmt; procedure writevmt;
procedure writeinterfaceids; procedure writeinterfaceids;
end; end;
@ -152,6 +154,12 @@ implementation
end; end;
destructor tclassheader.destroy;
begin
disposevmttree;
end;
{************************************** {**************************************
Message Tables Message Tables
**************************************} **************************************}
@ -729,7 +737,7 @@ implementation
end; end;
procedure tclassheader.genvmt(list : TAAsmoutput); procedure tclassheader.genvmt;
procedure do_genvmt(p : tobjectdef); procedure do_genvmt(p : tobjectdef);
@ -742,11 +750,6 @@ implementation
p.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}eachsym); p.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}eachsym);
end; end;
var
symcoll : psymcoll;
procdefcoll : pprocdefcoll;
i : longint;
begin begin
wurzel:=nil; wurzel:=nil;
nextvirtnumber:=0; nextvirtnumber:=0;
@ -759,50 +762,6 @@ implementation
if has_virtual_method and not(has_constructor) then if has_virtual_method and not(has_constructor) then
Message1(parser_w_virtual_without_constructor,_class.objname^); Message1(parser_w_virtual_without_constructor,_class.objname^);
{ generates the VMT }
{ walk trough all numbers for virtual methods and search }
{ the method }
for i:=0 to nextvirtnumber-1 do
begin
symcoll:=wurzel;
{ walk trough all symbols }
while assigned(symcoll) do
begin
{ walk trough all methods }
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
{ writes the addresses to the VMT }
{ but only this which are declared as virtual }
if procdefcoll^.data.extnumber=i then
begin
if (po_virtualmethod in procdefcoll^.data.procoptions) then
begin
{ if a method is abstract, then is also the }
{ class abstract and it's not allow to }
{ generates an instance }
if (po_abstractmethod in procdefcoll^.data.procoptions) then
begin
include(_class.objectoptions,oo_has_abstract);
List.concat(Tai_const_symbol.Createname('FPC_ABSTRACTERROR'));
end
else
begin
List.concat(Tai_const_symbol.createname(procdefcoll^.data.mangledname));
end;
end;
end;
procdefcoll:=procdefcoll^.next;
end;
symcoll:=symcoll^.next;
end;
end;
disposevmttree;
end; end;
@ -1135,11 +1094,58 @@ implementation
dataSegment.concat(Tai_string.Create(_class.iidstr^)); dataSegment.concat(Tai_string.Create(_class.iidstr^));
end; end;
procedure tclassheader.writevirtualmethods(List:TAAsmoutput);
var
symcoll : psymcoll;
procdefcoll : pprocdefcoll;
i : longint;
begin
{ walk trough all numbers for virtual methods and search }
{ the method }
for i:=0 to nextvirtnumber-1 do
begin
symcoll:=wurzel;
{ walk trough all symbols }
while assigned(symcoll) do
begin
{ walk trough all methods }
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
{ writes the addresses to the VMT }
{ but only this which are declared as virtual }
if procdefcoll^.data.extnumber=i then
begin
if (po_virtualmethod in procdefcoll^.data.procoptions) then
begin
{ if a method is abstract, then is also the }
{ class abstract and it's not allow to }
{ generates an instance }
if (po_abstractmethod in procdefcoll^.data.procoptions) then
begin
include(_class.objectoptions,oo_has_abstract);
List.concat(Tai_const_symbol.Createname('FPC_ABSTRACTERROR'));
end
else
begin
List.concat(Tai_const_symbol.createname(procdefcoll^.data.mangledname));
end;
end;
end;
procdefcoll:=procdefcoll^.next;
end;
symcoll:=symcoll^.next;
end;
end;
end;
{ generates the vmt for classes as well as for objects } { generates the vmt for classes as well as for objects }
procedure tclassheader.writevmt; procedure tclassheader.writevmt;
var var
vmtlist : taasmoutput;
methodnametable,intmessagetable, methodnametable,intmessagetable,
strmessagetable,classnamelabel, strmessagetable,classnamelabel,
fieldtablelabel : tasmlabel; fieldtablelabel : tasmlabel;
@ -1151,9 +1157,6 @@ implementation
{$ifdef WITHDMT} {$ifdef WITHDMT}
dmtlabel:=gendmt; dmtlabel:=gendmt;
{$endif WITHDMT} {$endif WITHDMT}
{ this generates the entries }
vmtlist:=TAasmoutput.Create;
genvmt(vmtlist);
if (cs_create_smart in aktmoduleswitches) then if (cs_create_smart in aktmoduleswitches) then
dataSegment.concat(Tai_cut.Create); dataSegment.concat(Tai_cut.Create);
@ -1258,8 +1261,8 @@ implementation
else else
dataSegment.concat(Tai_const.Create_32bit(0)); dataSegment.concat(Tai_const.Create_32bit(0));
end; end;
dataSegment.concatlist(vmtlist); { write virtual methods }
vmtlist.free; writevirtualmethods(dataSegment);
{ write the size of the VMT } { write the size of the VMT }
dataSegment.concat(Tai_symbol_end.Createname(_class.vmt_mangledname)); dataSegment.concat(Tai_symbol_end.Createname(_class.vmt_mangledname));
end; end;
@ -1270,7 +1273,10 @@ initialization
end. end.
{ {
$Log$ $Log$
Revision 1.4 2001-09-19 11:04:42 michael Revision 1.5 2001-10-20 17:20:14 peter
* fixed generation of rtti for virtualmethods
Revision 1.4 2001/09/19 11:04:42 michael
* Smartlinking with interfaces fixed * Smartlinking with interfaces fixed
* Better smartlinking for rtti and init tables * Better smartlinking for rtti and init tables

17
compiler/pdecl.pas
View File

@ -477,12 +477,6 @@ implementation
oldfilepos:=aktfilepos; oldfilepos:=aktfilepos;
aktfilepos:=newtype.fileinfo; aktfilepos:=newtype.fileinfo;
{ generate rtti info for classes, but not for forward classes }
if (tt.def.deftype=objectdef) and
(oo_can_have_published in tobjectdef(tt.def).objectoptions) and
not(oo_is_forward in tobjectdef(tt.def).objectoptions) then
generate_rtti(newtype);
{ generate persistent init/final tables when it's declared in the interface so it can { generate persistent init/final tables when it's declared in the interface so it can
be reused in other used } be reused in other used }
if (not current_module.in_implementation) and if (not current_module.in_implementation) and
@ -498,6 +492,12 @@ implementation
not(oo_is_forward in tobjectdef(tt.def).objectoptions) then not(oo_is_forward in tobjectdef(tt.def).objectoptions) then
begin begin
ch:=cclassheader.create(tobjectdef(tt.def)); ch:=cclassheader.create(tobjectdef(tt.def));
{ generate and check virtual methods, must be done
before RTTI is written }
ch.genvmt;
{ generate rtti info if published items are available }
if (oo_can_have_published in tobjectdef(tt.def).objectoptions) then
generate_rtti(newtype);
if is_interface(tobjectdef(tt.def)) then if is_interface(tobjectdef(tt.def)) then
ch.writeinterfaceids; ch.writeinterfaceids;
if (oo_has_vmt in tobjectdef(tt.def).objectoptions) then if (oo_has_vmt in tobjectdef(tt.def).objectoptions) then
@ -593,7 +593,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.34 2001-09-19 11:06:03 michael Revision 1.35 2001-10-20 17:20:13 peter
* fixed generation of rtti for virtualmethods
Revision 1.34 2001/09/19 11:06:03 michael
* realname updated for some hints * realname updated for some hints
* realname used for consts,labels * realname used for consts,labels