mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 17:49:27 +02:00
--- Merging r39886 into '.':
U packages/rtl-objpas/src/inc/rtti.pp U packages/rtl-objpas/tests/tests.rtti.pas --- Recording mergeinfo for merge of r39886 into '.': U . --- Recording mergeinfo for merge of r39886 into 'packages/rtl-objpas/src/inc/rtti.pp': U packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39886 into 'packages/rtl-objpas/tests/tests.rtti.pas': U packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39887 into '.': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39887 into '.': G . --- Recording mergeinfo for merge of r39887 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39887 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39888 into '.': G packages/rtl-objpas/tests/tests.rtti.pas G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39888 into '.': G . --- Recording mergeinfo for merge of r39888 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39888 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39889 into '.': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39889 into '.': G . --- Recording mergeinfo for merge of r39889 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39889 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39890 into '.': U packages/libffi/src/ffi.manager.pp --- Recording mergeinfo for merge of r39890 into '.': G . --- Recording mergeinfo for merge of r39890 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39890 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39891 into '.': G packages/libffi/src/ffi.manager.pp --- Recording mergeinfo for merge of r39891 into '.': G . --- Recording mergeinfo for merge of r39891 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39891 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39892 into '.': G packages/libffi/src/ffi.manager.pp --- Recording mergeinfo for merge of r39892 into '.': G . --- Recording mergeinfo for merge of r39892 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39892 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39893 into '.': U packages/rtl-objpas/tests/tests.rtti.invoke.pas G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39893 into '.': G . --- Recording mergeinfo for merge of r39893 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39893 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39894 into '.': U packages/rtl-objpas/fpmake.pp A packages/rtl-objpas/src/x86_64 A packages/rtl-objpas/src/x86_64/invoke.inc G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39894 into '.': G . --- Recording mergeinfo for merge of r39894 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39894 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39895 into '.': U packages/rtl-objpas/tests/testrunner.rtlobjpas.pp --- Recording mergeinfo for merge of r39895 into '.': G . --- Recording mergeinfo for merge of r39895 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39895 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39896 into '.': G packages/rtl-objpas/tests/testrunner.rtlobjpas.pp --- Recording mergeinfo for merge of r39896 into '.': G . --- Recording mergeinfo for merge of r39896 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39896 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas --- Merging r39897 into '.': G packages/rtl-objpas/tests/tests.rtti.invoke.pas --- Recording mergeinfo for merge of r39897 into '.': G . --- Recording mergeinfo for merge of r39897 into 'packages/rtl-objpas/src/inc/rtti.pp': G packages/rtl-objpas/src/inc/rtti.pp --- Recording mergeinfo for merge of r39897 into 'packages/rtl-objpas/tests/tests.rtti.pas': G packages/rtl-objpas/tests/tests.rtti.pas # revisions: 39886,39887,39888,39889,39890,39891,39892,39893,39894,39895,39896,39897 git-svn-id: branches/fixes_3_2@40288 -
This commit is contained in:
marco
parent
6f88dbd9d5
commit
3661b7bcfa
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -7494,6 +7494,7 @@ packages/rtl-objpas/src/inc/varutilh.inc svneol=native#text/plain
|
||||
packages/rtl-objpas/src/inc/varutils.inc svneol=native#text/plain
|
||||
packages/rtl-objpas/src/inc/widestrutils.pp svneol=native#text/plain
|
||||
packages/rtl-objpas/src/win/varutils.pp svneol=native#text/plain
|
||||
packages/rtl-objpas/src/x86_64/invoke.inc svneol=native#text/plain
|
||||
packages/rtl-objpas/tests/testrunner.rtlobjpas.pp svneol=native#text/pascal
|
||||
packages/rtl-objpas/tests/tests.rtti.invoke.pas svneol=native#text/pascal
|
||||
packages/rtl-objpas/tests/tests.rtti.pas svneol=native#text/plain
|
||||
|
||||
@ -41,7 +41,7 @@ begin
|
||||
Dispose(t);
|
||||
end;
|
||||
|
||||
function TypeInfoToFFIType(aTypeInfo: PTypeInfo): pffi_type; forward;
|
||||
function TypeInfoToFFIType(aTypeInfo: PTypeInfo; aFlags: TParamFlags): pffi_type; forward;
|
||||
|
||||
function RecordOrObjectToFFIType(aTypeInfo: PTypeInfo): pffi_type;
|
||||
var
|
||||
@ -58,9 +58,10 @@ var
|
||||
end;
|
||||
|
||||
var
|
||||
td: PTypeData;
|
||||
i, curoffset, remoffset: SizeInt;
|
||||
td, fieldtd: PTypeData;
|
||||
i, j, curoffset, remoffset: SizeInt;
|
||||
field: PManagedField;
|
||||
ffitype: pffi_type;
|
||||
begin
|
||||
td := GetTypeData(aTypeInfo);
|
||||
if td^.TotalFieldCount = 0 then
|
||||
@ -69,6 +70,7 @@ begin
|
||||
New(Result);
|
||||
FillChar(Result^, SizeOf(Result), 0);
|
||||
Result^._type := _FFI_TYPE_STRUCT;
|
||||
Result^.elements := Nil;
|
||||
curoffset := 0;
|
||||
curindex := 0;
|
||||
field := PManagedField(PByte(@td^.TotalFieldCount) + SizeOf(td^.TotalFieldCount));
|
||||
@ -98,8 +100,21 @@ begin
|
||||
AddElement(@ffi_type_uint8);
|
||||
Dec(remoffset, SizeOf(Byte))
|
||||
end;
|
||||
{ now add the real field type }
|
||||
AddElement(TypeInfoToFFIType(field^.TypeRef));
|
||||
{ now add the real field type (Note: some are handled differently from
|
||||
being passed as arguments, so we handle those here) }
|
||||
if field^.TypeRef^.Kind = tkObject then
|
||||
AddElement(RecordOrObjectToFFIType(field^.TypeRef))
|
||||
else if field^.TypeRef^.Kind = tkSString then begin
|
||||
fieldtd := GetTypeData(field^.TypeRef);
|
||||
for j := 0 to fieldtd^.MaxLength + 1 do
|
||||
AddElement(@ffi_type_uint8);
|
||||
end else if field^.TypeRef^.Kind = tkArray then begin
|
||||
fieldtd := GetTypeData(field^.TypeRef);
|
||||
ffitype := TypeInfoToFFIType(fieldtd^.ArrayData.ElType, []);
|
||||
for j := 0 to fieldtd^.ArrayData.ElCount - 1 do
|
||||
AddElement(ffitype);
|
||||
end else
|
||||
AddElement(TypeInfoToFFIType(field^.TypeRef, []));
|
||||
Inc(field);
|
||||
curoffset := field^.FldOffset;
|
||||
end;
|
||||
@ -130,6 +145,7 @@ begin
|
||||
Exit(Nil);
|
||||
New(Result);
|
||||
Result^._type := _FFI_TYPE_STRUCT;
|
||||
Result^.elements := Nil;
|
||||
curindex := 0;
|
||||
SetLength(elements, aSize);
|
||||
while aSize >= SizeOf(QWord) do begin
|
||||
@ -153,7 +169,7 @@ begin
|
||||
Tpffi_typeArray(Result^.elements) := elements;
|
||||
end;
|
||||
|
||||
function TypeInfoToFFIType(aTypeInfo: PTypeInfo): pffi_type;
|
||||
function TypeInfoToFFIType(aTypeInfo: PTypeInfo; aFlags: TParamFlags): pffi_type;
|
||||
|
||||
function TypeKindName: String;
|
||||
begin
|
||||
@ -167,103 +183,106 @@ begin
|
||||
Result := @ffi_type_void;
|
||||
if Assigned(aTypeInfo) then begin
|
||||
td := GetTypeData(aTypeInfo);
|
||||
case aTypeInfo^.Kind of
|
||||
tkInteger,
|
||||
tkEnumeration,
|
||||
tkBool,
|
||||
tkInt64,
|
||||
tkQWord:
|
||||
case td^.OrdType of
|
||||
otSByte:
|
||||
Result := @ffi_type_sint8;
|
||||
otUByte:
|
||||
Result := @ffi_type_uint8;
|
||||
otSWord:
|
||||
Result := @ffi_type_sint16;
|
||||
otUWord:
|
||||
Result := @ffi_type_uint16;
|
||||
otSLong:
|
||||
Result := @ffi_type_sint32;
|
||||
otULong:
|
||||
Result := @ffi_type_uint32;
|
||||
otSQWord:
|
||||
Result := @ffi_type_sint64;
|
||||
otUQWord:
|
||||
Result := @ffi_type_uint64;
|
||||
end;
|
||||
tkChar:
|
||||
Result := @ffi_type_uint8;
|
||||
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;
|
||||
if aFlags * [pfArray, pfOut, pfVar, pfConstRef] <> [] then
|
||||
Result := @ffi_type_pointer
|
||||
else
|
||||
case aTypeInfo^.Kind of
|
||||
tkInteger,
|
||||
tkEnumeration,
|
||||
tkBool,
|
||||
tkInt64,
|
||||
tkQWord:
|
||||
case td^.OrdType of
|
||||
otSByte:
|
||||
Result := @ffi_type_sint8;
|
||||
otUByte:
|
||||
Result := @ffi_type_uint8;
|
||||
otSWord:
|
||||
Result := @ffi_type_sint16;
|
||||
otUWord:
|
||||
Result := @ffi_type_uint16;
|
||||
otSLong:
|
||||
Result := @ffi_type_sint32;
|
||||
otULong:
|
||||
Result := @ffi_type_uint32;
|
||||
otSQWord:
|
||||
Result := @ffi_type_sint64;
|
||||
otUQWord:
|
||||
Result := @ffi_type_uint64;
|
||||
end;
|
||||
otUWord:
|
||||
Result := @ffi_type_uint16;
|
||||
otULong:
|
||||
Result := @ffi_type_uint32;
|
||||
end;
|
||||
tkWChar,
|
||||
tkUChar:
|
||||
Result := @ffi_type_uint16;
|
||||
tkInterface,
|
||||
tkAString,
|
||||
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;
|
||||
tkChar:
|
||||
Result := @ffi_type_uint8;
|
||||
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;
|
||||
otUWord:
|
||||
Result := @ffi_type_uint16;
|
||||
otULong:
|
||||
Result := @ffi_type_uint32;
|
||||
end;
|
||||
tkWChar,
|
||||
tkUChar:
|
||||
Result := @ffi_type_uint16;
|
||||
tkInterface,
|
||||
tkAString,
|
||||
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;
|
||||
|
||||
function ValueToFFIValue(constref aValue: Pointer; aKind: TTypeKind; aIsResult: Boolean): Pointer;
|
||||
function ValueToFFIValue(constref aValue: Pointer; aKind: TTypeKind; aFlags: TParamFlags; aIsResult: Boolean): Pointer;
|
||||
const
|
||||
ResultTypeNeedsIndirection = [
|
||||
tkAString,
|
||||
@ -274,7 +293,9 @@ const
|
||||
];
|
||||
begin
|
||||
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;
|
||||
end;
|
||||
|
||||
@ -444,8 +465,8 @@ begin
|
||||
{ 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].Info.ParamType);
|
||||
argvalues[0] := ValueToFFIValue(aArgs[0].ValueRef, aArgs[0].Info.ParamType^.Kind, False);
|
||||
argtypes[0] := TypeInfoToFFIType(aArgs[0].Info.ParamType, aArgs[0].Info.ParamFlags);
|
||||
argvalues[0] := ValueToFFIValue(aArgs[0].ValueRef, aArgs[0].Info.ParamType^.Kind, aArgs[0].Info.ParamFlags, False);
|
||||
if retparam then
|
||||
Inc(retidx);
|
||||
argstart := 1;
|
||||
@ -453,16 +474,16 @@ begin
|
||||
argstart := 0;
|
||||
|
||||
for i := Low(aArgs) + argstart to High(aArgs) do begin
|
||||
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);
|
||||
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, aArgs[i].Info.ParamFlags, False);
|
||||
end;
|
||||
|
||||
if retparam then begin
|
||||
argtypes[retidx] := TypeInfoToFFIType(aResultType);
|
||||
argvalues[retidx] := ValueToFFIValue(aResultValue, aResultType^.Kind, True);
|
||||
argtypes[retidx] := TypeInfoToFFIType(aResultType, []);
|
||||
argvalues[retidx] := ValueToFFIValue(aResultValue, aResultType^.Kind, [], True);
|
||||
rtype := @ffi_type_void;
|
||||
end else begin
|
||||
rtype := TypeInfoToFFIType(aResultType);
|
||||
rtype := TypeInfoToFFIType(aResultType, []);
|
||||
end;
|
||||
|
||||
if ffi_prep_cif(@cif, abi, arglen, rtype, @argtypes[0]) <> FFI_OK then
|
||||
|
||||
@ -57,6 +57,7 @@ begin
|
||||
|
||||
P.IncludePath.Add('src/inc');
|
||||
P.IncludePath.Add('src/$(OS)');
|
||||
P.IncludePath.Add('src/$(CPU)');
|
||||
P.IncludePath.Add('src/common',CommonSrcOSes);
|
||||
|
||||
T:=P.Targets.AddUnit('strutils.pp',StrUtilsOses);
|
||||
@ -119,6 +120,10 @@ begin
|
||||
end;
|
||||
|
||||
T:=P.Targets.AddUnit('rtti.pp',RttiOSes);
|
||||
with T.Dependencies do
|
||||
begin
|
||||
AddInclude('invoke.inc',[x86_64],RttiOSes);
|
||||
end;
|
||||
T.ResourceStrings:=true;
|
||||
end
|
||||
end;
|
||||
|
||||
@ -76,6 +76,8 @@ type
|
||||
14: (FAsSInt64: Int64);
|
||||
15: (FAsMethod: TMethod);
|
||||
16: (FAsPointer: Pointer);
|
||||
{ FPC addition for open arrays }
|
||||
17: (FArrLength: SizeInt; FElSize: SizeInt);
|
||||
end;
|
||||
|
||||
{ TValue }
|
||||
@ -91,10 +93,15 @@ type
|
||||
public
|
||||
class function Empty: TValue; static;
|
||||
class procedure Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); static;
|
||||
{ Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! }
|
||||
class procedure MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue); static;
|
||||
{$ifndef NoGenericMethods}
|
||||
generic class function From<T>(constref aValue: T): TValue; static; inline;
|
||||
{ Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! }
|
||||
generic class function FromOpenArray<T>(constref aValue: array of T): TValue; static; inline;
|
||||
{$endif}
|
||||
function IsArray: boolean; inline;
|
||||
function IsOpenArray: Boolean; inline;
|
||||
function AsString: string; inline;
|
||||
function AsUnicodeString: UnicodeString;
|
||||
function AsAnsiString: AnsiString;
|
||||
@ -287,6 +294,42 @@ type
|
||||
function ToString: String; override;
|
||||
end;
|
||||
|
||||
TRttiInvokableType = class(TRttiType)
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; virtual; abstract;
|
||||
function GetCallingConvention: TCallConv; virtual; abstract;
|
||||
function GetReturnType: TRttiType; virtual; abstract;
|
||||
public
|
||||
function GetParameters: specialize TArray<TRttiParameter>; inline;
|
||||
property CallingConvention: TCallConv read GetCallingConvention;
|
||||
property ReturnType: TRttiType read GetReturnType;
|
||||
function Invoke(const aProcOrMeth: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
|
||||
end;
|
||||
|
||||
TRttiMethodType = class(TRttiInvokableType)
|
||||
private
|
||||
FCallConv: TCallConv;
|
||||
FReturnType: TRttiType;
|
||||
FParams, FParamsAll: specialize TArray<TRttiParameter>;
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
|
||||
function GetCallingConvention: TCallConv; override;
|
||||
function GetReturnType: TRttiType; override;
|
||||
public
|
||||
function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
|
||||
end;
|
||||
|
||||
TRttiProcedureType = class(TRttiInvokableType)
|
||||
private
|
||||
FParams, FParamsAll: specialize TArray<TRttiParameter>;
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
|
||||
function GetCallingConvention: TCallConv; override;
|
||||
function GetReturnType: TRttiType; override;
|
||||
public
|
||||
function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
|
||||
end;
|
||||
|
||||
TDispatchKind = (
|
||||
dkStatic,
|
||||
dkVtable,
|
||||
@ -312,6 +355,7 @@ type
|
||||
function GetMethodKind: TMethodKind; virtual; abstract;
|
||||
function GetReturnType: TRttiType; virtual; abstract;
|
||||
function GetVirtualIndex: SmallInt; virtual; abstract;
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; virtual; abstract;
|
||||
public
|
||||
property CallingConvention: TCallConv read GetCallingConvention;
|
||||
property CodeAddress: CodePointer read GetCodeAddress;
|
||||
@ -325,7 +369,10 @@ type
|
||||
property ReturnType: TRttiType read GetReturnType;
|
||||
property VirtualIndex: SmallInt read GetVirtualIndex;
|
||||
function ToString: String; override;
|
||||
function GetParameters: specialize TArray<TRttiParameter>; virtual; abstract;
|
||||
function GetParameters: specialize TArray<TRttiParameter>; inline;
|
||||
function Invoke(aInstance: TObject; const aArgs: array of TValue): TValue;
|
||||
function Invoke(aInstance: TClass; const aArgs: array of TValue): TValue;
|
||||
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
|
||||
end;
|
||||
|
||||
TRttiStructuredType = class(TRttiType)
|
||||
@ -436,6 +483,10 @@ procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
|
||||
|
||||
function IsManaged(TypeInfo: PTypeInfo): boolean;
|
||||
|
||||
{$ifndef InLazIDE}
|
||||
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
|
||||
{$endif}
|
||||
|
||||
{ these resource strings are needed by units implementing function call managers }
|
||||
resourcestring
|
||||
SErrInvokeNotImplemented = 'Invoke functionality is not implemented';
|
||||
@ -543,11 +594,26 @@ type
|
||||
constructor Create(AVmtMethodParam: PVmtMethodParam);
|
||||
end;
|
||||
|
||||
TRttiMethodTypeParameter = class(TRttiParameter)
|
||||
private
|
||||
fHandle: Pointer;
|
||||
fName: String;
|
||||
fFlags: TParamFlags;
|
||||
fType: PTypeInfo;
|
||||
protected
|
||||
function GetHandle: Pointer; override;
|
||||
function GetName: String; override;
|
||||
function GetFlags: TParamFlags; override;
|
||||
function GetParamType: TRttiType; override;
|
||||
public
|
||||
constructor Create(aHandle: Pointer; const aName: String; aFlags: TParamFlags; aType: PTypeInfo);
|
||||
end;
|
||||
|
||||
TRttiIntfMethod = class(TRttiMethod)
|
||||
private
|
||||
FIntfMethodEntry: PIntfMethodEntry;
|
||||
FIndex: SmallInt;
|
||||
FParams: specialize TArray<TRttiParameter>;
|
||||
FParams, FParamsAll: specialize TArray<TRttiParameter>;
|
||||
protected
|
||||
function GetHandle: Pointer; override;
|
||||
function GetName: String; override;
|
||||
@ -562,9 +628,9 @@ type
|
||||
function GetMethodKind: TMethodKind; override;
|
||||
function GetReturnType: TRttiType; override;
|
||||
function GetVirtualIndex: SmallInt; override;
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
|
||||
public
|
||||
constructor Create(AParent: TRttiType; AIntfMethodEntry: PIntfMethodEntry; AIndex: SmallInt);
|
||||
function GetParameters: specialize TArray<TRttiParameter>; override;
|
||||
end;
|
||||
|
||||
resourcestring
|
||||
@ -573,12 +639,28 @@ resourcestring
|
||||
SErrInvalidTypecast = 'Invalid class typecast';
|
||||
SErrRttiObjectNoHandle = 'RTTI object instance has no valid handle property';
|
||||
SErrRttiObjectAlreadyRegistered = 'A RTTI object with handle 0x%x is already registered';
|
||||
SErrInvokeInsufficientRtti = 'Insufficient RTTI to invoke function';
|
||||
SErrInvokeStaticNoSelf = 'Static function must not be called with in an instance: %s';
|
||||
SErrInvokeNotStaticNeedsSelf = 'Non static function must be called with an instance: %s';
|
||||
SErrInvokeClassMethodClassSelf = 'Class method needs to be called with a class type: %s';
|
||||
SErrInvokeArrayArgExpected = 'Array argument expected for parameter %s of method %s';
|
||||
SErrInvokeArgInvalidType = 'Invalid type of argument for parameter %s of method %s';
|
||||
SErrInvokeArgCount = 'Invalid argument count for method %s; expected %d, but got %d';
|
||||
SErrInvokeNoCodeAddr = 'Failed to determine code address for method: %s';
|
||||
SErrInvokeRttiDataError = 'The RTTI data is inconsistent for method: %s';
|
||||
SErrInvokeCallableNotProc = 'The callable value is not a procedure variable for: %s';
|
||||
SErrInvokeCallableNotMethod = 'The callable value is not a method variable for: %s';
|
||||
|
||||
var
|
||||
PoolRefCount : integer;
|
||||
GRttiPool : TRttiPool;
|
||||
FuncCallMgr: TFunctionCallManagerArray;
|
||||
|
||||
function CCToStr(aCC: TCallConv): String; inline;
|
||||
begin
|
||||
WriteStr(Result, aCC);
|
||||
end;
|
||||
|
||||
procedure NoInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
|
||||
aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
|
||||
begin
|
||||
@ -743,6 +825,108 @@ begin
|
||||
FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags);
|
||||
end;
|
||||
|
||||
function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; aInstance: TValue; constref aArgs: array of TValue; const aParams: specialize TArray<TRttiParameter>; aReturnType: TRttiType): TValue;
|
||||
var
|
||||
arrparam, param: TRttiParameter;
|
||||
unhidden, highs, i: SizeInt;
|
||||
args: TFunctionCallParameterArray;
|
||||
highargs: array of SizeInt;
|
||||
restype: PTypeInfo;
|
||||
resptr: Pointer;
|
||||
mgr: TFunctionCallManager;
|
||||
flags: TFunctionCallFlags;
|
||||
begin
|
||||
mgr := FuncCallMgr[aCallConv];
|
||||
if not Assigned(mgr.Invoke) then
|
||||
raise EInvocationError.CreateFmt(SErrCallConvNotSupported, [CCToStr(aCallConv)]);
|
||||
|
||||
if not Assigned(aCodeAddress) then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeNoCodeAddr, [aName]);
|
||||
|
||||
unhidden := 0;
|
||||
highs := 0;
|
||||
for param in aParams do begin
|
||||
if unhidden < Length(aArgs) then begin
|
||||
if pfArray in param.Flags then begin
|
||||
if Assigned(aArgs[unhidden].TypeInfo) and not aArgs[unhidden].IsArray and (aArgs[unhidden].Kind <> param.ParamType.TypeKind) then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeArrayArgExpected, [param.Name, aName]);
|
||||
end else if not (pfHidden in param.Flags) then begin
|
||||
if aArgs[unhidden].Kind <> param.ParamType.TypeKind then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]);
|
||||
end;
|
||||
end;
|
||||
if not (pfHidden in param.Flags) then
|
||||
Inc(unhidden);
|
||||
if pfHigh in param.Flags then
|
||||
Inc(highs);
|
||||
end;
|
||||
|
||||
if unhidden <> Length(aArgs) then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeArgCount, [aName, unhidden, Length(aArgs)]);
|
||||
|
||||
if Assigned(aReturnType) then begin
|
||||
TValue.Make(Nil, aReturnType.FTypeInfo, Result);
|
||||
resptr := Result.GetReferenceToRawData;
|
||||
restype := aReturnType.FTypeInfo;
|
||||
end else begin
|
||||
Result := TValue.Empty;
|
||||
resptr := Nil;
|
||||
restype := Nil;
|
||||
end;
|
||||
|
||||
SetLength(highargs, highs);
|
||||
SetLength(args, Length(aParams));
|
||||
unhidden := 0;
|
||||
highs := 0;
|
||||
|
||||
for i := 0 to High(aParams) do begin
|
||||
param := aParams[i];
|
||||
args[i].Info.ParamType := param.ParamType.FTypeInfo;
|
||||
args[i].Info.ParamFlags := param.Flags;
|
||||
args[i].Info.ParaLocs := Nil;
|
||||
|
||||
if pfHidden in param.Flags then begin
|
||||
if pfSelf in param.Flags then
|
||||
args[i].ValueRef := aInstance.GetReferenceToRawData
|
||||
else if pfResult in param.Flags then begin
|
||||
if not Assigned(restype) then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeRttiDataError, [aName]);
|
||||
args[i].ValueRef := resptr;
|
||||
restype := Nil;
|
||||
resptr := Nil;
|
||||
end else if pfHigh in param.Flags then begin
|
||||
{ the corresponding array argument is the *previous* unhidden argument }
|
||||
if aArgs[unhidden - 1].IsArray then
|
||||
highargs[highs] := aArgs[unhidden - 1].GetArrayLength - 1
|
||||
else if not Assigned(aArgs[unhidden - 1].TypeInfo) then
|
||||
highargs[highs] := -1
|
||||
else
|
||||
highargs[highs] := 0;
|
||||
args[i].ValueRef := @highargs[highs];
|
||||
Inc(highs);
|
||||
end;
|
||||
end else begin
|
||||
if (pfArray in param.Flags) then begin
|
||||
if not Assigned(aArgs[unhidden].TypeInfo) then
|
||||
args[i].ValueRef := Nil
|
||||
else if aArgs[unhidden].Kind = tkDynArray then
|
||||
args[i].ValueRef := PPointer(aArgs[unhidden].GetReferenceToRawData)^
|
||||
else
|
||||
args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData;
|
||||
end else
|
||||
args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData;
|
||||
|
||||
Inc(unhidden);
|
||||
end;
|
||||
end;
|
||||
|
||||
flags := [];
|
||||
if aStatic then
|
||||
Include(flags, fcfStatic);
|
||||
|
||||
mgr.Invoke(aCodeAddress, args, aCallConv, restype, resptr, flags);
|
||||
end;
|
||||
|
||||
function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
|
||||
begin
|
||||
if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then
|
||||
@ -794,6 +978,19 @@ begin
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
{$ifndef InLazIDE}
|
||||
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
|
||||
var
|
||||
arr: specialize TArray<T>;
|
||||
i: SizeInt;
|
||||
begin
|
||||
SetLength(arr, Length(aArray));
|
||||
for i := 0 to High(aArray) do
|
||||
arr[i] := aArray[i];
|
||||
Result := TValue.specialize From<specialize TArray<T>>(arr);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
{ TRttiPointerType }
|
||||
|
||||
function TRttiPointerType.GetReferredType: TRttiType;
|
||||
@ -850,6 +1047,8 @@ begin
|
||||
tkWString : Result := TRttiStringType.Create(ATypeInfo);
|
||||
tkFloat : Result := TRttiFloatType.Create(ATypeInfo);
|
||||
tkPointer : Result := TRttiPointerType.Create(ATypeInfo);
|
||||
tkProcVar : Result := TRttiProcedureType.Create(ATypeInfo);
|
||||
tkMethod : Result := TRttiMethodType.Create(ATypeInfo);
|
||||
else
|
||||
Result := TRttiType.Create(ATypeInfo);
|
||||
end;
|
||||
@ -1187,6 +1386,43 @@ begin
|
||||
FVmtMethodParam := AVmtMethodParam;
|
||||
end;
|
||||
|
||||
{ TRttiMethodTypeParameter }
|
||||
|
||||
function TRttiMethodTypeParameter.GetHandle: Pointer;
|
||||
begin
|
||||
Result := fHandle;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetName: String;
|
||||
begin
|
||||
Result := fName;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetFlags: TParamFlags;
|
||||
begin
|
||||
Result := fFlags;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetParamType: TRttiType;
|
||||
var
|
||||
context: TRttiContext;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
Result := context.GetType(FType);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TRttiMethodTypeParameter.Create(aHandle: Pointer; const aName: String; aFlags: TParamFlags; aType: PTypeInfo);
|
||||
begin
|
||||
fHandle := aHandle;
|
||||
fName := aName;
|
||||
fFlags := aFlags;
|
||||
fType := aType;
|
||||
end;
|
||||
|
||||
{ TRttiIntfMethod }
|
||||
|
||||
function TRttiIntfMethod.GetHandle: Pointer;
|
||||
@ -1271,20 +1507,23 @@ begin
|
||||
FIndex := AIndex;
|
||||
end;
|
||||
|
||||
function TRttiIntfMethod.GetParameters: specialize TArray<TRttiParameter>;
|
||||
function TRttiIntfMethod.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
|
||||
var
|
||||
param: PVmtMethodParam;
|
||||
total, visible: SizeInt;
|
||||
context: TRttiContext;
|
||||
obj: TRttiObject;
|
||||
begin
|
||||
if Length(FParams) > 0 then
|
||||
if aWithHidden and (Length(FParamsAll) > 0) then
|
||||
Exit(FParamsAll);
|
||||
if not aWithHidden and (Length(FParams) > 0) then
|
||||
Exit(FParams);
|
||||
|
||||
if FIntfMethodEntry^.ParamCount = 0 then
|
||||
Exit(Nil);
|
||||
|
||||
SetLength(FParams, FIntfMethodEntry^.ParamCount);
|
||||
SetLength(FParamsAll, FIntfMethodEntry^.ParamCount);
|
||||
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
@ -1292,14 +1531,16 @@ begin
|
||||
visible := 0;
|
||||
param := FIntfMethodEntry^.Param[0];
|
||||
while total < FIntfMethodEntry^.ParamCount do begin
|
||||
obj := context.GetByHandle(param);
|
||||
if Assigned(obj) then
|
||||
FParamsAll[total] := obj as TRttiVmtMethodParameter
|
||||
else begin
|
||||
FParamsAll[total] := TRttiVmtMethodParameter.Create(param);
|
||||
context.AddObject(FParamsAll[total]);
|
||||
end;
|
||||
|
||||
if not (pfHidden in param^.Flags) then begin
|
||||
obj := context.GetByHandle(param);
|
||||
if Assigned(obj) then
|
||||
FParams[visible] := obj as TRttiVmtMethodParameter
|
||||
else begin
|
||||
FParams[visible] := TRttiVmtMethodParameter.Create(param);
|
||||
context.AddObject(FParams[visible]);
|
||||
end;
|
||||
FParams[visible] := FParamsAll[total];
|
||||
Inc(visible);
|
||||
end;
|
||||
|
||||
@ -1307,12 +1548,16 @@ begin
|
||||
Inc(total);
|
||||
end;
|
||||
|
||||
SetLength(FParams, visible);
|
||||
if visible <> total then
|
||||
SetLength(FParams, visible);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
|
||||
Result := FParams;
|
||||
if aWithHidden then
|
||||
Result := FParamsAll
|
||||
else
|
||||
Result := FParams;
|
||||
end;
|
||||
|
||||
{ TRttiFloatType }
|
||||
@ -1467,11 +1712,48 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue);
|
||||
var
|
||||
el: TValue;
|
||||
begin
|
||||
Result.FData.FTypeInfo := ATypeInfo;
|
||||
{ resets the whole variant part; FValueData is already Nil }
|
||||
{$if SizeOf(TMethod) > SizeOf(QWord)}
|
||||
Result.FData.FAsMethod.Code := Nil;
|
||||
Result.FData.FAsMethod.Data := Nil;
|
||||
{$else}
|
||||
Result.FData.FAsUInt64 := 0;
|
||||
{$endif}
|
||||
if not Assigned(ATypeInfo) then
|
||||
Exit;
|
||||
if ATypeInfo^.Kind <> tkArray then
|
||||
Exit;
|
||||
if not Assigned(AArray) then
|
||||
Exit;
|
||||
if ALength < 0 then
|
||||
Exit;
|
||||
Result.FData.FValueData := TValueDataIntImpl.CreateRef(@AArray, ATypeInfo, False);
|
||||
Result.FData.FArrLength := ALength;
|
||||
Make(Nil, Result.TypeData^.ArrayData.ElType, el);
|
||||
Result.FData.FElSize := el.DataSize;
|
||||
end;
|
||||
|
||||
{$ifndef NoGenericMethods}
|
||||
generic class function TValue.From<T>(constref aValue: T): TValue;
|
||||
begin
|
||||
TValue.Make(@aValue, System.TypeInfo(T), Result);
|
||||
end;
|
||||
|
||||
generic class function TValue.FromOpenArray<T>(constref aValue: array of T): TValue;
|
||||
var
|
||||
arrdata: Pointer;
|
||||
begin
|
||||
if Length(aValue) > 0 then
|
||||
arrdata := @aValue[0]
|
||||
else
|
||||
arrdata := Nil;
|
||||
TValue.MakeOpenArray(arrdata, Length(aValue), System.TypeInfo(aValue), Result);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function TValue.GetTypeDataProp: PTypeData;
|
||||
@ -1586,6 +1868,14 @@ begin
|
||||
result := kind in [tkArray, tkDynArray];
|
||||
end;
|
||||
|
||||
function TValue.IsOpenArray: Boolean;
|
||||
var
|
||||
td: PTypeData;
|
||||
begin
|
||||
td := TypeData;
|
||||
Result := (Kind = tkArray) and (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0)
|
||||
end;
|
||||
|
||||
function TValue.AsString: string;
|
||||
begin
|
||||
if System.GetTypeKind(String) = tkUString then
|
||||
@ -1785,9 +2075,13 @@ end;
|
||||
function TValue.ToString: String;
|
||||
begin
|
||||
case Kind of
|
||||
tkWString,
|
||||
tkUString : result := AsUnicodeString;
|
||||
tkSString,
|
||||
tkAString : result := AsString;
|
||||
tkAString : result := AsAnsiString;
|
||||
tkInteger : result := IntToStr(AsInteger);
|
||||
tkQWord : result := IntToStr(AsUInt64);
|
||||
tkInt64 : result := IntToStr(AsInt64);
|
||||
tkBool : result := BoolToStr(AsBoolean, True);
|
||||
else
|
||||
result := '';
|
||||
@ -1795,19 +2089,27 @@ begin
|
||||
end;
|
||||
|
||||
function TValue.GetArrayLength: SizeInt;
|
||||
var
|
||||
td: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
raise EInvalidCast.Create(SErrInvalidTypecast);
|
||||
if Kind = tkDynArray then
|
||||
Result := DynArraySize(PPointer(FData.FValueData.GetReferenceToRawData)^)
|
||||
else
|
||||
Result := TypeData^.ArrayData.ElCount;
|
||||
else begin
|
||||
td := TypeData;
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then
|
||||
Result := FData.FArrLength
|
||||
else
|
||||
Result := td^.ArrayData.ElCount;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TValue.GetArrayElement(AIndex: SizeInt): TValue;
|
||||
var
|
||||
data: Pointer;
|
||||
eltype: PTypeInfo;
|
||||
elsize: SizeInt;
|
||||
td: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
@ -1818,7 +2120,15 @@ begin
|
||||
end else begin
|
||||
td := TypeData;
|
||||
eltype := td^.ArrayData.ElType;
|
||||
data := PByte(FData.FValueData.GetReferenceToRawData) + AIndex * (td^.ArrayData.Size div td^.ArrayData.ElCount);
|
||||
{ open array? }
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin
|
||||
data := PPointer(FData.FValueData.GetReferenceToRawData)^;
|
||||
elsize := FData.FElSize
|
||||
end else begin
|
||||
data := FData.FValueData.GetReferenceToRawData;
|
||||
elsize := td^.ArrayData.Size div td^.ArrayData.ElCount;
|
||||
end;
|
||||
data := PByte(data) + AIndex * elsize;
|
||||
end;
|
||||
{ MakeWithoutCopy? }
|
||||
Make(data, eltype, Result);
|
||||
@ -1828,6 +2138,7 @@ procedure TValue.SetArrayElement(AIndex: SizeInt; constref AValue: TValue);
|
||||
var
|
||||
data: Pointer;
|
||||
eltype: PTypeInfo;
|
||||
elsize: SizeInt;
|
||||
td, tdv: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
@ -1838,7 +2149,15 @@ begin
|
||||
end else begin
|
||||
td := TypeData;
|
||||
eltype := td^.ArrayData.ElType;
|
||||
data := PByte(FData.FValueData.GetReferenceToRawData) + AIndex * (td^.ArrayData.Size div td^.ArrayData.ElCount);
|
||||
{ open array? }
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin
|
||||
data := PPointer(FData.FValueData.GetReferenceToRawData)^;
|
||||
elsize := FData.FElSize
|
||||
end else begin
|
||||
data := FData.FValueData.GetReferenceToRawData;
|
||||
elsize := td^.ArrayData.Size div td^.ArrayData.ElCount;
|
||||
end;
|
||||
data := PByte(data) + AIndex * elsize;
|
||||
end;
|
||||
{ maybe we'll later on allow some typecasts, but for now be restrictive }
|
||||
if eltype^.Kind <> AValue.Kind then
|
||||
@ -2126,6 +2445,276 @@ begin
|
||||
Result := FString;
|
||||
end;
|
||||
|
||||
function TRttiMethod.GetParameters: specialize TArray<TRttiParameter>;
|
||||
begin
|
||||
Result := GetParameters(False);
|
||||
end;
|
||||
|
||||
function TRttiMethod.Invoke(aInstance: TObject; const aArgs: array of TValue): TValue;
|
||||
var
|
||||
instance: TValue;
|
||||
begin
|
||||
TValue.Make(@aInstance, TypeInfo(TObject), instance);
|
||||
Result := Invoke(instance, aArgs);
|
||||
end;
|
||||
|
||||
function TRttiMethod.Invoke(aInstance: TClass; const aArgs: array of TValue): TValue;
|
||||
var
|
||||
instance: TValue;
|
||||
begin
|
||||
TValue.Make(@aInstance, TypeInfo(TClass), instance);
|
||||
Result := Invoke(instance, aArgs);
|
||||
end;
|
||||
|
||||
function TRttiMethod.Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
|
||||
var
|
||||
addr: CodePointer;
|
||||
vmt: PCodePointer;
|
||||
begin
|
||||
if not HasExtendedInfo then
|
||||
raise EInvocationError.Create(SErrInvokeInsufficientRtti);
|
||||
|
||||
if IsStatic and not aInstance.IsEmpty then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeStaticNoSelf, [Name]);
|
||||
|
||||
if not IsStatic and aInstance.IsEmpty then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeNotStaticNeedsSelf, [Name]);
|
||||
|
||||
if not IsStatic and IsClassMethod and not aInstance.IsClass then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeClassMethodClassSelf, [Name]);
|
||||
|
||||
addr := Nil;
|
||||
if IsStatic then
|
||||
addr := CodeAddress
|
||||
else begin
|
||||
vmt := Nil;
|
||||
if aInstance.Kind in [tkInterface, tkInterfaceRaw] then
|
||||
vmt := PCodePointer(PPPointer(aInstance.GetReferenceToRawData)^^);
|
||||
{ ToDo }
|
||||
if Assigned(vmt) then
|
||||
addr := vmt[VirtualIndex];
|
||||
end;
|
||||
|
||||
Result := Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), ReturnType);
|
||||
end;
|
||||
|
||||
{ TRttiInvokableType }
|
||||
|
||||
function TRttiInvokableType.GetParameters: specialize TArray<TRttiParameter>;
|
||||
begin
|
||||
Result := GetParameters(False);
|
||||
end;
|
||||
|
||||
{ TRttiMethodType }
|
||||
|
||||
function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
|
||||
type
|
||||
TParamInfo = record
|
||||
Handle: Pointer;
|
||||
Flags: TParamFlags;
|
||||
Name: String;
|
||||
end;
|
||||
|
||||
PParamFlags = ^TParamFlags;
|
||||
PCallConv = ^TCallConv;
|
||||
PPPTypeInfo = ^PPTypeInfo;
|
||||
|
||||
var
|
||||
infos: array of TParamInfo;
|
||||
total, visible, i: SizeInt;
|
||||
ptr: PByte;
|
||||
paramtypes: PPPTypeInfo;
|
||||
context: TRttiContext;
|
||||
obj: TRttiObject;
|
||||
begin
|
||||
if aWithHidden and (Length(FParamsAll) > 0) then
|
||||
Exit(FParamsAll);
|
||||
if not aWithHidden and (Length(FParams) > 0) then
|
||||
Exit(FParams);
|
||||
|
||||
ptr := @FTypeData^.ParamList[0];
|
||||
visible := 0;
|
||||
total := 0;
|
||||
|
||||
if FTypeData^.ParamCount > 0 then begin
|
||||
SetLength(infos, FTypeData^.ParamCount);
|
||||
|
||||
while total < FTypeData^.ParamCount do begin
|
||||
infos[total].Handle := ptr;
|
||||
infos[total].Flags := PParamFlags(ptr)^;
|
||||
Inc(ptr, SizeOf(TParamFlags));
|
||||
{ handle name }
|
||||
infos[total].Name := PShortString(ptr)^;
|
||||
Inc(ptr, ptr^ + SizeOf(Byte));
|
||||
{ skip type name }
|
||||
Inc(ptr, ptr^ + SizeOf(Byte));
|
||||
{ align? }
|
||||
if not (pfHidden in infos[total].Flags) then
|
||||
Inc(visible);
|
||||
Inc(total);
|
||||
end;
|
||||
end;
|
||||
|
||||
if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
|
||||
{ skip return type name }
|
||||
ptr := AlignTypeData(PByte(ptr) + ptr^ + SizeOf(Byte));
|
||||
{ handle return type }
|
||||
FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
|
||||
Inc(ptr, SizeOf(PPTypeInfo));
|
||||
end;
|
||||
|
||||
{ handle calling convention }
|
||||
FCallConv := PCallConv(ptr)^;
|
||||
Inc(ptr, SizeOf(TCallConv));
|
||||
|
||||
SetLength(FParamsAll, FTypeData^.ParamCount);
|
||||
SetLength(FParams, visible);
|
||||
|
||||
if FTypeData^.ParamCount > 0 then begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
paramtypes := PPPTypeInfo(ptr);
|
||||
visible := 0;
|
||||
for i := 0 to FTypeData^.ParamCount - 1 do begin
|
||||
obj := context.GetByHandle(infos[i].Handle);
|
||||
if Assigned(obj) then
|
||||
FParamsAll[i] := obj as TRttiMethodTypeParameter
|
||||
else begin
|
||||
FParamsAll[i] := TRttiMethodTypeParameter.Create(infos[i].Handle, infos[i].Name, infos[i].Flags, paramtypes[i]^);
|
||||
context.AddObject(FParamsAll[i]);
|
||||
end;
|
||||
|
||||
if not (pfHidden in infos[i].Flags) then begin
|
||||
FParams[visible] := FParamsAll[i];
|
||||
Inc(visible);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
if aWithHidden then
|
||||
Result := FParamsAll
|
||||
else
|
||||
Result := FParams;
|
||||
end;
|
||||
|
||||
function TRttiMethodType.GetCallingConvention: TCallConv;
|
||||
begin
|
||||
{ the calling convention is located after the parameters, so get the parameters
|
||||
which will also initialize the calling convention }
|
||||
GetParameters(True);
|
||||
Result := FCallConv;
|
||||
end;
|
||||
|
||||
function TRttiMethodType.GetReturnType: TRttiType;
|
||||
begin
|
||||
if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
|
||||
{ the return type is located after the parameters, so get the parameters
|
||||
which will also initialize the return type }
|
||||
GetParameters(True);
|
||||
Result := FReturnType;
|
||||
end else
|
||||
Result := Nil;
|
||||
end;
|
||||
|
||||
function TRttiMethodType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
|
||||
var
|
||||
method: PMethod;
|
||||
inst: TValue;
|
||||
begin
|
||||
if aCallable.Kind <> tkMethod then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeCallableNotMethod, [Name]);
|
||||
|
||||
method := PMethod(aCallable.GetReferenceToRawData);
|
||||
|
||||
{ by using a pointer we can also use this for non-class instance methods }
|
||||
TValue.Make(@method^.Data, PTypeInfo(TypeInfo(Pointer)), inst);
|
||||
|
||||
Result := Rtti.Invoke(Name, method^.Code, CallingConvention, False, inst, aArgs, GetParameters(True), ReturnType);
|
||||
end;
|
||||
|
||||
{ TRttiProcedureType }
|
||||
|
||||
function TRttiProcedureType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
|
||||
var
|
||||
visible, i: SizeInt;
|
||||
param: PProcedureParam;
|
||||
obj: TRttiObject;
|
||||
context: TRttiContext;
|
||||
begin
|
||||
if aWithHidden and (Length(FParamsAll) > 0) then
|
||||
Exit(FParamsAll);
|
||||
if not aWithHidden and (Length(FParams) > 0) then
|
||||
Exit(FParams);
|
||||
|
||||
if FTypeData^.ProcSig.ParamCount = 0 then
|
||||
Exit(Nil);
|
||||
|
||||
SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
|
||||
SetLength(FParams, FTypeData^.ProcSig.ParamCount);
|
||||
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
param := AlignTypeData(PProcedureParam(@FTypeData^.ProcSig.ParamCount + SizeOf(FTypeData^.ProcSig.ParamCount)));
|
||||
visible := 0;
|
||||
for i := 0 to FTypeData^.ProcSig.ParamCount - 1 do begin
|
||||
obj := context.GetByHandle(param);
|
||||
if Assigned(obj) then
|
||||
FParamsAll[i] := obj as TRttiMethodTypeParameter
|
||||
else begin
|
||||
FParamsAll[i] := TRttiMethodTypeParameter.Create(param, param^.Name, param^.ParamFlags, param^.ParamType);
|
||||
context.AddObject(FParamsAll[i]);
|
||||
end;
|
||||
|
||||
if not (pfHidden in param^.ParamFlags) then begin
|
||||
FParams[visible] := FParamsAll[i];
|
||||
Inc(visible);
|
||||
end;
|
||||
|
||||
param := PProcedureParam(AlignTypeData(PByte(@param^.Name) + Length(param^.Name) + SizeOf(param^.Name[0])));
|
||||
end;
|
||||
|
||||
SetLength(FParams, visible);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
|
||||
if aWithHidden then
|
||||
Result := FParamsAll
|
||||
else
|
||||
Result := FParams;
|
||||
end;
|
||||
|
||||
function TRttiProcedureType.GetCallingConvention: TCallConv;
|
||||
begin
|
||||
Result := FTypeData^.ProcSig.CC;
|
||||
end;
|
||||
|
||||
function TRttiProcedureType.GetReturnType: TRttiType;
|
||||
var
|
||||
context: TRttiContext;
|
||||
begin
|
||||
if not Assigned(FTypeData^.ProcSig.ResultTypeRef) then
|
||||
Exit(Nil);
|
||||
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
Result := context.GetType(FTypeData^.ProcSig.ResultTypeRef^);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TRttiProcedureType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
|
||||
begin
|
||||
if aCallable.Kind <> tkProcVar then
|
||||
raise EInvocationError.CreateFmt(SErrInvokeCallableNotProc, [Name]);
|
||||
|
||||
Result := Rtti.Invoke(Name, PCodePointer(aCallable.GetReferenceToRawData)^, CallingConvention, True, TValue.Empty, aArgs, GetParameters(True), ReturnType);
|
||||
end;
|
||||
|
||||
{ TRttiStringType }
|
||||
|
||||
function TRttiStringType.GetStringKind: TRttiStringKind;
|
||||
@ -2683,8 +3272,17 @@ begin
|
||||
result := (FContextToken as IPooltoken).RttiPool.GetTypes;
|
||||
end;}
|
||||
|
||||
{$ifndef InLazIDE}
|
||||
{$if defined(CPUX86_64) and defined(WIN64)}
|
||||
{$I invoke.inc}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
initialization
|
||||
PoolRefCount := 0;
|
||||
InitDefaultFunctionCallManager;
|
||||
{$ifdef SYSTEM_HAS_INVOKE}
|
||||
InitSystemFunctionCallManager;
|
||||
{$endif}
|
||||
end.
|
||||
|
||||
|
||||
268
packages/rtl-objpas/src/x86_64/invoke.inc
Normal file
268
packages/rtl-objpas/src/x86_64/invoke.inc
Normal file
@ -0,0 +1,268 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (C) 2018 Sven Barth
|
||||
member of the Free Pascal development team.
|
||||
|
||||
Function call manager for x86_64
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
}
|
||||
|
||||
resourcestring
|
||||
SErrPlatformNotSupported = 'Invoke is not supported on this platform';
|
||||
|
||||
{$define SYSTEM_HAS_INVOKE}
|
||||
|
||||
{$ifdef windows}
|
||||
function InvokeKernelWin64(aArgsStackSize: PtrUInt; aArgsStack, aArgsReg: Pointer; aFunc: CodePointer): PtrUInt; assembler; nostackframe;
|
||||
asm
|
||||
{ save non-volatile registers in shadow space }
|
||||
movq %rbp, 8(%rsp)
|
||||
.seh_savereg %rbp, 8
|
||||
movq %rsi, 16(%rsp)
|
||||
.seh_savereg %rsi, 16
|
||||
movq %rdi, 24(%rsp)
|
||||
.seh_savereg %rdi, 24
|
||||
|
||||
movq %rsp, %rbp
|
||||
.seh_setframe %rbp, 0
|
||||
.seh_endprologue
|
||||
|
||||
{ align stack size to 16 Byte }
|
||||
add $15, aArgsStackSize
|
||||
and $-16, aArgsStackSize
|
||||
sub aArgsStackSize, %rsp
|
||||
|
||||
movq aArgsStackSize, %rax
|
||||
|
||||
{ copy the stack arguments as QWord entries }
|
||||
shr $3, %rcx
|
||||
|
||||
mov %rdx, %rsi
|
||||
mov %rsp, %rdi
|
||||
mov %r9, %rax
|
||||
|
||||
cld
|
||||
rep movsq
|
||||
|
||||
{ setup general purpose registers }
|
||||
movq 0(%r8), %rcx
|
||||
movq 8(%r8), %rdx
|
||||
movq 24(%r8), %r9
|
||||
movq 16(%r8), %r8
|
||||
|
||||
{ also setup SSE2 registers }
|
||||
movq %rcx, %xmm0
|
||||
movq %rdx, %xmm1
|
||||
movq %r8 , %xmm2
|
||||
movq %r9 , %xmm3
|
||||
|
||||
{ provide shadow space }
|
||||
sub $32, %rsp
|
||||
|
||||
{ now call the function }
|
||||
call *%rax
|
||||
|
||||
{ restore non-volatile registers }
|
||||
movq %rbp, %rsp
|
||||
|
||||
movq 24(%rsp), %rdi
|
||||
movq 16(%rsp), %rsi
|
||||
movq 8(%rsp), %rbp
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
resourcestring
|
||||
SErrFailedToConvertArg = 'Failed to convert argument %d of type %s';
|
||||
SErrFailedToConvertRes = 'Failed to convert result of type %s';
|
||||
|
||||
procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
|
||||
aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
|
||||
type
|
||||
PBoolean16 = ^Boolean16;
|
||||
PBoolean32 = ^Boolean32;
|
||||
PBoolean64 = ^Boolean64;
|
||||
PByteBool = ^ByteBool;
|
||||
PQWordBool = ^QWordBool;
|
||||
var
|
||||
stackarea: array of PtrUInt;
|
||||
stackptr: Pointer;
|
||||
regs: array[0..3] of PtrUInt;
|
||||
i, regidx, stackidx: LongInt;
|
||||
val: PtrUInt;
|
||||
td: PTypeData;
|
||||
retinparam: Boolean;
|
||||
argcount, resreg: SizeInt;
|
||||
begin
|
||||
if Assigned(aResultType) and not Assigned(aResultValue) then
|
||||
raise EInvocationError.Create(SErrInvokeResultTypeNoValue);
|
||||
{$ifdef windows}
|
||||
retinparam := False;
|
||||
if Assigned(aResultType) then begin
|
||||
case aResultType^.Kind of
|
||||
tkSString,
|
||||
tkAString,
|
||||
tkUString,
|
||||
tkWString,
|
||||
tkInterface,
|
||||
tkDynArray:
|
||||
retinparam := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
stackidx := 0;
|
||||
regidx := 0;
|
||||
argcount := Length(aArgs);
|
||||
if retinparam then begin
|
||||
if fcfStatic in aFlags then
|
||||
resreg := 0
|
||||
else
|
||||
resreg := 1;
|
||||
regs[resreg] := PtrUInt(aResultValue);
|
||||
Inc(argcount);
|
||||
end else
|
||||
resreg := -1;
|
||||
if argcount > 4 then
|
||||
SetLength(stackarea, argcount - 4);
|
||||
for i := 0 to High(aArgs) do begin
|
||||
if pfArray in aArgs[i].Info.ParamFlags then
|
||||
val := PtrUInt(aArgs[i].ValueRef)
|
||||
else if aArgs[i].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
|
||||
val := PtrUInt(aArgs[i].ValueRef)
|
||||
else begin
|
||||
td := GetTypeData(aArgs[i].Info.ParamType);
|
||||
case aArgs[i].Info.ParamType^.Kind of
|
||||
tkSString,
|
||||
tkMethod:
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
tkArray:
|
||||
if td^.ArrayData.Size in [1, 2, 4, 8] then
|
||||
val := PPtrUInt(aArgs[i].ValueRef)^
|
||||
else
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
tkRecord:
|
||||
if td^.RecSize in [1, 2, 4, 8] then
|
||||
val := PPtrUInt(aArgs[i].ValueRef)^
|
||||
else
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
{ ToDo: handle object like record? }
|
||||
tkObject,
|
||||
tkWString,
|
||||
tkUString,
|
||||
tkAString,
|
||||
tkDynArray,
|
||||
tkClass,
|
||||
tkClassRef,
|
||||
tkInterface,
|
||||
tkInterfaceRaw,
|
||||
tkProcVar,
|
||||
tkPointer:
|
||||
val := PPtrUInt(aArgs[i].ValueRef)^;
|
||||
tkInt64,
|
||||
tkQWord:
|
||||
val := PInt64(aArgs[i].ValueRef)^;
|
||||
tkSet: begin
|
||||
case td^.OrdType of
|
||||
otUByte: begin
|
||||
case td^.SetSize of
|
||||
0, 1:
|
||||
val := PByte(aArgs[i].ValueRef)^;
|
||||
2:
|
||||
val := PWord(aArgs[i].ValueRef)^;
|
||||
3:
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
4:
|
||||
val := PLongWord(aArgs[i].ValueRef)^;
|
||||
5..7:
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
8:
|
||||
val := Int64(PQWord(aArgs[i].ValueRef)^);
|
||||
else
|
||||
val := PtrUInt(aArgs[i].ValueRef);
|
||||
end;
|
||||
end;
|
||||
otUWord:
|
||||
val := PWord(aArgs[i].ValueRef)^;
|
||||
otULong:
|
||||
val := PLongWord(aArgs[i].ValueRef)^;
|
||||
end;
|
||||
end;
|
||||
tkEnumeration,
|
||||
tkInteger: begin
|
||||
case td^.OrdType of
|
||||
otSByte: val := PShortInt(aArgs[i].ValueRef)^;
|
||||
otUByte: val := PByte(aArgs[i].ValueRef)^;
|
||||
otSWord: val := PSmallInt(aArgs[i].ValueRef)^;
|
||||
otUWord: val := PWord(aArgs[i].ValueRef)^;
|
||||
otSLong: val := PLongInt(aArgs[i].ValueRef)^;
|
||||
otULong: val := PLongWord(aArgs[i].ValueRef)^;
|
||||
end;
|
||||
end;
|
||||
tkBool: begin
|
||||
case td^.OrdType of
|
||||
otUByte: val := ShortInt(PBoolean(aArgs[i].ValueRef)^);
|
||||
otUWord: val := Byte(PBoolean16(aArgs[i].ValueRef)^);
|
||||
otULong: val := SmallInt(PBoolean32(aArgs[i].ValueRef)^);
|
||||
otUQWord: val := QWord(PBoolean64(aArgs[i].ValueRef)^);
|
||||
otSByte: val := Word(PByteBool(aArgs[i].ValueRef)^);
|
||||
otSWord: val := LongInt(PWordBool(aArgs[i].ValueRef)^);
|
||||
otSLong: val := LongWord(PLongBool(aArgs[i].ValueRef)^);
|
||||
otSQWord: val := Int64(PQWordBool(aArgs[i].ValueRef)^);
|
||||
end;
|
||||
end;
|
||||
tkFloat: begin
|
||||
case td^.FloatType of
|
||||
ftCurr : val := PInt64(PCurrency(aArgs[i].ValueRef))^;
|
||||
ftSingle : val := PInt64(PSingle(aArgs[i].ValueRef))^;
|
||||
ftDouble : val := PInt64(PDouble(aArgs[i].ValueRef))^;
|
||||
ftExtended: val := PInt64(PExtended(aArgs[i].ValueRef))^;
|
||||
ftComp : val := PInt64(PComp(aArgs[i].ValueRef))^;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, aArgs[i].Info.ParamType^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
if regidx = resreg then
|
||||
Inc(regidx);
|
||||
|
||||
if regidx < 4 then begin
|
||||
regs[regidx] := val;
|
||||
Inc(regidx);
|
||||
end else begin
|
||||
stackarea[stackidx] := val;
|
||||
Inc(stackidx);
|
||||
end;
|
||||
end;
|
||||
|
||||
if stackidx > 0 then
|
||||
stackptr := @stackarea[0]
|
||||
else
|
||||
stackptr := Nil;
|
||||
val := InvokeKernelWin64(stackidx * SizeOf(PtrUInt), stackptr, @regs[0], aCodeAddress);
|
||||
|
||||
if Assigned(aResultType) and not retinparam then begin
|
||||
PPtrUInt(aResultValue)^ := val;
|
||||
end;
|
||||
{$else}
|
||||
raise EInvocationError.Create(SErrPlatformNotSupported);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
const
|
||||
SystemFunctionCallManager: TFunctionCallManager = (
|
||||
Invoke: @SystemInvoke;
|
||||
CreateCallbackProc: Nil;
|
||||
CreateCallbackMethod: Nil;
|
||||
);
|
||||
|
||||
procedure InitSystemFunctionCallManager;
|
||||
begin
|
||||
SetFunctionCallManager([ccReg, ccCdecl, ccPascal, ccStdCall], SystemFunctionCallManager);
|
||||
end;
|
||||
@ -5,9 +5,19 @@ program testrunner.rtlobjpas;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
{ Invoke needs a function call manager }
|
||||
{.$define testinvoke}
|
||||
{.$define useffi}
|
||||
{$if defined(CPUX64) and defined(WINDOWS)}
|
||||
{$define testinvoke}
|
||||
{$else}
|
||||
{$ifdef useffi}
|
||||
{$define testinvoke}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
uses
|
||||
{$ifdef useffi}
|
||||
ffi.manager,
|
||||
{$endif}
|
||||
consoletestrunner,
|
||||
{$ifdef testinvoke}
|
||||
tests.rtti.invoke,
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -52,6 +52,9 @@ type
|
||||
procedure TestMakeObject;
|
||||
procedure TestMakeArrayDynamic;
|
||||
procedure TestMakeArrayStatic;
|
||||
{$ifdef fpc}
|
||||
procedure TestMakeArrayOpen;
|
||||
{$endif}
|
||||
|
||||
procedure TestDataSize;
|
||||
procedure TestDataSizeEmpty;
|
||||
@ -59,11 +62,17 @@ type
|
||||
procedure TestReferenceRawDataEmpty;
|
||||
|
||||
procedure TestIsManaged;
|
||||
{$ifdef fpc}
|
||||
procedure TestOpenArrayToDyn;
|
||||
{$endif}
|
||||
|
||||
procedure TestInterface;
|
||||
{$ifdef fpc}
|
||||
procedure TestInterfaceRaw;
|
||||
{$endif}
|
||||
|
||||
procedure TestProcVar;
|
||||
procedure TestMethod;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -149,7 +158,11 @@ type
|
||||
TTestSet = set of TTestEnum;
|
||||
|
||||
TTestProc = procedure;
|
||||
TTestFunc1 = function: LongInt;
|
||||
TTestFunc2 = function(aArg1: LongInt; aArg2: array of LongInt): String;
|
||||
TTestMethod = procedure of object;
|
||||
TTestMethod1 = function: LongInt of object;
|
||||
TTestMethod2 = function(aArg1: LongInt; aArg2: array of LongInt): String of object;
|
||||
TTestHelper = class helper for TObject
|
||||
end;
|
||||
|
||||
@ -393,6 +406,84 @@ begin
|
||||
CheckEquals(value.GetArrayElement(3).AsInteger, 63);
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
procedure TTestCase1.TestMakeArrayOpen;
|
||||
|
||||
procedure TestOpenArrayValueCopy(aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
end;
|
||||
|
||||
procedure TestOpenArrayValueVar(var aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
end;
|
||||
|
||||
procedure TestOpenArrayValueOut(var aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
value.SetArrayElement(1, 128);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
CheckEquals(aArr[1], 128);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 84);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 128);
|
||||
end;
|
||||
|
||||
var
|
||||
arr: array of LongInt;
|
||||
begin
|
||||
TestOpenArrayValueCopy([42, 21]);
|
||||
|
||||
arr := [42, 21];
|
||||
TestOpenArrayValueVar(arr);
|
||||
CheckEquals(arr[0], 84);
|
||||
CheckEquals(arr[1], 21);
|
||||
|
||||
arr := [42, 21];
|
||||
TestOpenArrayValueOut(arr);
|
||||
CheckEquals(arr[0], 84);
|
||||
CheckEquals(arr[1], 128);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure TTestCase1.TestGetIsReadable;
|
||||
var
|
||||
c: TRttiContext;
|
||||
@ -1285,6 +1376,34 @@ begin
|
||||
CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
procedure TTestCase1.TestOpenArrayToDyn;
|
||||
|
||||
procedure OpenArrayProc(aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
{$ifndef InLazIDE}
|
||||
value := specialize OpenArrayToDynArrayValue<LongInt>(aArr);
|
||||
{$endif}
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, False);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 84);
|
||||
value.SetArrayElement(0, 21);
|
||||
{ since this is a copy the original array is not modified! }
|
||||
CheckEquals(aArr[0], 42);
|
||||
end;
|
||||
|
||||
begin
|
||||
OpenArrayProc([42, 84]);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure TTestCase1.TestInterface;
|
||||
var
|
||||
context: TRttiContext;
|
||||
@ -1436,6 +1555,111 @@ begin
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestProcVar;
|
||||
var
|
||||
context: TRttiContext;
|
||||
t: TRttiType;
|
||||
p: TRttiProcedureType;
|
||||
params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestProc)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(not Assigned(p.ReturnType), 'Return type is assigned');
|
||||
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(p.ReturnType), 'Return type is not assigned');
|
||||
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
|
||||
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(p.ReturnType), 'Return type is not assigned');
|
||||
Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
|
||||
|
||||
params := p.GetParameters;
|
||||
CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters');
|
||||
|
||||
Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
|
||||
//Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
|
||||
Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
|
||||
Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestMethod;
|
||||
var
|
||||
context: TRttiContext;
|
||||
t: TRttiType;
|
||||
m: TRttiMethodType;
|
||||
params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(not Assigned(m.ReturnType), 'Return type is assigned');
|
||||
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(m.ReturnType), 'Return type is not assigned');
|
||||
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
|
||||
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(m.ReturnType), 'Return type is not assigned');
|
||||
Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');
|
||||
|
||||
params := m.GetParameters;
|
||||
CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters');
|
||||
|
||||
Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
|
||||
//Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
|
||||
Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
|
||||
Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif}
|
||||
|
||||
initialization
|
||||
|
||||
Loading…
Reference in New Issue
Block a user