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

* moved rtti to ncgrtti

Browse Source 
git-svn-id: trunk@5219 -
This commit is contained in:
peter 2006-11-04 10:43:27 +00:00
parent 4cbb67aa00
commit 3cae449fda
22 changed files with 1112 additions and 1242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -253,6 +253,7 @@ compiler/ncgld.pas svneol=native#text/plain
compiler/ncgmat.pas svneol=native#text/plain
compiler/ncgmem.pas svneol=native#text/plain
compiler/ncgopt.pas svneol=native#text/plain
compiler/ncgrtti.pas svneol=native#text/plain
compiler/ncgset.pas svneol=native#text/plain
compiler/ncgutil.pas svneol=native#text/plain
compiler/ncnv.pas svneol=native#text/plain

13
compiler/cgobj.pas
View File

@ -552,7 +552,8 @@ implementation
uses
globals,options,systems,
verbose,defutil,paramgr,symsym,
tgobj,cutils,procinfo;
tgobj,cutils,procinfo,
ncgrtti;
{*****************************************************************************
@ -2523,7 +2524,7 @@ implementation
end
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0);
paramanager.allocparaloc(list,cgpara2);
a_paramaddr_ref(list,href,cgpara2);
paramanager.allocparaloc(list,cgpara1);
@ -2570,7 +2571,7 @@ implementation
begin
if needrtti then
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0);
tempreg2:=getaddressregister(list);
a_loadaddr_ref_reg(list,href,tempreg2);
end;
@ -2591,7 +2592,7 @@ implementation
end
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0);
paramanager.allocparaloc(list,cgpara2);
a_paramaddr_ref(list,href,cgpara2);
paramanager.allocparaloc(list,cgpara1);
@ -2623,7 +2624,7 @@ implementation
a_load_const_ref(list,OS_ADDR,0,ref)
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0);
paramanager.allocparaloc(list,cgpara2);
a_paramaddr_ref(list,href,cgpara2);
paramanager.allocparaloc(list,cgpara1);
@ -2657,7 +2658,7 @@ implementation
end
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0);
paramanager.allocparaloc(list,cgpara2);
a_paramaddr_ref(list,href,cgpara2);
paramanager.allocparaloc(list,cgpara1);

3
compiler/dbgdwarf.pas
View File

@ -1895,9 +1895,6 @@ implementation
enumsym :
{ ignore enum syms, they are written by the owner }
;
rttisym :
{ ignore rtti syms, they are only of internal use }
;
syssym :
{ ignore sys syms, they are only of internal use }
;

4
compiler/ncginl.pas
View File

@ -62,7 +62,7 @@ implementation
aasmbase,aasmtai,aasmdata,aasmcpu,parabase,
cgbase,pass_1,pass_2,
cpuinfo,cpubase,paramgr,procinfo,
nbas,ncon,ncal,ncnv,nld,
nbas,ncon,ncal,ncnv,nld,ncgrtti,
tgobj,ncgutil,
cgutils,cgobj
{$ifndef cpu64bit}
@ -479,7 +479,7 @@ implementation
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
reference_reset_symbol(href,tstoreddef(left.resultdef).get_rtti_label(fullrtti),0);
reference_reset_symbol(href,RTTIWriter.get_rtti_label(left.resultdef,fullrtti),0);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,location.register);
end;

4
compiler/ncgld.pas
View File

@ -55,7 +55,7 @@ implementation
systems,
verbose,globtype,globals,
symconst,symtype,symdef,symsym,defutil,paramgr,
ncnv,ncon,nmem,nbas,
ncnv,ncon,nmem,nbas,ncgrtti,
aasmbase,aasmtai,aasmdata,aasmcpu,
cgbase,pass_2,
procinfo,
@ -979,7 +979,7 @@ implementation
procedure tcgrttinode.pass_generate_code;
begin
location_reset(location,LOC_CREFERENCE,OS_NO);
location.reference.symbol:=rttidef.get_rtti_label(rttitype);
location.reference.symbol:=RTTIWriter.get_rtti_label(rttidef,rttitype);
end;

880
compiler/ncgrtti.pas Normal file
View File

@ -0,0 +1,880 @@
{
Copyright (c) 1998-2002 by Florian Klaempfl
Routines for the code generation of RTTI data structures
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 ncgrtti;
{$i fpcdefs.inc}
interface
uses
cclasses,
aasmbase,
symbase,symconst,symtype,symdef;
type
{ TRTTIWriter }
TRTTIWriter=class
private
function fields_count(st:tsymtable;rt:trttitype):longint;
procedure fields_write_rtti(st:tsymtable;rt:trttitype);
procedure fields_write_rtti_data(st:tsymtable;rt:trttitype);
procedure published_write_rtti(st:tsymtable;rt:trttitype);
function published_properties_count(st:tsymtable):longint;
procedure published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
procedure write_rtti_name(def:tdef);
procedure write_rtti_data(def:tdef;rt:trttitype);
procedure write_child_rtti_data(def:tdef;rt:trttitype);
function ref_rtti(def:tdef;rt:trttitype):tasmsymbol;
public
procedure write_rtti(def:tdef;rt:trttitype);
function get_rtti_label(def:tdef;rt:trttitype):tasmsymbol;
end;
var
RTTIWriter : TRTTIWriter;
implementation
uses
cutils,
globals,globtype,verbose,
fmodule,
symsym,
aasmtai,aasmdata
;
const
rttidefopt : array[trttitype] of tdefoption = (df_has_rttitable,df_has_inittable);
type
TPropNameListItem = class(TFPHashObject)
propindex : longint;
propowner : TSymtable;
end;
{***************************************************************************
TRTTIWriter
***************************************************************************}
procedure TRTTIWriter.write_rtti_name(def:tdef);
var
hs : string;
begin
{ name }
if assigned(def.typesym) then
begin
hs:=ttypesym(def.typesym).realname;
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(chr(length(hs))+hs));
end
else
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(#0));
end;
function TRTTIWriter.fields_count(st:tsymtable;rt:trttitype):longint;
var
i : longint;
sym : tsym;
begin
result:=0;
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (rt=fullrtti) or
(
(tsym(sym).typ=fieldvarsym) and
tfieldvarsym(sym).vardef.needs_inittable
) then
inc(result);
end;
end;
procedure TRTTIWriter.fields_write_rtti_data(st:tsymtable;rt:trttitype);
var
i : longint;
sym : tsym;
begin
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (rt=fullrtti) or
(
(tsym(sym).typ=fieldvarsym) and
tfieldvarsym(sym).vardef.needs_inittable
) then
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(tfieldvarsym(sym).vardef,rt)));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tfieldvarsym(sym).fieldoffset));
end;
end;
end;
procedure TRTTIWriter.fields_write_rtti(st:tsymtable;rt:trttitype);
var
i : longint;
sym : tsym;
begin
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (rt=fullrtti) or
(
(tsym(sym).typ=fieldvarsym) and
tfieldvarsym(sym).vardef.needs_inittable
) then
write_rtti(tfieldvarsym(sym).vardef,rt);
end;
end;
procedure TRTTIWriter.published_write_rtti(st:tsymtable;rt:trttitype);
var
i : longint;
sym : tsym;
begin
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (sp_published in tsym(sym).symoptions) then
begin
case tsym(sym).typ of
propertysym:
write_rtti(tpropertysym(sym).propdef,rt);
fieldvarsym:
write_rtti(tfieldvarsym(sym).vardef,rt);
end;
end;
end;
end;
function TRTTIWriter.published_properties_count(st:tsymtable):longint;
var
i : longint;
sym : tsym;
begin
result:=0;
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (tsym(sym).typ=propertysym) and
(sp_published in tsym(sym).symoptions) then
inc(result);
end;
end;
procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
var
i : longint;
sym : tsym;
pn : tpropnamelistitem;
begin
if assigned(objdef.childof) then
collect_propnamelist(propnamelist,objdef.childof);
for i:=0 to objdef.symtable.SymList.Count-1 do
begin
sym:=tsym(objdef.symtable.SymList[i]);
if (tsym(sym).typ=propertysym) and
(sp_published in tsym(sym).symoptions) then
begin
pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name));
if not assigned(pn) then
begin
pn:=tpropnamelistitem.create(propnamelist,tsym(sym).name);
pn.propindex:=propnamelist.count-1;
pn.propowner:=tsym(sym).owner;
end;
end;
end;
end;
procedure TRTTIWriter.published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
var
i : longint;
sym : tsym;
proctypesinfo : byte;
propnameitem : tpropnamelistitem;
procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
var
typvalue : byte;
hp : ppropaccesslistitem;
address : longint;
def : tdef;
hpropsym : tpropertysym;
propaccesslist : tpropaccesslist;
begin
hpropsym:=tpropertysym(sym);
repeat
propaccesslist:=hpropsym.propaccesslist[pap];
if not propaccesslist.empty then
break;
hpropsym:=hpropsym.overridenpropsym;
until not assigned(hpropsym);
if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,unsetvalue));
typvalue:=3;
end
else if propaccesslist.firstsym^.sym.typ=fieldvarsym then
begin
address:=0;
hp:=propaccesslist.firstsym;
def:=nil;
while assigned(hp) do
begin
case hp^.sltype of
sl_load :
begin
def:=tfieldvarsym(hp^.sym).vardef;
inc(address,tfieldvarsym(hp^.sym).fieldoffset);
end;
sl_subscript :
begin
if not(assigned(def) and (def.typ=recorddef)) then
internalerror(200402171);
inc(address,tfieldvarsym(hp^.sym).fieldoffset);
def:=tfieldvarsym(hp^.sym).vardef;
end;
sl_vec :
begin
if not(assigned(def) and (def.typ=arraydef)) then
internalerror(200402172);
def:=tarraydef(def).elementdef;
inc(address,def.size*hp^.value);
end;
end;
hp:=hp^.next;
end;
current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,address));
typvalue:=0;
end
else
begin
{ When there was an error then procdef is not assigned }
if not assigned(propaccesslist.procdef) then
exit;
if not(po_virtualmethod in tprocdef(propaccesslist.procdef).procoptions) then
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(tprocdef(propaccesslist.procdef).mangledname,0));
typvalue:=1;
end
else
begin
{ virtual method, write vmt offset }
current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,
tprocdef(propaccesslist.procdef)._class.vmtmethodoffset(tprocdef(propaccesslist.procdef).extnumber)));
typvalue:=2;
end;
end;
proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
end;
begin
for i:=0 to st.SymList.Count-1 do
begin
sym:=tsym(st.SymList[i]);
if (sym.typ=propertysym) and
(sp_published in sym.symoptions) then
begin
if ppo_indexed in tpropertysym(sym).propoptions then
proctypesinfo:=$40
else
proctypesinfo:=0;
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(tpropertysym(sym).propdef,fullrtti)));
writeaccessproc(palt_read,0,0);
writeaccessproc(palt_write,2,0);
{ is it stored ? }
if not(ppo_stored in tpropertysym(sym).propoptions) then
begin
{ no, so put a constant zero }
current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,0));
proctypesinfo:=proctypesinfo or (3 shl 4);
end
else
writeaccessproc(palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).index));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).default));
propnameitem:=TPropNameListItem(propnamelist.Find(tpropertysym(sym).name));
if not assigned(propnameitem) then
internalerror(200512201);
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.propindex));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tpropertysym(sym).realname));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
end;
end;
end;
procedure TRTTIWriter.write_rtti_data(def:tdef;rt:trttitype);
procedure unknown_rtti(def:tstoreddef);
begin
current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
write_rtti_name(def);
end;
procedure variantdef_rtti(def:tvariantdef);
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkVariant));
end;
procedure stringdef_rtti(def:tstringdef);
begin
case def.stringtype of
st_ansistring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkAString));
write_rtti_name(def);
end;
st_widestring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWString));
write_rtti_name(def);
end;
st_longstring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkLString));
write_rtti_name(def);
end;
st_shortstring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSString));
write_rtti_name(def);
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.len));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
end;
end;
end;
procedure enumdef_rtti(def:tenumdef);
var
hp : tenumsym;
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkEnumeration));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
case longint(def.size) of
1 :
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otUByte));
2 :
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otUWord));
4 :
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otULong));
end;
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.min));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.max));
if assigned(def.basedef) then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.basedef,rt)))
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
hp:=tenumsym(def.firstenum);
while assigned(hp) do
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(hp.realname)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(hp.realname));
hp:=hp.nextenum;
end;
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
end;
procedure orddef_rtti(def:torddef);
procedure dointeger;
const
trans : array[tordtype] of byte =
(otUByte{otNone},
otUByte,otUWord,otULong,otUByte{otNone},
otSByte,otSWord,otSLong,otUByte{otNone},
otUByte,otUWord,otULong,otUByte,
otUByte,otUWord,otUByte);
begin
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(byte(trans[def.ordtype])));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(def.low)));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(def.high)));
end;
begin
case def.ordtype of
s64bit :
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkInt64));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ low }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(int64($80000000) shl 32));
{ high }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit((int64($7fffffff) shl 32) or int64($ffffffff)));
end;
u64bit :
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkQWord));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ low }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(0));
{ high }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_64bit(int64((int64($ffffffff) shl 32) or int64($ffffffff))));
end;
bool8bit:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkBool));
dointeger;
end;
uchar:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkChar));
dointeger;
end;
uwidechar:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWChar));
dointeger;
end;
else
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkInteger));
dointeger;
end;
end;
end;
procedure floatdef_rtti(def:tfloatdef);
const
{tfloattype = (s32real,s64real,s80real,s64bit,s128bit);}
translate : array[tfloattype] of byte =
(ftSingle,ftDouble,ftExtended,ftComp,ftCurr,ftFloat128);
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkFloat));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(translate[def.floattype]));
end;
procedure setdef_rtti(def:tsetdef);
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSet));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otULong));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.elementdef,rt)));
end;
procedure arraydef_rtti(def:tarraydef);
begin
if ado_IsDynamicArray in def.arrayoptions then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkdynarray))
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkarray));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ size of elements }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(def.elesize));
if not(ado_IsDynamicArray in def.arrayoptions) then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(def.elecount));
{ element type }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.elementdef,rt)));
{ variant type }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tstoreddef(def.elementdef).getvardef));
end;
procedure recorddef_rtti(def:trecorddef);
var
fieldcnt : longint;
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkrecord));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.size));
fieldcnt:=fields_count(def.symtable,rt);
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(fieldcnt));
fields_write_rtti_data(def.symtable,rt);
end;
procedure procvar_rtti(def:tprocvardef);
procedure write_para(parasym:tparavarsym);
var
paraspec : byte;
begin
{ only store user visible parameters }
if not(vo_is_hidden_para in parasym.varoptions) then
begin
case parasym.varspez of
vs_value: paraspec := 0;
vs_const: paraspec := pfConst;
vs_var : paraspec := pfVar;
vs_out : paraspec := pfOut;
end;
{ write flags for current parameter }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec));
{ write name of current parameter }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(parasym.realname)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(parasym.realname));
{ write name of type of current parameter }
write_rtti_name(parasym.vardef);
end;
end;
var
methodkind : byte;
i : integer;
begin
if po_methodpointer in def.procoptions then
begin
{ write method id and name }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkmethod));
write_rtti_name(def);
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ write kind of method (can only be function or procedure)}
if def.returndef = voidtype then
methodkind := mkProcedure
else
methodkind := mkFunction;
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(methodkind));
{ write parameter info. The parameters must be written in reverse order
if this method uses right to left parameter pushing! }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.maxparacount));
if def.proccalloption in pushleftright_pocalls then
begin
for i:=0 to def.paras.count-1 do
write_para(tparavarsym(def.paras[i]));
end
else
begin
for i:=def.paras.count-1 downto 0 do
write_para(tparavarsym(def.paras[i]));
end;
{ write name of result type }
write_rtti_name(def.returndef);
end
else
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkprocvar));
write_rtti_name(def);
end;
end;
procedure objectdef_rtti(def:tobjectdef);
procedure objectdef_rtti_class_init(def:tobjectdef);
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.size));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(fields_count(def.symtable,rt)));
fields_write_rtti_data(def.symtable,rt);
end;
procedure objectdef_rtti_interface_init(def:tobjectdef);
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.size));
end;
procedure objectdef_rtti_class_full(def:tobjectdef);
var
propnamelist : TFPHashObjectList;
begin
{ Collect unique property names with nameindex }
propnamelist:=TFPHashObjectList.Create;
collect_propnamelist(propnamelist,def);
if (oo_has_vmt in def.objectoptions) then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(def.vmt_mangledname,0))
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
{ write parent typeinfo }
if assigned(def.childof) and
(oo_can_have_published in def.childof.objectoptions) then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.childof,fullrtti)))
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
{ total number of unique properties }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
{ write unit name }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(current_module.realmodulename^));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ write published properties for this object }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
published_properties_write_rtti_data(propnamelist,def.symtable);
propnamelist.free;
end;
procedure objectdef_rtti_interface_full(def:tobjectdef);
var
i : longint;
propnamelist : TFPHashObjectList;
begin
{ Collect unique property names with nameindex }
propnamelist:=TFPHashObjectList.Create;
collect_propnamelist(propnamelist,def);
{ write parent typeinfo }
if assigned(def.childof) then
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.childof,fullrtti)))
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
{ interface: write flags, iid and iidstr }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(
{ ugly, but working }
longint([
TCompilerIntfFlag(ord(ifHasGuid)*ord(assigned(def.iidguid))),
TCompilerIntfFlag(ord(ifHasStrGUID)*ord(assigned(def.iidstr)))
])
{
ifDispInterface,
ifDispatch, }
));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(def.iidguid^.D1)));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(def.iidguid^.D2));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(def.iidguid^.D3));
for i:=Low(def.iidguid^.D4) to High(def.iidguid^.D4) do
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.iidguid^.D4[i]));
{ write unit name }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(current_module.realmodulename^));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ write iidstr }
if assigned(def.iidstr) then
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(def.iidstr^)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(def.iidstr^));
end
else
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
{ write published properties for this object }
published_properties_write_rtti_data(propnamelist,def.symtable);
propnamelist.free;
end;
begin
case def.objecttype of
odt_class:
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkclass));
odt_object:
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkobject));
odt_interfacecom:
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkinterface));
odt_interfacecorba:
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkinterfaceCorba));
else
internalerror(200611034);
end;
{ generate the name }
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(def.objrealname^)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(def.objrealname^));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
case rt of
initrtti :
begin
if def.objecttype in [odt_class,odt_object] then
objectdef_rtti_class_init(def)
else
objectdef_rtti_interface_init(def);
end;
fullrtti :
begin
if def.objecttype in [odt_class,odt_object] then
objectdef_rtti_class_full(def)
else
objectdef_rtti_interface_full(def);
end;
end;
end;
begin
case def.typ of
variantdef :
variantdef_rtti(tvariantdef(def));
stringdef :
stringdef_rtti(tstringdef(def));
enumdef :
enumdef_rtti(tenumdef(def));
orddef :
orddef_rtti(torddef(def));
floatdef :
floatdef_rtti(tfloatdef(def));
setdef :
setdef_rtti(tsetdef(def));
arraydef :
begin
if ado_IsBitPacked in tarraydef(def).arrayoptions then
unknown_rtti(tstoreddef(def))
else
arraydef_rtti(tarraydef(def));
end;
recorddef :
begin
if trecorddef(def).is_packed then
unknown_rtti(tstoreddef(def))
else
recorddef_rtti(trecorddef(def));
end;
objectdef :
objectdef_rtti(tobjectdef(def));
else
unknown_rtti(tstoreddef(def));
end;
end;
procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
begin
case def.typ of
enumdef :
if assigned(tenumdef(def).basedef) then
write_rtti(tenumdef(def).basedef,rt);
setdef :
write_rtti(tsetdef(def).elementdef,rt);
arraydef :
write_rtti(tarraydef(def).elementdef,rt);
recorddef :
fields_write_rtti(trecorddef(def).symtable,rt);
objectdef :
if rt=initrtti then
fields_write_rtti(tobjectdef(def).symtable,rt)
else
published_write_rtti(tobjectdef(def).symtable,rt);
end;
end;
function TRTTIWriter.ref_rtti(def:tdef;rt:trttitype):tasmsymbol;
begin
if not(rttidefopt[rt] in def.defoptions) then
internalerror(200611037);
result:=current_asmdata.RefAsmSymbol(def.rtti_mangledname(rt));
end;
procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype);
var
rttilab : tasmsymbol;
begin
if rttidefopt[rt] in def.defoptions then
exit;
{ only write the rttis of defs defined in the current unit,
otherwise we will generate duplicate asmsymbols }
if not findunitsymtable(def.owner).iscurrentunit then
internalerror(200611035);
{ prevent recursion }
include(def.defoptions,rttidefopt[rt]);
{ write first all dependencies }
write_child_rtti_data(def,rt);
{ write rtti data }
rttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(rt),AB_GLOBAL,AT_DATA);
maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
new_section(current_asmdata.asmlists[al_rtti],sec_rodata,rttilab.name,const_align(sizeof(aint)));
current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(rttilab,0));
write_rtti_data(def,rt);
current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(rttilab));
end;
function TRTTIWriter.get_rtti_label(def:tdef;rt:trttitype):tasmsymbol;
begin
if not(rttidefopt[rt] in def.defoptions) then
write_rtti(def,rt);
result:=ref_rtti(def,rt);
end;
end.

79
compiler/ncgutil.pas
View File

@ -143,10 +143,6 @@ interface
procedure gen_alloc_symtable(list:TAsmList;st:TSymtable);
procedure gen_free_symtable(list:TAsmList;st:TSymtable);
{ rtti and init/final }
procedure generate_rtti(p:Ttypesym);
procedure generate_inittable(p:tsym);
procedure location_free(list: TAsmList; const location : TLocation);
function getprocalign : shortint;
@ -2660,81 +2656,6 @@ implementation
end;
{ persistent rtti generation }
procedure generate_rtti(p:Ttypesym);
var
rsym : trttisym;
def : tstoreddef;
begin
{ rtti can only be generated for classes that are always typesyms }
def:=tstoreddef(ttypesym(p).typedef);
{ there is an error, skip rtti info }
if (def.typ=errordef) or (Errorcount>0) then
exit;
{ only create rtti once for each definition }
if not(df_has_rttitable in def.defoptions) then
begin
{ definition should be in the same symtable as the symbol }
if p.owner<>def.owner then
internalerror(200108262);
{ create rttisym }
rsym:=trttisym.create(p.name,fullrtti);
p.owner.insert(rsym);
{ register rttisym in definition }
include(def.defoptions,df_has_rttitable);
def.rttitablesym:=rsym;
{ write rtti data }
def.write_child_rtti_data(fullrtti);
maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
new_section(current_asmdata.asmlists[al_rtti],sec_rodata,rsym.get_label.name,const_align(sizeof(aint)));
current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(rsym.get_label,0));
def.write_rtti_data(fullrtti);
current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(rsym.get_label));
end;
end;
{ persistent init table generation }
procedure generate_inittable(p:tsym);
var
rsym : trttisym;
def : tstoreddef;
begin
{ anonymous types are also allowed for records that can be varsym }
case p.typ of
typesym :
def:=tstoreddef(ttypesym(p).typedef);
globalvarsym,
localvarsym,
paravarsym :
def:=tstoreddef(tabstractvarsym(p).vardef);
else
internalerror(200108263);
end;
{ only create inittable once for each definition }
if not(df_has_inittable in def.defoptions) then
begin
{ definition should be in the same symtable as the symbol }
if p.owner<>def.owner then
internalerror(200108264);
{ create rttisym }
rsym:=trttisym.create(p.name,initrtti);
p.owner.insert(rsym);
{ register rttisym in definition }
include(def.defoptions,df_has_inittable);
def.inittablesym:=rsym;
{ write inittable data }
def.write_child_rtti_data(initrtti);
maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
new_section(current_asmdata.asmlists[al_rtti],sec_rodata,rsym.get_label.name,const_align(sizeof(aint)));
current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(rsym.get_label,0));
def.write_rtti_data(initrtti);
current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(rsym.get_label));
end;
end;
procedure gen_intf_wrapper(list:TAsmList;_class:tobjectdef);
var
i,j : longint;

84
compiler/nobj.pas
View File

@ -110,6 +110,7 @@ interface
function genstrmsgtab : tasmlabel;
function genintmsgtab : tasmlabel;
function genpublishedmethodstable : tasmlabel;
function generate_field_table : tasmlabel;
{ generates a VMT entries }
procedure genvmt;
{$ifdef WITHDMT}
@ -130,7 +131,8 @@ implementation
SysUtils,
globals,verbose,systems,
symtable,symconst,symtype,defcmp,
dbgbase
dbgbase,
ncgrtti
;
@ -512,6 +514,80 @@ implementation
end;
function tclassheader.generate_field_table : tasmlabel;
var
i : longint;
sym : tsym;
fieldtable,
classtable : tasmlabel;
classindex,
fieldcount : longint;
classtablelist : TFPList;
begin
classtablelist:=TFPList.Create;
current_asmdata.getdatalabel(fieldtable);
current_asmdata.getdatalabel(classtable);
maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
new_section(current_asmdata.asmlists[al_rtti],sec_rodata,classtable.name,const_align(sizeof(aint)));
{ retrieve field info fields }
fieldcount:=0;
for i:=0 to _class.symtable.SymList.Count-1 do
begin
sym:=tsym(_class.symtable.SymList[i]);
if (tsym(sym).typ=fieldvarsym) and
(sp_published in tsym(sym).symoptions) then
begin
if tfieldvarsym(sym).vardef.typ<>objectdef then
internalerror(200611032);
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
if classindex=-1 then
classtablelist.Add(tfieldvarsym(sym).vardef);
inc(fieldcount);
end;
end;
{ write fields }
current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(fieldtable));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(fieldcount));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(classtable));
for i:=0 to _class.symtable.SymList.Count-1 do
begin
sym:=tsym(_class.symtable.SymList[i]);
if (tsym(sym).typ=fieldvarsym) and
(sp_published in tsym(sym).symoptions) then
begin
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(AInt)));
{$endif cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset));
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
if classindex=-1 then
internalerror(200611033);
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classindex+1));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname)));
current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tfieldvarsym(sym).realname));
end;
end;
{ generate the class table }
current_asmdata.asmlists[al_rtti].concat(cai_align.create(const_align(sizeof(aint))));
current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(classtable));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classtablelist.count));
{$ifdef cpurequiresproperalignment}
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment}
for i:=0 to classtablelist.Count-1 do
current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tobjectdef(classtablelist[i]).vmt_mangledname,0));
classtablelist.free;
result:=fieldtable;
end;
{**************************************
VMT
**************************************}
@ -1292,7 +1368,7 @@ implementation
interfacetable:=genintftable;
methodnametable:=genpublishedmethodstable;
fieldtablelabel:=_class.generate_field_table;
fieldtablelabel:=generate_field_table;
{ write class name }
current_asmdata.asmlists[al_globals].concat(Tai_label.Create(classnamelabel));
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.objrealname^)));
@ -1349,12 +1425,12 @@ implementation
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(fieldtablelabel));
{ pointer to type info of published section }
if (oo_can_have_published in _class.objectoptions) then
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(_class.get_rtti_label(fullrtti)))
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,fullrtti)))
else
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
{ inittable for con-/destruction }
if _class.members_need_inittable then
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(_class.get_rtti_label(initrtti)))
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,initrtti)))
else
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil));
{ auto table }

7
compiler/parser.pas
View File

@ -49,7 +49,7 @@ implementation
script,gendef,
comphook,
scanner,scandir,
pbase,ptype,psystem,pmodules,psub,
pbase,ptype,psystem,pmodules,psub,ncgrtti,
cresstr,cpuinfo,procinfo;
@ -97,6 +97,9 @@ implementation
if stacksize=0 then
stacksize:=target_info.stacksize;
{ RTTI writer }
RTTIWriter:=TRTTIWriter.Create;
{ open assembler response }
if cs_link_on_target in current_settings.globalswitches then
GenerateAsmRes(outputexedir+ChangeFileExt(inputfilename,'_ppas'))
@ -158,6 +161,8 @@ implementation
{ close scanner }
DoneScanner;
RTTIWriter.free;
{ close ppas,deffile }
asmres.free;
deffile.free;

54
compiler/pdecl.pas
View File

@ -59,7 +59,7 @@ implementation
{ pass 1 }
nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,
{ codegen }
ncgutil,
ncgutil,ncgrtti,
{ parser }
scanner,
pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,
@ -562,40 +562,42 @@ implementation
{ generate persistent init/final tables when it's declared in the interface so it can
be reused in other used }
if current_module.in_interface and
((is_class(hdef) and
tobjectdef(hdef).members_need_inittable) or
hdef.needs_inittable) then
generate_inittable(newtype);
if current_module.in_interface {or
(
(is_class(hdef) and
tobjectdef(hdef).members_need_inittable) or
hdef.needs_inittable
) }
then
RTTIWriter.write_rtti(hdef,initrtti);
{ for objects we should write the vmt and interfaces.
This need to be done after the rtti has been written, because
it can contain a reference to that data (PFV)
This is not for forward classes }
if (hdef.typ=objectdef) and
(hdef.owner.symtabletype in [staticsymtable,globalsymtable]) then
with Tobjectdef(hdef) do
begin
if not(oo_is_forward in objectoptions) then
begin
ch:=tclassheader.create(tobjectdef(hdef));
{ generate and check virtual methods, must be done
before RTTI is written }
ch.genvmt;
{ Generate RTTI for class }
generate_rtti(newtype);
if is_interface(tobjectdef(hdef)) then
ch.writeinterfaceids;
if (oo_has_vmt in objectoptions) then
ch.writevmt;
ch.free;
end;
end
if (hdef.typ=objectdef) then
begin
if not(oo_is_forward in tobjectdef(hdef).objectoptions) then
begin
ch:=tclassheader.create(tobjectdef(hdef));
{ generate and check virtual methods, must be done
before RTTI is written }
ch.genvmt;
{ Generate RTTI for class }
RTTIWriter.write_rtti(hdef,fullrtti);
if is_interface(tobjectdef(hdef)) then
ch.writeinterfaceids;
if (oo_has_vmt in tobjectdef(hdef).objectoptions) then
ch.writevmt;
ch.free;
end;
end
else
begin
{ Always generate RTTI info for all types. This is to have typeinfo() return
the same pointer }
generate_rtti(newtype);
if current_module.in_interface then
RTTIWriter.write_rtti(hdef,fullrtti);
end;
current_filepos:=oldfilepos;

7
compiler/powerpc/cpupi.pas
View File

@ -58,7 +58,7 @@ unit cpupi;
cpubase,
aasmtai,aasmdata,
tgobj,cgobj,
symconst,symsym,paramgr,symutil,
symconst,symsym,paramgr,symutil,symtable,
verbose;
constructor tppcprocinfo.create(aparent:tprocinfo);
@ -74,7 +74,6 @@ unit cpupi;
procedure tppcprocinfo.set_first_temp_offset;
var
ofs : aword;
locals: longint;
begin
if not(po_assembler in procdef.procoptions) then
begin
@ -90,9 +89,7 @@ unit cpupi;
end
else
begin
locals := 0;
current_procinfo.procdef.localst.SymList.ForEachCall(@count_locals,@locals);
if locals <> 0 then
if tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals <> 0 then
begin
{ at 0(r1), the previous value of r1 will be stored }
tg.setfirsttemp(4);

7
compiler/powerpc64/cpupi.pas
View File

@ -50,7 +50,7 @@ uses
cpubase, cgbase,
aasmtai,aasmdata,
tgobj,
symconst, symsym, paramgr, symutil,
symconst, symsym, paramgr, symutil, symtable,
verbose;
constructor tppcprocinfo.create(aparent: tprocinfo);
@ -64,7 +64,6 @@ end;
procedure tppcprocinfo.set_first_temp_offset;
var
ofs: aword;
locals: longint;
begin
if not (po_assembler in procdef.procoptions) then begin
{ align the stack properly }
@ -78,9 +77,7 @@ begin
end;
tg.setfirsttemp(ofs);
end else begin
locals := 0;
current_procinfo.procdef.localst.SymList.ForEachCall(@count_locals, @locals);
if locals <> 0 then
if tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals <> 0 then
{ at 0(r1), the previous value of r1 will be stored }
tg.setfirsttemp(8);
end;

4
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion=68;
CurrentPPUVersion=69;
{ buffer sizes }
maxentrysize = 1024;
@ -97,7 +97,7 @@ const
ibunitsym = 29;
iblabelsym = 30;
ibsyssym = 31;
ibrttisym = 32;
// ibrttisym = 32;
iblocalvarsym = 33;
ibparavarsym = 34;
ibmacrosym = 35;

5
compiler/pstatmnt.pas
View File

@ -1168,9 +1168,8 @@ implementation
- target processor has optional frame pointer save
(vm, i386, vm only currently)
}
locals:=0;
current_procinfo.procdef.localst.SymList.ForEachCall(@count_locals,@locals);
current_procinfo.procdef.parast.SymList.ForEachCall(@count_locals,@locals);
locals:=tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals+
tabstractlocalsymtable(current_procinfo.procdef.parast).count_locals;
if (locals=0) and
(current_procinfo.procdef.owner.symtabletype<>ObjectSymtable) and
(not assigned(current_procinfo.procdef.funcretsym) or

25
compiler/psystem.pas
View File

@ -43,7 +43,8 @@ implementation
globals,globtype,verbose,
systems,
symconst,symtype,symsym,symdef,symtable,
aasmtai,aasmdata,aasmcpu,ncgutil,fmodule,
aasmtai,aasmdata,aasmcpu,
ncgutil,ncgrtti,fmodule,
node,nbas,nflw,nset,ncon,ncnv,nld,nmem,ncal,nmat,nadd,ninl,nopt
;
@ -111,14 +112,9 @@ implementation
begin
result:=ttypesym.create(s,def);
systemunit.insert(result);
{ add init/final table if required }
if def.needs_inittable then
generate_inittable(result);
end;
procedure adddef(const s:string;def:tdef);
begin
systemunit.insert(ttypesym.create(s,def));
{ write always RTTI to get persistent typeinfo }
RTTIWriter.write_rtti(def,initrtti);
RTTIWriter.write_rtti(def,fullrtti);
end;
var
@ -235,7 +231,7 @@ implementation
end;
{$ifdef x86}
if target_info.system<>system_x86_64_win64 then
adddef('Comp',tfloatdef.create(s64comp));
addtype('Comp',tfloatdef.create(s64comp));
{$endif x86}
addtype('Currency',s64currencytype);
addtype('Pointer',voidpointertype);
@ -264,8 +260,8 @@ implementation
addtype('Int64',s64inttype);
addtype('Char',cchartype);
addtype('WideChar',cwidechartype);
adddef('Text',tfiledef.createtext);
adddef('TypedFile',tfiledef.createtyped(voidtype));
addtype('Text',tfiledef.createtext);
addtype('TypedFile',tfiledef.createtyped(voidtype));
addtype('Variant',cvarianttype);
addtype('OleVariant',colevarianttype);
{ Internal types }
@ -307,6 +303,10 @@ implementation
hrecst:=trecordsymtable.create(current_settings.packrecords);
vmttype:=trecorddef.create(hrecst);
pvmttype:=tpointerdef.create(vmttype);
{ can't use addtype for pvmt because the rtti of the pointed
type is not available. The rtti for pvmt will be written implicitly
by thev tblarray below }
systemunit.insert(ttypesym.create('$pvmt',pvmttype));
hrecst.insertfield(tfieldvarsym.create('$parent',vs_value,pvmttype,[]));
hrecst.insertfield(tfieldvarsym.create('$length',vs_value,s32inttype,[]));
hrecst.insertfield(tfieldvarsym.create('$mlength',vs_value,s32inttype,[]));
@ -314,7 +314,6 @@ implementation
tarraydef(vmtarraytype).elementdef:=voidpointertype;
hrecst.insertfield(tfieldvarsym.create('$__pfn',vs_value,vmtarraytype,[]));
addtype('$__vtbl_ptr_type',vmttype);
addtype('$pvmt',pvmttype);
vmtarraytype:=tarraydef.create(0,1,s32inttype);
tarraydef(vmtarraytype).elementdef:=pvmttype;
addtype('$vtblarray',vmtarraytype);

4
compiler/symconst.pas
View File

@ -386,7 +386,7 @@ type
globalvarsym,localvarsym,paravarsym,fieldvarsym,
typesym,procsym,unitsym,constsym,enumsym,typedconstsym,
errorsym,syssym,labelsym,absolutevarsym,propertysym,
macrosym,rttisym
macrosym
);
{ State of the variable, if it's declared, assigned or used }
@ -442,7 +442,7 @@ const
'abstractsym','globalvar','localvar','paravar','fieldvar',
'type','proc','unit','const','enum','typed const',
'errorsym','system sym','label','absolutevar','property',
'macrosym','rttisym'
'macrosym'
);
typName : array[tdeftyp] of string[12] = (

956
compiler/symdef.pas
View File

File diff suppressed because it is too large Load Diff

82
compiler/symsym.pas
View File

@ -327,21 +327,6 @@ interface
function GetCopy:tmacro;
end;
{ compiler generated symbol to point to rtti and init/finalize tables }
trttisym = class(tstoredsym)
private
_mangledname : pshortstring;
public
lab : tasmsymbol;
rttityp : trttitype;
constructor create(const n:string;rt:trttitype);
constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
function mangledname:string;override;
function get_label:tasmsymbol;
end;
var
generrorsym : tsym;
@ -2024,71 +2009,4 @@ implementation
Result:=p;
end;
{****************************************************************************
TRTTISYM
****************************************************************************}
constructor trttisym.create(const n:string;rt:trttitype);
const
prefix : array[trttitype] of string[5]=('$rtti','$init');
begin
inherited create(rttisym,prefix[rt]+n);
include(symoptions,sp_internal);
lab:=nil;
rttityp:=rt;
end;
destructor trttisym.destroy;
begin
if assigned(_mangledname) then
begin
{$ifdef MEMDEBUG}
memmanglednames.start;
{$endif MEMDEBUG}
stringdispose(_mangledname);
{$ifdef MEMDEBUG}
memmanglednames.stop;
{$endif MEMDEBUG}
end;
inherited destroy;
end;
constructor trttisym.ppuload(ppufile:tcompilerppufile);
begin
inherited ppuload(rttisym,ppufile);
lab:=nil;
rttityp:=trttitype(ppufile.getbyte);
end;
procedure trttisym.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putbyte(byte(rttityp));
ppufile.writeentry(ibrttisym);
end;
function trttisym.mangledname : string;
const
prefix : array[trttitype] of string[5]=('RTTI_','INIT_');
begin
if not assigned(_mangledname) then
_mangledname:=stringdup(make_mangledname(prefix[rttityp],owner,Copy(name,5,255)));
result:=_mangledname^;
end;
function trttisym.get_label:tasmsymbol;
begin
{ the label is always a global label }
if not assigned(lab) then
lab:=current_asmdata.RefAsmSymbol(mangledname);
get_label:=lab;
end;
end.

51
compiler/symtable.pas
View File

@ -113,9 +113,12 @@ interface
function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
end;
{ tabstractlocalsymtable }
tabstractlocalsymtable = class(tstoredsymtable)
public
procedure ppuwrite(ppufile:tcompilerppufile);override;
function count_locals:longint;
end;
tlocalsymtable = class(tabstractlocalsymtable)
@ -180,7 +183,6 @@ interface
****************************************************************************}
{*** Misc ***}
function finduniTSymtable(st:TSymtable):TSymtable;
function FullTypeName(def,otherdef:tdef):string;
procedure incompatibletypes(def1,def2:tdef);
procedure hidesym(sym:TSymEntry);
@ -363,7 +365,6 @@ implementation
ibunitsym : sym:=tunitsym.ppuload(ppufile);
iblabelsym : sym:=tlabelsym.ppuload(ppufile);
ibsyssym : sym:=tsyssym.ppuload(ppufile);
ibrttisym : sym:=trttisym.ppuload(ppufile);
ibmacrosym : sym:=tmacro.ppuload(ppufile);
ibendsyms : break;
ibend : Message(unit_f_ppu_read_error);
@ -1085,6 +1086,25 @@ implementation
end;
function tabstractlocalsymtable.count_locals:longint;
var
i : longint;
sym : tsym;
begin
result:=0;
for i:=0 to SymList.Count-1 do
begin
sym:=tsym(SymList[i]);
{ Count only varsyms, but ignore the funcretsym }
if (tsym(sym).typ in [localvarsym,paravarsym]) and
(tsym(sym)<>current_procinfo.procdef.funcretsym) and
(not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or
(tstoredsym(sym).refs>0)) then
inc(result);
end;
end;
{****************************************************************************
TLocalSymtable
****************************************************************************}
@ -1375,33 +1395,6 @@ implementation
Helper Routines
*****************************************************************************}
function finduniTSymtable(st:TSymtable):TSymtable;
begin
result:=nil;
repeat
if not assigned(st) then
internalerror(200602034);
case st.symtabletype of
localmacrosymtable,
exportedmacrosymtable,
staticsymtable,
globalsymtable :
begin
result:=st;
exit;
end;
recordsymtable,
localsymtable,
parasymtable,
ObjectSymtable :
st:=st.defowner.owner;
else
internalerror(200602035);
end;
until false;
end;
function FullTypeName(def,otherdef:tdef):string;
var
s1,s2 : string;

40
compiler/symtype.pas
View File

@ -71,6 +71,7 @@ interface
function GetTypeName:string;virtual;
function mangledparaname:string;
function getmangledparaname:string;virtual;
function rtti_mangledname(rt:trttitype):string;virtual;abstract;
function size:aint;virtual;abstract;
function packedbitsize:aint;virtual;
function alignment:shortint;virtual;abstract;
@ -191,14 +192,46 @@ interface
const
current_object_option : tsymoptions = [sp_public];
function FindUnitSymtable(st:TSymtable):TSymtable;
implementation
uses
verbose,
fmodule,symtable
fmodule
;
{****************************************************************************
Utils
****************************************************************************}
function FindUnitSymtable(st:TSymtable):TSymtable;
begin
result:=nil;
repeat
if not assigned(st) then
internalerror(200602034);
case st.symtabletype of
localmacrosymtable,
exportedmacrosymtable,
staticsymtable,
globalsymtable :
begin
result:=st;
exit;
end;
recordsymtable,
localsymtable,
parasymtable,
ObjectSymtable :
st:=st.defowner.owner;
else
internalerror(200602035);
end;
until false;
end;
{****************************************************************************
Tdef
@ -561,9 +594,9 @@ implementation
begin
{$warning TODO ugly hack}
if s is tsym then
st:=finduniTSymtable(tsym(s).owner)
st:=FindUnitSymtable(tsym(s).owner)
else
st:=finduniTSymtable(tdef(s).owner);
st:=FindUnitSymtable(tdef(s).owner);
if not st.iscurrentunit then
begin
{ register that the unit is needed for resolving }
@ -968,3 +1001,4 @@ finalization
{$endif MEMDEBUG}
end.

28
compiler/symutil.pas
View File

@ -26,20 +26,17 @@ unit symutil;
interface
uses
symbase,symtype,symsym,cclasses;
symbase,symtype,symsym;
function is_funcret_sym(p:TSymEntry):boolean;
{ returns true, if sym needs an entry in the proplist of a class rtti }
function needs_prop_entry(sym : tsym) : boolean;
function equal_constsym(sym1,sym2:tconstsym):boolean;
procedure count_locals(sym:TObject;arg:pointer);
implementation
uses
cclasses,
globtype,cpuinfo,procinfo,
symconst,widestr;
@ -51,14 +48,6 @@ implementation
end;
function needs_prop_entry(sym : tsym) : boolean;
begin
needs_prop_entry:=(sp_published in tsym(sym).symoptions) and
(sym.typ in [propertysym,fieldvarsym]);
end;
function equal_constsym(sym1,sym2:tconstsym):boolean;
var
p1,p2,pend : pchar;
@ -104,16 +93,5 @@ implementation
end;
end;
procedure count_locals(sym:TObject;arg:pointer);
begin
{ Count only varsyms, but ignore the funcretsym }
if (tsym(sym).typ in [localvarsym,paravarsym]) and
(tsym(sym)<>current_procinfo.procdef.funcretsym) and
(not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or
(tstoredsym(sym).refs>0)) then
inc(plongint(arg)^);
end;
end.

16
compiler/utils/ppudump.pp
View File

@ -801,16 +801,6 @@ begin
if df_unique in defoptions then
writeln (space,' Unique type symbol');
if df_has_rttitable in defoptions then
begin
write (space,' RTTI symbol : ');
readderef;
end;
if df_has_inittable in defoptions then
begin
write (space,' Init symbol : ');
readderef;
end;
if df_generic in defoptions then
begin
tokenbufsize:=ppufile.getlongint;
@ -1572,12 +1562,6 @@ begin
writeln(space,' Internal Nr : ',getlongint);
end;
ibrttisym :
begin
readcommonsym('RTTI symbol ');
writeln(space,' RTTI Type : ',getbyte);
end;
ibmacrosym :
begin
readcommonsym('Macro symbol ');