compiler: write extended RTTI for tkProcVar (tkProcedure in Delphi)

rtl: add appropriate types for tkProcVar RTTI (based on Delphi help)
+ test

git-svn-id: trunk@24468 -

.gitattributes

@@ -11692,6 +11692,7 @@ tests/test/trtti5.pp svneol=native#text/plain
 tests/test/trtti6.pp svneol=native#text/pascal
 tests/test/trtti7.pp svneol=native#text/pascal
 tests/test/trtti8.pp svneol=native#text/pascal
+tests/test/trtti9.pp svneol=native#text/pascal
 tests/test/tsafecall1.pp svneol=native#text/plain
 tests/test/tsafecall2.pp svneol=native#text/pascal
 tests/test/tsafecall3.pp svneol=native#text/pascal

compiler/ncgrtti.pas

@@ -693,43 +693,63 @@ implementation
               { 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;
+               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);
-           var
-             paraspec : byte;
-           begin
-             { only store user visible parameters }
-             if not(vo_is_hidden_para in parasym.varoptions) then
-               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;
+             begin
+               { only store user visible parameters }
+               if not(vo_is_hidden_para in parasym.varoptions) then
+                 begin
+                   { write flags for current parameter }
+                   write_param_flag(parasym);
+                   { write name of current parameter }
+                   write_string(parasym.realname);
+                   { write name of type of current parameter }
+                   write_rtti_name(parasym.vardef);
                  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));
-                 { write name of current parameter }
-                 write_string(parasym.realname);
-                 { write name of type of current parameter }
-                 write_rtti_name(parasym.vardef);
-               end;
-           end;
+             end;
+
+           procedure write_procedure_param(parasym:tparavarsym);
+             begin
+               { only store user visible parameters }
+               if not(vo_is_hidden_para in parasym.varoptions) then
+                 begin
+                   { write flags for current parameter }
+                   write_param_flag(parasym);
+                   { write param type }
+                   current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(parasym.vardef,fullrtti)));
+                   { write name of current parameter }
+                   write_string(parasym.realname);
+                 end;
+             end;
 
         var
           methodkind : byte;
@@ -795,7 +815,27 @@ implementation
                    current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(tparavarsym(def.paras[i]).vardef,fullrtti)));
             end
           else
-            write_header(def,tkProcvar);
+            begin
+              write_header(def,tkProcvar);
+              maybe_write_align;
+
+              { flags }
+              current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
+              maybe_write_align;
+              { write calling convention }
+              current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(ProcCallOptionToCallConv[def.proccalloption]));
+              maybe_write_align;
+              { write result typeinfo }
+              if is_void(def.returndef) then
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(nil))
+              else
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.returndef,fullrtti)));
+              { write parameter count }
+              current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.maxparacount));
+              maybe_write_align;
+              for i:=0 to def.paras.count-1 do
+                write_procedure_param(tparavarsym(def.paras[i]));
+            end;
         end;
 
 

rtl/objpas/typinfo.pp

@@ -125,6 +125,7 @@ unit typinfo;
         Dims: array[0..255] of PTypeInfo;
       end;
 
+      PManagedField = ^TManagedField;
       TManagedField =
       {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
       packed
@@ -134,6 +135,29 @@ unit typinfo;
         FldOffset: SizeInt;
       end;
 
+      PProcedureParam = ^TProcedureParam;
+      TProcedureParam =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+        Flags: Byte;
+        ParamType: PPTypeInfo;
+        Name: ShortString;
+      end;
+
+      TProcedureSignature =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+        Flags: Byte;
+        CC: TCallConv;
+        ResultType: PTypeInfo;
+        ParamCount: Byte;
+        {Params: array[1..ParamCount] of TProcedureParam;}
+      end;
+
 {$PACKRECORDS C}
       PTypeData = ^TTypeData;
       TTypeData =
@@ -203,6 +227,8 @@ unit typinfo;
                   CC : TCallConv;
                   ParamTypeRefs : array[1..ParamCount] of PTypeInfo;}
               );
+            tkProcVar:
+              (ProcSig: TProcedureSignature);
             tkInt64:
               (MinInt64Value, MaxInt64Value: Int64);
             tkQWord:
@@ -223,9 +249,7 @@ unit typinfo;
                IIDStr: ShortString;
               );
             tkArray:
-              (
-              ArrayData: TArrayTypeData;
-              );
+              (ArrayData: TArrayTypeData);
             tkDynArray:
               (
               elSize     : PtrUInt;
@@ -235,13 +259,9 @@ unit typinfo;
               DynUnitName: ShortStringBase
               );
             tkClassRef:
-              (
-              InstanceType: PTypeInfo;
-              );
+              (InstanceType: PTypeInfo);
             tkPointer:
-              (
-              RefType: PTypeInfo;
-              );
+              (RefType: PTypeInfo);
       end;
 
       TPropData =

tests/test/trtti9.pp

@@ -0,0 +1,38 @@
+program trtti9;
+
+{$mode delphi}
+
+uses
+  typinfo;
+
+type
+  PProcedureParam = ^TProcedureParam;
+  TProc = procedure(var A: Integer; S: String); stdcall;
+
+function TestParam(Param: PProcedureParam; Flags: Byte; ParamType: Pointer; Name: ShortString): Boolean;
+begin
+  Result := (Param^.Flags = Flags) and (Param^.ParamType = ParamType) and (Param^.Name = Name);
+end;
+
+var
+  Info: PTypeInfo;
+  Data: PTypeData;
+  Param: PProcedureParam;
+begin
+  Info := TypeInfo(TProc);
+  if Info^.Kind <> tkProcedure then
+    halt(1);
+  Data := GetTypeData(Info);
+  if Data^.ProcSig.CC <> ccStdCall then
+    halt(2);
+  if Data^.ProcSig.ResultType <> nil then
+     halt(3);
+  if Data^.ProcSig.ParamCount <> 2 then
+     halt(4);
+  Param := PProcedureParam(PAnsiChar(@Data^.ProcSig.Flags) + SizeOf(TProcedureSignature));
+  if not TestParam(Param, 1, TypeInfo(Integer), 'A') then
+     halt(5);
+  Param := PProcedureParam(PAnsiChar(@Param^.Name) + (Length(Param^.Name) + 1) * SizeOf(AnsiChar));
+  if not TestParam(Param, 0, TypeInfo(String), 'S') then
+     halt(6);
+end.