View Issue Details

IDProjectCategoryView StatusLast Update
0038964FPCCompilerpublic2021-06-05 21:56
ReporterRyan Joseph Assigned To 
PrioritynormalSeverityminorReproducibilityN/A
Status newResolutionopen 
Product Version3.3.1 
Summary0038964: [PATCH] Extended RTTI
DescriptionI am working on implementing the compiler side of extended RTTI and will putting up patches here for review/discussion although the feature is not complete yet and will require additional units in the RTL which I will not be included here.
Additional Informationhttp://docwiki.embarcadero.com/RADStudio/Sydney/en/RTTI_directive_(Delphi)
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Ryan Joseph

2021-06-05 17:58

reporter   ~0131164

Rough draft of the basic outline
patch.diff (42,048 bytes)   
diff --git a/compiler/fmodule.pas b/compiler/fmodule.pas
index 3653ea7996..bb8b857a39 100644
--- a/compiler/fmodule.pas
+++ b/compiler/fmodule.pas
@@ -233,6 +233,9 @@ interface
            -- actual type: tnode (but fmodule should not depend on node) }
          tcinitcode     : tobject;
 
+        { the current extended rtti directive }
+        pending_rtti : trtti_directive;
+
         {create creates a new module which name is stored in 's'. LoadedFrom
         points to the module calling it. It is nil for the first compiled
         module. This allow inheritence of all path lists. MUST pay attention
@@ -754,6 +757,8 @@ implementation
 {$ifdef MEMDEBUG}
         memsymtable.stop;
 {$endif}
+        if assigned(pending_rtti) then
+          pending_rtti.free;
         inherited Destroy;
       end;
 
diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas
index 6551b9585e..79310b2e81 100644
--- a/compiler/ncgrtti.pas
+++ b/compiler/ncgrtti.pas
@@ -49,9 +49,8 @@ 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 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;
@@ -61,7 +60,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);
@@ -71,6 +70,8 @@ interface
       public
         constructor create;
         procedure write_rtti(def:tdef;rt:trttitype);
+        procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
+        procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
         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;
@@ -111,6 +112,20 @@ implementation
        end;
 
 
+    function visibility_to_rtti(vis: tvisibility): trtti_visibility;
+      begin
+        case vis of
+          vis_private: result:=vcprivate;
+          vis_protected: result:=vcprotected;
+          vis_public: result:=vcpublic;
+          vis_published: result:=vcpublished;
+          otherwise
+            // TODO: make real error!
+            internalerror(1);
+        end;
+      end;
+
+
     procedure write_persistent_type_info(st: tsymtable; is_global: boolean);
       var
         i : longint;
@@ -173,7 +188,8 @@ implementation
                 is_global and
                 not is_objc_class_or_protocol(def)
                ) or
-               (ds_rtti_table_used in def.defstates) then
+               (ds_rtti_table_used in def.defstates) or
+               ((def.typ=recorddef) and (trecorddef(def).has_extended_rtti)) then
               RTTIWriter.write_rtti(def,fullrtti);
           end;
       end;
@@ -198,7 +214,7 @@ 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,
@@ -252,6 +268,10 @@ implementation
                       tcb.emit_ord_const(def.callerargareasize,ptrsinttype);
                       tcb.emit_pooled_shortstring_const_ref(sym.realname);
 
+                      { write visiblity section for extended RTTI }
+                      if extended_rtti then
+                        tcb.emit_ord_const(byte(visibility_to_rtti(sym.visibility)),u8inttype);
+
                       for k:=0 to def.paras.count-1 do
                         begin
                           para:=tparavarsym(def.paras[k]);
@@ -689,6 +709,86 @@ 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(romethods,tprocdef(sym.procdeflist[j]).visibility) then
+                  inc(methodcount);
+            end;
+
+        tcb.begin_anonymous_record('',packrecords,1,
+          targetinfos[target_info.system]^.alignment.recordalignmin);
+        { emit method count }
+        tcb.emit_tai(Tai_const.Create_16bit(methodcount),u16inttype);
+        { emit method entries (array) }
+        if methodcount>0 then
+          write_methods(tcb,def.symtable,true,def.rtti_visibilities_for_option(romethods));
+        tcb.end_anonymous_record;
+      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(rofields, sym.visibility) then
+              list.add(sym);
+          end;
+        {
+          TExtendedFieldTable = record
+            FieldCount: Word;
+            Fields: array[0..0] of TExtendedFieldInfo;
+          end;
+        }
+        tcb.begin_anonymous_record(
+          internaltypeprefixName[itp_rtti_header]+tostr(list.count),packrecords,1,
+          targetinfos[target_info.system]^.alignment.recordalignmin);
+        tcb.emit_tai(Tai_const.Create_16bit(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('$fpc_intern_ext_fieldinfo',packrecords,1,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(byte(visibility_to_rtti(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.published_write_rtti(st:tsymtable;rt:trttitype);
       var
         i   : longint;
@@ -712,35 +812,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
@@ -754,7 +842,7 @@ 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;
@@ -858,15 +946,30 @@ 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;
+
       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"
@@ -908,8 +1011,18 @@ implementation
                 { write reference to attribute table }
                 write_attribute_data(tcb,tpropertysym(sym).rtti_attribute_list);
 
-                { Write property name }
-                tcb.emit_shortstring_const(tpropertysym(sym).realname);
+                if extended_rtti then
+                  begin
+                    { write visiblity section for extended RTTI }
+                    tcb.emit_ord_const(byte(visibility_to_rtti(sym.visibility)),u8inttype);
+                    { write property name as pshortstring }
+                    tcb.emit_pooled_shortstring_const_ref(sym.realname);
+                  end
+                else
+                  begin
+                    { Write property name }
+                    tcb.emit_shortstring_const(sym.realname);
+                  end;
 
                 tcb.end_anonymous_record;
              end;
@@ -1400,6 +1513,18 @@ implementation
             tcb.free;
           end;
 
+          procedure write_extended_property_table;
+          var
+            propnamelist: TFPHashObjectList;
+            visibilities: tvisibilities;
+          begin
+            propnamelist:=TFPHashObjectList.Create;
+            visibilities:=def.rtti_visibilities_for_option(roproperties);
+            collect_propnamelist(propnamelist,def,visibilities);
+            properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
+            propnamelist.free;
+          end;
+
         begin
            write_header(tcb,def,tkRecord);
            { need extra reqalign record, because otherwise the u32 int will
@@ -1440,6 +1565,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;
 
@@ -1607,13 +1739,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(roproperties);
+            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);
@@ -1643,7 +1787,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;
 
@@ -1660,7 +1807,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);
@@ -1701,10 +1848,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;
@@ -2191,6 +2338,7 @@ implementation
               if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
                 fields_write_rtti(tobjectdef(def).symtable,rt)
               else
+                // TODO: make this work for extended rtti visibility
                 published_write_rtti(tobjectdef(def).symtable,rt);
 
               if (rt=fullrtti) then
diff --git a/compiler/ncgvmt.pas b/compiler/ncgvmt.pas
index e887deea75..57bdbacc07 100644
--- a/compiler/ncgvmt.pas
+++ b/compiler/ncgvmt.pas
@@ -529,10 +529,18 @@ implementation
          count : longint;
          lists : tvmtasmoutput;
          pubmethodsarraydef: tarraydef;
+         datatcb: ttai_typedconstbuilder;
+         packrecords: longint;
       begin
+        // TODO: 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[romethods]<>[]) then
            begin
               { in the list of the published methods (from objpas.inc):
                   tmethodnamerec = packed record
@@ -553,14 +561,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,packrecords);
               tcb.finish_internal_data_builder(lists.pubmethodstcb,lab,pubmethodsdef,sizeof(pint));
            end
          else
@@ -569,7 +582,7 @@ implementation
              pubmethodsdef:=nil;
            end;
       end;
-
+      
 
     procedure TVMTWriter.generate_field_table(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out fieldtabledef: trecorddef);
       var
@@ -584,6 +597,7 @@ implementation
         classdef: tobjectdef;
         classtabledef: trecorddef;
       begin
+        classtable:=nil;
         classtablelist:=TFPList.Create;
         { retrieve field info fields }
         fieldcount:=0;
@@ -594,8 +608,9 @@ implementation
                not(sp_static in sym.symoptions) and
                (sym.visibility=vis_published) then
              begin
+                { legacy fields can be objectdef only }
                 if tfieldvarsym(sym).vardef.typ<>objectdef then
-                  internalerror(200611032);
+                  continue;
                 classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
                 if classindex=-1 then
                   classtablelist.Add(tfieldvarsym(sym).vardef);
@@ -603,7 +618,7 @@ implementation
              end;
           end;
 
-        if fieldcount>0 then
+        if (fieldcount>0) or (_class.rtti_options[rofields]<>[]) then
           begin
             if (tf_requires_proper_alignment in target_info.flags) then
               packrecords:=0
@@ -611,23 +626,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 }
             {
@@ -650,36 +668,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,packrecords);
             fieldtabledef:=datatcb.end_anonymous_record;
             tcb.finish_internal_data_builder(datatcb,lab,fieldtabledef,sizeof(pint));
           end
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index b490cd18f3..b84530da6d 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -1614,6 +1614,14 @@ implementation
               end
             else
               olddef:=nil;
+              
+            { apply $RTTI directive to current object }
+            if current_module.pending_rtti<>nil then
+              begin
+                current_structdef.appy_rtti_directive(current_module.pending_rtti);
+                current_module.pending_rtti.free;
+                current_module.pending_rtti:=nil;
+              end;
 
             { parse and insert object members }
             parse_object_members;
diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
index 446542e519..17ba42e4fd 100644
--- a/compiler/pdecvar.pas
+++ b/compiler/pdecvar.pas
@@ -1822,6 +1822,7 @@ implementation
                    try_read_field_external_sc(sc);
                end;
              if (visibility=vis_published) and
+                not(vcpublished in current_structdef.rtti_options[rofields]) and
                 not(is_class(hdef)) then
                begin
                  MessagePos(tfieldvarsym(sc[0]).fileinfo,parser_e_cant_publish_that);
@@ -1830,6 +1831,7 @@ implementation
 
              if (visibility=vis_published) and
                 not(oo_can_have_published in tobjectdef(hdef).objectoptions) and
+                not(vcpublished in current_structdef.rtti_options[rofields]) and
                 not(m_delphi in current_settings.modeswitches) then
                begin
                  MessagePos(tfieldvarsym(sc[0]).fileinfo,parser_e_only_publishable_classes_can_be_published);
diff --git a/compiler/ptype.pas b/compiler/ptype.pas
index 18af2688ad..80f6cd83a1 100644
--- a/compiler/ptype.pas
+++ b/compiler/ptype.pas
@@ -797,7 +797,9 @@ implementation
                      end;
                    _PUBLISHED :
                      begin
-                       Message(parser_e_no_record_published);
+                       { records can have published sections if extended RTTI is enabled }
+                       if not current_structdef.has_published_rtti then
+                         Message(parser_e_no_record_published);
                        consume(_PUBLISHED);
                        current_structdef.symtable.currentvisibility:=vis_published;
                        fields_allowed:=true;
@@ -1048,7 +1050,18 @@ implementation
          { in non-Delphi modes we need a strict private symbol without type
            count and type parameters in the name to simply resolving }
          maybe_insert_generic_rename_symbol(n,genericlist);
-
+        { apply $RTTI directive to current object }
+        if (current_module.pending_rtti<>nil) then
+          begin
+            { records don't allow the inherit clause }
+            if current_module.pending_rtti.clause=vcInherit then
+              // TODO: make a real error!
+              internalerror(1)
+            else
+              current_structdef.appy_rtti_directive(current_module.pending_rtti);
+            current_module.pending_rtti.free;
+            current_module.pending_rtti:=nil;
+          end;
          if m_advanced_records in current_settings.modeswitches then
            begin
              parse_record_members(recsym);
diff --git a/compiler/scanner.pas b/compiler/scanner.pas
index 9632471f24..f147fdf137 100644
--- a/compiler/scanner.pas
+++ b/compiler/scanner.pas
@@ -2667,6 +2667,162 @@ type
          end;
       end;
 
+    procedure dir_rtti;
+      const
+        DefaultFieldRttiVisibility = [vcPrivate..vcPublished];
+        DefaultMethodRttiVisibility = [vcPublic..vcPublished];
+        DefaultPropertyRttiVisibility = [vcPublic..vcPublished];
+
+      procedure consume(i : ttoken);
+        begin
+          current_scanner.readtoken(false);
+          if (token<>i) and (idtoken<>i) then
+            if token=_id then
+              Message2(scan_f_syn_expected,tokeninfo^[i].str,'identifier '+pattern)
+            else
+              Message2(scan_f_syn_expected,tokeninfo^[i].str,tokeninfo^[token].str)
+        end;
+
+      function consume_id: string;
+        var
+          last: char;
+        begin
+          last:=c;
+          current_scanner.readtoken(false);
+          if (token<>_ID) then
+            Message2(scan_f_syn_expected,tokeninfo^[_ID].str,last);
+          result:=pattern;
+        end;
+
+      procedure rtti_error(msg: string);
+        begin
+          writeln(msg);
+          internalerror(0);
+        end;
+
+      function read_rtti_options: trtti_visibilities;
+        var
+          id: string;
+        begin
+          result:=[];
+
+          consume(_LKLAMMER);
+          { first try to read explicit constants }
+          current_scanner.skipspace;
+          id:=current_scanner.readid;
+          if id<>'' then
+            begin
+              case id of
+                'DEFAULTFIELDRTTIVISIBILITY':
+                  result:=DefaultFieldRttiVisibility;
+                'DEFAULTMETHODRTTIVISIBILITY':
+                  result:=DefaultMethodRttiVisibility;
+                'DEFAULTPROPERTYRTTIVISIBILITY':
+                  result:=DefaultPropertyRttiVisibility;
+                otherwise
+                  rtti_error('invalid default visibility '+id);
+              end;
+              consume(_RKLAMMER);
+              exit;
+            end;
+          consume(_LECKKLAMMER);
+
+          current_scanner.skipspace;
+          id:=current_scanner.readid;
+          while id<>'' do
+            begin
+              case id of
+                'VCPRIVATE':
+                  if not(vcPrivate in result) then
+                    include(result, vcPrivate)
+                  else
+                    rtti_error('duplicate visibility '+id);
+                'VCPROTECTED':
+                  if not(vcProtected in result) then
+                    include(result, vcProtected)
+                  else
+                    rtti_error('duplicate visibility '+id);
+                'VCPUBLIC':
+                  if not(vcPublic in result) then
+                    include(result, vcPublic)
+                  else
+                    rtti_error('duplicate visibility '+id);
+                'VCPUBLISHED':
+                  if not(vcPublished in result) then
+                    include(result, vcPublished)
+                  else
+                    rtti_error('duplicate visibility '+id);
+                otherwise
+                  rtti_error('invalid visibility '+id);
+              end;
+              { read next visibility section }
+              current_scanner.skipspace;
+              current_scanner.readtoken(false);
+              case token of
+                _COMMA:
+                  begin
+                    current_scanner.skipspace;
+                    id:=consume_id;
+                  end;
+                _RECKKLAMMER:
+                  break;
+              end;
+            end;
+
+          { nothing was found so consume the trailing _RECKKLAMMER }
+          if result=[] then
+            consume(_RECKKLAMMER);
+          consume(_RKLAMMER);
+        end;
+
+      var
+        id: string;
+        mac: tmacro;
+        dir: trtti_directive;
+      begin
+        dir:=trtti_directive.create;
+
+        current_scanner.skipspace;
+        id:=consume_id;
+        case id of
+          'INHERIT':
+            dir.clause:=vcInherit;
+          'EXPLICIT':
+            dir.clause:=vcExplicit;
+          otherwise
+            rtti_error('invalid rtti clause '+id);
+        end;
+
+        current_scanner.skipspace;
+        if dir.clause=vcExplicit then
+          id:=consume_id
+        else
+          id:=current_scanner.readid;
+        while id<>'' do
+          begin
+            case id of
+              'METHODS':
+                dir.options[roMethods]:=read_rtti_options;
+              'PROPERTIES':
+                dir.options[roProperties]:=read_rtti_options;
+              'FIELDS':
+                dir.options[roFields]:=read_rtti_options;
+              otherwise
+                rtti_error('invalid rtti option '+id);
+            end;
+            current_scanner.skipspace;
+            id:=current_scanner.readid;
+          end;
+
+        { make sure the directive is terminated }
+        if (id='') and (c<>'}') then
+          rtti_error('expected end of rtti direction');
+
+        { set the directive }
+        if current_module.pending_rtti<>nil then  
+          current_module.pending_rtti.free;
+        current_module.pending_rtti:=dir;
+      end;
 
 {*****************************************************************************
                             Preprocessor writing
@@ -5860,6 +6016,9 @@ exit_label:
         AddConditional('ELSEIF',directive_all, @dir_elseif);
         AddConditional('ENDIF',directive_all, @dir_endif);
 
+        { Extended RTTI }
+        AddConditional('RTTI',directive_all, @dir_rtti);
+
         { Directives and conditionals for all modes except mode macpas}
         AddDirective('INCLUDE',directive_turbo, @dir_include);
         AddDirective('LIBPREFIX',directive_turbo, @dir_libprefix);
diff --git a/compiler/symbase.pas b/compiler/symbase.pas
index 13712edbd9..1a6a059442 100644
--- a/compiler/symbase.pas
+++ b/compiler/symbase.pas
@@ -143,6 +143,15 @@ interface
          function getcopyuntil(finalst: TSymtable): TSymtablestack;
        end;
 
+       { extended rtti directive }
+       trtti_clause = (vcNone,vcInherit,vcExplicit);
+       trtti_visibility = (vcPrivate,vcProtected,vcPublic,vcPublished);
+       trtti_visibilities = set of trtti_visibility;
+       trtti_option = (roMethods,roFields,roProperties);
+       trtti_directive = class
+         clause: trtti_clause;
+         options: array[trtti_option] of trtti_visibilities;
+       end;
 
     var
        initialmacrosymtable: TSymtable;   { macros initially defined by the compiler or
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index fca90803bf..4f207d1fe7 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -339,6 +339,9 @@ interface
           { for targets that initialise typed constants via explicit assignments
             instead of by generating an initialised data sectino }
           tcinitcode     : tnode;
+          { extended rtti }
+          rtti_clause: trtti_clause;
+          rtti_options: array[trtti_option] of trtti_visibilities;
           constructor create(const n:string; dt:tdeftyp;doregister:boolean);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -360,6 +363,12 @@ interface
           function contains_float_field : boolean;
           { check if the symtable contains a field that spans an aword boundary }
           function contains_cross_aword_field: boolean;
+          { extended RTTI }
+          procedure appy_rtti_directive(dir: trtti_directive); virtual;
+          function is_visible_for_rtti(option: trtti_option; vis: tvisibility): boolean; inline;
+          function rtti_visibilities_for_option(option: trtti_option): tvisibilities; inline;
+          function has_extended_rtti: boolean; inline;
+          function has_published_rtti: boolean; inline;
        end;
 
        pvariantrecdesc = ^tvariantrecdesc;
@@ -551,6 +560,7 @@ interface
           function check_objc_types: boolean;
           { C++ }
           procedure finish_cpp_data;
+          procedure appy_rtti_directive(dir: trtti_directive); override;
        end;
        tobjectdefclass = class of tobjectdef;
 
@@ -4928,6 +4938,57 @@ implementation
         result:=false;
       end;
 
+
+    procedure tabstractrecorddef.appy_rtti_directive(dir: trtti_directive);
+      begin
+        rtti_clause:=dir.clause;
+        rtti_options:=dir.options;
+      end;
+
+
+    function tabstractrecorddef.is_visible_for_rtti(option: trtti_option; vis: tvisibility): boolean;
+      begin
+        case vis of
+          vis_private:   result:=vcprivate in rtti_options[option];
+          vis_protected: result:=vcprotected in rtti_options[option];
+          vis_public:    result:=vcpublic in rtti_options[option];
+          vis_published: result:=vcpublished in rtti_options[option];
+          otherwise
+            result:=false;
+        end;
+      end;
+
+
+    function tabstractrecorddef.rtti_visibilities_for_option(option: trtti_option): tvisibilities;
+      begin
+        result:=[];
+        if vcprivate in rtti_options[option] then
+          include(result,vis_private);
+        if vcprotected in rtti_options[option] then
+          include(result,vis_protected);
+        if vcpublic in rtti_options[option] then
+          include(result,vis_public);
+        if vcpublished in rtti_options[option] then
+          include(result,vis_published);
+      end;
+
+
+    function tabstractrecorddef.has_extended_rtti: boolean;
+      begin
+        result := (rtti_options[roFields]<>[]) or
+                  (rtti_options[roMethods]<>[]) or
+                  (rtti_options[roProperties]<>[]);
+      end;
+
+
+    function tabstractrecorddef.has_published_rtti: boolean;
+      begin
+        result := (vcPublished in rtti_options[roFields]) or
+                  (vcPublished in rtti_options[roMethods]) or
+                  (vcPublished in rtti_options[roProperties]);
+      end;
+
+
 {$ifdef DEBUG_NODE_XML}
     procedure tabstractrecorddef.XMLPrintDefData(var T: Text; Sym: TSym);
 
@@ -8465,6 +8526,19 @@ implementation
         self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
       end;
 
+
+    procedure tobjectdef.appy_rtti_directive(dir: trtti_directive);
+      begin
+        rtti_clause:=dir.clause;
+        rtti_options:=dir.options;
+        if (dir.clause=vcInherit) and assigned(childof) and (childof.rtti_clause<>vcNone) then
+          begin
+            rtti_options[roMethods] := rtti_options[roMethods] + childof.rtti_options[roMethods];
+            rtti_options[roFields] := rtti_options[roFields] + childof.rtti_options[roFields];
+            rtti_options[roProperties] := rtti_options[roProperties] + childof.rtti_options[roProperties];
+          end;
+      end;
+
 {$ifdef DEBUG_NODE_XML}
     function TObjectDef.XMLPrintType: ansistring;
       begin
patch.diff (42,048 bytes)   

Ryan Joseph

2021-06-05 18:38

reporter   ~0131165

and here is the GitHub branch which may be easier to use. https://github.com/genericptr/freepascal/tree/extended_rtti

Sven Barth

2021-06-05 19:27

manager   ~0131166

Various remarks:

- tabstractrecorddef related:
  - the has_published_rtti is not needed, because the $RTTI doesn't add published properties to records nor does it enabled published properties for classes if the $M directive is not given (thus your changes in ptype and pdecvar are not needed)
  - you have a typo in your apply_rtti_directive method (missing 'l')
  - I'm not yet sure whether the behavior of “inherit” is correct, cause my tests back then didn't match the documentation... (but considering that we're normally relying on the documentation and not the behavior of the Delphi implementation your implementation at least matches the documentation... *shrugs*)

- regarding the $RTTI directive (and related parts):
  - the vc* constants are only intended for writing the RTTI data (thus inside TRTTIWriter), you don't use them for trtti_visibility (or in dir_rtti), instead you need to cleanly declare the enum members as any other enums in the compiler: in this case it would be e.g. rv_private, etc.; also each element gets its own line
  - the $RTTI directive does not have a “pending” concept, instead it's a “state” and all types declared after a $RTTI directive will use that state until its changed again
  - you don't need to use a class cause in the end every tabstractrecorddef will have such an RTTI state associated with it even if e.g. interfaces won't make use of it
  - you need to write the RTTI state to the PPU and restore it from there
  - for records “inherited” means the same as “explicit”, not an internal error
  - the $RTTI directive is not a core scanner directive, thus it belongs into scandir.pas, not scanner.pas
  - also it's a directive, not a conditional
  - in dir_rtti you don't need the Default* constants and you don't need the vc* constants, instead you need to use the scanner's expression parser (current_scanner.readpreprocint) which handles constants as well, though you might need to add a readpreprocset so that everything is handled correctly, because the following use is valid in Delphi as well:
  
const
  vcDefaultVis = vcPublic;

  MyDefaultVis = [vcPrivate, vcProtected];

{$RTTI EXPLICIT FIELDS([vcDefaultVis]) METHODS(MyDefaultVis)}


- regarding the writing of the RTTI:
  - TVMTWriter.generate_field_table: published fields can still only be objectdefs, so the internal error in the initial loop stays
  - visibility_to_rtti: you need to handle vis_strictprivate and vis_strictprotected as well (they should be mapped to private and protected respectively though I personally would like to also have an additional bit to denote this "strict" or not...)
  - it needs to be checked whether Delphi also generates extended RTTI for class and static methods, properties and fields
  - the change in write_persistent_type_info is unnecessary, because (for now) the RTTI data is only supposed to be written if it is indeed used, thus if the TypeInfo() intrinsic is used on the type or its referenced either by a class' VMT or through another RTTI data (but the compiler already handles that as long as you adjust e.g. TRTTIWriter.published_write_rtti)
  
I think that's it so far... Most of the writing of the data itself at least appears to be correct.

ravi dion

2021-06-05 21:25

reporter   ~0131169

Is it this? https://foundation.freepascal.org/projects/project-1

Awesome work then!!! Thx

Ryan Joseph

2021-06-05 21:56

reporter   ~0131170

@ravi Yes, that's it but it's not even nearly complete yet nor is the companion RTL units ready (which another developer is doing). Once it's all done it will put here and submitted for merging.

Issue History

Date Modified Username Field Change
2021-06-05 17:58 Ryan Joseph New Issue
2021-06-05 17:58 Ryan Joseph Note Added: 0131164
2021-06-05 17:58 Ryan Joseph File Added: patch.diff
2021-06-05 18:38 Ryan Joseph Note Added: 0131165
2021-06-05 19:27 Sven Barth Note Added: 0131166
2021-06-05 21:25 ravi dion Note Added: 0131169
2021-06-05 21:56 Ryan Joseph Note Added: 0131170