Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • Petr-K/source
  • freepascal.org/fpc/source
  • ccrause/fpc-source
  • henriquewerlang/source
  • andrewd207/free-pascal-source
  • FPK2/source
  • genericptr/free-pascal
  • michael-ring/freepascal-sources
  • prof7bit/fpc-source
  • alb42/fpc-source
  • khemicalkoder/fpc-source
  • DonAlfredo/fpc-source
  • fpc-ondrej/source
  • CuriousKit/optimisations
  • sergy.larin/fpcsrc
  • Bi0T1N/free-pascal-source
  • Free_Coder/source
  • BDmytro/fpc-source
  • alexraynepe196/fpc-source
  • robdaemon/fpc-source
  • odisey1245/source
  • Akira13641/source
  • runewalsh/source
  • pa7n/source
  • iongion/source
  • th-otto/source
  • Thompson1985/source
  • badsectoracula/fpc-source
  • KaMiSchi/source
  • waynesherman/fpc-source
  • inoussa12/source
  • suvepl/fpc-src
  • magorium/fpc-source
  • margers.roked/textmode_ide
  • PizzaProgram/source
  • BranDougherty/source
  • ndusart/fpcsource
  • Yn0ga/FPC
  • benibela/fpc-source
  • daniel.franzini/source
  • martin_frb/fpc-rademakers
  • frank.rademakers/fpc
  • blikblum/fpc
  • seryal/source
  • andrey.sobol.nn/fpcsrc
  • paweld_/fpc_source
  • Free-Pascal-meets-SDL-Website/fpc-source
  • martin_frb/fpc-src
  • MQ-mengqing/source
  • dirk_grineisen/source
  • lixing-star/source
  • d.ioannidis/source
  • keithbowes/fpc-source
  • Onur2x2/source
  • armbiant/fpc
  • fibodevy/source
  • DonAlfredo/freepascal-sources
  • mikhailnov/fpc-source
  • maricarai/source
  • SlawekZalecki/source
  • _alligator_/source
  • dbannon/fpc-source
  • NormanDunbar/FPC_Source
  • ACTom/source
  • Interferon/source
  • peterdell/source
  • ariochthe/FPC_source
  • begasus1/source
  • leledumbo/fpc-source
  • kevinofoz/kj-fpc-source
  • bogen85/source
  • wFeus/fpc-with-inline-variables
  • Warfley/fpcsource
  • michalgw/fpc-main
  • modersohn/FPCsource
  • Arael1895/fp-report-fix
  • troublemaker-dev/fpc-source
  • CharlesAverill/source
  • kagamma/source
  • barracuda156/source
  • zamtmn/source
  • markusbeth/source
  • rchaer/source
  • kberov/fpc_source
  • MaxM74/fpc-source
  • jry2/fpc-source
  • KaiBurghardt/source
  • mattvvv/source
  • sechshelme/source
  • jsuzineau/FPC
  • socialmediarefugee/fpcsrc
  • scootersoftware/source
  • Key-Real/source
  • PearlDragon/source
  • armbiant/android-fpc-source
  • armbiant/android-fpc
  • armbiant/android-fpc-optimizations
  • armbiant/apache-android-fpc-optimizations
  • dkk089/fpc-src
  • chrschllr/fpc-source
  • aruna.hewapathirane/source
  • olatov/fpc-source
  • regs01/source
103 results
Show changes
Commits on Source (19)
Hide whitespace changes
Inline Side-by-side
Showing
with 1331 additions and 400 deletions
packages/rtl-objpas/src/inc/rtti.pp
View file @ cb072b6b
......@@ -71,6 +71,7 @@ TRttiMethod = class;
TRttiIndexedProperty = class;
TRttiField = Class;
TRttiProperty = class;
TRttiOrdinalType = class;
TRttiInstanceType = class;
TRttiRecordType = class;
......@@ -185,6 +186,7 @@ TValue = record
procedure CastInterfaceToInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
procedure CastFromInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
// From Pointer
procedure CastPointerToClass(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
procedure CastFromPointer(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
// From set
procedure CastSetToSet(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
......@@ -207,6 +209,7 @@ TValue = record
{ Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! }
generic class function FromOpenArray<T>(constref aValue: array of T): TValue; static; inline;
{$endif}
class function From(aTypeInfo: PTypeInfo; ABuffer: Pointer): TValue; static;
class function FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue; static; {inline;}
class function FromArray(aArrayTypeInfo: PTypeInfo; const aValues: array of TValue): TValue; static;
class function FromVarRec(const aValue: TVarRec): TValue; static;
......@@ -282,6 +285,7 @@ TValue = record
class operator := (AValue: QWord): TValue; inline;
class operator := (AValue: TObject): TValue; inline;
class operator := (AValue: TClass): TValue; inline;
class operator := (AValue: Pointer): TValue; inline;
class operator := (AValue: Boolean): TValue; inline;
class operator := (AValue: IUnknown): TValue; inline;
class operator := (AValue: TVarRec): TValue; inline;
......@@ -358,6 +362,8 @@ TRttiType = class(TRttiNamedObject)
FProperties : TRttiPropertyArray;
FIndexedProperties : TRttiIndexedPropertyArray;
function GetAsInstance: TRttiInstanceType;
function GetAsOrdinal: TRttiOrdinalType;
function GetAsRecord: TRttiRecordType;
protected
FTypeData: PTypeData;
function GetName: string; override;
......@@ -388,6 +394,8 @@ TRttiType = class(TRttiNamedObject)
function GetMethods: TRttiMethodArray; virtual; overload;
function GetMethods(const aName: string): TRttiMethodArray; overload; virtual;
function GetMethod(const aName: String): TRttiMethod; virtual;
function GetMethod(aCodeAddress: CodePointer): TRttiMethod; overload; virtual;
function ToString : RTLString; override;
property IsInstance: boolean read GetIsInstance;
property IsManaged: boolean read GetIsManaged;
property IsOrdinal: boolean read GetIsOrdinal;
......@@ -396,6 +404,8 @@ TRttiType = class(TRttiNamedObject)
property BaseType: TRttiType read GetBaseType;
property Handle: PTypeInfo read FTypeInfo;
property AsInstance: TRttiInstanceType read GetAsInstance;
property AsOrdinal: TRttiOrdinalType read GetAsOrdinal;
property AsRecord: TRttiRecordType read GetAsRecord;
property TypeKind: TTypeKind read GetTypeKind;
property TypeSize: integer read GetTypeSize;
end;
......@@ -411,12 +421,15 @@ TRttiFloatType = class(TRttiType)
property FloatType: TFloatType read GetFloatType;
end;
{ TRttiOrdinalType }
TRttiOrdinalType = class(TRttiType)
private
function GetMaxValue: LongInt; inline;
function GetMinValue: LongInt; inline;
function GetOrdType: TOrdType; inline;
protected
function GetIsOrdinal: Boolean; override;
function GetTypeSize: Integer; override;
public
property OrdType: TOrdType read GetOrdType;
......@@ -543,7 +556,12 @@ TRttiProperty = class(TRttiDataMember)
function GetIsWritable: boolean; override;
function GetIsReadable: boolean; override;
function GetDataType: TRttiType; override;
function GetDefault: Integer; virtual;
function GetIndex: Integer; virtual;
function GetIsClassProperty: boolean; virtual;
protected
procedure SetStaticPropValue(const AValue: TValue); virtual;
function GetStaticPropValue: TValue; virtual;
function GetName: string; override;
function GetHandle: Pointer; override;
public
......@@ -554,6 +572,9 @@ TRttiProperty = class(TRttiDataMember)
procedure SetValue(Instance: pointer; const AValue: TValue); override;
function ToString: String; override;
property PropertyType: TRttiType read GetPropertyType;
property Default: Integer read GetDefault;
property Index: Integer read GetIndex;
property IsClassProperty: boolean read GetIsClassProperty;
property IsReadable: boolean read GetIsReadable;
property IsWritable: boolean read GetIsWritable;
end;
......@@ -568,13 +589,14 @@ TRttiField = class(TRttiDataMember)
FHandle : PExtendedFieldEntry;
FAttributes: TCustomAttributeArray;
FAttributesResolved : Boolean;
function GetName: string; override;
function GetDataType: TRttiType; override;
function GetIsReadable: Boolean; override;
function GetIsWritable: Boolean; override;
procedure ResolveAttributes;
protected
function GetName: string; override;
function GetHandle: Pointer; override;
Function GetAttributes: TCustomAttributeArray; override;
procedure ResolveAttributes;
// constructor Create(AParent: TRttiObject; var P: PByte); override;
public
destructor destroy; override;
......@@ -658,11 +680,14 @@ TRttiInvokableType = class(TRttiType)
function ToString : string; override;
end;
{ TRttiMethodType }
TRttiMethodType = class(TRttiInvokableType)
private
FCallConv: TCallConv;
FReturnType: TRttiType;
FParams, FParamsAll: TRttiParameterArray;
function GetMethodKind: TMethodKind;
protected
function GetParameters(aWithHidden: Boolean): TRttiParameterArray; override;
function GetCallingConvention: TCallConv; override;
......@@ -670,6 +695,7 @@ TRttiMethodType = class(TRttiInvokableType)
function GetFlags: TFunctionCallFlags; override;
public
function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
property MethodKind: TMethodKind read GetMethodKind;
function ToString: string; override;
end;
......@@ -728,7 +754,7 @@ TRttiMethod = class(TRttiMember)
function GetParameters: TRttiParameterArray;
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;
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
{ Note: once "reference to" is supported these will be replaced by a single method }
function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod): TMethodImplementation;
function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackProc): TMethodImplementation;
......@@ -739,10 +765,13 @@ TRttiIndexedProperty = class(TRttiMember)
FPropInfo: PPropInfo;
FAttributesResolved: boolean;
FAttributes: TCustomAttributeArray;
FParams: TRttiParameterArray;
FReadMethod: TRttiMethod;
FWriteMethod: TRttiMethod;
procedure GetAccessors;
//function GetIsDefault: Boolean; virtual;
function GetIndexParameters: TRttiParameterArray; virtual;
function GetIsClassProperty: Boolean; virtual;
function GetPropertyType: TRttiType; virtual;
function GetIsReadable: Boolean; virtual;
function GetIsWritable: Boolean; virtual;
......@@ -750,7 +779,8 @@ TRttiIndexedProperty = class(TRttiMember)
function GetWriteMethod: TRttiMethod; virtual;
function GetReadProc: CodePointer; virtual;
function GetWriteProc: CodePointer; virtual;
protected
procedure ResolveIndexParams;
protected
function GetName: string; override;
function GetHandle: Pointer; override;
public
......@@ -762,6 +792,8 @@ TRttiIndexedProperty = class(TRttiMember)
const aValue: TValue);
function ToString: String; override;
property Handle: Pointer read GetHandle;
property IndexParameters: TRttiParameterArray read GetIndexParameters;
property IsClassProperty: Boolean read GetIsClassProperty;
property IsReadable: Boolean read GetIsReadable;
property IsWritable: Boolean read GetIsWritable;
property PropertyType: TRttiType read GetPropertyType;
......@@ -850,19 +882,22 @@ TRttiRecordType = class(TRttiStructuredType)
FDeclaredProperties: TRttiPropertyArray;
FDeclaredIndexedProperties: TRttiIndexedPropertyArray;
protected
function GetIsRecord: boolean; override;
procedure ResolveFields;
procedure ResolveMethods;
procedure ResolveProperties;
procedure ResolveIndexedProperties;
function GetTypeSize: Integer; override;
public
function GetFields : TRttiFieldArray; override;
function GetMethods: TRttiMethodArray; override;
function GetProperties: TRttiPropertyArray; override;
function GetDeclaredFields: TRttiFieldArray; override;
function GetDeclaredMethods: TRttiMethodArray; override;
function GetDeclaredProperties: TRttiPropertyArray; override;
function GetDeclaredIndexedProperties: TRttiIndexedPropertyArray; override;
function GetAttributes: TCustomAttributeArray;
function GetAttributes: TCustomAttributeArray; override;
function GetIndexedProperties: TRttiIndexedPropertyArray; override;
// property ManagedFields: TRttiManagedFieldArray read GetManagedFields;
end;
......@@ -944,12 +979,12 @@ function ArrayOfConstToTValueArray(const aValues: array of const): TValueArray;
{ these resource strings are needed by units implementing function call managers }
resourcestring
SErrInvokeNotImplemented = 'Invoke functionality is not implemented';
SErrInvokeNotImplemented = 'Invoke functionality is not implemented on this platform. Use external managers, e.g. ffi.manager.';
SErrInvokeResultTypeNoValue = 'Function has a result type, but no result pointer provided';
SErrInvokeFailed = 'Invoke call failed';
SErrMethodImplCreateFailed = 'Failed to create method implementation';
SErrCallbackNotImplemented = 'Callback functionality is not implemented';
SErrCallConvNotSupported = 'Calling convention not supported: %s';
SErrCallConvNotSupported = 'Calling convention not supported: %s. Enable external managers, e.g. ffi.manager.';
SErrTypeKindNotSupported = 'Type kind is not supported: %s';
SErrCallbackHandlerNil = 'Callback handler is Nil';
SErrMissingSelfParam = 'Missing self parameter';
......@@ -1268,6 +1303,7 @@ TRttiIntfMethod = class(TRttiMethod)
public
constructor Create(AParent: TRttiType; AIntfMethodEntry: PIntfMethodEntry; AIndex: SmallInt);
function GetAttributes: TCustomAttributeArray; override;
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue; override;
end;
{ TRttiInstanceMethod }
......@@ -1302,6 +1338,7 @@ TRttiInstanceMethod = class(TRttiMethod)
public
constructor Create(AParent: TRttiType; aHandle: PVmtMethodExEntry);
function GetAttributes: TCustomAttributeArray; override;
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue; override;
end;
{ TRttiRecordMethod }
......@@ -1331,6 +1368,7 @@ TRttiRecordMethod = class(TRttiMethod)
constructor Create(AParent: TRttiType; aHandle: PRecMethodExEntry);
function GetParameters(aWithHidden: Boolean): TRttiParameterArray; override;
Function GetAttributes: TCustomAttributeArray; override;
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue; override;
end;
resourcestring
......@@ -1345,6 +1383,9 @@ TRttiRecordMethod = class(TRttiMethod)
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';
SErrInvokeNotStaticRecSelf = 'Non static record method requires a pointer or record instance: %s';
SErrInvokeRecCreateSelf = 'The record constructor can only take an empty value, a record or a pointer: %s';
SErrInvokeInstCreateSelf = 'The instance constructor can only accept a class, an instance of a class, or an empty value: %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';
......@@ -1366,8 +1407,13 @@ TRttiRecordMethod = class(TRttiMethod)
SErrVirtIntfMethodNil = 'Method %1:d of ''%0:s'' is Nil';
SErrVirtIntfCreateVmt = 'Failed to create VMT for ''%s''';
// SErrVirtIntfIInterface = 'Failed to prepare IInterface method callbacks';
SErrCannotWriteToClassProperty = 'Cannot write to class property "%s"';
SErrCannotReadClassProperty = 'Cannot read class property "%s"';
SErrCannotWriteToIndexedProperty = 'Cannot write to indexed property "%s"';
SErrCannotReadIndexedProperty = 'Cannot read indexed property "%s"';
// SErrIndPropArgInvalidType = 'Invalid type of argument for parameter %s of indexed property %s';
SErrIndPropArgCount = 'Invalid argument count for indexed property %s; expected %d, but got %d';
// SErrInvalidIndPropValue = 'Invalid indexed property value type for: %s';
var
// Boolean = UsePublishedOnly
......@@ -1822,6 +1868,214 @@ procedure InitDefaultFunctionCallManager;
FuncCallMgr[cc] := NoFunctionCallManager;
end;
function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray;
aCallConv: TCallConv; aResultType: PTypeInfo; aIsStatic: Boolean;
aIsConstructor: Boolean): TValue;
var
funcargs: TFunctionCallParameterArray;
i: LongInt;
flags: TFunctionCallFlags;
begin
{ sanity check }
if not Assigned(FuncCallMgr[aCallConv].Invoke) then
raise ENotImplemented.Create(SErrInvokeNotImplemented);
{ IsConstructor in FPC should not affect the result of the call }
flags := [];
if aIsStatic then
Include(flags, fcfStatic)
else if Length(aArgs) = 0 then
raise EInvocationError.Create(SErrMissingSelfParam);
funcargs:=[];
SetLength(funcargs, Length(aArgs));
for i := Low(aArgs) to High(aArgs) do
begin
funcargs[i - Low(aArgs) + Low(funcargs)].ValueRef := aArgs[i].GetReferenceToRawData;
funcargs[i - Low(aArgs) + Low(funcargs)].ValueSize := aArgs[i].DataSize;
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamType := aArgs[i].TypeInfo;
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamFlags := [];
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParaLocs := Nil;
end;
if Assigned(aResultType) then
TValue.Make(Nil, aResultType, Result)
else
Result := TValue.Empty;
FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags);
end;
{ internal realization }
function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; constref aInstance: TValue; constref aArgs: array of TValue; const aParams: TRttiParameterArray; aReturnType: PTypeInfo): TValue;
function ShouldTryCast(AParam: TRttiParameter; const AArg: TValue): boolean;
begin
Result := Assigned(AParam.ParamType) and (AParam.ParamType.FTypeInfo <> AArg.TypeInfo);
end;
var
param: TRttiParameter;
unhidden, i: SizeInt;
args: TFunctionCallParameterArray;
castedargs: array of TValue; // instance + args[i].Cast<ParamType>
resptr: Pointer;
mgr: TFunctionCallManager;
flags: TFunctionCallFlags;
hiddenVmt : Pointer;
highArg: SizeInt;
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]);
SetLength(castedargs, Length(aParams));
unhidden := 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;
end;
if not (pfHidden in param.Flags) then
Inc(unhidden);
end;
if unhidden <> Length(aArgs) then
raise EInvocationError.CreateFmt(SErrInvokeArgCount, [aName, unhidden, Length(aArgs)]);
if Assigned(aReturnType) then
begin
TValue.Make(Nil, aReturnType, Result);
resptr := Result.GetReferenceToRawData;
end
else
begin
Result := TValue.Empty;
resptr := Nil;
end;
args:=[];
SetLength(args, Length(aParams));
unhidden := 0;
for i := 0 to High(aParams) do
begin
param := aParams[i];
if Assigned(param.ParamType) then
args[i].Info.ParamType := param.ParamType.FTypeInfo
else
args[i].Info.ParamType := Nil;
args[i].Info.ParamFlags := param.Flags;
args[i].Info.ParaLocs := Nil;
if pfHidden in param.Flags then
begin
if pfSelf in param.Flags then
begin
{ we must ensure the correctness of Self transfer for record methods }
if (args[i].Info.ParamType <> nil) and (args[i].Info.ParamType^.Kind = tkRecord) and
(pfVar in param.Flags) and (aInstance.Kind = tkPointer) then
begin
args[i].Info.ParamFlags := [];
args[i].Info.ParamType := aInstance.TypeInfo;
args[i].ValueRef := aInstance.GetReferenceToRawData;
end
else if ShouldTryCast(param, aInstance) then
begin
if not aInstance.TryCast(param.ParamType.Handle, castedargs[I]) then
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, ['Self', aName, param.ParamType.Name, aInstance.TypeInfo^.Name]);
args[i].ValueRef := castedargs[I].GetReferenceToRawData;
end
else
args[i].ValueRef := aInstance.GetReferenceToRawData
end
else if pfVmt in param.Flags then
begin
if aInstance.Kind=tkClassRef then
hiddenVmt:=aInstance.AsClass
else if aInstance.Kind=tkClass then
hiddenVmt:=aInstance.AsObject.ClassType;
args[i].ValueRef := @HiddenVmt;
end
else if pfResult in param.Flags then
begin
if not Assigned(aReturnType) then
raise EInvocationError.CreateFmt(SErrInvokeRttiDataError, [aName]);
args[i].ValueRef := resptr;
aReturnType := 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
highArg := aArgs[unhidden - 1].GetArrayLength - 1
else if not Assigned(aArgs[unhidden - 1].TypeInfo) then
highArg := -1
else
highArg := 0;
TValue.Make(@highArg, TypeInfo(SizeInt), castedargs[i]);
args[i].ValueRef := castedargs[i].GetReferenceToRawData;
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
begin
if ShouldTryCast(param, aArgs[unhidden]) then
begin
if (param.Flags * [pfVar, pfOut, pfConstRef] <> []) or
not aArgs[unhidden].TryCast(param.ParamType.Handle, castedargs[I]) then
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName, param.ParamType.Name, aArgs[unhidden].TypeInfo^.Name]);
args[i].ValueRef := castedargs[I].GetReferenceToRawData;
end
else
args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData;
end;
Inc(unhidden);
end;
end;
flags := [];
if aStatic then
Include(flags, fcfStatic);
mgr.Invoke(aCodeAddress, args, aCallConv, aReturnType, resptr, flags);
end;
function TypeInfoFromRtti(const RttiType: TRttiType): PTypeInfo; inline;
begin
if RttiType = nil then
Result := nil
else
Result := RttiType.FTypeInfo;
end;
{ TRttiInstanceMethod }
function TRttiInstanceMethod.GetHandle: Pointer;
......@@ -1998,6 +2252,77 @@ function TRttiInstanceMethod.GetAttributes: TCustomAttributeArray;
Result:=FAttributes;
end;
function TRttiInstanceMethod.Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
type
TNewInstance = function(cls: TClass): TObject;
var
MetaClass: TClass;
pNewInst, addr: CodePointer;
vmt: PCodePointer;
begin
if IsConstructor then
begin
if aInstance.IsEmpty or not aInstance.IsObject then
begin
MetaClass := Parent.AsInstance.GetMetaClassType;
pNewInst := PVmt(MetaClass)^.vNewInstance;
end;
case aInstance.Kind of
{ TValue.Empty }
tkUnknown:
begin
aInstance := TNewInstance(pNewInst)(MetaClass);
end;
tkClassRef:
begin
aInstance := TNewInstance(pNewInst)(aInstance.AsClass);
end;
tkClass:
{ late constructor of already created object };
else
raise EInvocationError.CreateFmt(SErrInvokeInstCreateSelf, [Name]);
end;
end
else if IsStatic then
begin
if not aInstance.IsEmpty then
raise EInvocationError.CreateFmt(SErrInvokeStaticNoSelf, [Name]);
end
else if IsClassMethod then
begin
if not (aInstance.Kind in [tkUnknown, tkClassRef]) then
raise EInvocationError.CreateFmt(SErrInvokeClassMethodClassSelf, [Name]);
if aInstance.IsEmpty then
aInstance := Parent.AsInstance.GetMetaClassType;
end
else
begin
if aInstance.IsEmpty or not aInstance.IsObject then
raise EInvocationError.CreateFmt(SErrInvokeNotStaticNeedsSelf, [Name]);
end;
addr := Nil;
if IsStatic or IsConstructor or (GetVirtualIndex=-1) 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]
else
addr := CodeAddress;
end;
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;
{ TRttiPool }
function TRttiPool.GetTypes: specialize TArray<TRttiType>;
......@@ -2358,6 +2683,14 @@ function TValue.IsType(ATypeInfo: PTypeInfo): boolean;
result := ATypeInfo = TypeInfo;
end;
function TValue.GetIsEmpty: boolean;
begin
result := (FData.FTypeInfo=nil) or
((Kind in [tkSString, tkObject, tkRecord, tkArray]) and not Assigned(FData.FValueData)) or
((Kind in [tkPointer, tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer));
end;
function TValue.IsType(ATypeInfo: PTypeInfo; const EmptyAsAnyType : Boolean): boolean;
begin
Result:=IsEmpty;
......@@ -2386,7 +2719,6 @@ class procedure TValue.Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result:
Make(@AValue, System.TypeInfo(AValue), Result);
end;
class operator TValue.:=(const AValue: WideString): TValue;
begin
Make(@AValue, System.TypeInfo(AValue), Result);
......@@ -2472,6 +2804,11 @@ class procedure TValue.Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result:
Make(@AValue, System.TypeInfo(AValue), Result);
end;
class operator TValue.:=(AValue: Pointer): TValue;
begin
Make(@AValue, System.TypeInfo(AValue), Result);
end;
class operator TValue.:=(AValue: Boolean): TValue;
begin
Make(@AValue, System.TypeInfo(AValue), Result);
......@@ -2516,83 +2853,84 @@ class function TValue.Empty: TValue;
function TValue.GetDataSize: SizeInt;
begin
Result := 0;
if Assigned(FData.FValueData) and (Kind <> tkSString) then
Result := FData.FValueData.GetDataSize
else begin
Result := 0;
case Kind of
tkEnumeration,
tkBool,
tkInt64,
tkQWord,
tkInteger:
case TypeData^.OrdType of
otSByte,
otUByte:
Result := SizeOf(Byte);
otSWord,
otUWord:
Result := SizeOf(Word);
otSLong,
otULong:
Result := SizeOf(LongWord);
otSQWord,
otUQWord:
Result := SizeOf(QWord);
end;
tkChar:
Result := SizeOf(AnsiChar);
tkFloat:
case TypeData^.FloatType of
ftSingle:
Result := SizeOf(Single);
ftDouble:
Result := SizeOf(Double);
ftExtended:
Result := SizeOf(Extended);
ftComp:
Result := SizeOf(Comp);
ftCurr:
Result := SizeOf(Currency);
end;
tkSet:
Result := TypeData^.SetSize;
tkMethod:
Result := SizeOf(TMethod);
tkSString:
{ ShortString can hold max. 254 characters as [0] is Length and [255] is #0 }
Result := SizeOf(ShortString) - 2;
tkVariant:
Result := SizeOf(Variant);
tkProcVar:
Result := SizeOf(CodePointer);
tkWChar:
Result := SizeOf(WideChar);
tkUChar:
Result := SizeOf(UnicodeChar);
tkFile:
{ ToDo }
Result := SizeOf(TTextRec);
tkAString,
tkWString,
tkUString,
tkInterface,
tkDynArray,
tkClass,
tkHelper,
tkClassRef,
tkInterfaceRaw,
tkPointer:
Result := SizeOf(Pointer);
tkObject,
tkRecord:
Result := TypeData^.RecSize;
tkArray:
Result := TypeData^.ArrayData.Size;
tkUnknown,
tkLString:
Assert(False);
end;
begin
Result:=FData.FValueData.GetDataSize;
exit;
end;
case Kind of
tkEnumeration,
tkBool,
tkInt64,
tkQWord,
tkInteger:
case TypeData^.OrdType of
otSByte,
otUByte:
Result := SizeOf(Byte);
otSWord,
otUWord:
Result := SizeOf(Word);
otSLong,
otULong:
Result := SizeOf(LongWord);
otSQWord,
otUQWord:
Result := SizeOf(QWord);
end;
tkChar:
Result := SizeOf(AnsiChar);
tkFloat:
case TypeData^.FloatType of
ftSingle:
Result := SizeOf(Single);
ftDouble:
Result := SizeOf(Double);
ftExtended:
Result := SizeOf(Extended);
ftComp:
Result := SizeOf(Comp);
ftCurr:
Result := SizeOf(Currency);
end;
tkSet:
Result := TypeData^.SetSize;
tkMethod:
Result := SizeOf(TMethod);
tkSString:
{ ShortString can hold max. 254 characters as [0] is Length and [255] is #0 }
Result := SizeOf(ShortString) - 2;
tkVariant:
Result := SizeOf(Variant);
tkProcVar:
Result := SizeOf(CodePointer);
tkWChar:
Result := SizeOf(WideChar);
tkUChar:
Result := SizeOf(UnicodeChar);
tkFile:
{ ToDo }
Result := SizeOf(TTextRec);
tkAString,
tkWString,
tkUString,
tkInterface,
tkDynArray,
tkClass,
tkHelper,
tkClassRef,
tkInterfaceRaw,
tkPointer:
Result := SizeOf(Pointer);
tkObject,
tkRecord:
Result := TypeData^.RecSize;
tkArray:
Result := TypeData^.ArrayData.Size;
tkUnknown,
tkLString:
Assert(False);
end;
end;
......@@ -2933,7 +3271,7 @@ function TValue.GetDataSize: SizeInt;
begin
ExtractRawData(@CFrom);
Cto:=GetTypeData(GetTypeData(aDestType)^.InstanceType)^.ClassType;
aRes:=(cFrom=nil) or (Cfrom.InheritsFrom(cTo));
aRes:=(cFrom=nil) or ((Cfrom=nil) and (Cto=nil)) or (CFrom.InheritsFrom(Cto));
if aRes then
TValue.Make(PtrInt(cFrom),aDestType,aDest);
end;
......@@ -3181,6 +3519,7 @@ function TValue.GetDataSize: SizeInt;
Tmp:=Specialize AsType<AnsiChar>;
tkString,
tkLString,
tkAString,
tkWString,
tkUString:
Tmp:=AsString;
......@@ -3301,6 +3640,7 @@ function TValue.GetDataSize: SizeInt;
tkString,
tkWChar,
tkLString,
tkAString,
tkWString,
tkUString : CastCharToString(aRes,aDest,aDestType);
tkVariant : CastToVariant(aRes,aDest,aDestType);
......@@ -3316,6 +3656,7 @@ function TValue.GetDataSize: SizeInt;
tkString,
tkWChar,
tkLString,
tkAString,
tkWString,
tkUString : CastWCharToString(aRes,aDest,aDestType);
tkVariant : CastToVariant(aRes,aDest,aDestType);
......@@ -3419,6 +3760,7 @@ function TValue.GetDataSize: SizeInt;
tkString,
tkWChar,
tkLString,
tkAString,
tkWString,
tkInt64,
tkQWord,
......@@ -3429,11 +3771,23 @@ function TValue.GetDataSize: SizeInt;
end;
end;
Procedure TValue.CastPointerToClass(out aRes : Boolean; out ADest: TValue; aDestType: PTypeInfo);
var
Tmp: Pointer;
begin
Tmp:=AsPointer;
TValue.Make(@Tmp,aDestType,aDest);
aRes:=True;
end;
Procedure TValue.CastFromPointer(out aRes : Boolean; out ADest: TValue; aDestType: PTypeInfo);
begin
Case aDestType^.Kind of
tkPointer, tkProcedure: CastAssign(aRes,aDest,aDestType);
tkClass: CastPointerToClass(aRes,aDest,aDestType);
else
aRes:=False;
end;
......@@ -3655,6 +4009,12 @@ class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInf
Result.FData.FElSize := el.DataSize;
end;
class function TValue.From(aTypeInfo: PTypeInfo; ABuffer: Pointer): TValue;
begin
TValue.Make(ABuffer, PTypeInfo(aTypeInfo), Result);
end;
class function TValue.FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue;
{$ifdef ENDIAN_BIG}
var
......@@ -3775,12 +4135,6 @@ class function TValue.FromVariant(const aValue : Variant) : TValue;
end;
function TValue.GetIsEmpty: boolean;
begin
result := (FData.FTypeInfo=nil) or
((Kind in [tkSString, tkObject, tkRecord, tkArray]) and not Assigned(FData.FValueData)) or
((Kind in [tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer));
end;
function TValue.IsArray: boolean;
begin
......@@ -4162,9 +4516,22 @@ function TValue.AsInterface: IInterface;
function TValue.ToString: String;
function GetArrayElType(ATypeInfo: PTypeInfo): PTypeInfo;
begin
case ATypeInfo^.Kind of
tkArray:
Result := GetTypeData(ATypeInfo)^.ArrayData.ElType;
tkDynArray:
Result := GetTypeData(ATypeInfo)^.ElType2;
else
Result := nil;
end;
end;
var
Obj : TObject;
Cls: TClass;
ArrayKind: string;
begin
if IsEmpty then
......@@ -4186,6 +4553,7 @@ function TValue.ToString: String;
tkInterface : result := '(interface @ ' + HexStr(PPointer(FData.FValueData.GetReferenceToRawData)^) + ')';
tkInterfaceRaw : result := '(raw interface @ ' + HexStr(FData.FAsPointer) + ')';
tkEnumeration: Result := GetEnumName(TypeInfo, Integer(AsOrdinal));
tkSet: Result := SetToString(TypeInfo, GetReferenceToRawData, True);
tkChar: Result := AnsiChar(FData.FAsUByte);
tkWChar: Result := UTF8Encode(WideChar(FData.FAsUWord));
tkClass :
......@@ -4196,11 +4564,30 @@ function TValue.ToString: String;
else
Result:='<Nil>';
end;
tkRecord: Result := '(' + TypeInfo^.Name + ' record)';
tkClassRef:
begin
Cls:=AsClass;
if Assigned(Cls) then
Result := Format('(class ''%s'' @ %p)', [Cls.ClassName, Pointer(Cls)])
else
Result:='<empty class ref>';
end;
tkArray,
tkDynArray:
begin
if Kind = tkDynArray then
ArrayKind := 'dynamic '
else
ArrayKind := '';
Result:=Format('(%sarray [0..%d] of %s)', [ArrayKind, GetArrayLength - 1, GetArrayElType(TypeInfo)^.Name]);
end;
{$IF SIZEOF(POINTER) = SIZEOF(CODEPOINTER)}
{ if CodePointer is not the same as Pointer then it currently can't be
passed onto a array of const }
tkMethod: Result := Format('(method code=%p, data=%p)', [FData.FAsMethod.Code, FData.FAsMethod.Data]);
{$ENDIF}
tkVariant: Result := '(variant)';
else
result := '<unknown kind: '+GetEnumName(System.TypeInfo(TTypeKind),Ord(Kind))+'>';
end;
......@@ -4423,182 +4810,6 @@ procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer);
end;
function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray;
aCallConv: TCallConv; aResultType: PTypeInfo; aIsStatic: Boolean;
aIsConstructor: Boolean): TValue;
var
funcargs: TFunctionCallParameterArray;
i: LongInt;
flags: TFunctionCallFlags;
begin
{ sanity check }
if not Assigned(FuncCallMgr[aCallConv].Invoke) then
raise ENotImplemented.Create(SErrInvokeNotImplemented);
{ ToDo: handle IsConstructor }
if aIsConstructor then
raise ENotImplemented.Create(SErrInvokeNotImplemented);
flags := [];
if aIsStatic then
Include(flags, fcfStatic)
else if Length(aArgs) = 0 then
raise EInvocationError.Create(SErrMissingSelfParam);
funcargs:=[];
SetLength(funcargs, Length(aArgs));
for i := Low(aArgs) to High(aArgs) do begin
funcargs[i - Low(aArgs) + Low(funcargs)].ValueRef := aArgs[i].GetReferenceToRawData;
funcargs[i - Low(aArgs) + Low(funcargs)].ValueSize := aArgs[i].DataSize;
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamType := aArgs[i].TypeInfo;
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamFlags := [];
funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParaLocs := Nil;
end;
if Assigned(aResultType) then
TValue.Make(Nil, aResultType, Result)
else
Result := TValue.Empty;
FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags);
end;
function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; aInstance: TValue; constref aArgs: array of TValue; const aParams: TRttiParameterArray; aReturnType: TRttiType): TValue;
function ShouldTryCast(AParam: TRttiParameter; const AArg: TValue): boolean;
begin
Result := Assigned(AParam.ParamType) and (AParam.ParamType.FTypeInfo <> AArg.TypeInfo);
end;
var
param: TRttiParameter;
unhidden, i: SizeInt;
args: TFunctionCallParameterArray;
castedargs: array of TValue; // instance + args[i].Cast<ParamType>
restype: PTypeInfo;
resptr: Pointer;
mgr: TFunctionCallManager;
flags: TFunctionCallFlags;
hiddenVmt : Pointer;
highArg: SizeInt;
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]);
SetLength(castedargs, Length(aParams));
unhidden := 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;
end;
if not (pfHidden in param.Flags) then
Inc(unhidden);
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;
args:=[];
SetLength(args, Length(aParams));
unhidden := 0;
for i := 0 to High(aParams) do begin
param := aParams[i];
if Assigned(param.ParamType) then
args[i].Info.ParamType := param.ParamType.FTypeInfo
else
args[i].Info.ParamType := Nil;
args[i].Info.ParamFlags := param.Flags;
args[i].Info.ParaLocs := Nil;
if pfHidden in param.Flags then begin
if pfSelf in param.Flags then
begin
if ShouldTryCast(param, aInstance) then
begin
if not aInstance.TryCast(param.ParamType.Handle, castedargs[I]) then
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, ['Self', aName]);
args[i].ValueRef := castedargs[I].GetReferenceToRawData;
end else
args[i].ValueRef := aInstance.GetReferenceToRawData
end
else if pfVmt in param.Flags then
begin
if aInstance.Kind=tkClassRef then
hiddenVmt:=aInstance.AsClass
else if aInstance.Kind=tkClass then
hiddenVmt:=aInstance.AsObject.ClassType;
args[i].ValueRef := @HiddenVmt;
end
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
highArg := aArgs[unhidden - 1].GetArrayLength - 1
else if not Assigned(aArgs[unhidden - 1].TypeInfo) then
highArg := -1
else
highArg := 0;
TValue.Make(@highArg, TypeInfo(SizeInt), castedargs[i]);
args[i].ValueRef := castedargs[i].GetReferenceToRawData;
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
begin
if param.Flags * [pfVar, pfOut] <> [] then
begin
if ShouldTryCast(param, aArgs[unhidden]) then
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]);
args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData
end
else if not ShouldTryCast(param, aArgs[unhidden]) then
args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData
else
begin
if not aArgs[unhidden].TryCast(param.ParamType.Handle, castedargs[I]) then
raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]);
args[i].ValueRef := castedargs[I].GetReferenceToRawData;
end;
end;
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 TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
begin
if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then
......@@ -5068,16 +5279,46 @@ function TRttiIntfMethod.GetParameters(aWithHidden: Boolean): TRttiParameterArra
Inc(total);
end;
if visible <> total then
SetLength(FParams, visible);
finally
context.Free;
if visible <> total then
SetLength(FParams, visible);
finally
context.Free;
end;
if aWithHidden then
Result := FParamsAll
else
Result := FParams;
end;
function TRttiIntfMethod.Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
var
addr: CodePointer;
vmt: PCodePointer;
begin
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 GetVirtualIndex=-1 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;
if aWithHidden then
Result := FParamsAll
else
Result := FParams;
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;
{ TRttiInt64Type }
......@@ -5119,6 +5360,11 @@ function TRttiOrdinalType.GetOrdType: TOrdType;
Result := FTypeData^.OrdType;
end;
function TRttiOrdinalType.GetIsOrdinal: Boolean;
begin
Result:=True;
end;
function TRttiOrdinalType.GetTypeSize: Integer;
begin
case OrdType of
......@@ -5450,39 +5696,6 @@ function TRttiMethod.Invoke(aInstance: TClass; const aArgs: array of TValue): TV
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 or (GetVirtualIndex=-1) 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 := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), ReturnType);
end;
function TRttiMethod.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod): TMethodImplementation;
var
params: TRttiParameterArray;
......@@ -5558,14 +5771,17 @@ function TRttiMethod.CreateImplementation(aUserData: Pointer; aCallback: TMethod
{ TRttiIndexedProperty }
procedure TRttiIndexedProperty.GetAccessors;
var
context: TRttiContext;
obj: TRttiObject;
begin
if Assigned(FReadMethod) or Assigned(FWriteMethod) or
not IsReadable and not IsWritable then
if Assigned(FReadMethod)
or Assigned(FWriteMethod)
or not (IsReadable or IsWritable) then
Exit;
// yet not implemented
{ not tested on virtual methods }
if IsReadable then
FReadMethod := Parent.GetMethod(ReadProc);
if IsWritable then
FWriteMethod := Parent.GetMethod(WriteProc);
end;
function TRttiIndexedProperty.GetPropertyType: TRttiType;
......@@ -5580,6 +5796,61 @@ function TRttiIndexedProperty.GetPropertyType: TRttiType;
end;
end;
procedure TRttiIndexedProperty.ResolveIndexParams;
var
param: PVmtMethodParam;
total, visible: SizeInt;
context: TRttiContext;
obj: TRttiObject;
prtti : TRttiVmtMethodParameter;
begin
total := 0;
visible := 0;
SetLength(FParams,FPropInfo^.PropParams^.Count);
context := TRttiContext.Create(FUsePublishedOnly);
try
param := @FPropInfo^.PropParams^.Params[0];
while total < FPropInfo^.PropParams^.Count do
begin
obj := context.GetByHandle(param);
if Assigned(obj) then
prtti := obj as TRttiVmtMethodParameter
else
begin
prtti := TRttiVmtMethodParameter.Create(param);
context.AddObject(prtti);
end;
FParams[total]:=prtti;
if not (pfHidden in param^.Flags) then
begin
FParams[visible] := prtti;
Inc(visible);
end;
param := param^.Next;
Inc(total);
end;
if visible <> total then
SetLength(FParams, visible);
finally
context.Free;
end;
end;
function TRttiIndexedProperty.GetIndexParameters: TRttiParameterArray;
begin
if FPropInfo^.PropParams^.Count = 0 then
Exit(Nil);
if Length(FParams) > 0 then
Exit(FParams);
ResolveIndexParams;
Result := FParams;
end;
function TRttiIndexedProperty.GetIsClassProperty: boolean;
begin
result := FPropInfo^.IsStatic;
end;
function TRttiIndexedProperty.GetIsReadable: boolean;
begin
Result := Assigned(FPropInfo^.GetProc);
......@@ -5592,26 +5863,42 @@ function TRttiIndexedProperty.GetIsWritable: boolean;
function TRttiIndexedProperty.GetReadMethod: TRttiMethod;
begin
//Result := FPropInfo^.GetProc;
Result := nil;
raise ENotImplemented.Create(SErrNotImplementedRtti);
if IsReadable then
begin
if FReadMethod = nil then
GetAccessors;
Result := FReadMethod;
end;
end;
function TRttiIndexedProperty.GetWriteMethod: TRttiMethod;
begin
//Result := FPropInfo^.SetProc;
Result := nil;
raise ENotImplemented.Create(SErrNotImplementedRtti);
if IsWritable then
begin
if FWriteMethod = nil then
GetAccessors;
Result := FWriteMethod;
end;
end;
function TRttiIndexedProperty.GetReadProc: CodePointer;
begin
Result := FPropInfo^.GetProc;
if (FPropInfo^.PropProcs and 3)=ptStatic then
Result := FPropInfo^.GetProc
else
{ ptVirtual }
Result := PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.GetProc))^;
end;
function TRttiIndexedProperty.GetWriteProc: CodePointer;
begin
Result := FPropInfo^.SetProc;
if (FPropInfo^.PropProcs and 3)=ptStatic then
Result := FPropInfo^.SetProc
else
{ ptVirtual }
Result := PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.SetProc))^;
end;
function TRttiIndexedProperty.GetName: string;
......@@ -5629,6 +5916,7 @@ constructor TRttiIndexedProperty.Create(AParent: TRttiType; APropInfo: PPropInfo
inherited Create(AParent);
FPropInfo := APropInfo;
end;
destructor TRttiIndexedProperty.Destroy;
var
attr: TCustomAttribute;
......@@ -5660,35 +5948,67 @@ function TRttiIndexedProperty.GetAttributes: TCustomAttributeArray;
function TRttiIndexedProperty.GetValue(aInstance: Pointer;
const aArgs: array of TValue): TValue;
var
getter: TRttiMethod;
argList: TValueArray;
I, J: Integer;
params: TRttiParameterArray;
begin
getter := ReadMethod;
if getter = nil then
if not IsReadable then
raise EPropertyError.CreateFmt(SErrCannotReadIndexedProperty, [Name]);
if getter.IsStatic or getter.IsClassMethod then
Result := getter.Invoke(TClass(aInstance), aArgs)
params := GetIndexParameters;
if Length(params) <> Length(aArgs) then
raise EInvocationError.CreateFmt(SErrIndPropArgCount, [Name, Length(params), Length(aArgs)]);
if FPropInfo^.IsStatic then
J := 0
else
Result := getter.Invoke(TObject(aInstance), aArgs);
J := 1;
argList := [];
SetLength(argList, J + Length(aArgs));
if not FPropInfo^.IsStatic then
if Parent is TRttiInstanceType then
argList[0] := TObject(aInstance)
else
argList[0] := aInstance;
for I := 0 to Length(aArgs)-1 do
begin
argList[J] := aArgs[I].Cast(TypeInfoFromRtti(params[I].ParamType));
Inc(J);
end;
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(ReadProc, argList, ccReg, FPropInfo^.PropType, FPropInfo^.IsStatic, False);
end;
procedure TRttiIndexedProperty.SetValue(aInstance: Pointer;
const aArgs: array of TValue; const aValue: TValue);
var
setter: TRttiMethod;
argsV: TValueArray;
i: Integer;
argList: TValueArray;
I, J: Integer;
params: TRttiParameterArray;
begin
setter := WriteMethod;
if setter = nil then
if not IsWritable then
raise EPropertyError.CreateFmt(SErrCannotWriteToIndexedProperty, [Name]);
SetLength(argsV, Length(aArgs) + 1);
for i := 0 to High(aArgs) do
argsV[i] := aArgs[i];
argsV[Length(aArgs)] := aValue;
if setter.IsStatic or setter.IsClassMethod then
setter.Invoke(TClass(aInstance), argsV)
params := GetIndexParameters;
if Length(params) <> Length(aArgs) then
raise EInvocationError.CreateFmt(SErrIndPropArgCount, [Name, Length(params), Length(aArgs)]);
if FPropInfo^.IsStatic then
J := 0
else
setter.Invoke(TObject(aInstance), argsV);
J := 1;
argList := [];
SetLength(argList, J + Length(aArgs) + 1);
if not FPropInfo^.IsStatic then
if Parent is TRttiInstanceType then
argList[0] := TObject(aInstance)
else
argList[0] := aInstance;
for I := 0 to Length(aArgs)-1 do
begin
argList[J] := aArgs[I].Cast(TypeInfoFromRtti(params[I].ParamType));
Inc(J);
end;
argList[J] := aValue.Cast(FPropInfo^.PropType);
{$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(WriteProc, argList, ccReg, FPropInfo^.PropType, FPropInfo^.IsStatic, False);
end;
function TRttiIndexedProperty.ToString: string;
......@@ -5821,6 +6141,11 @@ function TRttiInvokableType.ToString: string;
{ TRttiMethodType }
function TRttiMethodType.GetMethodKind: TMethodKind;
begin
Result := FTypeData^.MethodKind;
end;
function TRttiMethodType.GetParameters(aWithHidden: Boolean): TRttiParameterArray;
type
TParamInfo = record
......@@ -5966,7 +6291,7 @@ function TRttiMethodType.Invoke(const aCallable: TValue; const aArgs: array of T
{ by using a pointer we can also use this for non-class instance methods }
TValue.Make(@method^.Data, PTypeInfo(TypeInfo(Pointer)), inst);
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, method^.Code, CallingConvention, False, inst, aArgs, GetParameters(True), ReturnType);
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, method^.Code, CallingConvention, False, inst, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;
{ TRttiProcedureType }
......@@ -6051,7 +6376,7 @@ function TRttiProcedureType.Invoke(const aCallable: TValue; const aArgs: array o
if aCallable.Kind <> tkProcVar then
raise EInvocationError.CreateFmt(SErrInvokeCallableNotProc, [Name]);
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, PCodePointer(aCallable.GetReferenceToRawData)^, CallingConvention, True, TValue.Empty, aArgs, GetParameters(True), ReturnType);
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, PCodePointer(aCallable.GetReferenceToRawData)^, CallingConvention, True, TValue.Empty, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;
{ TRttiStringType }
......@@ -6195,12 +6520,11 @@ function TRttiInstanceType.GetTypeSize: integer;
var
Table: PPropDataEx;
//List : PPropListEx;
Ctx: TRttiContext;
info : PPropInfoEx;
TP : PPropInfo;
Prop : TRttiProperty;
i,j,Idx,IdxCount,Len, PropCount : Integer;
obj: TRttiObject;
i,j,Len, PropCount : Integer;
begin
Table:=PClassData(FTypeData)^.ExRTTITable;
Len:=Table^.PropCount;
......@@ -6240,12 +6564,8 @@ function TRttiInstanceType.GetTypeSize: integer;
var
Table: PPropData;
lTypeInfo: PTypeInfo;
TypeRttiType: TRttiType;
TD: PTypeData;
TP: PPropInfo;
Idx,I,Len: longint;
I,Len: longint;
Prop: TRttiProperty;
begin
......@@ -6287,12 +6607,11 @@ function TRttiInstanceType.GetDeclaredProperties: TRttiPropertyArray;
var
Table: PPropDataEx;
Ctx: TRttiContext;
info : PPropInfoEx;
TP : PPropInfo;
IProp : TRttiIndexedProperty;
i,j,Idx,IdxCount,Len, PropCount : Integer;
obj: TRttiObject;
i,Len, PropCount : Integer;
begin
Table:=PClassData(FTypeData)^.ExRTTITable;
Len:=Table^.PropCount;
......@@ -6451,6 +6770,11 @@ function TRttiRecordType.GetMethods: TRttiMethodArray;
Result:=GetDeclaredMethods;
end;
function TRttiRecordType.GetIsRecord: boolean;
begin
Result:=True;
end;
procedure TRttiRecordType.ResolveFields;
Var
Tbl : PExtendedFieldInfoTable;
......@@ -6462,10 +6786,14 @@ procedure TRttiRecordType.ResolveFields;
begin
Tbl:=Nil;
Len:=GetFieldList(FTypeInfo,Tbl);
SetLength(FDeclaredFields,Len);
FFieldsResolved:=True;
if Len=0 then
begin
if assigned(Tbl) then
FreeMem(Tbl);
exit;
end;
SetLength(FDeclaredFields,Len);
Ctx:=TRttiContext.Create(Self.FUsePublishedOnly);
try
For I:=0 to Len-1 do
......@@ -6502,33 +6830,36 @@ procedure TRttiRecordType.ResolveMethods;
i,idx,aCount : integer;
Ctx : TRttiContext;
begin
begin
FMethodsResolved:=True;
if FUsePublishedOnly then
exit;
aCount:=GetMethodList(FTypeInfo,Tbl,[]);
if aCount=0 then
begin
if assigned(Tbl) then
FreeMem(Tbl);
exit;
end;
SetLength(FDeclaredMethods,aCount);
Ctx:=TRttiContext.Create(FUsePublishedOnly);
try
aCount:=GetMethodList(FTypeInfo,Tbl,[]);
SetLength(FDeclaredMethods,aCount);
Idx:=0;
For I:=0 to aCount-1 do
begin
aData:=Tbl^[i];
if (Not FUsePublishedOnly) or (aData^.MethodVisibility=vcPublished) then
begin
Meth:=TRttiRecordMethod(Ctx.GetByHandle(aData));
if Meth=Nil then
begin
Meth:=TRttiRecordMethod.Create(Self,aData);
Meth.FUsePublishedOnly:=Self.FUsePublishedOnly;
Ctx.AddObject(Meth)
end;
Meth.FVisibility:=MemberVisibilities[aData^.MethodVisibility];
Meth.FStrictVisibility:=aData^.StrictVisibility;
FDeclaredMethods[Idx]:=Meth;
Inc(Idx);
end;
end;
begin
aData:=Tbl^[i];
Meth:=TRttiRecordMethod(Ctx.GetByHandle(aData));
if Meth=Nil then
begin
Meth:=TRttiRecordMethod.Create(Self,aData);
Meth.FUsePublishedOnly:=Self.FUsePublishedOnly;
Ctx.AddObject(Meth)
end;
Meth.FVisibility:=MemberVisibilities[aData^.MethodVisibility];
Meth.FStrictVisibility:=aData^.StrictVisibility;
FDeclaredMethods[Idx]:=Meth;
Inc(Idx);
end;
finally
if assigned(Tbl) then
FreeMem(Tbl);
......@@ -6555,7 +6886,7 @@ procedure TRttiRecordType.ResolveProperties;
PropCount:=aCount;
J := 0;
try
SetLength(FProperties,aCount);
SetLength(FDeclaredProperties,aCount);
For I:=0 to aCount-1 do
begin
Info:=List^[I];
......@@ -6563,21 +6894,18 @@ procedure TRttiRecordType.ResolveProperties;
if TP^.PropParams <> nil then
begin
Dec(PropCount);
SetLength(FProperties, PropCount);
continue;
end;
obj:=GRttiPool[FUsePublishedOnly].GetByHandle(TP);
if Assigned(obj) then
FProperties[J]:=obj as TRttiProperty
else
Prop := TRttiProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
if Prop=nil then
begin
Prop:=TRttiProperty.Create(Self, TP);
FProperties[J]:=Prop;
GRttiPool[FUsePublishedOnly].AddObject(Prop);
end;
Prop.FVisibility:=MemberVisibilities[Info^.Visibility];
Prop.FStrictVisibility:=Info^.StrictVisibility;
FDeclaredProperties[J]:=Prop;
Inc(J);
end;
finally
......@@ -6594,7 +6922,6 @@ procedure TRttiRecordType.ResolveProperties;
TP : PPropInfo;
IProp : TRttiIndexedProperty;
i,Len, PropCount : Integer;
obj: TRttiObject;
begin
List:=Nil;
......@@ -6644,11 +6971,14 @@ function TRttiRecordType.GetTypeSize: Integer;
Result:=GetTypeData(PTypeInfo(Handle))^.RecSize;
end;
function TRttiRecordType.GetFields: TRttiFieldArray;
begin
Result:=GetDeclaredFields;
end;
function TRttiRecordType.GetProperties: TRttiPropertyArray;
begin
if not FPropertiesResolved then
ResolveProperties;
Result:=FProperties;
Result:=GetDeclaredProperties;
end;
function TRttiRecordType.GetDeclaredFields: TRttiFieldArray;
......@@ -6684,6 +7014,11 @@ function TRttiRecordType.GetAttributes: TCustomAttributeArray;
Result:=inherited GetAttributes;
end;
function TRttiRecordType.GetIndexedProperties: TRttiIndexedPropertyArray;
begin
Result:=GetDeclaredIndexedProperties;
end;
{ TRttiMember }
function TRttiMember.GetVisibility: TMemberVisibility;
......@@ -6711,6 +7046,21 @@ function TRttiProperty.GetDataType: TRttiType;
Result:=GetPropertyType
end;
function TRttiProperty.GetDefault: Integer;
begin
Result := FPropInfo^.Default;
end;
function TRttiProperty.GetIndex: Integer;
begin
Result := FPropInfo^.Index;
end;
function TRttiProperty.GetIsClassProperty: boolean;
begin
result := FPropInfo^.IsStatic;
end;
function TRttiProperty.GetPropertyType: TRttiType;
var
context: TRttiContext;
......@@ -6777,6 +7127,34 @@ function TRttiProperty.GetAttributes: TCustomAttributeArray;
result := FAttributes;
end;
function TRttiProperty.GetStaticPropValue: TValue;
var
getter: CodePointer;
Args: array of TValue;
begin
case FPropInfo^.PropProcs and 3 of
ptField:
TValue.Make(PtrUInt(FPropInfo^.GetProc), FPropInfo^.PropType, Result);
ptStatic,
ptVirtual:
begin
if (FPropInfo^.PropProcs and 3)=ptStatic then
getter:=FPropInfo^.GetProc
else
getter:=PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.GetProc))^;
if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
Args := []
else
Args := [FPropInfo^.Index];
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(getter, Args, ccReg, FPropInfo^.PropType, FPropInfo^.IsStatic, False);
end;
else
raise EPropertyError.CreateFmt(SErrCannotReadClassProperty, [FPropInfo^.Name]);
end;
end;
function TRttiProperty.GetValue(Instance: pointer): TValue;
procedure ValueFromBool(value: Int64);
......@@ -6885,6 +7263,11 @@ function TRttiProperty.GetValue(Instance: pointer): TValue;
M: TMethod;
Int: IUnknown;
begin
if FPropInfo^.IsStatic then
begin
Result:= GetStaticPropValue();
exit;
end;
case FPropinfo^.PropType^.Kind of
tkSString:
begin
......@@ -6992,8 +7375,42 @@ function TRttiProperty.GetValue(Instance: pointer): TValue;
end
end;
procedure TRttiProperty.SetStaticPropValue(const AValue: TValue);
var
setter: CodePointer;
Args: array of TValue;
begin
case (FPropInfo^.PropProcs shr 2) and 3 of
ptField:
AValue.Cast(FPropInfo^.PropType).ExtractRawData(FPropInfo^.SetProc);
ptStatic,
ptVirtual:
begin
if ((FPropInfo^.PropProcs shr 2) and 3)=ptStatic then
setter:=FPropInfo^.SetProc
else
setter:=PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.SetProc))^;
if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
Args := [AValue.Cast(FPropInfo^.PropType)]
else
Args := [FPropInfo^.Index, AValue.Cast(FPropInfo^.PropType)];
{$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(setter, Args, ccReg, nil, FPropInfo^.IsStatic, False);
end;
else
raise EPropertyError.CreateFmt(SErrCannotWriteToClassProperty, [FPropInfo^.Name]);
end;
end;
procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
begin
if FPropInfo^.IsStatic then
begin
SetStaticPropValue(aValue);
exit;
end;
case FPropinfo^.PropType^.Kind of
tkSString,
tkAString:
......@@ -7013,7 +7430,7 @@ procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
tkClass:
SetObjectProp(TObject(Instance), FPropInfo, AValue.AsObject);
tkMethod:
SetMethodProp(TObject(Instance), FPropInfo, TMethod(AValue.GetReferenceToRawData^));
SetMethodProp(TObject(Instance), FPropInfo, PMethod(AValue.GetReferenceToRawData)^);
tkInterface:
SetInterfaceProp(TObject(Instance), FPropInfo, AValue.AsInterface);
tkFloat:
......@@ -7060,7 +7477,6 @@ function TRttiField.GetHandle: Pointer;
destructor TRttiField.destroy;
var
Attr : TCustomAttribute;
I : Integer;
begin
......@@ -7155,6 +7571,17 @@ function TRttiType.GetAsInstance: TRttiInstanceType;
result := TRttiInstanceType(self);
end;
function TRttiType.GetAsOrdinal: TRttiOrdinalType;
begin
Result := TRttiOrdinalType(Self);
end;
function TRttiType.GetAsRecord: TRttiRecordType;
begin
result := TRttiRecordType(self);
end;
function TRttiType.GetBaseType: TRttiType;
begin
result := nil;
......@@ -7465,7 +7892,7 @@ function TRttiType.GetMethods: TRttiMethodArray;
function TRttiType.GetMethod(const aName: String): TRttiMethod;
var
methods: specialize TArray<TRttiMethod>;
methods: TRttiMethodArray;
method: TRttiMethod;
begin
methods := GetMethods;
......@@ -7475,9 +7902,26 @@ function TRttiType.GetMethod(const aName: String): TRttiMethod;
Result := Nil;
end;
function TRttiType.GetMethod(aCodeAddress: CodePointer): TRttiMethod;
var
methods: TRttiMethodArray;
method: TRttiMethod;
begin
methods := GetMethods;
for method in methods do
if method.CodeAddress = aCodeAddress then
Exit(method);
Result := Nil;
end;
function TRttiType.ToString: RTLString;
begin
Result:=Name;
end;
function TRttiType.GetMethods(const aName: string): TRttiMethodArray;
var
methods: specialize TArray<TRttiMethod>;
methods: TRttiMethodArray;
method: TRttiMethod;
count: Integer;
begin
......@@ -7531,7 +7975,7 @@ class function TRttiContext.Create: TRttiContext;
class function TRttiContext.Create(aUsePublishedOnly: Boolean): TRttiContext;
begin
Result:=Create;
Result:=Create();
Result.UsePublishedOnly:=aUsePublishedOnly;
end;
......@@ -7895,10 +8339,10 @@ function TRttiRecordMethod.GetVirtualIndex: SmallInt;
function TRttiRecordMethod.GetParameters(aWithHidden : Boolean): TRttiParameterArray;
begin
if (Length(FParams[aWithHidden]) > 0) then
Exit(FParams[aWithHidden]);
if FHandle^.ParamCount = 0 then
Exit(Nil);
if (Length(FParams[aWithHidden]) > 0) then
Exit(FParams[aWithHidden]);
ResolveParams;
Result := FParams[aWithHidden];
end;
......@@ -7928,6 +8372,53 @@ function TRttiRecordMethod.GetIsDestructor: Boolean;
Result:=False;
end;
function TRttiRecordMethod.Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
var
inst: TValue;
I: Integer;
ResultType: PTypeInfo;
begin
if IsConstructor and aInstance.IsEmpty then
TValue.Make(nil, Parent.FTypeInfo, aInstance);
{ records cannot be non-static class methods }
if IsConstructor or not IsStatic then
begin
case aInstance.Kind of
tkPointer:
{ temporary implementation, before TValue.MakeWithoutCopy is added }
inst := aInstance;
tkRecord:
inst := aInstance;
else if IsConstructor then
raise EInvocationError.CreateFmt(SErrInvokeRecCreateSelf, [Name])
else
raise EInvocationError.CreateFmt(SErrInvokeNotStaticRecSelf, [Name]);
end;
end
else
begin
if not aInstance.IsEmpty then
raise EInvocationError.CreateFmt(SErrInvokeStaticNoSelf, [Name]);
inst := TValue.Empty;
end;
if IsConstructor then
ResultType := nil
else
ResultType := TypeInfoFromRtti(ReturnType);
Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, CodeAddress, CallingConvention, IsStatic and not IsConstructor, inst, aArgs, GetParameters(True), ResultType);
if IsConstructor then
if aInstance.Kind = tkRecord then
Result := inst
else
TValue.Make(PPointer(inst.GetReferenceToRawData)^, ReturnType.FTypeInfo, Result);
end;
{$ifndef InLazIDE}
{$if defined(CPUI386) or (defined(CPUX86_64) and defined(WIN64))}
......
packages/rtl-objpas/tests/testrunner.rtlobjpas.lpi
View file @ cb072b6b
......@@ -87,6 +87,10 @@
<Filename Value="utmathvectorbase.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="tests.rtti.attrtypes2.pp"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
......
packages/rtl-objpas/tests/testrunner.rtlobjpas.pp
View file @ cb072b6b
......@@ -55,7 +55,7 @@
utcvector,
utcquaternion
{$IFDEF HAS_MONITOR}
,utcfpmonitor
,utcfpmonitor, tests.rtti.attrtypes2
{$ENDIF}
;
......
packages/rtl-objpas/tests/tests.rtti.attrtypes2.pp 0 → 100644
View file @ cb072b6b
unit tests.rtti.attrtypes2;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
interface
uses
Classes,
SysUtils,
TypInfo,
Rtti
{$ifndef Windows},
ffi.manager
{$endif};
{$RTTI EXPLICIT
FIELDS([vcPublic])
PROPERTIES([vcPublic,vcPublished])
METHODS([vcPublic,vcPublished])}
var
ErrorCount: Integer;
type
TTestAttr2Record = record
fa:integer;
fa2:integer;
fa3:integer;
public
function Offset(arg1, arg2: Integer): Integer;
property TestIProp[i1, i2: Integer]: Integer read Offset;
constructor Create(a1, a2: Integer); overload;
constructor Create(rec: TTestAttr2Record); overload;
class function StaticFunc(d: integer; p: TPoint; r: TRect): string; static;
end;
TTestAttr2Class = class
private
class var
static_var: Integer;
class function GetStaticProp: Integer; static;
class procedure SetStaticProp(value: Integer); static;
function GetIndProp(arg1, arg2: Integer): TObject;
procedure SetIndProp(arg1, arg2: Integer; value: TObject);
public
fa, fa2:integer;
property TestIProp[i: Integer; i2: Integer]: TObject read GetIndProp write SetIndProp;
class property StaticProp: Integer read GetStaticProp write SetStaticProp;
procedure MethodForNil(arg1, arg2: TObject);
class function StaticMethod(str: string): Integer; static;
constructor Create(a1, a2: Integer);
class procedure ClassProc(var int: Integer; var str: string);
end;
TInherited2Class = class(TTestAttr2Class)
end;
implementation
uses fpcunit;
procedure Check(ACondition: boolean; const AMessage: string);
begin
TAssert.AssertTrue(AMessage,ACondition);
end;
function TTestAttr2Record.Offset(arg1, arg2: Integer): Integer;
begin
fa := fa + arg1;
fa2 := fa2 + arg2;
Result := fa + fa2;
end;
constructor TTestAttr2Record.Create(a1, a2: Integer);
begin
Check((fa = 60) and (fa2 = 80) and (fa3 = 90), 'Original TTestAttr2Record was delivered incorrectly');
fa := a1;
fa2 := a2;
end;
constructor TTestAttr2Record.Create(rec: TTestAttr2Record);
begin
fa := rec.fa;
fa2 := rec.fa2;
end;
class function TTestAttr2Record.StaticFunc(d: integer; p: TPoint; r: TRect): string;
begin
Result := 'experiment_'+d.ToString+'_'+p.X.ToString+'_'+p.Y.ToString+'_'+r.Left.ToString+'_'+r.Top.ToString+'_'+r.Right.ToString+'_'+r.Bottom.ToString;
end;
class function TTestAttr2Class.GetStaticProp: Integer;
begin
Result := static_var;
end;
class procedure TTestAttr2Class.SetStaticProp(value: Integer);
begin
static_var := Value;
end;
function TTestAttr2Class.GetIndProp(arg1, arg2: Integer): TObject;
begin
fa := arg1;
fa2 := arg2;
Result := Self;
end;
procedure TTestAttr2Class.SetIndProp(arg1, arg2: Integer; value: TObject);
begin
fa := arg1;
fa2 := arg2;
Check((arg1 = 653) and (arg2 = 796) and ((value as TTestAttr2Class).fa2 = 796),
'The setter of an indexed property is incorrectly called');
end;
procedure TTestAttr2Class.MethodForNil(arg1, arg2: TObject);
begin
Check((arg1 = nil) and (arg2 = nil), 'MethodForNil did not get only nil');
end;
class function TTestAttr2Class.StaticMethod(str: string): Integer;
begin
Check(str = 'simple string', 'The static method argument is incorrect');
Result := 7775;
end;
class procedure TTestAttr2Class.ClassProc(var int: Integer; var str: string);
begin
Check(Self.ClassName = 'TInherited2Class', 'Incorrect class transfer to Self');
Inc(int, 12);
str := str + '_addon';
end;
constructor TTestAttr2Class.Create(a1, a2: Integer);
begin
fa:=a1;
fa2:=a2;
end;
end.
packages/rtl-objpas/tests/tests.rtti.invoke.pas
View file @ cb072b6b
......@@ -14,7 +14,9 @@ interface
{$ELSE FPC}
TestFramework,
{$ENDIF FPC}
types,
sysutils, typinfo, Rtti,
tests.rtti.attrtypes2,
tests.rtti.invoketypes,
Tests.Rtti.Util;
......@@ -56,6 +58,7 @@ TTestInvokeBase = class(TTestCase)
{ TTestInvoke }
TTestInvoke = class(TTestInvokeBase)
private
published
procedure TestShortString;
procedure TestAnsiString;
......@@ -69,6 +72,10 @@ TTestInvoke = class(TTestInvokeBase)
procedure TestTObject;
procedure TestCasts;
procedure TestClassConstructor;
procedure TestInheritedClassConstructor;
procedure TestClassProperty;
procedure TestIndexedProperty;
end;
{ TTestInvokeIntfMethods }
......@@ -288,8 +295,30 @@ TTestInvokeProcVarRecs = class(TTestInvokeMethodTests)
Procedure TestInvokeConstructor;
end;
{ TTestRecordMethodInvoke }
TTestRecordMethodInvoke = class(TTestInvokeBase)
private
Fctx: TRttiContext;
recType : TRttitype;
testRec, testRec2: TTestAttr2Record;
tv_rec : TValue;
Protected
procedure SetUp; override;
procedure TearDown; override;
Published
Procedure TestCreate;
procedure TestCreate2;
procedure TestCreate3;
procedure TestCreate4;
procedure TestOffset1;
procedure TestOffset2;
procedure TestStaticFunc;
end;
implementation
{ ----------------------------------------------------------------------
Auxiliary methods to test
----------------------------------------------------------------------}
......@@ -1547,6 +1576,62 @@ procedure TTestInvoke.TestCasts;
end;
end;
procedure TTestInvoke.TestClassConstructor;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass := aclassType.GetMethod('Create').Invoke(TValue.Empty, [459, 982]).AsObject as TTestAttr2Class;
AssertTrue('Created from nothing TTestClass is incorrect', (testClass.fa = 459) and (testClass.fa2 = 982));
end;
procedure TTestInvoke.TestInheritedClassConstructor;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass := aclassType.GetMethod('Create').Invoke(TInherited2Class, [116, 904]).AsObject as TTestAttr2Class;
AssertTrue('TInheritedClass created via an ancestor constructor is incorrect',(testClass is TInherited2Class) and (testClass.fa = 116) and (testClass.fa2 = 904));
end;
procedure TTestInvoke.TestClassProperty;
var
context: TRttiContext;
aclassType: TRttiType;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
aclassType.GetProperty('StaticProp').SetValue(nil, 4539);
AssertTrue('Class property is set or got incorrectly via methods',aclassType.GetProperty('StaticProp').GetValue(nil).AsInteger = 4539);
end;
procedure TTestInvoke.TestIndexedProperty;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass:=TTestAttr2Class.Create(784,328);
aclassType.GetIndexedProperty('TestIProp').SetValue(testClass, [653, 796], testClass);
testClass := TTestAttr2Class(aclassType.GetIndexedProperty('TestIProp').GetValue(testClass, [384, 170]).AsObject);
AssertTrue('The getter of an indexed property for a class is incorrectly called', (testClass.fa = 384) and (testClass.fa2 = 170));
end;
procedure TTestInvoke.TestTObject;
procedure DoStaticInvokeTestClassCompare(
......@@ -2826,6 +2911,99 @@ procedure TTestInvokeInstanceMethods.TestInvokeConstructor;
CheckEquals('In test',P.DoTest,'Correct result when called as parent class');
end;
{ TTestRecordMethodInvoke }
procedure TTestRecordMethodInvoke.SetUp;
begin
inherited SetUp;
Fctx:=TRttiContext.Create(False);
recType:=FCtx.GetType(TypeInfo(TTestAttr2Record));
testRec:=Default(TTestAttr2Record);
testRec2:=Default(TTestAttr2Record);
tv_rec:=Default(TValue);
end;
procedure TTestRecordMethodInvoke.TearDown;
begin
inherited TearDown;
end;
procedure TTestRecordMethodInvoke.TestCreate;
begin
testRec.fa:=60;
testRec.fa2:=80;
testRec.fa3:=90;
TValue.Make(@testRec, TypeInfo(TTestAttr2Record), tv_rec);
testRec2 := TTestAttr2Record(recType.GetMethods('Create')[0].Invoke(tv_rec, [111, 222]).GetReferenceToRawData^);
AssertTrue( 'Original TTestRecord is broken', (testRec.fa = 60) and (testRec.fa2 = 80));
AssertTrue( 'New TTestRecord is incorrect', (testRec2.fa = 111) and (testRec2.fa2 = 222));
end;
procedure TTestRecordMethodInvoke.TestCreate2;
begin
testRec.fa:=60;
testRec.fa2:=80;
testRec.fa3:=90;
recType.GetMethod('Create').Invoke(@testRec, [333, 444]);
AssertTrue('Updated TTestRecord is incorrect',(testRec.fa = 333) and (testRec.fa2 = 444) and (testRec.fa3 = 90));
end;
procedure TTestRecordMethodInvoke.TestCreate3;
begin
testRec.fa:=111;
testRec.fa2:=222;
TValue.Make(@testRec, TypeInfo(TTestAttr2Record), tv_rec);
testRec := TTestAttr2Record(recType.GetMethods('Create')[1].Invoke(TValue.Empty, [tv_rec]).GetReferenceToRawData^);
AssertTrue('Created from nothing TTestRecord is incorrect', (testRec.fa = 111) and (testRec.fa2 = 222));
end;
procedure TTestRecordMethodInvoke.TestCreate4;
begin
testRec.fa:=111;
testRec.fa2:=222;
TValue.Make(@testRec, TypeInfo(TTestAttr2Record), tv_rec);
testRec := TTestAttr2Record(recType.GetMethods('Create')[1].Invoke(@testRec, [tv_rec]).GetReferenceToRawData^);
// tv_rec was modified by reference by the first constructor
AssertTrue( 'Created from nothing TTestRecord is incorrect',(testRec.fa = 111) and (testRec.fa2 = 222));
end;
procedure TTestRecordMethodInvoke.TestOffset1;
begin
testRec.fa:=111;
testRec.fa2:=222;
AssertTrue('Result of Offset in incorrect (by pointer)',recType.GetMethod('Offset').Invoke(@testRec, [12, 15]).AsInteger = 360);
AssertTrue('Offset of original TTestRecord is incorrect (by pointer)',(testRec.fa = 123) and (testRec.fa2 = 237));
end;
procedure TTestRecordMethodInvoke.TestOffset2;
begin
testRec.fa:=111;
testRec.fa2:=222;
TValue.Make(@testRec, TypeInfo(TTestAttr2Record), tv_rec);
AssertTrue('Result of Offset in incorrect (by TValue)',recType.GetMethod('Offset').Invoke(tv_rec, [12, 15]).AsInteger = 360);
end;
procedure TTestRecordMethodInvoke.TestStaticFunc;
var
pnt: TPoint;
rect: TRect;
tvp, tvr, exp: TValue;
begin
pnt := TPoint.Create(45, 89);
rect := TRect.Create(19, 28, 37, 26);
TValue.Make(@pnt, TypeInfo(TPoint), tvp);
TValue.Make(@rect, TypeInfo(TRect), tvr);
AssertEquals('Static call with string return is incorrect','experiment_460_45_89_19_28_37_26',recType.GetMethod('StaticFunc').Invoke(TValue.Empty, [460, tvp, tvr]).AsString);
end;
begin
{$ifdef fpc}
RegisterTest(TTestInvoke);
......@@ -2839,6 +3017,7 @@ procedure TTestInvokeInstanceMethods.TestInvokeConstructor;
RegisterTest(TTestInvokeTestProcRecs);
RegisterTest(TTestInvokeUntyped);
RegisterTest(TTestInvokeInstanceMethods);
RegisterTest(TTestRecordMethodInvoke);
{$else fpc}
RegisterTest(TTestInvoke.Suite);
RegisterTest(TTestInvokeIntfMethods.Suite);
......
packages/rtl-objpas/tests/tests.rtti.pas
View file @ cb072b6b
......@@ -109,6 +109,7 @@ TTestClassExtendedRTTI = class(TTestExtendedRtti)
Procedure TestProperties;
Procedure TestDeclaredMethods;
Procedure TestMethods;
Procedure TestMethodByAddress;
Procedure TestMethodsInherited;
Procedure TestPrivateFieldAttributes;
Procedure TestProtectedFieldAttributes;
......@@ -117,6 +118,8 @@ TTestClassExtendedRTTI = class(TTestExtendedRtti)
Procedure TestProtectedPropertyAttributes;
Procedure TestPublicPropertyAttributes;
Procedure TestPublishedPropertyAttributes;
procedure TestGetStaticProperty;
procedure TestSetStaticProperty;
end;
{ TTestRecordExtendedRTTI }
......@@ -135,7 +138,11 @@ TTestRecordExtendedRTTI = class(TTestExtendedRtti)
implementation
uses
Tests.Rtti.Util, {tests.rtti.exttypes, } tests.rtti.attrtypes, tests.rtti.types;
Tests.Rtti.Util,
{tests.rtti.exttypes, }
tests.rtti.attrtypes2,
tests.rtti.attrtypes,
tests.rtti.types;
......@@ -1822,6 +1829,20 @@ procedure TTestClassExtendedRTTI.TestMethods;
CheckMethod('Full declared',1, A[0],'PublicAdditionalMethod',mvPublic);
end;
procedure TTestClassExtendedRTTI.TestMethodByAddress;
var
Obj : TRttiObject;
RttiData : TRttiInstanceType absolute obj;
M1,M2 : TRttiMethod;
begin
Obj:=FCtx.GetType(TAdditionalMethodClassRTTI.ClassInfo);
M1:=RttiData.GetMethod('PublicAdditionalMethod');
AssertNotNull('have method',m1);
M2:=RttiData.GetMethod(@TAdditionalMethodClassRTTI.PublicAdditionalMethod);
AssertSame('Correct method ',M1,M2);
end;
procedure TTestClassExtendedRTTI.TestMethodsInherited;
Var
A : TRttiMethodArray;
......@@ -2057,6 +2078,31 @@ procedure TTestClassExtendedRTTI.TestPublishedPropertyAttributes;
AssertEquals('Attribute value ',5,M3.Int);
end;
procedure TTestClassExtendedRTTI.TestGetStaticProperty;
var
Obj : TRttiObject;
RttiData : TRttiInstanceType absolute obj;
Prop : TRttiProperty;
begin
Obj:=FCtx.GetType(TypeInfo(TTestAttr2Class));
TTestAttr2Class.StaticProp:=4539;
Prop:=rttiData.GetProperty('StaticProp');
AssertEquals('Class property is set or got incorrectly via methods', 4539, Prop.GetValue(nil).AsInteger);
end;
procedure TTestClassExtendedRTTI.TestSetStaticProperty;
var
Obj : TRttiObject;
RttiData : TRttiInstanceType absolute obj;
Prop : TRttiProperty;
begin
Obj:=FCtx.GetType(TypeInfo(TTestAttr2Class));
Prop:=rttiData.GetProperty('StaticProp');
// Write
Prop.SetValue(nil, 4539);
AssertEquals('Property correctly set',4539,TTestAttr2Class.StaticProp);
end;
{ TTestRecordExtendedRTTI }
......
packages/rtl-objpas/tests/tests.rtti.value.pas
View file @ cb072b6b
......@@ -17,6 +17,7 @@ interface
procedure TestReferenceRawDataEmpty;
procedure TestIsManaged;
procedure TestCasts;
procedure TestAssignPointer;
end;
TTestValueSimple = Class(TTestCase)
......@@ -1959,7 +1960,14 @@ procedure TTestValueGeneral.TestCasts;
.{$ifdef fpc}specialize{$endif} Cast<AnsiString>
.{$ifdef fpc}specialize{$endif} AsType<AnsiString>, 'TValue.From<shortring>.Cast<AnsiString> failed');
end;
procedure TTestValueGeneral.TestAssignPointer;
var
V : TValue;
begin
V:=Pointer(Nil);
AssertSame('Correct type info', TypeInfo(Pointer),V.TypeInfo);
end;
procedure TTestValueGeneral.TestReferenceRawData;
var
......
rtl/objpas/classes/classesh.inc
View file @ cb072b6b
......@@ -1048,8 +1048,10 @@ TStrings = class(TPersistent)
procedure SaveToStream(Stream: TStream; IgnoreEncoding : Boolean); overload;
procedure SaveToStream(Stream: TStream; AEncoding: TEncoding); overload; virtual;
function Shift : String;
Procedure Slice(fromIndex: integer; aList : TStrings);
Function Slice(fromIndex: integer) : TStrings;
Procedure Slice(fromIndex: integer; aList : TStrings); overload;
Procedure Slice(fromIndex, toIndex: integer; aList : TStrings); overload;
Function Slice(fromIndex: integer) : TStrings; overload;
Function Slice(fromIndex, toIndex: integer) : TStrings; overload;
procedure SetText(TheText: PChar); virtual;
property AlwaysQuote: Boolean read FAlwaysQuote write FAlwaysQuote;
property Capacity: Integer read GetCapacity write SetCapacity;
......
rtl/objpas/classes/stringl.inc
View file @ cb072b6b
......@@ -430,28 +430,42 @@ function TStrings.Reduce(aReduceMethod: TStringsReduceMethod; const startingValu
end;
Procedure TStrings.Slice(fromIndex: integer; aList : TStrings);
Procedure TStrings.Slice(fromIndex, toIndex: integer; aList : TStrings);
var
i: integer;
begin
for i:=fromIndex to Count-1 do
for i:=fromIndex to toIndex do
aList.Add(Self[i]);
end;
Function TStrings.Slice(fromIndex: integer) : TStrings;
Procedure TStrings.Slice(fromIndex: integer; aList : TStrings);
begin
Slice(fromIndex,Count-1,aList);
end;
Function TStrings.Slice(fromIndex, toIndex: integer) : TStrings;
begin
Result:=TStringsClass(Self.ClassType).Create;
try
Slice(FromIndex,Result);
Slice(FromIndex, toIndex,Result);
except
FreeAndNil(Result);
Raise;
end;
end;
Function TStrings.Slice(fromIndex: integer) : TStrings;
begin
Result := Slice(fromIndex,Count-1);
end;
function TStrings.GetName(Index: Integer): string;
Var
......
tests/webtbf/tw41068.pp 0 → 100644
View file @ cb072b6b
program sl;
{$mode objfpc}
{$assertions on}
{$WARN 5024 off : Parameter "$1" not used}
uses
SysUtils, Classes;
var
Source, DestP, DestF: TStringList;
i, StartIdx, EndIdx: Integer;
begin
{$if declared(TMyStringsHelper)}
writeln('Using TMyStringsHelper class');
{$endif}
Source := TStringList.Create;
DestP := TStringList.Create;
try
for i := 0 to 19 do Source.Add(i.ToString);
StartIDx := 7;
EndIdx := 16;
Source.Slice(StartIdx, EndIdx, DestP);
TStrings(DestF) := Source.Slice(StartIdx, EndIdx);
Assert(DestP.Count = DestF.Count,Format('DestP.Count (%d) <> DestF.Count (%d)',[DestP.Count, DestF.Count]));
Assert(DestP.Count = EndIdx-StartIdx+1, Format('Dest.Count=%d, Expected: %d (%d-%d+1)',[DestP.Count,StartIdx-EndIdx+1,StartIdx,EndIdx]));
writeln('Dest.Count=',DestP.Count, ' [Ok]');
for i := 0 to DestP.Count-1 do
begin
Assert(DestP[i]=DestF[i],Format('Dest[%d] (%s) <> DestF[%d] (%s)',[i,DestP[i],i,DestF[i]]));
Assert((DestP[i] = (i + StartIdx).ToString),Format('Dest[%d]: Found %s, Expected: %s',[i,DestP[i],(i + StartIdx).ToString]));
writeln(i:2,': ',DestP[i]);
end;
finally
Source.Free;
DestP.Free;
DestF.Free;
end;
writeln('TStrings.Slice test: Ok');
end.