* moved rtti to ncgrtti

git-svn-id: trunk@5219 -

.gitattributes

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

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);

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 }
             ;

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;
 

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;
 
 

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.
+

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;

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 }

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;

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
+              if current_module.in_interface {or
-                 ((is_class(hdef) and
+                 (
-                   tobjectdef(hdef).members_need_inittable) or
+                  (is_class(hdef) and
-                  hdef.needs_inittable) then
+                  tobjectdef(hdef).members_need_inittable) or
-                generate_inittable(newtype);
+                  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
+              if (hdef.typ=objectdef) then
-                 (hdef.owner.symtabletype in [staticsymtable,globalsymtable]) then
+                begin
-                with Tobjectdef(hdef) do
+                  if not(oo_is_forward in tobjectdef(hdef).objectoptions) then
-                  begin
+                    begin
-                    if not(oo_is_forward in objectoptions) then
+                      ch:=tclassheader.create(tobjectdef(hdef));
-                      begin
+                      { generate and check virtual methods, must be done
-                        ch:=tclassheader.create(tobjectdef(hdef));
+                        before RTTI is written }
-                        { generate and check virtual methods, must be done
+                      ch.genvmt;
-                          before RTTI is written }
+                      { Generate RTTI for class }
-                        ch.genvmt;
+                      RTTIWriter.write_rtti(hdef,fullrtti);
-                        { Generate RTTI for class }
+                      if is_interface(tobjectdef(hdef)) then
-                        generate_rtti(newtype);
+                        ch.writeinterfaceids;
-                        if is_interface(tobjectdef(hdef)) then
+                      if (oo_has_vmt in tobjectdef(hdef).objectoptions) then
-                          ch.writeinterfaceids;
+                        ch.writevmt;
-                        if (oo_has_vmt in objectoptions) then
+                      ch.free;
-                          ch.writevmt;
+                    end;
-                        ch.free;
+                end
-                      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;

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;
+            if tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals <> 0 then
-            current_procinfo.procdef.localst.SymList.ForEachCall(@count_locals,@locals);
-            if locals <> 0 then
               begin
                 { at 0(r1), the previous value of r1 will be stored }
                 tg.setfirsttemp(4);

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;
+    if tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals <> 0 then
-    current_procinfo.procdef.localst.SymList.ForEachCall(@count_locals, @locals);
-    if locals <> 0 then
       { at 0(r1), the previous value of r1 will be stored }
       tg.setfirsttemp(8);
   end;

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;

compiler/pstatmnt.pas

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

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 }
+          { write always RTTI to get persistent typeinfo }
-          if def.needs_inittable then
+          RTTIWriter.write_rtti(def,initrtti);
-           generate_inittable(result);
+          RTTIWriter.write_rtti(def,fullrtti);
-        end;
-
-        procedure adddef(const s:string;def:tdef);
-        begin
-          systemunit.insert(ttypesym.create(s,def));
         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);
+        addtype('Text',tfiledef.createtext);
-        adddef('TypedFile',tfiledef.createtyped(voidtype));
+        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);

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] = (

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.

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;

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.
+

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.
+

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 ');