* Write extended RTTI info

compiler/ncgrtti.pas

@@ -50,9 +50,10 @@ interface
         procedure methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
         procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
         procedure published_write_rtti(st:tsymtable;rt:trttitype);
-        function  published_properties_count(st:tsymtable):longint;
-        procedure published_properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist: TFPHashObjectList; st: tsymtable);
-        procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
+        procedure properties_write_rtti_data(tcb:ttai_typedconstbuilder;propnamelist:TFPHashObjectList;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
+        procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
+        procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
+        procedure collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
         { only use a direct reference if the referenced type can *only* reside
           in the same unit as the current one }
         function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
@@ -62,7 +63,7 @@ interface
         procedure write_attribute_data(tcb: ttai_typedconstbuilder;attr_list:trtti_attribute_list);
         procedure write_child_rtti_data(def:tdef;rt:trttitype);
         procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
-        procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
+        procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
         procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
         function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
         procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
@@ -73,6 +74,8 @@ interface
       public
         constructor create;
         procedure write_rtti(def:tdef;rt:trttitype);
+        procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
+        procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
         function  get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
         function  get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
         function  get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
@@ -117,6 +120,35 @@ implementation
        end;
 
 
+    function visibility_to_rtti_flags(vis: tvisibility): byte;
+      begin
+        case vis of
+          vis_private:
+            result:=byte(rv_private);
+          vis_strictprivate:
+            begin
+              result:=byte(rv_private);
+              // add bit to indicate "strict"
+              result:=result or (1 shl 2);
+            end;
+          vis_protected:
+            result:=byte(rv_protected);
+          vis_strictprotected:
+            begin
+              result:=byte(rv_protected);
+              // add bit to indicate "strict"
+              result:=result or (1 shl 2);
+            end;
+          vis_public:
+            result:=byte(rv_public);
+          vis_published:
+            result:=byte(rv_published);
+          otherwise
+            internalerror(2021061301);
+        end;
+      end;
+
+
     procedure write_persistent_type_info(st: tsymtable; is_global: boolean);
       var
         i : longint;
@@ -207,11 +239,12 @@ implementation
         result:=ref_rtti(def,rt,indirect,'_s2o');
       end;
 
-    procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
+    procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
       var
         rtticount,
         totalcount,
         i,j,k : longint;
+        vmt_index : integer;
         sym : tprocsym;
         def : tprocdef;
         para : tparavarsym;
@@ -232,88 +265,114 @@ implementation
                   inc(rtticount);
             end;
 
-        maybe_add_comment(tcb,#9'count');
-        tcb.emit_ord_const(totalcount,u16inttype);
-        maybe_add_comment(tcb,#9'RTTI count');
-        if rtticount = 0 then
-          tcb.emit_ord_const($FFFF,u16inttype)
-        else
+        { write the count section for non-extended methods }
+        if not extended_rtti then
           begin
-            tcb.emit_ord_const(rtticount,u16inttype);
-
-            for i:=0 to st.symlist.count-1 do
-              if tsym(st.symlist[i]).typ=procsym then
-                begin
-                  sym:=tprocsym(st.symlist[i]);
-                  for j:=0 to sym.procdeflist.count-1 do
-                    begin
-                      def:=tprocdef(sym.procdeflist[j]);
-
-                      if not (def.visibility in visibilities) then
-                        continue;
-
-                      def.init_paraloc_info(callerside);
-
-                      maybe_add_comment(tcb,'RTTI: begin method '+def.fullprocname(false));
-                      tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
-                        targetinfos[target_info.system]^.alignment.recordalignmin);
-
-                      maybe_add_comment(tcb,#9'return type');
-                      write_rtti_reference(tcb,def.returndef,fullrtti);
-                      maybe_add_comment(tcb,#9'calling convention');
-                      write_callconv(tcb,def);
-                      maybe_add_comment(tcb,#9'method kind');
-                      write_methodkind(tcb,def);
-                      maybe_add_comment(tcb,#9'param count');
-                      tcb.emit_ord_const(def.paras.count,u16inttype);
-                      maybe_add_comment(tcb,#9'caller args size');
-                      tcb.emit_ord_const(def.callerargareasize,sizesinttype);
-                      maybe_add_comment(tcb,#9'invoke helper');
-                      if def.invoke_helper=nil then
-                        tcb.emit_tai(Tai_const.Create_nil_dataptr,voidcodepointertype)
-                      else
-                        tcb.emit_procdef_const(def.invoke_helper);
-                      maybe_add_comment(tcb,#9'name');
-                      tcb.emit_pooled_shortstring_const_ref(sym.realname);
-
-                      for k:=0 to def.paras.count-1 do
-                        begin
-                          para:=tparavarsym(def.paras[k]);
-                          maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname);
-                          tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
-                            targetinfos[target_info.system]^.alignment.recordalignmin);
-
-                          maybe_add_comment(tcb,#9'type');
-                          if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
-                            write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
-                          else if para.vardef=cformaltype then
-                            write_rtti_reference(tcb,nil,fullrtti)
-                          else
-                            write_rtti_reference(tcb,para.vardef,fullrtti);
-                          maybe_add_comment(tcb,#9'flags');
-                          write_param_flag(tcb,para);
-
-                          maybe_add_comment(tcb,#9'name');
-                          tcb.emit_pooled_shortstring_const_ref(para.realname);
-
-                          maybe_add_comment(tcb,#9'locs');
-                          write_paralocs(tcb,@para.paraloc[callerside]);
-
-                          tcb.end_anonymous_record;
-                          maybe_add_comment(tcb,'RTTI: end param '+para.prettyname);
-                        end;
-
-                      if not is_void(def.returndef) then
-                        begin
-                        maybe_add_comment(tcb,#9'return loc');
-                        write_paralocs(tcb,@def.funcretloc[callerside]);
-                        end;
-
-                      tcb.end_anonymous_record;
-                    end;
-                end;
+            maybe_add_comment(tcb,#9'count');
+            tcb.emit_ord_const(totalcount,u16inttype);
+            maybe_add_comment(tcb,#9'RTTI count');
+            if rtticount=0 then
+              tcb.emit_ord_const($FFFF,u16inttype)
+            else
+              tcb.emit_ord_const(rtticount,u16inttype);
           end;
 
+        if rtticount>0 then
+          for i:=0 to st.symlist.count-1 do
+            if tsym(st.symlist[i]).typ=procsym then
+              begin
+                sym:=tprocsym(st.symlist[i]);
+                for j:=0 to sym.procdeflist.count-1 do
+                  begin
+                    def:=tprocdef(sym.procdeflist[j]);
+
+                    if not (def.visibility in visibilities) then
+                      continue;
+
+                    def.init_paraloc_info(callerside);
+
+                    maybe_add_comment(tcb,'RTTI: begin method '+def.fullprocname(false));
+                    tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+                      targetinfos[target_info.system]^.alignment.recordalignmin);
+
+                    maybe_add_comment(tcb,#9'return type');
+                    write_rtti_reference(tcb,def.returndef,fullrtti);
+                    maybe_add_comment(tcb,#9'calling convention');
+                    write_callconv(tcb,def);
+                    maybe_add_comment(tcb,#9'method kind');
+                    write_methodkind(tcb,def);
+                    maybe_add_comment(tcb,#9'param count');
+                    tcb.emit_ord_const(def.paras.count,u16inttype);
+                    maybe_add_comment(tcb,#9'caller args size');
+                    tcb.emit_ord_const(def.callerargareasize,sizesinttype);
+                    maybe_add_comment(tcb,#9'invoke helper');
+                    if def.invoke_helper=nil then
+                      tcb.emit_tai(Tai_const.Create_nil_dataptr,voidcodepointertype)
+                    else
+                      tcb.emit_procdef_const(def.invoke_helper);
+                    maybe_add_comment(tcb,#9'name');
+                    tcb.emit_pooled_shortstring_const_ref(sym.realname);
+
+                    if extended_rtti then
+                      begin
+                        { write visibility section for extended RTTI }
+                        maybe_add_comment(tcb,#9'visibility');
+                        tcb.emit_ord_const(visibility_to_rtti_flags(def.visibility),u8inttype);
+                        { for classes write a VMT index }
+                        if st.defowner.typ=objectdef then
+                          begin
+                            vmt_index:=-1;
+                            if po_virtualmethod in def.procoptions then
+                              for k:=0 to tobjectdef(st.defowner).vmtentries.count-1 do
+                                if pvmtentry(tobjectdef(st.defowner).vmtentries[k])^.procdef=def then
+                                  begin
+                                    vmt_index:=k;
+                                    break;
+                                  end;
+                            maybe_add_comment(tcb,#9'VMT index');
+                            tcb.emit_ord_const(vmt_index,s16inttype);
+                          end;
+                      end;
+
+                    for k:=0 to def.paras.count-1 do
+                      begin
+                        para:=tparavarsym(def.paras[k]);
+
+                        maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname);
+                        tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+                          targetinfos[target_info.system]^.alignment.recordalignmin);
+
+                        maybe_add_comment(tcb,#9'type');
+                        if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
+                          write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
+                        else if para.vardef=cformaltype then
+                          write_rtti_reference(tcb,nil,fullrtti)
+                        else
+                          write_rtti_reference(tcb,para.vardef,fullrtti);
+                        maybe_add_comment(tcb,#9'flags');
+                        write_param_flag(tcb,para);
+
+                        maybe_add_comment(tcb,#9'name');
+                        tcb.emit_pooled_shortstring_const_ref(para.realname);
+
+                        maybe_add_comment(tcb,#9'locs');
+                        write_paralocs(tcb,@para.paraloc[callerside]);
+
+                        tcb.end_anonymous_record;
+                        maybe_add_comment(tcb,'RTTI: end param '+para.prettyname);
+                      end;
+
+                    if not is_void(def.returndef) then
+                      begin
+                      maybe_add_comment(tcb,#9'return loc');
+                      write_paralocs(tcb,@def.funcretloc[callerside]);
+                      end;
+
+                    tcb.end_anonymous_record;
+                    maybe_add_comment(tcb,'RTTI: end method '+def.fullprocname(false));
+                  end;
+              end;
+
         tcb.end_anonymous_record;
         maybe_add_comment(tcb,'RTTI: end methods');
       end;
@@ -724,6 +783,97 @@ implementation
       end;
 
 
+    procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
+      var
+        methodcount,
+        i, j: longint;
+        sym: tprocsym;
+      begin
+        { count methods }
+        methodcount:=0;
+        for i:=0 to def.symtable.symlist.count-1 do
+          if tsym(def.symtable.symlist[i]).typ=procsym then
+            begin
+              sym:=tprocsym(def.symtable.symlist[i]);
+              for j:=0 to sym.procdeflist.count-1 do
+                if def.is_visible_for_rtti(ro_methods,tprocdef(sym.procdeflist[j]).visibility) then
+                  inc(methodcount);
+            end;
+
+        tcb.begin_anonymous_record('',packrecords,min(reqalign,SizeOf(PInt)),
+          targetinfos[target_info.system]^.alignment.recordalignmin);
+        { emit method count }
+        tcb.emit_ord_const(methodcount,u16inttype);
+        { emit method entries (array) }
+        if methodcount>0 then
+          write_methods(tcb,def.symtable,true,def.rtti_visibilities_for_option(ro_methods));
+        tcb.end_anonymous_record;
+      end;
+
+
+    procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
+      begin
+        write_extended_method_table(tcb,def,defaultpacking);
+      end;
+
+
+    procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
+      var
+        i: integer;
+        sym: tsym;
+        list: TFPList;
+      begin
+        list:=TFPList.Create;
+        { build list of visible fields }
+        for i:=0 to def.symtable.symlist.Count-1 do
+          begin
+            sym:=tsym(def.symtable.symlist[i]);
+            if (sym.typ=fieldvarsym) and
+               not(sp_static in sym.symoptions) and
+               def.is_visible_for_rtti(ro_fields, sym.visibility) then
+              list.add(sym);
+          end;
+        {
+          TExtendedFieldTable = record
+            FieldCount: Word;
+            Fields: array[0..0] of TExtendedFieldInfo;
+          end;
+        }
+        tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_table]+tostr(list.count),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
+        tcb.emit_ord_const(list.count,u16inttype);
+        for i := 0 to list.count-1 do
+          begin
+            sym:=tsym(list[i]);
+            {
+              TExtendedFieldInfo = record
+                FieldOffset: SizeUInt;
+                FieldType: Pointer;
+                FieldVisibility: Byte;
+                Name: PShortString;
+              end;
+            }
+            tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_field]+tostr(tfieldvarsym(sym).fieldoffset),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
+            { FieldOffset }
+            tcb.emit_tai(Tai_const.Create_sizeint(tfieldvarsym(sym).fieldoffset),sizeuinttype);
+            { FieldType: PPTypeInfo }
+            tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(tfieldvarsym(sym).vardef,fullrtti,true)),voidpointertype);
+            { FieldVisibility }
+            tcb.emit_ord_const(visibility_to_rtti_flags(tfieldvarsym(sym).visibility),u8inttype);
+            { Name }
+            tcb.emit_pooled_shortstring_const_ref(sym.realname);
+            tcb.end_anonymous_record;
+          end;
+        tcb.end_anonymous_record;
+        list.free;
+      end;
+
+
+    procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
+      begin
+        write_extended_field_table(tcb,def,defaultpacking);
+      end;
+
+
     procedure TRTTIWriter.published_write_rtti(st:tsymtable;rt:trttitype);
       var
         i   : longint;
@@ -747,35 +897,23 @@ implementation
       end;
 
 
-    function TRTTIWriter.published_properties_count(st:tsymtable):longint;
+    procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
       var
         i   : longint;
         sym : tsym;
+        pn  : tpropnamelistitem;
       begin
-        result:=0;
-        for i:=0 to st.SymList.Count-1 do
+        { search into parent for objects }
+        if def.typ=objectdef then
           begin
-            sym:=tsym(st.SymList[i]);
-            if (tsym(sym).typ=propertysym) and
-               (sym.visibility=vis_published) then
-              inc(result);
+            if assigned(tobjectdef(def).childof) then
+              collect_propnamelist(propnamelist,tobjectdef(def).childof,visibilities);
           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
+        for i:=0 to def.symtable.SymList.Count-1 do
           begin
-            sym:=tsym(objdef.symtable.SymList[i]);
+            sym:=tsym(def.symtable.SymList[i]);
             if (tsym(sym).typ=propertysym) and
-               (sym.visibility=vis_published) then
+               (sym.visibility in visibilities) then
               begin
                 pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name));
                 if not assigned(pn) then
@@ -789,15 +927,18 @@ implementation
       end;
 
 
-    procedure TRTTIWriter.published_properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList;st:tsymtable);
+    procedure TRTTIWriter.properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList; st:tsymtable; extended_rtti:boolean; visibilities:tvisibilities);
       var
         i : longint;
         sym : tsym;
         proctypesinfo : byte;
         propnameitem  : tpropnamelistitem;
         propdefname : string;
+        tbltcb : ttai_typedconstbuilder;
+        tbllab : tasmlabel;
+        tbldef : tdef;
 
-        procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
+        procedure writeaccessproc(tcb: ttai_typedconstbuilder; pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
         var
            typvalue : byte;
            hp : ppropaccesslistitem;
@@ -893,73 +1034,134 @@ implementation
            proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
         end;
 
+        function 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
+                   (sym.visibility in visibilities) then
+                  inc(result);
+              end;
+          end;
+
+        function write_propinfo_data(tcb: ttai_typedconstbuilder; sym: tpropertysym): tdef;
+          begin
+            { we can only easily reuse defs if the property is not stored,
+              because otherwise the rtti layout depends on how the "stored"
+              is defined (field, indexed expression, virtual method, ...) }
+            if not(ppo_stored in sym.propoptions) then
+              propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(sym.realname))
+            else
+              propdefname:='';
+            { TPropInfo is a packed record (even on targets that require
+              alignment), but it starts aligned }
+            if addcomments then
+              tcb.emit_comment('RTTI: begin propinfo record '+sym.realname);
+            tcb.begin_anonymous_record(
+              propdefname,
+              1,min(reqalign,SizeOf(PInt)),
+              targetinfos[target_info.system]^.alignment.recordalignmin);
+            if ppo_indexed in sym.propoptions then
+              proctypesinfo:=$40
+            else
+              proctypesinfo:=0;
+            if addcomments then
+              tcb.emit_comment(#9'type info');
+            write_rtti_reference(tcb,sym.propdef,fullrtti);
+            if addcomments then
+              tcb.emit_comment(#9'read access');
+            writeaccessproc(tcb,palt_read,0,0);
+            if addcomments then
+              tcb.emit_comment(#9'write access');
+            writeaccessproc(tcb,palt_write,2,0);
+            { is it stored ? }
+            if addcomments then
+              tcb.emit_comment(#9'stored ?');
+            if not(ppo_stored in sym.propoptions) then
+              begin
+                { no, so put a constant zero }
+                tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype);
+                proctypesinfo:=proctypesinfo or (3 shl 4);
+              end
+            else
+              writeaccessproc(tcb,palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
+            if addcomments then
+              tcb.emit_comment(#9'Index');
+            tcb.emit_ord_const(sym.index,u32inttype);
+            if addcomments then
+              tcb.emit_comment(#9'default');
+            tcb.emit_ord_const(sym.default,u32inttype);
+            propnameitem:=TPropNameListItem(propnamelist.Find(sym.name));
+            if not assigned(propnameitem) then
+              internalerror(200512201);
+            if addcomments then
+              tcb.emit_comment(#9'property index');
+            tcb.emit_ord_const(propnameitem.propindex,u16inttype);
+            if addcomments then
+              tcb.emit_comment(#9'proc types');
+            tcb.emit_ord_const(proctypesinfo,u8inttype);
+            { write reference to attribute table }
+            if addcomments then
+              tcb.emit_comment(#9'attributes');
+            write_attribute_data(tcb,sym.rtti_attribute_list);
+            { write property name }
+            if addcomments then
+              tcb.emit_comment(#9'name');
+            tcb.emit_shortstring_const(sym.realname);
+            result:=tcb.end_anonymous_record;
+            if addcomments then
+              tcb.emit_comment('RTTI: End propinfo record '+sym.realname);
+          end;
+
       begin
         tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
           targetinfos[target_info.system]^.alignment.recordalignmin);
-        tcb.emit_ord_const(published_properties_count(st),u16inttype);
+        tcb.emit_ord_const(properties_count(st),u16inttype);
         for i:=0 to st.SymList.Count-1 do
           begin
             sym:=tsym(st.SymList[i]);
             if (sym.typ=propertysym) and
-               (sym.visibility=vis_published) then
+               (sym.visibility in visibilities) then
               begin
-                { we can only easily reuse defs if the property is not stored,
-                  because otherwise the rtti layout depends on how the "stored"
-                  is defined (field, indexed expression, virtual method, ...) }
-                if not(ppo_stored in tpropertysym(sym).propoptions) then
-                  propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(tpropertysym(sym).realname))
-                else
-                  propdefname:='';
-                { TPropInfo is a packed record (even on targets that require
-                  alignment), but it starts aligned }
-                maybe_add_comment(tcb,'RTTI: begin property '+sym.prettyname);
-                tcb.begin_anonymous_record(
-                  propdefname,
-                  1,min(reqalign,SizeOf(PInt)),
-                  targetinfos[target_info.system]^.alignment.recordalignmin);
-                if ppo_indexed in tpropertysym(sym).propoptions then
-                  proctypesinfo:=$40
-                else
-                  proctypesinfo:=0;
-                maybe_add_comment(tcb,#9'type info');
-                write_rtti_reference(tcb,tpropertysym(sym).propdef,fullrtti);
-                maybe_add_comment(tcb,#9'read access');
-                writeaccessproc(palt_read,0,0);
-                maybe_add_comment(tcb,#9'write access');
-                writeaccessproc(palt_write,2,0);
-                { is it stored ? }
-                maybe_add_comment(tcb,#9'stored ?');
-                if not(ppo_stored in tpropertysym(sym).propoptions) then
+                if extended_rtti then
                   begin
-                    { no, so put a constant zero }
-                    tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype);
-                    proctypesinfo:=proctypesinfo or (3 shl 4);
+                    {
+                      TPropInfoEx = record
+                        Flags: Byte;
+                        Info: PPropInfo;
+                        // AttrData: TAttrData
+                      end;
+                    }
+                    maybe_add_comment(tcb,'RTTI: begin property '+sym.prettyname);
+                    tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+                      targetinfos[target_info.system]^.alignment.recordalignmin);
+                    { write visiblity flags for extended RTTI }
+                    maybe_add_comment(tcb,#9'visibility flags');
+                    tcb.emit_ord_const(byte(visibility_to_rtti_flags(sym.visibility)),u8inttype);
+                    { create separate constant builder }
+                    current_asmdata.getglobaldatalabel(tbllab);
+                    tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
+                    { write TPropInfo record }
+                    tbldef:=write_propinfo_data(tbltcb,tpropertysym(sym));
+                    current_asmdata.asmlists[al_rtti].concatlist(
+                      tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
+                    );
+                    tbltcb.free;
+                    { write the pointer to the prop info }
+                    maybe_add_comment(tcb,#9'property info reference');
+                    tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
+                    { end record }
+                    tcb.end_anonymous_record;
+                    maybe_add_comment(tcb,'RTTI: end property '+sym.prettyname);
                   end
                 else
-                  writeaccessproc(palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
-                maybe_add_comment(tcb,#9'index');
-                tcb.emit_ord_const(tpropertysym(sym).index,u32inttype);
-                maybe_add_comment(tcb,#9'default');
-                tcb.emit_ord_const(tpropertysym(sym).default,u32inttype);
-                maybe_add_comment(tcb,#9'property index');
-                propnameitem:=TPropNameListItem(propnamelist.Find(tpropertysym(sym).name));
-                if not assigned(propnameitem) then
-                  internalerror(200512201);
-                tcb.emit_ord_const(propnameitem.propindex,u16inttype);
-                maybe_add_comment(tcb,#9'proc types');
-                tcb.emit_ord_const(proctypesinfo,u8inttype);
-
-                { write reference to attribute table }
-                maybe_add_comment(tcb,#9'attributes');
-                write_attribute_data(tcb,tpropertysym(sym).rtti_attribute_list);
-
-                { Write property name }
-                maybe_add_comment(tcb,#9'name');
-                tcb.emit_shortstring_const(tpropertysym(sym).realname);
-
-                tcb.end_anonymous_record;
-                maybe_add_comment(tcb,'RTTI: end property '+sym.prettyname);
-             end;
+                  write_propinfo_data(tcb,tpropertysym(sym));
+              end;
           end;
         tcb.end_anonymous_record;
       end;
@@ -1443,8 +1645,22 @@ implementation
             tcb.free;
           end;
 
+
+          procedure write_extended_property_table;
+          var
+            propnamelist: TFPHashObjectList;
+            visibilities: tvisibilities;
+          begin
+            propnamelist:=TFPHashObjectList.Create;
+            visibilities:=def.rtti_visibilities_for_option(ro_properties);
+            collect_propnamelist(propnamelist,def,visibilities);
+            properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
+            propnamelist.free;
+          end;
+
         var
           oplab : tasmlabel;
+
         begin
            write_header(tcb,def,tkRecord);
            { need extra reqalign record, because otherwise the u32 int will
@@ -1489,6 +1705,13 @@ implementation
              end;
 
            fields_write_rtti_data(tcb,def,rt);
+           { write extended rtti }
+           if rt=fullrtti then
+             begin
+               write_extended_field_table(tcb,def,defaultpacking);
+               write_extended_method_table(tcb,def,defaultpacking);
+               write_extended_property_table;
+             end;
            tcb.end_anonymous_record;
            tcb.end_anonymous_record;
 
@@ -1658,13 +1881,25 @@ implementation
             tcb.emit_ord_const(def.size, u32inttype);
           end;
 
+          procedure objectdef_extended_rtti_class(def:tobjectdef);
+          var
+            propnamelist : TFPHashObjectList;
+            visibilities : tvisibilities;
+          begin
+            propnamelist:=TFPHashObjectList.Create;
+            visibilities:=def.rtti_visibilities_for_option(ro_properties);
+            collect_propnamelist(propnamelist,def,visibilities);
+            properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
+            propnamelist.free;
+          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);
+            collect_propnamelist(propnamelist,def,[vis_published]);
 
             tcb.begin_anonymous_record('',defaultpacking,reqalign,
               targetinfos[target_info.system]^.alignment.recordalignmin);
@@ -1704,7 +1939,10 @@ implementation
             tcb.emit_shortstring_const(current_module.realmodulename^);
 
             { write published properties for this object }
-            published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
+            properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
+
+            { write extended properties }
+            objectdef_extended_rtti_class(def);
 
             tcb.end_anonymous_record;
 
@@ -1721,7 +1959,7 @@ implementation
           begin
             { Collect unique property names with nameindex }
             propnamelist:=TFPHashObjectList.Create;
-            collect_propnamelist(propnamelist,def);
+            collect_propnamelist(propnamelist,def,[vis_published]);
 
             tcb.begin_anonymous_record('',defaultpacking,reqalign,
               targetinfos[target_info.system]^.alignment.recordalignmin);
@@ -1765,10 +2003,10 @@ implementation
               end;
 
             { write published properties for this object }
-            published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
+            properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
 
             { write published methods for this interface }
-            write_methods(tcb,def.symtable,[vis_published]);
+            write_methods(tcb,def.symtable,false,[vis_published]);
 
             tcb.end_anonymous_record;
             tcb.end_anonymous_record;

compiler/ncgvmt.pas

@@ -527,10 +527,18 @@ implementation
          count : longint;
          lists : tvmtasmoutput;
          pubmethodsarraydef: tarraydef;
+         datatcb: ttai_typedconstbuilder;
+         packrecords: longint;
       begin
+        // TODO(ryan): is extended method table packed?
+        if (tf_requires_proper_alignment in target_info.flags) then
+          packrecords:=0
+        else
+          packrecords:=1;
+
          count:=0;
          _class.symtable.SymList.ForEachCall(@do_count_published_methods,@count);
-         if count>0 then
+         if (count>0) or (_class.rtti.options[ro_methods]<>[]) then
            begin
               { in the list of the published methods (from objpas.inc):
                   tmethodnamerec = packed record
@@ -551,14 +559,19 @@ implementation
               lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsdef);
               { emit count field }
               lists.pubmethodstcb.emit_tai(Tai_const.Create_32bit(count),u32inttype);
-              { begin entries field (array) }
-              lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsarraydef);
-              { add all entries elements }
-              _class.symtable.SymList.ForEachCall(@do_gen_published_methods,@lists);
-              { end entries field (array) }
-              lists.pubmethodstcb.maybe_end_aggregate(pubmethodsarraydef);
+              if count>0 then
+                begin
+                  { begin entries field (array) }
+                  lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsarraydef);
+                  { add all entries elements }
+                  _class.symtable.SymList.ForEachCall(@do_gen_published_methods,@lists);
+                  { end entries field (array) }
+                  lists.pubmethodstcb.maybe_end_aggregate(pubmethodsarraydef);
+                end;
               { end methodnametable }
               lists.pubmethodstcb.maybe_end_aggregate(pubmethodsdef);
+              { write extended method rtti }
+              RTTIWriter.write_extended_method_table(lists.pubmethodstcb,_class);
               tcb.finish_internal_data_builder(lists.pubmethodstcb,lab,pubmethodsdef,sizeof(pint));
            end
          else
@@ -582,7 +595,9 @@ implementation
         classdef: tobjectdef;
         classtabledef: trecorddef;
       begin
+        classtable:=nil;
         classtablelist:=TFPList.Create;
+        classtabledef:=nil;
         { retrieve field info fields }
         fieldcount:=0;
         for i:=0 to _class.symtable.SymList.Count-1 do
@@ -601,7 +616,7 @@ implementation
              end;
           end;
 
-        if fieldcount>0 then
+        if (fieldcount>0) or (_class.rtti.options[ro_fields]<>[]) then
           begin
             if (tf_requires_proper_alignment in target_info.flags) then
               packrecords:=0
@@ -609,23 +624,26 @@ implementation
               packrecords:=1;
 
             { generate the class table }
-            tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,_class.vmt_mangledname,datatcb,classtable);
-            datatcb.begin_anonymous_record('$fpc_intern_classtable_'+tostr(classtablelist.Count-1),
-              packrecords,1,
-              targetinfos[target_info.system]^.alignment.recordalignmin);
-            datatcb.emit_tai(Tai_const.Create_16bit(classtablelist.count),u16inttype);
-            for i:=0 to classtablelist.Count-1 do
+            if classtablelist.count>0 then
               begin
-                classdef:=tobjectdef(classtablelist[i]);
-                { type of the field }
-                datatcb.queue_init(voidpointertype);
-                { reference to the vmt }
-                datatcb.queue_emit_asmsym(
-                  current_asmdata.RefAsmSymbol(classdef.vmt_mangledname,AT_DATA,true),
-                  tfieldvarsym(classdef.vmt_field).vardef);
+                tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,_class.vmt_mangledname,datatcb,classtable);
+                datatcb.begin_anonymous_record('$fpc_intern_classtable_'+tostr(classtablelist.Count-1),
+                  packrecords,1,
+                  targetinfos[target_info.system]^.alignment.recordalignmin);
+                datatcb.emit_tai(Tai_const.Create_16bit(classtablelist.count),u16inttype);
+                for i:=0 to classtablelist.Count-1 do
+                  begin
+                    classdef:=tobjectdef(classtablelist[i]);
+                    { type of the field }
+                    datatcb.queue_init(voidpointertype);
+                    { reference to the vmt }
+                    datatcb.queue_emit_asmsym(
+                      current_asmdata.RefAsmSymbol(classdef.vmt_mangledname,AT_DATA,true),
+                      tfieldvarsym(classdef.vmt_field).vardef);
+                  end;
+                classtabledef:=datatcb.end_anonymous_record;
+                tcb.finish_internal_data_builder(datatcb,classtable,classtabledef,sizeof(pint));
               end;
-            classtabledef:=datatcb.end_anonymous_record;
-            tcb.finish_internal_data_builder(datatcb,classtable,classtabledef,sizeof(pint));
 
             { write fields }
             {
@@ -648,36 +666,47 @@ implementation
             datatcb.begin_anonymous_record('',packrecords,1,
               targetinfos[target_info.system]^.alignment.recordalignmin);
             datatcb.emit_tai(Tai_const.Create_16bit(fieldcount),u16inttype);
-            datatcb.emit_tai(Tai_const.Create_sym(classtable),cpointerdef.getreusable(classtabledef));
-            for i:=0 to _class.symtable.SymList.Count-1 do
+            if classtable<>nil then
+              datatcb.emit_tai(Tai_const.Create_sym(classtable),cpointerdef.getreusable(classtabledef))
+            else
+              datatcb.emit_tai(tai_const.Create_nil_codeptr,voidpointertype);
+            if fieldcount>0 then
               begin
-                sym:=tsym(_class.symtable.SymList[i]);
-                if (sym.typ=fieldvarsym) and
-                   not(sp_static in sym.symoptions) and
-                  (sym.visibility=vis_published) then
+                for i:=0 to _class.symtable.SymList.Count-1 do
                   begin
-                    {
-                      TFieldInfo =
-                     $ifndef FPC_REQUIRES_PROPER_ALIGNMENT
-                      packed
-                     $endif FPC_REQUIRES_PROPER_ALIGNMENT
-                      record
-                        FieldOffset: SizeUInt;
-                        ClassTypeIndex: Word;
-                        Name: ShortString;
+                    sym:=tsym(_class.symtable.SymList[i]);
+                    if (sym.typ=fieldvarsym) and
+                       not(sp_static in sym.symoptions) and
+                      (sym.visibility=vis_published) then
+                      begin
+                        { skip non-object defs for legacy rtti }
+                        if tfieldvarsym(sym).vardef.typ<>objectdef then
+                          continue;
+                        {
+                          TFieldInfo =
+                         $ifndef FPC_REQUIRES_PROPER_ALIGNMENT
+                          packed
+                         $endif FPC_REQUIRES_PROPER_ALIGNMENT
+                          record
+                            FieldOffset: SizeUInt;
+                            ClassTypeIndex: Word;
+                            Name: ShortString;
+                          end;
+                        }
+                        datatcb.begin_anonymous_record('$fpc_intern_fieldinfo_'+tostr(length(tfieldvarsym(sym).realname)),packrecords,1,
+                          targetinfos[target_info.system]^.alignment.recordalignmin);
+                        datatcb.emit_tai(Tai_const.Create_sizeint(tfieldvarsym(sym).fieldoffset),sizeuinttype);
+                        classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
+                        if classindex=-1 then
+                          internalerror(200611033);
+                        datatcb.emit_tai(Tai_const.Create_16bit(classindex+1),u16inttype);
+                        datatcb.emit_shortstring_const(tfieldvarsym(sym).realname);
+                        datatcb.end_anonymous_record;
                       end;
-                    }
-                    datatcb.begin_anonymous_record('$fpc_intern_fieldinfo_'+tostr(length(tfieldvarsym(sym).realname)),packrecords,1,
-                      targetinfos[target_info.system]^.alignment.recordalignmin);
-                    datatcb.emit_tai(Tai_const.Create_sizeint(tfieldvarsym(sym).fieldoffset),sizeuinttype);
-                    classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
-                    if classindex=-1 then
-                      internalerror(200611033);
-                    datatcb.emit_tai(Tai_const.Create_16bit(classindex+1),u16inttype);
-                    datatcb.emit_shortstring_const(tfieldvarsym(sym).realname);
-                    datatcb.end_anonymous_record;
                   end;
               end;
+            { append the extended rtti table }
+            RTTIWriter.write_extended_field_table(datatcb,_class);
             fieldtabledef:=datatcb.end_anonymous_record;
             tcb.finish_internal_data_builder(datatcb,lab,fieldtabledef,sizeof(pint));
           end

compiler/symconst.pas

@@ -835,7 +835,9 @@ type
     itb_objc_fr_category,
     itb_objc_fr_meta_class,
     itb_objc_fr_class,
-    itp_vardisp_calldesc
+    itp_vardisp_calldesc,
+    itp_extended_rtti_table,
+    itp_extended_rtti_field
   );
 
   { The order is from low priority to high priority,
@@ -988,7 +990,9 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
        '$objc_fr_category$',
        '$objc_fr_meta_class$',
        '$objc_fr_class$',
-       '$itp_vardisp_calldesc$'
+       '$itp_vardisp_calldesc$',
+       '$extended_rtti_table$',
+       '$extended_rtti_field$'
      );