--- Merging r39878 into '.':

U    packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r39878 into '.':
 U   .
--- Recording mergeinfo for merge of r39878 into 'packages/rtl-objpas/src/inc/rtti.pp':
 U   packages/rtl-objpas/src/inc/rtti.pp
--- Merging r39879 into '.':
G    packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r39879 into '.':
 G   .
--- Recording mergeinfo for merge of r39879 into 'packages/rtl-objpas/src/inc/rtti.pp':
 G   packages/rtl-objpas/src/inc/rtti.pp
--- Merging r39880 into '.':
U    packages/libffi/src/ffi.manager.pp
--- Recording mergeinfo for merge of r39880 into '.':
 G   .
--- Recording mergeinfo for merge of r39880 into 'packages/rtl-objpas/src/inc/rtti.pp':
 G   packages/rtl-objpas/src/inc/rtti.pp
--- Merging r39881 into '.':
G    packages/rtl-objpas/src/inc/rtti.pp
G    packages/libffi/src/ffi.manager.pp
--- Recording mergeinfo for merge of r39881 into '.':
 G   .
--- Recording mergeinfo for merge of r39881 into 'packages/rtl-objpas/src/inc/rtti.pp':
 G   packages/rtl-objpas/src/inc/rtti.pp
--- Merging r39883 into '.':
U    packages/rtl-objpas/tests/tests.rtti.pas
--- Recording mergeinfo for merge of r39883 into '.':
 G   .
--- Recording mergeinfo for merge of r39883 into 'packages/rtl-objpas/src/inc/rtti.pp':
 G   packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r39883 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 U   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r39884 into '.':
G    packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r39884 into '.':
 G   .
--- Recording mergeinfo for merge of r39884 into 'packages/rtl-objpas/src/inc/rtti.pp':
 G   packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r39884 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas

# revisions: 39878,39879,39880,39881,39883,39884

git-svn-id: branches/fixes_3_2@40287 -

packages/libffi/src/ffi.manager.pp

@@ -157,6 +157,7 @@ function TypeInfoToFFIType(aTypeInfo: PTypeInfo): pffi_type;
 
   function TypeKindName: String;
   begin
+    Result := '';
     WriteStr(Result, aTypeInfo^.Kind);
   end;
 
@@ -262,7 +263,7 @@ begin
   end;
 end;
 
-function ValueToFFIValue(constref Value: TValue; var aIndirect: Pointer; aIsResult: Boolean): Pointer;
+function ValueToFFIValue(constref aValue: Pointer; aKind: TTypeKind; aIsResult: Boolean): Pointer;
 const
   ResultTypeNeedsIndirection = [
    tkAString,
@@ -272,17 +273,85 @@ const
    tkDynArray
   ];
 begin
-  aIndirect := Nil;
-  Result := Value.GetReferenceToRawData;
-  if (Value.Kind = tkSString) or (aIsResult and (Value.Kind in ResultTypeNeedsIndirection)) then begin
-    aIndirect := Result;
-    Result := @aIndirect;
-  end;
+  Result := aValue;
+  if (aKind = tkSString) or (aIsResult and (aKind in ResultTypeNeedsIndirection)) then
+    Result := @aValue;
 end;
 
-function FFIValueToValue(Value: Pointer; TypeInfo: PTypeInfo): TValue;
+procedure FFIValueToValue(Source, Dest: Pointer; TypeInfo: PTypeInfo);
+var
+  size: SizeInt;
+  td: PTypeData;
 begin
-  TValue.Make(Value, TypeInfo, Result);
+  td := GetTypeData(TypeInfo);
+  size := 0;
+  case TypeInfo^.Kind of
+    tkChar,
+    tkWChar,
+    tkUChar,
+    tkEnumeration,
+    tkBool,
+    tkInteger,
+    tkInt64,
+    tkQWord:
+      case td^.OrdType of
+        otSByte,
+        otUByte:
+          size := 1;
+        otSWord,
+        otUWord:
+          size := 2;
+        otSLong,
+        otULong:
+          size := 4;
+        otSQWord,
+        otUQWord:
+          size := 8;
+      end;
+    tkSet:
+      size := td^.SetSize;
+    tkFloat:
+      case td^.FloatType of
+        ftSingle:
+          size := SizeOf(Single);
+        ftDouble:
+          size := SizeOf(Double);
+        ftExtended:
+          size := SizeOf(Extended);
+        ftComp:
+          size := SizeOf(Comp);
+        ftCurr:
+          size := SizeOf(Currency);
+      end;
+    tkMethod:
+      size := SizeOf(TMethod);
+    tkSString:
+      size := td^.MaxLength + 1;
+    tkDynArray,
+    tkLString,
+    tkAString,
+    tkUString,
+    tkWString,
+    tkClass,
+    tkPointer,
+    tkClassRef,
+    tkInterfaceRaw:
+      size := SizeOf(Pointer);
+    tkVariant:
+      size := SizeOf(tvardata);
+    tkArray:
+      size := td^.ArrayData.Size;
+    tkRecord:
+      size := td^.RecSize;
+    tkProcVar:
+      size := SizeOf(CodePointer);
+    tkObject: ;
+    tkHelper: ;
+    tkFile: ;
+  end;
+
+  if size > 0 then
+    Move(Source^, Dest^, size);
 end;
 
 { move this to type info? }
@@ -303,7 +372,7 @@ begin
 end;
 
 procedure FFIInvoke(aCodeAddress: Pointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
-            aResultType: PTypeInfo; out aResultValue: TValue; aFlags: TFunctionCallFlags);
+            aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
 
   function CallConvName: String; inline;
   begin
@@ -314,14 +383,14 @@ var
   abi: ffi_abi;
   argtypes: array of pffi_type;
   argvalues: array of Pointer;
-  argindirect: array of Pointer;
   rtype: pffi_type;
   rvalue: ffi_arg;
   i, arglen, argoffset, retidx, argstart: LongInt;
   cif: ffi_cif;
   retparam: Boolean;
 begin
-  aResultValue := TValue.Empty;
+  if Assigned(aResultType) and not Assigned(aResultValue) then
+    raise EInvocationError.Create(SErrInvokeResultTypeNoValue);
 
   if not (fcfStatic in aFlags) and (Length(aArgs) = 0) then
     raise EInvocationError.Create(SErrMissingSelfParam);
@@ -371,13 +440,12 @@ begin
 
   SetLength(argtypes, arglen);
   SetLength(argvalues, arglen);
-  SetLength(argindirect, arglen);
 
   { the order is Self/Vmt (if any), Result param (if any), other params }
 
   if not (fcfStatic in aFlags) and retparam then begin
-    argtypes[0] := TypeInfoToFFIType(aArgs[0].Value.TypeInfo);
-    argvalues[0] := ValueToFFIValue(aArgs[0].Value, argindirect[0], False);
+    argtypes[0] := TypeInfoToFFIType(aArgs[0].Info.ParamType);
+    argvalues[0] := ValueToFFIValue(aArgs[0].ValueRef, aArgs[0].Info.ParamType^.Kind, False);
     if retparam then
       Inc(retidx);
     argstart := 1;
@@ -385,14 +453,13 @@ begin
     argstart := 0;
 
   for i := Low(aArgs) + argstart to High(aArgs) do begin
-    argtypes[i - Low(aArgs) + Low(argtypes) + argoffset] := TypeInfoToFFIType(aArgs[i].Value.TypeInfo);
-    argvalues[i - Low(aArgs) + Low(argtypes) + argoffset] := ValueToFFIValue(aArgs[i].Value, argindirect[i + argoffset], False);
+    argtypes[i - Low(aArgs) + Low(argtypes) + argoffset] := TypeInfoToFFIType(aArgs[i].Info.ParamType);
+    argvalues[i - Low(aArgs) + Low(argtypes) + argoffset] := ValueToFFIValue(aArgs[i].ValueRef, aArgs[i].Info.ParamType^.Kind, False);
   end;
 
   if retparam then begin
     argtypes[retidx] := TypeInfoToFFIType(aResultType);
-    TValue.Make(Nil, aResultType, aResultValue);
-    argvalues[retidx] := ValueToFFIValue(aResultValue, argindirect[retidx], True);
+    argvalues[retidx] := ValueToFFIValue(aResultValue, aResultType^.Kind, True);
     rtype := @ffi_type_void;
   end else begin
     rtype := TypeInfoToFFIType(aResultType);
@@ -404,7 +471,7 @@ begin
   ffi_call(@cif, ffi_fn(aCodeAddress), @rvalue, @argvalues[0]);
 
   if Assigned(aResultType) and not retparam then
-    aResultValue := FFIValueToValue(@rvalue, aResultType);
+    FFIValueToValue(@rvalue, aResultValue, aResultType);
 end;
 
 const

packages/rtl-objpas/src/inc/rtti.pp

@@ -193,10 +193,11 @@ type
     function GetTypeSize: integer; virtual;
     function GetBaseType: TRttiType; virtual;
   public
-    constructor create(ATypeInfo : PTypeInfo);
+    constructor Create(ATypeInfo : PTypeInfo);
     function GetProperties: specialize TArray<TRttiProperty>; virtual;
     function GetProperty(const AName: string): TRttiProperty; virtual;
     function GetMethods: specialize TArray<TRttiMethod>; virtual;
+    function GetMethod(const aName: String): TRttiMethod; virtual;
     function GetDeclaredMethods: specialize TArray<TRttiMethod>; virtual;
     property IsInstance: boolean read GetIsInstance;
     property isManaged: boolean read GetIsManaged;
@@ -247,7 +248,7 @@ type
   protected
     function GetVisibility: TMemberVisibility; virtual;
   public
-    constructor create(AParent: TRttiType);
+    constructor Create(AParent: TRttiType);
     property Visibility: TMemberVisibility read GetVisibility;
     property Parent: TRttiType read FParent;
   end;
@@ -265,7 +266,7 @@ type
     function GetName: string; override;
     function GetHandle: Pointer; override;
   public
-    constructor create(AParent: TRttiType; APropInfo: PPropInfo);
+    constructor Create(AParent: TRttiType; APropInfo: PPropInfo);
     function GetValue(Instance: pointer): TValue;
     procedure SetValue(Instance: pointer; const AValue: TValue);
     property PropertyType: TRttiType read GetPropertyType;
@@ -381,11 +382,16 @@ type
   EInvocationError = class(Exception);
   ENonPublicType = class(Exception);
 
-  TFunctionCallParameter = record
-    Value: TValue;
+  TFunctionCallParameterInfo = record
+    ParamType: PTypeInfo;
     ParamFlags: TParamFlags;
     ParaLocs: PParameterLocations;
   end;
+
+  TFunctionCallParameter = record
+    ValueRef: Pointer;
+    Info: TFunctionCallParameterInfo;
+  end;
   TFunctionCallParameterArray = specialize TArray<TFunctionCallParameter>;
 
   TFunctionCallFlag = (
@@ -400,7 +406,7 @@ type
 
   TFunctionCallManager = record
     Invoke: procedure(CodeAddress: CodePointer; const Args: TFunctionCallParameterArray; CallingConvention: TCallConv;
-              ResultType: PTypeInfo; out ResultValue: TValue; Flags: TFunctionCallFlags);
+              ResultType: PTypeInfo; ResultValue: Pointer; Flags: TFunctionCallFlags);
     CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
     CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
     FreeCallback: procedure(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
@@ -433,6 +439,7 @@ function IsManaged(TypeInfo: PTypeInfo): boolean;
 { these resource strings are needed by units implementing function call managers }
 resourcestring
   SErrInvokeNotImplemented = 'Invoke functionality is not implemented';
+  SErrInvokeResultTypeNoValue = 'Function has a result type, but no result pointer provided';
   SErrInvokeFailed = 'Invoke call failed';
   SErrCallbackNotImplented = 'Callback functionality is not implemented';
   SErrCallConvNotSupported = 'Calling convention not supported: %s';
@@ -573,7 +580,7 @@ var
   FuncCallMgr: TFunctionCallManagerArray;
 
 procedure NoInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
-            aResultType: PTypeInfo; out aResultValue: TValue; aFlags: TFunctionCallFlags);
+            aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
 begin
   raise ENotImplemented.Create(SErrInvokeNotImplemented);
 end;
@@ -722,12 +729,18 @@ begin
 
   SetLength(funcargs, Length(aArgs));
   for i := Low(aArgs) to High(aArgs) do begin
-    funcargs[i - Low(aArgs) + Low(funcargs)].Value := aArgs[i];
-    funcargs[i - Low(aArgs) + Low(funcargs)].ParamFlags := [];
-    funcargs[i - Low(aArgs) + Low(funcargs)].ParaLocs := Nil;
+    funcargs[i - Low(aArgs) + Low(funcargs)].ValueRef := aArgs[i].GetReferenceToRawData;
+    funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamType := aArgs[i].TypeInfo;
+    funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamFlags := [];
+    funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParaLocs := Nil;
   end;
 
-  FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result, flags);
+  if Assigned(aResultType) then
+    TValue.Make(Nil, aResultType, Result)
+  else
+    Result := TValue.Empty;
+
+  FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags);
 end;
 
 function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
@@ -1855,7 +1868,7 @@ end;
 
 function TValue.GetReferenceToRawData: Pointer;
 begin
-  if IsEmpty then
+  if not Assigned(FData.FTypeInfo) then
     Result := Nil
   else if Assigned(FData.FValueData) then
     Result := FData.FValueData.GetReferenceToRawData
@@ -2299,9 +2312,9 @@ begin
   result := mvPublished;
 end;
 
-constructor TRttiMember.create(AParent: TRttiType);
+constructor TRttiMember.Create(AParent: TRttiType);
 begin
-  inherited create();
+  inherited Create();
   FParent := AParent;
 end;
 
@@ -2338,9 +2351,9 @@ begin
   Result := FPropInfo;
 end;
 
-constructor TRttiProperty.create(AParent: TRttiType; APropInfo: PPropInfo);
+constructor TRttiProperty.Create(AParent: TRttiType; APropInfo: PPropInfo);
 begin
-  inherited create(AParent);
+  inherited Create(AParent);
   FPropInfo := APropInfo;
 end;
 
@@ -2548,9 +2561,9 @@ begin
   Result := FTypeInfo;
 end;
 
-constructor TRttiType.create(ATypeInfo: PTypeInfo);
+constructor TRttiType.Create(ATypeInfo: PTypeInfo);
 begin
-  inherited create();
+  inherited Create();
   FTypeInfo:=ATypeInfo;
   if assigned(FTypeInfo) then
     FTypeData:=GetTypeData(ATypeInfo);
@@ -2596,6 +2609,18 @@ begin
   Result := fMethods;
 end;
 
+function TRttiType.GetMethod(const aName: String): TRttiMethod;
+var
+  methods: specialize TArray<TRttiMethod>;
+  method: TRttiMethod;
+begin
+  methods := GetMethods;
+  for method in methods do
+    if SameText(method.Name, AName) then
+      Exit(method);
+  Result := Nil;
+end;
+
 function TRttiType.GetDeclaredMethods: specialize TArray<TRttiMethod>;
 begin
   Result := Nil;

packages/rtl-objpas/tests/tests.rtti.pas

@@ -330,6 +330,7 @@ begin
   CheckEquals(AValue.IsClass, False);
   CheckEquals(AValue.IsObject, True);
   Check(AValue.AsObject=ATestClass);
+  Check(PPointer(AValue.GetReferenceToRawData)^ = Pointer(ATestClass));
   CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
   ATestClass.Free;
 end;
@@ -350,6 +351,7 @@ begin
   CheckEquals(value.GetArrayLength, 2);
   CheckEquals(value.GetArrayElement(0).AsInteger, 42);
   CheckEquals(value.GetArrayElement(1).AsInteger, 21);
+  Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arr));
   value.SetArrayElement(0, 84);
   CheckEquals(arr[0], 84);
 end;