mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 10:11:27 +01:00
1593 lines
61 KiB
ObjectPascal
1593 lines
61 KiB
ObjectPascal
{
|
|
$Id$
|
|
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
|
|
{$ifdef Delphi}
|
|
dmisc,
|
|
{$endif}
|
|
cutils,cclasses,
|
|
globtype,
|
|
symdef,
|
|
aasmbase,aasmtai,
|
|
cpuinfo
|
|
;
|
|
|
|
type
|
|
pprocdeftree = ^tprocdeftree;
|
|
tprocdeftree = record
|
|
data : tprocdef;
|
|
nl : tasmlabel;
|
|
l,r : pprocdeftree;
|
|
end;
|
|
|
|
pprocdefcoll = ^tprocdefcoll;
|
|
tprocdefcoll = record
|
|
data : tprocdef;
|
|
hidden : boolean;
|
|
next : pprocdefcoll;
|
|
end;
|
|
|
|
psymcoll = ^tsymcoll;
|
|
tsymcoll = record
|
|
speedvalue : cardinal;
|
|
name : pstring;
|
|
data : pprocdefcoll;
|
|
next : psymcoll;
|
|
end;
|
|
|
|
tclassheader=class
|
|
private
|
|
_Class : tobjectdef;
|
|
count : integer;
|
|
private
|
|
{ message tables }
|
|
root : pprocdeftree;
|
|
procedure disposeprocdeftree(p : pprocdeftree);
|
|
procedure insertmsgint(p : tnamedindexitem;arg:pointer);
|
|
procedure insertmsgstr(p : tnamedindexitem;arg:pointer);
|
|
procedure insertint(p : pprocdeftree;var at : pprocdeftree);
|
|
procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
|
|
procedure writenames(p : pprocdeftree);
|
|
procedure writeintentry(p : pprocdeftree);
|
|
procedure writestrentry(p : pprocdeftree);
|
|
{$ifdef WITHDMT}
|
|
private
|
|
{ dmt }
|
|
procedure insertdmtentry(p : tnamedindexitem;arg:pointer);
|
|
procedure writedmtindexentry(p : pprocdeftree);
|
|
procedure writedmtaddressentry(p : pprocdeftree);
|
|
{$endif}
|
|
private
|
|
{ published methods }
|
|
procedure do_count(p : tnamedindexitem;arg:pointer);
|
|
procedure genpubmethodtableentry(p : tnamedindexitem;arg:pointer);
|
|
private
|
|
{ vmt }
|
|
wurzel : psymcoll;
|
|
nextvirtnumber : integer;
|
|
has_constructor,
|
|
has_virtual_method : boolean;
|
|
procedure eachsym(sym : tnamedindexitem;arg:pointer);
|
|
procedure disposevmttree;
|
|
procedure writevirtualmethods(List:TAAsmoutput);
|
|
private
|
|
{ interface tables }
|
|
function gintfgetvtbllabelname(intfindex: integer): string;
|
|
procedure gintfcreatevtbl(intfindex: integer; rawdata,rawcode: TAAsmoutput);
|
|
procedure gintfgenentry(intfindex, contintfindex: integer; rawdata: TAAsmoutput);
|
|
procedure gintfoptimizevtbls(implvtbl : plongintarray);
|
|
procedure gintfwritedata;
|
|
function gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
|
|
procedure gintfdoonintf(intf: tobjectdef; intfindex: longint);
|
|
procedure gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
|
|
protected
|
|
{ adjusts the self value with ioffset when casting a interface
|
|
to a class
|
|
}
|
|
procedure adjustselfvalue(procdef: tprocdef;ioffset: aword);virtual;
|
|
{ generates the wrapper for a call to a method via an interface }
|
|
procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract;
|
|
public
|
|
constructor create(c:tobjectdef);
|
|
destructor destroy;override;
|
|
{ generates the message tables for a class }
|
|
function genstrmsgtab : tasmlabel;
|
|
function genintmsgtab : tasmlabel;
|
|
function genpublishedmethodstable : tasmlabel;
|
|
{ generates a VMT entries }
|
|
procedure genvmt;
|
|
{$ifdef WITHDMT}
|
|
{ generates a DMT for _class }
|
|
function gendmt : tasmlabel;
|
|
{$endif WITHDMT}
|
|
{ interfaces }
|
|
function genintftable: tasmlabel;
|
|
{ write the VMT to datasegment }
|
|
procedure writevmt;
|
|
procedure writeinterfaceids;
|
|
end;
|
|
|
|
tclassheaderclass=class of tclassheader;
|
|
|
|
var
|
|
cclassheader : tclassheaderclass;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$ifdef delphi}
|
|
sysutils,
|
|
{$else}
|
|
strings,
|
|
{$endif}
|
|
globals,verbose,
|
|
symtable,symconst,symtype,symsym,defcmp,paramgr,
|
|
{$ifdef GDB}
|
|
gdb,
|
|
{$endif GDB}
|
|
aasmcpu,
|
|
cpubase,cgbase,
|
|
cgobj
|
|
;
|
|
|
|
|
|
{*****************************************************************************
|
|
TClassHeader
|
|
*****************************************************************************}
|
|
|
|
constructor tclassheader.create(c:tobjectdef);
|
|
begin
|
|
inherited Create;
|
|
_Class:=c;
|
|
end;
|
|
|
|
|
|
destructor tclassheader.destroy;
|
|
begin
|
|
disposevmttree;
|
|
end;
|
|
|
|
|
|
{**************************************
|
|
Message Tables
|
|
**************************************}
|
|
|
|
procedure tclassheader.disposeprocdeftree(p : pprocdeftree);
|
|
begin
|
|
if assigned(p^.l) then
|
|
disposeprocdeftree(p^.l);
|
|
if assigned(p^.r) then
|
|
disposeprocdeftree(p^.r);
|
|
dispose(p);
|
|
end;
|
|
|
|
|
|
procedure tclassheader.insertint(p : pprocdeftree;var at : pprocdeftree);
|
|
|
|
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)
|
|
else if p^.data.messageinf.i>at^.data.messageinf.i then
|
|
insertint(p,at^.r)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,tostr(p^.data.messageinf.i));
|
|
end;
|
|
end;
|
|
|
|
procedure tclassheader.insertstr(p : pprocdeftree;var at : pprocdeftree);
|
|
|
|
var
|
|
i : integer;
|
|
|
|
begin
|
|
if at=nil then
|
|
begin
|
|
at:=p;
|
|
inc(count);
|
|
end
|
|
else
|
|
begin
|
|
i:=strcomp(p^.data.messageinf.str,at^.data.messageinf.str);
|
|
if i<0 then
|
|
insertstr(p,at^.l)
|
|
else if i>0 then
|
|
insertstr(p,at^.r)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,strpas(p^.data.messageinf.str));
|
|
end;
|
|
end;
|
|
|
|
procedure tclassheader.insertmsgint(p : tnamedindexitem;arg:pointer);
|
|
|
|
var
|
|
i : cardinal;
|
|
def: Tprocdef;
|
|
pt : pprocdeftree;
|
|
|
|
begin
|
|
if tsym(p).typ=procsym then
|
|
for i:=1 to Tprocsym(p).procdef_count do
|
|
begin
|
|
def:=Tprocsym(p).procdef[i];
|
|
if po_msgint in def.procoptions then
|
|
begin
|
|
new(pt);
|
|
pt^.data:=def;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertint(pt,root);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure tclassheader.insertmsgstr(p : tnamedindexitem;arg:pointer);
|
|
|
|
var
|
|
i : cardinal;
|
|
def: Tprocdef;
|
|
pt : pprocdeftree;
|
|
|
|
begin
|
|
if tsym(p).typ=procsym then
|
|
for i:=1 to Tprocsym(p).procdef_count do
|
|
begin
|
|
def:=Tprocsym(p).procdef[i];
|
|
if po_msgstr in def.procoptions then
|
|
begin
|
|
new(pt);
|
|
pt^.data:=def;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertstr(pt,root);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure tclassheader.writenames(p : pprocdeftree);
|
|
var
|
|
ca : pchar;
|
|
len : longint;
|
|
begin
|
|
objectlibrary.getdatalabel(p^.nl);
|
|
if assigned(p^.l) then
|
|
writenames(p^.l);
|
|
datasegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(p^.nl));
|
|
len:=strlen(p^.data.messageinf.str);
|
|
datasegment.concat(tai_const.create_8bit(len));
|
|
getmem(ca,len+1);
|
|
move(p^.data.messageinf.str^,ca^,len+1);
|
|
dataSegment.concat(Tai_string.Create_pchar(ca));
|
|
if assigned(p^.r) then
|
|
writenames(p^.r);
|
|
end;
|
|
|
|
procedure tclassheader.writestrentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writestrentry(p^.l);
|
|
|
|
{ write name label }
|
|
dataSegment.concat(Tai_const_symbol.Create(p^.nl));
|
|
dataSegment.concat(Tai_const_symbol.Createname(p^.data.mangledname));
|
|
|
|
if assigned(p^.r) then
|
|
writestrentry(p^.r);
|
|
end;
|
|
|
|
|
|
function tclassheader.genstrmsgtab : tasmlabel;
|
|
var
|
|
r : tasmlabel;
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
{ insert all message handlers into a tree, sorted by name }
|
|
_class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgstr,nil);
|
|
|
|
{ write all names }
|
|
if assigned(root) then
|
|
writenames(root);
|
|
|
|
{ now start writing of the message string table }
|
|
objectlibrary.getdatalabel(r);
|
|
datasegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(r));
|
|
genstrmsgtab:=r;
|
|
dataSegment.concat(Tai_const.Create_32bit(count));
|
|
if assigned(root) then
|
|
begin
|
|
writestrentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tclassheader.writeintentry(p : pprocdeftree);
|
|
begin
|
|
if assigned(p^.l) then
|
|
writeintentry(p^.l);
|
|
|
|
{ write name label }
|
|
dataSegment.concat(Tai_const.Create_32bit(p^.data.messageinf.i));
|
|
dataSegment.concat(Tai_const_symbol.Createname(p^.data.mangledname));
|
|
|
|
if assigned(p^.r) then
|
|
writeintentry(p^.r);
|
|
end;
|
|
|
|
|
|
function tclassheader.genintmsgtab : tasmlabel;
|
|
var
|
|
r : tasmlabel;
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
{ insert all message handlers into a tree, sorted by name }
|
|
_class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertmsgint,nil);
|
|
|
|
{ now start writing of the message string table }
|
|
objectlibrary.getdatalabel(r);
|
|
datasegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(r));
|
|
genintmsgtab:=r;
|
|
dataSegment.concat(Tai_const.Create_32bit(count));
|
|
if assigned(root) then
|
|
begin
|
|
writeintentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef WITHDMT}
|
|
|
|
{**************************************
|
|
DMT
|
|
**************************************}
|
|
|
|
procedure tclassheader.insertdmtentry(p : tnamedindexitem;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 tclassheader.writedmtindexentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtindexentry(p^.l);
|
|
dataSegment.concat(Tai_const.Create_32bit(p^.data.messageinf.i));
|
|
if assigned(p^.r) then
|
|
writedmtindexentry(p^.r);
|
|
end;
|
|
|
|
procedure tclassheader.writedmtaddressentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtaddressentry(p^.l);
|
|
dataSegment.concat(Tai_const_symbol.Createname(p^.data.mangledname));
|
|
if assigned(p^.r) then
|
|
writedmtaddressentry(p^.r);
|
|
end;
|
|
|
|
function tclassheader.gendmt : tasmlabel;
|
|
|
|
var
|
|
r : tasmlabel;
|
|
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
gendmt:=nil;
|
|
{ insert all message handlers into a tree, sorted by number }
|
|
_class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}insertdmtentry);
|
|
|
|
if count>0 then
|
|
begin
|
|
objectlibrary.getdatalabel(r);
|
|
gendmt:=r;
|
|
datasegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(r));
|
|
{ entries for caching }
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
|
|
dataSegment.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 tclassheader.do_count(p : tnamedindexitem;arg:pointer);
|
|
|
|
begin
|
|
if (tsym(p).typ=procsym) and (sp_published in tsym(p).symoptions) then
|
|
inc(count);
|
|
end;
|
|
|
|
procedure tclassheader.genpubmethodtableentry(p : tnamedindexitem;arg:pointer);
|
|
|
|
var
|
|
hp : tprocdef;
|
|
l : tasmlabel;
|
|
|
|
begin
|
|
if (tsym(p).typ=procsym) and (sp_published in tsym(p).symoptions) then
|
|
begin
|
|
if Tprocsym(p).procdef_count>1 then
|
|
internalerror(1209992);
|
|
hp:=tprocsym(p).first_procdef;
|
|
objectlibrary.getdatalabel(l);
|
|
|
|
consts.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
Consts.concat(Tai_label.Create(l));
|
|
Consts.concat(Tai_const.Create_8bit(length(p.name)));
|
|
Consts.concat(Tai_string.Create(p.name));
|
|
|
|
dataSegment.concat(Tai_const_symbol.Create(l));
|
|
dataSegment.concat(Tai_const_symbol.Createname(hp.mangledname));
|
|
end;
|
|
end;
|
|
|
|
function tclassheader.genpublishedmethodstable : tasmlabel;
|
|
|
|
var
|
|
l : tasmlabel;
|
|
|
|
begin
|
|
count:=0;
|
|
_class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}do_count,nil);
|
|
if count>0 then
|
|
begin
|
|
objectlibrary.getdatalabel(l);
|
|
datasegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(l));
|
|
dataSegment.concat(Tai_const.Create_32bit(count));
|
|
_class.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}genpubmethodtableentry,nil);
|
|
genpublishedmethodstable:=l;
|
|
end
|
|
else
|
|
genpublishedmethodstable:=nil;
|
|
end;
|
|
|
|
|
|
{**************************************
|
|
VMT
|
|
**************************************}
|
|
|
|
procedure tclassheader.eachsym(sym : tnamedindexitem;arg:pointer);
|
|
|
|
var
|
|
procdefcoll : pprocdefcoll;
|
|
symcoll : psymcoll;
|
|
_name : string;
|
|
_speed : cardinal;
|
|
|
|
procedure newdefentry(pd:tprocdef);
|
|
begin
|
|
new(procdefcoll);
|
|
procdefcoll^.data:=pd;
|
|
procdefcoll^.hidden:=false;
|
|
procdefcoll^.next:=symcoll^.data;
|
|
symcoll^.data:=procdefcoll;
|
|
|
|
{ if it's a virtual method }
|
|
if (po_virtualmethod in pd.procoptions) then
|
|
begin
|
|
{ then it gets a number ... }
|
|
pd.extnumber:=nextvirtnumber;
|
|
{ and we inc the number }
|
|
inc(nextvirtnumber);
|
|
has_virtual_method:=true;
|
|
end;
|
|
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
has_constructor:=true;
|
|
|
|
{ check, if a method should be overridden }
|
|
if (pd._class=_class) and
|
|
(po_overridingmethod in pd.procoptions) then
|
|
MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
|
|
end;
|
|
|
|
{ creates a new entry in the procsym list }
|
|
procedure newentry;
|
|
|
|
var i:cardinal;
|
|
|
|
begin
|
|
{ if not, generate a new symbol item }
|
|
new(symcoll);
|
|
symcoll^.speedvalue:=sym.speedvalue;
|
|
symcoll^.name:=stringdup(sym.name);
|
|
symcoll^.next:=wurzel;
|
|
symcoll^.data:=nil;
|
|
wurzel:=symcoll;
|
|
|
|
{ inserts all definitions }
|
|
for i:=1 to Tprocsym(sym).procdef_count do
|
|
newdefentry(Tprocsym(sym).procdef[i]);
|
|
end;
|
|
|
|
label
|
|
handlenextdef;
|
|
var
|
|
pd : tprocdef;
|
|
i : cardinal;
|
|
is_visible,
|
|
hasoverloads,
|
|
pdoverload : boolean;
|
|
begin
|
|
{ put only sub routines into the VMT, and routines
|
|
that are visible to the current class. Skip private
|
|
methods in other classes }
|
|
if (tsym(sym).typ=procsym) then
|
|
begin
|
|
{ is this symbol 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:=tprocsym(sym).is_visible_for_object(_class);
|
|
{ check the current list of symbols }
|
|
_name:=sym.name;
|
|
_speed:=sym.speedvalue;
|
|
symcoll:=wurzel;
|
|
while assigned(symcoll) do
|
|
begin
|
|
{ does the symbol already exist in the list? First
|
|
compare speedvalue before doing the string compare to
|
|
speed it up a little }
|
|
if (_speed=symcoll^.speedvalue) and
|
|
(_name=symcoll^.name^) then
|
|
begin
|
|
hasoverloads:=(Tprocsym(sym).procdef_count>1);
|
|
{ walk through all defs of the symbol }
|
|
for i:=1 to Tprocsym(sym).procdef_count do
|
|
begin
|
|
pd:=Tprocsym(sym).procdef[i];
|
|
if pd.procsym=sym then
|
|
begin
|
|
pdoverload:=(po_overload in pd.procoptions);
|
|
|
|
{ compare with all stored definitions }
|
|
procdefcoll:=symcoll^.data;
|
|
while assigned(procdefcoll) do
|
|
begin
|
|
{ compare only if the definition is not hidden }
|
|
if not procdefcoll^.hidden then
|
|
begin
|
|
{ check if one of the two methods has virtual }
|
|
if (po_virtualmethod in procdefcoll^.data.procoptions) or
|
|
(po_virtualmethod in pd.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
|
|
begin
|
|
if tstoredsym(procdefcoll^.data.procsym).is_visible_for_object(pd._class) and
|
|
(not(pdoverload or hasoverloads) or
|
|
(compare_paras(procdefcoll^.data.para,pd.para,cp_value_equal_const,[])>=te_equal)) then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if _class=pd._class 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(_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.para,pd.para,cp_value_equal_const,[])>=te_equal)) and
|
|
(tstoredsym(procdefcoll^.data.procsym).is_visible_for_object(pd._class)) then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if _class=pd._class then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
|
|
end;
|
|
end
|
|
{ check if the method to override is visible }
|
|
else if (po_overridingmethod in pd.procoptions) and
|
|
(not tstoredsym(procdefcoll^.data.procsym).is_visible_for_object(pd._class)) then
|
|
begin
|
|
{ do nothing, the error will follow when adding the entry }
|
|
end
|
|
{ same parameters }
|
|
else if (compare_paras(procdefcoll^.data.para,pd.para,cp_value_equal_const,[])>=te_equal) 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;
|
|
|
|
{ the flags have to match except abstract and override }
|
|
{ only if both are virtual !! }
|
|
if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
|
|
(procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
|
|
((procdefcoll^.data.procoptions-
|
|
[po_abstractmethod,po_overridingmethod,po_assembler,po_overload,po_public])<>
|
|
(pd.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler,po_overload,po_public])) then
|
|
begin
|
|
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
|
|
tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
|
|
end;
|
|
|
|
{ error, if the return types aren't equal }
|
|
if not(equal_defs(procdefcoll^.data.rettype.def,pd.rettype.def)) and
|
|
not((procdefcoll^.data.rettype.def.deftype=objectdef) and
|
|
(pd.rettype.def.deftype=objectdef) and
|
|
is_class(procdefcoll^.data.rettype.def) and
|
|
is_class(pd.rettype.def) and
|
|
(tobjectdef(pd.rettype.def).is_related(
|
|
tobjectdef(procdefcoll^.data.rettype.def)))) then
|
|
Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
|
|
procdefcoll^.data.fullprocname(false));
|
|
|
|
{ now set the number }
|
|
pd.extnumber:=procdefcoll^.data.extnumber;
|
|
{ and exchange }
|
|
procdefcoll^.data:=pd;
|
|
goto handlenextdef;
|
|
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 then
|
|
begin
|
|
if is_visible then
|
|
procdefcoll^.hidden:=true;
|
|
if _class=pd._class then
|
|
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.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.para,pd.para,cp_value_equal_const,[])>=te_equal)) then
|
|
procdefcoll^.hidden:=true;
|
|
end;
|
|
end
|
|
else
|
|
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
|
|
(compare_paras(procdefcoll^.data.para,pd.para,cp_value_equal_const,[])>=te_equal)) then
|
|
procdefcoll^.hidden:=true;
|
|
end;
|
|
end; { not hidden }
|
|
procdefcoll:=procdefcoll^.next;
|
|
end;
|
|
|
|
{ if it isn't saved in the list we create a new entry }
|
|
newdefentry(pd);
|
|
end;
|
|
handlenextdef:
|
|
end;
|
|
exit;
|
|
end;
|
|
symcoll:=symcoll^.next;
|
|
end;
|
|
newentry;
|
|
end;
|
|
end;
|
|
|
|
procedure tclassheader.disposevmttree;
|
|
|
|
var
|
|
symcoll : psymcoll;
|
|
procdefcoll : pprocdefcoll;
|
|
|
|
begin
|
|
{ disposes the above generated tree }
|
|
symcoll:=wurzel;
|
|
while assigned(symcoll) do
|
|
begin
|
|
wurzel:=symcoll^.next;
|
|
stringdispose(symcoll^.name);
|
|
procdefcoll:=symcoll^.data;
|
|
while assigned(procdefcoll) do
|
|
begin
|
|
symcoll^.data:=procdefcoll^.next;
|
|
dispose(procdefcoll);
|
|
procdefcoll:=symcoll^.data;
|
|
end;
|
|
dispose(symcoll);
|
|
symcoll:=wurzel;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tclassheader.genvmt;
|
|
|
|
procedure do_genvmt(p : tobjectdef);
|
|
|
|
begin
|
|
{ start with the base class }
|
|
if assigned(p.childof) then
|
|
do_genvmt(p.childof);
|
|
|
|
{ walk through all public syms }
|
|
p.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}eachsym,nil);
|
|
end;
|
|
|
|
begin
|
|
wurzel:=nil;
|
|
nextvirtnumber:=0;
|
|
|
|
has_constructor:=false;
|
|
has_virtual_method:=false;
|
|
|
|
{ generates a tree of all used methods }
|
|
do_genvmt(_class);
|
|
|
|
if not(is_interface(_class)) and
|
|
has_virtual_method and
|
|
not(has_constructor) then
|
|
Message1(parser_w_virtual_without_constructor,_class.objrealname^);
|
|
end;
|
|
|
|
|
|
{**************************************
|
|
Interface tables
|
|
**************************************}
|
|
|
|
function tclassheader.gintfgetvtbllabelname(intfindex: integer): string;
|
|
begin
|
|
gintfgetvtbllabelname:=make_mangledname('VTBL',_class.owner,_class.objname^+
|
|
'_$_'+_class.implementedinterfaces.interfaces(intfindex).objname^);
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata,rawcode: TAAsmoutput);
|
|
var
|
|
implintf: timplementedinterfaces;
|
|
curintf: tobjectdef;
|
|
proccount: integer;
|
|
tmps: string;
|
|
i: longint;
|
|
begin
|
|
implintf:=_class.implementedinterfaces;
|
|
curintf:=implintf.interfaces(intfindex);
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
rawdata.concat(Tai_symbol.Createname_global(gintfgetvtbllabelname(intfindex),0))
|
|
else
|
|
rawdata.concat(Tai_symbol.Createname(gintfgetvtbllabelname(intfindex),0));
|
|
proccount:=implintf.implproccount(intfindex);
|
|
for i:=1 to proccount do
|
|
begin
|
|
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+curintf.objname^+'_$_'+
|
|
tostr(i)+'_$_'+
|
|
implintf.implprocs(intfindex,i).mangledname);
|
|
{ create wrapper code }
|
|
cgintfwrapper(rawcode,implintf.implprocs(intfindex,i),tmps,implintf.ioffsets(intfindex)^);
|
|
{ create reference }
|
|
rawdata.concat(Tai_const_symbol.Createname(tmps));
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfgenentry(intfindex, contintfindex: integer; rawdata: TAAsmoutput);
|
|
var
|
|
implintf: timplementedinterfaces;
|
|
curintf: tobjectdef;
|
|
tmplabel: tasmlabel;
|
|
i: longint;
|
|
begin
|
|
implintf:=_class.implementedinterfaces;
|
|
curintf:=implintf.interfaces(intfindex);
|
|
{ GUID }
|
|
if curintf.objecttype in [odt_interfacecom] then
|
|
begin
|
|
{ label for GUID }
|
|
objectlibrary.getdatalabel(tmplabel);
|
|
rawdata.concat(tai_align.create(const_align(pointer_size)));
|
|
rawdata.concat(Tai_label.Create(tmplabel));
|
|
rawdata.concat(Tai_const.Create_32bit(longint(curintf.iidguid^.D1)));
|
|
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D2));
|
|
rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D3));
|
|
for i:=Low(curintf.iidguid^.D4) to High(curintf.iidguid^.D4) do
|
|
rawdata.concat(Tai_const.Create_8bit(curintf.iidguid^.D4[i]));
|
|
dataSegment.concat(Tai_const_symbol.Create(tmplabel));
|
|
end
|
|
else
|
|
begin
|
|
{ nil for Corba interfaces }
|
|
dataSegment.concat(Tai_const.Create_32bit(0)); { nil }
|
|
end;
|
|
{ VTable }
|
|
dataSegment.concat(Tai_const_symbol.Createname(gintfgetvtbllabelname(contintfindex)));
|
|
{ IOffset field }
|
|
dataSegment.concat(Tai_const.Create_32bit(implintf.ioffsets(contintfindex)^));
|
|
{ IIDStr }
|
|
objectlibrary.getdatalabel(tmplabel);
|
|
rawdata.concat(tai_align.create(const_align(pointer_size)));
|
|
rawdata.concat(Tai_label.Create(tmplabel));
|
|
rawdata.concat(Tai_const.Create_8bit(length(curintf.iidstr^)));
|
|
if curintf.objecttype=odt_interfacecom then
|
|
rawdata.concat(Tai_string.Create(upper(curintf.iidstr^)))
|
|
else
|
|
rawdata.concat(Tai_string.Create(curintf.iidstr^));
|
|
dataSegment.concat(Tai_const_symbol.Create(tmplabel));
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfoptimizevtbls(implvtbl : plongintarray);
|
|
type
|
|
tcompintfentry = record
|
|
weight: longint;
|
|
compintf: longint;
|
|
end;
|
|
{ Max 1000 interface in the class header interfaces it's enough imho }
|
|
tcompintfs = packed array[1..1000] of tcompintfentry;
|
|
pcompintfs = ^tcompintfs;
|
|
tequals = packed array[1..1000] of longint;
|
|
pequals = ^tequals;
|
|
var
|
|
max: longint;
|
|
equals: pequals;
|
|
compats: pcompintfs;
|
|
i: longint;
|
|
j: longint;
|
|
w: longint;
|
|
cij: boolean;
|
|
cji: boolean;
|
|
begin
|
|
max:=_class.implementedinterfaces.count;
|
|
if max>High(tequals) then
|
|
Internalerror(200006135);
|
|
getmem(compats,sizeof(tcompintfentry)*max);
|
|
getmem(equals,sizeof(longint)*max);
|
|
fillchar(compats^,sizeof(tcompintfentry)*max,0);
|
|
fillchar(equals^,sizeof(longint)*max,0);
|
|
{ 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:=1 to max do
|
|
begin
|
|
for j:=i+1 to max do
|
|
begin
|
|
cij:=_class.implementedinterfaces.isimplmergepossible(i,j,w);
|
|
cji:=_class.implementedinterfaces.isimplmergepossible(j,i,w);
|
|
if cij and cji then { i equal j }
|
|
begin
|
|
{ get minimum index of equal }
|
|
if equals^[j]=0 then
|
|
equals^[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;
|
|
for i:=1 to max do
|
|
begin
|
|
if compats^[i].compintf<>0 then
|
|
implvtbl[i]:=compats^[i].compintf
|
|
else if equals^[i]<>0 then
|
|
implvtbl[i]:=equals^[i]
|
|
else
|
|
implvtbl[i]:=i;
|
|
end;
|
|
freemem(compats,sizeof(tcompintfentry)*max);
|
|
freemem(equals,sizeof(longint)*max);
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfwritedata;
|
|
var
|
|
rawdata,rawcode: taasmoutput;
|
|
impintfindexes: plongintarray;
|
|
max: longint;
|
|
i: longint;
|
|
begin
|
|
max:=_class.implementedinterfaces.count;
|
|
getmem(impintfindexes,(max+1)*sizeof(longint));
|
|
|
|
gintfoptimizevtbls(impintfindexes);
|
|
|
|
rawdata:=TAAsmOutput.Create;
|
|
rawcode:=TAAsmOutput.Create;
|
|
dataSegment.concat(Tai_const.Create_16bit(max));
|
|
{ Two pass, one for allocation and vtbl creation }
|
|
for i:=1 to max do
|
|
begin
|
|
if impintfindexes[i]=i then { if implement itself }
|
|
begin
|
|
{ allocate a pointer in the object memory }
|
|
with tobjectsymtable(_class.symtable) do
|
|
begin
|
|
if (dataalignment>=pointer_size) then
|
|
datasize:=align(datasize,dataalignment)
|
|
else
|
|
datasize:=align(datasize,pointer_size);
|
|
_class.implementedinterfaces.ioffsets(i)^:=datasize;
|
|
datasize:=datasize+pointer_size;
|
|
end;
|
|
{ write vtbl }
|
|
gintfcreatevtbl(i,rawdata,rawcode);
|
|
end;
|
|
end;
|
|
{ second pass: for fill interfacetable and remained ioffsets }
|
|
for i:=1 to max do
|
|
begin
|
|
if i<>impintfindexes[i] then { why execute x:=x ? }
|
|
with _class.implementedinterfaces do
|
|
ioffsets(i)^:=ioffsets(impintfindexes[i])^;
|
|
gintfgenentry(i,impintfindexes[i],rawdata);
|
|
end;
|
|
dataSegment.concatlist(rawdata);
|
|
rawdata.free;
|
|
codeSegment.concatlist(rawcode);
|
|
rawcode.free;
|
|
freemem(impintfindexes,(max+1)*sizeof(longint));
|
|
end;
|
|
|
|
|
|
function tclassheader.gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
|
|
var
|
|
sym: tsym;
|
|
implprocdef : Tprocdef;
|
|
i: cardinal;
|
|
begin
|
|
gintfgetcprocdef:=nil;
|
|
|
|
sym:=tsym(search_class_member(_class,name));
|
|
if assigned(sym) and
|
|
(sym.typ=procsym) then
|
|
begin
|
|
{ when the definition has overload directive set, we search for
|
|
overloaded definitions in the class, this only needs to be done once
|
|
for class entries as the tree keeps always the same }
|
|
if (not tprocsym(sym).overloadchecked) and
|
|
(po_overload in tprocsym(sym).first_procdef.procoptions) and
|
|
(tprocsym(sym).owner.symtabletype=objectsymtable) then
|
|
search_class_overloads(tprocsym(sym));
|
|
|
|
for i:=1 to tprocsym(sym).procdef_count do
|
|
begin
|
|
implprocdef:=tprocsym(sym).procdef[i];
|
|
if (compare_paras(proc.para,implprocdef.para,cp_none,[])>=te_equal) and
|
|
(proc.proccalloption=implprocdef.proccalloption) then
|
|
begin
|
|
gintfgetcprocdef:=implprocdef;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfdoonintf(intf: tobjectdef; intfindex: longint);
|
|
var
|
|
def: tdef;
|
|
procname: string; { for error }
|
|
mappedname: string;
|
|
nextexist: pointer;
|
|
implprocdef: tprocdef;
|
|
begin
|
|
def:=tdef(intf.symtable.defindex.first);
|
|
while assigned(def) do
|
|
begin
|
|
if def.deftype=procdef then
|
|
begin
|
|
procname:='';
|
|
implprocdef:=nil;
|
|
nextexist:=nil;
|
|
repeat
|
|
mappedname:=_class.implementedinterfaces.getmappings(intfindex,tprocdef(def).procsym.name,nextexist);
|
|
if procname='' then
|
|
procname:=tprocdef(def).procsym.name;
|
|
//mappedname; { for error messages }
|
|
if mappedname<>'' then
|
|
implprocdef:=gintfgetcprocdef(tprocdef(def),mappedname);
|
|
until assigned(implprocdef) or not assigned(nextexist);
|
|
if not assigned(implprocdef) then
|
|
implprocdef:=gintfgetcprocdef(tprocdef(def),tprocdef(def).procsym.name);
|
|
if procname='' then
|
|
procname:=tprocdef(def).procsym.name;
|
|
if assigned(implprocdef) then
|
|
_class.implementedinterfaces.addimplproc(intfindex,implprocdef)
|
|
else
|
|
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
|
|
end;
|
|
def:=tdef(def.indexnext);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tclassheader.gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
|
|
begin
|
|
if assigned(intf.childof) then
|
|
gintfwalkdowninterface(intf.childof,intfindex);
|
|
gintfdoonintf(intf,intfindex);
|
|
end;
|
|
|
|
|
|
function tclassheader.genintftable: tasmlabel;
|
|
var
|
|
intfindex: longint;
|
|
curintf: tobjectdef;
|
|
intftable: tasmlabel;
|
|
begin
|
|
{ 1. step collect implementor functions into the implementedinterfaces.implprocs }
|
|
for intfindex:=1 to _class.implementedinterfaces.count do
|
|
begin
|
|
curintf:=_class.implementedinterfaces.interfaces(intfindex);
|
|
gintfwalkdowninterface(curintf,intfindex);
|
|
end;
|
|
{ 2. step calc required fieldcount and their offsets in the object memory map
|
|
and write data }
|
|
objectlibrary.getdatalabel(intftable);
|
|
dataSegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(intftable));
|
|
gintfwritedata;
|
|
_class.implementedinterfaces.clearimplprocs; { release temporary information }
|
|
genintftable:=intftable;
|
|
end;
|
|
|
|
|
|
{ Write interface identifiers to the data section }
|
|
procedure tclassheader.writeinterfaceids;
|
|
var
|
|
i: longint;
|
|
begin
|
|
if assigned(_class.iidguid) then
|
|
begin
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
dataSegment.concat(Tai_cut.Create);
|
|
dataSegment.concat(Tai_symbol.Createname_global(make_mangledname('IID',_class.owner,_class.objname^),0));
|
|
dataSegment.concat(Tai_const.Create_32bit(longint(_class.iidguid^.D1)));
|
|
dataSegment.concat(Tai_const.Create_16bit(_class.iidguid^.D2));
|
|
dataSegment.concat(Tai_const.Create_16bit(_class.iidguid^.D3));
|
|
for i:=Low(_class.iidguid^.D4) to High(_class.iidguid^.D4) do
|
|
dataSegment.concat(Tai_const.Create_8bit(_class.iidguid^.D4[i]));
|
|
end;
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
dataSegment.concat(Tai_cut.Create);
|
|
dataSegment.concat(Tai_symbol.Createname_global(make_mangledname('IIDSTR',_class.owner,_class.objname^),0));
|
|
dataSegment.concat(Tai_const.Create_8bit(length(_class.iidstr^)));
|
|
dataSegment.concat(Tai_string.Create(_class.iidstr^));
|
|
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
|
|
List.concat(Tai_const_symbol.Createname('FPC_ABSTRACTERROR'))
|
|
else
|
|
List.concat(Tai_const_symbol.createname(procdefcoll^.data.mangledname));
|
|
end;
|
|
end;
|
|
procdefcoll:=procdefcoll^.next;
|
|
end;
|
|
symcoll:=symcoll^.next;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ generates the vmt for classes as well as for objects }
|
|
procedure tclassheader.writevmt;
|
|
|
|
var
|
|
methodnametable,intmessagetable,
|
|
strmessagetable,classnamelabel,
|
|
fieldtablelabel : tasmlabel;
|
|
{$ifdef WITHDMT}
|
|
dmtlabel : tasmlabel;
|
|
{$endif WITHDMT}
|
|
interfacetable : tasmlabel;
|
|
begin
|
|
{$ifdef WITHDMT}
|
|
dmtlabel:=gendmt;
|
|
{$endif WITHDMT}
|
|
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
dataSegment.concat(Tai_cut.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
|
|
{ interface table }
|
|
if _class.implementedinterfaces.count>0 then
|
|
begin
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
codeSegment.concat(Tai_cut.Create);
|
|
interfacetable:=genintftable;
|
|
end;
|
|
|
|
methodnametable:=genpublishedmethodstable;
|
|
fieldtablelabel:=_class.generate_field_table;
|
|
{ write class name }
|
|
objectlibrary.getdatalabel(classnamelabel);
|
|
dataSegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_label.Create(classnamelabel));
|
|
dataSegment.concat(Tai_const.Create_8bit(length(_class.objrealname^)));
|
|
dataSegment.concat(Tai_string.Create(_class.objrealname^));
|
|
{ generate message and dynamic tables }
|
|
if (oo_has_msgstr in _class.objectoptions) then
|
|
strmessagetable:=genstrmsgtab;
|
|
if (oo_has_msgint in _class.objectoptions) then
|
|
intmessagetable:=genintmsgtab;
|
|
end;
|
|
|
|
{ write debug info }
|
|
{$ifdef GDB}
|
|
if (cs_debuginfo in aktmoduleswitches) then
|
|
begin
|
|
do_count_dbx:=true;
|
|
if assigned(_class.owner) and assigned(_class.owner.name) then
|
|
dataSegment.concat(Tai_stabs.Create(strpnew('"vmt_'+_class.owner.name^+_class.name+':S'+
|
|
typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+_class.vmt_mangledname)));
|
|
end;
|
|
{$endif GDB}
|
|
dataSegment.concat(tai_align.create(const_align(POINTER_SIZE)));
|
|
dataSegment.concat(Tai_symbol.Createdataname_global(_class.vmt_mangledname,0));
|
|
|
|
{ determine the size with symtable.datasize, because }
|
|
{ size gives back 4 for classes }
|
|
dataSegment.concat(Tai_const.Create_32bit(tobjectsymtable(_class.symtable).datasize));
|
|
dataSegment.concat(Tai_const.Create_32bit(-tobjectsymtable(_class.symtable).datasize));
|
|
{$ifdef WITHDMT}
|
|
if _class.classtype=ct_object then
|
|
begin
|
|
if assigned(dmtlabel) then
|
|
dataSegment.concat(Tai_const_symbol.Create(dmtlabel)))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(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
|
|
dataSegment.concat(Tai_const_symbol.Createname(_class.childof.vmt_mangledname))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
|
|
{ write extended info for classes, for the order see rtl/inc/objpash.inc }
|
|
if is_class(_class) then
|
|
begin
|
|
{ pointer to class name string }
|
|
dataSegment.concat(Tai_const_symbol.Create(classnamelabel));
|
|
{ pointer to dynamic table }
|
|
if (oo_has_msgint in _class.objectoptions) then
|
|
dataSegment.concat(Tai_const_symbol.Create(intmessagetable))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ pointer to method table }
|
|
if assigned(methodnametable) then
|
|
dataSegment.concat(Tai_const_symbol.Create(methodnametable))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ pointer to field table }
|
|
dataSegment.concat(Tai_const_symbol.Create(fieldtablelabel));
|
|
{ pointer to type info of published section }
|
|
if (oo_can_have_published in _class.objectoptions) then
|
|
dataSegment.concat(Tai_const_symbol.Create(_class.get_rtti_label(fullrtti)))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ inittable for con-/destruction }
|
|
if _class.members_need_inittable then
|
|
dataSegment.concat(Tai_const_symbol.Create(_class.get_rtti_label(initrtti)))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ auto table }
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ interface table }
|
|
if _class.implementedinterfaces.count>0 then
|
|
dataSegment.concat(Tai_const_symbol.Create(interfacetable))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
{ table for string messages }
|
|
if (oo_has_msgstr in _class.objectoptions) then
|
|
dataSegment.concat(Tai_const_symbol.Create(strmessagetable))
|
|
else
|
|
dataSegment.concat(Tai_const.Create_32bit(0));
|
|
end;
|
|
{ write virtual methods }
|
|
writevirtualmethods(dataSegment);
|
|
{ write the size of the VMT }
|
|
dataSegment.concat(Tai_symbol_end.Createname(_class.vmt_mangledname));
|
|
end;
|
|
|
|
procedure tclassheader.adjustselfvalue(procdef: tprocdef;ioffset: aword);
|
|
var
|
|
hsym : tsym;
|
|
href : treference;
|
|
locpara : tparalocation;
|
|
begin
|
|
{ calculate the parameter info for the procdef }
|
|
if not procdef.has_paraloc_info then
|
|
begin
|
|
paramanager.create_paraloc_info(procdef,callerside);
|
|
procdef.has_paraloc_info:=true;
|
|
end;
|
|
hsym:=tsym(procdef.parast.search('self'));
|
|
if not(assigned(hsym) and
|
|
(hsym.typ=varsym) and
|
|
assigned(tvarsym(hsym).paraitem)) then
|
|
internalerror(200305251);
|
|
locpara:=tvarsym(hsym).paraitem.paraloc[callerside];
|
|
case locpara.loc of
|
|
LOC_REGISTER:
|
|
cg.a_op_const_reg(exprasmlist,OP_SUB,locpara.size,ioffset,locpara.register);
|
|
LOC_REFERENCE:
|
|
begin
|
|
{ offset in the wrapper needs to be adjusted for the stored
|
|
return address }
|
|
reference_reset_base(href,locpara.reference.index,locpara.reference.offset+POINTER_SIZE);
|
|
cg.a_op_const_ref(exprasmlist,OP_SUB,locpara.size,ioffset,href);
|
|
end
|
|
else
|
|
internalerror(200309189);
|
|
end;
|
|
end;
|
|
|
|
|
|
initialization
|
|
cclassheader:=tclassheader;
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.56 2003-11-28 17:24:22 peter
|
|
* reversed offset calculation for caller side so it works
|
|
correctly for interfaces
|
|
|
|
Revision 1.55 2003/10/30 16:23:13 peter
|
|
* don't search for overloads in parents for constructors
|
|
|
|
Revision 1.54 2003/10/29 19:48:50 peter
|
|
* renamed mangeldname_prefix to make_mangledname and made it more
|
|
generic
|
|
* make_mangledname is now also used for internal threadvar/resstring
|
|
lists
|
|
* Add P$ in front of program modulename to prevent duplicated symbols
|
|
at assembler level, because the main program can have the same name
|
|
as a unit, see webtbs/tw1251b
|
|
|
|
Revision 1.53 2003/10/13 14:05:12 peter
|
|
* removed is_visible_for_proc
|
|
* search also for class overloads when finding interface
|
|
implementations
|
|
|
|
Revision 1.52 2003/10/10 17:48:13 peter
|
|
* old trgobj moved to x86/rgcpu and renamed to trgx86fpu
|
|
* tregisteralloctor renamed to trgobj
|
|
* removed rgobj from a lot of units
|
|
* moved location_* and reference_* to cgobj
|
|
* first things for mmx register allocation
|
|
|
|
Revision 1.51 2003/10/07 21:14:32 peter
|
|
* compare_paras() has a parameter to ignore hidden parameters
|
|
* cross unit overload searching ignores hidden parameters when
|
|
comparing parameter lists. Now function(string):string is
|
|
not overriden with procedure(string) which has the same visible
|
|
parameter list
|
|
|
|
Revision 1.50 2003/10/07 20:44:22 peter
|
|
* inherited forced calling convention
|
|
* show hints when forward doesn't match
|
|
|
|
Revision 1.49 2003/10/01 20:34:49 peter
|
|
* procinfo unit contains tprocinfo
|
|
* cginfo renamed to cgbase
|
|
* moved cgmessage to verbose
|
|
* fixed ppc and sparc compiles
|
|
|
|
Revision 1.48 2003/09/23 17:56:05 peter
|
|
* locals and paras are allocated in the code generation
|
|
* tvarsym.localloc contains the location of para/local when
|
|
generating code for the current procedure
|
|
|
|
Revision 1.47 2003/08/21 14:47:41 peter
|
|
* remove convert_registers
|
|
|
|
Revision 1.46 2003/08/20 09:07:00 daniel
|
|
* New register coding now mandatory, some more convert_registers calls
|
|
removed.
|
|
|
|
Revision 1.45 2003/08/10 17:25:23 peter
|
|
* fixed some reported bugs
|
|
|
|
Revision 1.44 2003/06/01 21:38:06 peter
|
|
* getregisterfpu size parameter added
|
|
* op_const_reg size parameter added
|
|
* sparc updates
|
|
|
|
Revision 1.43 2003/05/23 14:27:35 peter
|
|
* remove some unit dependencies
|
|
* current_procinfo changes to store more info
|
|
|
|
Revision 1.42 2003/04/25 20:59:33 peter
|
|
* removed funcretn,funcretsym, function result is now in varsym
|
|
and aliases for result and function name are added using absolutesym
|
|
* vs_hidden parameter for funcret passed in parameter
|
|
* vs_hidden fixes
|
|
* writenode changed to printnode and released from extdebug
|
|
* -vp option added to generate a tree.log with the nodetree
|
|
* nicer printnode for statements, callnode
|
|
|
|
Revision 1.41 2003/04/23 10:11:22 peter
|
|
* range check error for GUID fixed
|
|
|
|
Revision 1.40 2003/01/13 14:54:34 daniel
|
|
* Further work to convert codegenerator register convention;
|
|
internalerror bug fixed.
|
|
|
|
Revision 1.39 2003/01/09 21:52:37 peter
|
|
* merged some verbosity options.
|
|
* V_LineInfo is a verbosity flag to include line info
|
|
|
|
Revision 1.38 2002/11/25 17:43:20 peter
|
|
* splitted defbase in defutil,symutil,defcmp
|
|
* merged isconvertable and is_equal into compare_defs(_ext)
|
|
* made operator search faster by walking the list only once
|
|
|
|
Revision 1.37 2002/11/17 16:31:56 carl
|
|
* memory optimization (3-4%) : cleanup of tai fields,
|
|
cleanup of tdef and tsym fields.
|
|
* make it work for m68k
|
|
|
|
Revision 1.36 2002/11/15 01:58:52 peter
|
|
* merged changes from 1.0.7 up to 04-11
|
|
- -V option for generating bug report tracing
|
|
- more tracing for option parsing
|
|
- errors for cdecl and high()
|
|
- win32 import stabs
|
|
- win32 records<=8 are returned in eax:edx (turned off by default)
|
|
- heaptrc update
|
|
- more info for temp management in .s file with EXTDEBUG
|
|
|
|
Revision 1.35 2002/11/09 16:19:43 carl
|
|
- remove superfluous data in classname
|
|
|
|
Revision 1.34 2002/11/09 15:35:35 carl
|
|
* major alignment updates for objects/class tables
|
|
|
|
Revision 1.33 2002/10/20 15:33:36 peter
|
|
* having overloads is the same as overload directive for hiding of
|
|
parent methods. This is required becuase it can be possible that a
|
|
method will then hide a method in the parent that an overloaded
|
|
method requires. See webbug tw2185
|
|
|
|
Revision 1.32 2002/10/19 15:09:24 peter
|
|
+ tobjectdef.members_need_inittable that is used to generate only the
|
|
inittable when it is really used. This saves a lot of useless calls
|
|
to fpc_finalize when destroying classes
|
|
|
|
Revision 1.31 2002/10/15 19:00:42 peter
|
|
* small tweak to use speedvalue before comparing strings
|
|
|
|
Revision 1.30 2002/10/06 16:40:25 florian
|
|
* interface wrapper name mangling improved
|
|
|
|
Revision 1.29 2002/10/05 12:43:25 carl
|
|
* fixes for Delphi 6 compilation
|
|
(warning : Some features do not work under Delphi)
|
|
|
|
Revision 1.28 2002/09/16 14:11:13 peter
|
|
* add argument to equal_paras() to support default values or not
|
|
|
|
Revision 1.27 2002/09/03 16:26:26 daniel
|
|
* Make Tprocdef.defs protected
|
|
|
|
Revision 1.26 2002/09/03 15:44:44 peter
|
|
* fixed private methods hiding public virtual methods
|
|
|
|
Revision 1.25 2002/08/11 14:32:27 peter
|
|
* renamed current_library to objectlibrary
|
|
|
|
Revision 1.24 2002/08/11 13:24:12 peter
|
|
* saving of asmsymbols in ppu supported
|
|
* asmsymbollist global is removed and moved into a new class
|
|
tasmlibrarydata that will hold the info of a .a file which
|
|
corresponds with a single module. Added librarydata to tmodule
|
|
to keep the library info stored for the module. In the future the
|
|
objectfiles will also be stored to the tasmlibrarydata class
|
|
* all getlabel/newasmsymbol and friends are moved to the new class
|
|
|
|
Revision 1.23 2002/08/09 07:33:01 florian
|
|
* a couple of interface related fixes
|
|
|
|
Revision 1.22 2002/07/20 11:57:55 florian
|
|
* types.pas renamed to defbase.pas because D6 contains a types
|
|
unit so this would conflicts if D6 programms are compiled
|
|
+ Willamette/SSE2 instructions to assembler added
|
|
|
|
Revision 1.21 2002/07/01 18:46:23 peter
|
|
* internal linker
|
|
* reorganized aasm layer
|
|
|
|
Revision 1.20 2002/05/18 13:34:10 peter
|
|
* readded missing revisions
|
|
|
|
Revision 1.19 2002/05/16 19:46:39 carl
|
|
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
|
|
+ try to fix temp allocation (still in ifdef)
|
|
+ generic constructor calls
|
|
+ start of tassembler / tmodulebase class cleanup
|
|
|
|
Revision 1.17 2002/05/12 16:53:08 peter
|
|
* moved entry and exitcode to ncgutil and cgobj
|
|
* foreach gets extra argument for passing local data to the
|
|
iterator function
|
|
* -CR checks also class typecasts at runtime by changing them
|
|
into as
|
|
* fixed compiler to cycle with the -CR option
|
|
* fixed stabs with elf writer, finally the global variables can
|
|
be watched
|
|
* removed a lot of routines from cga unit and replaced them by
|
|
calls to cgobj
|
|
* u32bit-s32bit updates for and,or,xor nodes. When one element is
|
|
u32bit then the other is typecasted also to u32bit without giving
|
|
a rangecheck warning/error.
|
|
* fixed pascal calling method with reversing also the high tree in
|
|
the parast, detected by tcalcst3 test
|
|
|
|
Revision 1.16 2002/04/20 21:32:24 carl
|
|
+ generic FPC_CHECKPOINTER
|
|
+ first parameter offset in stack now portable
|
|
* rename some constants
|
|
+ move some cpu stuff to other units
|
|
- remove unused constents
|
|
* fix stacksize for some targets
|
|
* fix generic size problems which depend now on EXTEND_SIZE constant
|
|
|
|
Revision 1.15 2002/04/19 15:46:01 peter
|
|
* mangledname rewrite, tprocdef.mangledname is now created dynamicly
|
|
in most cases and not written to the ppu
|
|
* add mangeledname_prefix() routine to generate the prefix of
|
|
manglednames depending on the current procedure, object and module
|
|
* removed static procprefix since the mangledname is now build only
|
|
on demand from tprocdef.mangledname
|
|
|
|
Revision 1.14 2002/04/15 18:59:07 carl
|
|
+ target_info.size_of_pointer -> pointer_Size
|
|
|
|
Revision 1.13 2002/02/11 18:51:35 peter
|
|
* fixed vmt generation for private procedures that were skipped after
|
|
my previous changes
|
|
|
|
}
|