freepascal.compiler/packages/rtl-objpas/src/inc/rtti.pp

{
  This file is part of the Free Pascal run time library.
  Copyright (C) 2013 Joost van der Sluis [email protected]
  member of the Free Pascal development team.

  Extended RTTI compatibility unit

  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.
}
{$IFNDEF FPC_DOTTEDUNITS}
unit Rtti;
{$ENDIF}

{$IFDEF CPUWASM}
// Thunk class could also be used for other CPUS, but it is mandatory for wasm
{$define use_thunk_class}
{$define use_invoke_helper}
{$ENDIF}

{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
{$modeswitch functionreferences}
{$goto on}
{$Assertions on}

{$WARN 4055 off : Conversion between ordinals and pointers is not portable}
interface

{$IFDEF FPC_DOTTEDUNITS}
uses
  System.Types,
  System.Classes,
  System.SysUtils,
  System.Math,
  System.TypInfo;
{$ELSE FPC_DOTTEDUNITS}
uses
  Types,
  Classes,
  SysUtils,
  Math,
  typinfo;
{$ENDIF FPC_DOTTEDUNITS}

Const
{$IFDEF FPC_DOTTEDUNITS}
  DefaultUsePublishedOnly = False;
{$ELSE}
  DefaultUsePublishedOnly = True;
{$ENDIF}

Var
  GlobalUsePublishedOnly : Boolean = DefaultUsePublishedOnly;

type

  TRttiObject = class;
  TRttiType = class;
  TRttiMethod = class;
  TRttiIndexedProperty = class;
  TRttiField = Class;
  TRttiProperty = class;
  TRttiOrdinalType = class;
  TRttiInstanceType = class;
  TRttiRecordType = class;

  TCustomAttributeClass = class of TCustomAttribute;
  TRttiClass = class of TRttiObject;

  TCustomAttributeArray = specialize TArray<TCustomAttribute>;

  TFunctionCallCallback = class
  protected
    function GetCodeAddress: CodePointer; virtual; abstract;
  public
    property CodeAddress: CodePointer read GetCodeAddress;
  end;

  TFunctionCallFlag = (
    fcfStatic
  );
  TFunctionCallFlags = set of TFunctionCallFlag;

  TFunctionCallParameterInfo = record
    ParamType: PTypeInfo;
    ParamFlags: TParamFlags;
    ParaLocs: PParameterLocations;
  end;

  IValueData = interface
  ['{1338B2F3-2C21-4798-A641-CA2BC5BF2396}']
    procedure ExtractRawData(ABuffer: pointer);
    procedure ExtractRawDataNoCopy(ABuffer: pointer);
    function GetDataSize: SizeInt;
    function GetReferenceToRawData: pointer;
  end;

  TValueData = record
    FTypeInfo: PTypeInfo;
    FValueData: IValueData;
    case integer of
      0:  (FAsUByte: Byte);
      1:  (FAsUWord: Word);
      2:  (FAsULong: LongWord);
      3:  (FAsObject: Pointer);
      4:  (FAsClass: TClass);
      5:  (FAsSByte: Shortint);
      6:  (FAsSWord: Smallint);
      7:  (FAsSLong: LongInt);
      8:  (FAsSingle: Single);
      9:  (FAsDouble: Double);
      10: (FAsExtended: Extended);
      11: (FAsComp: Comp);
      12: (FAsCurr: Currency);
      13: (FAsUInt64: QWord);
      14: (FAsSInt64: Int64);
      15: (FAsMethod: TMethod);
      16: (FAsPointer: Pointer);
      { FPC addition for open arrays }
      17: (FArrLength: SizeInt; FElSize: SizeInt);
  end;

  { TValue }

  TValue = record
  private
    FData: TValueData;
    function GetDataSize: SizeInt;
    function GetTypeDataProp: PTypeData; inline;
    function GetTypeInfo: PTypeInfo; inline;
    function GetTypeKind: TTypeKind; // inline;
    function GetIsEmpty: boolean; inline;
    procedure Init; inline;
    // typecast
    procedure CastAssign(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastToVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // from integer
    procedure CastIntegerToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastIntegerToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastIntegerToInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastIntegerToQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // from Ansichar
    procedure CastCharToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromAnsiChar(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From WideChar
    procedure CastWCharToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromWideChar(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From Enumerated
    procedure CastEnumToEnum(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromEnum(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From float
    procedure CastFloatToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFloatToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From string
    procedure CastStringToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From class
    procedure CastClassRefToClassRef(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastClassToClass(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastClassToInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromClass(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From Int64
    procedure CastInt64ToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastInt64ToQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastInt64ToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From QWord
    procedure CastQWordToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastQWordToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastQWordToInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From Interface
    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);
    procedure CastFromSet(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // From variant
    procedure CastVariantToVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure CastFromVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    procedure DoCastFromVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
    // Cast entry
    procedure CastFromType(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);
  public
    class function Empty: TValue; static;
    class procedure Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); static;
    class procedure Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result: TValue); static; inline;
    { 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;
    generic class procedure Make<T>(const AValue: T; out Result: TValue); static; inline;
    generic class function From<T>(constref aValue: T): TValue; static; inline;
    { Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! }
    generic class function FromOpenArray<T>(constref aValue: array of T): TValue; static; inline;
    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;
    class function FromVariant(const aValue : Variant) : TValue; static;
    class function Equals(const Left, Right: array of TValue): Boolean; static;
    class function SameValue(const Left, Right: TValue): Boolean; static;
    function IsArray: boolean; inline;
    function IsOpenArray: Boolean; inline;
    // Maybe we need to check these now that Cast<> is implemented.
    // OTOH they will probablu be faster.
    function AsString: string; inline;
    function AsUnicodeString: UnicodeString;
    function AsAnsiString: AnsiString;
    function AsExtended: Extended;
    function IsClass: boolean; inline;
    function AsClass: TClass;
    function IsObject: boolean; inline;
    function AsObject: TObject;
    function IsOrdinal: boolean; inline;
    function AsOrdinal: Int64;
    function AsBoolean: boolean;
    function IsNumeric : boolean;
    function IsSingle : boolean; inline;
    function IsCurrency : boolean; inline;
    function IsDouble : boolean; inline;
    function IsExtended : boolean; inline;
    Function IsString : boolean; inline;
    Function IsPointer : boolean; inline;
    Function IsVariant : boolean; inline;
    function AsCurrency: Currency;
    function AsSingle : Single;
    function AsDateTime : TDateTime;
    function IsDateTime: boolean; inline;
    function AsDouble : Double;
    function AsInteger: Integer;
    function AsError: HRESULT;
    function AsChar: AnsiChar; inline;
    function AsAnsiChar: AnsiChar;
    function AsWideChar: WideChar;
    function AsInt64: Int64;
    function AsUInt64: QWord;
    function AsInterface: IInterface;
    function AsPointer : Pointer;
    function AsVariant : Variant;
    function ToString: String; overload;
    function ToString(aSettings: TFormatSettings): String; overload;
    function GetArrayLength: SizeInt;
    function GetArrayElement(AIndex: SizeInt): TValue;
    procedure SetArrayElement(AIndex: SizeInt; constref AValue: TValue);
    function IsType(aTypeInfo: PTypeInfo): boolean; inline;
    function IsType(aTypeInfo: PTypeInfo; const EmptyAsAnyType: Boolean) : Boolean;
    function IsInstanceOf(aClass : TClass): boolean; inline;
    function TryCast(aTypeInfo: PTypeInfo; out aResult: TValue; const aEmptyAsAnyType: Boolean = True): Boolean;
    function Cast(aTypeInfo: PTypeInfo; const aEmptyAsAnyType: Boolean = True): TValue; overload;
    generic function Cast<T>(const aEmptyAsAnyType: Boolean = True): TValue; overload;
    generic function IsType<T>: Boolean; inline; overload;
    generic function IsType<T>(const EmptyAsAnyType: Boolean) : Boolean; inline; overload;
    generic function AsType<T>(const aEmptyAsAnyType: Boolean = True): T;
    generic function TryAsType<T>(out aResult: T; const aEmptyAsAnyType: Boolean = True): Boolean; inline;
    function TryAsOrdinal(out AResult: int64): boolean;
    function GetReferenceToRawData: Pointer;
    procedure ExtractRawData(ABuffer: Pointer);
    procedure ExtractRawDataNoCopy(ABuffer: Pointer);
    class operator := (const AValue: ShortString): TValue; inline;
    class operator := (const AValue: AnsiString): TValue; inline;
    class operator := (const AValue: UnicodeString): TValue; inline;
    class operator := (const AValue: WideString): TValue; inline;
    class operator := (AValue: LongInt): TValue; inline;
    class operator := (AValue: SmallInt): TValue; inline;
    class operator := (AValue: ShortInt): TValue; inline;
    class operator := (AValue: Byte): TValue; inline;
    class operator := (AValue: Word): TValue; inline;
    class operator := (AValue: Cardinal): TValue; inline;
    class operator := (AValue: Single): TValue; inline;
    class operator := (AValue: Double): TValue; inline;
{$ifdef FPC_HAS_TYPE_EXTENDED}
    class operator := (AValue: Extended): TValue; inline;
{$endif}
    class operator := (AValue: Currency): TValue; inline;
    class operator := (AValue: Comp): TValue; inline;
    class operator := (AValue: Int64): TValue; inline;
    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;
    class operator := (AValue: TDateTime): TValue; inline;
    class operator := (AValue: TDate): TValue; inline;
    class operator := (AValue: system.TTime): TValue; inline;
    class operator = (const ALeft, ARight: TValue): Boolean; inline;
    class operator <> (const ALeft, ARight: TValue): Boolean; inline;
    property DataSize: SizeInt read GetDataSize;
    property Kind: TTypeKind read GetTypeKind;
    property TypeData: PTypeData read GetTypeDataProp;
    property TypeInfo: PTypeInfo read GetTypeInfo;
    property IsEmpty: boolean read GetIsEmpty;
  end;
  PValue = ^TValue;
  TValueArray = specialize TArray<TValue>;

  { TRttiContext }

  TRttiContext = record
  private
    FPoolIndex: int32; { < 0: empty. >= 0: uses boolean(FPoolIndex)-th pool. }
    FUsePublishedOnly : Boolean;
    class var FKeepContextCounter: integer;
    class operator Initialize(var self: TRttiContext);
    class operator Finalize(var self: TRttiContext);
    class operator Copy(constref b: TRttiContext; var self: TRttiContext);
    class operator AddRef(var self: TRttiContext);
    function GetByHandle(AHandle: Pointer): TRttiObject;
    procedure AddObject(AObject: TRttiObject);
    procedure SetUsePublishedOnly(Value: Boolean);
  public
    class function Create: TRttiContext; static;
    class function Create(aUsePublishedOnly : Boolean): TRttiContext; static;
    class procedure DropContext; static;
    class procedure KeepContext; static;
    procedure Free;
    function GetType(ATypeInfo: PTypeInfo): TRttiType;
    function GetType(AClass: TClass): TRttiType;
    property UsePublishedOnly: Boolean read FUsePublishedOnly write SetUsePublishedOnly;
    //function GetTypes: specialize TArray<TRttiType>;
  end;

  { TRttiObject }

  TRttiObject = class abstract
  Private
    FUsePublishedOnly : Boolean;
  protected
    function GetHandle: Pointer; virtual; abstract;
  public
    function HasAttribute(aClass: TCustomAttributeClass): Boolean;
    function GetAttribute(aClass: TCustomAttributeClass): TCustomAttribute;
    generic function GetAttribute<T>: T;
    generic function HasAttribute<T>: Boolean;
    function GetAttributes: TCustomAttributeArray; virtual; abstract;
    property Handle: Pointer read GetHandle;
  end;

  { TRttiNamedObject }

  TRttiNamedObject = class(TRttiObject)
  protected
    function GetName: string; virtual;
  public
    function HasName(const aName: string): Boolean;
    property Name: string read GetName;
  end;

  { TRttiType }
  TRttiFieldArray = specialize TArray<TRttiField>;
  TRttiPropertyArray = specialize TArray<TRttiProperty>;
  TRttiMethodArray = specialize TArray<TRttiMethod>;
  TRttiIndexedPropertyArray = specialize TArray<TRttiIndexedProperty>;

  TRttiType = class(TRttiNamedObject)
  private
    FTypeInfo: PTypeInfo;
    FAttributesResolved: boolean;
    FAttributes: TCustomAttributeArray;
    FMethods: TRttiMethodArray;
    FFields : TRttiFieldArray;
    FProperties : TRttiPropertyArray;
    FIndexedProperties : TRttiIndexedPropertyArray;
    function GetAsInstance: TRttiInstanceType;
    function GetAsOrdinal: TRttiOrdinalType;
    function GetAsRecord: TRttiRecordType;
  protected
    FTypeData: PTypeData;
    function GetName: string; override;
    function GetHandle: Pointer; override;
    function GetIsInstance: boolean; virtual;
    function GetIsManaged: boolean; virtual;
    function GetIsOrdinal: boolean; virtual;
    function GetIsRecord: boolean; virtual;
    function GetIsSet: boolean; virtual;
    function GetTypeKind: TTypeKind; virtual;
    function GetTypeSize: integer; virtual;
    function GetBaseType: TRttiType; virtual;
  public
    constructor Create(ATypeInfo : PTypeInfo);
    constructor Create(ATypeInfo : PTypeInfo; aUsePublishedOnly : Boolean);
    destructor Destroy; override;
    function GetAttributes: TCustomAttributeArray; override;
    function GetFields: TRttiFieldArray; virtual;
    function GetField(const aName: String): TRttiField; virtual;
    function GetDeclaredMethods: TRttiMethodArray; virtual;
    function GetDeclaredFields: TRttiFieldArray; virtual;
    function GetDeclaredProperties: TRttiPropertyArray; virtual;
    function GetDeclaredIndexedProperties: TRttiIndexedPropertyArray; virtual;
    function GetProperty(const AName: string): TRttiProperty; virtual;  
    function GetProperties: TRttiPropertyArray; virtual;
    function GetIndexedProperty(const AName: string): TRttiIndexedProperty; virtual;
    function GetIndexedProperties: TRttiIndexedPropertyArray; virtual;
    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;
    property IsRecord: boolean read GetIsRecord;
    property IsSet: boolean read GetIsSet;
    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;

  { TRttiFloatType }

  TRttiFloatType = class(TRttiType)
  private
    function GetFloatType: TFloatType; inline;
  protected
    function GetTypeSize: integer; override;
  public
    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;
    property MinValue: LongInt read GetMinValue;
    property MaxValue: LongInt read GetMaxValue;
  end;
  
  { TRttiEnumerationType }

  TRttiEnumerationType = class(TRttiOrdinalType)
  private
    function GetUnderlyingType: TRttiType;
  public
    function GetNames: TStringDynArray;
    generic class function GetName<T{: enum}>(AValue: T): string; reintroduce; static;
    generic class function GetValue<T{: enum}>(const AName: string): T; static;
    property UnderlyingType: TRttiType read GetUnderlyingType;
  end;
  

  TRttiInt64Type = class(TRttiType)
  private
    function GetMaxValue: Int64; inline;
    function GetMinValue: Int64; inline;
    function GetUnsigned: Boolean; inline;
  protected
    function GetTypeSize: integer; override;
  public
    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
    property Unsigned: Boolean read GetUnsigned;
  end;

  TRttiStringKind = (skShortString, skAnsiString, skWideString, skUnicodeString);

  { TRttiStringType }

  TRttiStringType = class(TRttiType)
  private
    function GetStringKind: TRttiStringKind;
  public
    property StringKind: TRttiStringKind read GetStringKind;
  end;

  TRttiAnsiStringType = class(TRttiStringType)
  private
    function GetCodePage: Word;
  public
    property CodePage: Word read GetCodePage;
  end;

  TRttiPointerType = class(TRttiType)
  private
    function GetReferredType: TRttiType;
  public
    property ReferredType: TRttiType read GetReferredType;
  end;

  TRttiArrayType = class(TRttiType)
  private
    function GetDimensionCount: SizeUInt; inline;
    function GetDimension(aIndex: SizeInt): TRttiType; inline;
    function GetElementType: TRttiType; inline;
    function GetTotalElementCount: SizeInt; inline;
  public
    property DimensionCount: SizeUInt read GetDimensionCount;
    property Dimensions[Index: SizeInt]: TRttiType read GetDimension;
    property ElementType: TRttiType read GetElementType;
    property TotalElementCount: SizeInt read GetTotalElementCount;
  end;

  TRttiDynamicArrayType = class(TRttiType)
  private
    function GetDeclaringUnitName: String; inline;
    function GetElementSize: SizeUInt; inline;
    function GetElementType: TRttiType; inline;
    function GetOleAutoVarType: TVarType; inline;
  public
    property DeclaringUnitName: String read GetDeclaringUnitName;
    property ElementSize: SizeUInt read GetElementSize;
    property ElementType: TRttiType read GetElementType;
    property OleAutoVarType: TVarType read GetOleAutoVarType;
  end;

  { TRttiMember }

  TMemberVisibility=(mvPrivate, mvProtected, mvPublic, mvPublished);

  TRttiMember = class(TRttiNamedObject)
  private
    FParent: TRttiType;
    FVisibility : TMemberVisibility;
    FStrictVisibility : Boolean;
    function GetVisibility: TMemberVisibility; virtual;
    function GetStrictVisibility: Boolean; virtual;
  public
    constructor Create(AParent: TRttiType);
    property Visibility: TMemberVisibility read GetVisibility;
    Property StrictVisibility: Boolean Read GetStrictVisibility;
    property Parent: TRttiType read FParent;
  end;

  TRttiDataMember = class abstract(TRttiMember)
  private
    function GetDataType: TRttiType; virtual; abstract;
    function GetIsReadable: Boolean; virtual; abstract;
    function GetIsWritable: Boolean; virtual; abstract;
  public
    function GetValue(Instance: Pointer): TValue; virtual; abstract;
    procedure SetValue(Instance: Pointer; const AValue: TValue); virtual; abstract;
    property DataType: TRttiType read GetDataType;
    property IsReadable: Boolean read GetIsReadable;
    property IsWritable: Boolean read GetIsWritable;
  end;

  { TRttiProperty }

  TRttiProperty = class(TRttiDataMember)
  private
    FPropInfo: PPropInfo;
    FAttributesResolved: boolean;
    FAttributes: TCustomAttributeArray;
    function GetPropertyType: TRttiType;
    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
    constructor Create(AParent: TRttiType; APropInfo: PPropInfo);
    destructor Destroy; override;
    function GetAttributes: TCustomAttributeArray; override;
    function GetValue(Instance: pointer): TValue;  override;
    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;

  { TRttiField }

  TRttiField = class(TRttiDataMember)
  private
    FFieldType: TRttiType;
    FOffset: Integer;
    FName : String;
    FHandle : PExtendedFieldEntry;
    FAttributes: TCustomAttributeArray;
    FAttributesResolved : Boolean;
    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;
//    constructor Create(AParent: TRttiObject; var P: PByte); override;
  public
    destructor destroy; override;
    function GetValue(aInstance: Pointer): TValue; override;
    procedure SetValue(aInstance: Pointer; const aValue: TValue); override;
    function ToString: string; override;
    property FieldType: TRttiType read FFieldType;
    property Offset: Integer read FOffset;
  end;

(*
  TRttiManagedField = class(TRttiObject)
  private
    function GetFieldOffset: Integer;
    function GetDataType: TRttiType;
//    constructor Create(AParent: TRttiObject; var P: PByte); override;
  public
    property FieldType: TRttiType read GetDataType;
    property FieldOffset: Integer read GetFieldOffset;
  end;
*)

  TRttiParameter = class(TRttiNamedObject)
  private
    FString: String;
  protected
    function GetParamType: TRttiType; virtual; abstract;
    function GetFlags: TParamFlags; virtual; abstract;
  public
    property ParamType: TRttiType read GetParamType;
    property Flags: TParamFlags read GetFlags;
    function ToString: String; override;
  end;
  TRttiParameterArray = specialize TArray<TRttiParameter>;

  TMethodImplementationCallback = reference to procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
  TMethodImplementationCallbackMethod = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue) of object; deprecated 'Use TMethodImplementationCallback';
  TMethodImplementationCallbackProc = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue); deprecated 'Use TMethodImplementationCallback';
  TFunctionCallParameterInfoArray = specialize TArray<TFunctionCallParameterInfo>;
  TPointerArray = specialize TArray<Pointer>;

  TMethodImplementation = class
  private
    fLowLevelCallback: TFunctionCallCallback;
    fCallback: TMethodImplementationCallback;
    fArgs: specialize TArray<TFunctionCallParameterInfo>;
    fArgLen: SizeInt;
    fRefArgs: specialize TArray<SizeInt>;
    fFlags: TFunctionCallFlags;
    fResult: PTypeInfo;
    fCC: TCallConv;
    procedure InitArgs;
    procedure HandleCallback(const aArgs: TPointerArray; aResult: Pointer; aContext: Pointer);
    constructor Create(aCC: TCallConv; aArgs: TFunctionCallParameterInfoArray; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallback);
  Protected
    function GetCodeAddress: CodePointer; inline;
  public
    constructor Create;
    destructor Destroy; override;
    property CodeAddress: CodePointer read GetCodeAddress;
  end;

  TRttiInvokableType = class(TRttiType)
  protected
    function GetParameters(aWithHidden: Boolean): TRttiParameterArray; virtual; abstract;
    function GetCallingConvention: TCallConv; virtual; abstract;
    function GetReturnType: TRttiType; virtual; abstract;
    function GetFlags: TFunctionCallFlags; virtual; abstract;
  public type
    TCallback = reference to procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
    TCallbackMethod = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue) of object; deprecated 'Use TRttiInvokableType.TCallback';
    TCallbackProc = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue); deprecated 'Use TRttiInvokableType.TCallback';
  public
    function GetParameters: TRttiParameterArray; inline;
    property CallingConvention: TCallConv read GetCallingConvention;
    property ReturnType: TRttiType read GetReturnType;
    function Invoke(const aProcOrMeth: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
    function CreateImplementation(aCallback: TCallback): TMethodImplementation;
    function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
    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;
    function GetReturnType: TRttiType; override;
    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;

  TRttiProcedureType = class(TRttiInvokableType)
  private
    FParams, FParamsAll: TRttiParameterArray;
  protected
    function GetParameters(aWithHidden: Boolean): TRttiParameterArray; override;
    function GetCallingConvention: TCallConv; override;
    function GetReturnType: TRttiType; override;
    function GetFlags: TFunctionCallFlags; override;
  public
    function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
  end;

  TDispatchKind = (
    dkStatic,
    dkVtable,
    dkDynamic,
    dkMessage,
    dkInterface,
    { the following are FPC-only and will be moved should Delphi add more }
    dkMessageString
  );

  TRttiMethod = class(TRttiMember)
  private
    FString: String;
    function GetFlags: TFunctionCallFlags;
  protected
{$IFDEF USE_INVOKE_HELPER}
    function HandleInvokeHelper(aParentTypeInfo : PTypeInfo; aInstance : Pointer; const aArgs : array of TValue): TValue;
{$ENDIF}
    function GetCallingConvention: TCallConv; virtual; abstract;
    function GetCodeAddress: CodePointer; virtual; abstract;
    function GetDispatchKind: TDispatchKind; virtual; abstract;
    function GetHasExtendedInfo: Boolean; virtual;
    function GetIsClassMethod: Boolean; virtual; abstract;
    function GetIsConstructor: Boolean; virtual; abstract;
    function GetIsDestructor: Boolean; virtual; abstract;
    function GetIsStatic: Boolean; virtual; abstract;
    function GetMethodKind: TMethodKind; virtual; abstract;
    function GetReturnType: TRttiType; virtual; abstract;
    function GetVirtualIndex: SmallInt; virtual; abstract;
    function GetParameters(aWithHidden: Boolean): TRttiParameterArray; virtual; abstract;
  public
    property CallingConvention: TCallConv read GetCallingConvention;
    property CodeAddress: CodePointer read GetCodeAddress;
    property DispatchKind: TDispatchKind read GetDispatchKind;
    property HasExtendedInfo: Boolean read GetHasExtendedInfo;
    property IsClassMethod: Boolean read GetIsClassMethod;
    property IsConstructor: Boolean read GetIsConstructor;
    property IsDestructor: Boolean read GetIsDestructor;
    property IsStatic: Boolean read GetIsStatic;
    property MethodKind: TMethodKind read GetMethodKind;
    property ReturnType: TRttiType read GetReturnType;
    property VirtualIndex: SmallInt read GetVirtualIndex;
    function ToString: String; override;
    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; virtual; abstract;
    function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
  end;

  TRttiIndexedProperty = class(TRttiMember)
  private
    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;
    function GetReadMethod: TRttiMethod; virtual;
    function GetWriteMethod: TRttiMethod; virtual;
    function GetReadProc: CodePointer; virtual;
    function GetWriteProc: CodePointer; virtual;
    procedure ResolveIndexParams;
  protected
    function GetName: string; override;
    function GetHandle: Pointer; override;
  public
    constructor Create(AParent: TRttiType; APropInfo: PPropInfo);
    destructor Destroy; override;
    function GetAttributes: TCustomAttributeArray; override;
    function GetValue(aInstance: Pointer; const aArgs: array of TValue): TValue;
    procedure SetValue(aInstance: Pointer; const aArgs: array of TValue;
      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;
    property ReadMethod: TRttiMethod read GetReadMethod;
    property WriteMethod: TRttiMethod read GetWriteMethod;
    property ReadProc: CodePointer read GetReadProc;
    property WriteProc: CodePointer read GetWriteProc;
  end;

  TRttiStructuredType = class(TRttiType)

  end;

  TInterfaceType = (
    itRefCounted, { aka COM interface }
    itRaw         { aka CORBA interface }
  );

  TRttiInterfaceType = class(TRttiType)
  private
    fDeclaredMethods: TRttiMethodArray;
  protected
    function IntfMethodCount: Word;
    function MethodTable: PIntfMethodTable; virtual; abstract;
    function GetBaseType: TRttiType; override;
    function GetIntfBaseType: TRttiInterfaceType; virtual; abstract;
    function GetDeclaringUnitName: String; virtual; abstract;
    function GetGUID: TGUID; virtual; abstract;
    function GetGUIDStr: String; virtual;
    function GetIntfFlags: TIntfFlags; virtual; abstract;
    function GetIntfType: TInterfaceType; virtual; abstract;
  public
    property BaseType: TRttiInterfaceType read GetIntfBaseType;
    property DeclaringUnitName: String read GetDeclaringUnitName;
    property GUID: TGUID read GetGUID;
    property GUIDStr: String read GetGUIDStr;
    property IntfFlags: TIntfFlags read GetIntfFlags;
    property IntfType: TInterfaceType read GetIntfType;
    function GetDeclaredMethods: TRttiMethodArray; override;
  end;

  { TRttiInstanceType }

  TRttiInstanceType = class(TRttiStructuredType)
  private
    FFieldsResolved: Boolean;
    FMethodsResolved : Boolean;
    FPropertiesResolved: Boolean;
    FIndexedPropertiesResolved: Boolean;
    FDeclaredFields: TRttiFieldArray;
    FDeclaredMethods : TRttiMethodArray;
    FDeclaredProperties : TRttiPropertyArray;
    FDeclaredIndexedProperties : TRttiIndexedPropertyArray;
    function GetDeclaringUnitName: string;
    function GetMetaClassType: TClass;
    procedure ResolveClassicDeclaredProperties;
    procedure ResolveExtendedDeclaredProperties;
    procedure ResolveDeclaredIndexedProperties;
    procedure ResolveDeclaredFields;
    procedure ResolveDeclaredMethods;
  protected
    function GetIsInstance: boolean; override;
    function GetTypeSize: integer; override;
    function GetBaseType: TRttiType; override;
  public
    function GetDeclaredFields: TRttiFieldArray; override;
    function GetDeclaredMethods: TRttiMethodArray; override;
    function GetDeclaredProperties: TRttiPropertyArray; override;
    function GetDeclaredIndexedProperties: TRttiIndexedPropertyArray; override;
    property MetaClassType: TClass read GetMetaClassType;
    property DeclaringUnitName: string read GetDeclaringUnitName;
  end;

  { TRttiRecordType }

  TRttiRecordType = class(TRttiStructuredType)
  private
    FMethOfs: PByte;
//    function GetManagedFields: TRttiManagedFieldArray;
    FFieldsResolved: Boolean;   
    FMethodsResolved : Boolean; 
    FPropertiesResolved: Boolean;      
    FIndexedPropertiesResolved: Boolean;
    FDeclaredFields: TRttiFieldArray;
    FDeclaredMethods : TRttiMethodArray;  
    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; override;
    function GetIndexedProperties: TRttiIndexedPropertyArray; override;
//    property ManagedFields: TRttiManagedFieldArray read GetManagedFields;
  end;


  TVirtualInterfaceInvokeEvent = procedure(aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue) of object;

  TVirtualInterface = class(TInterfacedObject, IInterface)
  private
    // Add fields before
    fGUID: TGUID;
    fOnInvoke: TVirtualInterfaceInvokeEvent;
    fContext: TRttiContext;
{$IFNDEF USE_THUNK_CLASS}
    fThunks: array[0..2] of CodePointer;
    fImpls: array of TMethodImplementation;
    fVmt: PCodePointer;
{$ELSE}
    IThunk : IInterface;
    FIntfRTTI : trttitype;
    FThunk : TInterfaceThunk;
    Procedure ThunkClassCallback(aInstance: Pointer; aMethod,aCount : Longint; aData: TInterfaceThunk.PArgData);
    procedure CreateThunk(aPIID: PTypeInfo; T : trttitype; td : PInterfaceData);
    procedure DestroyThunk;
{$ENDIF}

  protected
{$IFDEF USE_THUNK_CLASS}
    Procedure HandleThunkQueryInterface(iid : tguid;out Result : longint;out aIntf); virtual;
{$ENDIF}
    function QueryInterface(constref aIID: TGuid; out aObj): LongInt;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; reintroduce; virtual;
    function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; reintroduce; virtual;
    function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; reintroduce; virtual;

    procedure HandleUserCallback(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
  public
    constructor Create(aPIID: PTypeInfo);
    constructor Create(aPIID: PTypeInfo; aInvokeEvent: TVirtualInterfaceInvokeEvent);
    destructor Destroy; override;
    property OnInvoke: TVirtualInterfaceInvokeEvent read fOnInvoke write fOnInvoke;
  end;


  ERtti = class(Exception);
  EInsufficientRtti = class(ERtti);
  EInvocationError = class(ERtti);
  ENonPublicType = class(ERtti);

  TFunctionCallParameter = record
    ValueRef: Pointer;
    ValueSize: SizeInt;
    Info: TFunctionCallParameterInfo;
  end;
  TFunctionCallParameterArray = specialize TArray<TFunctionCallParameter>;

  TFunctionCallProc = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
  TFunctionCallMethod = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer) of object;

  TFunctionCallManager = record
    Invoke: procedure(CodeAddress: CodePointer; const Args: TFunctionCallParameterArray; CallingConvention: TCallConv;
              ResultType: PTypeInfo; ResultValue: Pointer; Flags: TFunctionCallFlags);
    CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
    CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
  end;
  TFunctionCallManagerArray = array[TCallConv] of TFunctionCallManager;

  TCallConvSet = set of TCallConv;

procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager; out aOldFuncCallMgr: TFunctionCallManager);
procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager);
procedure SetFunctionCallManager(aCallConvs: TCallConvSet; constref aFuncCallMgr: TFunctionCallManager; out aOldFuncCallMgrs: TFunctionCallManagerArray);
procedure SetFunctionCallManager(aCallConvs: TCallConvSet; constref aFuncCallMgr: TFunctionCallManager);
procedure SetFunctionCallManagers(aCallConvs: TCallConvSet; constref aFuncCallMgrs: TFunctionCallManagerArray; out aOldFuncCallMgrs: TFunctionCallManagerArray);
procedure SetFunctionCallManagers(aCallConvs: TCallConvSet; constref aFuncCallMgrs: TFunctionCallManagerArray);
procedure SetFunctionCallManagers(constref aFuncCallMgrs: TFunctionCallManagerArray; out aOldFuncCallMgrs: TFunctionCallManagerArray);
procedure SetFunctionCallManagers(constref aFuncCallMgrs: TFunctionCallManagerArray);
procedure GetFunctionCallManager(aCallConv: TCallConv; out aFuncCallMgr: TFunctionCallManager);
procedure GetFunctionCallManagers(aCallConvs: TCallConvSet; out aFuncCallMgrs: TFunctionCallManagerArray);
procedure GetFunctionCallManagers(out aFuncCallMgrs: TFunctionCallManagerArray);

function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray; aCallConv: TCallConv;
  aResultType: PTypeInfo; aIsStatic: Boolean; aIsConstructor: Boolean): TValue;

function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;

function IsManaged(TypeInfo: PTypeInfo): boolean;
function IsBoolType(ATypeInfo: PTypeInfo): Boolean;

function ArrayOfConstToTValueArray(const aValues: array of const): TValueArray;
{$ifndef InLazIDE}
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
{$endif}

{ these resource strings are needed by units implementing function call managers }
resourcestring
  SErrInvokeNotImplemented = 'Invoke functionality is not implemented 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.  Enable external managers, e.g. ffi.manager.';
  SErrTypeKindNotSupported = 'Type kind is not supported: %s';
  SErrCallbackHandlerNil = 'Callback handler is Nil';
  SErrMissingSelfParam = 'Missing self parameter';
  SErrNotEnumeratedType = '%s is not an enumerated type.';
  SErrNoFieldRtti = 'No field type info available';
  SErrNotImplementedRtti = 'This functionality is not implemented in RTTI';

implementation

{$ifdef windows}
  {$ifndef win16}
    {$define USE_WINDOWS_UNIT}
  {$endif not win16}
{$endif windows}

uses
{$IFDEF FPC_DOTTEDUNITS}
  System.Variants,
{$ifdef USE_WINDOWS_UNIT}
  WinApi.Windows,
{$endif}
{$ifdef unix}
  UnixApi.Base,
{$endif}
  System.SysConst,
  System.FGL;
{$ELSE FPC_DOTTEDUNITS}
  Variants,
{$ifdef USE_WINDOWS_UNIT}
  Windows,
{$endif}
{$ifdef unix}
  BaseUnix,
{$endif}
  sysconst,
  fgl;
{$ENDIF FPC_DOTTEDUNITS}


Const
  MemberVisibilities: array[TVisibilityClass] of TMemberVisibility
                    = (mvPrivate, mvProtected, mvPublic, mvPublished);


function AlignToPtr(aPtr: Pointer): Pointer; inline;
begin
{$ifdef CPUM68K}
  Result := AlignTypeData(aPtr);
{$else}
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  Result := Align(aPtr, SizeOf(Pointer));
{$else}
  Result := aPtr;
{$endif}
{$endif}
end;

Function IsDateTimeType(aData : PTypeInfo) : Boolean; inline;

begin
  Result:=(aData=TypeInfo(TDateTime))
          or (aData=TypeInfo(TDate))
          or (aData=TypeInfo(TTime));
end;

Function TypeInfoToVarType(aTypeInfo : PTypeInfo; out aType : TVarType) : Boolean;

begin
  aType:=varEmpty;
  case aTypeInfo^.Kind of
    tkChar,
    tkWideChar,
    tkString,
    tkLString:
      aType:=varString;
    tkUString:
      aType:=varUString;
    tkWString:
      aType:=varOleStr;
    tkVariant:
      aType:=varVariant;
    tkInteger:
      case GetTypeData(aTypeInfo)^.OrdType of
        otSByte:  aType:=varShortInt;
        otSWord:  aType:=varSmallint;
        otSLong:  aType:=varInteger;
        otUByte:  aType:=varByte;
        otUWord:  aType:=varWord;
        otULong:  aType:=varLongWord;
        otUQWord: aType:=varQWord;
        otSQWord: aType:=varInt64;
      end;
    tkEnumeration:
      if IsBoolType(aTypeInfo) then
        aType:=varBoolean;
    tkFloat:
      if IsDateTimeType(aTypeInfo) then
        aType:=varDate
      else
        case GetTypeData(aTypeInfo)^.FloatType of
          ftSingle:   aType:=varSingle;
          ftDouble:   aType:=varDouble;
          ftExtended: aType:=varDouble;
          ftComp:     aType:=varInt64;
          ftCurr:     aType:=varCurrency;
        end;
    tkInterface:
      if aTypeInfo=System.TypeInfo(IDispatch) then
        aType:=varDispatch
      else
        aType:=varUnknown;
    tkInt64:
      aType:=varInt64;
    tkQWord:
      aType:=varUInt64
  else
    aType:=varEmpty;
  end;
  Result:=(aType<>varEmpty);
end;

function VarTypeToTypeInfo(aVarType : TVarType; out DataType: PTypeInfo) : Boolean;

begin
  Result:=True;
  DataType:=Nil;
  case aVarType of
    varEmpty,
    varNull:
      ;
    varUnknown:
      DataType:=System.TypeInfo(IInterface);
    varShortInt:
      DataType:=System.TypeInfo(ShortInt);
    varSmallint:
      DataType:=System.TypeInfo(SmallInt);
    varInteger:
      DataType:=System.TypeInfo(Integer);
    varSingle:
      DataType:=System.TypeInfo(Single);
    varCurrency:
      DataType:=System.TypeInfo(Currency);
    varDate:
      DataType:=System.TypeInfo(TDateTime);
    varOleStr:
      DataType:=System.TypeInfo(WideString);
    varUString:
      DataType:=System.TypeInfo(UnicodeString);
    varDispatch:
      DataType:=System.TypeInfo(IDispatch);
    varError:
      DataType:=System.TypeInfo(HRESULT);
    varByte:
      DataType:=System.TypeInfo(Byte);
    varWord:
      DataType:=System.TypeInfo(Word);
    varInt64:
      DataType:=System.TypeInfo(Int64);
    varUInt64:
      DataType:=System.TypeInfo(UInt64);
    varBoolean:
      DataType:=System.TypeInfo(Boolean);
    varDouble:
      DataType:=System.TypeInfo(Double);
    varString:
      DataType:=System.TypeInfo(RawByteString);
  else
    Result:=False;
  end;
end;

Function FloatTypeToTypeInfo(FT : TFloatType) : PTypeInfo;

begin
  Case FT of
    ftSingle: Result:=System.TypeInfo(Single);
    ftDouble: Result:=System.TypeInfo(Double);
    ftExtended: Result:=System.TypeInfo(Extended);
    ftComp: Result:=System.TypeInfo(Comp);
    ftCurr: Result:=System.TypeInfo(Currency);
  end;
end;

type

  { TRttiPool }

  TRttiPool = class
  private type
    TRttiObjectMap = specialize TFPGMap<Pointer, TRttiObject>;
  private
    FObjectMap: TRttiObjectMap;
    FTypesList: specialize TArray<TRttiType>;
    FTypeCount: LongInt;
    FLock: TRTLCriticalSection;
  public
    function GetTypes: specialize TArray<TRttiType>;
    function GetType(ATypeInfo: PTypeInfo): TRttiType;
    function GetType(ATypeInfo: PTypeInfo; UsePublishedOnly : Boolean): TRttiType;
    function GetByHandle(aHandle: Pointer): TRttiObject;
    procedure AddObject(aObject: TRttiObject);
    constructor Create;
    destructor Destroy; override;
  end;

  { TValueDataIntImpl }

  TValueDataIntImpl = class(TInterfacedObject, IValueData)
  private
    FBuffer: Pointer;
    FDataSize: SizeInt;
    FTypeInfo: PTypeInfo;
    FIsCopy: Boolean;
    FUseAddRef: Boolean;
  public
    constructor CreateCopy(ACopyFromBuffer: Pointer; ALen: SizeInt; ATypeInfo: PTypeInfo; AAddRef: Boolean);
    constructor CreateRef(AData: Pointer; ATypeInfo: PTypeInfo; AAddRef: Boolean);
    destructor Destroy; override;
    procedure ExtractRawData(ABuffer: pointer);
    procedure ExtractRawDataNoCopy(ABuffer: pointer);
    function GetDataSize: SizeInt;
    function GetReferenceToRawData: pointer;
  end;

  TRttiRefCountedInterfaceType = class(TRttiInterfaceType)
  private
    function IntfData: PInterfaceData; inline;
  protected
    function MethodTable: PIntfMethodTable; override;
    function GetIntfBaseType: TRttiInterfaceType; override;
    function GetDeclaringUnitName: String; override;
    function GetGUID: TGUID; override;
    function GetIntfFlags: TIntfFlags; override;
    function GetIntfType: TInterfaceType; override;
  end;

  TRttiRawInterfaceType = class(TRttiInterfaceType)
  private
    function IntfData: PInterfaceRawData; inline;
  protected
    function MethodTable: PIntfMethodTable; override;
    function GetIntfBaseType: TRttiInterfaceType; override;
    function GetDeclaringUnitName: String; override;
    function GetGUID: TGUID; override;
    function GetGUIDStr: String; override;
    function GetIntfFlags: TIntfFlags; override;
    function GetIntfType: TInterfaceType; override;
  end;

  { TRttiVmtMethodParameter }

  TRttiVmtMethodParameter = class(TRttiParameter)
  private
    FVmtMethodParam: PVmtMethodParam;
  protected
    function GetHandle: Pointer; override;
    function GetName: String; override;
    function GetFlags: TParamFlags; override;
    function GetParamType: TRttiType; override;
  public
    constructor Create(AVmtMethodParam: PVmtMethodParam);
    function GetAttributes: TCustomAttributeArray; override;
  end;

  { TRttiMethodTypeParameter }

  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);
    function GetAttributes: TCustomAttributeArray; override;
  end;

  { TRttiIntfMethod }

  TRttiIntfMethod = class(TRttiMethod)
  private
    FIntfMethodEntry: PIntfMethodEntry;
    FIndex: SmallInt;
    FParams, FParamsAll: TRttiParameterArray;
    FAttributesResolved: boolean;
    FAttributes: TCustomAttributeArray;
  protected
    function GetHandle: Pointer; override;
    function GetName: String; override;
    function GetCallingConvention: TCallConv; override;
    function GetCodeAddress: CodePointer; override;
    function GetDispatchKind: TDispatchKind; override;
    function GetHasExtendedInfo: Boolean; override;
    function GetIsClassMethod: Boolean; override;
    function GetIsConstructor: Boolean; override;
    function GetIsDestructor: Boolean; override;
    function GetIsStatic: Boolean; override;
    function GetMethodKind: TMethodKind; override;
    function GetReturnType: TRttiType; override;
    function GetVirtualIndex: SmallInt; override;
    function GetParameters(aWithHidden: Boolean): TRttiParameterArray; override;
  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 }

  TRttiInstanceMethod = class(TRttiMethod)
  Type
    TStaticMethod = (smCalc, smFalse, smTrue);
  private
    FHandle: PVmtMethodExEntry;
    // False: without hidden, true: with hidden
    FParams : Array [Boolean] of TRttiParameterArray;
    FAttributesResolved: boolean;
    FAttributes: TCustomAttributeArray;
    FStaticCalculated : TStaticMethod;
    procedure ResolveParams;
    procedure ResolveAttributes;
  protected
    function GetHandle: Pointer; override;
    function GetName: String; override;
    function GetCallingConvention: TCallConv; override;
    function GetCodeAddress: CodePointer; override;
    function GetDispatchKind: TDispatchKind; override;
    function GetHasExtendedInfo: Boolean; override;
    function GetIsClassMethod: Boolean; override;
    function GetIsConstructor: Boolean; override;
    function GetIsDestructor: Boolean; override;
    function GetIsStatic: Boolean; override;
    function GetMethodKind: TMethodKind; override;
    function GetReturnType: TRttiType; override;
    function GetVirtualIndex: SmallInt; override;
    function GetParameters(aWithHidden: Boolean): TRttiParameterArray; override;
  public
    constructor Create(AParent: TRttiType; aHandle:  PVmtMethodExEntry);
    function GetAttributes: TCustomAttributeArray; override;
    function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue; override;
  end;

 { TRttiRecordMethod }

 TRttiRecordMethod = class(TRttiMethod)
  private
    FHandle : PRecMethodExEntry;
    // False: without hidden, true: with hidden
    FParams : Array [Boolean] of TRttiParameterArray;
    procedure ResolveParams;
  Protected
    function GetName: string; override;
    Function GetIsConstructor: Boolean; override;
    Function GetIsDestructor: Boolean; override;
    function GetCallingConvention: TCallConv; override;
    function GetReturnType: TRttiType; override;
    function GetDispatchKind: TDispatchKind; override;
    function GetMethodKind: TMethodKind; override;
    function GetHasExtendedInfo: Boolean; override;
    function GetCodeAddress: CodePointer; override;
    function GetIsClassMethod: Boolean; override;
    function GetIsStatic: Boolean; override;
    function GetVisibility: TMemberVisibility; override;
    function GetHandle : Pointer; override;
    function GetVirtualIndex: SmallInt; override;
  public
    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
  SErrUnableToGetValueForType = 'Unable to get value for type %s';
  SErrUnableToSetValueForType = 'Unable to set value for type %s';
  SErrDimensionOutOfRange     = 'Dimension index %d is out of range [0, %d[';
  SErrLengthOfArrayMismatch   = 'Length of static array does not match: Got %d, but expected %d';
  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';
  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: expected %s, but got %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';
  SErrMethodImplNoCallback    = 'No callback specified for method implementation';
//  SErrMethodImplInsufficientRtti = 'Insufficient RTTI to create method implementation';
  SErrMethodImplCreateNoArg   = 'TMethodImplementation can not be created this way';
  SErrVirtIntfTypeNil = 'No type information provided for TVirtualInterface';
  SErrVirtIntfTypeMustBeIntf = 'Type ''%s'' is not an interface type';
  SErrVirtIntfTypeNotFound = 'Type ''%s'' is not valid';
  SErrVirtIntfNotAllMethodsRTTI = 'Not all methods of ''%s'' or its parents have the required RTTI';
//  SErrVirtIntfRetrieveIInterface = 'Failed to retrieve IInterface information';
  SErrVirtThunkClassTypeNotFound = 'Type ''%s'' has no thunk class';
  SErrVirtThunkMethodNotFound = 'Type ''%s'' has no method with VMT index %d';
  SErrVirtThunkParameterMismatch = 'Type ''%s'', method "%s", parameter mismatch: expected %d, got %d';
  SErrVirtThunkNotCorrectInterface = 'Type ''%s'', does not implement the correct interface';
  SErrVirtIntfCreateThunk = 'Failed to create thunks for ''%0:s''';
//  SErrVirtIntfCreateImpl = 'Failed to create implementation for method ''%1:s'' of ''%0:s''';
  SErrVirtIntfInvalidVirtIdx = 'Virtual index %2:d for method ''%1:s'' of ''%0:s'' is invalid';
  SErrVirtIntfMethodNil = 'Method %1:d of ''%0:s'' is Nil';
  SErrVirtIntfCreateVmt = 'Failed to create VMT for ''%s''';
//  SErrVirtIntfIInterface = 'Failed to prepare IInterface method callbacks'; 
  SErrCannotWriteToProperty = 'Cannot write to property "%s"';
  SErrCannotReadProperty = 'Cannot read property "%s"'; 
  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
  PoolLock : TRTLCriticalSection;
  // Boolean = UsePublishedOnly
  PoolRefCount : Array [Boolean] of integer;
  GRttiPool : Array [Boolean] of TRttiPool;
  FuncCallMgr: TFunctionCallManagerArray;

{$ifndef use_thunk_class}

function AllocateMemory(aSize: PtrUInt): Pointer;
begin
{$IF DEFINED(USE_WINDOWS_UNIT)}
  Result := VirtualAlloc(Nil, aSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
{$ELSEIF DEFINED(UNIX)}
  Result := fpmmap(Nil, aSize, PROT_READ or PROT_WRITE, MAP_PRIVATE or MAP_ANONYMOUS, 0, 0);
{$ELSE}
  Result := Nil;
{$ENDIF}
end;

function ProtectMemory(aPtr: Pointer; aSize: PtrUInt; aExecutable: Boolean): Boolean;
{$IF DEFINED(USE_WINDOWS_UNIT)}
var
  oldprot: DWORD;
{$ENDIF}
begin
{$IF DEFINED(USE_WINDOWS_UNIT)}
  if aExecutable then
    Result := VirtualProtect(aPtr, aSize, PAGE_EXECUTE_READ, oldprot)
  else
    Result := VirtualProtect(aPtr, aSize, PAGE_READWRITE, oldprot);
{$ELSEIF DEFINED(UNIX)}
  if aExecutable then
    Result := Fpmprotect(aPtr, aSize, PROT_EXEC or PROT_READ) = 0
  else
    Result := Fpmprotect(aPtr, aSize, PROT_READ or PROT_WRITE) = 0;
{$ELSE}
  Result := False;
{$ENDIF}
end;

procedure FreeMemory(aPtr: Pointer; aSize: PtrUInt);
begin
{$IF DEFINED(USE_WINDOWS_UNIT)}
  VirtualFree(aPtr, 0, MEM_RELEASE);
{$ELSEIF DEFINED(UNIX)}
  fpmunmap(aPtr, aSize);
{$ELSE}
  { nothing }
{$ENDIF}
end;

label
  RawThunkEnd;

{$if defined(cpui386)}
const
  RawThunkPlaceholderBytesToPop = $12341234;
  RawThunkPlaceholderProc = $87658765;
  RawThunkPlaceholderContext = $43214321;

type
  TRawThunkBytesToPop = UInt32;
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

{ works for both cdecl and stdcall }
procedure RawThunk; assembler; nostackframe;
asm
  { the stack layout is
      $ReturnAddr <- ESP
      ArgN
      ArgN - 1
      ...
      Arg1
      Arg0

    aBytesToPop is the size of the stack to the Self argument }

  movl RawThunkPlaceholderBytesToPop, %eax
  movl %esp, %ecx
  lea (%ecx,%eax), %eax
  movl RawThunkPlaceholderContext, (%eax)
  movl RawThunkPlaceholderProc, %eax
  jmp %eax
RawThunkEnd:
end;
{$elseif defined(cpux86_64)}
const
  RawThunkPlaceholderProc = PtrUInt($8765876587658765);
  RawThunkPlaceholderContext = PtrUInt($4321432143214321);

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

{$ifdef win64}
procedure RawThunk; assembler; nostackframe;
asm
  { Self is always in register RCX }
  movq RawThunkPlaceholderContext, %rcx
  movq RawThunkPlaceholderProc, %rax
  jmp %rax
RawThunkEnd:
end;
{$else}
procedure RawThunk; assembler; nostackframe;
asm
  { Self is always in register RDI }
  movq RawThunkPlaceholderContext, %rdi
  movq RawThunkPlaceholderProc, %rax
  jmp %rax
RawThunkEnd:
end;
{$endif}
{$elseif defined(cpuarm)}
const
  RawThunkPlaceholderProc = $87658765;
  RawThunkPlaceholderContext = $43214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  (* To be compatible with Thumb we first load the function pointer into R0,
    then move that to R12 which is volatile and then we load the new Self into
    R0 *)
  ldr r0, .LProc
  mov r12, r0
  ldr r0, .LContext
{$ifdef CPUARM_HAS_BX}
  bx r12
{$else}
  mov pc, r12
{$endif}
.LProc:
  .long RawThunkPlaceholderProc
.LContext:
  .long RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpuaarch64)}
const
  RawThunkPlaceholderProc = $8765876587658765;
  RawThunkPlaceholderContext = $4321432143214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  ldr x16, .LProc
  ldr x0, .LContext
  br x16
.LProc:
  .quad RawThunkPlaceholderProc
.LContext:
  .quad RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpum68k)}
const
  RawThunkPlaceholderProc = $87658765;
  RawThunkPlaceholderContext = $43214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  lea 4(sp), a0
  move.l #RawThunkPlaceholderContext, (a0)
  move.l #RawThunkPlaceholderProc, a0
  jmp (a0)
RawThunkEnd:
end;
{$elseif defined(cpuriscv64)}
const
  RawThunkPlaceholderProc = $8765876587658765;
  RawThunkPlaceholderContext = $4321432143214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  ld x5, .LProc
  ld x10, .LContext
  jalr x0, x5, 0
.LProc:
  .quad RawThunkPlaceholderProc
.LContext:
  .quad RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpuriscv32)}
const
  RawThunkPlaceholderProc = $87658765;
  RawThunkPlaceholderContext = $43214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  lw x5, .LProc
  lw x10, .LContext
  jalr x0, x5, 0
.LProc:
  .long RawThunkPlaceholderProc
.LContext:
  .long RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpuloongarch64)}
const
  RawThunkPlaceholderProc = $8765876587658765;
  RawThunkPlaceholderContext = $4321432143214321;

type
  TRawThunkProc = PtrUInt;
  TRawThunkContext = PtrUInt;

procedure RawThunk; assembler; nostackframe;
asm
  move $t0, $ra
  bl .Lreal
  .quad RawThunkPlaceholderProc
  .quad RawThunkPlaceholderContext
.Lreal:
  ld.d $a0, $ra, 8
  ld.d $t1, $ra, 0
  move $ra, $t0
  jr $t1
RawThunkEnd:
end;
{$endif}

{$if declared(RawThunk)}
const
  RawThunkEndPtr: Pointer = @RawThunkEnd;

type
{$if declared(TRawThunkBytesToPop)}
  PRawThunkBytesToPop = ^TRawThunkBytesToPop;
{$endif}
  PRawThunkContext = ^TRawThunkContext;
  PRawThunkProc = ^TRawThunkProc;
{$endif}

{ Delphi has these as part of TRawVirtualClass.TVTable; until we have that we
  simply leave that here in the implementation }
function AllocateRawThunk(aProc: CodePointer; aContext: Pointer; aBytesToPop: SizeInt): CodePointer;
{$if declared(RawThunk)}
var
  size, i: SizeInt;
{$if declared(TRawThunkBytesToPop)}
  btp: PRawThunkBytesToPop;
  btpdone: Boolean;
{$endif}
  context: PRawThunkContext;
  contextdone: Boolean;
  proc: PRawThunkProc;
  procdone: Boolean;
{$endif}
begin
{$if not declared(RawThunk)}
  { platform dose not have thunk support... :/ }
  Result := Nil;
{$else}
  Size := PtrUInt(RawThunkEndPtr) - PtrUInt(@RawThunk) + 1;
  Result := AllocateMemory(size);
  Move(Pointer(@RawThunk)^, Result^, size);

{$if declared(TRawThunkBytesToPop)}
  btpdone := False;
{$endif}
  contextdone := False;
  procdone := False;

  for i := 0 to Size - 1 do begin
{$if declared(TRawThunkBytesToPop)}
    if not btpdone and (i <= Size - SizeOf(TRawThunkBytesToPop)) then begin
      btp := PRawThunkBytesToPop(PByte(Result) + i);
      if btp^ = TRawThunkBytesToPop(RawThunkPlaceholderBytesToPop) then begin
        btp^ := TRawThunkBytesToPop(aBytesToPop);
        btpdone := True;
      end;
    end;
{$endif}
    if not contextdone and (i <= Size - SizeOf(TRawThunkContext)) then begin
      context := PRawThunkContext(PByte(Result) + i);
      if context^ = TRawThunkContext(RawThunkPlaceholderContext) then begin
        context^ := TRawThunkContext(aContext);
        contextdone := True;
      end;
    end;
    if not procdone and (i <= Size - SizeOf(TRawThunkProc)) then begin
      proc := PRawThunkProc(PByte(Result) + i);
      if proc^ = TRawThunkProc(RawThunkPlaceholderProc) then begin
        proc^ := TRawThunkProc(aProc);
        procdone := True;
      end;
    end;
  end;

  if not contextdone or not procdone
{$if declared(TRawThunkBytesToPop)}
      or not btpdone
{$endif}
      then begin
    FreeMemory(Result, Size);
    Result := Nil;
  end else
    ProtectMemory(Result, Size, True);
{$endif}
end;

procedure FreeRawThunk(aThunk: CodePointer);
begin
{$if declared(RawThunk)}
  FreeMemory(aThunk, PtrUInt(RawThunkEndPtr) - PtrUInt(@RawThunk));
{$endif}
end;

{$ENDIF use_thunk_class}

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
  raise ENotImplemented.Create(SErrInvokeNotImplemented);
end;

function NoCreateCallbackProc(aFunc: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
begin
  Result := Nil;
  raise ENotImplemented.Create(SErrCallbackNotImplemented);
end;

function NoCreateCallbackMethod(aFunc: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
begin
  Result := Nil;
  raise ENotImplemented.Create(SErrCallbackNotImplemented);
end;

const
  NoFunctionCallManager: TFunctionCallManager = (
    Invoke: @NoInvoke;
    CreateCallbackProc: @NoCreateCallbackProc;
    CreateCallbackMethod: @NoCreateCallbackMethod;
  );

procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager;
  out aOldFuncCallMgr: TFunctionCallManager);
begin
  aOldFuncCallMgr := FuncCallMgr[aCallConv];
  FuncCallMgr[aCallConv] := aFuncCallMgr;
end;

procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager);
var
  dummy: TFunctionCallManager;
begin
  SetFunctionCallManager(aCallConv, aFuncCallMgr, dummy);
end;

procedure SetFunctionCallManager(aCallConvs: TCallConvSet; constref aFuncCallMgr: TFunctionCallManager;
  out aOldFuncCallMgrs: TFunctionCallManagerArray);
var
  cc: TCallConv;
begin
  for cc := Low(TCallConv) to High(TCallConv) do
    if cc in aCallConvs then begin
      aOldFuncCallMgrs[cc] := FuncCallMgr[cc];
      FuncCallMgr[cc] := aFuncCallMgr;
    end else
      aOldFuncCallMgrs[cc] := Default(TFunctionCallManager);
end;

procedure SetFunctionCallManager(aCallConvs: TCallConvSet; constref aFuncCallMgr: TFunctionCallManager);
var
  dummy: TFunctionCallManagerArray;
begin
  SetFunctionCallManager(aCallConvs, aFuncCallMgr, dummy);
end;

procedure SetFunctionCallManagers(aCallConvs: TCallConvSet; constref aFuncCallMgrs: TFunctionCallManagerArray; out aOldFuncCallMgrs: TFunctionCallManagerArray);
var
  cc: TCallConv;
begin
  for cc := Low(TCallConv) to High(TCallConv) do
    if cc in aCallConvs then begin
      aOldFuncCallMgrs[cc] := FuncCallMgr[cc];
      FuncCallMgr[cc] := aFuncCallMgrs[cc];
    end else
      aOldFuncCallMgrs[cc] := Default(TFunctionCallManager);
end;

procedure SetFunctionCallManagers(aCallConvs: TCallConvSet; constref aFuncCallMgrs: TFunctionCallManagerArray);
var
  dummy: TFunctionCallManagerArray;
begin
  SetFunctionCallManagers(aCallConvs, aFuncCallMgrs, dummy);
end;

procedure SetFunctionCallManagers(constref aFuncCallMgrs: TFunctionCallManagerArray; out aOldFuncCallMgrs: TFunctionCallManagerArray);
begin
  aOldFuncCallMgrs := FuncCallMgr;
  FuncCallMgr := aFuncCallMgrs;
end;

procedure SetFunctionCallManagers(constref aFuncCallMgrs: TFunctionCallManagerArray);
var
  dummy: TFunctionCallManagerArray;
begin
  SetFunctionCallManagers(aFuncCallMgrs, dummy);
end;

procedure GetFunctionCallManager(aCallConv: TCallConv; out aFuncCallMgr: TFunctionCallManager);
begin
  aFuncCallMgr := FuncCallMgr[aCallConv];
end;

procedure GetFunctionCallManagers(aCallConvs: TCallConvSet; out aFuncCallMgrs: TFunctionCallManagerArray);
var
  cc: TCallConv;
begin
  for cc := Low(TCallConv) to High(TCallConv) do
    if cc in aCallConvs then
      aFuncCallMgrs[cc] := FuncCallMgr[cc]
    else
      aFuncCallMgrs[cc] := Default(TFunctionCallManager);
end;

procedure GetFunctionCallManagers(out aFuncCallMgrs: TFunctionCallManagerArray);
begin
  aFuncCallMgrs := FuncCallMgr;
end;

procedure InitDefaultFunctionCallManager;
var
  cc: TCallConv;
begin
  for cc := Low(TCallConv) to High(TCallConv) do
    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;
begin
  Result:=FHandle;
end;

function TRttiInstanceMethod.GetName: String;
begin
  Result:=FHandle^.Name;
end;

function TRttiInstanceMethod.GetCallingConvention: TCallConv;
begin
  Result:=FHandle^.CC;
end;

function TRttiInstanceMethod.GetCodeAddress: CodePointer;
begin
  Result:=FHandle^.CodeAddress;
end;

function TRttiInstanceMethod.GetDispatchKind: TDispatchKind;
begin
  if FHandle^.VmtIndex<>-1 then
    Result:=dkStatic
  else
    Result:=dkVtable;
end;

function TRttiInstanceMethod.GetHasExtendedInfo: Boolean;
begin
  Result:=True;
end;

function TRttiInstanceMethod.GetIsClassMethod: Boolean;
begin
  Result:=MethodKind in [mkClassConstructor, mkClassDestructor, mkClassProcedure,mkClassFunction];
end;

function TRttiInstanceMethod.GetIsConstructor: Boolean;
begin
  Result:=MethodKind in [mkClassConstructor, mkConstructor];
end;

function TRttiInstanceMethod.GetIsDestructor: Boolean;
begin
  Result:=MethodKind in [mkClassDestructor, mkDestructor];
end;

function TRttiInstanceMethod.GetIsStatic: Boolean;

var
  I : integer;

begin
  if FStaticCalculated=smCalc then
    begin
    FStaticCalculated:=smTrue;
    I:=0;
    While (FStaticCalculated=smTrue) and (I<FHandle^.ParamCount) do
      begin
      if ((FHandle^.Param[i]^.Flags * [pfSelf,pfVmt])<>[]) then
        FStaticCalculated:=smFalse;
      Inc(I);
      end;
    end;
  Result:=(FStaticCalculated=smTrue);
end;

function TRttiInstanceMethod.GetMethodKind: TMethodKind;
begin
  Result:=FHandle^.Kind;
end;

function TRttiInstanceMethod.GetReturnType: TRttiType;
begin
  Result := nil;
  if Assigned(FHandle^.ResultType) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(FHandle^.ResultType^);
end;

function TRttiInstanceMethod.GetVirtualIndex: SmallInt;
begin
  Result:=FHandle^.VmtIndex;
end;

procedure TRttiInstanceMethod.ResolveParams;

var
  param: PVmtMethodParam;
  total, visible: SizeInt;
  context: TRttiContext;
  obj: TRttiObject;
  prtti : TRttiVmtMethodParameter;

begin
  total := 0;
  visible := 0;
  SetLength(FParams[False],FHandle^.ParamCount);
  SetLength(FParams[True],FHandle^.ParamCount);
  context := TRttiContext.Create(FUsePublishedOnly);
  param := FHandle^.Param[0];
  while total < FHandle^.ParamCount 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[True][total]:=prtti;
    if not (pfHidden in param^.Flags) then
      begin
      FParams[False][visible] := prtti;
      Inc(visible);
    end;
    param := param^.Next;
    Inc(total);
  end;
  if visible <> total then
    SetLength(FParams[False], visible);
end;

procedure TRttiInstanceMethod.ResolveAttributes;

var
  tbl : PAttributeTable;
  i : Integer;

begin
  FAttributesResolved:=True;
  tbl:=FHandle^.AttributeTable;
  if not (assigned(Tbl) and (Tbl^.AttributeCount>0)) then
    exit;
  SetLength(FAttributes,Tbl^.AttributeCount);
  For I:=0 to Length(FAttributes)-1 do
    FAttributes[I]:={$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(Tbl,I);
end;

function TRttiInstanceMethod.GetParameters(aWithHidden: Boolean): TRttiParameterArray;
begin
  if FHandle^.ParamCount = 0 then
    Exit(Nil);
  if  (Length(FParams[aWithHidden]) > 0) then
    Exit(FParams[aWithHidden]);
  ResolveParams;
  Result := FParams[aWithHidden];
end;

constructor TRttiInstanceMethod.Create(AParent: TRttiType; aHandle: PVmtMethodExEntry);
begin
  Inherited Create(aParent);
  FHandle:=aHandle;
end;

function TRttiInstanceMethod.GetAttributes: TCustomAttributeArray;
begin
  if not FAttributesResolved then
    ResolveAttributes;
  Result:=FAttributes;
end;

{$IFDEF USE_INVOKE_HELPER}
function TRttiMethod.HandleInvokeHelper(aParentTypeInfo : PTypeInfo; aInstance : Pointer; const aArgs : array of TValue): TValue;

var
  lArgs : Array of Pointer;
  I : integer;

begin
  SetLength(lArgs,Length(aArgs)+1);
  if Assigned(ReturnType) then
    TValue.Make(Nil,ReturnType.Handle,Result)
  else
    Result:=TValue.Empty;
  lArgs[0]:=Result.GetReferenceToRawData;
  For I:=0 to Length(aArgs)-1 do
    lArgs[i+1]:=aArgs[i].GetReferenceToRawData;
  CallInvokeHelper(aParentTypeInfo,aInstance,Name,@lArgs[0]);
end;
{$ENDIF}


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
    case aInstance.Kind of
      tkUnknown, tkClassRef:
      begin
        { TValue.Empty }
        if aInstance.Kind = tkUnknown then
          MetaClass := Parent.AsInstance.GetMetaClassType
        else
          MetaClass := aInstance.AsClass;

        pNewInst := PVmt(MetaClass)^.vNewInstance;
        aInstance := TNewInstance(pNewInst)(MetaClass);
      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>;
begin
  if not Assigned(FTypesList) then
    Exit(Nil);
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalsection(FLock);
  try
{$endif}
    Result := Copy(FTypesList, 0, FTypeCount);
{$ifdef FPC_HAS_FEATURE_THREADING}
  finally
    LeaveCriticalsection(FLock);
  end;
{$endif}
end;

function TRttiPool.GetType(ATypeInfo: PTypeInfo): TRttiType;

begin
  Result:=GetType(aTypeInfo,GlobalUsePublishedOnly);
end;

function TRttiPool.GetType(ATypeInfo: PTypeInfo; UsePublishedOnly : Boolean): TRttiType;

var
  obj: TRttiObject;
begin
  if not Assigned(ATypeInfo) then
    Exit(Nil);
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalsection(FLock);
  try
{$endif}
    Result := Nil;
    obj := GetByHandle(ATypeInfo);
    if Assigned(obj) then
      Result := obj as TRttiType;
    if not Assigned(Result) then
      begin
        if FTypeCount = Length(FTypesList) then
          begin
            SetLength(FTypesList, FTypeCount * 2);
          end;
        case ATypeInfo^.Kind of
          tkClass   : Result := TRttiInstanceType.Create(ATypeInfo,UsePublishedOnly);
          tkInterface: Result := TRttiRefCountedInterfaceType.Create(ATypeInfo,UsePublishedOnly);
          tkInterfaceRaw: Result := TRttiRawInterfaceType.Create(ATypeInfo,UsePublishedOnly);
          tkArray: Result := TRttiArrayType.Create(ATypeInfo);
          tkDynArray: Result := TRttiDynamicArrayType.Create(ATypeInfo);
          tkInt64,
          tkQWord: Result := TRttiInt64Type.Create(ATypeInfo);
          tkInteger,
          tkChar,
          tkWChar: Result := TRttiOrdinalType.Create(ATypeInfo);
          tkEnumeration : Result := TRttiEnumerationType.Create(ATypeInfo);
          tkSString,
          tkLString,
          tkAString,
          tkUString,
          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);
          tkRecord : Result:=TRttiRecordType.Create(aTypeInfo,UsePublishedOnly);
        else
          Result := TRttiType.Create(ATypeInfo);
        end;
        FTypesList[FTypeCount] := Result;
        FObjectMap.Add(ATypeInfo, Result);
        Inc(FTypeCount);
      end;
{$ifdef FPC_HAS_FEATURE_THREADING}
  finally
    LeaveCriticalsection(FLock);
  end;
{$endif}
end;

function TRttiPool.GetByHandle(aHandle: Pointer): TRttiObject;
var
  idx: LongInt;
begin
  if not Assigned(aHandle) then
    Exit(Nil);
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalsection(FLock);
  try
{$endif}
    idx := FObjectMap.IndexOf(aHandle);
    if idx < 0 then
      Result := Nil
    else
      Result := FObjectMap.Data[idx];
{$ifdef FPC_HAS_FEATURE_THREADING}
  finally
    LeaveCriticalsection(FLock);
  end;
{$endif}
end;

procedure TRttiPool.AddObject(aObject: TRttiObject);
var
  idx: LongInt;
begin
  if not Assigned(aObject) then
    Exit;
  if not Assigned(aObject.Handle) then
    raise EArgumentException.Create(SErrRttiObjectNoHandle);
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalsection(FLock);
  try
{$endif}
    idx := FObjectMap.IndexOf(aObject.Handle);
    if idx < 0 then
      FObjectMap.Add(aObject.Handle, aObject)
    else if FObjectMap.Data[idx] <> aObject then
      raise EInvalidOpException.CreateFmt(SErrRttiObjectAlreadyRegistered, [aObject.Handle]);
{$ifdef FPC_HAS_FEATURE_THREADING}
  finally
    LeaveCriticalsection(FLock);
  end;
{$endif}
end;

constructor TRttiPool.Create;
begin
{$ifdef FPC_HAS_FEATURE_THREADING}
  InitCriticalSection(FLock);
{$endif}
  SetLength(FTypesList, 32);
  FObjectMap := TRttiObjectMap.Create;
end;

destructor TRttiPool.Destroy;
var
  i: LongInt;
begin
  for i := 0 to FObjectMap.Count - 1 do
    FObjectMap.Data[i].Free;
  FObjectMap.Free;
{$ifdef FPC_HAS_FEATURE_THREADING}
  DoneCriticalsection(FLock);
{$endif}
  inherited Destroy;
end;

{ TValueDataIntImpl }

procedure IntFinalize(APointer, ATypeInfo: Pointer);
  external name 'FPC_FINALIZE';
procedure IntInitialize(APointer, ATypeInfo: Pointer);
  external name 'FPC_INITIALIZE';
procedure IntAddRef(APointer, ATypeInfo: Pointer);
  external name 'FPC_ADDREF';
function IntCopy(ASource, ADest, ATypeInfo: Pointer): SizeInt;
  external name 'FPC_COPY';

constructor TValueDataIntImpl.CreateCopy(ACopyFromBuffer: Pointer; ALen: SizeInt; ATypeInfo: PTypeInfo; AAddRef: Boolean);
begin
  FTypeInfo := ATypeInfo;
  FDataSize:=ALen;
  if ALen>0 then
    begin
      Getmem(FBuffer,FDataSize);
      if Assigned(ACopyFromBuffer) then
        system.move(ACopyFromBuffer^,FBuffer^,FDataSize)
      else
        FillChar(FBuffer^, FDataSize, 0);
    end;
  FIsCopy := True;
  FUseAddRef := AAddRef;
  if AAddRef and (ALen > 0) then begin
    if Assigned(ACopyFromBuffer) then
      IntAddRef(FBuffer, FTypeInfo)
    else
      IntInitialize(FBuffer, FTypeInfo);
  end;
end;

constructor TValueDataIntImpl.CreateRef(AData: Pointer; ATypeInfo: PTypeInfo; AAddRef: Boolean);
begin
  FTypeInfo := ATypeInfo;
  FDataSize := SizeOf(Pointer);
  if Assigned(AData) then
    FBuffer := PPointer(AData)^
  else
    FBuffer := Nil;
  FIsCopy := False;
  FUseAddRef := AAddRef;
  if AAddRef and Assigned(AData) then
    IntAddRef(@FBuffer, FTypeInfo);
end;

destructor TValueDataIntImpl.Destroy;
begin
  if Assigned(FBuffer) then begin
    if FUseAddRef then
      if FIsCopy then
        IntFinalize(FBuffer, FTypeInfo)
      else
        IntFinalize(@FBuffer, FTypeInfo);
    if FIsCopy then
      Freemem(FBuffer);
  end;
  inherited Destroy;
end;

procedure TValueDataIntImpl.ExtractRawData(ABuffer: pointer);
begin
  if FDataSize = 0 then
    Exit;
  if FIsCopy then
    System.Move(FBuffer^, ABuffer^, FDataSize)
  else
    System.Move(FBuffer{!}, ABuffer^, FDataSize);
  if FUseAddRef then
    IntAddRef(ABuffer, FTypeInfo);
end;

procedure TValueDataIntImpl.ExtractRawDataNoCopy(ABuffer: pointer);
begin
  if FDataSize = 0 then
    Exit;
  if FIsCopy then
    system.move(FBuffer^, ABuffer^, FDataSize)
  else
    System.Move(FBuffer{!}, ABuffer^, FDataSize);
end;

function TValueDataIntImpl.GetDataSize: SizeInt;
begin
  result := FDataSize;
end;

function TValueDataIntImpl.GetReferenceToRawData: pointer;
begin
  if FIsCopy then
    result := FBuffer
  else
    result := @FBuffer;
end;

{ TValue }

function TValue.GetTypeDataProp: PTypeData;
begin
  result := GetTypeData(FData.FTypeInfo);
end;

function TValue.GetTypeInfo: PTypeInfo;
begin
  result := FData.FTypeInfo;
end;

function TValue.GetTypeKind: TTypeKind;
begin
  if not Assigned(FData.FTypeInfo) then
    Result := tkUnknown
  else
    result := FData.FTypeInfo^.Kind;
end;

function TValue.IsObject: boolean;
begin
  result := (Kind = tkClass) or ((Kind = tkUnknown) and not Assigned(FData.FAsObject));
end;

function TValue.IsClass: boolean;
begin
  result := (Kind = tkClassRef) or ((Kind in [tkClass,tkUnknown]) and not Assigned(FData.FAsObject));
end;

function TValue.IsOrdinal: boolean;
begin
  result := (Kind in [tkInteger, tkInt64, tkQWord, tkBool, tkEnumeration, tkChar, tkWChar, tkUChar]) or
            ((Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown]) and not Assigned(FData.FAsPointer));
end;

function TValue.IsDateTime: boolean;

begin
  Result:=IsDateTimeType(TypeInfo);
end;

function TValue.IsInstanceOf(aClass : TClass): boolean; 

var
  Obj : TObject;

begin
  Result:=IsObject;
  if not Result then
    exit;
  Obj:=AsObject;
  Result:=Assigned(Obj) and Obj.InheritsFrom(aClass);
end;

generic function TValue.IsType<T>:Boolean;
begin
  Result := IsType(PTypeInfo(System.TypeInfo(T)));
end;

generic function TValue.IsType<T>(const EmptyAsAnyType : Boolean):Boolean;
begin
  Result := IsType(PTypeInfo(System.TypeInfo(T)),EmptyAsAnyType);
end;

generic class procedure TValue.Make<T>(const AValue: T; out Result: TValue);
begin
  TValue.Make(@AValue, PTypeInfo(System.TypeInfo(T)), Result);
end;

generic class function TValue.From<T>(constref aValue: T): TValue;
begin
  TValue.Make(@aValue, PTypeInfo(System.TypeInfo(T)), Result);
end;

generic class function TValue.FromOpenArray<T>(constref aValue: array of T): TValue;
var
  arrdata: Pointer;
begin
  if Length(aValue) > 0 then
    arrdata := @aValue[0]
  else
    arrdata := Nil;
  TValue.MakeOpenArray(arrdata, Length(aValue), PTypeInfo(System.TypeInfo(aValue)), Result);
end;

function TValue.IsType(aTypeInfo: PTypeInfo): boolean;
begin
  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;
  if Not Result then
    result := ATypeInfo = TypeInfo;
end;


class procedure TValue.Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result: TValue);
begin
  TValue.Make(@AValue, ATypeInfo, Result);
end;

class operator TValue.:=(const AValue: ShortString): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(const AValue: AnsiString): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(const AValue: UnicodeString): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(const AValue: WideString): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: SmallInt): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: ShortInt): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: Byte): TValue; inline;

begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: Word): TValue; inline;

begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: Cardinal): TValue; inline;

begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: LongInt): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: Single): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: Double): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

{$ifdef FPC_HAS_TYPE_EXTENDED}
class operator TValue.:=(AValue: Extended): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;
{$endif}

class operator TValue.:=(AValue: Currency): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: Comp): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: Int64): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: QWord): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:=(AValue: TObject): TValue;
begin
  Make(@AValue, PTypeInfo(AValue.ClassInfo), Result);
end;

class operator TValue.:=(AValue: TClass): TValue;
begin
  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);
end;

class operator TValue.:=(AValue: IUnknown): TValue;
begin
  Make(@AValue, System.TypeInfo(AValue), Result);
end;

class operator TValue.:= (AValue: TVarRec): TValue;

begin
  Result:=TValue.FromVarRec(aValue);
end;

class operator TValue.:=(AValue: TDateTime): TValue;
begin
  Make(@AValue, System.TypeInfo(TDateTime), Result);
end;

class operator TValue.:=(AValue: TDate): TValue;
begin
  Make(@AValue, System.TypeInfo(TDate), Result);
end;

class operator TValue.:=(AValue: system.TTime): TValue;
begin
  Make(@AValue, System.TypeInfo(system.TTime), Result);
end;

class operator TValue.= (const ALeft, ARight: TValue): Boolean;
begin
  Result := SameValue(ALeft, ARight);
end;

class operator TValue.<> (const ALeft, ARight: TValue): Boolean;
begin
  Result := not SameValue(ALeft, ARight);
end;

function TValue.AsString: string;
begin
  if System.GetTypeKind(String) = tkUString then
    Result := String(AsUnicodeString)
  else
    Result := String(AsAnsiString);
end;

procedure TValue.Init;
begin
  { resets the whole variant part; FValueData is already Nil }
{$if SizeOf(TMethod) > SizeOf(QWord)}
  FData.FAsMethod.Code := Nil;
  FData.FAsMethod.Data := Nil;
{$else}
  FData.FAsUInt64 := 0;
{$endif}
end;

class function TValue.Empty: TValue;
begin
  Result.Init;
  result.FData.FTypeInfo := nil;
end;


function TValue.GetDataSize: SizeInt;
begin
  Result := 0;
  if Assigned(FData.FValueData) and (Kind <> tkSString) then
  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;

procedure TValue.CastAssign(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  aRes:=True;
  aDest:=Self;
end;

procedure TValue.CastIntegerToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Integer;

begin
  with FData do
    case GetTypeData(FTypeInfo)^.OrdType of
      otSByte: Tmp:=FAsSByte;
      otSWord: Tmp:=FAsSWord;
      otSLong: Tmp:=FAsSLong;
    else
      Tmp:=Integer(FAsULong);
    end;
  TValue.Make(@Tmp,aDestType,aDest);
  aRes:=True;
end;


procedure TValue.CastIntegerToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Int64;
  Ti : PtypeInfo;
  DestFloatType: TFloatType;
  S: Single;
  D: Double;
  E: Extended;
  Co: Comp;
  Cu: Currency;
begin
  Tmp:=AsInt64;
  DestFloatType := GetTypeData(aDestType)^.FloatType;
  Ti:=FloatTypeToTypeInfo(DestFloatType);
  case DestFloatType of
    ftSingle:   begin S  := Tmp; TValue.Make(@S, Ti,aDest); end;
    ftDouble:   begin D  := Tmp; TValue.Make(@D, Ti,aDest); end;
    ftExtended: begin E  := Tmp; TValue.Make(@E, Ti,aDest); end;
    ftComp:     begin Co := Tmp; TValue.Make(@Co,Ti,aDest); end;
    ftCurr:     begin Cu := Tmp; TValue.Make(@Cu,Ti,aDest); end;
  else
    aRes := False;
    Exit;
  end;
  aRes:=True;
end;

procedure TValue.CastIntegerToInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: Int64;

begin
  Tmp:=AsInt64;
  TValue.Make(@Tmp,aDestType,aDest);
  aRes:=True;
end;

procedure TValue.CastIntegerToQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: QWord;

begin
  Tmp:=QWord(AsInt64);
  TValue.Make(@Tmp, aDestType, aDest);
  aRes:=True;
end;


procedure TValue.CastCharToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: AnsiChar;
  S : RawByteString;

begin
  Tmp:=AsAnsiChar;
  aRes:=True;
  case aDestType^.Kind of
    tkChar:
      TValue.Make(NativeInt(Tmp), aDestType, aDest);
    tkString:
      TValue.Make(@Tmp,System.TypeInfo(ShortString),aDest);
    tkWString:
      TValue.Make(@Tmp,System.TypeInfo(WideString),aDest);
    tkUString:
      TValue.Make(@Tmp,System.TypeInfo(UnicodeString),aDest);
    tkLString:
      begin
      SetString(S, PAnsiChar(@Tmp), 1);
      SetCodePage(S,GetTypeData(aDestType)^.CodePage);
      TValue.Make(@S, aDestType, aDest);
      end;
  else
    aRes:=False;
  end;
end;

procedure TValue.CastWCharToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: WideChar;
  RS: RawByteString;
  SS : ShortString;
  WS : WideString;
  US : WideString;

begin
  Tmp:=AsWideChar;
  aRes:=True;
  case aDestType^.Kind of
    tkWChar: TValue.Make(NativeInt(Tmp), aDestType, aDest);
    tkString:
      begin
      SS:=Tmp;
      TValue.Make(@SS,System.TypeInfo(ShortString),aDest);
      end;
    tkWString:
      begin
      WS:=Tmp;
      TValue.Make(@WS,System.TypeInfo(WideString),aDest);
      end;
    tkUString:
      begin
      US:=Tmp;
      TValue.Make(@US,System.TypeInfo(UnicodeString),aDest);
      end;
    tkLString:
      begin
      SetString(RS,PAnsiChar(@Tmp),1);
      SetCodePage(RS,GetTypeData(aDestType)^.CodePage);
      TValue.Make(@RS,aDestType,aDest);
      end;
  else
    aRes:=False;
  end;

end;

procedure TValue.CastEnumToEnum(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

  Function GetEnumBaseType(aType : PTypeInfo) : PTypeInfo;

  begin
    if aType^.Kind=tkEnumeration then
    begin
      Result:=GetTypeData(aType)^.BaseType;
      if Assigned(Result) and (Result^.Kind = tkEnumeration) then
        Result := GetEnumBaseType(Result)
      else
        Result := aType;
    end
    else
      Result:=Nil;
  end;

var
  N : NativeInt;
  BoolType : PTypeInfo;
begin
  N:=AsOrdinal;
  if IsBoolType(FData.FTypeInfo) and IsBoolType(aDestType) then
    begin
    aRes:=True;
    BoolType:=GetEnumBaseType(aDestType);
    if (N<>0) then
      if (BoolType=System.TypeInfo(Boolean)) then
        N:=Ord(True)
      else
        N:=-1;
    TValue.Make(NativeInt(N),aDestType,aDest)
    end
  else
    begin
    aRes:=GetEnumBaseType(FData.FTypeInfo)=GetEnumBaseType(aDestType);
    if aRes then
      TValue.Make(NativeInt(N), aDestType, aDest);
    end;
end;


procedure TValue.CastFloatToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Ti : PTypeInfo;
  S : Single;
  D : Double;
  E : Extended;
  Cu : Currency;
  DestFloatType: TFloatType;
begin
  if TypeData^.FloatType = ftComp then
  begin
    aRes := False;
    Exit;
  end;
  // Destination float type
  DestFloatType := GetTypeData(aDestType)^.FloatType;
  if DestFloatType = ftComp then
  begin
    aRes := False;
    Exit;
  end;
  ti:=FloatTypeToTypeInfo(DestFloatType);
  case TypeData^.FloatType of
    ftSingle:
      begin
      S:=AsSingle;
      case DestFloatType of
        ftSingle:   begin          TValue.Make(@S, Ti,aDest); end;
        ftDouble:   begin D := S;  TValue.Make(@D, Ti,aDest); end;
        ftExtended: begin E := S;  TValue.Make(@E, Ti,aDest); end;
        ftCurr:     begin Cu := S; TValue.Make(@Cu,Ti,aDest); end;
      end;
      end;
    ftDouble:
      begin
      D:=AsDouble;
      case DestFloatType of
        ftSingle:   begin S  := D; TValue.Make(@S, Ti,aDest); end;
        ftDouble:   begin          TValue.Make(@D, Ti,aDest); end;
        ftExtended: begin E  := D; TValue.Make(@E, Ti,aDest); end;
        ftCurr:     begin Cu := D; TValue.Make(@Cu,Ti,aDest); end;
      end;
      end;
    ftExtended:
      begin
      E:=AsExtended;
      case DestFloatType of
        ftSingle:   begin S  := E; TValue.Make(@S, Ti,aDest); end;
        ftDouble:   begin D  := E; TValue.Make(@D, Ti,aDest); end;
        ftExtended: begin          TValue.Make(@E, Ti,aDest); end;
        ftCurr:     begin Cu := E; TValue.Make(@Cu,Ti,aDest); end;
      end;
      end;
    ftCurr:
      begin
      Cu:=AsCurrency;
      case DestFloatType of
        ftSingle:   begin S  := Cu; TValue.Make(@S, Ti,aDest); end;
        ftDouble:   begin D  := Cu; TValue.Make(@D, Ti,aDest); end;
        ftExtended: begin E  := Cu; TValue.Make(@E, Ti,aDest); end;
        ftCurr:     begin           TValue.Make(@Cu,Ti,aDest); end;
      end;
      end;
    end;
  aRes:=True;
  // This is for TDateTime, TDate, TTime
  aDest.FData.FTypeInfo:=aDestType;
end;

procedure TValue.CastStringToString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  US : UnicodeString;
  RS : RawByteString;
  WS : WideString;
  SS : ShortString;
  AStr: AnsiString;
begin
  aRes:=False;
  US:=AsUnicodeString;
  case aDestType^.Kind of
  tkUString:
    TValue.Make(@US,aDestType,aDest);
  tkWString:
    begin
    WS:=US;
    TValue.Make(@WS,aDestType,aDest);
    end;
  tkString:
    begin
    RS:=AnsiString(US);
    if Length(RS)>GetTypeData(aDestType)^.MaxLength then
      Exit;
    SS:=RS;
    TValue.Make(@SS,aDestType,aDest);
    end;
  tkChar:
    begin
    RS:=AnsiString(US);
    if Length(RS)<>1 then
      Exit;
    TValue.Make(PAnsiChar(RS),aDestType,aDest);
    end;
  tkLString:
    begin
    SetString(RS,PAnsiChar(US),Length(US));
    TValue.Make(@RS, aDestType, aDest);
    end;
  tkAString:
    begin
    AStr := AnsiString(US);
    TValue.Make(@AStr, aDestType, aDest);
    end;
  tkWChar:
    begin
    if Length(US)<>1 then
      Exit;
    TValue.Make(PWideChar(US),aDestType,aDest);
    end;
  else
    Exit;
  end;
  aRes:=True;
end;

procedure TValue.CastClassToClass(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : TObject;
  aClass : TClass;

begin
  Tmp:=AsObject;
  aClass:=GetTypeData(aDestType)^.ClassType;
  aRes:=Tmp.InheritsFrom(aClass);
  if aRes then
    TValue.Make(IntPtr(Tmp),aDestType,aDest);
end;

procedure TValue.CastClassRefToClassRef(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Cfrom,Cto: TClass;

begin
  ExtractRawData(@CFrom);
  Cto:=GetTypeData(GetTypeData(aDestType)^.InstanceType)^.ClassType;
  aRes:=(cFrom=nil) or ((Cfrom=nil) and (Cto=nil)) or (CFrom.InheritsFrom(Cto));
  if aRes then
    TValue.Make(PtrInt(cFrom),aDestType,aDest);
end;

procedure TValue.CastClassToInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  aGUID : TGUID;
  P : Pointer;

begin
  aRes:=False;
  aGUID:=GetTypeData(aDestType)^.Guid;
  if IsEqualGUID(GUID_NULL,aGUID) then
    Exit;
  aRes:=TObject(AsObject).GetInterface(aGUID,P);
  if aRes then
    begin
    TValue.Make(@P,aDestType,aDest);
    IUnknown(P)._Release;
    end;
end;

procedure TValue.CastInterfaceToInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Parent: PTypeData;
  Tmp : Pointer;

begin
  aRes:=(aDestType=TypeInfo) or (aDestType=System.TypeInfo(IInterface));
  if not aRes then
    begin
    Parent:=GetTypeData(TypeInfo);
    while (not aRes) and Assigned(Parent) and Assigned(Parent^.IntfParent) do
      begin
      aRes:=(Parent^.IntfParent=aDestType);
      if not aRes then
        Parent:=GetTypeData(Parent^.IntfParent);
      end;
    end;
  if not aRes then
    exit;
  ExtractRawDataNoCopy(@Tmp);
  TValue.Make(@Tmp,aDestType,aDest);
end;

procedure TValue.CastQWordToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : QWord;
  N : NativeInt;

begin
  aRes:=True;
  Tmp:=FData.FAsUInt64;
  case GetTypeData(aDestType)^.OrdType of
    otSByte: N:=NativeInt(Int8(Tmp));
    otSWord: N:=NativeInt(Int16(Tmp));
    otSLong: N:=NativeInt(Int32(Tmp));
    otUByte: N:=NativeInt(UInt8(Tmp));
    otUWord: N:=NativeInt(UInt16(Tmp));
    otULong: N:=NativeInt(UInt32(Tmp));
  else
    aRes:=False;
  end;
  if aRes then
    TValue.Make(N, aDestType, aDest);
end;

procedure TValue.CastInt64ToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: Int64;
  N : NativeInt;

begin
  Tmp:=FData.FAsSInt64;
  aRes:=True;
  case GetTypeData(aDestType)^.OrdType of
    otSByte: N:=NativeInt(Int8(Tmp));
    otSWord: N:=NativeInt(Int16(Tmp));
    otSLong: N:=NativeInt(Int32(Tmp));
    otUByte: N:=NativeInt(UInt8(Tmp));
    otUWord: N:=NativeInt(UInt16(Tmp));
    otULong: N:=NativeInt(UInt32(Tmp));
  else
    aRes:=False;
  end;
  if aRes then
    TValue.Make(N, aDestType, aDest);
end;

procedure TValue.CastQWordToInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : QWord;

begin
  Tmp:=FData.FAsUInt64;
  TValue.Make(@Tmp,System.TypeInfo(Int64),aDest);
  aRes:=True;
end;


procedure TValue.CastInt64ToQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Int64;

begin
  Tmp:=FData.FAsSInt64;
  TValue.Make(@Tmp,System.TypeInfo(QWord),aDest);
  aRes:=True;
end;


procedure TValue.CastQWordToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : QWord;
  Ti : PTypeInfo;

begin
  Tmp:=FData.FAsUInt64;
  Ti:=FloatTypeToTypeInfo(GetTypeData(aDestType)^.FloatType);
  TValue.Make(@Tmp,Ti,aDest);
  aRes:=True;
end;

procedure TValue.CastInt64ToFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Int64;
  Ti : PTypeInfo;
begin
  Tmp:=AsInt64;
  Ti:=FloatTypeToTypeInfo(GetTypeData(aDestType)^.FloatType);
  TValue.Make(@Tmp,Ti,aDest);
  aRes:=True;
end;

procedure TValue.CastFloatToInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: Int64;
  DTD : PTypeData;

begin
  aRes:=TypeData^.FloatType=ftComp;
  if not aRes then
    Exit;
  Tmp:=FData.FAsSInt64;
  DTD:=GetTypeData(aDestType);
  Case aDestType^.Kind of
  tkInteger:
    begin
    with DTD^ do
      if MinValue<=MaxValue then
        aRes:=(Tmp>=MinValue) and (Tmp<=MaxValue)
      else
        aRes:=(Tmp>=Cardinal(MinValue)) and (Tmp<=Cardinal(MaxValue))
    end;
  tkInt64:
    With DTD^ do
      aRes:=(Tmp>=MinInt64Value) and (Tmp<=MaxInt64Value);
  tkQWord:
    With DTD^ do
      aRes:=(Tmp>=0) and (QWord(Tmp)>=Qword(MinInt64Value)) and (QWord(Tmp)<=UInt64(MaxInt64Value));
  else
    aRes:=False;
  end;
  if aRes then
    TValue.Make(@Tmp, aDestType, aDest);
end;

procedure TValue.CastFromVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Variant;
  tmpBool: Boolean;
  tmpExtended: Extended;
  tmpShortString: ShortString;

  VarType: TVarType;
  DataPtr: Pointer;
  DataType: PTypeInfo;

begin
  aRes:=False;
  Tmp:=AsVariant;
  if VarIsNull(Tmp) and NullStrictConvert then
    Exit;
  if not TypeInfoToVarType(aDestType,VarType) then
    exit;
  try
    Tmp:=VarAsType(Tmp,VarType);
  except
    Exit;
  end;
  DataType:=nil;
  DataPtr:=@TVarData(Tmp).VBoolean;
  if not VarTypeToTypeInfo(TVarData(Tmp).VType,DataType) then
    Exit;
  if DataType=Nil then
    begin
    aDest:=TValue.Empty;
    aRes:=True;
    Exit;
    end;
  // Some special cases
  if (DataType=System.TypeInfo(Boolean)) then
    begin
    tmpBool:=TVarData(Tmp).VBoolean=True;
    DataPtr:=@tmpBool;
    end
  else if (DataType=System.TypeInfo(Double)) then
    begin
    if GetTypeData(aDestType)^.FloatType=ftExtended then
      begin
      tmpExtended:=Extended(TVarData(Tmp).VDouble);
      DataPtr:=@tmpExtended;
      DataType:=System.TypeInfo(Extended);
      end
    end
  else if (DataType=System.TypeInfo(ShortString)) then
    begin
    tmpShortString:=RawByteString(TVarData(tmp).VString);
    DataPtr:=@tmpShortString;
    end;
  TValue.Make(DataPtr,DataType,aDest);
  aRes:=True;
end;


procedure TValue.CastToVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp: Variant;

begin
  aRes:=False;
  case Self.Kind of
    tkChar:
      Tmp:=Specialize AsType<AnsiChar>;
    tkString,
    tkLString,
    tkAString,
    tkWString,
    tkUString:
      Tmp:=AsString;
    tkWChar:
      Tmp:=WideChar(FData.FAsUWord);
    tkClass:
      Tmp:=PtrInt(AsObject);
    tkInterface:
      Tmp:=AsInterface;
    tkInteger:
      begin
        case TypeData^.OrdType of
          otSByte: Tmp:=FData.FAsSByte;
          otUByte: Tmp:=FData.FAsUByte;
          otSWord: Tmp:=FData.FAsSWord;
          otUWord: Tmp:=FData.FAsUWord;
          otSLong: Tmp:=FData.FAsSLong;
          otULong: Tmp:=FData.FAsULong;
          otSQWord: Tmp:=FData.FAsSInt64;
          otUQWord: Tmp:=FData.FAsUInt64;
        end;
      end;
    tkFloat:
      if IsDateTime then
        Tmp:=TDateTime(FData.FAsDouble)
      else
        case TypeData^.FloatType of
          ftSingle,
          ftDouble,
          ftExtended:
            Tmp:=AsExtended;
          ftComp:
            Tmp:=FData.FAsComp;
          ftCurr:
            Tmp:=FData.FAsCurr;
        end;
    tkInt64:
      Tmp:=AsInt64;
    tkQWord:
      Tmp:=AsUInt64;
    tkEnumeration:
      if IsType(System.TypeInfo(Boolean)) then
        Tmp:=AsBoolean
      else
        Tmp:=AsOrdinal;
  else
    Exit;
  end;
  if aDestType=System.TypeInfo(OleVariant) then
    TValue.Make(@Tmp,System.TypeInfo(OleVariant),aDest)
  else
    TValue.Make(@Tmp,System.TypeInfo(Variant),aDest);
  aRes:=True;
end;

procedure TValue.CastVariantToVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  Tmp : Variant;


begin
  if (TypeInfo=aDestType) then
    aDest:=Self
  else
    begin
    Tmp:=AsVariant;
    if (aDestType=System.TypeInfo(OleVariant)) then
      TValue.Make(@Tmp,System.TypeInfo(OleVariant),aDest)
    else
      TValue.Make(@Tmp,System.TypeInfo(Variant),aDest);
    end;
  aRes:=True;
end;

procedure TValue.CastSetToSet(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

var
  sMax, dMax, sMin, dMin : Integer;
  TD : PTypeData;

begin
  aRes:=False;
  TD:=TypeData;
  TD:=GetTypeData(TD^.CompType);
  sMin:=TD^.MinValue;
  sMax:=TD^.MaxValue;
  TD:=GetTypeData(aDestType);
  TD:=GetTypeData(TD^.CompType);
  dMin:=TD^.MinValue;
  dMax:=TD^.MaxValue;
  aRes:=(sMin=dMin) and (sMax=dMax);
  if aRes then
    begin
    TValue.Make(GetReferenceToRawData, aDestType, aDest);
    aRes:=true;
    end
end;

procedure TValue.CastFromInteger(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkInteger: CastIntegerToInteger(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
    tkInt64 : CastIntegerToInt64(aRes,aDest,aDestType);
    tkQWord : CastIntegerToQWord(aRes,aDest,aDestType);
    tkFloat : CastIntegerToFloat(aRes,aDest,aDestType);
  else
    aRes:=False
  end;
end;

procedure TValue.CastFromAnsiChar(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  case aDestType^.Kind of
    tkString,
    tkWChar,
    tkLString,
    tkAString,
    tkWString,
    tkUString : CastCharToString(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False
  end;
end;

procedure TValue.CastFromWideChar(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  case aDestType^.Kind of
    tkString,
    tkWChar,
    tkLString,
    tkAString,
    tkWString,
    tkUString : CastWCharToString(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


procedure TValue.CastFromEnum(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  case aDestType^.Kind of
    tkEnumeration : CastEnumToEnum(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=false;
  end;
end;


procedure TValue.CastFromFloat(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  case aDestType^.Kind of
    tkInt64,
    tkQWord,
    tkInteger : CastFloatToInteger(aRes,aDest,aDestType);
    tkFloat : CastFloatToFloat(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


procedure TValue.CastFromString(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkString,
    tkWChar,
    tkLString,
    tkAString,
    tkWString,
    tkUString,
    tkChar : CastStringToString(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end
end;

procedure TValue.CastFromSet(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkSet : CastSetToSet(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


procedure TValue.CastFromClass(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkClass : CastClassToClass(aRes,aDest,aDestType);
    tkInterfaceRaw,
    tkInterface : CastClassToInterface(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


procedure TValue.CastFromInterface(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkInterfaceRaw,
    tkInterface : CastInterfaceToInterface(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


procedure TValue.DoCastFromVariant(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkInteger,
    tkChar,
    tkEnumeration,
    tkFloat,
    tkString,
    tkWChar,
    tkLString,
    tkAString,
    tkWString,
    tkInt64,
    tkQWord,
    tkUnicodeString : CastFromVariant(aRes,aDest,aDestType);
    tkVariant : CastVariantToVariant(aRes,aDest,aDestType);
  else
    aRes:=False;
  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;
end;

procedure TValue.CastFromInt64(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkInteger: CastInt64ToInteger(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
    tkInt64 : CastAssign(aRes,aDest,aDestType);
    tkQWord : CastInt64ToQWord(aRes,aDest,aDestType);
    tkFloat : CastInt64ToFloat(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;

procedure TValue.CastFromQWord(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case aDestType^.Kind of
    tkInteger: CastQWordToInteger(aRes,aDest,aDestType);
    tkVariant : CastToVariant(aRes,aDest,aDestType);
    tkInt64 : CastQWordToInt64(aRes,aDest,aDestType);
    tkQWord : CastAssign(aRes,aDest,aDestType);
    tkFloat : CastQWordToFloat(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;

procedure TValue.CastFromType(out aRes: Boolean; out ADest: TValue; aDestType: PTypeInfo);

begin
  Case Kind of
    tkInteger : CastFromInteger(aRes,aDest,aDestType);
    tkChar : CastFromAnsiChar(aRes,aDest,aDestType);
    tkEnumeration : CastFromEnum(aRes,aDest,aDestType);
    tkFloat : CastFromFloat(aRes,aDest,aDestType);
    tkLString,
    tkAString,
    tkWString,
    tkUstring,
    tkSString : CastFromString(aRes,aDest,aDestType);
    tkSet : CastFromSet(aRes,aDest,aDestType);
    tkWChar : CastFromWideChar(aRes,aDest,aDestType);
    tkInterfaceRaw,
    tkInterface : CastFromInterface(aRes,aDest,aDestType);
    tkVariant : DoCastFromVariant(aRes,aDest,aDestType);
    tkInt64 : CastFromInt64(aRes,aDest,aDestType);
    tkQWord : CastFromQWord(aRes,aDest,aDestType);
    tkClass : CastFromClass(aRes,aDest,aDestType);
    tkClassRef : begin
                 aRes:=(aDestType^.kind=tkClassRef);
                 if aRes then
                   CastClassRefToClassRef(aRes,aDest,aDestType);
                 end;

    tkProcedure,
    tkPointer : CastFromPointer(aRes,aDest,aDestType);
  else
    aRes:=False;
  end;
end;


class procedure TValue.Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue);
type
  PMethod = ^TMethod;
var
  td: PTypeData;
begin
  result.Init;
  result.FData.FTypeInfo:=ATypeInfo;
  if not Assigned(ATypeInfo) then
    Exit;
  { first handle those types that need a TValueData implementation }
  case ATypeInfo^.Kind of
    tkSString  : begin
                   td := GetTypeData(ATypeInfo);
                   result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, ATypeInfo, True);
                 end;
    tkWString,
    tkUString,
    tkAString  : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
    tkDynArray : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
    tkArray    : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, IsManaged(ATypeInfo));
    tkObject,
    tkRecord   : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, IsManaged(ATypeInfo));
    tkVariant  : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, SizeOf(Variant), ATypeInfo, True);
    tkInterface: result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
  else
    // Silence compiler warning
  end;
  if not Assigned(ABuffer) then
    Exit;
  { now handle those that are happy with the variant part of FData }
  case ATypeInfo^.Kind of
    tkSString,
    tkWString,
    tkUString,
    tkAString,
    tkDynArray,
    tkArray,
    tkObject,
    tkRecord,
    tkVariant,
    tkInterface:
      { ignore }
      ;
    tkClass    : result.FData.FAsObject := PPointer(ABuffer)^;
    tkClassRef : result.FData.FAsClass := PClass(ABuffer)^;
    tkInterfaceRaw : result.FData.FAsPointer := PPointer(ABuffer)^;
    tkInt64    : result.FData.FAsSInt64 := PInt64(ABuffer)^;
    tkQWord    : result.FData.FAsUInt64 := PQWord(ABuffer)^;
    tkProcVar  : result.FData.FAsMethod.Code := PCodePointer(ABuffer)^;
    tkMethod   : result.FData.FAsMethod := PMethod(ABuffer)^;
    tkPointer  : result.FData.FAsPointer := PPointer(ABuffer)^;
    tkSet      : begin
                   td := GetTypeData(ATypeInfo);
                   case td^.OrdType of
                     otUByte: begin
                       { this can either really be 1 Byte or a set > 32-bit, so
                         check the underlying type }
                       if not (td^.CompType^.Kind in [tkInteger,tkEnumeration]) then
                         raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]);
                       case td^.SetSize of
                         0, 1:
                           Result.FData.FAsUByte := PByte(ABuffer)^;
                         { these two cases shouldn't happen, but better safe than sorry... }
                         2:
                           Result.FData.FAsUWord := PWord(ABuffer)^;
                         3, 4:
                           Result.FData.FAsULong := PLongWord(ABuffer)^;
                         { maybe we should also allow storage as otUQWord? }
                         5..8:
                           Result.FData.FAsUInt64 := PQWord(ABuffer)^;
                         else
                           Result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.SetSize, ATypeInfo, False);
                       end;
                     end;
                     otUWord:
                       Result.FData.FAsUWord := PWord(ABuffer)^;
                     otULong:
                       Result.FData.FAsULong := PLongWord(ABuffer)^;
                     else
                       { ehm... Panic? }
                       raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]);
                   end;
                 end;
    tkChar,
    tkWChar,
    tkUChar,
    tkEnumeration,
    tkInteger  : begin
                   case GetTypeData(ATypeInfo)^.OrdType of
                     otSByte: result.FData.FAsSByte := PShortInt(ABuffer)^;
                     otUByte: result.FData.FAsUByte := PByte(ABuffer)^;
                     otSWord: result.FData.FAsSWord := PSmallInt(ABuffer)^;
                     otUWord: result.FData.FAsUWord := PWord(ABuffer)^;
                     otSLong: result.FData.FAsSLong := PLongInt(ABuffer)^;
                     otULong: result.FData.FAsULong := PLongWord(ABuffer)^;
                   else
                     // Silence compiler warning
                   end;
                 end;
    tkBool     : begin
                   case GetTypeData(ATypeInfo)^.OrdType of
                     otUByte: result.FData.FAsUByte := Byte(System.PBoolean(ABuffer)^);
                     otUWord: result.FData.FAsUWord := Word(PBoolean16(ABuffer)^);
                     otULong: result.FData.FAsULong := DWord(PBoolean32(ABuffer)^);
                     otUQWord: result.FData.FAsUInt64 := QWord(PBoolean64(ABuffer)^);
                     otSByte: result.FData.FAsSByte := ShortInt(PByteBool(ABuffer)^);
                     otSWord: result.FData.FAsSWord := SmallInt(PWordBool(ABuffer)^);
                     otSLong: result.FData.FAsSLong := LongInt(PLongBool(ABuffer)^);
                     otSQWord: result.FData.FAsSInt64 := Int64(PQWordBool(ABuffer)^);
                   end;
                 end;
    tkFloat    : begin
                   case GetTypeData(ATypeInfo)^.FloatType of
                     ftCurr   : result.FData.FAsCurr := PCurrency(ABuffer)^;
                     ftSingle : result.FData.FAsSingle := PSingle(ABuffer)^;
                     ftDouble : result.FData.FAsDouble := PDouble(ABuffer)^;
                     ftExtended: result.FData.FAsExtended := PExtended(ABuffer)^;
                     ftComp   : result.FData.FAsComp := PComp(ABuffer)^;
                   end;
                 end;
  else
    raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]);
  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;

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
  p: PByte;
  td: PTypeData;
{$endif}
begin
  if not Assigned(aTypeInfo) or
      not (aTypeInfo^.Kind in [tkInteger, tkInt64, tkQWord, tkEnumeration, tkBool, tkChar, tkWChar, tkUChar]) then
    raise EInvalidCast.Create(SErrInvalidTypecast);

{$ifdef ENDIAN_BIG}
  td := GetTypeData(aTypeInfo);
  p := @aValue;
  case td^.OrdType of
    otSByte,
    otUByte:
      p := p + 7;
    otSWord,
    otUWord:
      p := p + 6;
    otSLong,
    otULong:
      p := p + 4;
    otSQWord,
    otUQWord: ;
  end;
  TValue.Make(p, aTypeInfo, Result);
{$else}
  TValue.Make(@aValue, aTypeInfo, Result);
{$endif}
end;

class function TValue.FromArray(aArrayTypeInfo: PTypeInfo; const aValues: array of TValue): TValue; static;
var
  i, sz: SizeInt;
  data: TValueDataIntImpl;
begin
  Result.Init;
  Result.FData.FTypeInfo := aArrayTypeInfo;
  if not Assigned(aArrayTypeInfo) then
    Exit;
  if aArrayTypeInfo^.Kind = tkDynArray then begin
    data := TValueDataIntImpl.CreateRef(Nil, aArrayTypeInfo, True);
    sz := Length(aValues);
    DynArraySetLength(data.FBuffer, aArrayTypeInfo, 1, @sz);
    Result.FData.FValueData := data;
  end else if aArrayTypeInfo^.Kind = tkArray then begin
    if Result.GetArrayLength <> Length(aValues) then
      raise ERtti.CreateFmt(SErrLengthOfArrayMismatch, [Length(aValues), Result.GetArrayLength]);
    Result.FData.FValueData := TValueDataIntImpl.CreateCopy(Nil, Result.TypeData^.ArrayData.Size, aArrayTypeInfo, False);
  end else
    raise ERtti.CreateFmt(SErrTypeKindNotSupported, [aArrayTypeInfo^.Name]);
  for i := 0 to High(aValues) do
    Result.SetArrayElement(i, aValues[i]);
end;

class function TValue.FromVarRec(const aValue: TVarRec): TValue;

begin
  Result:=Default(TValue);
  case aValue.VType of
    vtInteger: Result:=aValue.VInteger;
    vtBoolean: Result:=aValue.VBoolean;
    vtWideChar: TValue.Make(@aValue.VWideChar,System.TypeInfo(WideChar),Result);
    vtInt64: Result:=aValue.VInt64^;
    vtQWord: Result:=aValue.VQWord^;
    vtChar: TValue.Make(@aValue.VChar,System.TypeInfo(AnsiChar),Result);
    vtPChar: Result:=string(aValue.VPChar);
    vtPWideChar: Result:=widestring(aValue.VPWideChar);
    vtString: Result:=aValue.VString^;
    vtWideString: Result:=WideString(aValue.VWideString);
    vtAnsiString: Result:=AnsiString(aValue.VAnsiString);
    vtUnicodeString: Result:=UnicodeString(aValue.VUnicodeString);
    vtObject: Result:=TObject(aValue.VObject);
    vtPointer: TValue.Make(@aValue.VPointer,System.TypeInfo(Pointer),Result);
    vtInterface: Result:=IInterface(aValue.VInterface);
    vtClass: Result:=aValue.VClass;
    vtVariant: TValue.Make(@aValue.VVariant^,System.TypeInfo(Variant),result);
    vtExtended: Result := aValue.VExtended^;
    vtCurrency: Result := aValue.VCurrency^;
  end;
end;

class function TValue.FromVariant(const aValue : Variant) : TValue;

var
  aType : TVarType;

begin
  Result:=Default(TValue);
  aType:=TVarData(aValue).vtype;
  case aType of
    varEmpty,
    VarNull : TValue.Make(@aValue,System.TypeInfo(Variant),Result);
    varInteger : Result:=Integer(aValue);
    varSmallInt : Result:=SmallInt(aValue);
    varBoolean : Result:=Boolean(aValue);
    varOleStr: Result:=WideString(aValue);
    varInt64: Result:=Int64(aValue);
    varQWord: Result:=QWord(aValue);
    varShortInt: Result:=ShortInt(aValue);
    varByte : Result:=Byte(aValue);
    varWord : Result:=Word(aValue);
    varLongWord : Result:=Cardinal(aValue);
    varSingle : Result:=Single(aValue);
    varDouble : Result:=Double(aValue);
    varDate : TValue.Make(@TVarData(aValue).vDate,System.TypeInfo(TDateTime),Result);
    varDispatch : TValue.Make(@TVarData(aValue).VDispatch,System.TypeInfo(IDispatch),Result);
    varError : TValue.Make(@TVarData(aValue).vDate,System.TypeInfo(HRESULT),Result);
    varUnknown : TValue.Make(@TVarData(aValue).vunknown,System.TypeInfo(IUnknown),Result);
    varCurrency : Result:=Currency(aValue);
    varString : Result:=AnsiString(aValue);
    varUString : Result:=UnicodeString(TVarData(aValue).vustring);
  else
    raise EVariantTypeCastError.CreateFmt('Invalid variant cast from type %d',[aType]);
  end;
end;


class function TValue.SameValue(const Left, Right: TValue): Boolean;
begin
  if Left.IsNumeric and Right.IsNumeric then
  begin
    if Left.IsOrdinal then
    begin
      if Right.IsOrdinal then
      begin
        Result := Left.AsOrdinal = Right.AsOrdinal;
      end else
      if Right.IsSingle then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsOrdinal, Right.AsSingle);
      end else
      if Right.IsDouble then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsOrdinal, Right.AsDouble);
      end
      else
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsOrdinal, Right.AsExtended);
      end;
    end else
    if Left.IsSingle then
    begin
      if Right.IsOrdinal then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsSingle, Right.AsOrdinal);
      end else
      if Right.IsSingle then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsSingle, Right.AsSingle);
      end else
      if Right.IsDouble then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsSingle, Right.AsDouble);
      end
      else
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsSingle, Right.AsExtended);
      end;
    end else
    if Left.IsDouble then
    begin
      if Right.IsOrdinal then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsDouble, Right.AsOrdinal);
      end else
      if Right.IsSingle then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsDouble, Right.AsSingle);
      end else
      if Right.IsDouble then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsDouble, Right.AsDouble);
      end
      else
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsDouble, Right.AsExtended);
      end;
    end
    else
    begin
      if Right.IsOrdinal then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsExtended, Right.AsOrdinal);
      end else
      if Right.IsSingle then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsExtended, Right.AsSingle);
      end else
      if Right.IsDouble then
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsExtended, Right.AsDouble);
      end
      else
      begin
        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Math.SameValue(Left.AsExtended, Right.AsExtended);
      end;
    end;
  end else
  if Left.IsString and Right.IsString then
  begin
    Result := Left.AsString = Right.AsString;
  end else
  if Left.IsClass and Right.IsClass then
  begin
    Result := Left.AsClass = Right.AsClass;
  end else
  if Left.IsObject and Right.IsObject then
  begin
    Result := Left.AsObject = Right.AsObject;
  end else
  if Left.IsPointer and Right.IsPointer then
  begin
    Result := Left.AsPointer = Right.AsPointer;
  end else
  if Left.IsVariant and Right.IsVariant then
  begin
    Result := Left.AsVariant = Right.AsVariant;
  end else
  if Left.TypeInfo = Right.TypeInfo then
  begin
    Result := Left.AsPointer = Right.AsPointer;
  end else
  begin
    Result := False;
  end;
end;

class function TValue.Equals(const Left, Right: array of TValue): Boolean;

var
  i: Integer;
begin
  Result := Length(Left) = Length(Right);
  if Result then
  begin
    for i := Low(Left) to High(Left) do
    begin
      if not SameValue(Left[i], Right[i]) then
      begin
        Result := False;
        Break;
      end;
    end
  end;
end;


function TValue.IsArray: boolean;
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.AsUnicodeString: UnicodeString;

begin
  if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then
    Result := ''
  else
    case Kind of
      tkSString:
        Result := UnicodeString(PShortString(FData.FValueData.GetReferenceToRawData)^);
      tkAString:
        Result := UnicodeString(PAnsiString(FData.FValueData.GetReferenceToRawData)^);
      tkWString:
        Result := UnicodeString(PWideString(FData.FValueData.GetReferenceToRawData)^);
      tkUString:
        Result := UnicodeString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^);
    else
      raise EInvalidCast.Create(SErrInvalidTypecast);
    end;
end;

function TValue.AsAnsiString: AnsiString;
begin
  if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then
    Result := ''
  else
    case Kind of
      tkSString:
        Result := AnsiString(PShortString(FData.FValueData.GetReferenceToRawData)^);
      tkAString:
        Result := AnsiString(PAnsiString(FData.FValueData.GetReferenceToRawData)^);
      tkWString:
        Result := AnsiString(PWideString(FData.FValueData.GetReferenceToRawData)^);
      tkUString:
        Result := AnsiString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^);
    else
      raise EInvalidCast.Create(SErrInvalidTypecast);
    end;
end;

function TValue.AsExtended: Extended;
begin
  if Kind = tkFloat then
    begin
    case TypeData^.FloatType of
      ftSingle   : result := FData.FAsSingle;
      ftDouble   : result := FData.FAsDouble;
      ftExtended : result := FData.FAsExtended;
      ftCurr     : result := FData.FAsCurr;
      ftComp     : result := FData.FAsComp;
    else
      raise EInvalidCast.Create(SErrInvalidTypecast);
    end;
    end
  else if Kind in [tkInteger, tkInt64, tkQWord] then
    Result := AsInt64
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;



function TValue.TryCast(aTypeInfo: PTypeInfo; out aResult: TValue; const aEmptyAsAnyType: Boolean = True): Boolean;

begin
  Result:=False;
  if aEmptyAsAnyType and IsEmpty then
    begin
    aResult:=TValue.Empty;
    if (aTypeInfo=nil) then
      exit;
    AResult.FData.FTypeInfo:=aTypeInfo;
    Exit(True);
    end;
  if not aEmptyAsAnyType and (Self.TypeInfo=nil) then
    Exit;
  if (Self.TypeInfo=ATypeInfo) then
    begin
    aResult:=Self;
    Exit(True);
    end;
  if Not Assigned(aTypeInfo) then
    Exit;
  if (aTypeInfo=System.TypeInfo(TValue)) then
    begin
    TValue.Make(@Self,System.TypeInfo(TValue),aResult);
    Exit(True);
    end;
  CastFromType(Result,aResult,ATypeInfo);
end;

function TValue.Cast(aTypeInfo: PTypeInfo; const aEmptyAsAnyType: Boolean = True): TValue; overload;

begin
  if not TryCast(aTypeInfo,Result,aEmptyAsAnyType) then
    raise EInvalidCast.Create(SInvalidCast);
end;

generic function TValue.AsType<T>(const aEmptyAsAnyType: Boolean = True): T;

begin
  if not (specialize TryAsType<T>(Result,aEmptyAsAnyType)) then
    raise EInvalidCast.Create(SInvalidCast);
end;

generic function TValue.Cast<T>(const aEmptyAsAnyType: Boolean = True): TValue; overload;

var
  Info : PTypeInfo;

begin
  Info:=System.TypeInfo(T);
  if not TryCast(Info,Result,aEmptyAsAnyType) then
    raise EInvalidCast.Create(SInvalidCast);
end;

generic function TValue.TryAsType<T>(out aResult: T; const aEmptyAsAnyType: Boolean = True): Boolean; inline;

var
  Tmp: TValue;
  Info : PTypeInfo;  
begin
  Info:=System.TypeInfo(T);
  Result:=TryCast(Info,Tmp,aEmptyAsAnyType);
  if Result then
    if Assigned(Tmp.TypeInfo) then
      Tmp.ExtractRawData(@aResult)
    else  
      aResult:=Default(T);
end;   

function TValue.AsObject: TObject;
begin
  if IsObject or (IsClass and not Assigned(FData.FAsObject)) then
    result := TObject(FData.FAsObject)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsClass: TClass;
begin
  if IsClass then
    result := FData.FAsClass
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsBoolean: boolean;
begin
  if (Kind = tkBool) then
    case TypeData^.OrdType of
      otSByte:  Result := ByteBool(FData.FAsSByte);
      otUByte:  Result := Boolean(FData.FAsUByte);
      otSWord:  Result := WordBool(FData.FAsSWord);
      otUWord:  Result := Boolean16(FData.FAsUWord);
      otSLong:  Result := LongBool(FData.FAsSLong);
      otULong:  Result := Boolean32(FData.FAsULong);
      otSQWord: Result := QWordBool(FData.FAsSInt64);
      otUQWord: Result := Boolean64(FData.FAsUInt64);
    end
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.IsNumeric: boolean;

begin
  Result := Kind in [tkInteger, tkChar, tkEnumeration, tkFloat, tkWChar, tkInt64];
end;

function TValue.IsSingle : boolean;

begin
  Result:=(Kind=tkFloat) and (TypeData^.FloatType=ftSingle);
end;

function TValue.IsCurrency : boolean;

begin
  Result:=(Kind=tkFloat) and (TypeData^.FloatType=ftCurr);
end;

function TValue.IsDouble : boolean;

begin
  Result:=(Kind=tkFloat) and (TypeData^.FloatType=ftDouble);
end;

function TValue.IsExtended: boolean;
begin
  Result:=(Kind=tkFloat) and (TypeData^.FloatType=ftExtended);
end;

function TValue.IsString: boolean;
begin
  Result := Kind in [tkChar, tkSString, tkWChar, tkAString, tkWString, tkUString];
end;

function TValue.IsPointer: boolean;
begin
  Result:=kind=tkPointer;
end;

function TValue.IsVariant: boolean;
begin
  Result:=kind=tkVariant;
end;

function TValue.AsOrdinal: Int64;
begin
  if IsOrdinal then
    if Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown] then
      Result := 0
    else
      case TypeData^.OrdType of
        otSByte:  Result := FData.FAsSByte;
        otUByte:  Result := FData.FAsUByte;
        otSWord:  Result := FData.FAsSWord;
        otUWord:  Result := FData.FAsUWord;
        otSLong:  Result := FData.FAsSLong;
        otULong:  Result := FData.FAsULong;
        otSQWord: Result := FData.FAsSInt64;
        otUQWord: Result := FData.FAsUInt64;
      end
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;


function TValue.AsCurrency: Currency;
begin
  if (Kind = tkFloat) and (TypeData^.FloatType=ftCurr) then
    result := FData.FAsCurr
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsSingle: Single;

begin
  if Kind = tkFloat then
    begin
    case TypeData^.FloatType of
      ftSingle   : result := FData.FAsSingle;
      ftDouble   : result := FData.FAsDouble;
      ftExtended : result := FData.FAsExtended;
      ftCurr     : result := FData.FAsCurr;
      ftComp     : result := FData.FAsComp;
    else
      raise EInvalidCast.Create(SErrInvalidTypecast);
    end;
    end
  else if Kind in [tkInteger, tkInt64, tkQWord] then
    Result := AsInt64
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsDateTime: TDateTime;

begin
  if (Kind = tkFloat) and (TypeData^.FloatType=ftDouble) and IsDateTimeType(TypeInfo) then
    result := FData.FAsDouble
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;


function TValue.AsDouble: Double;
begin
  if Kind = tkFloat then
    begin
    case TypeData^.FloatType of
      ftSingle   : result := FData.FAsSingle;
      ftDouble   : result := FData.FAsDouble;
      ftExtended : result := FData.FAsExtended;
      ftCurr     : result := FData.FAsCurr;
      ftComp     : result := FData.FAsComp;
    else
      raise EInvalidCast.Create(SErrInvalidTypecast);
    end;
    end
  else if Kind in [tkInteger, tkInt64, tkQWord] then
    Result := AsInt64
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;


function TValue.AsError: HRESULT;

begin
  if (Kind = tkInteger) and (TypeInfo=System.TypeInfo(HRESULT)) then
    result := HResult(AsInteger)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsInteger: Integer;
begin
  if Kind in [tkInteger, tkInt64, tkQWord] then
    case TypeData^.OrdType of
      otSByte:  Result := FData.FAsSByte;
      otUByte:  Result := FData.FAsUByte;
      otSWord:  Result := FData.FAsSWord;
      otUWord:  Result := FData.FAsUWord;
      otSLong:  Result := FData.FAsSLong;
      otULong:  Result := FData.FAsULong;
      otSQWord: Result := FData.FAsSInt64;
      otUQWord: Result := FData.FAsUInt64;
    end
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsAnsiChar: AnsiChar;
begin
  if Kind = tkChar then
    Result := Chr(FData.FAsUByte)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsWideChar: WideChar;
begin
  if Kind = tkWChar then
    Result := WideChar(FData.FAsUWord)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsChar: AnsiChar;
begin
{$if SizeOf(AnsiChar) = 1}
  Result := AsAnsiChar;
{$else}
  Result := AsWideChar;
{$endif}
end;

function TValue.AsPointer : Pointer;

begin
  if Kind in [tkPointer, tkInterface, tkInterfaceRaw, tkClass,tkClassRef,tkAString,tkWideString,tkUnicodeString] then
    Result:=FData.FAsPointer
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsVariant : Variant;

begin
  if (Kind=tkVariant) then
    Result:= PVariant(FData.FValueData.GetReferenceToRawData)^
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsInt64: Int64;
begin
  if Kind in [tkInteger, tkInt64, tkQWord] then
    case TypeData^.OrdType of
      otSByte:  Result := FData.FAsSByte;
      otUByte:  Result := FData.FAsUByte;
      otSWord:  Result := FData.FAsSWord;
      otUWord:  Result := FData.FAsUWord;
      otSLong:  Result := FData.FAsSLong;
      otULong:  Result := FData.FAsULong;
      otSQWord: Result := FData.FAsSInt64;
      otUQWord: Result := FData.FAsUInt64;
    end
  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
    Result := Int64(FData.FAsComp)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsUInt64: QWord;
begin
  if Kind in [tkInteger, tkInt64, tkQWord] then
    case TypeData^.OrdType of
      otSByte:  Result := FData.FAsSByte;
      otUByte:  Result := FData.FAsUByte;
      otSWord:  Result := FData.FAsSWord;
      otUWord:  Result := FData.FAsUWord;
      otSLong:  Result := FData.FAsSLong;
      otULong:  Result := FData.FAsULong;
      otSQWord: Result := FData.FAsSInt64;
      otUQWord: Result := FData.FAsUInt64;
    end
  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
    Result := QWord(FData.FAsComp)
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.AsInterface: IInterface;
begin
  if Kind = tkInterface then
    Result := PInterface(FData.FValueData.GetReferenceToRawData)^
  else if (Kind in [tkClass, tkClassRef, tkUnknown]) and not Assigned(FData.FAsPointer) then
    Result := Nil
  else
    raise EInvalidCast.Create(SErrInvalidTypecast);
end;

function TValue.ToString: String;

begin
 Result:=ToString(TFormatSettings.Invariant);   
end;

function TValue.ToString(aSettings : TFormatSettings): 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
    Exit('(empty)');
  case Kind of
    tkWString,
    tkUString : result := AsUnicodeString;
    tkSString,
    tkAString : result := AsAnsiString;
    tkFloat   :
      begin
      Case TypeData^.FloatType of
        ftDouble : Result := FloatToStr(AsDouble,aSettings);
        ftExtended : Result := FloatToStr(AsExtended,aSettings);
        ftSingle : Result := FloatToStr(AsSingle,aSettings);
        ftCurr : Result:=CurrToStr(AsCurrency,aSettings);
      end;
    end;
    tkInteger : result := IntToStr(AsInteger);
    tkQWord   : result := IntToStr(AsUInt64);
    tkInt64   : result := IntToStr(AsInt64);
    tkBool    : result := BoolToStr(AsBoolean, True);
    tkPointer : result := '(pointer @ ' + HexStr(FData.FAsPointer) + ')';
    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 : 
      begin
      Obj:=AsObject;
      if Assigned(Obj) then
        Result:=Obj.ToString
      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;
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 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
    raise EInvalidCast.Create(SErrInvalidTypecast);
  if Kind = tkDynArray then begin
    data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo);
    eltype := TypeData^.elType2;
  end else begin
    td := TypeData;
    eltype := td^.ArrayData.ElType;
    { 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);
end;

procedure TValue.SetArrayElement(AIndex: SizeInt; constref AValue: TValue);
var
  data: Pointer;
  eltype: PTypeInfo;
  elsize: SizeInt;
  td, tdv: PTypeData;
begin
  if not IsArray then
    raise EInvalidCast.Create(SErrInvalidTypecast);
  if Kind = tkDynArray then begin
    data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo);
    eltype := TypeData^.elType2;
  end else begin
    td := TypeData;
    eltype := td^.ArrayData.ElType;
    { 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
    raise EInvalidCast.Create(SErrInvalidTypecast);
  td := GetTypeData(eltype);
  tdv := AValue.TypeData;
  if ((eltype^.Kind in [tkInteger, tkBool, tkEnumeration, tkSet]) and (td^.OrdType <> tdv^.OrdType)) or
      ((eltype^.Kind = tkFloat) and (td^.FloatType <> tdv^.FloatType)) then
    raise EInvalidCast.Create(SErrInvalidTypecast);
  if Assigned(AValue.FData.FValueData) and (eltype^.Kind <> tkSString) then
    IntCopy(AValue.FData.FValueData.GetReferenceToRawData, data, eltype)
  else
    Move(AValue.GetReferenceToRawData^, data^, AValue.DataSize);
end;

function TValue.TryAsOrdinal(out AResult: int64): boolean;
begin
  result := IsOrdinal;
  if result then
    AResult := AsOrdinal;
end;

function TValue.GetReferenceToRawData: Pointer;
begin
  if not Assigned(FData.FTypeInfo) then
    Result := Nil
  else if Assigned(FData.FValueData) then
    Result := FData.FValueData.GetReferenceToRawData
  else begin
    Result := Nil;
    case Kind of
      tkInteger,
      tkEnumeration,
      tkInt64,
      tkQWord,
      tkBool:
        case TypeData^.OrdType of
          otSByte:
            Result := @FData.FAsSByte;
          otUByte:
            Result := @FData.FAsUByte;
          otSWord:
            Result := @FData.FAsSWord;
          otUWord:
            Result := @FData.FAsUWord;
          otSLong:
            Result := @FData.FAsSLong;
          otULong:
            Result := @FData.FAsULong;
          otSQWord:
            Result := @FData.FAsSInt64;
          otUQWord:
            Result := @FData.FAsUInt64;
        end;
      tkSet: begin
        case TypeData^.OrdType of
          otUByte: begin
            case TypeData^.SetSize of
              1:
                Result := @FData.FAsUByte;
              2:
                Result := @FData.FAsUWord;
              3, 4:
                Result := @FData.FAsULong;
              5..8:
                Result := @FData.FAsUInt64;
              else
                { this should have gone through FAsValueData :/ }
                Result := Nil;
            end;
          end;
          otUWord:
            Result := @FData.FAsUWord;
          otULong:
            Result := @FData.FAsULong;
          else
            Result := Nil;
        end;
      end;
      tkChar:
        Result := @FData.FAsUByte;
      tkFloat:
        case TypeData^.FloatType of
          ftSingle:
            Result := @FData.FAsSingle;
          ftDouble:
            Result := @FData.FAsDouble;
          ftExtended:
            Result := @FData.FAsExtended;
          ftComp:
            Result := @FData.FAsComp;
          ftCurr:
            Result := @FData.FAsCurr;
        end;
      tkMethod:
        Result := @FData.FAsMethod;
      tkClass:
        Result := @FData.FAsObject;
      tkWChar:
        Result := @FData.FAsUWord;
      tkInterfaceRaw:
        Result := @FData.FAsPointer;
      tkProcVar:
        Result := @FData.FAsMethod.Code;
      tkUChar:
        Result := @FData.FAsUWord;
      tkFile:
        Result := @FData.FAsPointer;
      tkClassRef:
        Result := @FData.FAsClass;
      tkPointer:
        Result := @FData.FAsPointer;
      tkVariant,
      tkDynArray,
      tkArray,
      tkObject,
      tkRecord,
      tkInterface,
      tkSString,
      tkLString,
      tkAString,
      tkUString,
      tkWString:
        Assert(false, 'Managed/complex type not handled through IValueData');
    else
      // Silence compiler warning
    end;
  end;
end;

procedure TValue.ExtractRawData(ABuffer: Pointer);
begin
  if Assigned(FData.FValueData) then
    FData.FValueData.ExtractRawData(ABuffer)
  else if Assigned(FData.FTypeInfo) then
    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
end;

procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer);
begin
  if Assigned(FData.FValueData) then
    FData.FValueData.ExtractRawDataNoCopy(ABuffer)
  else if Assigned(FData.FTypeInfo) then
    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
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
    raise ENotImplemented.Create(SErrCallbackNotImplemented);

  if not Assigned(aHandler) then
    raise EArgumentNilException.Create(SErrCallbackHandlerNil);

  Result := FuncCallMgr[aCallConv].CreateCallbackProc(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
end;

function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
begin
  if not Assigned(FuncCallMgr[aCallConv].CreateCallbackMethod) then
    raise ENotImplemented.Create(SErrCallbackNotImplemented);

  if not Assigned(aHandler) then
    raise EArgumentNilException.Create(SErrCallbackHandlerNil);

  Result := FuncCallMgr[aCallConv].CreateCallbackMethod(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
end;

function IsManaged(TypeInfo: PTypeInfo): boolean;
begin
  if Assigned(TypeInfo) then
    case TypeInfo^.Kind of
      tkAString,
      tkLString,
      tkWString,
      tkUString,
      tkInterface,
      tkVariant,
      tkDynArray  : Result := true;
      tkArray     : Result := IsManaged(GetTypeData(TypeInfo)^.ArrayData.ElType);
      tkRecord,
      tkObject    :
        with GetTypeData(TypeInfo)^.RecInitData^ do
          Result := (ManagedFieldCount > 0) or Assigned(ManagementOp);
    else
      Result := false;
    end
  else
    Result := false;
end;

function IsBoolType(ATypeInfo: PTypeInfo): Boolean;

begin
  Result:=(ATypeInfo=TypeInfo(Boolean)) or
          (ATypeInfo=TypeInfo(ByteBool)) or
          (ATypeInfo=TypeInfo(WordBool)) or
          (ATypeInfo=TypeInfo(LongBool));
end;


{$ifndef InLazIDE}
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
var
  arr: specialize TArray<T>;
  i: SizeInt;
begin
  arr:=[];
  SetLength(arr, Length(aArray));
  for i := 0 to High(aArray) do
    arr[i] := aArray[i];
  Result := TValue.specialize From<specialize TArray<T>>(arr);
end;
{$endif}

function ArrayOfConstToTValueArray(const aValues: array of const): TValueArray;

var
  I,Len: Integer;

begin
  Result:=[];
  Len:=Length(aValues);
  SetLength(Result,Len);
  for I:=0 to Len-1 do
    Result[I]:=aValues[I];
end;

{ TRttiPointerType }

function TRttiPointerType.GetReferredType: TRttiType;
begin
  Result := GRttiPool[FUsePublishedOnly].GetType(FTypeData^.RefType);
end;

{ TRttiArrayType }

function TRttiArrayType.GetDimensionCount: SizeUInt;
begin
  Result := FTypeData^.ArrayData.DimCount;
end;

function TRttiArrayType.GetDimension(aIndex: SizeInt): TRttiType;
begin
  if aIndex >= FTypeData^.ArrayData.DimCount then
    raise ERtti.CreateFmt(SErrDimensionOutOfRange, [aIndex, FTypeData^.ArrayData.DimCount]);
  Result := GRttiPool[FUsePublishedOnly].GetType(FTypeData^.ArrayData.Dims[Byte(aIndex)]);
end;

function TRttiArrayType.GetElementType: TRttiType;
begin
  Result := GRttiPool[FUsePublishedOnly].GetType(FTypeData^.ArrayData.ElType);
end;

function TRttiArrayType.GetTotalElementCount: SizeInt;
begin
  Result := FTypeData^.ArrayData.ElCount;
end;

{ TRttiDynamicArrayType }

function TRttiDynamicArrayType.GetDeclaringUnitName: String;
begin
  Result := FTypeData^.DynUnitName;
end;

function TRttiDynamicArrayType.GetElementSize: SizeUInt;
begin
  Result := FTypeData^.elSize;
end;

function TRttiDynamicArrayType.GetElementType: TRttiType;
begin
  Result := GRttiPool[FUsePublishedOnly].GetType(FTypeData^.ElType2);
end;

function TRttiDynamicArrayType.GetOleAutoVarType: TVarType;
begin
  Result := Word(FTypeData^.varType);
end;

{ TRttiRefCountedInterfaceType }

function TRttiRefCountedInterfaceType.IntfData: PInterfaceData;
begin
  Result := PInterfaceData(FTypeData);
end;

function TRttiRefCountedInterfaceType.MethodTable: PIntfMethodTable;
begin
  Result := IntfData^.MethodTable;
end;

function TRttiRefCountedInterfaceType.GetIntfBaseType: TRttiInterfaceType;
begin
  Result := nil;
  if Assigned(IntfData^.Parent) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(IntfData^.Parent^) as TRttiInterfaceType;
end;

function TRttiRefCountedInterfaceType.GetDeclaringUnitName: String;
begin
  Result := IntfData^.UnitName;
end;

function TRttiRefCountedInterfaceType.GetGUID: TGUID;
begin
  Result := IntfData^.GUID;
end;

function TRttiRefCountedInterfaceType.GetIntfFlags: TIntfFlags;
begin
  Result := IntfData^.Flags;
end;

function TRttiRefCountedInterfaceType.GetIntfType: TInterfaceType;
begin
  Result := itRefCounted;
end;

{ TRttiRawInterfaceType }

function TRttiRawInterfaceType.IntfData: PInterfaceRawData;
begin
  Result := PInterfaceRawData(FTypeData);
end;

function TRttiRawInterfaceType.MethodTable: PIntfMethodTable;
begin
  { currently there is none! }
  Result := Nil;
end;

function TRttiRawInterfaceType.GetIntfBaseType: TRttiInterfaceType;
var
  context: TRttiContext;
begin
  Result := nil;
  if Assigned(IntfData^.Parent) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(IntfData^.Parent^) as TRttiInterfaceType;
end;

function TRttiRawInterfaceType.GetDeclaringUnitName: String;
begin
  Result := IntfData^.UnitName;
end;

function TRttiRawInterfaceType.GetGUID: TGUID;
begin
  Result := IntfData^.IID;
end;

function TRttiRawInterfaceType.GetGUIDStr: String;
begin
  Result := IntfData^.IIDStr;
end;

function TRttiRawInterfaceType.GetIntfFlags: TIntfFlags;
begin
  Result := IntfData^.Flags;
end;

function TRttiRawInterfaceType.GetIntfType: TInterfaceType;
begin
  Result := itRaw;
end;

{ TRttiVmtMethodParameter }

function TRttiVmtMethodParameter.GetHandle: Pointer;
begin
  Result := FVmtMethodParam;
end;

function TRttiVmtMethodParameter.GetName: String;
begin
  Result := FVmtMethodParam^.Name;
end;

function TRttiVmtMethodParameter.GetFlags: TParamFlags;
begin
  Result := FVmtMethodParam^.Flags;
end;

function TRttiVmtMethodParameter.GetParamType: TRttiType;
begin
  Result := nil;
  if Assigned(FVmtMethodParam^.ParamType) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(FVmtMethodParam^.ParamType^);
end;

constructor TRttiVmtMethodParameter.Create(AVmtMethodParam: PVmtMethodParam);
begin
  inherited Create;
  FVmtMethodParam := AVmtMethodParam;
end;

function TRttiVmtMethodParameter.GetAttributes: TCustomAttributeArray;
begin
  Result:=Nil;
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;
begin
  Result := TRttiContext.Create(FUsePublishedOnly).GetType(FType);
end;

constructor TRttiMethodTypeParameter.Create(aHandle: Pointer; const aName: String; aFlags: TParamFlags; aType: PTypeInfo);
begin
  fHandle := aHandle;
  fName := aName;
  fFlags := aFlags;
  fType := aType;
end;

function TRttiMethodTypeParameter.GetAttributes: TCustomAttributeArray;
begin
  Result:=Nil;
end;

{ TRttiIntfMethod }

function TRttiIntfMethod.GetHandle: Pointer;
begin
  Result := FIntfMethodEntry;
end;

function TRttiIntfMethod.GetName: String;
begin
  Result := FIntfMethodEntry^.Name;
end;

function TRttiIntfMethod.GetCallingConvention: TCallConv;
begin
  Result := FIntfMethodEntry^.CC;
end;

function TRttiIntfMethod.GetCodeAddress: CodePointer;
begin
  Result := Nil;
end;

function TRttiIntfMethod.GetDispatchKind: TDispatchKind;
begin
  Result := dkInterface;
end;

function TRttiIntfMethod.GetHasExtendedInfo: Boolean;
begin
  Result := True;
end;

function TRttiIntfMethod.GetIsClassMethod: Boolean;
begin
  Result := False;
end;

function TRttiIntfMethod.GetIsConstructor: Boolean;
begin
  Result := False;
end;

function TRttiIntfMethod.GetIsDestructor: Boolean;
begin
  Result := False;
end;

function TRttiIntfMethod.GetIsStatic: Boolean;
begin
  Result := False;
end;

function TRttiIntfMethod.GetMethodKind: TMethodKind;
begin
  Result := FIntfMethodEntry^.Kind;
end;

function TRttiIntfMethod.GetReturnType: TRttiType;
begin
  Result := nil;
  if Assigned(FIntfMethodEntry^.ResultType) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(FIntfMethodEntry^.ResultType^);
end;

function TRttiIntfMethod.GetVirtualIndex: SmallInt;
begin
  Result := FIndex;
end;

constructor TRttiIntfMethod.Create(AParent: TRttiType; AIntfMethodEntry: PIntfMethodEntry; AIndex: SmallInt);
begin
  inherited Create(AParent);
  FIntfMethodEntry := AIntfMethodEntry;
  FIndex := AIndex;
end;

function TRttiIntfMethod.GetAttributes: TCustomAttributeArray;
{var
  i: SizeInt;
  at: PAttributeTable;}
begin
  FAttributes:=Nil;
  FAttributesResolved:=True;
{ // needs extended RTTI branch
  if not FAttributesResolved then
    begin
      at := FIntfMethodEntry^.Attributes
      if Assigned(at) then
        begin
          SetLength(FAttributes, at^.AttributeCount);
          for i := 0 to High(FAttributes) do
            FAttributes[i] := TCustomAttribute({$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(at, i));
        end;
      FAttributesResolved:=true;
    end;
}
  result := FAttributes;

end;

function TRttiIntfMethod.GetParameters(aWithHidden: Boolean): TRttiParameterArray;
var
  param: PVmtMethodParam;
  total, visible: SizeInt;
  context: TRttiContext;
  obj: TRttiObject;
begin
  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(FUsePublishedOnly);
  total := 0;
  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
      FParams[visible] := FParamsAll[total];
      Inc(visible);
    end;

    param := param^.Next;
    Inc(total);
  end;

  if visible <> total then
    SetLength(FParams, visible);

  if aWithHidden then
    Result := FParamsAll
  else
    Result := FParams;
end;

function TRttiIntfMethod.Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
var
  {$IFDEF USE_INVOKE_HELPER}
  Intf : IInterface;
  InstPtr : Pointer;
  {$ELSE}
  addr: CodePointer;
  vmt: PCodePointer;
  {$ENDIF}
begin
  if IsStatic and not aInstance.IsEmpty then
    raise EInvocationError.CreateFmt(SErrInvokeStaticNoSelf, [Name]);

{$IFDEF USE_INVOKE_HELPER}
  // Until extended info is available.
  Intf:=aInstance.AsInterface;
  if not Supports(Intf,TRttiInterfaceType(Parent).GUID,InstPtr) then
    raise EInvocationError.Create(SErrInvokeInsufficientRtti);
  Result:=HandleInvokeHelper(Parent.handle,InstPtr,aArgs);
{$ELSE}
  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;

  Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
{$endif}
end;

{ TRttiInt64Type }

function TRttiInt64Type.GetMaxValue: Int64;
begin
  Result := FTypeData^.MaxInt64Value;
end;

function TRttiInt64Type.GetMinValue: Int64;
begin
  Result := FTypeData^.MinInt64Value;
end;

function TRttiInt64Type.GetUnsigned: Boolean;
begin
  Result := FTypeData^.OrdType = otUQWord;
end;

function TRttiInt64Type.GetTypeSize: integer;
begin
  Result := SizeOf(QWord);
end;

{ TRttiOrdinalType }

function TRttiOrdinalType.GetMaxValue: LongInt;
begin
  Result := FTypeData^.MaxValue;
end;

function TRttiOrdinalType.GetMinValue: LongInt;
begin
  Result := FTypeData^.MinValue;
end;

function TRttiOrdinalType.GetOrdType: TOrdType;
begin
  Result := FTypeData^.OrdType;
end;

function TRttiOrdinalType.GetIsOrdinal: Boolean;
begin
  Result:=True;
end;

function TRttiOrdinalType.GetTypeSize: Integer;
begin
  case OrdType of
    otSByte,
    otUByte:
      Result := SizeOf(Byte);
    otSWord,
    otUWord:
      Result := SizeOf(Word);
    otSLong,
    otULong:
      Result := SizeOf(LongWord);
    otSQWord,
    otUQWord:
      Result := SizeOf(QWord);
  end;
end;

{ TRttiEnumerationType }

function TRttiEnumerationType.GetUnderlyingType: TRttiType;

begin
  Result:=GRttiPool[FUsePublishedOnly].GetType(GetTypeData(Handle)^.BaseType);
end;


function TRttiEnumerationType.GetNames: TStringDynArray;

var
  I : Integer;

begin
  Result:=[];
  SetLength(Result,GetEnumNameCount(Handle));
  For I:=0 to Length(Result)-1 do
    Result[I]:=GetEnumName(Handle,I);
end;

generic class function TRttiEnumerationType.GetName<T{: enum}>(AValue: T): string;

var
  Info : PTypeInfo;

begin
  Info:=PtypeInfo(TypeInfo(T));
  if Not (Info^.kind in [tkBool,tkEnumeration]) then
    raise EInvalidCast.CreateFmt(SErrNotEnumeratedType,[PtypeInfo(TypeInfo(T))^.name]);
  Result:=GetEnumName(Info,Ord(aValue))
end;

generic class function TRttiEnumerationType.GetValue<T{: enum}>(const AName: string): T;

var
  Info : PTypeInfo;

begin
  Info:=PtypeInfo(TypeInfo(T));
  if Not (Info^.kind in [tkBool,tkEnumeration]) then
    raise EInvalidCast.CreateFmt(SErrNotEnumeratedType,[PtypeInfo(TypeInfo(T))^.name]);
  Result:=T(GetEnumValue(Info,aName))
end;


{ TRttiFloatType }

function TRttiFloatType.GetFloatType: TFloatType;
begin
  result := FTypeData^.FloatType;
end;

function TRttiFloatType.GetTypeSize: integer;
begin
  case FloatType of
    ftSingle:
      Result := SizeOf(Single);
    ftDouble:
      Result := SizeOf(Double);
    ftExtended:
      Result := SizeOf(Extended);
    ftComp:
      Result := SizeOf(Comp);
    ftCurr:
      Result := SizeOf(Currency);
  end;
end;

{ TRttiParameter }

function TRttiParameter.ToString: String;
var
  f: TParamFlags;
  n: String;
  t: TRttiType;
begin
  if FString = '' then begin
    f := Flags;

    if pfVar in f then
      FString := 'var'
    else if pfConst in f then
      FString := 'const'
    else if pfOut in f then
      FString := 'out'
    else if pfConstRef in f then
      FString := 'constref';
    if FString <> '' then
      FString := FString + ' ';

    n := Name;
    if n = '' then
      n := '<unknown>';
    FString := FString + n;

    t := ParamType;
    if Assigned(t) then begin
      FString := FString + ': ';
      if pfArray in flags then
        FString := 'array of ';
      FString := FString + t.Name;
    end;
  end;

  Result := FString;
end;

{ TMethodImplementation }

function TMethodImplementation.GetCodeAddress: CodePointer;
begin
  Result := fLowLevelCallback.CodeAddress;
end;

procedure TMethodImplementation.InitArgs;
var
  i, refargs: SizeInt;
begin
  i := 0;
  refargs := 0;
  SetLength(fRefArgs, Length(fArgs));
  while i < Length(fArgs) do begin
    if (fArgs[i].ParamFlags * [pfVar, pfOut] <> []) and not (pfHidden in fArgs[i].ParamFlags) then begin
      fRefArgs[refargs] := fArgLen;
      Inc(refargs);
    end;

    if pfArray in fArgs[i].ParamFlags then begin
      Inc(i);
      if (i = Length(fArgs)) or not (pfHigh in fArgs[i].ParamFlags) then
        raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
      Inc(fArgLen);
    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then
      Inc(fArgLen)
    else if (pfResult in fArgs[i].ParamFlags) then
      fResult := fArgs[i].ParamType;

    Inc(i);
  end;

  SetLength(fRefArgs, refargs);
end;

procedure TMethodImplementation.HandleCallback(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
var
  i, argidx, validx: SizeInt;
  args: TValueArray;
  res: TValue;
begin
  Assert(fArgLen = Length(aArgs), 'Length of arguments does not match');
  args:=[];
  SetLength(args, fArgLen);
  argidx := 0;
  validx := 0;
  i := 0;
  while i < Length(fArgs) do begin
    if pfArray in fArgs[i].ParamFlags then begin
      Inc(validx);
      Inc(i);
      Assert((i < Length(fArgs)) and (pfHigh in fArgs[i].ParamFlags), 'Expected high parameter after open array parameter');
      TValue.MakeOpenArray(aArgs[validx - 1], SizeInt(aArgs[validx]), fArgs[i].ParamType, args[argidx]);
      Inc(argidx);
      Inc(validx);
    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then begin
      if Assigned(fArgs[i].ParamType) then
        TValue.Make(aArgs[validx], fArgs[i].ParamType, args[argidx])
      else
        TValue.Make(@aArgs[validx], TypeInfo(Pointer), args[argidx]);
      Inc(argidx);
      Inc(validx);
    end;

    Inc(i);
  end;

  fCallback(aContext, args, res);

  { copy back var/out parameters }
  for i := 0 to High(fRefArgs) do begin
    args[fRefArgs[i]].ExtractRawData(aArgs[fRefArgs[i]]);
  end;

  if Assigned(fResult) then
    res.ExtractRawData(aResult);
end;

constructor TMethodImplementation.Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallback);
begin
  fCC := aCC;
  fArgs := aArgs;
  fResult := aResult;
  fFlags := aFlags;
  fCallback := aCallback;
  InitArgs;
  fLowLevelCallback := CreateCallbackMethod(@HandleCallback, fCC, aArgs, aResult, aFlags, aUserData);
  if not Assigned(fLowLevelCallback) then
    raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
end;

constructor TMethodImplementation.Create;
begin
  raise EInvalidOpException.Create(SErrMethodImplCreateNoArg);
end;

destructor TMethodImplementation.Destroy;
begin
  fLowLevelCallback.Free;
  inherited Destroy;
end;

{ TRttiMethod }

function TRttiMethod.GetHasExtendedInfo: Boolean;
begin
  Result := False;
end;

function TRttiMethod.GetFlags: TFunctionCallFlags;
begin
  Result := [];
  if IsStatic then
    Include(Result, fcfStatic);
end;

function TRttiMethod.GetParameters: TRttiParameterArray;
begin
  Result := GetParameters(False);
end;

function TRttiMethod.ToString: String;
var
  ret: TRttiType;
  n: String;
  params: TRttiParameterArray;
  i: LongInt;
begin
  if FString = '' then begin
    n := Name;
    if n = '' then
      n := '<unknown>';
    if not HasExtendedInfo then begin
      FString := 'method ' + n;
    end else begin
      ret := ReturnType;

      if IsClassMethod then
        FString := 'class ';
      if IsConstructor then
        FString := FString + 'constructor'
      else if IsDestructor then
        FString := FString + 'destructor'
      else if Assigned(ret) then
        FString := FString + 'function'
      else
        FString := FString + 'procedure';

      FString := FString + ' ' + n;

      params := GetParameters;
      if Length(params) > 0 then begin
        FString := FString + '(';
        for i := 0 to High(params) do begin
          if i > 0 then
            FString := FString + '; ';
          FString := FString + params[i].ToString;
        end;
        FString := FString + ')';
      end;

      if Assigned(ret) then
        FString := FString + ': ' + ret.Name;

      if IsStatic then
        FString := FString + '; static';
    end;
  end;

  Result := FString;
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.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
var
  params: TRttiParameterArray;
  args: specialize TArray<TFunctionCallParameterInfo>;
  res: PTypeInfo;
  restype: TRttiType;
  resinparam: Boolean;
  i: SizeInt;
begin
  if not Assigned(aCallback) then
    raise EArgumentNilException.Create(SErrMethodImplNoCallback);

  resinparam := False;
  params := GetParameters(True);
  args:=[];
  SetLength(args, Length(params));
  for i := 0 to High(params) do begin
    if Assigned(params[i].ParamType) then
      args[i].ParamType := params[i].ParamType.FTypeInfo
    else
      args[i].ParamType := Nil;
    args[i].ParamFlags := params[i].Flags;
    args[i].ParaLocs := Nil;
    if pfResult in params[i].Flags then
      resinparam := True;
  end;

  restype := GetReturnType;
  if Assigned(restype) and not resinparam then
    res := restype.FTypeInfo
  else
    res := Nil;

  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, aUserData, aCallback);
end;

{ TRttiIndexedProperty }

procedure TRttiIndexedProperty.GetAccessors;

begin
  if Assigned(FReadMethod)
     or Assigned(FWriteMethod)
     or not (IsReadable or IsWritable) then
    Exit;
  { not tested on virtual methods }
  if IsReadable then
    FReadMethod := Parent.GetMethod(ReadProc);
  if IsWritable then
    FWriteMethod := Parent.GetMethod(WriteProc);
end;

function TRttiIndexedProperty.GetPropertyType: TRttiType;
begin
  Result := TRttiContext.Create(FUsePublishedOnly).GetType(FPropInfo^.PropType);
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);
  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);
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);
end;

function TRttiIndexedProperty.GetIsWritable: boolean;
begin
  Result := Assigned(FPropInfo^.SetProc);
end;

function TRttiIndexedProperty.GetReadMethod: TRttiMethod;
begin
  Result := nil;
  if IsReadable then
  begin
    if FReadMethod = nil then
      GetAccessors;
    Result := FReadMethod;
  end;
end;

function TRttiIndexedProperty.GetWriteMethod: TRttiMethod;
begin
  Result := nil;
  if IsWritable then
  begin
    if FWriteMethod = nil then
      GetAccessors;
    Result := FWriteMethod;
  end;
end;

function TRttiIndexedProperty.GetReadProc: CodePointer;
begin
  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
  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;
begin
  Result := FPropInfo^.Name;
end;

function TRttiIndexedProperty.GetHandle: Pointer;
begin
  Result := FPropInfo;
end;

constructor TRttiIndexedProperty.Create(AParent: TRttiType; APropInfo: PPropInfo);
begin
  inherited Create(AParent);
  FPropInfo := APropInfo;
end;

destructor TRttiIndexedProperty.Destroy;
var
  attr: TCustomAttribute;
begin
  for attr in FAttributes do
    attr.Free;
  inherited Destroy;
end;

function TRttiIndexedProperty.GetAttributes: TCustomAttributeArray;
var
  i: SizeInt;
  at: PAttributeTable;
begin
  if not FAttributesResolved then
    begin
      at := FPropInfo^.AttributeTable;
      if Assigned(at) then
        begin
          SetLength(FAttributes, at^.AttributeCount);
          for i := 0 to High(FAttributes) do
            FAttributes[i] := TCustomAttribute({$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(at, i));
        end;
      FAttributesResolved:=true;
    end;
  result := FAttributes;
end;

function TRttiIndexedProperty.GetValue(aInstance: Pointer;
  const aArgs: array of TValue): TValue;
var
  argList: TValueArray;
  I, J: Integer;
  params: TRttiParameterArray;
begin
  if not IsReadable then
    raise EPropertyError.CreateFmt(SErrCannotReadIndexedProperty, [Name]);
  params := GetIndexParameters;
  if Length(params) <> Length(aArgs) then
    raise EInvocationError.CreateFmt(SErrIndPropArgCount, [Name, Length(params), Length(aArgs)]);
  if FPropInfo^.IsStatic then
    J := 0
  else
    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
  argList: TValueArray;
  I, J: Integer;
  params: TRttiParameterArray;
begin
  if not IsWritable then
    raise EPropertyError.CreateFmt(SErrCannotWriteToIndexedProperty, [Name]);
  params := GetIndexParameters;
  if Length(params) <> Length(aArgs) then
    raise EInvocationError.CreateFmt(SErrIndPropArgCount, [Name, Length(params), Length(aArgs)]);
  if FPropInfo^.IsStatic then
    J := 0
  else
    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;
var
  params: PPropParams;
  param: TVmtMethodParam;
  i: Integer;
begin
  Result := 'indexed property ' + Name + '[';

  params := FPropInfo^.PropParams;
  for i := 0 to params^.Count - 2 do
  begin
    param := params^.Params[i];
    Result := Result + param.Name + ': ' + param.ParamType^^.Name + '; ';
  end;
  param := params^.Params[params^.Count - 1];
  Result := Result + param.Name + ': ' + param.ParamType^^.Name + ']: ' + PropertyType.Name;
end;

{ TRttiInvokableType }

function TRttiInvokableType.GetParameters: TRttiParameterArray;
begin
  Result := GetParameters(False);
end;

function TRttiInvokableType.CreateImplementation(aCallback: TCallback): TMethodImplementation;

  procedure SelfCallback(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
  begin
    aCallback(TRttiInvokableType(aUserData), aArgs, aResult);
  end;

begin
  if not Assigned(aCallback) then
    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
  Result := CreateImplementation(Self, @SelfCallback);
end;

function TRttiInvokableType.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
var
  params: TRttiParameterArray;
  args: specialize TArray<TFunctionCallParameterInfo>;
  res: PTypeInfo;
  restype: TRttiType;
  resinparam: Boolean;
  i: SizeInt;
begin
  if not Assigned(aCallback) then
    raise EArgumentNilException.Create(SErrMethodImplNoCallback);

  resinparam := False;
  params := GetParameters(True);
  args:=[];
  SetLength(args, Length(params));
  for i := 0 to High(params) do begin
    if Assigned(params[i].ParamType) then
      args[i].ParamType := params[i].ParamType.FTypeInfo
    else
      args[i].ParamType := Nil;
    args[i].ParamFlags := params[i].Flags;
    args[i].ParaLocs := Nil;
    if pfResult in params[i].Flags then
      resinparam := True;
  end;

  restype := GetReturnType;
  if Assigned(restype) and not resinparam then
    res := restype.FTypeInfo
  else
    res := Nil;

  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, aUserData, aCallback);
end;

function TRttiInvokableType.ToString: string;

var
  P : TRTTIParameter;
  A : TRTTIParameterArray;
  I : integer;
  RT : TRttiType;

begin
  RT:=GetReturnType;
  if RT=nil then
    Result:=name+' = procedure ('
  else
    Result:=name+' = function (';
  A:=GetParameters(False);
  for I:=0 to Length(a)-1 do
    begin
      P:=A[I];
      if I>0 then
        Result:=Result+'; ';
      Result:=Result+P.Name;
      if Assigned(P.ParamType) then
        Result:=Result+' : '+P.ParamType.Name;
    end;
  result:=Result+')';
  if Assigned(RT) then
    Result:=Result+' : '+RT.Name;
end;



{ TRttiMethodType }

function TRttiMethodType.GetMethodKind: TMethodKind;
begin
  Result := FTypeData^.MethodKind;
end;

function TRttiMethodType.GetParameters(aWithHidden: Boolean): TRttiParameterArray;
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;
  paramtype: PTypeInfo;
  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
    infos:=[];
    SetLength(infos, FTypeData^.ParamCount);
    while total < FTypeData^.ParamCount do begin
      { align }
      ptr := AlignTParamFlags(ptr);
      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));

      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 := AlignToPtr(PByte(ptr) + ptr^ + SizeOf(Byte));
    { handle return type }
    FReturnType := GRttiPool[FUsePublishedOnly].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(FUsePublishedOnly);
    paramtypes := PPPTypeInfo(AlignTypeData(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
        if Assigned(paramtypes[i]) then
          paramtype := paramtypes[i]^
        else
          paramtype := Nil;
        FParamsAll[i] := TRttiMethodTypeParameter.Create(infos[i].Handle, infos[i].Name, infos[i].Flags, paramtype);
        context.AddObject(FParamsAll[i]);
      end;

      if not (pfHidden in infos[i].Flags) then begin
        FParams[visible] := FParamsAll[i];
        Inc(visible);
      end;
    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.GetFlags: TFunctionCallFlags;
begin
  Result := [];
end;

function TRttiMethodType.ToString: string;

begin
  Result:=Inherited ToString;
  Result:=Result+' of object';
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 := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, method^.Code, CallingConvention, False, inst, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;

{ TRttiProcedureType }

function TRttiProcedureType.GetParameters(aWithHidden: Boolean): TRttiParameterArray;
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(FUsePublishedOnly);
  param := AlignToPtr(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(AlignToPtr(PByte(@param^.Name) + Length(param^.Name) + SizeOf(param^.Name[0])));
  end;
  SetLength(FParams, visible);

  if aWithHidden then
    Result := FParamsAll
  else
    Result := FParams;
end;

function TRttiProcedureType.GetCallingConvention: TCallConv;
begin
  Result := FTypeData^.ProcSig.CC;
end;

function TRttiProcedureType.GetReturnType: TRttiType;
begin
  Result := nil;
  if Assigned(FTypeData^.ProcSig.ResultTypeRef) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(FTypeData^.ProcSig.ResultTypeRef^);
end;

function TRttiProcedureType.GetFlags: TFunctionCallFlags;
begin
  Result := [fcfStatic];
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 := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(Name, PCodePointer(aCallable.GetReferenceToRawData)^, CallingConvention, True, TValue.Empty, aArgs, GetParameters(True), TypeInfoFromRtti(ReturnType));
end;

{ TRttiStringType }

function TRttiStringType.GetStringKind: TRttiStringKind;
begin
  case TypeKind of
    tkSString : result := skShortString;
    tkLString : result := skAnsiString;
    tkAString : result := skAnsiString;
    tkUString : result := skUnicodeString;
    tkWString : result := skWideString;
  else
    Raise EConvertError.Create('Not a string type :'+GetEnumName(TypeInfo(TTypeKind),Ord(TypeKind)));
  end;
end;

function TRttiAnsiStringType.GetCodePage: Word;

begin
  Result:=FTypeData^.CodePage;
end;

{ TRttiInterfaceType }

function TRttiInterfaceType.IntfMethodCount: Word;
var
  parent: TRttiInterfaceType;
  table: PIntfMethodTable;
begin
  parent := GetIntfBaseType;
  if Assigned(parent) then
    Result := parent.IntfMethodCount
  else
    Result := 0;

  table := MethodTable;
  if Assigned(table) then
    Inc(Result, table^.Count);
end;

function TRttiInterfaceType.GetBaseType: TRttiType;
begin
  Result := GetIntfBaseType;
end;

function TRttiInterfaceType.GetGUIDStr: String;
begin
  Result := GUIDToString(GUID);
end;

function TRttiInterfaceType.GetDeclaredMethods: specialize TArray<TRttiMethod>;
var
  methtable: PIntfMethodTable;
  count, index: Word;
  method: PIntfMethodEntry;
  context: TRttiContext;
  obj: TRttiObject;
  parent: TRttiInterfaceType;
  parentmethodcount: Word;
begin
  if Assigned(fDeclaredMethods) then
    Exit(fDeclaredMethods);

  methtable := MethodTable;
  if not Assigned(methtable) then
    Exit(Nil);

  if (methtable^.Count = 0) or (methtable^.RTTICount = $ffff) then
    Exit(Nil);

  parent := GetIntfBaseType;
  if Assigned(parent) then
    parentmethodcount := parent.IntfMethodCount
  else
    parentmethodcount := 0;

  SetLength(fDeclaredMethods, methtable^.Count);

  context := TRttiContext.Create(FUsePublishedOnly);
  method := methtable^.Method[0];
  count := methtable^.Count;
  while count > 0 do begin
    index := methtable^.Count - count;
    obj := context.GetByHandle(method);
    if Assigned(obj) then
      fDeclaredMethods[index] := obj as TRttiMethod
    else begin
      fDeclaredMethods[index] := TRttiIntfMethod.Create(Self, method, parentmethodcount + index);
      context.AddObject(fDeclaredMethods[index]);
    end;

    method := method^.Next;
    Dec(count);
  end;

  Result := fDeclaredMethods;
end;

{ TRttiInstanceType }

function TRttiInstanceType.GetMetaClassType: TClass;
begin
  result := FTypeData^.ClassType;
end;

function TRttiInstanceType.GetDeclaringUnitName: string;
begin
  result := FTypeData^.UnitName;
end;

function TRttiInstanceType.GetBaseType: TRttiType;
begin
  result := TRttiContext.Create(FUsePublishedOnly).GetType(FTypeData^.ParentInfo);
end;

function TRttiInstanceType.GetIsInstance: boolean;
begin
  Result:=True;
end;

function TRttiInstanceType.GetTypeSize: integer;
begin
  Result:=sizeof(TObject);
end;


Procedure TRttiInstanceType.ResolveExtendedDeclaredProperties;

var
  Table: PPropDataEx;
  //List : PPropListEx;
  info : PPropInfoEx;
  TP : PPropInfo;
  Prop : TRttiProperty;
  i,j,Len, PropCount : Integer;

begin
  Table:=PClassData(FTypeData)^.ExRTTITable;
  Len:=Table^.PropCount;
  PropCount:=Len;
  SetLength(FDeclaredProperties,PropCount);
  FPropertiesResolved:=True;
  if Len=0 then
    exit;
  try
    J := 0;
    For I:=0 to Len-1 do
    begin
      Info := Table^.Prop[i];
      TP:=Info^.Info;
      if TP^.PropParams <> nil then
      begin
        Dec(PropCount);
        continue;
      end;
      Prop := TRttiProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
      if Prop=nil then
      begin
        Prop:=TRttiProperty.Create(Self, TP);
        GRttiPool[FUsePublishedOnly].AddObject(Prop);
      end;                             
      Prop.FVisibility:=MemberVisibilities[Info^.Visibility];
      Prop.FStrictVisibility:=Info^.StrictVisibility;
      FDeclaredProperties[J]:=Prop;
      Inc(J);
    end;
  finally
    SetLength(FDeclaredProperties, PropCount);
  end;
end;

Procedure TRttiInstanceType.ResolveClassicDeclaredProperties;

var
  Table: PPropData;
  TP: PPropInfo;
  I,Len: longint;
  Prop: TRttiProperty;

begin
  Table:=PClassData(FTypeData)^.PropertyTable;
  Len:=Table^.PropCount;
  SetLength(FDeclaredProperties,Len);
  FPropertiesResolved:=True;
  if Len=0 then
    exit;
  try
    TP:=PPropInfo(@Table^.PropList);
    For I:=0 to Len-1 do
      begin
      Prop := TRttiProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
      if Prop=nil then
      begin
        Prop:=TRttiProperty.Create(Self, TP);
        Prop.FUsePublishedOnly:=FUsePublishedOnly;
        GRttiPool[FUsePublishedOnly].AddObject(Prop);
      end;
      FDeclaredProperties[I]:=Prop; 
      TP:=TP^.Next;
      end;
  finally
  end;
end;

function TRttiInstanceType.GetDeclaredProperties: TRttiPropertyArray;
begin
  if Not FPropertiesResolved then
    if fUsePublishedOnly then
      ResolveClassicDeclaredProperties
    else
      ResolveExtendedDeclaredProperties;
  result := FDeclaredProperties;
end;

Procedure TRttiInstanceType.ResolveDeclaredIndexedProperties;

var   
  Table: PPropDataEx;
  info : PPropInfoEx;
  TP : PPropInfo;
  IProp : TRttiIndexedProperty;
  i,Len, PropCount : Integer;

begin
  Table:=PClassData(FTypeData)^.ExRTTITable;
  Len:=Table^.PropCount;
  PropCount:=0;
  SetLength(FDeclaredIndexedProperties,0);
  FIndexedPropertiesResolved:=True;
  if Len=0 then
    exit;
  try
    For I:=0 to Len-1 do
      begin
      Info := Table^.Prop[i];
      TP:=Info^.Info;
      if TP^.PropParams = nil then
      begin
        continue;
      end;              
      Inc(PropCount);
      SetLength(FDeclaredIndexedProperties, PropCount);
      IProp := TRttiIndexedProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
      if IProp=nil then
      begin
        IProp:=TRttiIndexedProperty.Create(Self, TP);
        GRttiPool[FUsePublishedOnly].AddObject(IProp);
      end;                               
      IProp.FVisibility:=MemberVisibilities[Info^.Visibility];
      IProp.FStrictVisibility:=Info^.StrictVisibility;
      FDeclaredIndexedProperties[PropCount-1]:=IProp;
    end;
  finally
  end;
end;      

function TRttiInstanceType.GetDeclaredIndexedProperties: TRttiIndexedPropertyArray;
begin
  if not FIndexedPropertiesResolved then
    ResolveDeclaredIndexedProperties;
  Result:=FDeclaredIndexedProperties;
end;

procedure TRttiInstanceType.ResolveDeclaredFields;

Var
  Tbl : PExtendedFieldInfoTable;
  aData: PExtendedVmtFieldEntry;
  Fld : TRttiField;
  i,Len : integer;
  Ctx : TRttiContext;

begin
  Tbl:=Nil;
  try
    Len:=GetFieldList(FTypeInfo,Tbl,[],False);
    SetLength(FDeclaredFields,Len);
    FFieldsResolved:=True;
    if Len=0 then
      exit;
    Ctx:=TRttiContext.Create(FUsePublishedOnly);
    For I:=0 to Len-1 do
      begin
      aData:=Tbl^[i];
      Fld:=TRttiField(Ctx.GetByHandle(aData));
      if Fld=Nil then
        begin
        Fld:=TRttiField.Create(Self);
        Fld.FHandle:=aData;
        Fld.FName:=aData^.Name^;
        Fld.FOffset:=aData^.FieldOffset;
        Fld.FFieldType:=Ctx.GetType(aData^.FieldType^);
        Fld.FVisibility:=MemberVisibilities[aData^.FieldVisibility];
        Fld.FStrictVisibility:=aData^.StrictVisibility;
        Ctx.AddObject(Fld);
        end;
      FDeclaredFields[I]:=Fld;
      end;
  finally
    FreeMem(Tbl);
  end;
end;

procedure TRttiInstanceType.ResolveDeclaredMethods;

Var
  Tbl : PExtendedMethodInfoTable;
  aData: PVmtMethodExEntry;
  Meth : TRttiInstanceMethod;
  i,idx,aCount,Len : integer;
  Ctx : TRttiContext;

begin
  tbl:=Nil;
  Ctx:=TRttiContext.Create(FUsePublishedOnly);
  try
    FMethodsResolved:=True;
    Len:=GetMethodList(FTypeInfo,Tbl,[],False);
    if not FUsePublishedOnly then
      aCount:=Len
    else
      begin
      aCount:=0;
      For I:=0 to Len-1 do
        if Tbl^[I]^.MethodVisibility=vcPublished then
           Inc(aCount);
      end;
    SetLength(FDeclaredMethods,aCount);
    Idx:=0;
    For I:=0 to Len-1 do
      begin
      aData:=Tbl^[i];
      if (Not FUsePublishedOnly) or (aData^.MethodVisibility=vcPublished) then
        begin
        Meth:=TRttiInstanceMethod(Ctx.GetByHandle(aData));
        if Meth=Nil then
          begin
          Meth:=TRttiInstanceMethod.Create(Self,aData);
          Meth.FUsePublishedOnly:=Self.FUsePublishedOnly;
          Meth.FVisibility:=MemberVisibilities[aData^.MethodVisibility];
          Meth.FStrictVisibility:=aData^.StrictVisibility;
          Ctx.AddObject(Meth);
          end;
        FDeclaredMethods[Idx]:=Meth;
        Inc(Idx);
        end;
      end;
  finally
    FreeMem(Tbl);
  end;
end;

function TRttiInstanceType.GetDeclaredFields: TRttiFieldArray;
begin
  if not FFieldsResolved then
    ResolveDeclaredFields;
  Result:=FDeclaredFields;
end;

function TRttiInstanceType.GetDeclaredMethods: TRttiMethodArray;
begin
  if not FMethodsResolved then
    ResolveDeclaredMethods;
  Result:=FDeclaredMethods;
end;

{ TRttiRecordType }

function TRttiRecordType.GetMethods: TRttiMethodArray;
begin
  Result:=GetDeclaredMethods;
end;

function TRttiRecordType.GetIsRecord: boolean;
begin
  Result:=True;
end;

procedure TRttiRecordType.ResolveFields;
Var
  Tbl : PExtendedFieldInfoTable;
  aData: PExtendedVmtFieldEntry;
  Fld : TRttiField;
  i,Len : integer;
  Ctx : TRttiContext;

begin
  Tbl:=Nil;
  Len:=GetFieldList(FTypeInfo,Tbl);
  FFieldsResolved:=True;
  try
    if Len=0 then
      exit;
    SetLength(FDeclaredFields,Len);
    Ctx:=TRttiContext.Create(Self.FUsePublishedOnly);
    For I:=0 to Len-1 do
      begin
      aData:=Tbl^[i];
      Fld:=TRttiField(Ctx.GetByHandle(aData));
      if Fld=Nil then
        begin
        Fld:=TRttiField.Create(Self);
        Fld.FName:=aData^.Name^;
        Fld.FOffset:=aData^.FieldOffset;
        Fld.FFieldType:=Ctx.GetType(aData^.FieldType^);
        Fld.FVisibility:=MemberVisibilities[aData^.FieldVisibility];
        Fld.FStrictVisibility:=aData^.StrictVisibility;
        Fld.FHandle:=aData;
        Ctx.AddObject(Fld);
        end;
      FDeclaredFields[I]:=Fld;
      end;
    FFields:=FDeclaredFields;
  finally
    FreeMem(Tbl);
  end;
end;

procedure TRttiRecordType.ResolveMethods;

Var
  Tbl : PRecordMethodInfoTable;
  aData: PRecMethodExEntry;
  Meth : TRttiRecordMethod;
  i,idx,aCount : integer;
  Ctx : TRttiContext;

begin
  FMethodsResolved:=True;
  if FUsePublishedOnly then
    exit;
  aCount:=GetMethodList(FTypeInfo,Tbl,[]);
  try
    if aCount=0 then
      exit;
    SetLength(FDeclaredMethods,aCount);
    Ctx:=TRttiContext.Create(FUsePublishedOnly);
    Idx:=0;
    For I:=0 to aCount-1 do
    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
    FreeMem(Tbl);
  end;
end;

procedure TRttiRecordType.ResolveProperties;

var
  List : PPropListEx;
  info : PPropInfoEx;
  TP : PPropInfo;
  Prop : TRttiProperty;
  i, j, PropCount, aCount : Integer;
  obj: TRttiObject;

begin
  List:=Nil;
  FPropertiesResolved:=True;
  if FUsePublishedOnly then
    Exit;
  aCount:=GetPropListEx(FTypeinfo,List);
  PropCount:=aCount; 
  J := 0;
  try
    SetLength(FDeclaredProperties,aCount);
    For I:=0 to aCount-1 do
    begin
      Info:=List^[I];
      TP:=Info^.Info;
      if TP^.PropParams <> nil then
      begin
        Dec(PropCount);
        continue;
      end;

      Prop := TRttiProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
      if Prop=nil then
      begin
        Prop:=TRttiProperty.Create(Self, TP);
        GRttiPool[FUsePublishedOnly].AddObject(Prop);
      end;
      Prop.FVisibility:=MemberVisibilities[Info^.Visibility];
      Prop.FStrictVisibility:=Info^.StrictVisibility;
      FDeclaredProperties[J]:=Prop;
      Inc(J);
    end;
  finally
    SetLength(FDeclaredProperties,PropCount);
    if assigned(List) then
      FreeMem(List);
  end;
end;    

Procedure TRttiRecordType.ResolveIndexedProperties;

var
  List : PPropListEx;
  info : PPropInfoEx;
  TP : PPropInfo;
  IProp : TRttiIndexedProperty;
  i,Len, PropCount : Integer;

begin
  List:=Nil;   
  FIndexedPropertiesResolved:=True;
  if FUsePublishedOnly then
    exit;
  Len:=GetPropListEx(FTypeInfo,List);
  PropCount:=0;
  SetLength(FDeclaredIndexedProperties,0);
  FIndexedPropertiesResolved:=True;
  if Len=0 then
  begin
    if Assigned(List) then
      FreeMem(List);
    exit;
  end;
  try
    For I:=0 to Len-1 do
    begin
      Info := List^[I];
      TP:=Info^.Info;
      if TP^.PropParams = nil then
      begin
        continue;
      end;                    
      Inc(PropCount);
      SetLength(FDeclaredIndexedProperties, PropCount);

      IProp := TRttiIndexedProperty(GRttiPool[FUsePublishedOnly].GetByHandle(TP));
      if IProp=nil then
      begin
        IProp:=TRttiIndexedProperty.Create(Self, TP);
        GRttiPool[FUsePublishedOnly].AddObject(IProp);
      end;                         
      IProp.FVisibility:=MemberVisibilities[Info^.Visibility];
      IProp.FStrictVisibility:=Info^.StrictVisibility;
      FDeclaredIndexedProperties[PropCount-1]:=IProp;
    end;
  finally
    if Assigned(List) then
      FreeMem(List);
  end;
end;

function TRttiRecordType.GetTypeSize: Integer;
begin
  Result:=GetTypeData(PTypeInfo(Handle))^.RecSize;
end;

function TRttiRecordType.GetFields: TRttiFieldArray;
begin
  Result:=GetDeclaredFields;
end;

function TRttiRecordType.GetProperties: TRttiPropertyArray;
begin
  Result:=GetDeclaredProperties;
end;

function TRttiRecordType.GetDeclaredFields: TRttiFieldArray;
begin
  If not FFieldsResolved then
    ResolveFields;
  Result:=FDeclaredFields;
end;

function TRttiRecordType.GetDeclaredMethods: TRttiMethodArray;
begin
  If not FMethodsResolved then
    ResolveMethods;
  Result:=FDeclaredMethods;
end;        

function TRttiRecordType.GetDeclaredProperties: TRttiPropertyArray;
begin
  if not FPropertiesResolved then
    ResolveProperties;
  Result:=FDeclaredProperties;
end;

function TRttiRecordType.GetDeclaredIndexedProperties: TRttiIndexedPropertyArray;
begin
  if not FIndexedPropertiesResolved then
    ResolveIndexedProperties;
  Result:=FDeclaredIndexedProperties;
end;

function TRttiRecordType.GetAttributes: TCustomAttributeArray;
begin
  Result:=inherited GetAttributes;
end;

function TRttiRecordType.GetIndexedProperties: TRttiIndexedPropertyArray;
begin
  Result:=GetDeclaredIndexedProperties;
end;

{ TRttiMember }

function TRttiMember.GetVisibility: TMemberVisibility;
begin
  Result:=FVisibility;
end;

function TRttiMember.GetStrictVisibility: Boolean;
begin
  Result:=FStrictVisibility;
end;

constructor TRttiMember.Create(AParent: TRttiType);
begin
  inherited Create();
  FParent := AParent;
  FVisibility:=mvPublished;
end;

{ TRttiProperty }

function TRttiProperty.GetDataType: TRttiType;

begin
  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;
begin
  Result := TRttiContext.Create(FUsePublishedOnly).GetType(FPropInfo^.PropType);
end;

function TRttiProperty.GetIsReadable: boolean;
begin
  result := assigned(FPropInfo^.GetProc);
end;

function TRttiProperty.GetIsWritable: boolean;
begin
  result := assigned(FPropInfo^.SetProc);
end;

function TRttiProperty.GetName: string;
begin
  Result:=FPropInfo^.Name;
end;

function TRttiProperty.GetHandle: Pointer;
begin
  Result := FPropInfo;
end;

constructor TRttiProperty.Create(AParent: TRttiType; APropInfo: PPropInfo);
begin
  inherited Create(AParent);
  FPropInfo := APropInfo;
end;

destructor TRttiProperty.Destroy;
var
  attr: TCustomAttribute;
begin
  for attr in FAttributes do
    attr.Free;
  inherited Destroy;
end;

function TRttiProperty.GetAttributes: TCustomAttributeArray;
var
  i: SizeInt;
  at: PAttributeTable;
begin
  if not FAttributesResolved then
    begin
      at := FPropInfo^.AttributeTable;
      if Assigned(at) then
        begin
          SetLength(FAttributes, at^.AttributeCount);
          for i := 0 to High(FAttributes) do
            FAttributes[i] := TCustomAttribute({$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(at, i));
        end;
      FAttributesResolved:=true;
    end;
  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);
  var
    b8: Boolean;
    b16: Boolean16;
    b32: Boolean32;
    bb: ByteBool;
    bw: WordBool;
    bl: LongBool;
    td: PTypeData;
    p: Pointer;
  begin
    td := GetTypeData(FPropInfo^.PropType);
    case td^.OrdType of
      otUByte:
        begin
          b8 := Boolean(value);
          p := @b8;
        end;
      otUWord:
        begin
          b16 := Boolean16(value);
          p := @b16;
        end;
      otULong:
        begin
          b32 := Boolean32(value);
          p := @b32;
        end;
      otSByte:
        begin
          bb := ByteBool(value);
          p := @bb;
        end;
      otSWord:
        begin
          bw := WordBool(value);
          p := @bw;
        end;
      otSLong:
        begin
          bl := LongBool(value);
          p := @bl;
        end;
    else
      // Silence compiler warning
    end;
    TValue.Make(p, FPropInfo^.PropType, result);
  end;

  procedure ValueFromInt(value: Int64);
  var
    i8: UInt8;
    i16: UInt16;
    i32: UInt32;
    td: PTypeData;
    p: Pointer;
  begin
    td := GetTypeData(FPropInfo^.PropType);
    case td^.OrdType of
      otUByte,
      otSByte:
        begin
          i8 := value;
          p := @i8;
        end;
      otUWord,
      otSWord:
        begin
          i16 := value;
          p := @i16;
        end;
      otULong,
      otSLong:
        begin
          i32 := value;
          p := @i32;
        end;
    else
      // Silence compiler warning
    end;
    TValue.Make(p, FPropInfo^.PropType, result);
  end;

var
  Values: record
    case Integer of
      0: (Enum: Int64);
      1: (Bool: Int64);
      2: (Int: Int64);
      3: (Ch: Byte);
      4: (Wch: Word);
      5: (I64: Int64);
      6: (Si: Single);
      7: (Db: Double);
      8: (Ex: Extended);
      9: (Cur: Currency);
     10: (Cp: Comp);
     11: (A: Pointer;)
  end;
  s: String;
  ss: ShortString;
  u : UnicodeString;
  O: TObject;
  M: TMethod;
  Int: IUnknown;
  getter: CodePointer;
  Args: array of TValue;
begin
  if FPropInfo^.IsStatic then
    begin
    Result:= GetStaticPropValue();
    exit;
    end;
  case FPropinfo^.PropType^.Kind of
    tkSString:
      begin
        ss := ShortString(GetStrProp(TObject(Instance), FPropInfo));
        TValue.Make(@ss, FPropInfo^.PropType, result);
      end;
    tkAString:
      begin
        s := GetStrProp(TObject(Instance), FPropInfo);
        TValue.Make(@s, FPropInfo^.PropType, result);
      end;
    tkUString:
      begin
        U := GetUnicodeStrProp(TObject(Instance), FPropInfo);
        TValue.Make(@U, FPropInfo^.PropType, result);
      end;
    tkWString:
      begin
        U := GetWideStrProp(TObject(Instance), FPropInfo);
        TValue.Make(@U, FPropInfo^.PropType, result);
      end;
    tkEnumeration:
      begin
        Values.Enum := Integer(GetOrdProp(TObject(Instance), FPropInfo));
        ValueFromInt(Values.Enum);
      end;
    tkBool:
      begin
        Values.Bool := GetOrdProp(TObject(Instance), FPropInfo);
        ValueFromBool(Values.Bool);
      end;
    tkInteger:
      begin
        Values.Int := GetOrdProp(TObject(Instance), FPropInfo);
        ValueFromInt(Values.Int);
      end;
    tkChar:
      begin
        Values.Ch := Byte(GetOrdProp(TObject(Instance), FPropInfo));
        TValue.Make(@Values.Ch, FPropInfo^.PropType, result);
      end;
    tkWChar:
      begin
        Values.Wch := Word(GetOrdProp(TObject(Instance), FPropInfo));
        TValue.Make(@Values.Wch, FPropInfo^.PropType, result);
      end;
    tkInt64,
    tkQWord:
      begin
        Values.I64 := GetOrdProp(TObject(Instance), FPropInfo);
        TValue.Make(@Values.I64, FPropInfo^.PropType, result);
      end;
    tkClass:
    begin
      O := GetObjectProp(TObject(Instance), FPropInfo);
      TValue.Make(@O, FPropInfo^.PropType, Result);
    end;
    tkMethod:
    begin
      M := GetMethodProp(TObject(Instance), FPropInfo);
      TValue.Make(@M, FPropInfo^.PropType, Result);
    end;
    tkInterface:
    begin
      Int := GetInterfaceProp(TObject(Instance), FPropInfo);
      TValue.Make(@Int, FPropInfo^.PropType, Result);
    end;
    tkFloat:
    begin
      case GetTypeData(FPropInfo^.PropType)^.FloatType of
        ftCurr   :
          begin
            Values.Cur := Currency(GetFloatProp(TObject(Instance), FPropInfo));
            TValue.Make(@Values.Cur, FPropInfo^.PropType, Result);
          end;
        ftSingle :
          begin
            Values.Si := Single(GetFloatProp(TObject(Instance), FPropInfo));
            TValue.Make(@Values.Si, FPropInfo^.PropType, Result);
          end;
        ftDouble :
          begin
            Values.Db := Double(GetFloatProp(TObject(Instance), FPropInfo));
            TValue.Make(@Values.Db, FPropInfo^.PropType, Result);
          end;
        ftExtended:
          begin
            Values.Ex := GetFloatProp(TObject(Instance), FPropInfo);
            TValue.Make(@Values.Ex, FPropInfo^.PropType, Result);
          end;
        ftComp   :
          begin
            Values.Cp := Comp(GetFloatProp(TObject(Instance), FPropInfo));
            TValue.Make(@Values.Cp, FPropInfo^.PropType, Result);
          end;
      end;
    end;
    tkDynArray:
      begin
        Values.A := GetDynArrayProp(TObject(Instance), FPropInfo);
        TValue.Make(@Values.A, FPropInfo^.PropType, Result);
      end
  else
    { tkRecord etc }
    case FPropInfo^.PropProcs and 3 of
      ptField:
        TValue.Make(Pointer(Instance)+PtrUInt(FPropInfo^.GetProc), FPropInfo^.PropType, Result);
      ptStatic,
      ptVirtual:
        begin
          if (FPropInfo^.PropProcs and 3)=ptStatic then
            getter:=FPropInfo^.GetProc
          else
            getter:=PCodePointer(Pointer(TObject(Instance).ClassType)+PtrUInt(FPropInfo^.GetProc))^;
          if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
            Args := [Instance]
          else
            Args := [Instance, FPropInfo^.Index];
          Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(getter, Args, ccReg, FPropInfo^.PropType, False, False);
        end;
    else
      raise EPropertyError.CreateFmt(SErrCannotReadProperty, [FPropInfo^.Name]);
    end;
  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:
      {$ifdef cpu8086}
      { convert to the correct pointer type }
      AValue.Cast(FPropInfo^.PropType).ExtractRawData(PPointer(@(FPropInfo^.SetProc))^);
      {$else}
      AValue.Cast(FPropInfo^.PropType).ExtractRawData(FPropInfo^.SetProc);
      {$endif}
    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);
var
  setter: CodePointer;
  Args: array of TValue;
begin
  if FPropInfo^.IsStatic then
    begin
    SetStaticPropValue(aValue);
    exit;
    end;
  case FPropinfo^.PropType^.Kind of
    tkSString,
    tkAString:
      SetStrProp(TObject(Instance), FPropInfo, AValue.AsString);
    tkUString:
      SetUnicodeStrProp(TObject(Instance), FPropInfo, AValue.AsUnicodeString);
    tkWString:
      SetWideStrProp(TObject(Instance), FPropInfo, AValue.AsUnicodeString);
    tkInteger,
    tkInt64,
    tkQWord,
    tkChar,
    tkBool,
    tkWChar,
    tkEnumeration:
      SetOrdProp(TObject(Instance), FPropInfo, AValue.AsOrdinal);
    tkClass:
      SetObjectProp(TObject(Instance), FPropInfo, AValue.AsObject);
    tkMethod:
      SetMethodProp(TObject(Instance), FPropInfo, PMethod(AValue.GetReferenceToRawData)^);
    tkInterface:
      SetInterfaceProp(TObject(Instance), FPropInfo, AValue.AsInterface);
    tkFloat:
      SetFloatProp(TObject(Instance), FPropInfo, AValue.AsExtended);
    tkDynArray:
      SetDynArrayProp(TObject(Instance), FPropInfo, PPointer(AValue.GetReferenceToRawData)^);
  else
    { tkRecord etc }
    case (FPropInfo^.PropProcs shr 2) and 3 of
      ptField:
        {$ifdef cpu8086}
        { convert to the correct pointer type }
        AValue.Cast(FPropInfo^.PropType).ExtractRawData(Pointer(Instance)+CodePtrUInt(FPropInfo^.SetProc));
        {$else}
        AValue.Cast(FPropInfo^.PropType).ExtractRawData(Pointer(Instance)+PtrUInt(FPropInfo^.SetProc));
        {$endif}
      ptStatic,
      ptVirtual:
        begin
          if ((FPropInfo^.PropProcs shr 2) and 3)=ptStatic then
            setter:=FPropInfo^.SetProc
          else
            setter:=PCodePointer(Pointer(TObject(Instance).ClassType)+PtrUInt(FPropInfo^.SetProc))^;
          if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
            Args := [Instance, AValue.Cast(FPropInfo^.PropType)]
          else
            Args := [Instance, FPropInfo^.Index, AValue.Cast(FPropInfo^.PropType)];
          {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(setter, Args, ccReg, nil, False, False);
        end;
    else
      raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [FPropInfo^.Name]);
    end;
  end
end;

function TRttiProperty.ToString: String;
begin
  Result := 'property ' + Name + ': ' + PropertyType.Name;
end;

{ TRttiField }

function TRttiField.GetName: string;
begin
  Result:=FName;
end;

function TRttiField.GetDataType: TRttiType;
begin
  Result:=FFieldType;
end;

function TRttiField.GetIsReadable: Boolean;
begin
  Result:=True;
end;

function TRttiField.GetIsWritable: Boolean;
begin
  Result:=True;
end;

function TRttiField.GetHandle: Pointer;
begin
  Result:=FHandle;
end;

destructor TRttiField.destroy;

var
  I : Integer;

begin
  For I:=0 to Length(FAttributes)-1 do
    FAttributes[i].Free;
  Inherited;
end;

Procedure TRttiField.ResolveAttributes;

var
  tbl : PAttributeTable;
  i : Integer;

begin
  FAttributesResolved:=True;
  Fattributes:=[];
  tbl:=FHandle^.AttributeTable;
  if not (assigned(Tbl) and (Tbl^.AttributeCount>0)) then
    exit;
  SetLength(FAttributes,Tbl^.AttributeCount);
  For I:=0 to Length(FAttributes)-1 do
    FAttributes[I]:={$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(Tbl,I);
end;

function TRttiField.GetAttributes: TCustomAttributeArray;

begin
  if not FAttributesResolved then
    ResolveAttributes;
  Result:=FAttributes;
end;

function TRttiField.GetValue(aInstance: Pointer): TValue;
begin
  if Not Assigned(FieldType) then
    raise EInsufficientRtti.Create(SErrNoFieldRtti);
  TValue.Make(PByte(aInstance)+Offset,FieldType.Handle,Result);
end;

procedure TRttiField.SetValue(aInstance: Pointer; const aValue: TValue);

var
  FldAddr : Pointer;

begin
  if Not Assigned(FieldType) then
    raise EInsufficientRtti.Create(SErrNoFieldRtti);
  FldAddr:=PByte(aInstance)+Offset;
  if aValue.TypeInfo=FieldType.Handle then
    aValue.ExtractRawData(FldAddr)
  else
    aValue.Cast(FieldType.Handle).ExtractRawData(FldAddr);
end;

function TRttiField.ToString: string;
begin
  if FieldType = nil then
    Result := Name + ' @ ' + IntToHex(Offset, 2)
  else
    Result := Name + ': ' + FieldType.Name + ' @ ' + IntToHex(Offset, 2);
end;

function TRttiType.GetIsInstance: boolean;
begin
  result := false;
end;

function TRttiType.GetIsManaged: boolean;
begin
  result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.IsManaged(FTypeInfo);
end;

function TRttiType.GetIsOrdinal: boolean;
begin
  result := false;
end;

function TRttiType.GetIsRecord: boolean;
begin
  result := false;
end;
function TRttiType.GetIsSet: boolean;

begin
  result := false;
end;

function TRttiType.GetAsInstance: TRttiInstanceType;
begin
  // This is a ridicoulous design, but Delphi-compatible...
  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;
end;

function TRttiType.GetTypeKind: TTypeKind;
begin
  result := FTypeInfo^.Kind;
end;

function TRttiType.GetTypeSize: integer;
begin
  result := -1;
end;

function TRttiType.GetName: string;
begin
  Result:=FTypeInfo^.Name;
end;

function TRttiType.GetHandle: Pointer;
begin
  Result := FTypeInfo;
end;

constructor TRttiType.Create(ATypeInfo: PTypeInfo; aUsePublishedOnly: Boolean);

begin
  inherited Create();
  FTypeInfo:=ATypeInfo;
  if assigned(FTypeInfo) then
    FTypeData:=GetTypeData(ATypeInfo);
  fUsePublishedOnly:=aUsePublishedOnly;
end;

constructor TRttiType.Create(ATypeInfo: PTypeInfo);
begin
  Create(aTypeInfo,GlobalUsePublishedOnly);
end;

destructor TRttiType.Destroy;
var
  attr: TCustomAttribute;
begin
  for attr in FAttributes do
    attr.Free;
  inherited;
end;


function TRttiType.GetFields: TRttiFieldArray;

var
  parentfields, selffields: TRttiFieldArray;
  parent: TRttiType;

begin
  if Assigned(fFields) then
    Exit(fFields);

  selffields := GetDeclaredFields;

  parent := GetBaseType;
  if Assigned(parent) then begin
    parentfields := parent.GetFields;
  end;

  fFields := Concat(selffields, parentfields);

  Result := fFields;
end;

function TRttiType.GetField(const aName: String): TRttiField;

var
  Flds : TRttiFieldArray;
  Fld: TRttiField;

begin
  Flds:=GetFields;
  For Fld in Flds do
    if SameText(Fld.Name,aName) then
      Exit(Fld);
  Result:=Nil;
end;

function TRttiType.GetAttributes: TCustomAttributeArray;
var
  i: Integer;
  at: PAttributeTable;
begin
  if not FAttributesResolved then
    begin
    at := GetAttributeTable(FTypeInfo);
    if Assigned(at) then
      begin
      setlength(FAttributes,at^.AttributeCount);
      for i := 0 to at^.AttributeCount-1 do
        FAttributes[i]:={$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}TypInfo.GetAttribute(at,i);
      end;
    FAttributesResolved:=true;
    end;
  result := FAttributes;
end;

function TRttiType.GetDeclaredProperties: TRttiPropertyArray;
begin
  Result := Nil;
end;

function TRttiType.GetProperties: TRttiPropertyArray;
var
  parentproperties, selfproperties: TRttiPropertyArray;
  parent: TRttiType;
  prop: TRttiProperty;
  NameIndexes : Array of Integer;
  Idx, IdxCount, aCount, I: Integer;

  Function IndexOfNameIndex(Idx : Integer) : integer;
  begin
    Result:=IdxCount-1;
    While (Result>=0) and (NameIndexes[Result]<>Idx) do
      Dec(Result);
  end;

begin
  NameIndexes:=[];
  IdxCount:=0;

  if Assigned(fProperties) then
    Exit(fProperties);

  selfproperties := GetDeclaredProperties;

  parent := GetBaseType;
  if Assigned(parent) then
    parentproperties := parent.GetProperties
  else
    parentproperties := nil;

  if (not Assigned(parent)) or (Length(parentproperties) = 0) then
  begin
    fProperties := selfproperties;
    Exit(fProperties);
  end
  else if Length(selfproperties) = 0 then
  begin
    fProperties := parentproperties;
    Exit(fProperties);
  end;

  aCount := Length(parentproperties) + Length(selfproperties);
  SetLength(fProperties,aCount);
  SetLength(NameIndexes,aCount);

  IdxCount := 0;

  For I:=0 to Length(selfproperties)-1 do
  begin
    prop := selfproperties[I];

    NameIndexes[IdxCount]:=Prop.FPropInfo^.NameIndex;
    fProperties[IdxCount]:=Prop;
    Inc(IdxCount);
  end;

  For I:=0 to Length(parentproperties)-1 do
  begin
    Prop := parentproperties[I];
    Idx:=IndexOfNameIndex(Prop.FPropInfo^.NameIndex);

    if Idx = -1 then
    begin
      NameIndexes[IdxCount]:=Prop.FPropInfo^.NameIndex;
      fProperties[IdxCount]:=Prop;
      Inc(IdxCount);
    end;
  end;

  SetLength(fProperties, IdxCount);

  Result := fProperties;
end;

function TRttiType.GetIndexedProperties: TRttiIndexedPropertyArray;
var
  parentproperties, selfproperties: TRttiIndexedPropertyArray;
  parent: TRttiType;
  iprop: TRttiIndexedProperty;
  NameIndexes : Array of Integer;
  Idx, IdxCount, aCount, I: Integer;

  Function IndexOfNameIndex(Idx : Integer) : integer;
  begin
    Result:=IdxCount-1;
    While (Result>=0) and (NameIndexes[Result]<>Idx) do
      Dec(Result);
  end;

begin
  NameIndexes:=[];
  IdxCount:=0;

  if Assigned(fIndexedProperties) then
    Exit(fIndexedProperties);

  selfproperties := GetDeclaredIndexedProperties;

  parent := GetBaseType;
  if Assigned(parent) then
    parentproperties := parent.GetIndexedProperties
  else
    parentproperties := nil;

  if (not Assigned(parent)) or (Length(parentproperties) = 0) then
  begin
    fIndexedProperties := selfproperties;
    Exit(fIndexedProperties);
  end
  else if Length(selfproperties) = 0 then
  begin
    fIndexedProperties := parentproperties;
    Exit(fIndexedProperties);
  end;

  aCount := Length(parentproperties) + Length(selfproperties);
  SetLength(fIndexedProperties,aCount);
  SetLength(NameIndexes,aCount);

  IdxCount := 0;

  For I:=0 to Length(selfproperties)-1 do
  begin
    IProp := selfproperties[I];

    NameIndexes[IdxCount]:=IProp.FPropInfo^.NameIndex;
    fIndexedProperties[IdxCount]:=IProp;
    Inc(IdxCount);
  end;

  For I:=0 to Length(parentproperties)-1 do
  begin
    IProp := parentproperties[I];
    Idx:=IndexOfNameIndex(IProp.FPropInfo^.NameIndex);

    if Idx = -1 then
    begin
      NameIndexes[IdxCount]:=IProp.FPropInfo^.NameIndex;
      fIndexedProperties[IdxCount]:=IProp;
      Inc(IdxCount);
    end;
  end;

  SetLength(fIndexedProperties, IdxCount);

  Result := fIndexedProperties;
end;

function TRttiType.GetProperty(const AName: string): TRttiProperty;
var
  FPropList: TRttiPropertyArray;
  i: Integer;
begin
  result := nil;
  FPropList := GetProperties;
  for i := 0 to length(FPropList)-1 do
    if sametext(FPropList[i].Name,AName) then
      begin
        result := FPropList[i];
        break;
      end;
end;             

function TRttiType.GetIndexedProperty(const AName: string): TRttiIndexedProperty;
var
  FPropList: TRttiIndexedPropertyArray;
  i: Integer;
begin
  result := nil;
  FPropList := GetIndexedProperties;
  for i := 0 to length(FPropList)-1 do
    if sametext(FPropList[i].Name,AName) then
      begin
        result := FPropList[i];
        break;
      end;
end;

function TRttiType.GetMethods: TRttiMethodArray;
var
  parentmethods, selfmethods: TRttiMethodArray;
  parent: TRttiType;
begin
  if Assigned(fMethods) then
    Exit(fMethods);

  selfmethods := GetDeclaredMethods;

  parent := GetBaseType;
  if Assigned(parent) then begin
    parentmethods := parent.GetMethods;
  end;

  fMethods := Concat(selfmethods, parentmethods);

  Result := fMethods;
end;

function TRttiType.GetMethod(const aName: String): TRttiMethod;
var
  methods: TRttiMethodArray;
  method: TRttiMethod;
begin
  methods := GetMethods;
  for method in methods do
    if SameText(method.Name, AName) then
      Exit(method);
  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: TRttiMethodArray;
  method: TRttiMethod;
  count: Integer;
begin
  methods := Self.GetMethods;
  count := 0;
  Result := nil;

  for method in methods do
    if SameText(method.Name, aName) then
    begin
      SetLength(Result, count + 1);
      Result[count] := method;
      Inc(count);
    end;
end;

function TRttiType.GetDeclaredMethods: TRttiMethodArray;
begin
  Result := Nil;
end;

function TRttiType.GetDeclaredFields: TRttiFieldArray;
begin
  Result:=Nil;
end;

function TRttiType.GetDeclaredIndexedProperties: TRttiIndexedPropertyArray;
begin
  Result:=Nil;
end;

{ TRttiNamedObject }

function TRttiNamedObject.GetName: string;
begin
  result := '';
end;

function TRttiNamedObject.HasName(const aName: string): Boolean;
begin
  Result:=SameText(Name,AName);
end;

{ TRttiContext }

procedure NewPoolRef(PoolIndex: boolean);
var
  pool: TRttiPool;
begin
  pool := nil;
  if not Assigned(GRttiPool[PoolIndex]) then
    pool := TRttiPool.Create; { Heuristically pre-create. }
  repeat
{$ifdef FPC_HAS_FEATURE_THREADING}
    EnterCriticalSection(PoolLock);
{$endif}
    if PoolRefCount[PoolIndex] = 0 then
      if Assigned(pool) then
        GRttiPool[PoolIndex] := specialize Exchange<TRttiPool>(pool, nil)
      else
      begin
{$ifdef FPC_HAS_FEATURE_THREADING}
        LeaveCriticalSection(PoolLock);
{$endif}
        pool := TRttiPool.Create; { Create outside of the lock and retry. }
        continue;
      end;
    inc(PoolRefCount[PoolIndex]);
{$ifdef FPC_HAS_FEATURE_THREADING}
    LeaveCriticalSection(PoolLock);
{$endif}
    break;
  until false;
  pool.Free;
end;

function EnsurePool(var ctx: TRttiContext): TRttiPool;
begin
  if ctx.FPoolIndex < 0 then
  begin
    NewPoolRef(ctx.UsePublishedOnly);
    ctx.FPoolIndex := ord(ctx.UsePublishedOnly);
  end;
  result := GRttiPool[boolean(ctx.FPoolIndex)];
end;

procedure FreePools;
var
  iPool: boolean;
begin
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalSection(PoolLock);
{$endif}
  for iPool in boolean do
    if PoolRefCount[iPool] = 0 then
      specialize Exchange<TRttiPool>(GRttiPool[iPool], nil).Free;
{$ifdef FPC_HAS_FEATURE_THREADING}
  LeaveCriticalSection(PoolLock);
{$endif}
end;

class function TRttiContext.Create: TRttiContext;
begin
  result.Free;
  result.FUsePublishedOnly:=DefaultUsePublishedOnly;
end;

class function TRttiContext.Create(aUsePublishedOnly: Boolean): TRttiContext;
begin
  result.Free;
  Result.FUsePublishedOnly:=aUsePublishedOnly;
end;

class procedure TRttiContext.DropContext;
var
  counterFetch: integer;
begin
  repeat
    counterFetch := FKeepContextCounter;
    if counterFetch <= 0 then
      raise ERtti.Create('Unpaired DropContext.');
  until AtomicCmpExchange(FKeepContextCounter, counterFetch - 1, counterFetch) = counterFetch;
  if counterFetch = 1 then
    FreePools;
end;

class procedure TRttiContext.KeepContext;
begin
  AtomicIncrement(FKeepContextCounter);
end;

procedure TRttiContext.Free;
var
  toFree: TRttiPool;
begin
  if FPoolIndex < 0 then
    exit;
  toFree := nil;
{$ifdef FPC_HAS_FEATURE_THREADING}
  EnterCriticalSection(PoolLock);
{$endif}
  dec(PoolRefCount[boolean(FPoolIndex)]);
  if (PoolRefCount[boolean(FPoolIndex)] = 0) and (FKeepContextCounter <= 0) then
    toFree := specialize Exchange<TRttiPool>(GRttiPool[boolean(FPoolIndex)], nil);
{$ifdef FPC_HAS_FEATURE_THREADING}
  LeaveCriticalSection(PoolLock);
{$endif}
  FPoolIndex := -1;
  toFree.Free; { Free outside of the lock. }
end;

class operator TRttiContext.Initialize(var self: TRttiContext);
begin
  self.FPoolIndex := -1;
end;

class operator TRttiContext.Finalize(var self: TRttiContext);
begin
  self.Free;
end;

class operator TRttiContext.Copy(constref b: TRttiContext; var self: TRttiContext);
begin
  if b.FPoolIndex <> self.FPoolIndex then
  begin
    self.Free;
    if b.FPoolIndex >= 0 then
      NewPoolRef(boolean(b.FPoolIndex));
    self.FPoolIndex := b.FPoolIndex;
  end;
  self.FUsePublishedOnly := b.FUsePublishedOnly;
end;

class operator TRttiContext.AddRef(var self: TRttiContext);
begin
  if self.FPoolIndex >= 0 then
    NewPoolRef(boolean(self.FPoolIndex));
end;

function TRttiContext.GetByHandle(AHandle: Pointer): TRttiObject;
begin
  Result := EnsurePool(Self).GetByHandle(AHandle);
end;

procedure TRttiContext.AddObject(AObject: TRttiObject);
begin
  EnsurePool(Self).AddObject(AObject);
  AObject.FUsePublishedOnly := UsePublishedOnly;
end;

procedure TRttiContext.SetUsePublishedOnly(Value: Boolean);
begin
  if (FPoolIndex >= 0) and (FPoolIndex <> ord(Value)) then
    Free;
  FUsePublishedOnly := Value;
end;

function TRttiContext.GetType(ATypeInfo: PTypeInfo): TRttiType;
begin
  result := EnsurePool(Self).GetType(ATypeInfo,UsePublishedOnly);
end;

function TRttiContext.GetType(AClass: TClass): TRttiType;
begin
  if assigned(AClass) then
    result := GetType(PTypeInfo(AClass.ClassInfo))
  else
    result := nil;
end;

{function TRttiContext.GetTypes: specialize TArray<TRttiType>;

begin
  result := EnsurePool(Self).GetTypes;
end;}

{ TVirtualInterface }

{.$define DEBUG_VIRTINTF}

{$IFDEF USE_THUNK_CLASS}
constructor TVirtualInterface.Create(aPIID: PTypeInfo);

var
  TD : PInterfaceData;
  t: TRttiType;

begin
  if not Assigned(aPIID) then
    raise EArgumentNilException.Create(SErrVirtIntfTypeNil);
  { ToDo: add support for raw interfaces once they support RTTI }
  if aPIID^.Kind <> tkInterface then
    raise EArgumentException.CreateFmt(SErrVirtIntfTypeMustBeIntf, [aPIID^.Name]);

  fContext := TRttiContext.Create;
  t := fContext.GetType(aPIID);
  if not Assigned(t) then
    raise EInsufficientRtti.CreateFmt(SErrVirtIntfTypeNotFound, [aPIID^.Name]);
  td := PInterfaceData(GetTypeData(aPIID));
  CreateThunk(aPIID,t,td);
end;

Procedure TVirtualInterface.ThunkClassCallback(aInstance: Pointer; aMethod,aCount : Longint; aData : TInterfaceThunk.PArgData);

var
  len,lCount,I : integer;
  methods: specialize TArray<TRttiMethod>;
  M : TRttiMethod;
  ParamInfos : TRttiParameterArray;
  ParamInfo : TRttiParameter;
  ParamValues : Array of TValue;
  ReturnVal : TValue;
  TheIntf : Pointer;

begin
  I:=0;
  M:=Nil;
  Methods:=FIntfRTTI.GetMethods;
  len:=Length(Methods);
  // Find our method.
  // Quick check
  I:=aMethod-FThunk.InterfaceVmtOffset;
  if (I<Len) and (Methods[I].VirtualIndex=aMethod) then
    M:=Methods[I]
  else
    // Long check
    begin
    I:=0;
    While (M=Nil) and (I<Len) do
      begin
      if methods[i].VirtualIndex=aMethod then
        M:=methods[i];
      Inc(I);
      end;
    end;
  if (M=Nil) then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkMethodNotFound, [FIntfRTTI.Name,aMethod]);
  // Check parameter length
  ParamInfos:=M.GetParameters(True);
  lCount:=0;
  for I:=0 to Length(ParamInfos)-1 do
    if not (pfHidden in ParamInfos[i].Flags) then
      inc(lCount);
  if lCount<>acount then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkParameterMismatch, [FIntfRTTI.Name,M.Name,lCount,aCount]);
  // Prepare call args
  SetLength(ParamValues,aCount+1);
  // Convert interface to TValue
  if not Supports(TInterfaceThunk(aInstance),(FIntfRTTI as TRttiInterfaceType).GUID,TheIntf) then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkNotCorrectInterface, [FIntfRTTI.Name]);
  TValue.Make(@TheIntf,FIntfRTTI.Handle,ParamValues[0]);
  // Convert parameters to TValue
  For I:=1 to aCount do
    begin
    ParamInfo:=ParamInfos[aData[i].idx];
    if pfArray in ParamInfo.Flags then
      TValue.MakeOpenArray(aData[i].Addr,aData[i].aHigh,PTypeInfo(aData[i].info),ParamValues[I])
    else
      if Assigned(aData[i].info) then
        TValue.Make(aData[i].addr, aData[i].Info,ParamValues[i])
      else
        TValue.Make(@aData[i].addr, TypeInfo(Pointer), ParamValues[i]);
    end;

  // Callback...
  ReturnVal:=Default(TValue);

  HandleUserCallback(M,ParamValues,ReturnVal);

  { copy back var/out parameters }
  for i:=1 to aCount do
    begin
    ParamInfo:=ParamInfos[aData[i].idx];
    if (ParamInfo.Flags * [pfVar, pfOut] <> []) then
       ParamValues[I].ExtractRawData(aData[i].addr);
    end;
  // Copy back result
  if Assigned(aData[0].addr) then
    ReturnVal.ExtractRawData(aData[0].addr);
end;

Procedure TVirtualInterface.HandleThunkQueryInterface(iid : tguid;out Result : longint;out aIntf);
begin
  Result:=S_FALSE;
end;

procedure TVirtualInterface.CreateThunk(aPIID: PTypeInfo;T : trttitype; td : PInterfaceData);

Type
  TInterfaceThunkClass = class of TInterfaceThunk;

var
  TTI : PTypeInfo;
  TTD : PClassData;
  TC : TInterfaceThunkClass;

begin
  FIntfRTTI:=T;
  If not assigned(td^.ThunkClass) then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkClassTypeNotFound, [T.Name]);
  TTI:=td^.ThunkClass^;
  If not assigned(TTI)  then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkClassTypeNotFound, [T.Name]);
  TTD:=PClassData(GetTypeData(TTI));
  If not (assigned(TTD) and assigned(TTD^.ClassType)) then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkClassTypeNotFound, [T.Name]);
  TC:=TInterfaceThunkClass(TTD^.ClassType);
  FThunk:=TC.create(@ThunkClassCallback);
  FThunk.OnQueryInterface:=@HandleThunkQueryInterface;
  IThunk:=FThunk as IInterface;
  if not Supports(IThunk,td^.GUID) then
    raise EInsufficientRtti.CreateFmt(SErrVirtThunkClassTypeNotFound, [T.Name]);
end;

procedure TVirtualInterface.DestroyThunk;

begin
  iThunk:=nil;
end;

{$ELSE}
constructor TVirtualInterface.Create(aPIID: PTypeInfo);
const
  BytesToPopQueryInterface =
{$ifdef cpui386}
    3 * SizeOf(Pointer); { aIID + aObj + $RetAddr }
{$else}
    0;
{$endif}
  BytesToPopAddRef =
{$ifdef cpui386}
    1 * SizeOf(Pointer); { $RetAddr }
{$else}
    0;
{$endif}
  BytesToPopRelease =
{$ifdef cpui386}
    1 * SizeOf(Pointer); { $RetAddr }
{$else}
    0;
{$endif}
var
  t: TRttiType;
  ti: PTypeInfo;
  td: PInterfaceData;
  methods: specialize TArray<TRttiMethod>;
  m: TRttiMethod;
  mt: PIntfMethodTable;
  count, i: SizeInt;
begin
  if not Assigned(aPIID) then
    raise EArgumentNilException.Create(SErrVirtIntfTypeNil);
  { ToDo: add support for raw interfaces once they support RTTI }
  if aPIID^.Kind <> tkInterface then
    raise EArgumentException.CreateFmt(SErrVirtIntfTypeMustBeIntf, [aPIID^.Name]);

  fContext := TRttiContext.Create;
  t := fContext.GetType(aPIID);
  if not Assigned(t) then
    raise EInsufficientRtti.CreateFmt(SErrVirtIntfTypeNotFound, [aPIID^.Name]);

  { check whether the interface and all its parents have RTTI enabled (the only
    exception is IInterface as we know the methods of that) }
  td := PInterfaceData(GetTypeData(aPIID));

  fGUID := td^.GUID;

  fThunks[0] := AllocateRawThunk(TMethod(@QueryInterface).Code, Pointer(Self), BytesToPopQueryInterface);
  fThunks[1] := AllocateRawThunk(TMethod(@_AddRef).Code, Pointer(Self), BytesToPopAddRef);
  fThunks[2] := AllocateRawThunk(TMethod(@_Release).Code, Pointer(Self), BytesToPopRelease);

  for i := Low(fThunks) to High(fThunks) do
    if not Assigned(fThunks[i]) then
      raise ENotImplemented.CreateFmt(SErrVirtIntfCreateThunk, [aPIID^.Name]);

  ti := aPIID;
  { ignore the three methods of IInterface }
  count := 0;
  while ti <> TypeInfo(IInterface) do begin
    mt := td^.MethodTable;
    if (mt^.Count > 0) and (mt^.RTTICount <> mt^.Count) then
      raise EInsufficientRtti.CreateFmt(SErrVirtIntfNotAllMethodsRTTI, [aPIID^.Name]);
    Inc(count, mt^.Count);
    ti := td^.Parent^;
    td := PInterfaceData(GetTypeData(ti));
  end;

  SetLength(fImpls, count);

  methods := t.GetMethods;
  for m in methods do begin
    if m.VirtualIndex > High(fImpls) + Length(fThunks) then
      raise ERtti.CreateFmt(SErrVirtIntfInvalidVirtIdx, [aPIID^.Name, m.Name, m.VirtualIndex]);
    if m.VirtualIndex < Length(fThunks) then
      raise ERtti.CreateFmt(SErrVirtIntfInvalidVirtIdx, [aPIID^.Name, m.Name, m.VirtualIndex]);
    { we use the childmost entry, except for the IInterface methods }
    if Assigned(fImpls[m.VirtualIndex - Length(fThunks)]) then begin
      {$IFDEF DEBUG_VIRTINTF}Writeln('Ignoring duplicate implementation for index ', m.VirtualIndex);{$ENDIF}
      Continue;
    end;
    fImpls[m.VirtualIndex - Length(fThunks)] := m.CreateImplementation(m, @HandleUserCallback);
  end;

  for i := 0 to High(fImpls) do
    if not Assigned(fImpls) then
      raise ERtti.CreateFmt(SErrVirtIntfMethodNil, [aPIID^.Name, i]);

  fVmt := GetMem(Length(fImpls) * SizeOf(CodePointer) + Length(fThunks) * SizeOf(CodePointer));
  if not Assigned(fVmt) then
    raise ERtti.CreateFmt(SErrVirtIntfCreateVmt, [aPIID^.Name]);

  for i := 0 to High(fThunks) do begin
    fVmt[i] := fThunks[i];
    {$IFDEF DEBUG_VIRTINTF}Writeln('VMT ', i, ': ', HexStr(fVmt[i]));{$ENDIF}
  end;
  for i := 0 to High(fImpls) do begin
    fVmt[i + Length(fThunks)] := fImpls[i].CodeAddress;
    {$IFDEF DEBUG_VIRTINTF}Writeln('VMT ', i + Length(fThunks), ': ', HexStr(fVmt[i + Length(fThunks)]));{$ENDIF}
  end;
end;
{$ENDIF}

constructor TVirtualInterface.Create(aPIID: PTypeInfo; aInvokeEvent: TVirtualInterfaceInvokeEvent);
begin
  Create(aPIID);
  OnInvoke := aInvokeEvent;
end;

destructor TVirtualInterface.Destroy;
var
  impl: TMethodImplementation;
  thunk: CodePointer;
begin
{$IFDEF USE_THUNK_CLASS}
  DestroyThunk;
{$ELSE}
  {$IFDEF DEBUG_VIRTINTF}Writeln('Freeing implementations');{$ENDIF}
  for impl in fImpls do
    impl.Free;
  {$IFDEF DEBUG_VIRTINTF}Writeln('Freeing thunks');{$ENDIF}
  for thunk in fThunks do
    FreeRawThunk(thunk);
  {$IFDEF DEBUG_VIRTINTF}Writeln('Freeing VMT');{$ENDIF}
  if Assigned(fVmt) then
    FreeMem(fVmt);
  {$IFDEF DEBUG_VIRTINTF}Writeln('Done');{$ENDIF}
{$ENDIF}
  inherited Destroy;
end;

function TVirtualInterface.QueryInterface(constref aIID: TGuid; out aObj): LongInt;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
{$IFDEF USE_THUNK_CLASS}
   Result:=ITHUNK.QueryInterface(aIID,aObj);
{$ELSE}
  {$IFDEF DEBUG_VIRTINTF}Writeln('QueryInterface for ', GUIDToString(aIID));{$ENDIF}
  if IsEqualGUID(aIID, fGUID) then begin
    {$IFDEF DEBUG_VIRTINTF}Writeln('Returning ', HexStr(@fVmt));{$ENDIF}
    Pointer(aObj) := @fVmt;
    { QueryInterface increases the reference count }
    _AddRef;
    Result := S_OK;
  end else
    Result := inherited QueryInterface(aIID, aObj);
{$ENDIF}
end;

function TVirtualInterface._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 
begin
  Result:=Inherited _AddRef;
end;

function TVirtualInterface._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  Result:=Inherited _Release;
end;

procedure TVirtualInterface.HandleUserCallback(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
begin
  {$IFDEF DEBUG_VIRTINTF}Writeln('Call for ', TRttiMethod(aUserData).Name);{$ENDIF}
  if Assigned(fOnInvoke) then
    fOnInvoke(TRttiMethod(aUserData), aArgs, aResult);
end;

function TRttiObject.GetAttribute(aClass: TCustomAttributeClass): TCustomAttribute;

var
  attrarray : TCustomAttributeArray;
  a: TCustomAttribute;

begin
  Result:=nil;
  attrarray:=GetAttributes;
  for a in attrarray do
    if a.InheritsFrom(aClass) then
      Exit(a);
end;

function TRttiObject.HasAttribute(aClass: TCustomAttributeClass): Boolean;
begin
  Result:=Assigned(GetAttribute(aClass));
end;

generic function TRttiObject.GetAttribute<T>: T;
begin
  Result:=T(GetAttribute(T));
end;

generic function TRttiObject.HasAttribute<T>: Boolean;
begin
  Result:=HasAttribute(T);
end;


{ TRttiRecordMethod }

constructor TRttiRecordMethod.Create(AParent: TRttiType; aHandle: PRecMethodExEntry);
begin
  inherited create(aParent);
  FHandle:=aHandle;
end;

function TRttiRecordMethod.GetCallingConvention: TCallConv;
begin
  Result:=Fhandle^.CC;
end;

function TRttiRecordMethod.GetReturnType: TRttiType;
begin
  Result := nil;
  if Assigned(FHandle^.ResultType) then
    Result := TRttiContext.Create(FUsePublishedOnly).GetType(FHandle^.ResultType^);
end;

function TRttiRecordMethod.GetDispatchKind: TDispatchKind;
begin
  Result := dkStatic;
end;

function TRttiRecordMethod.GetHasExtendedInfo: Boolean;
begin
  Result:=True
end;

function TRttiRecordMethod.GetCodeAddress: CodePointer;
begin
  Result := FHandle^.CodeAddress;
end;

function TRttiRecordMethod.GetIsClassMethod: Boolean;
begin
  Result := GetMethodKind in [mkClassProcedure, mkClassFunction, mkOperatorOverload];
end;

function TRttiRecordMethod.GetIsStatic: Boolean;
begin
  Result:=not (GetMethodKind in [mkProcedure, mkFunction]);
end;

function TRttiRecordMethod.GetVisibility: TMemberVisibility;
begin
  Result:=MemberVisibilities[FHandle^.MethodVisibility];
end;

function TRttiRecordMethod.GetHandle: Pointer;
begin
  Result:=FHandle;
end;

function TRttiRecordMethod.GetVirtualIndex: SmallInt;
begin
  Result:=-1;
end;

Procedure TRttiRecordMethod.ResolveParams;

var
  param: PVmtMethodParam;
  total, visible: SizeInt;
  context: TRttiContext;
  obj: TRttiObject;
  prtti : TRttiVmtMethodParameter ;

begin
  total := 0;
  visible := 0;
  SetLength(FParams[False],FHandle^.ParamCount);
  SetLength(FParams[True],FHandle^.ParamCount);

  context := TRttiContext.Create(FUsePublishedOnly);
  param := FHandle^.Param[0];
  while total < FHandle^.ParamCount 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[True][total]:=prtti;
    if not (pfHidden in param^.Flags) then
      begin
      FParams[False][visible]:=prtti;
      Inc(visible);
      end;
    param := param^.Next;
    Inc(total);
  end;
  if visible <> total then
    SetLength(FParams[False], visible);
end;

function TRttiRecordMethod.GetParameters(aWithHidden : Boolean): TRttiParameterArray;
begin
  if FHandle^.ParamCount = 0 then
    Exit(Nil);
  if (Length(FParams[aWithHidden]) > 0) then
    Exit(FParams[aWithHidden]);
  ResolveParams;
  Result := FParams[aWithHidden];
end;

function TRttiRecordMethod.GetAttributes: TCustomAttributeArray;
begin
  Result:=Nil;
end;

function TRttiRecordMethod.GetMethodKind: TMethodKind;
begin
  Result:=FHandle^.Kind;
end;

function TRttiRecordMethod.GetName: string;
begin
  Result:=FHandle^.Name;
end;

function TRttiRecordMethod.GetIsConstructor: Boolean;
begin
  Result:=GetMethodKind in [mkConstructor,mkClassConstructor];
end;
 
function TRttiRecordMethod.GetIsDestructor: Boolean;
begin
  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)) or defined(CPUWASM32)}
{$I invoke.inc}
{$endif}
{$endif}

initialization
{$ifdef FPC_HAS_FEATURE_THREADING}
  InitCriticalSection(PoolLock);
{$endif}
  InitDefaultFunctionCallManager;
{$ifdef SYSTEM_HAS_INVOKE}
  InitSystemFunctionCallManager;
{$endif}
finalization
  FreePools;
{$ifdef FPC_HAS_FEATURE_THREADING}
  DoneCriticalSection(PoolLock);
{$endif}
end.