* Store TExtRttiData for each type holding extended rtti data

 * Use the TExtRttiData to store a reference to the class attributes
 * Add a list with external name INITEXTRTTIUNITS which holds a
   reference to the ExtRttiData records from each unit

git-svn-id: branches/joost/classattributes@23147 -

compiler/aasmdata.pas

@@ -57,6 +57,7 @@ interface
         al_exports,
         al_resources,
         al_rtti,
+        al_ext_rtti,
         al_dwarf_frame,
         al_dwarf_info,
         al_dwarf_abbrev,
@@ -107,6 +108,7 @@ interface
         'al_exports',
         'al_resources',
         'al_rtti',
+        'al_ext_rtti',
         'al_dwarf_frame',
         'al_dwarf_info',
         'al_dwarf_abbrev',

compiler/ncgrtti.pas

@@ -28,6 +28,7 @@ interface
     uses
       cclasses,constexp,
       aasmbase,
+      ppu,
       symbase,symconst,symtype,symdef;
 
     type
@@ -45,16 +46,19 @@ interface
         procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
         procedure write_rtti_name(def:tdef);
         procedure write_rtti_data(def:tdef;rt:trttitype);
+        procedure write_ext_rtti_data(def:tdef);
         procedure write_child_rtti_data(def:tdef;rt:trttitype);
         function  ref_rtti(def:tdef;rt:trttitype):tasmsymbol;
         procedure write_header(def: tdef; typekind: byte);
         procedure write_string(const s: string);
         procedure maybe_write_align;
+        procedure write_ext_rtti(def:tdef;rt:trttitype);
       public
         procedure write_rtti(def:tdef;rt:trttitype);
         function  get_rtti_label(def:tdef;rt:trttitype):tasmsymbol;
         function  get_rtti_label_ord2str(def:tdef;rt:trttitype):tasmsymbol;
         function  get_rtti_label_str2ord(def:tdef;rt:trttitype):tasmsymbol;
+        procedure after_write_unit_extrtti_info(st: TSymtable);
       end;
 
     var
@@ -77,6 +81,8 @@ implementation
     const
        rttidefstate : array[trttitype] of tdefstate =
          (ds_rtti_table_written,ds_init_table_written,
+         { Extended RTTI}
+         symconst.ds_none,symconst.ds_none,
          { Objective-C related, does not pass here }
          symconst.ds_none,symconst.ds_none,
          symconst.ds_none,symconst.ds_none);
@@ -98,6 +104,23 @@ implementation
           current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
       end;
 
+    procedure TRTTIWriter.write_ext_rtti(def: tdef; rt: trttitype);
+      var
+        extrttilab : tasmsymbol;
+      begin
+        extrttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(extrtti),AB_GLOBAL,AT_DATA);
+
+        new_section(current_asmdata.asmlists[al_ext_rtti],sec_rodata,extrttilab.name,const_align(sizeof(pint)));
+        current_asmdata.asmlists[al_ext_rtti].concat(Tai_symbol.Create_global(extrttilab,0));
+
+        // Write reference to 'normal' typedata
+        current_asmdata.asmlists[al_ext_rtti].concat(Tai_const.Createname(tstoreddef(def).rtti_mangledname(fullrtti),0));
+
+        write_ext_rtti_data(def);
+        current_asmdata.asmlists[al_ext_rtti].concat(Tai_symbol_end.Create(extrttilab));
+        inc(def.owner.ExtRttiCount);
+      end;
+
     procedure TRTTIWriter.write_string(const s: string);
       begin
         current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(s)));
@@ -974,6 +997,38 @@ implementation
         end;
       end;
 
+    procedure TRTTIWriter.write_ext_rtti_data(def: tdef);
+
+    var
+      attributecount: byte;
+      attributeindex: byte;
+      attributeslab : tasmsymbol;
+
+    begin
+      attributeslab := nil;
+      if def.typ = objectdef then
+        begin
+          if assigned(tobjectdef(def).rtti_attributesdef) then
+            begin
+              attributecount:=tobjectdef(def).rtti_attributesdef.get_attribute_count;
+              attributeslab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(attribute),AB_GLOBAL,AT_DATA);
+              current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(attributeslab,0));
+              current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(attributecount));
+
+              for attributeindex:=0 to attributecount-1 do
+                begin
+                  current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(trtti_attribute(tobjectdef(def).rtti_attributesdef.rtti_attributes[attributeindex]).symbolname,0));
+                end;
+            end
+          else
+            attributecount:=0;
+        end
+      else
+        attributecount:=0;
+
+      current_asmdata.asmlists[al_ext_rtti].concat(Tai_const.Create_sym(attributeslab));
+    end;
+
     procedure TRTTIWriter.write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
 
         type Penumsym = ^Tenumsym;
@@ -1252,8 +1307,14 @@ implementation
         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(pint)));
+        { write reference to extended rtti }
+        if rt=fullrtti then
+          current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tstoreddef(def).rtti_mangledname(extrtti),0));
+
         current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(rttilab,0));
         write_rtti_data(def,rt);
+        if rt=fullrtti then
+          write_ext_rtti(def, rt);
         current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(rttilab));
         write_rtti_extrasyms(def,rt,rttilab);
       end;
@@ -1274,5 +1335,22 @@ implementation
         result:=current_asmdata.RefAsmSymbol(def.rtti_mangledname(rt)+'_s2o');
       end;
 
+    procedure TRTTIWriter.after_write_unit_extrtti_info(st: TSymtable);
+      var
+        startrtti  : TAsmSymbol;
+        s          : string;
+    begin
+      if st.extrtticount>0 then
+        begin
+          startrtti := current_asmdata.DefineAsmSymbol(make_mangledname('EXTR',current_module.localsymtable,''),AB_GLOBAL,AT_DATA);
+          s := current_module.realmodulename^;
+          current_asmdata.asmlists[al_ext_rtti].insert(Tai_string.Create(s));
+          current_asmdata.asmlists[al_ext_rtti].insert(Tai_const.Create_8bit(length(s)));
+          current_asmdata.asmlists[al_ext_rtti].insert(Tai_const.Create_aint(st.ExtRttiCount));
+          current_asmdata.asmlists[al_ext_rtti].insert(Tai_symbol.Create_global(startrtti,0));
+          current_module.flags:=current_module.flags+uf_extrtti;
+        end;
+    end;
+
 end.
 

compiler/ngenutil.pas

@@ -72,6 +72,7 @@ interface
 
       class function create_main_procdef(const name: string; potype:tproctypeoption; ps: tprocsym):tdef; virtual;
       class procedure InsertInitFinalTable; virtual;
+      class procedure InsertExtRTTITable; virtual;
      protected
       class procedure InsertRuntimeInits(const prefix:string;list:TLinkedList;unitflag:cardinal); virtual;
       class procedure InsertRuntimeInitsTablesTable(const prefix,tablename:string;unitflag:cardinal); virtual;
@@ -644,6 +645,36 @@ implementation
     end;
 
 
+    class procedure tnodeutils.InsertExtRTTITable;
+      var
+        hp : tused_unit;
+        unitinits : TAsmList;
+        count : longint;
+    begin
+      unitinits:=TAsmList.Create;
+      count:=0;
+      hp:=tused_unit(usedunits.first);
+      while assigned(hp) do
+       begin
+         if (hp.u.flags and uf_extrtti) <> 0 then
+           begin
+             unitinits.concat(Tai_const.Createname(make_mangledname('EXTR',hp.u.globalsymtable,''),0));
+             inc(count);
+           end;
+         hp:=tused_unit(hp.next);
+       end;
+      { Insert TableCount,InitCount at start }
+      unitinits.insert(Tai_const.Create_32bit(count));
+      { Add to data segment }
+      maybe_new_object_file(current_asmdata.asmlists[al_globals]);
+      new_section(current_asmdata.asmlists[al_globals],sec_data,'INITEXTRTTIUNITS',sizeof(pint));
+      current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global('INITEXTRTTIUNITS',AT_DATA,0));
+      current_asmdata.asmlists[al_globals].concatlist(unitinits);
+      current_asmdata.asmlists[al_globals].concat(Tai_symbol_end.Createname('INITEXTRTTIUNITS'));
+      unitinits.free;
+    end;
+
+
   class procedure tnodeutils.InsertThreadvarTablesTable;
     var
       hp : tused_unit;

compiler/pmodules.pas

@@ -2124,6 +2124,7 @@ implementation
          cnodeutils.InsertWideInitsTablesTable;
          cnodeutils.InsertResStrTablesTable;
          cnodeutils.InsertMemorySizes;
+         cnodeutils.InsertExtRTTITable;
 
 {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
          if target_info.system in systems_interrupt_table then

compiler/ppu.pas

@@ -162,6 +162,7 @@ const
   uf_wideinits           = $400000; { this unit has winlike widestring typed constants }
   uf_classinits          = $800000; { this unit has class constructors/destructors }
   uf_resstrinits        = $1000000; { this unit has string consts referencing resourcestrings }
+  uf_extrtti            = $2000000; { this unit has extended rtti information }
 
 {$ifdef generic_cpu}
 { We need to use the correct size of aint and pint for

compiler/ptype.pas

@@ -1679,6 +1679,8 @@ implementation
         { no Delphi-style RTTI }
         exit;
 {$endif jvm}
+        if st.symtabletype = globalsymtable then
+          st.extrtticount := 0;
         for i:=0 to st.DefList.Count-1 do
           begin
             def:=tdef(st.DefList[i]);
@@ -1733,6 +1735,8 @@ implementation
                (ds_rtti_table_used in def.defstates) then
               RTTIWriter.write_rtti(def,fullrtti);
           end;
+        if st.symtabletype = globalsymtable then
+          RTTIWriter.after_write_unit_extrtti_info(st);
       end;
 
 

compiler/symbase.pas

@@ -101,6 +101,7 @@ interface
           { level of symtable, used for nested procedures }
           symtablelevel : byte;
           symtabletype  : TSymtabletype;
+          extrtticount : integer;
           constructor Create(const s:string);
           destructor  destroy;override;
           procedure freeinstance;override;

compiler/symconst.pas

@@ -553,6 +553,8 @@ type
   { RTTI information to store }
   trttitype = (
     fullrtti,initrtti,
+    { Extended RTTI }
+    extrtti, attribute,
     { Objective-C }
     objcmetartti,objcmetarortti,
     objcclassrtti,objcclassrortti

compiler/symdef.pas

@@ -1439,7 +1439,15 @@ implementation
       var
         prefix : string[4];
       begin
-        if (rt=fullrtti) or (not needs_separate_initrtti) then
+        if rt=extrtti then
+          begin
+            prefix:='EXTR';
+          end
+        else if rt=attribute then
+          begin
+            prefix:='ATTR';
+          end
+        else if (rt=fullrtti) or (not needs_separate_initrtti) then
           begin
             prefix:='RTTI';
             include(defstates,ds_rtti_table_used);

rtl/objpas/typinfo.pp

@@ -247,6 +247,19 @@ unit typinfo;
       PPropList = ^TPropList;
       TPropList = array[0..65535] of PPropInfo;
 
+      TClassAttributeData = record
+        AttributeCount: byte;
+        AttributesList: TAttributeProcList;
+      end;
+      PClassAttributeData = ^TClassAttributeData;
+
+      TExtRTTIData = record
+        TypeData: PTypeInfo;
+        AttributeData: PClassAttributeData;
+      end;
+      PExtRTTIData = ^TExtRTTIData;
+
+
    const
       tkAny = [Low(TTypeKind)..High(TTypeKind)];
       tkMethods = [tkMethod];
@@ -361,11 +374,15 @@ function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
 procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
 procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
 
+// Extended RTTI
+function GetExtRTTIData(TypeInfo : PTypeInfo) : PExtRTTIData;
+
 function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
 function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
 
-function GetClassAttributeProclist(TypeData: PTypeData): PAttributeProcList;
-function GetClassAttribute(TypeData: PTypeData; AttributeNr: byte): TObject;
+function GetClassAttributeCount(ExtRTTIData: PExtRTTIData): byte;
+function GetClassAttributeProclist(ExtRTTIData: PExtRTTIData): PAttributeProcList;
+function GetClassAttribute(ExtRTTIData: PExtRTTIData; AttributeNr: byte): TObject;
 
 // Auxiliary routines, which may be useful
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
@@ -417,6 +434,14 @@ function aligntoptr(p : pointer) : pointer;inline;
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
    end;
 
+function GetExtRTTIData(TypeInfo: PTypeInfo): PExtRTTIData;
+var
+  p: pointer;
+begin
+  p := pointer(TypeInfo) - sizeof(p);
+  result := PExtRTTIData(pointer(p)^);
+end;
+
 function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
 begin
   if PropInfo^.AttributeCount=0 then
@@ -440,25 +465,32 @@ begin
     end;
 end;
 
-function GetClassAttributeProclist(TypeData: PTypeData): PAttributeProcList;
+
+function GetClassAttributeCount(ExtRTTIData: PExtRTTIData): byte;
+begin
+  if not assigned(ExtRTTIData^.AttributeData) then
+    result := 0
+  else
+    result := ExtRTTIData^.AttributeData^.AttributeCount;
+end;
+
+function GetClassAttributeProclist(ExtRTTIData: PExtRTTIData): PAttributeProcList;
 begin
-  if TypeData^.AttributeCount=0 then
+  if GetClassAttributeCount(ExtRTTIData) = 0 then
     result := nil
   else
-    begin
-      Result:=PAttributeProcList(aligntoptr(pointer(@TypeData^.UnitName)+byte(TypeData^.UnitName[0])+1));
-    end;
+    result := @ExtRTTIData^.AttributeData^.AttributesList;
 end;
 
-function GetClassAttribute(TypeData: PTypeData; AttributeNr: byte): TObject;
+function GetClassAttribute(ExtRTTIData: PExtRTTIData; AttributeNr: byte): TObject;
 var
   AttributeProcList: PAttributeProcList;
 begin
-  if AttributeNr>=TypeData^.AttributeCount then
+  if AttributeNr>=GetClassAttributeCount(ExtRTTIData) then
     result := nil
   else
     begin
-      AttributeProcList := GetClassAttributeProclist(TypeData);
+      AttributeProcList := GetClassAttributeProclist(ExtRTTIData);
       result := AttributeProcList^[AttributeNr]();
     end;
 end;

tests/test/tclassattribute1.pp

@@ -19,7 +19,7 @@ type
   end;
 
 var
-  td: PTypeData;
+  rtd: PExtRTTIData;
   AClassAttribute: TCustomAttribute;
 
 { tmyt }
@@ -30,11 +30,11 @@ begin
 end;
 
 begin
-  td := GetTypeData(TMyObject.ClassInfo);
-  if td^.AttributeCount<>1 then
+  rtd := GetExtRTTIData(TMyObject.ClassInfo);
+  if GetClassAttributeCount(rtd)<>1 then
     halt(1);
 
-  AClassAttribute := GetClassAttribute(td,0) as TCustomAttribute;
+  AClassAttribute := GetClassAttribute(rtd,0) as TCustomAttribute;
   if AClassAttribute = nil then
     halt(2);
   writeln('ok');

tests/test/tclassattribute4.pp

@@ -23,7 +23,7 @@ type
   end;
 
 var
-  td: PTypeData;
+  rtd: PExtRTTIData;
   AClassAttribute: tmyt;
 
 { tmyt }
@@ -34,17 +34,18 @@ begin
 end;
 
 begin
-  td := GetTypeData(TMyObject.ClassInfo);
-  if td^.AttributeCount<>2 then
+  rtd := GetExtRTTIData(TMyObject.ClassInfo);
+
+  if GetClassAttributeCount(rtd)<>2 then
     halt(1);
 
-  AClassAttribute := GetClassAttribute(td,1) as tmyt;
+  AClassAttribute := GetClassAttribute(rtd,1) as tmyt;
   if AClassAttribute = nil then
     halt(2);
   if AClassAttribute.FID<>1425 then
     halt(3);
 
-  AClassAttribute := GetClassAttribute(td,0) as tmyt;
+  AClassAttribute := GetClassAttribute(rtd,0) as tmyt;
   if AClassAttribute = nil then
     halt(2);
   if AClassAttribute.FID<>924 then