mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 15:29:16 +02:00
* adjust Invoke API of FunctionCallManager to not rely on TValue
git-svn-id: trunk@39881 -
This commit is contained in:
svenbarth
parent
76a95f61e2
commit
00e700d598
@ -263,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,
|
||||
@ -273,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? }
|
||||
@ -304,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
|
||||
@ -315,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);
|
||||
@ -372,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;
|
||||
@ -386,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);
|
||||
@ -405,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
|
||||
|
||||
@ -381,11 +381,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 +405,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 +438,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 +579,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 +728,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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user