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,12 +693,9 @@ implementation
               { pocall_interrupt  } 12
              );
 
-           procedure write_para(parasym:tparavarsym);
+           procedure write_param_flag(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;
@@ -724,6 +721,15 @@ implementation
                  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
+               { 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 }
@@ -731,6 +737,20 @@ implementation
                  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;
           i : integer;
@@ -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
+            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.