paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 12:19:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

* also take param flags into consideration

Browse Source 
git-svn-id: trunk@39890 -
This commit is contained in:
svenbarth 2018-10-07 12:25:49 +00:00
parent 3ca2529b58
commit b91c856e38
1 changed files with 109 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -41,7 +41,7 @@ begin
Dispose(t); Dispose(t);
end; end;
function TypeInfoToFFIType(aTypeInfo: PTypeInfo): pffi_type; forward; function TypeInfoToFFIType(aTypeInfo: PTypeInfo; aFlags: TParamFlags): pffi_type; forward;
function RecordOrObjectToFFIType(aTypeInfo: PTypeInfo): pffi_type; function RecordOrObjectToFFIType(aTypeInfo: PTypeInfo): pffi_type;
var var
@ -99,7 +99,7 @@ begin
Dec(remoffset, SizeOf(Byte)) Dec(remoffset, SizeOf(Byte))
end; end;
{ now add the real field type } { now add the real field type }
AddElement(TypeInfoToFFIType(field^.TypeRef)); AddElement(TypeInfoToFFIType(field^.TypeRef, []));
Inc(field); Inc(field);
curoffset := field^.FldOffset; curoffset := field^.FldOffset;
end; end;
@ -153,7 +153,7 @@ begin
Tpffi_typeArray(Result^.elements) := elements; Tpffi_typeArray(Result^.elements) := elements;
end; end;
function TypeInfoToFFIType(aTypeInfo: PTypeInfo): pffi_type; function TypeInfoToFFIType(aTypeInfo: PTypeInfo; aFlags: TParamFlags): pffi_type;
function TypeKindName: String; function TypeKindName: String;
begin begin
@ -167,103 +167,106 @@ begin
Result := @ffi_type_void; Result := @ffi_type_void;
if Assigned(aTypeInfo) then begin if Assigned(aTypeInfo) then begin
td := GetTypeData(aTypeInfo); td := GetTypeData(aTypeInfo);
case aTypeInfo^.Kind of if aFlags * [pfArray, pfOut, pfVar, pfConstRef] <> [] then
tkInteger, Result := @ffi_type_pointer
tkEnumeration, else
tkBool, case aTypeInfo^.Kind of
tkInt64, tkInteger,
tkQWord: tkEnumeration,
case td^.OrdType of tkBool,
otSByte: tkInt64,
Result := @ffi_type_sint8; tkQWord:
otUByte: case td^.OrdType of
Result := @ffi_type_uint8; otSByte:
otSWord: Result := @ffi_type_sint8;
Result := @ffi_type_sint16; otUByte:
otUWord: Result := @ffi_type_uint8;
Result := @ffi_type_uint16; otSWord:
otSLong: Result := @ffi_type_sint16;
Result := @ffi_type_sint32; otUWord:
otULong: Result := @ffi_type_uint16;
Result := @ffi_type_uint32; otSLong:
otSQWord: Result := @ffi_type_sint32;
Result := @ffi_type_sint64; otULong:
otUQWord: Result := @ffi_type_uint32;
Result := @ffi_type_uint64; otSQWord:
end; Result := @ffi_type_sint64;
tkChar: otUQWord:
Result := @ffi_type_uint8; Result := @ffi_type_uint64;
tkFloat:
case td^.FloatType of
ftSingle:
Result := @ffi_type_float;
ftDouble:
Result := @ffi_type_double;
ftExtended:
Result := @ffi_type_longdouble;
ftComp:
{$ifndef FPC_HAS_TYPE_EXTENDED}
Result := @ffi_type_sint64;
{$else}
Result := @ffi_type_longdouble;
{$endif}
ftCurr:
Result := @ffi_type_sint64;
end;
tkSet:
case td^.OrdType of
otUByte: begin
if td^.SetSize = 1 then
Result := @ffi_type_uint8
else begin
{ ugh... build a of suitable record }
Result := SetToFFIType(td^.SetSize);
end;
end; end;
otUWord: tkChar:
Result := @ffi_type_uint16; Result := @ffi_type_uint8;
otULong: tkFloat:
Result := @ffi_type_uint32; case td^.FloatType of
end; ftSingle:
tkWChar, Result := @ffi_type_float;
tkUChar: ftDouble:
Result := @ffi_type_uint16; Result := @ffi_type_double;
tkInterface, ftExtended:
tkAString, Result := @ffi_type_longdouble;
tkUString, ftComp:
tkWString, {$ifndef FPC_HAS_TYPE_EXTENDED}
tkInterfaceRaw, Result := @ffi_type_sint64;
tkProcVar, {$else}
tkDynArray, Result := @ffi_type_longdouble;
tkClass, {$endif}
tkClassRef, ftCurr:
tkPointer: Result := @ffi_type_sint64;
Result := @ffi_type_pointer; end;
tkMethod: tkSet:
Result := RecordOrObjectToFFIType(TypeInfo(TMethod)); case td^.OrdType of
tkSString: otUByte: begin
{ since shortstrings are rather large they're passed as references } if td^.SetSize = 1 then
Result := @ffi_type_pointer; Result := @ffi_type_uint8
tkObject: else begin
{ passed around as pointer as well } { ugh... build a of suitable record }
Result := @ffi_type_pointer; Result := SetToFFIType(td^.SetSize);
tkArray: end;
{ arrays are passed as pointers to be compatible to C } end;
Result := @ffi_type_pointer; otUWord:
tkRecord: Result := @ffi_type_uint16;
Result := RecordOrObjectToFFIType(aTypeInfo); otULong:
tkVariant: Result := @ffi_type_uint32;
Result := RecordOrObjectToFFIType(TypeInfo(tvardata)); end;
//tkLString: ; tkWChar,
//tkHelper: ; tkUChar:
//tkFile: ; Result := @ffi_type_uint16;
else tkInterface,
raise EInvocationError.CreateFmt(SErrTypeKindNotSupported, [TypeKindName]); tkAString,
end; tkUString,
tkWString,
tkInterfaceRaw,
tkProcVar,
tkDynArray,
tkClass,
tkClassRef,
tkPointer:
Result := @ffi_type_pointer;
tkMethod:
Result := RecordOrObjectToFFIType(TypeInfo(TMethod));
tkSString:
{ since shortstrings are rather large they're passed as references }
Result := @ffi_type_pointer;
tkObject:
{ passed around as pointer as well }
Result := @ffi_type_pointer;
tkArray:
{ arrays are passed as pointers to be compatible to C }
Result := @ffi_type_pointer;
tkRecord:
Result := RecordOrObjectToFFIType(aTypeInfo);
tkVariant:
Result := RecordOrObjectToFFIType(TypeInfo(tvardata));
//tkLString: ;
//tkHelper: ;
//tkFile: ;
else
raise EInvocationError.CreateFmt(SErrTypeKindNotSupported, [TypeKindName]);
end;
end; end;
end; end;
function ValueToFFIValue(constref aValue: Pointer; aKind: TTypeKind; aIsResult: Boolean): Pointer; function ValueToFFIValue(constref aValue: Pointer; aKind: TTypeKind; aFlags: TParamFlags; aIsResult: Boolean): Pointer;
const const
ResultTypeNeedsIndirection = [ ResultTypeNeedsIndirection = [
tkAString, tkAString,
@ -274,7 +277,9 @@ const
]; ];
begin begin
Result := aValue; Result := aValue;
if (aKind = tkSString) or (aIsResult and (aKind in ResultTypeNeedsIndirection)) then if (aKind = tkSString) or
(aIsResult and (aKind in ResultTypeNeedsIndirection)) or
(aFlags * [pfArray, pfOut, pfVar, pfConstRef] <> []) then
Result := @aValue; Result := @aValue;
end; end;
@ -444,8 +449,8 @@ begin
{ the order is Self/Vmt (if any), Result param (if any), other params } { the order is Self/Vmt (if any), Result param (if any), other params }
if not (fcfStatic in aFlags) and retparam then begin if not (fcfStatic in aFlags) and retparam then begin
argtypes[0] := TypeInfoToFFIType(aArgs[0].Info.ParamType); argtypes[0] := TypeInfoToFFIType(aArgs[0].Info.ParamType, aArgs[0].Info.ParamFlags);
argvalues[0] := ValueToFFIValue(aArgs[0].ValueRef, aArgs[0].Info.ParamType^.Kind, False); argvalues[0] := ValueToFFIValue(aArgs[0].ValueRef, aArgs[0].Info.ParamType^.Kind, aArgs[0].Info.ParamFlags, False);
if retparam then if retparam then
Inc(retidx); Inc(retidx);
argstart := 1; argstart := 1;
@ -453,16 +458,16 @@ begin
argstart := 0; argstart := 0;
for i := Low(aArgs) + argstart to High(aArgs) do begin for i := Low(aArgs) + argstart to High(aArgs) do begin
argtypes[i - Low(aArgs) + Low(argtypes) + argoffset] := TypeInfoToFFIType(aArgs[i].Info.ParamType); argtypes[i - Low(aArgs) + Low(argtypes) + argoffset] := TypeInfoToFFIType(aArgs[i].Info.ParamType, aArgs[i].Info.ParamFlags);
argvalues[i - Low(aArgs) + Low(argtypes) + argoffset] := ValueToFFIValue(aArgs[i].ValueRef, aArgs[i].Info.ParamType^.Kind, False); argvalues[i - Low(aArgs) + Low(argtypes) + argoffset] := ValueToFFIValue(aArgs[i].ValueRef, aArgs[i].Info.ParamType^.Kind, aArgs[i].Info.ParamFlags, False);
end; end;
if retparam then begin if retparam then begin
argtypes[retidx] := TypeInfoToFFIType(aResultType); argtypes[retidx] := TypeInfoToFFIType(aResultType, []);
argvalues[retidx] := ValueToFFIValue(aResultValue, aResultType^.Kind, True); argvalues[retidx] := ValueToFFIValue(aResultValue, aResultType^.Kind, [], True);
rtype := @ffi_type_void; rtype := @ffi_type_void;
end else begin end else begin
rtype := TypeInfoToFFIType(aResultType); rtype := TypeInfoToFFIType(aResultType, []);
end; end;
if ffi_prep_cif(@cif, abi, arglen, rtype, @argtypes[0]) <> FFI_OK then if ffi_prep_cif(@cif, abi, arglen, rtype, @argtypes[0]) <> FFI_OK then