0001 Added Base Structure for delphi compatible interface rtti

git-svn-id: branches/interfacertti@30816 -

compiler/ncgrtti.pas

@@ -28,7 +28,7 @@ interface
     uses
       cclasses,constexp,
       aasmbase,
-      symbase,symconst,symtype,symdef;
+      symbase,symconst,symtype,symdef,symsym;
 
     type
 
@@ -43,6 +43,8 @@ interface
         procedure published_write_rtti(st:tsymtable;rt:trttitype);
         function  published_properties_count(st:tsymtable):longint;
         procedure published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
+        procedure write_param_flag(parasym:tparavarsym);
+        procedure methods_write_rtti(st:tsymtable);
         procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
         function  ref_rtti(def:tdef;rt:trttitype):tasmsymbol;
         procedure write_rtti_name(def:tdef);
@@ -69,7 +71,6 @@ implementation
        cutils,
        globals,globtype,verbose,systems,
        fmodule, procinfo,
-       symsym,
        aasmtai,aasmdata,
        defutil,
        wpobase
@@ -83,6 +84,23 @@ implementation
          symconst.ds_none,symconst.ds_none,
          symconst.ds_none,symconst.ds_none);
 
+       ProcCallOptionToCallConv: array[tproccalloption] of byte = (
+        { pocall_none       } 0,
+        { pocall_cdecl      } 1,
+        { pocall_cppdecl    } 5,
+        { pocall_far16      } 6,
+        { pocall_oldfpccall } 7,
+        { pocall_internproc } 8,
+        { pocall_syscall    } 9,
+        { pocall_pascal     } 2,
+        { pocall_register   } 0,
+        { pocall_safecall   } 4,
+        { pocall_stdcall    } 3,
+        { pocall_softfloat  } 10,
+        { pocall_mwpascal   } 11,
+        { pocall_interrupt  } 12
+       );
+
     type
        TPropNameListItem = class(TFPHashObject)
          propindex : longint;
@@ -414,6 +432,96 @@ implementation
           end;
       end;
 
+    procedure TRTTIWriter.write_param_flag(parasym:tparavarsym);
+    var
+      paraspec : byte;
+    begin
+      case parasym.varspez of
+        vs_value   : paraspec := 0;
+        vs_const   : paraspec := pfConst;
+        vs_var     : paraspec := pfVar;
+        vs_out     : paraspec := pfOut;
+        vs_constref: paraspec := pfConstRef;
+      else
+        internalerror(2013112904);
+      end;
+      { Kylix also seems to always add both pfArray and pfReference
+      in this case
+      }
+      if is_open_array(parasym.vardef) then
+        paraspec:=paraspec or pfArray or pfReference;
+      { and these for classes and interfaces (maybe because they
+      are themselves addresses?)
+      }
+      if is_class_or_interface(parasym.vardef) then
+        paraspec:=paraspec or pfAddress;
+      { set bits run from the highest to the lowest bit on
+      big endian systems
+      }
+      if (target_info.endian = endian_big) then
+        paraspec:=reverse_byte(paraspec);
+      { write flags for current parameter }
+      current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec));
+    end;
+
+    procedure TRTTIWriter.methods_write_rtti(st: tsymtable);
+    var
+      count: Word;
+      i,j,k: LongInt;
+
+      sym : tprocsym;
+      def : tabstractprocdef;
+      para : tparavarsym;
+
+      reg: Byte;
+      off: LongInt;
+    begin
+      count:=0;
+      for i:=0 to st.SymList.Count-1 do
+        if (tsym(st.SymList[i]).typ=procsym) then
+          inc(count);
+
+      current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(count));
+      current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(count));
+
+      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:=tabstractprocdef(sym.ProcdefList[j]);
+                def.init_paraloc_info(callerside);
+
+                write_string(sym.realname);
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(3));
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(ProcCallOptionToCallConv[def.proccalloption]));
+                write_rtti_reference(def.returndef,fullrtti);
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(def.callerargareasize));
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.maxparacount + 1));
+
+                for k:=0 to def.paras.count-1 do
+                  begin
+                    para:=tparavarsym(def.paras[k]);
+
+                    { write flags for current parameter }
+                    write_param_flag(para);
+                    maybe_write_align;
+                    { write param type }
+                    write_rtti_reference(para.vardef,fullrtti);
+
+                    reg:=0;
+                    off:=0;
+                    current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(reg));
+                    current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(off));
+
+                    { write name of current parameter }
+                    write_string(para.realname);
+                  end;
+              end;
+          end;
+    end;
+
 
     procedure TRTTIWriter.write_rtti_data(def:tdef;rt:trttitype);
 
@@ -686,55 +794,6 @@ implementation
 
 
         procedure procvardef_rtti(def:tprocvardef);
-           const
-             ProcCallOptionToCallConv: array[tproccalloption] of byte = (
-              { pocall_none       } 0,
-              { pocall_cdecl      } 1,
-              { pocall_cppdecl    } 5,
-              { pocall_far16      } 6,
-              { pocall_oldfpccall } 7,
-              { pocall_internproc } 8,
-              { pocall_syscall    } 9,
-              { pocall_pascal     } 2,
-              { pocall_register   } 0,
-              { pocall_safecall   } 4,
-              { pocall_stdcall    } 3,
-              { pocall_softfloat  } 10,
-              { pocall_mwpascal   } 11,
-              { pocall_interrupt  } 12
-             );
-
-           procedure write_param_flag(parasym:tparavarsym);
-             var
-               paraspec : byte;
-             begin
-               case parasym.varspez of
-                 vs_value   : paraspec := 0;
-                 vs_const   : paraspec := pfConst;
-                 vs_var     : paraspec := pfVar;
-                 vs_out     : paraspec := pfOut;
-                 vs_constref: paraspec := pfConstRef;
-                 else
-                   internalerror(2013112904);
-               end;
-               { Kylix also seems to always add both pfArray and pfReference
-                 in this case
-               }
-               if is_open_array(parasym.vardef) then
-                 paraspec:=paraspec or pfArray or pfReference;
-               { and these for classes and interfaces (maybe because they
-                 are themselves addresses?)
-               }
-               if is_class_or_interface(parasym.vardef) then
-                 paraspec:=paraspec or pfAddress;
-               { set bits run from the highest to the lowest bit on
-                 big endian systems
-               }
-               if (target_info.endian = endian_big) then
-                 paraspec:=reverse_byte(paraspec);
-               { write flags for current parameter }
-               current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec));
-             end;
 
            procedure write_para(parasym:tparavarsym);
              begin
@@ -944,15 +1003,24 @@ implementation
             maybe_write_align;
 
             { write iidstr }
-            if assigned(def.iidstr) then
-              write_string(def.iidstr^)
-            else
-              current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
-            maybe_write_align;
+            if def.objecttype = odt_interfacecorba then
+              begin
+                if assigned(def.iidstr) then
+                  write_string(def.iidstr^)
+                else
+                  current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
+
+                maybe_write_align;
+              end;
 
             { write published properties for this object }
+            current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
+            maybe_write_align;
             published_properties_write_rtti_data(propnamelist,def.symtable);
 
+            { write methods for this object }
+            methods_write_rtti(def.symtable);
+
             propnamelist.free;
           end;
 
@@ -1283,6 +1351,8 @@ implementation
     end;
 
     procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
+    var
+      i,j: SizeInt;
       begin
         case def.typ of
           enumdef :
@@ -1304,7 +1374,20 @@ implementation
               if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
                 fields_write_rtti(tobjectdef(def).symtable,rt)
               else
-                published_write_rtti(tobjectdef(def).symtable,rt);
+                begin
+                  published_write_rtti(tobjectdef(def).symtable,rt);
+
+                  if is_any_interface_kind(def) then
+                    with tobjectdef(def).symtable do
+                      for i := 0 to SymList.Count-1 do
+                        if (tsym(SymList[i]).typ=procsym) then
+                          with tprocsym(tobjectdef(def).symtable.SymList[i]) do
+                            for j := 0 to ProcdefList.Count - 1 do
+                              begin
+                                write_rtti(tabstractprocdef(ProcdefList[j]).returndef,rt);
+                                params_write_rtti(tabstractprocdef(ProcdefList[j]),rt);
+                              end;
+                end;
             end;
           classrefdef,
           pointerdef:

rtl/objpas/typinfo.pp

@@ -54,7 +54,7 @@ unit typinfo;
        TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
                       mkClassProcedure,mkClassFunction,mkClassConstructor, 
                       mkClassDestructor,mkOperatorOverload);
-       TParamFlag     = (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
+       TParamFlag     = (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut,pfConstRef);
        TParamFlags    = set of TParamFlag;
        TIntfFlag      = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID);
        TIntfFlags     = set of TIntfFlag;
@@ -63,6 +63,7 @@ unit typinfo;
        // don't rely on integer values of TCallConv since it includes all conventions
        // which both delphi and fpc support. In the future delphi can support more and
        // fpc own conventions will be shifted/reordered accordinly
+       PCallConv = ^TCallConv;
        TCallConv = (ccReg, ccCdecl, ccPascal, ccStdCall, ccSafeCall,
                     ccCppdecl, ccFar16, ccOldFPCCall, ccInternProc,
                     ccSysCall, ccSoftFloat, ccMWPascal);
@@ -161,6 +162,49 @@ unit typinfo;
         function GetParam(ParamIndex: Integer): PProcedureParam;
       end;
 
+      PVmtMethodParam = ^TVmtMethodParam;
+      TVmtMethodParam =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+        Flags: TParamFlags;
+        ParamType: PTypeInfo;
+        ParReg: Byte;
+        ParOff: LongInt;
+        Name: ShortString;
+        {Attribute data TODO}
+      end;
+
+      PIntfMethodEntry = ^TIntfMethodEntry;
+      TIntfMethodEntry =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+        Name: ShortString;
+        {
+        Version: Byte;
+        CC: TCallConv;
+        ResultType: PTypeInfo;
+        StackSize: Word;
+        ParamCount: Byte;
+        Params: array[0..ParamCount - 1] of TVmtMethodParam;
+        }
+        {Attribute data TODO}
+      end;
+
+      PIntfMethodTable = ^TIntfMethodTable;
+      TIntfMethodTable =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+        Count: Word;
+        RTTICount: Word;//$FFFF if there is no further info, or the value of Count
+        {Entry: array[0..Count - 1] of TIntfMethodEntry}
+      end;
+
       PTypeData = ^TTypeData;
       TTypeData =
 {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@@ -241,6 +285,11 @@ unit typinfo;
                IntfFlags : TIntfFlagsBase;
                GUID: TGUID;
                IntfUnit: ShortString;
+               {
+               IntfPropCount: Word;
+               IntfProps: array[0..IntfPropCount-1] of TPropInfo;
+               IntfMethTable : TIntfMethodTable;
+               }
               );
             tkInterfaceRaw:
               (
@@ -249,6 +298,11 @@ unit typinfo;
                IID: TGUID;
                RawIntfUnit: ShortString;
                IIDStr: ShortString;
+               {
+               RawIntfPropCount: Word;
+               RawIntfProps: array[0..IntfPropCount-1] of TPropInfo;
+               IntfMethTable : TIntfMethodTable;
+               }
               );
             tkArray:
               (ArrayData: TArrayTypeData);