From 3661b7bcfaa39e34648ef9c11de987d07343c3a6 Mon Sep 17 00:00:00 2001 From: marco Date: Mon, 12 Nov 2018 09:33:47 +0000 Subject: [PATCH] --- 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 - --- .gitattributes | 1 + packages/libffi/src/ffi.manager.pp | 235 ++-- packages/rtl-objpas/fpmake.pp | 5 + packages/rtl-objpas/src/inc/rtti.pp | 636 ++++++++- packages/rtl-objpas/src/x86_64/invoke.inc | 268 ++++ .../rtl-objpas/tests/testrunner.rtlobjpas.pp | 12 +- .../rtl-objpas/tests/tests.rtti.invoke.pas | 1227 +++++++++++++++++ packages/rtl-objpas/tests/tests.rtti.pas | 224 +++ 8 files changed, 2481 insertions(+), 127 deletions(-) create mode 100644 packages/rtl-objpas/src/x86_64/invoke.inc diff --git a/.gitattributes b/.gitattributes index 8647805498..9bd6d167e4 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/libffi/src/ffi.manager.pp b/packages/libffi/src/ffi.manager.pp index 8d1554f695..a86bea3b7a 100644 --- a/packages/libffi/src/ffi.manager.pp +++ b/packages/libffi/src/ffi.manager.pp @@ -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 diff --git a/packages/rtl-objpas/fpmake.pp b/packages/rtl-objpas/fpmake.pp index fe8c536336..fb9662bd50 100644 --- a/packages/rtl-objpas/fpmake.pp +++ b/packages/rtl-objpas/fpmake.pp @@ -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; diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index 20a8f79262..109acfd021 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -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(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(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; virtual; abstract; + function GetCallingConvention: TCallConv; virtual; abstract; + function GetReturnType: TRttiType; virtual; abstract; + public + function GetParameters: specialize TArray; 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; + protected + function GetParameters(aWithHidden: Boolean): specialize TArray; 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; + protected + function GetParameters(aWithHidden: Boolean): specialize TArray; 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; 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; virtual; abstract; + function GetParameters: specialize TArray; 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(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; + FParams, FParamsAll: specialize TArray; 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; override; public constructor Create(AParent: TRttiType; AIntfMethodEntry: PIntfMethodEntry; AIndex: SmallInt); - function GetParameters: specialize TArray; 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; 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(constref aArray: array of T): TValue; +var + arr: specialize TArray; + i: SizeInt; +begin + SetLength(arr, Length(aArray)); + for i := 0 to High(aArray) do + arr[i] := aArray[i]; + Result := TValue.specialize From>(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; +function TRttiIntfMethod.GetParameters(aWithHidden: Boolean): specialize TArray; 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(constref aValue: T): TValue; begin TValue.Make(@aValue, System.TypeInfo(T), Result); end; + +generic class function TValue.FromOpenArray(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; +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; +begin + Result := GetParameters(False); +end; + +{ TRttiMethodType } + +function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray; +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; +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. diff --git a/packages/rtl-objpas/src/x86_64/invoke.inc b/packages/rtl-objpas/src/x86_64/invoke.inc new file mode 100644 index 0000000000..c0bf62ed82 --- /dev/null +++ b/packages/rtl-objpas/src/x86_64/invoke.inc @@ -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; diff --git a/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp b/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp index 20d96f20e0..c807f8be99 100644 --- a/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp +++ b/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp @@ -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, diff --git a/packages/rtl-objpas/tests/tests.rtti.invoke.pas b/packages/rtl-objpas/tests/tests.rtti.invoke.pas index 497f447035..ebb973c495 100644 --- a/packages/rtl-objpas/tests/tests.rtti.invoke.pas +++ b/packages/rtl-objpas/tests/tests.rtti.invoke.pas @@ -17,6 +17,10 @@ uses sysutils, typinfo, Rtti; type +{$ifndef fpc} + CodePointer = Pointer; +{$endif} + TTestInvoke = class(TTestCase) private type TInvokeFlag = ( @@ -25,10 +29,20 @@ type ); TInvokeFlags = set of TInvokeFlag; private + function EqualValues(aValue1, aValue2: TValue): Boolean; + function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue; procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64); procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString); procedure DoStaticInvokeTestUnicodeStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString); + procedure DoIntfInvoke(aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); + procedure DoMethodInvoke(aInst: TObject; aMethod: TMethod; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); + procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); +{$ifndef InLazIDE} + {$ifdef fpc}generic{$endif} procedure GenDoMethodInvoke(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); + {$ifdef fpc}generic{$endif} procedure GenDoProcvarInvoke(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); + {$ifdef fpc}generic{$endif} function GetRecValue(aReverse: Boolean): TValue; +{$endif} {$ifdef fpc} procedure Status(const aMsg: String); {$endif} @@ -42,6 +56,15 @@ type procedure TestInt64; procedure TestTObject; + + procedure TestIntfMethods; + procedure TestIntfMethodsRecs; + + procedure TestMethodVars; + procedure TestMethodVarsRecs; + + procedure TestProcVars; + procedure TestProcVarsRecs; end; {$ifndef fpc} @@ -65,6 +88,96 @@ begin end; {$endif} +function TTestInvoke.EqualValues(aValue1, aValue2: TValue): Boolean; +var + td1, td2: PTypeData; + i: SizeInt; +begin +{$ifdef debug} + Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty); + Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind); + Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray); +{$endif} + if aValue1.IsEmpty and aValue2.IsEmpty then + Result := True + else if aValue1.IsEmpty and not aValue2.IsEmpty then + Result := False + else if not aValue1.IsEmpty and aValue2.IsEmpty then + Result := False + else if aValue1.IsArray and aValue2.IsArray then begin + if aValue1.GetArrayLength = aValue2.GetArrayLength then begin + Result := True; + for i := 0 to aValue1.GetArrayLength - 1 do + if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin + Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4)); + Result := False; + Break; + end; + end else + Result := False; + end else if aValue1.Kind = aValue2.Kind then begin + td1 := aValue1.TypeData; + td2 := aValue2.TypeData; + case aValue1.Kind of + tkBool: + Result := aValue1.AsBoolean xor not aValue2.AsBoolean; + tkSet: + if td1^.SetSize = td2^.SetSize then + if td1^.SetSize < SizeOf(SizeInt) then + Result := aValue1.AsOrdinal = aValue2.AsOrdinal + else + Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize) + else + Result := False; + tkEnumeration, + tkChar, + tkWChar, + tkUChar, + tkInt64, + tkInteger: + Result := aValue1.AsOrdinal = aValue2.AsOrdinal; + tkQWord: + Result := aValue1.AsUInt64 = aValue2.AsUInt64; + tkSString, + tkUString, + tkAString, + tkWString: + Result := aValue1.AsString = aValue2.AsString; + tkDynArray, + tkArray: + if aValue1.GetArrayLength = aValue2.GetArrayLength then begin + Result := True; + for i := 0 to aValue1.GetArrayLength - 1 do + if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin + Result := False; + Break; + end; + end else + Result := False; + tkClass, + tkClassRef, + tkInterface, + tkInterfaceRaw, + tkPointer: + Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^; + tkProcVar: + Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^; + tkRecord, + tkObject, + tkMethod, + tkVariant: begin + if aValue1.DataSize = aValue2.DataSize then + Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize) + else + Result := False; + end + else + Result := False; + end; + end else + Result := False; +end; + function TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue; begin @@ -521,6 +634,1120 @@ begin DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls); end; +type + TTestRecord1 = packed record + b: array[0..0] of Byte; + end; + + TTestRecord2 = packed record + b: array[0..1] of Byte; + end; + + TTestRecord3 = packed record + b: array[0..2] of Byte; + end; + + TTestRecord4 = packed record + b: array[0..3] of Byte; + end; + + TTestRecord5 = packed record + b: array[0..4] of Byte; + end; + + TTestRecord6 = packed record + b: array[0..5] of Byte; + end; + + TTestRecord7 = packed record + b: array[0..6] of Byte; + end; + + TTestRecord8 = packed record + b: array[0..7] of Byte; + end; + + TTestRecord9 = packed record + b: array[0..8] of Byte; + end; + + TTestRecord10 = packed record + b: array[0..9] of Byte; + end; + + {$M+} + ITestInterface = interface + procedure Test1; + function Test2: SizeInt; + function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt; + procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString); + function Test5: AnsiString; + function Test6: UnicodeString; + function Test7: WideString; + function Test8: ShortString; + procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt); + procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString); + procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString); + procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt); + + function TestRecSize1(aArg1: TTestRecord1): TTestRecord1; + function TestRecSize2(aArg1: TTestRecord2): TTestRecord2; + function TestRecSize3(aArg1: TTestRecord3): TTestRecord3; + function TestRecSize4(aArg1: TTestRecord4): TTestRecord4; + function TestRecSize5(aArg1: TTestRecord5): TTestRecord5; + function TestRecSize6(aArg1: TTestRecord6): TTestRecord6; + function TestRecSize7(aArg1: TTestRecord7): TTestRecord7; + function TestRecSize8(aArg1: TTestRecord8): TTestRecord8; + function TestRecSize9(aArg1: TTestRecord9): TTestRecord9; + function TestRecSize10(aArg1: TTestRecord10): TTestRecord10; + end; + {$M-} + + TTestInterfaceClass = class(TInterfacedObject, ITestInterface) + private + procedure Test1; + function Test2: SizeInt; + function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt; + procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString); + function Test5: AnsiString; + function Test6: UnicodeString; + function Test7: WideString; + function Test8: ShortString; + procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt); + procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString); + procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString); + procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt); + + function TestRecSize1(aArg1: TTestRecord1): TTestRecord1; + function TestRecSize2(aArg1: TTestRecord2): TTestRecord2; + function TestRecSize3(aArg1: TTestRecord3): TTestRecord3; + function TestRecSize4(aArg1: TTestRecord4): TTestRecord4; + function TestRecSize5(aArg1: TTestRecord5): TTestRecord5; + function TestRecSize6(aArg1: TTestRecord6): TTestRecord6; + function TestRecSize7(aArg1: TTestRecord7): TTestRecord7; + function TestRecSize8(aArg1: TTestRecord8): TTestRecord8; + function TestRecSize9(aArg1: TTestRecord9): TTestRecord9; + function TestRecSize10(aArg1: TTestRecord10): TTestRecord10; + public + InputArgs: array of TValue; + OutputArgs: array of TValue; + ResultValue: TValue; + CalledMethod: SizeInt; + InOutMapping: array of SizeInt; + procedure Reset; + public class var + ProcVarInst: TTestInterfaceClass; + ProcVarRecInst: TTestInterfaceClass; + public const + RecSizeMarker = SizeInt($80000000); + end; + + TMethodTest1 = procedure of object; + TMethodTest2 = function: SizeInt of object; + TMethodTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object; + TMethodTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString) of object; + TMethodTest5 = function: AnsiString of object; + TMethodTest6 = function: UnicodeString of object; + TMethodTest7 = function: WideString of object; + TMethodTest8 = function: ShortString of object; + TMethodTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt) of object; + TMethodTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString) of object; + TMethodTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString) of object; + TMethodTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt) of object; + + TMethodTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1 of object; + TMethodTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2 of object; + TMethodTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3 of object; + TMethodTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4 of object; + TMethodTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5 of object; + TMethodTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6 of object; + TMethodTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7 of object; + TMethodTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8 of object; + TMethodTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9 of object; + TMethodTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10 of object; + + TProcVarTest1 = procedure; + TProcVarTest2 = function: SizeInt; + TProcVarTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt; + TProcVarTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString); + TProcVarTest5 = function: AnsiString; + TProcVarTest6 = function: UnicodeString; + TProcVarTest7 = function: WideString; + TProcVarTest8 = function: ShortString; + TProcVarTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt); + TProcVarTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString); + TProcVarTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString); + TProcVarTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt); + + TProcVarTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1; + TProcVarTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2; + TProcVarTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3; + TProcVarTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4; + TProcVarTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5; + TProcVarTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6; + TProcVarTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7; + TProcVarTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8; + TProcVarTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9; + TProcVarTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10; + +procedure TTestInterfaceClass.Test1; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + ResultValue := TValue.Empty; + CalledMethod := 1; +end; + +function TTestInterfaceClass.Test2: SizeInt; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + Result := 42; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 2; +end; + +function TTestInterfaceClass.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt; +begin + SetLength(InputArgs, 10); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]); + TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]); + TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]); + TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]); + TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]); + TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]); + TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]); + TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]); + TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]); + SetLength(OutputArgs, 0); + Result := 42; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 3; +end; + +procedure TTestInterfaceClass.Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString); +begin + SetLength(InputArgs, 4); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]); + TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]); + TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]); + SetLength(OutputArgs, 0); + ResultValue := TValue.Empty; + CalledMethod := 4; +end; + +function TTestInterfaceClass.Test5: AnsiString; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + Result := 'Hello World'; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 5; +end; + +function TTestInterfaceClass.Test6: UnicodeString; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + Result := 'Hello World'; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 6; +end; + +function TTestInterfaceClass.Test7: WideString; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + Result := 'Hello World'; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 7; +end; + +function TTestInterfaceClass.Test8: ShortString; +begin + SetLength(InputArgs, 0); + SetLength(OutputArgs, 0); + Result := 'Hello World'; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 8; +end; + +procedure TTestInterfaceClass.Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt); +begin + SetLength(InputArgs, 4); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]); + TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]); + TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]); + aArg2 := $1234; + aArg3 := $5678; + SetLength(OutputArgs, 2); + TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]); + TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]); + SetLength(InOutMapping, 2); + InOutMapping[0] := 1; + InOutMapping[1] := 2; + ResultValue := TValue.Empty; + CalledMethod := 9; +end; + +procedure TTestInterfaceClass.Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString); +begin + SetLength(InputArgs, 4); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]); + TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]); + TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]); + aArg2 := 'Foo'; + aArg3 := 'Bar'; + SetLength(OutputArgs, 2); + TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]); + TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]); + SetLength(InOutMapping, 2); + InOutMapping[0] := 1; + InOutMapping[1] := 2; + ResultValue := TValue.Empty; + CalledMethod := 10; +end; + +procedure TTestInterfaceClass.Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString); +begin + SetLength(InputArgs, 4); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]); + TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]); + TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]); + aArg2 := 'Foo'; + aArg3 := 'Bar'; + SetLength(OutputArgs, 2); + TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]); + TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]); + SetLength(InOutMapping, 2); + InOutMapping[0] := 1; + InOutMapping[1] := 2; + ResultValue := TValue.Empty; + CalledMethod := 11; +end; + +procedure TTestInterfaceClass.Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt); +{$ifdef fpc} +var + i: SizeInt; + start: SizeInt; +{$endif} +begin +{$ifdef fpc} + SetLength(InputArgs, 4); + InputArgs[0] := specialize OpenArrayToDynArrayValue(aArg1); + InputArgs[1] := specialize OpenArrayToDynArrayValue(aArg2); + InputArgs[2] := specialize OpenArrayToDynArrayValue(aArg3); + InputArgs[3] := specialize OpenArrayToDynArrayValue(aArg4); + SetLength(OutputArgs, 2); + start := $4321; + for i := 0 to High(aArg2) do + aArg2[i] := start + i; + start := $9876; + for i := 0 to High(aArg3) do + aArg3[i] := start + i; + OutputArgs[0] := specialize OpenArrayToDynArrayValue(aArg2); + OutputArgs[1] := specialize OpenArrayToDynArrayValue(aArg3); + SetLength(InOutMapping, 2); + InOutMapping[0] := 1; + InOutMapping[1] := 2; + ResultValue := TValue.Empty; + CalledMethod := 12; +{$endif} +end; + +function TTestInterfaceClass.TestRecSize1(aArg1: TTestRecord1): TTestRecord1; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 1 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize2(aArg1: TTestRecord2): TTestRecord2; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 2 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize3(aArg1: TTestRecord3): TTestRecord3; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 3 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize4(aArg1: TTestRecord4): TTestRecord4; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 4 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize5(aArg1: TTestRecord5): TTestRecord5; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 5 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize6(aArg1: TTestRecord6): TTestRecord6; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 6 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize7(aArg1: TTestRecord7): TTestRecord7; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 7 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize8(aArg1: TTestRecord8): TTestRecord8; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 8 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize9(aArg1: TTestRecord9): TTestRecord9; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 9 or RecSizeMarker; +end; + +function TTestInterfaceClass.TestRecSize10(aArg1: TTestRecord10): TTestRecord10; +var + i: LongInt; +begin + SetLength(InputArgs, 1); + TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]); + SetLength(OutputArgs, 0); + for i := 0 to High(aArg1.b) do + Result.b[High(Result.b) - i] := aArg1.b[i]; + TValue.Make(@Result, TypeInfo(Result), ResultValue); + CalledMethod := 10 or RecSizeMarker; +end; + +procedure TTestInterfaceClass.Reset; +begin + InputArgs := Nil; + OutputArgs := Nil; + InOutMapping := Nil; + ResultValue := TValue.Empty; + CalledMethod := 0; +end; + +procedure ProcTest1; +begin + TTestInterfaceClass.ProcVarInst.Test1; +end; + +function ProcTest2: SizeInt; +begin + Result := TTestInterfaceClass.ProcVarInst.Test2; +end; + +function ProcTest3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt; +begin + Result := TTestInterfaceClass.ProcVarInst.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10); +end; + +procedure ProcTest4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString); +begin + TTestInterfaceClass.ProcVarInst.Test4(aArg1, aArg2, aArg3, aArg4); +end; + +function ProcTest5: AnsiString; +begin + Result := TTestInterfaceClass.ProcVarInst.Test5; +end; + +function ProcTest6: UnicodeString; +begin + Result := TTestInterfaceClass.ProcVarInst.Test6; +end; + +function ProcTest7: WideString; +begin + Result := TTestInterfaceClass.ProcVarInst.Test7; +end; + +function ProcTest8: ShortString; +begin + Result := TTestInterfaceClass.ProcVarInst.Test8; +end; + +procedure ProcTest9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt); +begin + TTestInterfaceClass.ProcVarInst.Test9(aArg1, aArg2, aArg3, aArg4); +end; + +procedure ProcTest10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString); +begin + TTestInterfaceClass.ProcVarInst.Test10(aArg1, aArg2, aArg3, aArg4); +end; + +procedure ProcTest11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString); +begin + TTestInterfaceClass.ProcVarInst.Test11(aArg1, aArg2, aArg3, aArg4); +end; + +procedure ProcTest12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt); +begin + TTestInterfaceClass.ProcVarInst.Test12(aArg1, aArg2, aArg3, aArg4); +end; + +function ProcTestRecSize1(aArg1: TTestRecord1): TTestRecord1; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize1(aArg1); +end; + +function ProcTestRecSize2(aArg1: TTestRecord2): TTestRecord2; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize2(aArg1); +end; + +function ProcTestRecSize3(aArg1: TTestRecord3): TTestRecord3; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize3(aArg1); +end; + +function ProcTestRecSize4(aArg1: TTestRecord4): TTestRecord4; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize4(aArg1); +end; + +function ProcTestRecSize5(aArg1: TTestRecord5): TTestRecord5; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize5(aArg1); +end; + +function ProcTestRecSize6(aArg1: TTestRecord6): TTestRecord6; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize6(aArg1); +end; + +function ProcTestRecSize7(aArg1: TTestRecord7): TTestRecord7; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize7(aArg1); +end; + +function ProcTestRecSize8(aArg1: TTestRecord8): TTestRecord8; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize8(aArg1); +end; + +function ProcTestRecSize9(aArg1: TTestRecord9): TTestRecord9; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize9(aArg1); +end; + +function ProcTestRecSize10(aArg1: TTestRecord10): TTestRecord10; +begin + Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1); +end; + +function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue; +var + arrptr: Pointer; + len, i: SizeInt; +begin + if aValue.Kind = tkDynArray then begin + { we need to decouple the source reference, so we're going to be a bit + cheeky here } + len := aValue.GetArrayLength; + arrptr := Nil; + DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len); + TValue.Make(@arrptr, aValue.TypeInfo, Result); + for i := 0 to len - 1 do + Result.SetArrayElement(i, aValue.GetArrayElement(i)); + end else + TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result); +end; + +procedure TTestInvoke.DoIntfInvoke(aIndex: SizeInt; aInputArgs, + aOutputArgs: TValueArray; aResult: TValue); +var + cls: TTestInterfaceClass; + intf: ITestInterface; + name: String; + context: TRttiContext; + t: TRttiType; + inst, res: TValue; + method: TRttiMethod; + i: SizeInt; + input: array of TValue; +begin + cls := TTestInterfaceClass.Create; + intf := cls; + + TValue.Make(@intf, TypeInfo(intf), inst); + + if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then + name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker) + else + name := 'Test' + IntToStr(aIndex); + + context := TRttiContext.Create; + try + t := context.GetType(TypeInfo(ITestInterface)); + method := t.GetMethod(name); + Check(Assigned(method), 'Method not found: ' + name); + + { arguments might be modified by Invoke (Note: Copy() does not uniquify the + IValueData of managed types) } + SetLength(input, Length(aInputArgs)); + for i := 0 to High(input) do + input[i] := CopyValue(aInputArgs[i]); + + try + res := method.Invoke(inst, aInputArgs); + except + DumpExceptionBacktrace(output); + raise; + end; + CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name); + Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name); + Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name); + CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name); + CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name); + CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name); + for i := 0 to High(aInputArgs) do begin + Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name])); + end; + for i := 0 to High(aOutputArgs) do begin + Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name])); + Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name])); + end; + finally + context.Free; + end; +end; + +procedure TTestInvoke.DoMethodInvoke(aInst: TObject; aMethod: TMethod; + aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); +var + cls: TTestInterfaceClass; + name: String; + context: TRttiContext; + t: TRttiType; + callable, res: TValue; + method: TRttiMethodType; + i: SizeInt; + input: array of TValue; +begin + cls := aInst as TTestInterfaceClass; + cls.Reset; + + if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then + name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker) + else + name := 'Test' + IntToStr(aIndex); + + TValue.Make(@aMethod, aTypeInfo, callable); + + context := TRttiContext.Create; + try + t := context.GetType(aTypeInfo); + Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name); + method := t as TRttiMethodType; + + { arguments might be modified by Invoke (Note: Copy() does not uniquify the + IValueData of managed types) } + SetLength(input, Length(aInputArgs)); + for i := 0 to High(input) do + input[i] := CopyValue(aInputArgs[i]); + + res := method.Invoke(callable, aInputArgs); + CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name); + Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name); + Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name); + CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name); + CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name); + CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name); + for i := 0 to High(aInputArgs) do begin + Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name])); + end; + for i := 0 to High(aOutputArgs) do begin + Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name])); + Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name])); + end; + finally + context.Free; + end; +end; + +procedure TTestInvoke.DoProcVarInvoke(aInst: TObject; aProc: CodePointer; + aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); +var + cls: TTestInterfaceClass; + name: String; + context: TRttiContext; + t: TRttiType; + callable, res: TValue; + proc: TRttiProcedureType; + i: SizeInt; + input: array of TValue; +begin + cls := aInst as TTestInterfaceClass; + cls.Reset; + + if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin + name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker); + TTestInterfaceClass.ProcVarRecInst := cls; + end else begin + name := 'Test' + IntToStr(aIndex); + TTestInterfaceClass.ProcVarInst := cls; + end; + + TValue.Make(@aProc, aTypeInfo, callable); + + context := TRttiContext.Create; + try + t := context.GetType(aTypeInfo); + Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name); + proc := t as TRttiProcedureType; + + { arguments might be modified by Invoke (Note: Copy() does not uniquify the + IValueData of managed types) } + SetLength(input, Length(aInputArgs)); + for i := 0 to High(input) do + input[i] := CopyValue(aInputArgs[i]); + + res := proc.Invoke(callable, aInputArgs); + CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name); + Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name); + Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name); + CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name); + CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name); + CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name); + for i := 0 to High(aInputArgs) do begin + Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name])); + end; + for i := 0 to High(aOutputArgs) do begin + Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name])); + Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name])); + end; + finally + context.Free; + end; +end; + +{$ifndef InLazIDE} +{$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoMethodInvoke(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); +begin + DoMethodInvoke(aInst, TMethod(aMethod), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult); +end; + +{$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoProcVarInvoke(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); +begin + DoProcVarInvoke(aInst, CodePointer(aProc), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult); +end; + +{$ifdef fpc}generic{$endif} function TTestInvoke.GetRecValue(aReverse: Boolean): TValue; +var + i: LongInt; + arr: array of Byte; +begin + SetLength(arr, SizeOf(T)); + RandSeed := $54827982; + if not aReverse then begin + for i := 0 to High(arr) do + arr[i] := Random($ff); + end else begin + for i := High(arr) downto 0 do + arr[i] := Random($ff); + end; + TValue.Make(@arr[0], PTypeInfo(TypeInfo(T)), Result); +end; +{$endif} + +function GetIntValue(aValue: SizeInt): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetAnsiString(const aValue: AnsiString): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetShortString(const aValue: ShortString): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +{$ifdef fpc} +function GetArray(const aArg: array of SizeInt): TValue; +begin + Result := specialize OpenArrayToDynArrayValue(aArg); +end; +{$endif} + +procedure TTestInvoke.TestIntfMethods; +begin + DoIntfInvoke(1, [], [], TValue.Empty); + DoIntfInvoke(2, [], [], TValue.{$ifdef fpc}specialize{$endif}From(42)); + + DoIntfInvoke(3, [ + GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3) + ], [], GetIntValue(42)); + + DoIntfInvoke(4, [ + TValue.{$ifdef fpc}specialize{$endif}From('Alpha'), + TValue.{$ifdef fpc}specialize{$endif}From('Beta'), + TValue.{$ifdef fpc}specialize{$endif}From('Gamma'), + TValue.{$ifdef fpc}specialize{$endif}From('Delta') + ], [], TValue.Empty); + + DoIntfInvoke(5, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + DoIntfInvoke(6, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + DoIntfInvoke(7, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + DoIntfInvoke(8, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + + DoIntfInvoke(9, [ + GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678) + ], [ + GetIntValue($1234), GetIntValue($5678) + ], TValue.Empty); + + DoIntfInvoke(10, [ + GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta') + ], [ + GetAnsiString('Foo'), GetAnsiString('Bar') + ], TValue.Empty); + + DoIntfInvoke(11, [ + GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta') + ], [ + GetShortString('Foo'), GetShortString('Bar') + ], TValue.Empty); + +{$ifdef fpc} + DoIntfInvoke(12, [ + GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432]) + ], [ + GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879]) + ], TValue.Empty); +{$endif} +end; + +procedure TTestInvoke.TestIntfMethodsRecs; +begin + DoIntfInvoke(1 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(2 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(3 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(4 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(5 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(6 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(7 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(8 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(9 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + DoIntfInvoke(10 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); +end; + +procedure TTestInvoke.TestMethodVars; +var + cls: TTestInterfaceClass; +begin + cls := TTestInterfaceClass.Create; + try + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test1, 1, [], [], TValue.Empty); + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From(42)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test3, 3, [ + GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3) + ], [], GetIntValue(42)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test4, 4, [ + TValue.{$ifdef fpc}specialize{$endif}From('Alpha'), + TValue.{$ifdef fpc}specialize{$endif}From('Beta'), + TValue.{$ifdef fpc}specialize{$endif}From('Gamma'), + TValue.{$ifdef fpc}specialize{$endif}From('Delta') + ], [], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test9, 9, [ + GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678) + ], [ + GetIntValue($1234), GetIntValue($5678) + ], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test10, 10, [ + GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta') + ], [ + GetAnsiString('Foo'), GetAnsiString('Bar') + ], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test11, 11, [ + GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta') + ], [ + GetShortString('Foo'), GetShortString('Bar') + ], TValue.Empty); + + {$ifdef fpc} + specialize GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.Test12, 12, [ + GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432]) + ], [ + GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879]) + ], TValue.Empty); + {$endif} + finally + cls.Free; + end; +end; + +procedure TTestInvoke.TestMethodVarsRecs; +var + cls: TTestInterfaceClass; +begin + cls := TTestInterfaceClass.Create; + try + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoMethodInvoke(cls, {$ifdef fpc}@{$endif}cls.TestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + finally + cls.Free; + end; +end; + +procedure TTestInvoke.TestProcVars; +var + cls: TTestInterfaceClass; +begin + cls := TTestInterfaceClass.Create; + try + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest1, 1, [], [], TValue.Empty); + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From(42)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest3, 3, [ + GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3) + ], [], GetIntValue(42)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest4, 4, [ + TValue.{$ifdef fpc}specialize{$endif}From('Alpha'), + TValue.{$ifdef fpc}specialize{$endif}From('Beta'), + TValue.{$ifdef fpc}specialize{$endif}From('Gamma'), + TValue.{$ifdef fpc}specialize{$endif}From('Delta') + ], [], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From('Hello World')); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest9, 9, [ + GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678) + ], [ + GetIntValue($1234), GetIntValue($5678) + ], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest10, 10, [ + GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta') + ], [ + GetAnsiString('Foo'), GetAnsiString('Bar') + ], TValue.Empty); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest11, 11, [ + GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta') + ], [ + GetShortString('Foo'), GetShortString('Bar') + ], TValue.Empty); + + {$ifdef fpc} + specialize GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTest12, 12, [ + GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432]) + ], [ + GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879]) + ], TValue.Empty); + {$endif} + finally + cls.Free; + end; +end; + +procedure TTestInvoke.TestProcVarsRecs; +var + cls: TTestInterfaceClass; +begin + cls := TTestInterfaceClass.Create; + try + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + + {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke(cls, {$ifdef fpc}@{$endif}ProcTestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker, + [{$ifdef fpc}specialize{$endif} GetRecValue(False)], [], + {$ifdef fpc}specialize{$endif} GetRecValue(True)); + finally + cls.Free; + end; +end; + begin {$ifdef fpc} RegisterTest(TTestInvoke); diff --git a/packages/rtl-objpas/tests/tests.rtti.pas b/packages/rtl-objpas/tests/tests.rtti.pas index 69eb27d2d7..7fd693fceb 100644 --- a/packages/rtl-objpas/tests/tests.rtti.pas +++ b/packages/rtl-objpas/tests/tests.rtti.pas @@ -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(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; +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; +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