summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpeter <peter@3ad0048d-3df7-0310-abae-a5850022a9f2>2006-11-04 10:43:27 +0000
committerpeter <peter@3ad0048d-3df7-0310-abae-a5850022a9f2>2006-11-04 10:43:27 +0000
commit56e79c634b1868697ea0b585d452f7442beab31f (patch)
tree63ab2d86073ab06dba89348bdfe7324ceb0a6e23
parent8fcebb524c3f785a3fe1ae728320187645cf528b (diff)
downloadfpc-56e79c634b1868697ea0b585d452f7442beab31f.tar.gz
* moved rtti to ncgrtti
git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@5219 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r--compiler/cgobj.pas13
-rw-r--r--compiler/dbgdwarf.pas3
-rw-r--r--compiler/ncginl.pas4
-rw-r--r--compiler/ncgld.pas4
-rw-r--r--compiler/ncgrtti.pas880
-rw-r--r--compiler/ncgutil.pas79
-rw-r--r--compiler/nobj.pas84
-rw-r--r--compiler/parser.pas7
-rw-r--r--compiler/pdecl.pas54
-rw-r--r--compiler/powerpc/cpupi.pas7
-rw-r--r--compiler/powerpc64/cpupi.pas7
-rw-r--r--compiler/ppu.pas4
-rw-r--r--compiler/pstatmnt.pas5
-rw-r--r--compiler/psystem.pas25
-rw-r--r--compiler/symconst.pas4
-rw-r--r--compiler/symdef.pas956
-rw-r--r--compiler/symsym.pas82
-rw-r--r--compiler/symtable.pas51
-rw-r--r--compiler/symtype.pas40
-rw-r--r--compiler/symutil.pas28
-rw-r--r--compiler/utils/ppudump.pp16
21 files changed, 1111 insertions, 1242 deletions
diff --git a/compiler/cgobj.pas b/compiler/cgobj.pas
index 2d5cd4cad6..d7fd2894ba 100644
--- a/compiler/cgobj.pas
+++ b/compiler/cgobj.pas
@@ -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);
diff --git a/compiler/dbgdwarf.pas b/compiler/dbgdwarf.pas
index 4b5a8431da..413b36fcff 100644
--- a/compiler/dbgdwarf.pas
+++ b/compiler/dbgdwarf.pas
@@ -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 }
;
diff --git a/compiler/ncginl.pas b/compiler/ncginl.pas
index 41ba87f39e..3c4f3a8dc2 100644
--- a/compiler/ncginl.pas
+++ b/compiler/ncginl.pas
@@ -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;
diff --git a/compiler/ncgld.pas b/compiler/ncgld.pas
index 97da075635..86213d1ffe 100644
--- a/compiler/ncgld.pas
+++ b/compiler/ncgld.pas
@@ -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;
diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas
new file mode 100644
index 0000000000..24e34a5211
--- /dev/null
+++ b/compiler/ncgrtti.pas
@@ -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.
+
diff --git a/compiler/ncgutil.pas b/compiler/ncgutil.pas
index 041121d572..83d48c8838 100644
--- a/compiler/ncgutil.pas
+++ b/compiler/ncgutil.pas
@@ -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;
diff --git a/compiler/nobj.pas b/compiler/nobj.pas
index 93099e5049..4f658ad917 100644
--- a/compiler/nobj.pas
+++ b/compiler/nobj.pas
@@ -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 }
diff --git a/compiler/parser.pas b/compiler/parser.pas
index 3de47585f4..249d3497fb 100644
--- a/compiler/parser.pas
+++ b/compiler/parser.pas
@@ -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;
diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas
index 86baa8a34c..51169719aa 100644
--- a/compiler/pdecl.pas
+++ b/compiler/pdecl.pas
@@ -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;
diff --git a/compiler/powerpc/cpupi.pas b/compiler/powerpc/cpupi.pas
index 49ab468df2..837c293a70 100644
--- a/compiler/powerpc/cpupi.pas
+++ b/compiler/powerpc/cpupi.pas
@@ -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);
diff --git a/compiler/powerpc64/cpupi.pas b/compiler/powerpc64/cpupi.pas
index 278d6f5940..4f24d14aea 100644
--- a/compiler/powerpc64/cpupi.pas
+++ b/compiler/powerpc64/cpupi.pas
@@ -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;
diff --git a/compiler/ppu.pas b/compiler/ppu.pas
index debe265ac7..a398229856 100644
--- a/compiler/ppu.pas
+++ b/compiler/ppu.pas
@@ -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;
diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas
index 95a694fba7..624eb1014a 100644
--- a/compiler/pstatmnt.pas
+++ b/compiler/pstatmnt.pas
@@ -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
diff --git a/compiler/psystem.pas b/compiler/psystem.pas
index 2a176306fe..c6cb3473b5 100644
--- a/compiler/psystem.pas
+++ b/compiler/psystem.pas
@@ -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);
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index f2b821a0fd..8b5e15e346 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -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] = (
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index 031d429308..25f58e8029 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -48,17 +48,12 @@ interface
TDef
************************************************}
+ { tstoreddef }
+
tstoreddef = class(tdef)
protected
typesymderef : tderef;
public
- { persistent (available across units) rtti and init tables }
- rttitablesym,
- inittablesym : tsym; {trttisym}
- rttitablesymderef,
- inittablesymderef : tderef;
- { local (per module) rtti and init tables }
- localrttilab : array[trttitype] of tasmlabel;
{$ifdef EXTDEBUG}
fileinfo : tfileposinfo;
{$endif}
@@ -82,11 +77,7 @@ interface
function alignment:shortint;override;
function is_publishable : boolean;override;
function needs_inittable : boolean;override;
- { rtti generation }
- procedure write_rtti_name;
- procedure write_rtti_data(rt:trttitype);virtual;
- procedure write_child_rtti_data(rt:trttitype);virtual;
- function get_rtti_label(rt:trttitype):tasmsymbol;
+ function rtti_mangledname(rt:trttitype):string;override;
{ regvars }
function is_intregable : boolean;
function is_fpuregable : boolean;
@@ -125,7 +116,6 @@ interface
procedure setsize;
function is_publishable : boolean;override;
function needs_inittable : boolean;override;
- procedure write_rtti_data(rt:trttitype);override;
end;
tformaldef = class(tstoreddef)
@@ -178,13 +168,6 @@ interface
end;
tabstractrecorddef= class(tstoreddef)
- private
- Count : integer;
- FRTTIType : trttitype;
- procedure count_field_rtti(sym:TObject;arg:pointer);
- procedure write_field_rtti(sym:TObject;arg:pointer);
- procedure generate_field_rtti(sym:TObject;arg:pointer);
- public
symtable : TSymtable;
procedure reset;override;
function GetSymtable(t:tGetSymtable):TSymtable;override;
@@ -207,9 +190,6 @@ interface
function GetTypeName:string;override;
{ debug }
function needs_inittable : boolean;override;
- { rtti }
- procedure write_child_rtti_data(rt:trttitype);override;
- procedure write_rtti_data(rt:trttitype);override;
end;
tprocdef = class;
@@ -239,13 +219,6 @@ interface
{ tobjectdef }
tobjectdef = class(tabstractrecorddef)
- private
- procedure count_published_properties(sym:TObject;arg:pointer);
- procedure collect_published_properties(sym:TObject;arg:pointer);
- procedure write_property_info(sym:TObject;arg:pointer);
- procedure generate_published_child_rtti(sym:TObject;arg:pointer);
- procedure count_published_fields(sym:TObject;arg:pointer);
- procedure writefields(sym:TObject;arg:pointer);
public
childof : tobjectdef;
childofderef : tderef;
@@ -283,16 +256,11 @@ interface
function is_publishable : boolean;override;
function needs_inittable : boolean;override;
function vmt_mangledname : string;
- function rtti_name : string;
procedure check_forwards;
function is_related(d : tdef) : boolean;override;
procedure insertvmt;
procedure set_parent(c : tobjectdef);
function FindDestructor : tprocdef;
- { rtti }
- procedure write_child_rtti_data(rt:trttitype);override;
- procedure write_rtti_data(rt:trttitype);override;
- function generate_field_table : tasmlabel;
end;
tclassrefdef = class(tabstractpointerdef)
@@ -330,8 +298,6 @@ interface
function alignment : shortint;override;
{ returns the label of the range check string }
function needs_inittable : boolean;override;
- procedure write_child_rtti_data(rt:trttitype);override;
- procedure write_rtti_data(rt:trttitype);override;
property elementdef : tdef read _elementdef write setelementdef;
end;
@@ -348,8 +314,6 @@ interface
procedure setsize;
function packedbitsize: aint; override;
function getvardef : longint;override;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
end;
tfloatdef = class(tstoreddef)
@@ -363,8 +327,6 @@ interface
function alignment:shortint;override;
procedure setsize;
function getvardef:longint;override;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
end;
tabstractprocdef = class(tstoreddef)
@@ -416,8 +378,6 @@ interface
function is_methodpointer:boolean;override;
function is_addressonly:boolean;override;
function getmangledparaname:string;override;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
end;
tmessageinf = record
@@ -546,10 +506,7 @@ interface
function getmangledparaname:string;override;
function is_publishable : boolean;override;
function alignment : shortint;override;
- { init/final }
function needs_inittable : boolean;override;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
end;
tenumdef = class(tstoreddef)
@@ -575,9 +532,6 @@ interface
procedure setmin(_min:aint);
function min:aint;
function max:aint;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
- procedure write_child_rtti_data(rt:trttitype);override;
end;
tsetdef = class(tstoreddef)
@@ -594,9 +548,6 @@ interface
procedure deref;override;
function GetTypeName:string;override;
function is_publishable : boolean;override;
- { rtti }
- procedure write_rtti_data(rt:trttitype);override;
- procedure write_child_rtti_data(rt:trttitype);override;
end;
Tdefmatch=(dm_exact,dm_equal,dm_convertl1);
@@ -876,7 +827,6 @@ implementation
{$ifdef EXTDEBUG}
fileinfo := current_filepos;
{$endif}
- fillchar(localrttilab,sizeof(localrttilab),0);
generictokenbuf:=nil;
genericdef:=nil;
{ Don't register forwarddefs, they are disposed at the
@@ -940,14 +890,9 @@ implementation
{$ifdef EXTDEBUG}
fillchar(fileinfo,sizeof(fileinfo),0);
{$endif}
- fillchar(localrttilab,sizeof(localrttilab),0);
{ load }
ppufile.getderef(typesymderef);
ppufile.getsmallset(defoptions);
- if df_has_rttitable in defoptions then
- ppufile.getderef(rttitablesymderef);
- if df_has_inittable in defoptions then
- ppufile.getderef(inittablesymderef);
if df_generic in defoptions then
begin
sizeleft:=ppufile.getlongint;
@@ -968,14 +913,24 @@ implementation
end;
+ function Tstoreddef.rtti_mangledname(rt:trttitype):string;
+ var
+ prefix : string[4];
+ begin
+ if rt=fullrtti then
+ prefix:='RTTI'
+ else
+ prefix:='INIT';
+ if assigned(typesym) and
+ (owner.symtabletype=globalsymtable) then
+ result:=make_mangledname(prefix,owner,typesym.name)
+ else
+ result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
+ end;
+
+
procedure Tstoreddef.reset;
begin
- if assigned(rttitablesym) then
- trttisym(rttitablesym).lab := nil;
- if assigned(inittablesym) then
- trttisym(inittablesym).lab := nil;
- localrttilab[initrtti]:=nil;
- localrttilab[fullrtti]:=nil;
end;
@@ -995,10 +950,6 @@ implementation
ppufile.putlongint(DefId);
ppufile.putderef(typesymderef);
ppufile.putsmallset(defoptions);
- if df_has_rttitable in defoptions then
- ppufile.putderef(rttitablesymderef);
- if df_has_inittable in defoptions then
- ppufile.putderef(inittablesymderef);
if df_generic in defoptions then
begin
oldintfcrc:=ppufile.do_interface_crc;
@@ -1031,8 +982,6 @@ implementation
procedure tstoreddef.buildderef;
begin
typesymderef.build(typesym);
- rttitablesymderef.build(rttitablesym);
- inittablesymderef.build(inittablesym);
genericdefderef.build(genericdef);
end;
@@ -1045,10 +994,6 @@ implementation
procedure tstoreddef.deref;
begin
typesym:=ttypesym(typesymderef.resolve);
- if df_has_rttitable in defoptions then
- rttitablesym:=trttisym(rttitablesymderef.resolve);
- if df_has_inittable in defoptions then
- inittablesym:=trttisym(inittablesymderef.resolve);
if df_specialization in defoptions then
genericdef:=tstoreddef(genericdefderef.resolve);
end;
@@ -1078,58 +1023,6 @@ implementation
end;
- procedure tstoreddef.write_rtti_name;
- var
- str : string;
- begin
- { name }
- if assigned(typesym) then
- begin
- str:=ttypesym(typesym).realname;
- current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(chr(length(str))+str));
- end
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(#0))
- end;
-
-
- procedure tstoreddef.write_rtti_data(rt:trttitype);
- begin
- current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
- write_rtti_name;
- end;
-
-
- procedure tstoreddef.write_child_rtti_data(rt:trttitype);
- begin
- end;
-
-
- function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
- begin
- { try to reuse persistent rtti data }
- if (rt=fullrtti) and (df_has_rttitable in defoptions) then
- get_rtti_label:=trttisym(rttitablesym).get_label
- else
- if (rt=initrtti) and (df_has_inittable in defoptions) then
- get_rtti_label:=trttisym(inittablesym).get_label
- else
- begin
- if not assigned(localrttilab[rt]) then
- begin
- current_asmdata.getdatalabel(localrttilab[rt]);
- write_child_rtti_data(rt);
- maybe_new_object_file(current_asmdata.asmlists[al_rtti]);
- new_section(current_asmdata.asmlists[al_rtti],sec_rodata,localrttilab[rt].name,const_align(sizeof(aint)));
- current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(localrttilab[rt],0));
- write_rtti_data(rt);
- current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(localrttilab[rt]));
- end;
- get_rtti_label:=localrttilab[rt];
- end;
- end;
-
-
{ returns true, if the definition can be published }
function tstoreddef.is_publishable : boolean;
begin
@@ -1342,37 +1235,6 @@ implementation
end;
- procedure tstringdef.write_rtti_data(rt:trttitype);
- begin
- case stringtype of
- st_ansistring:
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkAString));
- write_rtti_name;
- end;
- st_widestring:
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWString));
- write_rtti_name;
- end;
- st_longstring:
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkLString));
- write_rtti_name;
- end;
- st_shortstring:
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSString));
- write_rtti_name;
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(len));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- end;
- end;
- end;
-
-
function tstringdef.getmangledparaname : string;
begin
getmangledparaname:='STRING';
@@ -1544,61 +1406,18 @@ implementation
end;
- procedure tenumdef.write_child_rtti_data(rt:trttitype);
- begin
- if assigned(basedef) then
- basedef.get_rtti_label(rt);
- end;
-
-
- procedure tenumdef.write_rtti_data(rt:trttitype);
- var
- hp : tenumsym;
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkEnumeration));
- write_rtti_name;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- case longint(savesize) 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(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(min));
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(max));
- if assigned(basedef) then
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(basedef.get_rtti_label(rt)))
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
- hp:=tenumsym(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;
-
-
function tenumdef.is_publishable : boolean;
begin
is_publishable:=true;
end;
- function tenumdef.GetTypeName : string;
+ function tenumdef.GetTypeName : string;
begin
GetTypeName:='<enumeration type>';
end;
+
{****************************************************************************
TORDDEF
****************************************************************************}
@@ -1722,79 +1541,6 @@ implementation
end;
- procedure torddef.write_rtti_data(rt:trttitype);
-
- 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;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(byte(trans[ordtype])));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(low)));
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(high)));
- end;
-
- begin
- case ordtype of
- s64bit :
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkInt64));
- write_rtti_name;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_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;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_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;
-
-
function torddef.is_publishable : boolean;
begin
is_publishable:=(ordtype<>uvoid);
@@ -1802,7 +1548,6 @@ implementation
function torddef.GetTypeName : string;
-
const
names : array[tordtype] of string[20] = (
'untyped',
@@ -1815,6 +1560,7 @@ implementation
GetTypeName:=names[ordtype];
end;
+
{****************************************************************************
TFLOATDEF
****************************************************************************}
@@ -1897,21 +1643,6 @@ implementation
end;
- procedure tfloatdef.write_rtti_data(rt:trttitype);
- 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;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(translate[floattype]));
- end;
-
-
function tfloatdef.is_publishable : boolean;
begin
is_publishable:=true;
@@ -2120,12 +1851,6 @@ implementation
end;
- procedure tvariantdef.write_rtti_data(rt:trttitype);
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkVariant));
- end;
-
-
function tvariantdef.needs_inittable : boolean;
begin
needs_inittable:=true;
@@ -2349,27 +2074,6 @@ implementation
end;
- procedure tsetdef.write_child_rtti_data(rt:trttitype);
- begin
- tstoreddef(elementdef).get_rtti_label(rt);
- end;
-
-
- procedure tsetdef.write_rtti_data(rt:trttitype);
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkSet));
- write_rtti_name;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_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(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(elementdef).get_rtti_label(rt)));
- end;
-
-
function tsetdef.is_publishable : boolean;
begin
is_publishable:=(settype=smallset);
@@ -2617,39 +2321,6 @@ implementation
end;
- procedure tarraydef.write_child_rtti_data(rt:trttitype);
- begin
- tstoreddef(elementdef).get_rtti_label(rt);
- end;
-
-
- procedure tarraydef.write_rtti_data(rt:trttitype);
- begin
- if ado_IsBitPacked in arrayoptions then
- begin
- current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
- write_rtti_name;
- exit;
- end;
- if ado_IsDynamicArray in 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;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- { size of elements }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(elesize));
- if not(ado_IsDynamicArray in arrayoptions) then
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(elecount));
- { element type }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(elementdef).get_rtti_label(rt)));
- { variant type }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tstoreddef(elementdef).getvardef));
- end;
-
-
function tarraydef.GetTypeName : string;
begin
if (ado_IsConstString in arrayoptions) then
@@ -2715,35 +2386,6 @@ implementation
result:=tabstractrecordsymtable(symtable).is_packed;
end;
- procedure tabstractrecorddef.count_field_rtti(sym:TObject;arg:pointer);
- begin
- if (FRTTIType=fullrtti) or
- ((tsym(sym).typ=fieldvarsym) and
- tfieldvarsym(sym).vardef.needs_inittable) then
- inc(Count);
- end;
-
-
- procedure tabstractrecorddef.generate_field_rtti(sym:TObject;arg:pointer);
- begin
- if (FRTTIType=fullrtti) or
- ((tsym(sym).typ=fieldvarsym) and
- tfieldvarsym(sym).vardef.needs_inittable) then
- tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(FRTTIType);
- end;
-
-
- procedure tabstractrecorddef.write_field_rtti(sym:TObject;arg:pointer);
- begin
- if (FRTTIType=fullrtti) or
- ((tsym(sym).typ=fieldvarsym) and
- tfieldvarsym(sym).vardef.needs_inittable) then
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(FRTTIType)));
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tfieldvarsym(sym).fieldoffset));
- end;
- end;
-
{***************************************************************************
trecorddef
@@ -2850,35 +2492,6 @@ implementation
end;
- procedure trecorddef.write_child_rtti_data(rt:trttitype);
- begin
- FRTTIType:=rt;
- symtable.SymList.ForEachCall(@generate_field_rtti,nil);
- end;
-
-
- procedure trecorddef.write_rtti_data(rt:trttitype);
- begin
- if is_packed then
- begin
- current_asmdata.asmlists[al_rtti].concat(tai_const.create_8bit(tkUnknown));
- write_rtti_name;
- exit;
- end;
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkrecord));
- write_rtti_name;
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(size));
- Count:=0;
- FRTTIType:=rt;
- symtable.SymList.ForEachCall(@count_field_rtti,nil);
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(Count));
- symtable.SymList.ForEachCall(@write_field_rtti,nil);
- end;
-
-
function trecorddef.GetTypeName : string;
begin
GetTypeName:='<record type>'
@@ -3878,79 +3491,6 @@ implementation
end;
- procedure tprocvardef.write_rtti_data(rt:trttitype);
-
- 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 }
- tstoreddef(parasym.vardef).write_rtti_name;
- end;
- end;
-
- var
- methodkind : byte;
- i : integer;
- begin
- if po_methodpointer in procoptions then
- begin
- { write method id and name }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkmethod));
- write_rtti_name;
-
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- { write kind of method (can only be function or procedure)}
- if returndef = voidtype then
- methodkind := mkProcedure
- else
- methodkind := mkFunction;
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(methodkind));
-
- { get # of parameters }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(maxparacount));
-
- { write parameter info. The parameters must be written in reverse order
- if this method uses right to left parameter pushing! }
- if proccalloption in pushleftright_pocalls then
- begin
- for i:=0 to paras.count-1 do
- write_para(tparavarsym(paras[i]));
- end
- else
- begin
- for i:=paras.count-1 downto 0 do
- write_para(tparavarsym(paras[i]));
- end;
-
- { write name of result type }
- tstoreddef(returndef).write_rtti_name;
- end
- else
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkprocvar));
- write_rtti_name;
- end;
- end;
-
-
function tprocvardef.is_publishable : boolean;
begin
is_publishable:=(po_methodpointer in procoptions);
@@ -3992,56 +3532,6 @@ implementation
TOBJECTDEF
***************************************************************************}
- type
- tproptablelistitem = class(TLinkedListItem)
- index : longint;
- def : tobjectdef;
- end;
-
- tpropnamelistitem = class(TLinkedListItem)
- index : longint;
- name : TIDString;
- owner : TSymtable;
- end;
-
- var
- proptablelist : tlinkedlist;
- propnamelist : tlinkedlist;
-
- function searchproptablelist(p : tobjectdef) : tproptablelistitem;
- var
- hp : tproptablelistitem;
- begin
- hp:=tproptablelistitem(proptablelist.first);
- while assigned(hp) do
- if hp.def=p then
- begin
- result:=hp;
- exit;
- end
- else
- hp:=tproptablelistitem(hp.next);
- result:=nil;
- end;
-
-
- function searchpropnamelist(const n:string) : tpropnamelistitem;
- var
- hp : tpropnamelistitem;
- begin
- hp:=tpropnamelistitem(propnamelist.first);
- while assigned(hp) do
- if hp.name=n then
- begin
- result:=hp;
- exit;
- end
- else
- hp:=tpropnamelistitem(hp.next);
- result:=nil;
- end;
-
-
constructor tobjectdef.create(ot : tobjecttyp;const n : string;c : tobjectdef);
begin
inherited create(objectdef);
@@ -4449,12 +3939,6 @@ implementation
end;
- function tobjectdef.rtti_name : string;
- begin
- rtti_name:=make_mangledname('RTTI',owner,objname^);
- end;
-
-
function tobjectdef.needs_inittable : boolean;
begin
case objecttype of
@@ -4499,402 +3983,6 @@ implementation
end;
- procedure tobjectdef.collect_published_properties(sym:TObject;arg:pointer);
- var
- hp : tpropnamelistitem;
- begin
- if (tsym(sym).typ=propertysym) and
- (sp_published in tsym(sym).symoptions) then
- begin
- hp:=searchpropnamelist(tsym(sym).name);
- if not(assigned(hp)) then
- begin
- hp:=tpropnamelistitem.create;
- hp.name:=tsym(sym).name;
- hp.index:=propnamelist.count;
- hp.owner:=tsym(sym).owner;
- propnamelist.concat(hp);
- end;
- end;
- end;
-
-
- procedure tobjectdef.count_published_properties(sym:TObject;arg:pointer);
- begin
- if (tsym(sym).typ=propertysym) and
- (sp_published in tsym(sym).symoptions) then
- inc(plongint(arg)^);
- end;
-
-
- procedure tobjectdef.write_property_info(sym:TObject;arg:pointer);
- var
- 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
- if (tsym(sym).typ=propertysym) and
- (sp_published in tsym(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(tstoreddef(tpropertysym(sym).propdef).get_rtti_label(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:=searchpropnamelist(tpropertysym(sym).name);
- if not assigned(propnameitem) then
- internalerror(200512201);
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.index));
- 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(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- end;
- end;
-
-
- procedure tobjectdef.generate_published_child_rtti(sym:TObject;arg:pointer);
- begin
- if needs_prop_entry(tsym(sym)) then
- begin
- case tsym(sym).typ of
- propertysym:
- tstoreddef(tpropertysym(sym).propdef).get_rtti_label(fullrtti);
- fieldvarsym:
- tstoreddef(tfieldvarsym(sym).vardef).get_rtti_label(fullrtti);
- else
- internalerror(1509991);
- end;
- end;
- end;
-
-
- procedure tobjectdef.write_child_rtti_data(rt:trttitype);
- begin
- FRTTIType:=rt;
- case rt of
- initrtti :
- symtable.SymList.ForEachCall(@generate_field_rtti,nil);
- fullrtti :
- symtable.SymList.ForEachCall(@generate_published_child_rtti,nil);
- else
- internalerror(200108301);
- end;
- end;
-
-
- procedure tobjectdef.count_published_fields(sym:TObject;arg:pointer);
- var
- hp : tproptablelistitem;
- begin
- if (tsym(sym).typ=fieldvarsym) and
- (sp_published in tsym(sym).symoptions) then
- begin
- if tfieldvarsym(sym).vardef.typ<>objectdef then
- internalerror(0206001);
- hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vardef));
- if not(assigned(hp)) then
- begin
- hp:=tproptablelistitem.create;
- hp.def:=tobjectdef(tfieldvarsym(sym).vardef);
- hp.index:=proptablelist.count+1;
- proptablelist.concat(hp);
- end;
- inc(plongint(arg)^);
- end;
- end;
-
-
- procedure tobjectdef.writefields(sym:TObject;arg:pointer);
- var
- hp : tproptablelistitem;
- begin
- if needs_prop_entry(tsym(sym)) and
- (tsym(sym).typ=fieldvarsym) then
- begin
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(AInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset));
- hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vardef));
- if not(assigned(hp)) then
- internalerror(0206002);
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(hp.index));
- 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;
-
-
- function tobjectdef.generate_field_table : tasmlabel;
- var
- fieldtable,
- classtable : tasmlabel;
- hp : tproptablelistitem;
- fieldcount : longint;
- begin
- proptablelist:=TLinkedList.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)));
- { fields }
- fieldcount:=0;
- symtable.SymList.ForEachCall(@count_published_fields,@fieldcount);
- 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(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(classtable));
- symtable.SymList.ForEachCall(@writefields,nil);
-
- { generate the class table }
- current_asmdata.asmlists[al_rtti].concat(tai_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(proptablelist.count));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- hp:=tproptablelistitem(proptablelist.first);
- while assigned(hp) do
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tobjectdef(hp.def).vmt_mangledname,0));
- hp:=tproptablelistitem(hp.next);
- end;
-
- generate_field_table:=fieldtable;
- proptablelist.free;
- proptablelist:=nil;
- end;
-
-
- procedure tobjectdef.write_rtti_data(rt:trttitype);
-
- procedure collect_unique_published_props(pd:tobjectdef);
- begin
- if assigned(pd.childof) then
- collect_unique_published_props(pd.childof);
- pd.symtable.SymList.ForEachCall(@collect_published_properties,nil);
- end;
-
- var
- i : longint;
- propcount : longint;
- begin
- case 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
- exit;
- end;
-
- { generate the name }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(objrealname^)));
- current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(objrealname^));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- case rt of
- initrtti :
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(size));
- if objecttype in [odt_class,odt_object] then
- begin
- count:=0;
- FRTTIType:=rt;
- symtable.SymList.ForEachCall(@count_field_rtti,nil);
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(count));
- symtable.SymList.ForEachCall(@write_field_rtti,nil);
- end;
- end;
- fullrtti :
- begin
- { Collect unique property names with nameindex }
- propnamelist:=TLinkedList.Create;
- collect_unique_published_props(self);
-
- if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
- begin
- if (oo_has_vmt in objectoptions) then
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(vmt_mangledname,0))
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
- end;
-
- { write parent typeinfo }
- if assigned(childof) and ((oo_can_have_published in childof.objectoptions) or
- (objecttype in [odt_interfacecom,odt_interfacecorba])) then
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(childof.get_rtti_label(fullrtti)))
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_const.create_sym(nil));
-
- if objecttype in [odt_object,odt_class] then
- begin
- { total number of unique properties }
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
- end
- else
- { interface: write flags, iid and iidstr }
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(
- { ugly, but working }
- longint([
- TCompilerIntfFlag(ord(ifHasGuid)*ord(assigned(iidguid))),
- TCompilerIntfFlag(ord(ifHasStrGUID)*ord(assigned(iidstr)))
- ])
- {
- ifDispInterface,
- ifDispatch, }
- ));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(longint(iidguid^.D1)));
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(iidguid^.D2));
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(iidguid^.D3));
- for i:=Low(iidguid^.D4) to High(iidguid^.D4) do
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(iidguid^.D4[i]));
- end;
-
- { 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(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
-
- { write iidstr }
- if objecttype in [odt_interfacecom,odt_interfacecorba] then
- begin
- if assigned(iidstr) then
- begin
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(iidstr^)));
- current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(iidstr^));
- end
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- end;
-
- { write published properties for this object }
- if objecttype in [odt_object,odt_class] then
- begin
- propcount:=0;
- symtable.SymList.ForEachCall(@count_published_properties,@propcount);
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propcount));
-{$ifdef cpurequiresproperalignment}
- current_asmdata.asmlists[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
-{$endif cpurequiresproperalignment}
- end;
- symtable.SymList.ForEachCall(@write_property_info,nil);
-
- propnamelist.free;
- propnamelist:=nil;
- end;
- end;
- end;
-
-
function tobjectdef.is_publishable : boolean;
begin
is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
diff --git a/compiler/symsym.pas b/compiler/symsym.pas
index a04e65ba63..7284803707 100644
--- a/compiler/symsym.pas
+++ b/compiler/symsym.pas
@@ -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.
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index be8546c748..703f41f981 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -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;
diff --git a/compiler/symtype.pas b/compiler/symtype.pas
index 3b8e874042..75161b4ef3 100644
--- a/compiler/symtype.pas
+++ b/compiler/symtype.pas
@@ -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.
+
diff --git a/compiler/symutil.pas b/compiler/symutil.pas
index 488b47bde8..f8e5f6b9fa 100644
--- a/compiler/symutil.pas
+++ b/compiler/symutil.pas
@@ -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.
+
diff --git a/compiler/utils/ppudump.pp b/compiler/utils/ppudump.pp
index 0fc368004b..7fef859325 100644
--- a/compiler/utils/ppudump.pp
+++ b/compiler/utils/ppudump.pp
@@ -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 ');