paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 12:49:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r39878 into '.':

Browse Source 
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 -
This commit is contained in:
marco 2018-11-12 08:57:15 +00:00
parent f42dffb36d
commit 6f88dbd9d5
3 changed files with 132 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
packages/libffi/src/ffi.manager.pp
View File

@ -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

61
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -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;

2
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -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;