+ implement interface RTTI inspired by the changes from Steve Hildebrandt, yet not exactly the same. Like his implementation this one isn't Delphi compatible either.

+ added test

git-svn-id: trunk@35341 -

.gitattributes

@@ -13043,6 +13043,7 @@ tests/test/trtti11.pp svneol=native#text/pascal
 tests/test/trtti12.pp svneol=native#text/pascal
 tests/test/trtti13.pp svneol=native#text/pascal
 tests/test/trtti14.pp svneol=native#text/pascal
+tests/test/trtti15.pp svneol=native#text/pascal
 tests/test/trtti2.pp svneol=native#text/plain
 tests/test/trtti3.pp svneol=native#text/plain
 tests/test/trtti4.pp svneol=native#text/plain

compiler/ncgrtti.pas

@@ -59,6 +59,7 @@ interface
         procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
         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_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);
@@ -174,6 +175,95 @@ implementation
                               TRTTIWriter
 ***************************************************************************}
 
+
+    procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
+      var
+        rtticount,
+        totalcount,
+        i,j,k : longint;
+        sym : tprocsym;
+        def : tprocdef;
+        para : tparavarsym;
+      begin
+        tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PtrInt)),
+          targetinfos[target_info.system]^.alignment.recordalignmin,
+          targetinfos[target_info.system]^.alignment.maxCrecordalign);
+
+        totalcount:=0;
+        rtticount:=0;
+        for i:=0 to st.symlist.count-1 do
+          if tsym(st.symlist[i]).typ=procsym then
+            begin
+              sym:=tprocsym(st.symlist[i]);
+              inc(totalcount,sym.procdeflist.count);
+              for j:=0 to sym.procdeflist.count-1 do
+                if tprocdef(sym.procdeflist[j]).visibility in visibilities then
+                  inc(rtticount);
+            end;
+
+        tcb.emit_ord_const(totalcount,u16inttype);
+        if rtticount = 0 then
+          tcb.emit_ord_const($FFFF,u16inttype)
+        else
+          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);
+
+                      tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PtrInt)),
+                        targetinfos[target_info.system]^.alignment.recordalignmin,
+                        targetinfos[target_info.system]^.alignment.maxCrecordalign);
+
+                      write_rtti_reference(tcb,def.returndef,fullrtti);
+                      write_callconv(tcb,def);
+                      write_methodkind(tcb,def);
+                      tcb.emit_ord_const(def.paras.count,u16inttype);
+                      tcb.emit_ord_const(def.callerargareasize,ptrsinttype);
+                      tcb.emit_shortstring_const(sym.realname);
+
+                      for k:=0 to def.paras.count-1 do
+                        begin
+                          para:=tparavarsym(def.paras[k]);
+
+                          tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PtrInt)),
+                            targetinfos[target_info.system]^.alignment.recordalignmin,
+                            targetinfos[target_info.system]^.alignment.maxCrecordalign);
+
+                          if is_open_array(para.vardef) then
+                            write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
+                          else
+                            write_rtti_reference(tcb,para.vardef,fullrtti);
+                          write_param_flag(tcb,para);
+                          tcb.emit_shortstring_const(para.realname);
+
+                          write_paralocs(tcb,@para.paraloc[callerside]);
+
+                          tcb.end_anonymous_record;
+                        end;
+
+                      if not is_void(def.returndef) then
+                        write_paralocs(tcb,@para.paraloc[callerside]);
+
+                      tcb.end_anonymous_record;
+                    end;
+                end;
+          end;
+
+        tcb.end_anonymous_record;
+      end;
+
+
     procedure TRTTIWriter.write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
       var
         name: shortstring;
@@ -1276,6 +1366,9 @@ implementation
             { write published properties for this object }
             published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
 
+            { write published methods for this interface }
+            write_methods(tcb,def.symtable,[vis_published]);
+
             tcb.end_anonymous_record;
             tcb.end_anonymous_record;
 
@@ -1633,6 +1726,11 @@ implementation
                 fields_write_rtti(tobjectdef(def).symtable,rt)
               else
                 published_write_rtti(tobjectdef(def).symtable,rt);
+
+              if (rt=fullrtti)
+                  and (is_interface(def) or is_dispinterface(def))
+                  and (oo_can_have_published in tobjectdef(def).objectoptions) then
+                methods_write_rtti(tobjectdef(def).symtable,rt,[vis_published],true);
             end;
           classrefdef,
           pointerdef:

rtl/objpas/typinfo.pp

@@ -268,6 +268,68 @@ unit typinfo;
         function GetParam(ParamIndex: Integer): PProcedureParam;
       end;
 
+      PVmtMethodParam = ^TVmtMethodParam;
+      TVmtMethodParam =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+      private
+        function GetParaLocs: PParameterLocations; inline;
+        function GetTail: Pointer; inline;
+        function GetNext: PVmtMethodParam; inline;
+      public
+        ParamType: PPTypeInfo;
+        Flags: TParamFlags;
+        Name: ShortString;
+        { ParaLocs: TParameterLocations; }
+        property ParaLocs: PParameterLocations read GetParaLocs;
+        property Tail: Pointer read GetTail;
+        property Next: PVmtMethodParam read GetNext;
+      end;
+
+      PIntfMethodEntry = ^TIntfMethodEntry;
+      TIntfMethodEntry =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+      private
+        function GetParam(Index: Word): PVmtMethodParam;
+        function GetReturnLoc: PParameterLocations; inline;
+        function GetTail: Pointer; inline;
+        function GetNext: PIntfMethodEntry; inline;
+      public
+        ResultType: PPTypeInfo;
+        CC: TCallConv;
+        Kind: TMethodKind;
+        ParamCount: Word;
+        StackSize: SizeInt;
+        Name: ShortString;
+        { Params: array[0..ParamCount - 1] of TVmtMethodParam }
+        { ReturnLoc: TParameterLocations (if ResultType != Nil) }
+        property Param[Index: Word]: PVmtMethodParam read GetParam;
+        property ReturnLoc: PParameterLocations read GetReturnLoc;
+        property Tail: Pointer read GetTail;
+        property Next: PIntfMethodEntry read GetNext;
+      end;
+
+      PIntfMethodTable = ^TIntfMethodTable;
+      TIntfMethodTable =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+      private
+        function GetMethod(Index: Word): PIntfMethodEntry;
+      public
+        Count: Word;
+        { $FFFF if there is no further info, or the value of Count }
+        RTTICount: Word;
+        { Entry: array[0..Count - 1] of TIntfMethodEntry }
+        property Method[Index: Word]: PIntfMethodEntry read GetMethod;
+      end;
+
       PRecInitData = ^TRecInitData;
       TRecInitData =
       {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@@ -289,15 +351,18 @@ unit typinfo;
       private
         function GetUnitName: ShortString; inline;
         function GetPropertyTable: PPropData; inline;
+        function GetMethodTable: PIntfMethodTable; inline;
       public
         Parent: PPTypeInfo;
         Flags: TIntfFlagsBase;
         GUID: TGUID;
         property UnitName: ShortString read GetUnitName;
         property PropertyTable: PPropData read GetPropertyTable;
+        property MethodTable: PIntfMethodTable read GetMethodTable;
       private
         UnitNameField: ShortString;
         { PropertyTable: TPropData }
+        { MethodTable: TIntfMethodTable }
       end;
 
       PInterfaceRawData = ^TInterfaceRawData;
@@ -465,6 +530,7 @@ unit typinfo;
                GUID: TGUID;
                IntfUnit: ShortString;
                { PropertyTable: TPropData }
+               { MethodTable: TIntfMethodTable }
               );
             tkInterfaceRaw:
               (
@@ -2508,6 +2574,90 @@ begin
     end;
 end;
 
+{ TVmtMethodParam }
+
+function TVmtMethodParam.GetParaLocs: PParameterLocations;
+begin
+  Result := PParameterLocations(PByte(@Name[0]) + Length(Name) + 1);
+end;
+
+function TVmtMethodParam.GetTail: Pointer;
+var
+  pl: PParameterLocations;
+begin
+  pl := ParaLocs;
+  Result := PByte(@pl^.Count) + SizeOf(pl^.Count) + SizeOf(TParameterLocation) * pl^.Count;
+end;
+
+function TVmtMethodParam.GetNext: PVmtMethodParam;
+begin
+  Result := PVmtMethodParam(aligntoptr(Tail));
+end;
+
+{ TIntfMethodEntry }
+
+function TIntfMethodEntry.GetParam(Index: Word): PVmtMethodParam;
+begin
+  if Index >= ParamCount then
+    Result := Nil
+  else
+    begin
+      Result := PVmtMethodParam(aligntoptr(PByte(@Name[0]) + SizeOf(Name[0]) + Length(Name)));
+      while Index > 0 do
+        begin
+          Result := Result^.Next;
+          Dec(Index);
+        end;
+    end;
+end;
+
+function TIntfMethodEntry.GetReturnLoc: PParameterLocations;
+begin
+  if not Assigned(ResultType) then
+    Result := Nil
+  else if ParamCount = 0 then
+    Result := PParameterLocations(aligntoptr(PByte(@Name[0]) + SizeOf(Name[0]) + Length(Name)))
+  else
+    Result := PParameterLocations(aligntoptr(Param[ParamCount - 1]^.Tail));
+end;
+
+function TIntfMethodEntry.GetTail: Pointer;
+var
+  retloc: PParameterLocations;
+begin
+  if Assigned(ResultType) then
+    begin
+      retloc := ReturnLoc;
+      Result := PByte(@retloc^.Count) + SizeOf(retloc^.Count) + SizeOf(TParameterLocation) * retloc^.Count;
+    end
+  else if ParamCount = 0 then
+    Result := PByte(@Name[0]) + Length(Name) + SizeOf(Byte)
+  else
+    Result := Param[ParamCount - 1]^.Tail;
+end;
+
+function TIntfMethodEntry.GetNext: PIntfMethodEntry;
+begin
+  Result := PIntfMethodEntry(aligntoptr(Tail));
+end;
+
+{ TIntfMethodTable }
+
+function TIntfMethodTable.GetMethod(Index: Word): PIntfMethodEntry;
+begin
+  if (RTTICount = $FFFF) or (Index >= RTTICount) then
+    Result := Nil
+  else
+    begin
+      Result := aligntoptr(PIntfMethodEntry(PByte(@RTTICount) + SizeOf(RTTICount)));
+      while Index > 0 do
+        begin
+          Result := Result^.Next;
+          Dec(Index);
+        end;
+    end;
+end;
+
 { TInterfaceData }
 
 function TInterfaceData.GetUnitName: ShortString;
@@ -2523,6 +2673,11 @@ begin
   Result := aligntoptr(p);
 end;
 
+function TInterfaceData.GetMethodTable: PIntfMethodTable;
+begin
+  Result := aligntoptr(PropertyTable^.Tail);
+end;
+
 { TInterfaceRawData }
 
 function TInterfaceRawData.GetUnitName: ShortString;

tests/test/trtti15.pp

@@ -0,0 +1,217 @@
+program trtti15;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo,
+  sysutils;
+
+type
+  IBlubb = interface
+    procedure Test;
+  end;
+
+  {$push}
+  {$M+}
+  ITest = interface
+    procedure Test;
+    function Test2: LongInt;
+    procedure Test3(arg1: LongInt; arg2: String);
+    function Test4(arg1: LongInt; arg2: String): String;
+    function Test5(arg1: array of LongInt; arg2: Int64): Int64;
+    function Test6(arg1: LongInt; arg2: String): String; stdcall;
+    {$if defined(CPUI386) or defined(CPUI8086)}
+    function Test7(arg1: LongInt; arg2: String): String; pascal;
+    {$endif}
+    function Test8(arg1: LongInt; arg2: String): String; cdecl;
+    property T: LongInt read Test2;
+    property T2: LongInt read Test2;
+  end;
+
+  (*{$interfaces corba}
+  ITestRaw = interface
+    function Test: LongInt;
+    property T: LongInt read Test;
+  end;*)
+  {$pop}
+
+procedure ErrorHalt(const aMsg: String; const aArgs: array of const);
+begin
+  if Length(aArgs) = 0 then
+    Writeln(aMsg)
+  else
+    Writeln(Format(aMsg, aArgs));
+  Halt(1);
+end;
+
+procedure TestParam(aParam: PVmtMethodParam; const aName: String; aFlags: TParamFlags; aTypeInfo: PTypeInfo);
+begin
+  Writeln(#9'Testing parameter ', aName);
+  if not (pfHidden in aFlags) and (aParam^.Name <> aName) then
+    ErrorHalt('Expected parameter name %s, but got %s', [aName, aParam^.Name]);
+  if aParam^.Flags <> aFlags then
+    ErrorHalt('Expected parameter flags %s, but got %s', [HexStr(Word(aFlags), 4), HexStr(Word(aParam^.Flags), 4)]);
+  if not Assigned(aParam^.ParamType) then
+    ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]);
+  if aParam^.ParamType^ <> aTypeInfo then
+    ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]);
+end;
+
+type
+  TTestParam = record
+    name: String;
+    flags: TParamFlags;
+    paramtype: PTypeInfo;
+  end;
+
+function MakeParam(const aName: String; aFlags: TParamFlags; aTypeInfo: PTypeInfo): TTestParam;
+begin
+  Result.name := aName;
+  Result.flags := aFlags;
+  Result.paramtype := aTypeInfo;
+end;
+
+procedure TestMethod(aMethod: PIntfMethodEntry; const aName: String; aKind: TMethodKind; aCC: TCallConv; aParams: array of TTestParam; aResult: PTypeInfo);
+var
+  c, i: LongInt;
+  param: PVmtMethodParam;
+begin
+  Writeln('Testing method ', aName);
+  if aMethod^.Name <> aName then
+    ErrorHalt('Expected method name %s, but got %s', [aName, aMethod^.Name]);
+  if aMethod^.CC <> aCC then
+    ErrorHalt('Expected calling convention %d, but got %d', [Ord(aCC), Ord(aMethod^.CC)]);
+  if aMethod^.Kind <> aKind then
+    ErrorHalt('Expected method kind %d, but got %d', [Ord(aKind), Ord(aMethod^.Kind)]);
+  if Assigned(aResult) and not Assigned(aMethod^.ResultType) then
+    ErrorHalt('Expected result type %s, but got Nil', [aResult^.Name]);
+  if Assigned(aResult) and (aResult <> aMethod^.ResultType^) then
+    ErrorHalt('Expected result type %s, but got %s', [aResult^.Name, aMethod^.ResultType^^.Name]);
+
+  { we ignore an eventual result parameter }
+  if aMethod^.ParamCount < Length(aParams) then
+    ErrorHalt('Expected at least %d parameters, but got %d', [Length(aParams), aMethod^.ParamCount]);
+
+  if aMethod^.ParamCount < 1 then
+    ErrorHalt('Expected at least 1 parameter, but got 0', []);
+
+  { first parameter is always self }
+  c := 1;
+  TestParam(aMethod^.Param[0], aParams[0].name, aParams[0].flags, aParams[0].paramtype);
+
+  for i := 1 to aMethod^.ParamCount - 1 do begin
+    param := aMethod^.Param[i];
+    if pfResult in param^.Flags then
+      Continue;
+    TestParam(param, aParams[c].name, aParams[c].flags, aParams[c].paramtype);
+    Inc(c);
+  end;
+
+  if c <> Length(aParams) then
+    ErrorHalt('Expected %d parameters, but got %d', [Length(aParams), c]);
+end;
+
+type
+  TTestMethod = record
+    name: String;
+    cc: TCallConv;
+    kind: TMethodKind;
+    result: PTypeInfo;
+    params: array of TTestParam;
+  end;
+
+function MakeMethod(const aName: String; aCC: TCallConv; aKind: TMethodKind; aResult: PTypeInfo; aParams: array of TTestParam): TTestMethod;
+var
+  i: LongInt;
+begin
+  Result.name := aName;
+  Result.cc := aCC;
+  Result.kind := aKind;
+  Result.result := aResult;
+  SetLength(Result.params, Length(aParams));
+  for i := Low(aParams) to High(aParams) do
+    Result.params[i - Low(aParams)] := aParams[i];
+end;
+
+procedure TestInterface(aIntf: PTypeData; aRaw: Boolean; aPropCount: LongInt; aMethods: array of TTestMethod);
+var
+  proptable: PPropData;
+  methtable: PIntfMethodTable;
+  i: LongInt;
+begin
+  {if aRaw then begin
+    proptable := PInterfaceRawData(aIntf)^.PropertyTable;
+    methtable := PInterfaceRawData(aIntf)^.MethodTable;
+  end else }begin
+    proptable := PInterfaceData(aIntf)^.PropertyTable;
+    methtable := PInterfaceData(aIntf)^.MethodTable;
+  end;
+
+  if proptable^.PropCount <> aPropCount then
+    ErrorHalt('Expected %d properties, but got %d', [aPropCount, proptable^.PropCount]);
+
+  if methtable^.Count <> Length(aMethods) then
+    ErrorHalt('Expected %d methods, but got %d', [Length(aMethods), methtable^.Count]);
+
+  if methtable^.RttiCount = $ffff then
+    Exit;
+
+  for i := 0 to methtable^.Count - 1 do begin
+    TestMethod(methtable^.Method[i], aMethods[i].name, aMethods[i].kind, aMethods[i].cc, aMethods[i].params, aMethods[i].result);
+  end;
+end;
+
+const
+{$if defined(CPUI386) or defined(CPUI8086) or defined(CPUX86_64)}
+  DefaultCallingConvention = ccReg;
+{$else}
+  DefaultCallingConvention = ccStdCall;
+{$endif}
+
+begin
+  {TestInterface(GetTypeData(TypeInfo(ITestRaw)), True, 1, [
+      MakeMethod('Test', ccReg, mkFunction, TypeInfo(LongInt), [])
+    ]);}
+
+  TestInterface(GetTypeData(TypeInfo(ITest)), False, 2, [
+      MakeMethod('Test', DefaultCallingConvention, mkProcedure, Nil, [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest))
+        ]),
+      MakeMethod('Test2', DefaultCallingConvention, mkFunction, TypeInfo(LongInt), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest))
+        ]),
+      MakeMethod('Test3', DefaultCallingConvention, mkProcedure, Nil, [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [], TypeInfo(LongInt)),
+          MakeParam('arg2', [], TypeInfo(String))
+        ]),
+      MakeMethod('Test4', DefaultCallingConvention, mkFunction, TypeInfo(String), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [], TypeInfo(LongInt)),
+          MakeParam('arg2', [], TypeInfo(String))
+        ]),
+      MakeMethod('Test5', DefaultCallingConvention, mkFunction, TypeInfo(Int64), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [pfArray, pfReference], TypeInfo(LongInt)),
+          MakeParam('$highARG1', [pfHidden, pfHigh, pfConst], TypeInfo(SizeInt)),
+          MakeParam('arg2', [], TypeInfo(Int64))
+        ]),
+      MakeMethod('Test6', ccStdCall, mkFunction, TypeInfo(String), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [], TypeInfo(LongInt)),
+          MakeParam('arg2', [], TypeInfo(String))
+        ]),
+      {$if defined(CPUI386) or defined(CPUI8086)}
+      MakeMethod('Test7', ccPascal, mkFunction, TypeInfo(String), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [], TypeInfo(LongInt)),
+          MakeParam('arg2', [], TypeInfo(String))
+        ]),
+      {$endif}
+      MakeMethod('Test8', ccCdecl, mkFunction, TypeInfo(String), [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [], TypeInfo(LongInt)),
+          MakeParam('arg2', [], TypeInfo(String))
+        ])
+    ]);
+end.