* Patch from Евгений Савин to fix passing records to invoke. Fixes issue #41006

packages/libffi/src/ffi.manager.pp

@@ -50,7 +50,7 @@ end;
 
 
 function TypeInfoToFFIType(aTypeInfo: PTypeInfo; aFlags: TParamFlags): pffi_type; forward;
-function ArgIsIndirect(aKind: TTypeKind; aFlags: TParamFlags; aIsResult: Boolean): Boolean; forward;
+function ArgIsIndirect(aTypeInfo: PTypeInfo; aFlags: TParamFlags; aIsResult: Boolean): Boolean; forward;
 
 function RecordOrObjectToFFIType(aTypeInfo: PTypeInfo): pffi_type;
 var
@@ -131,7 +131,7 @@ begin
     { now add the real field type (Note: some are handled differently from
       being passed as arguments, so we handle those here) }
     aSize:=0;
-    if field^.TypeRef^.Kind = tkObject then
+    if field^.TypeRef^.Kind in [tkRecord, tkObject] then
       aSize:=AddElement(RecordOrObjectToFFIType(field^.TypeRef))
     else if field^.TypeRef^.Kind = tkSString then begin
       fieldtd := GetTypeData(field^.TypeRef);
@@ -220,7 +220,7 @@ begin
   Result := @ffi_type_void;
   if Assigned(aTypeInfo) then begin
     td := GetTypeData(aTypeInfo);
-    if ArgIsIndirect(aTypeInfo^.Kind,aFlags,False)  then
+    if ArgIsIndirect(aTypeInfo,aFlags,False)  then
       Result := @ffi_type_pointer
     else
       case aTypeInfo^.Kind of
@@ -317,7 +317,27 @@ begin
     Result := @ffi_type_pointer;
 end;
 
-function ArgIsIndirect(aKind: TTypeKind; aFlags: TParamFlags; aIsResult: Boolean): Boolean;
+function ArgIsIndirect(aTypeInfo: PTypeInfo; aFlags: TParamFlags; aIsResult: Boolean): Boolean;
+  function IsManaged(aTypeInfo: PTypeInfo): boolean;
+  begin
+    Result := False;
+    if aTypeInfo = nil then Exit;
+
+    case aTypeInfo^.Kind of
+      tkAString,
+      tkLString,
+      tkWString,
+      tkUString,
+      tkInterface,
+      tkDynArray,
+      tkVariant: Result := True;
+
+      tkRecord,
+      tkObject:
+        Result := GetTypeData(aTypeInfo)^.RecInitData^.ManagedFieldCount > 0;
+    end;
+  end;
+
 const
   ResultTypeNeedsIndirection = [
    tkAString,
@@ -326,16 +346,23 @@ const
    tkInterface,
    tkDynArray
   ];
+var
+  Kind: TTypeKind;
 begin
   Result := False;
-  if (aKind = tkSString) or
-      (aIsResult and (aKind in ResultTypeNeedsIndirection)) or
+  if aTypeInfo = nil then
+    Kind := tkUnknown
+  else
+    Kind := aTypeInfo^.Kind;
+  if (Kind = tkSString) or
+      (aIsResult and (Kind in ResultTypeNeedsIndirection)) or
       (aFlags * [pfArray, pfOut, pfVar, pfConstRef] <> []) or
-      ((aKind = tkUnknown) and (pfConst in aFlags))
+      ((pfConst in aFlags) and (Kind in [tkRecord, tkObject]) and (GetTypeData(aTypeInfo)^.RecSize > SizeOf(Pointer)) and IsManaged(aTypeInfo)) or
+      ((Kind = tkUnknown) and (pfConst in aFlags))
       // This is true for all CPUs except sparc64/xtensa and i386/X86_64 on windows.
       // The latter 2 are handled by the i386-specific invoke, so need not concern us here.
 {$IF NOT (DEFINED(CPUSPARC64) or DEFINED(CPUXTENSA))}
-      or (aKind=tkVariant)
+      or (Kind=tkVariant)
 {$ENDIF}
       then
     Result := True;
@@ -467,7 +494,6 @@ var
   abi: ffi_abi;
   i, arglen, argoffset, argstart: LongInt;
   usevalues, retparam: Boolean;
-  kind: TTypeKind;
   types: ppffi_type;
 
 begin
@@ -533,11 +559,7 @@ begin
 
   if not (fcfStatic in aFlags) and retparam then begin
     aData.Types[0] := TypeInfoToFFIType(aArgInfos[0].ParamType, aArgInfos[0].ParamFlags);
-    if Assigned(aArgInfos[0].ParamType) then
-      kind := aArgInfos[0].ParamType^.Kind
-    else
-      kind := tkUnknown;
-    aData.Indirect[0] := ArgIsIndirect(kind, aArgInfos[0].ParamFlags, False);
+    aData.Indirect[0] := ArgIsIndirect(aArgInfos[0].ParamType, aArgInfos[0].ParamFlags, False);
     if usevalues then
       if aData.Indirect[0] then
         aData.Values[0] := @aArgValues[0]
@@ -553,11 +575,7 @@ begin
     aData.Types[i + argoffset] := TypeInfoToFFIType(aArgInfos[i].ParamType, aArgInfos[i].ParamFlags);
     if (pfResult in aArgInfos[i].ParamFlags) and not retparam then
       aData.ResultIndex := i + argoffset;
-    if Assigned(aArgInfos[i].ParamType) then
-      kind := aArgInfos[i].ParamType^.Kind
-    else
-      kind := tkUnknown;
-    aData.Indirect[i + argoffset] := ArgIsIndirect(kind, aArgInfos[i].ParamFlags, False);
+    aData.Indirect[i + argoffset] := ArgIsIndirect(aArgInfos[i].ParamType, aArgInfos[i].ParamFlags, False);
     if usevalues then
       if aData.Indirect[i + argoffset] then
         aData.Values[i + argoffset] := @aArgValues[i]
@@ -567,7 +585,7 @@ begin
 
   if retparam then begin
     aData.Types[aData.ResultIndex] := TypeInfoToFFIType(aResultType, []);
-    aData.Indirect[aData.ResultIndex] := ArgIsIndirect(aResultType^.Kind, [], True);
+    aData.Indirect[aData.ResultIndex] := ArgIsIndirect(aResultType, [], True);
     if usevalues then
       if aData.Indirect[aData.ResultIndex] then
         aData.Values[aData.ResultIndex] := @aResultValue

tests/webtbs/tw41006.pp

@@ -0,0 +1,360 @@
+program tw41006;
+{$mode delphi}
+{$H+} {$M+}
+{$RTTI EXPLICIT METHODS([vcPublished]) PROPERTIES([vcPublished]) FIELDS([vcPublished])}
+uses
+  SysUtils, TypInfo, Rtti
+{$ifndef windows}
+  , ffi.manager
+{$endif}
+;
+
+type
+  TRec1 = record
+    Intf: IUnknown;
+  end;
+  TRec2 = record
+    P: Pointer;
+    Intf: IUnknown;
+    B: Byte;
+  end;
+  TRec3 = record
+    R: TRec1;
+  end;
+  TRec4 = record
+    R: TRec2;
+  end;
+  TRec5 = record
+    I: Integer;
+  end;
+  TRec6 = record
+    I1: Int64;
+    I2: Int64;
+  end;
+  TRec7 = record
+     R: TRec5;
+  end;
+  TRec8 = record
+     R: TRec6;
+  end;
+
+
+type
+
+  { TMyObj }
+
+  TMyObj = class
+  strict private
+    FStr: string;
+  public
+    constructor Create;
+  published
+    procedure Test1Value(ARec: TRec1);
+    procedure Test1Const(const ARec: TRec1);
+    procedure Test2Value(ARec: TRec2);
+    procedure Test2Const(const ARec: TRec2);
+    procedure Test3Value(ARec: TRec3);
+    procedure Test3Const(const ARec: TRec3);
+    procedure Test4Value(ARec: TRec4);
+    procedure Test4Const(const ARec: TRec4);
+    procedure Test5Value(ARec: TRec5);
+    procedure Test5Const(const ARec: TRec5);
+    procedure Test6Value(ARec: TRec6);
+    procedure Test6Const(const ARec: TRec6);
+    procedure Test7Value(ARec: TRec7);
+    procedure Test7Const(const ARec: TRec7);
+    procedure Test8Value(ARec: TRec8);
+    procedure Test8Const(const ARec: TRec8);
+
+    function Test1Ret: TRec1;
+    function Test2Ret: TRec2;
+    function Test3Ret: TRec3;
+    function Test4Ret: TRec4;
+    function Test5Ret: TRec5;
+    function Test6Ret: TRec6;
+    function Test7Ret: TRec7;
+    function Test8Ret: TRec8;
+  end;
+
+var
+  ErrorCount: Integer;
+
+procedure Check(ACondition: boolean; const AMessage: string);
+begin
+  if not ACondition then
+  begin
+    WriteLn('ERROR: ' + AMessage);
+    INc(ErrorCount);
+  end;
+end;
+
+var
+  Intf: IUnknown;
+
+{ TMyObj }
+
+constructor TMyObj.Create;
+begin
+  FStr := '123';
+end;
+
+procedure TMyObj.Test1Value(ARec: TRec1);
+begin
+  Check(FStr = '123', 'Test1Value: Self is broken');
+  Check(ARec.Intf = Intf, 'Test1Value: ARec is broken');
+end;
+
+procedure TMyObj.Test1Const(const ARec: TRec1);
+begin
+  Check(FStr = '123', 'Test1Const: Self is broken');
+  Check(ARec.Intf = Intf, 'Test1Const: ARec is broken');
+end;
+
+procedure TMyObj.Test2Value(ARec: TRec2);
+begin
+  Check(FStr = '123', 'Test2Value: Self is broken');
+  Check(ARec.Intf = Intf, 'Test2Value: ARec is broken');
+  Check(ARec.B = 59, 'Test2Value: ARec is broken');
+end;
+
+procedure TMyObj.Test2Const(const ARec: TRec2);
+begin
+  Check(FStr = '123', 'Test2Const: Self is broken');
+  Check(ARec.Intf = Intf, 'Test2Const: ARec is broken');
+  Check(ARec.B = 59, 'Test2Const: ARec is broken');
+end;
+
+procedure TMyObj.Test3Value(ARec: TRec3);
+begin
+  Check(FStr = '123', 'Test3Value: Self is broken');
+  Check(ARec.R.Intf = Intf, 'Test3Value: ARec is broken');
+end;
+
+procedure TMyObj.Test3Const(const ARec: TRec3);
+begin
+  Check(FStr = '123', 'Test3Const: Self is broken');
+  Check(ARec.R.Intf = Intf, 'Test3Const: ARec is broken');
+end;
+
+procedure TMyObj.Test4Value(ARec: TRec4);
+begin
+  Check(FStr = '123', 'Test4Value: Self is broken');
+  Check(ARec.R.Intf = Intf, 'Test4Value: ARec is broken');
+  Check(ARec.R.B = 81, 'Test4Value: ARec is broken');
+end;
+
+procedure TMyObj.Test4Const(const ARec: TRec4);
+begin
+  Check(FStr = '123', 'Test4Const: Self is broken');
+  Check(ARec.R.Intf = Intf, 'Test4Const: ARec is broken');
+  Check(ARec.R.B = 81, 'Test4Const: ARec is broken');
+end;
+
+procedure TMyObj.Test5Value(ARec: TRec5);
+begin
+  Check(FStr = '123', 'Test5Value: Self is broken');
+  Check(ARec.I = 15, 'Test5Value: ARec is broken');
+end;
+
+procedure TMyObj.Test5Const(const ARec: TRec5);
+begin
+  Check(FStr = '123', 'Test5Const: Self is broken');
+  Check(ARec.I = 15, 'Test5Const: ARec is broken');
+end;
+
+procedure TMyObj.Test6Value(ARec: TRec6);
+begin
+  Check(FStr = '123', 'Test6Value: Self is broken');
+  Check(ARec.I1 = 98, 'Test6Value: ARec is broken');
+  Check(ARec.I2 = 102, 'Test6Value: ARec is broken');
+end;
+
+procedure TMyObj.Test6Const(const ARec: TRec6);
+begin
+  Check(FStr = '123', 'Test6Const: Self is broken');
+  Check(ARec.I1 = 98, 'Test6Const: ARec is broken');
+  Check(ARec.I2 = 102, 'Test6Const: ARec is broken');
+end;
+
+procedure TMyObj.Test7Value(ARec: TRec7);
+begin
+  Check(FStr = '123', 'Test7Value: Self is broken');
+  Check(ARec.R.I = 98, 'Test7Value: ARec is broken');
+end;
+
+procedure TMyObj.Test7Const(const ARec: TRec7);
+begin
+  Check(FStr = '123', 'Test7Const: Self is broken');
+  Check(ARec.R.I = 98, 'Test7Const: ARec is broken');
+end;
+
+procedure TMyObj.Test8Value(ARec: TRec8);
+begin
+  Check(FStr = '123', 'Test8Value: Self is broken');
+  Check(ARec.R.I1 = 792, 'Test8Value: ARec is broken');
+  Check(ARec.R.I2 = 153, 'Test8Value: ARec is broken');
+end;
+
+procedure TMyObj.Test8Const(const ARec: TRec8);
+begin
+  Check(FStr = '123', 'Test8Const: Self is broken');
+  Check(ARec.R.I1 = 792, 'Test8Const: ARec is broken');
+  Check(ARec.R.I2 = 153, 'Test8Const: ARec is broken');
+end;
+
+function TMyObj.Test1Ret: TRec1;
+begin
+  Check(FStr = '123', 'Test2Ret: Self is broken');
+  Result.Intf := Intf;
+end;
+
+function TMyObj.Test2Ret: TRec2;
+begin
+  Check(FStr = '123', 'Test2Ret: Self is broken');
+  Result.Intf := Intf;
+  Result.B := 24;
+  Result.P := Pointer(8);
+end;
+
+function TMyObj.Test3Ret: TRec3;
+begin
+  Check(FStr = '123', 'Test3Ret: Self is broken');
+  Result.R.Intf := Intf;
+end;
+
+function TMyObj.Test4Ret: TRec4;
+begin
+  Check(FStr = '123', 'Test4Ret: Self is broken');
+  Result.R.Intf := Intf;
+  Result.R.P := Pointer(46);
+  Result.R.B := 13;
+end;
+
+function TMyObj.Test5Ret: TRec5;
+begin
+  Check(FStr = '123', 'Test5Ret: Self is broken');
+  Result.I := 465;
+end;
+
+function TMyObj.Test6Ret: TRec6;
+begin
+  Check(FStr = '123', 'Test6Ret: Self is broken');
+  Result.I1 := 136846;
+  Result.I2 := 8642;
+end;
+
+function TMyObj.Test7Ret: TRec7;
+begin
+  Check(FStr = '123', 'Test7Ret: Self is broken');
+  Result.R.I := 6943;
+end;
+
+function TMyObj.Test8Ret: TRec8;
+begin
+  Check(FStr = '123', 'Test8Ret: Self is broken');
+  Result.R.I1 := 984376;
+  Result.R.I2 := 937;
+end;
+
+procedure ZeroRecord(var Rec; ATypeInfo: PTypeInfo);
+begin
+  FinalizeArray(@Rec, ATypeInfo, 1);
+  FillChar(Rec, GetTypeData(ATypeInfo).RecSize, 0);
+end;
+
+var
+  O: TMyObj;
+  Context: TRttiContext;
+  R1: TRec1; R2: TRec2; R3: TRec3; R4: TRec4;
+  R5: TRec5; R6: TRec6; R7: TRec7; R8: TRec8;
+begin
+  O := TMyObj.Create;
+  Intf := TInterfacedObject.Create;
+  try
+  Context := TRttiContext.Create;
+  try
+    R1.Intf := Intf;
+    Context.GetType(TMyObj).GetMethod('Test1Value').Invoke(O, [TValue.From<TRec1>(R1)]);
+    Context.GetType(TMyObj).GetMethod('Test1Const').Invoke(O, [TValue.From<TRec1>(R1)]);
+
+    R2.Intf := Intf;
+    R2.B := 59;
+    Context.GetType(TMyObj).GetMethod('Test2Value').Invoke(O, [TValue.From<TRec2>(R2)]);
+    Context.GetType(TMyObj).GetMethod('Test2Const').Invoke(O, [TValue.From<TRec2>(R2)]);
+
+    R3.R.Intf := Intf;
+    Context.GetType(TMyObj).GetMethod('Test3Value').Invoke(O, [TValue.From<TRec3>(R3)]);
+    Context.GetType(TMyObj).GetMethod('Test3Const').Invoke(O, [TValue.From<TRec3>(R3)]);
+
+    R4.R.Intf := Intf;
+    R4.R.B := 81;
+    Context.GetType(TMyObj).GetMethod('Test4Value').Invoke(O, [TValue.From<TRec4>(R4)]);
+    Context.GetType(TMyObj).GetMethod('Test4Const').Invoke(O, [TValue.From<TRec4>(R4)]);
+
+    R5.I := 15;
+    Context.GetType(TMyObj).GetMethod('Test5Value').Invoke(O, [TValue.From<TRec5>(R5)]);
+    Context.GetType(TMyObj).GetMethod('Test5Const').Invoke(O, [TValue.From<TRec5>(R5)]);
+
+    R6.I1 := 98;
+    R6.I2 := 102;
+    Context.GetType(TMyObj).GetMethod('Test6Value').Invoke(O, [TValue.From<TRec6>(R6)]);
+    Context.GetType(TMyObj).GetMethod('Test6Const').Invoke(O, [TValue.From<TRec6>(R6)]);
+
+    R7.R.I := 98;
+    Context.GetType(TMyObj).GetMethod('Test7Value').Invoke(O, [TValue.From<TRec7>(R7)]);
+    Context.GetType(TMyObj).GetMethod('Test7Const').Invoke(O, [TValue.From<TRec7>(R7)]);
+
+    R8.R.I1 := 792;
+    R8.R.I2 := 153;
+    Context.GetType(TMyObj).GetMethod('Test8Value').Invoke(O, [TValue.From<TRec8>(R8)]);
+    Context.GetType(TMyObj).GetMethod('Test8Const').Invoke(O, [TValue.From<TRec8>(R8)]);
+
+    ZeroRecord(R1, TypeInfo(R1));
+    R1 := Context.GetType(TMyObj).GetMethod('Test1Ret').Invoke(O, []).AsType<TRec1>();
+    Check(R1.Intf = Intf, 'Test1Ret: Result variable');
+
+    ZeroRecord(R2, TypeInfo(R2));
+    R2 := Context.GetType(TMyObj).GetMethod('Test2Ret').Invoke(O, []).AsType<TRec2>();
+    Check(R2.Intf = Intf, 'Test2Ret: Result variable');
+    Check(R2.B = 24, 'Test2Ret: Result variable');
+
+    ZeroRecord(R3, TypeInfo(R3));
+    R3 := Context.GetType(TMyObj).GetMethod('Test3Ret').Invoke(O, []).AsType<TRec3>();
+    Check(R3.R.Intf = Intf, 'Test3Ret: Result variable');
+
+    ZeroRecord(R4, TypeInfo(R4));
+    R4 := Context.GetType(TMyObj).GetMethod('Test4Ret').Invoke(O, []).AsType<TRec4>();
+    Check(R4.R.Intf = Intf, 'Test4Ret: Result variable');
+    Check(R4.R.B = 13, 'Test4Ret: Result variable');
+
+    ZeroRecord(R5, TypeInfo(R5));
+    R5 := Context.GetType(TMyObj).GetMethod('Test5Ret').Invoke(O, []).AsType<TRec5>();
+    Check(R5.I = 465, 'Test5Ret: Result variable');
+
+    ZeroRecord(R6, TypeInfo(R6));
+    R6 := Context.GetType(TMyObj).GetMethod('Test6Ret').Invoke(O, []).AsType<TRec6>();
+    Check(R6.I1 = 136846, 'Test6Ret: Result variable');
+    Check(R6.I2 = 8642, 'Test6Ret: Result variable');
+
+    ZeroRecord(R7, TypeInfo(R7));
+    R7 := Context.GetType(TMyObj).GetMethod('Test7Ret').Invoke(O, []).AsType<TRec7>();
+    Check(R7.R.I = 6943, 'Test7Ret: Result variable');
+
+    ZeroRecord(R8, TypeInfo(R8));
+    R8 := Context.GetType(TMyObj).GetMethod('Test8Ret').Invoke(O, []).AsType<TRec8>();
+    Check(R8.R.I1 = 984376, 'Test8Ret: Result variable');
+    Check(R8.R.I2 = 937, 'Test8Ret: Result variable');
+  finally
+    Context.Free; O.Free;
+  end;
+  if ErrorCount > 0 then
+    Halt(ErrorCount);
+  WriteLn('OK');
+  except
+    on E: Exception do
+    begin
+      WriteLn(E.ClassName + ': ' + E.Message);
+      Halt(1);
+    end;
+  end;
+end.