{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclRTTI.pas.                                                                }
{                                                                                                  }
{ The Initial Developer of the Original Code is Marcel Bestebroer.                                 }
{ Portions created Marcel Bestebroer are Copyright (C) Marcel Bestebroer. All rights reserved.     }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{   Theo Bebekis                                                                                   }
{   Marcel Bestebroer (marcelb)                                                                    }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Matthias Thoma (mthoma)                                                                        }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Various RunTime Type Information routines. Includes retrieving RTTI information for different    }
{ types, declaring/generating new types, data conversion to user displayable values and 'is'/'as'  }
{ operator hooking.                                                                                }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Last modified: $Date:: 2009-11-05 18:00:22 +0100 (jeu., 05 nov. 2009)                          $ }
{ Revision:      $Rev:: 3071                                                                     $ }
{ Author:        $Author:: ahuser                                                                $ }
{                                                                                                  }
{**************************************************************************************************}

unit JclRTTI;

{$I jcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$IFDEF HAS_UNIT_TYPES}
  Types,
  {$IFDEF SUPPORTS_INLINE}
  Windows,
  {$ENDIF SUPPORTS_INLINE}
  {$ELSE ~HAS_UNIT_TYPES}
  Windows,
  {$ENDIF ~HAS_UNIT_TYPES}
  Classes, SysUtils, TypInfo,
  JclBase;

type
  // TypeInfo writing
  IJclInfoWriter = interface
    ['{7DAD522D-46EA-11D5-B0C0-4854E825F345}']
    function GetWrap: Integer;
    procedure SetWrap(const Value: Integer);
    procedure Write(const S: string);
    procedure Writeln(const S: string = '');
    procedure Indent;
    procedure Outdent;
    property Wrap: Integer read GetWrap write SetWrap;
  end;

  TJclInfoWriter = class(TInterfacedObject, IJclInfoWriter)
  private
    FCurLine: string;
    FIndentLevel: Integer;
    FWrap: Integer;
  protected
    procedure DoWrap;
    procedure DoWriteCompleteLines;
    procedure PrimWrite(const S: string); virtual; abstract;

    property CurLine: string read FCurLine write FCurLine;
    property IndentLevel: Integer read FIndentLevel write FIndentLevel;
  public
    constructor Create(const AWrap: Integer = 80);
    destructor Destroy; override;
    { IJclInfoWriter }
    function GetWrap: Integer;
    procedure SetWrap(const Value: Integer);
    procedure Write(const S: string);
    procedure Writeln(const S: string = '');
    procedure Indent;
    procedure Outdent;
    property Wrap: Integer read GetWrap write SetWrap;
  end;

  TJclInfoStringsWriter = class(TJclInfoWriter)
  private
    FStrings: TStrings;
  protected
    procedure PrimWrite(const S: string); override;
  public
    constructor Create(const AStrings: TStrings; const AWrap: Integer = 80);

    property Strings: TStrings read FStrings;
  end;

  // TypeInfo retrieval
  IJclBaseInfo = interface
    procedure WriteTo(const Dest: IJclInfoWriter);
    procedure DeclarationTo(const Dest: IJclInfoWriter);
  end;

  IJclTypeInfo = interface(IJclBaseInfo)
    ['{7DAD5220-46EA-11D5-B0C0-4854E825F345}']
    function GetName: string;
    function GetTypeData: PTypeData;
    function GetTypeInfo: PTypeInfo;
    function GetTypeKind: TTypeKind;

    property Name: string read GetName;
    property TypeData: PTypeData read GetTypeData;
    property TypeInfo: PTypeInfo read GetTypeInfo;
    property TypeKind: TTypeKind read GetTypeKind;
  end;

  TJclTypeInfo = class(TInterfacedObject, IJclTypeInfo)
  private
    FTypeData: PTypeData;
    FTypeInfo: PTypeInfo;
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); virtual;
    procedure DeclarationTo(const Dest: IJclInfoWriter); virtual;
  public
    constructor Create(ATypeInfo: PTypeInfo);
    { IJclTypeInfo }
    function GetName: string;
    function GetTypeData: PTypeData;
    function GetTypeInfo: PTypeInfo;
    function GetTypeKind: TTypeKind;
    property Name: string read GetName;
    property TypeData: PTypeData read GetTypeData;
    property TypeInfo: PTypeInfo read GetTypeInfo;
    property TypeKind: TTypeKind read GetTypeKind;
  end;

  // Ordinal types
  IJclOrdinalTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5221-46EA-11D5-B0C0-4854E825F345}']
    function GetOrdinalType: TOrdType;

    property OrdinalType: TOrdType read GetOrdinalType;
  end;

  TJclOrdinalTypeInfo = class(TJclTypeInfo, IJclOrdinalTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
  public
    { IJclOrdinalTypeInfo }
    function GetOrdinalType: TOrdType;
    property OrdinalType: TOrdType read GetOrdinalType;
  end;

  IJclOrdinalRangeTypeInfo = interface(IJclOrdinalTypeInfo)
    ['{7DAD5222-46EA-11D5-B0C0-4854E825F345}']
    function GetMinValue: Int64;
    function GetMaxValue: Int64;

    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
  end;

  TJclOrdinalRangeTypeInfo = class(TJclOrdinalTypeInfo, IJclOrdinalRangeTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclOrdinalRangeTypeInfo }
    function GetMinValue: Int64;
    function GetMaxValue: Int64;
    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
  end;

  IJclEnumerationTypeInfo = interface(IJclOrdinalRangeTypeInfo)
    ['{7DAD5223-46EA-11D5-B0C0-4854E825F345}']
    function GetBaseType: IJclEnumerationTypeInfo;
    function GetNames(const I: Integer): string;
    function GetUnitName: string;

    function IndexOfName(const Name: string): Integer;

    property BaseType: IJclEnumerationTypeInfo read GetBaseType;
    property Names[const I: Integer]: string read GetNames; default;
    property UnitName: string read GetUnitName;
  end;

  TJclEnumerationTypeInfo = class(TJclOrdinalRangeTypeInfo, IJclEnumerationTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclEnumerationTypeInfo }
    function GetBaseType: IJclEnumerationTypeInfo;
    function GetNames(const I: Integer): string;
    function GetUnitName: string;
    function IndexOfName(const Name: string): Integer;
    property BaseType: IJclEnumerationTypeInfo read GetBaseType;
    property Names[const I: Integer]: string read GetNames; default;
  end;

  IJclSetTypeInfo = interface(IJclOrdinalTypeInfo)
    ['{7DAD5224-46EA-11D5-B0C0-4854E825F345}']
    function GetBaseType: IJclOrdinalTypeInfo;

    procedure GetAsList(const Value;  const WantRanges: Boolean;
      const Strings: TStrings);
    procedure SetAsList(out Value; const Strings: TStrings);

    property BaseType: IJclOrdinalTypeInfo read GetBaseType;
  end;

  TJclSetTypeInfo = class(TJclOrdinalTypeInfo, IJclSetTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclSetTypeInfo }
    function GetBaseType: IJclOrdinalTypeInfo;
    procedure GetAsList(const Value; const WantRanges: Boolean;
      const Strings: TStrings);
    procedure SetAsList(out Value; const Strings: TStrings);
    property BaseType: IJclOrdinalTypeInfo read GetBaseType;
  end;

  // Float types
  IJclFloatTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5225-46EA-11D5-B0C0-4854E825F345}']
    function GetFloatType: TFloatType;

    property FloatType: TFloatType read GetFloatType;
  end;

  TJclFloatTypeInfo = class(TJclTypeInfo, IJclFloatTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclFloatTypeInfo }
    function GetFloatType: TFloatType;
    property FloatType: TFloatType read GetFloatType;
  end;

  // Short string types
  IJclStringTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5226-46EA-11D5-B0C0-4854E825F345}']
    function GetMaxLength: Integer;

    property MaxLength: Integer read GetMaxLength;
  end;

  TJclStringTypeInfo = class(TJclTypeInfo, IJclStringTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclStringTypeInfo }
    function GetMaxLength: Integer;
    property MaxLength: Integer read GetMaxLength;
  end;

  // Class types
  TJclPropSpecKind = (pskNone, pskStaticMethod, pskVirtualMethod, pskField,
    pskConstant);

  IJclPropInfo = interface
    ['{7DAD5227-46EA-11D5-B0C0-4854E825F345}']
    function GetPropInfo: PPropInfo;
    function GetPropType: IJclTypeInfo;
    function GetReader: Pointer;
    function GetWriter: Pointer;
    function GetStoredProc: Pointer;
    function GetIndex: Integer;
    function GetDefault: Longint;
    function GetNameIndex: Smallint;
    function GetName: string;
    function GetReaderType: TJclPropSpecKind;
    function GetWriterType: TJclPropSpecKind;
    function GetStoredType: TJclPropSpecKind;
    function GetReaderValue: TJclAddr;
    function GetWriterValue: TJclAddr;
    function GetStoredValue: TJclAddr;

    function IsStored(const AInstance: TObject): Boolean;
    function HasDefault: Boolean;
    function HasIndex: Boolean;

    property PropInfo: PPropInfo read GetPropInfo;
    property PropType: IJclTypeInfo read GetPropType;
    property Reader: Pointer read GetReader;
    property Writer: Pointer read GetWriter;
    property StoredProc: Pointer read GetStoredProc;
    property ReaderType: TJclPropSpecKind read GetReaderType;
    property WriterType: TJclPropSpecKind read GetWriterType;
    property StoredType: TJclPropSpecKind read GetStoredType;
    property ReaderValue: TJclAddr read GetReaderValue;
    property WriterValue: TJclAddr read GetWriterValue;
    property StoredValue: TJclAddr read GetStoredValue;
    property Index: Integer read GetIndex;
    property Default: Longint read GetDefault;
    property NameIndex: Smallint read GetNameIndex;
    property Name: string read GetName;
  end;

  TJclPropInfo = class(TInterfacedObject, IJclPropInfo)
  private
    FPropInfo: PPropInfo;
  public
    constructor Create(const APropInfo: PPropInfo);
    { IJclPropInfo }
    function GetPropInfo: PPropInfo;
    function GetPropType: IJclTypeInfo;
    function GetReader: Pointer;
    function GetWriter: Pointer;
    function GetStoredProc: Pointer;
    function GetIndex: Integer;
    function GetDefault: Longint;
    function GetNameIndex: Smallint;
    function GetName: string;
    function GetSpecKind(const Value: TJclAddr): TJclPropSpecKind;
    function GetSpecValue(const Value: TJclAddr): TJclAddr;
    function GetReaderType: TJclPropSpecKind;
    function GetWriterType: TJclPropSpecKind;
    function GetStoredType: TJclPropSpecKind;
    function GetReaderValue: TJclAddr;
    function GetWriterValue: TJclAddr;
    function GetStoredValue: TJclAddr;

    function IsStored(const AInstance: TObject): Boolean;
    function HasDefault: Boolean;
    function HasIndex: Boolean;

    property PropInfo: PPropInfo read GetPropInfo;
    property PropType: IJclTypeInfo read GetPropType;
    property Reader: Pointer read GetReader;
    property Writer: Pointer read GetWriter;
    property StoredProc: Pointer read GetStoredProc;
    property ReaderType: TJclPropSpecKind read GetReaderType;
    property WriterType: TJclPropSpecKind read GetWriterType;
    property StoredType: TJclPropSpecKind read GetStoredType;
    property ReaderValue: TJclAddr read GetReaderValue;
    property WriterValue: TJclAddr read GetWriterValue;
    property StoredValue: TJclAddr read GetStoredValue;
    property Index: Integer read GetIndex;
    property Default: Longint read GetDefault;
    property NameIndex: Smallint read GetNameIndex;
    property Name: string read GetName;
  end;

  IJclClassTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5228-46EA-11D5-B0C0-4854E825F345}']
    function GetClassRef: TClass;
    function GetParent: IJclClassTypeInfo;
    function GetTotalPropertyCount: Integer;
    function GetPropertyCount: Integer;
    function GetProperties(const PropIdx: Integer): IJclPropInfo;
    function GetPropNames(const Name: string): IJclPropInfo;
    function GetUnitName: string;

    property ClassRef: TClass read GetClassRef;
    property Parent: IJclClassTypeInfo read GetParent;
    property TotalPropertyCount: Integer read GetTotalPropertyCount;
    property PropertyCount: Integer read GetPropertyCount;
    property Properties[const PropIdx: Integer]: IJclPropInfo read GetProperties;
    property PropNames[const Name: string]: IJclPropInfo read GetPropNames;
    property UnitName: string read GetUnitName;
  end;

  TJclClassTypeInfo = class(TJclTypeInfo, IJclClassTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclClassTypeInfo }
    function GetClassRef: TClass;
    function GetParent: IJclClassTypeInfo;
    function GetTotalPropertyCount: Integer;
    function GetPropertyCount: Integer;
    function GetProperties(const PropIdx: Integer): IJclPropInfo;
    function GetPropNames(const Name: string): IJclPropInfo;
    function GetUnitName: string;
    property ClassRef: TClass read GetClassRef;
    property Parent: IJclClassTypeInfo read GetParent;
    property TotalPropertyCount: Integer read GetTotalPropertyCount;
    property PropertyCount: Integer read GetPropertyCount;
    property Properties[const PropIdx: Integer]: IJclPropInfo read GetProperties;
    property PropNames[const Name: string]: IJclPropInfo read GetPropNames;
  end;

  // Event types
  IJclEventParamInfo = interface
    ['{7DAD5229-46EA-11D5-B0C0-4854E825F345}']
    function GetFlags: TParamFlags;
    function GetName: string;
    function GetRecSize: Integer;
    function GetTypeName: string;
    function GetParam: Pointer;

    property Flags: TParamFlags read GetFlags;
    property Name: string read GetName;
    property RecSize: Integer read GetRecSize;
    property TypeName: string read GetTypeName;
    property Param: Pointer read GetParam;
  end;

  TJclEventParamInfo = class(TInterfacedObject, IJclEventParamInfo)
  private
    FParam: Pointer;
  public
    constructor Create(const AParam: Pointer);
    { IJclEventParamInfo }
    function GetFlags: TParamFlags;
    function GetName: string;
    function GetRecSize: Integer;
    function GetTypeName: string;
    function GetParam: Pointer;
    property Flags: TParamFlags read GetFlags;
    property Name: string read GetName;
    property RecSize: Integer read GetRecSize;
    property TypeName: string read GetTypeName;
    property Param: Pointer read GetParam;
  end;

  IJclEventTypeInfo = interface(IJclTypeInfo)
    ['{7DAD522A-46EA-11D5-B0C0-4854E825F345}']
    function GetMethodKind: TMethodKind;
    function GetParameterCount: Integer;
    function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
    function GetResultTypeName: string;

    property MethodKind: TMethodKind read GetMethodKind;
    property ParameterCount: Integer read GetParameterCount;
    property Parameters[const ParamIdx: Integer]: IJclEventParamInfo
      read GetParameters;
    property ResultTypeName: string read GetResultTypeName;
  end;

  TJclEventTypeInfo = class(TJclTypeInfo, IJclEventTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclEventTypeInfo }
    function GetMethodKind: TMethodKind;
    function GetParameterCount: Integer;
    function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
    function GetResultTypeName: string;
    property MethodKind: TMethodKind read GetMethodKind;
    property ParameterCount: Integer read GetParameterCount;
    property Parameters[const ParamIdx: Integer]: IJclEventParamInfo
      read GetParameters;
    property ResultTypeName: string read GetResultTypeName;
  end;

  // Interface types
  IJclInterfaceTypeInfo = interface(IJclTypeInfo)
    ['{7DAD522B-46EA-11D5-B0C0-4854E825F345}']
    function GetParent: IJclInterfaceTypeInfo;
    function GetFlags: TIntfFlagsBase;
    function GetGUID: TGUID;
    function GetPropertyCount: Integer;
    function GetUnitName: string;

    property Parent: IJclInterfaceTypeInfo read GetParent;
    property Flags: TIntfFlagsBase read GetFlags;
    property GUID: TGUID read GetGUID;
    property PropertyCount: Integer read GetPropertyCount;
    property UnitName: string read GetUnitName;
  end;

  TJclInterfaceTypeInfo = class(TJclTypeInfo, IJclInterfaceTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclInterfaceTypeInfo }
    function GetParent: IJclInterfaceTypeInfo;
    function GetFlags: TIntfFlagsBase;
    function GetGUID: TGUID;
    function GetPropertyCount: Integer;
    function GetUnitName: string;
    property Parent: IJclInterfaceTypeInfo read GetParent;
    property Flags: TIntfFlagsBase read GetFlags;
    property GUID: TGUID read GetGUID;
    property PropertyCount: Integer read GetPropertyCount;
  end;

  // Int64 types
  IJclInt64TypeInfo = interface(IJclTypeInfo)
    ['{7DAD522C-46EA-11D5-B0C0-4854E825F345}']
    function GetMinValue: Int64;
    function GetMaxValue: Int64;

    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
  end;

  TJclInt64TypeInfo = class(TJclTypeInfo, IJclInt64TypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclInt64TypeInfo }
    function GetMinValue: Int64;
    function GetMaxValue: Int64;
    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
  end;

  // Dynamic array types
  IJclDynArrayTypeInfo = interface(IJclTypeInfo)
    ['{7DAD522E-46EA-11D5-B0C0-4854E825F345}']
    function GetElementSize: Longint;
    function GetElementType: IJclTypeInfo;
    function GetElementsNeedCleanup: Boolean;
    function GetVarType: Integer;
    function GetUnitName: string;

    property ElementSize: Longint read GetElementSize;
    property ElementType: IJclTypeInfo read GetElementType;
    property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;
    property VarType: Integer read GetVarType;
    property UnitName: string read GetUnitName;
  end;

  TJclDynArrayTypeInfo = class(TJclTypeInfo, IJclDynArrayTypeInfo)
  protected
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    { IJclDynArrayTypeInfo }
    function GetElementSize: Longint;
    function GetElementType: IJclTypeInfo;
    function GetElementsNeedCleanup: Boolean;
    function GetVarType: Integer;
    function GetUnitName: string;
    property ElementSize: Longint read GetElementSize;
    property ElementType: IJclTypeInfo read GetElementType;
    property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;
    property VarType: Integer read GetVarType;
  end;

  EJclRTTIError = class(EJclError);

function JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;

// Enumeration types
const
  PREFIX_CUT_LOWERCASE = 255;
  PREFIX_CUT_EQUAL     = 254;

  MaxPrefixCut = 250;

function JclEnumValueToIdent(TypeInfo: PTypeInfo; const Value): string;

function JclGenerateEnumType(const TypeName: ShortString;
  const Literals: array of string): PTypeInfo;
function JclGenerateEnumTypeBasedOn(const TypeName: ShortString;
  BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;
function JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;
  const MinValue, MaxValue: Integer): PTypeInfo;


// Integer types
function JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;
function JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;

// Sets
function JclSetToList(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean;
  const Strings: TStrings): string;
function JclSetToStr(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean = False;
  const WantRanges: Boolean = False): string;
procedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);
procedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);
function JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;
function JclGenerateSetType(BaseType: PTypeInfo; const TypeName: ShortString): PTypeInfo;

// User generated type info managment
procedure RemoveTypeInfo(TypeInfo: PTypeInfo);

// Is/As hooking
function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.1-Build3536/jcl/source/common/JclRTTI.pas $';
    Revision: '$Revision: 3071 $';
    Date: '$Date: 2009-11-05 18:00:22 +0100 (jeu., 05 nov. 2009) $';
    LogPath: 'JCL\source\common';
    Extra: '';
    Data: nil
    );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysConst,
  JclLogic, JclResources, JclStrings, JclSysUtils;

//=== { TJclInfoWriter } =====================================================

constructor TJclInfoWriter.Create(const AWrap: Integer);
begin
  inherited Create;
  Wrap := AWrap;
end;

destructor TJclInfoWriter.Destroy;
begin
  if CurLine <> '' then
    Writeln('');
  inherited Destroy;
end;

function TJclInfoWriter.GetWrap: Integer;
begin
  Result := FWrap;
end;

procedure TJclInfoWriter.SetWrap(const Value: Integer);
begin
  FWrap := Value;
end;

procedure TJclInfoWriter.DoWrap;
const
  WrapChars : TSetOfAnsiChar = [#0..' ', '-'];
var
  TmpLines: TStringList;
  I: Integer;
  TmpLines2: TStringList;
  EndedInCRLF: Boolean;
  LineBreakLength: Integer;
begin
  LineBreakLength := Length(NativeLineBreak);
  EndedInCRLF := Copy(CurLine, Length(CurLine) - LineBreakLength + 1, LineBreakLength) = NativeLineBreak;
  TmpLines := TStringList.Create;
  try
    TmpLines.Text := CurLine;
    TmpLines2 := TStringList.Create;
    try
      I := TmpLines.Count-1;
      if not EndedInCRLF then
        Dec(I);
      while I >= 0 do
      begin
        TmpLines[I] := StringOfChar(' ', 2 * IndentLevel) + TmpLines[I];
        if (Wrap > 0) and (Length(TmpLines[I]) > Wrap) then
        begin
          TmpLines2.Text := WrapText(
            TmpLines[I],
            NativeLineBreak + StringOfChar(' ', 2 * (IndentLevel+1)),
            WrapChars,
            Wrap);
          TmpLines.Delete(I);
          TmpLines.Insert(I, Copy(TmpLines2.Text, 1,
            Length(TmpLines2.Text) - 2));
        end;
        Dec(I);
      end;
      CurLine := TmpLines.Text;
      if not EndedInCRLF then
        Delete(FCurLine, Length(FCurLine) - LineBreakLength + 1, LineBreakLength);
    finally
      TmpLines2.Free;
    end;
  finally
    TmpLines.Free;
  end;
end;

procedure TJclInfoWriter.DoWriteCompleteLines;
var
  CRLFPos: Integer;
begin
  CRLFPos := StrLastPos(NativeLineBreak, CurLine);
  if CRLFPos > 0 then
  begin
    PrimWrite(Copy(CurLine, 1, CRLFPos-1));
    Delete(FCurLine, 1, CRLFPos+1);
  end;
end;

procedure TJclInfoWriter.Indent;
begin
  IndentLevel := IndentLevel + 1;
end;

procedure TJclInfoWriter.Outdent;
begin
  IndentLevel := IndentLevel - 1;
end;

procedure TJclInfoWriter.Write(const S: string);
begin
  CurLine := CurLine + S;
  DoWrap;
  DoWriteCompleteLines;
end;

procedure TJclInfoWriter.Writeln(const S: string);
begin
  Write(S + NativeLineBreak);
end;

//=== { TJclInfoStringsWriter } ==============================================

constructor TJclInfoStringsWriter.Create(const AStrings: TStrings;
  const AWrap: Integer);
begin
  inherited Create(AWrap);
  FStrings := AStrings;
end;

procedure TJclInfoStringsWriter.PrimWrite(const S: string);
begin
  Strings.Add(S);
end;

//=== { TJclTypeInfo } =======================================================

constructor TJclTypeInfo.Create(ATypeInfo: PTypeInfo);
begin
  inherited Create;
  FTypeInfo := ATypeInfo;
  FTypeData := TypInfo.GetTypeData(ATypeInfo);
end;

function TJclTypeInfo.GetName: string;
begin
  Result := string(TypeInfo.Name);
end;

function TJclTypeInfo.GetTypeData: PTypeData;
begin
  Result := FTypeData;
end;

function TJclTypeInfo.GetTypeInfo: PTypeInfo;
begin
  Result := FTypeInfo;
end;

function TJclTypeInfo.GetTypeKind: TTypeKind;
begin
  Result := TypeInfo.Kind;
end;

procedure TJclTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  Dest.Writeln(LoadResString(@RsRTTIName) + Name);
  Dest.Writeln(LoadResString(@RsRTTITypeKind) + JclEnumValueToIdent(System.TypeInfo(TTypeKind),
    TypeInfo.Kind));
  Dest.Writeln(Format(LoadResString(@RsRTTITypeInfoAt), [TypeInfo]));
end;

procedure TJclTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Write(Format(LoadResString(@RsDeclarationFormat), [Name]));
end;

//=== { TJclOrdinalTypeInfo } ================================================

function TJclOrdinalTypeInfo.GetOrdinalType: TOrdType;
begin
  Result := TypeData.OrdType;
end;

procedure TJclOrdinalTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIOrdinalType) +
    JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
end;

//=== { TJclOrdinalRangeTypeInfo } ===========================================

function TJclOrdinalRangeTypeInfo.GetMinValue: Int64;
begin
  if OrdinalType = otULong then
    Result := Longword(TypeData.MinValue)
  else
    Result := TypeData.MinValue;
end;

function TJclOrdinalRangeTypeInfo.GetMaxValue: Int64;
begin
  if OrdinalType = otULong then
    Result := Longword(TypeData.MaxValue)
  else
    Result := TypeData.MaxValue;
end;

procedure TJclOrdinalRangeTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));
  Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));
end;

procedure TJclOrdinalRangeTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
const
  cRange = '..';
begin
  Dest.Write(Name + ' = ');
  if TypeInfo.Kind in [tkChar, tkWChar] then
  begin
    if (MinValue < Ord(' ')) or (MinValue > Ord('~')) then
      Dest.Write('#' + IntToStr(MinValue) + cRange)
    else
      Dest.Write('''' + Chr(Byte(MinValue)) + '''' + cRange);
    if (MaxValue < Ord(' ')) or (MaxValue > Ord('~')) then
      Dest.Write('#' + IntToStr(MaxValue))
    else
      Dest.Write('''' + Chr(Byte(MaxValue)) + '''');
  end
  else
    Dest.Write(IntToStr(MinValue) + '..' + IntToStr(MaxValue));
  Dest.Writeln('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
end;

//=== { TJclEnumerationTypeInfo } ============================================

function TJclEnumerationTypeInfo.GetBaseType: IJclEnumerationTypeInfo;
begin
  if TypeData.BaseType{$IFDEF BORLAND}^{$ENDIF} = TypeInfo then
    Result := Self
  else
    Result := TJclEnumerationTypeInfo.Create(TypeData.BaseType{$IFDEF BORLAND}^{$ENDIF});
end;

function TJclEnumerationTypeInfo.GetNames(const I: Integer): string;
var
  Base: IJclEnumerationTypeInfo;
  Idx: Integer;
  P: ^ShortString;
begin
  Base := BaseType;
  Idx := I;
  P := @Base.TypeData.NameList;
  while Idx <> 0 do
  begin
    Inc(TJclAddr(P), Length(P^) + 1);
    Dec(Idx);
  end;
  Result := string(P^);
end;

function TJclEnumerationTypeInfo.GetUnitName: string;
var
  I: Integer;
  P: ^ShortString;
begin
  if BaseType.TypeInfo = TypeInfo then
  begin
    I := MaxValue - MinValue;
    P := @TypeData.NameList;
    while I >= 0 do
    begin
      Inc(TJclAddr(P), Length(P^) + 1);
      Dec(I);
    end;
    Result := string(P^);
  end
  else
    Result := string(TypeData.NameList);
end;

function TJclEnumerationTypeInfo.IndexOfName(const Name: string): Integer;
begin
  Result := MaxValue;
  while (Result >= MinValue) and
        not AnsiSameText(Name, Names[Result]) do
    Dec(Result);
  if Result < MinValue then
    Result := -1;
end;

procedure TJclEnumerationTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  Idx: Integer;
  Prefix: string;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);
  Dest.Write(LoadResString(@RsRTTINameList));
  Prefix := '(';
  for Idx := MinValue to MaxValue do
  begin
    Dest.Write(Prefix + Names[Idx]);
    Prefix := ', ';
  end;
  Dest.Writeln(')');
end;

procedure TJclEnumerationTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Prefix: string;
  I: Integer;
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ');
  if BaseType.TypeInfo = TypeInfo then
  begin
    Dest.Write('(');
    Prefix := '';
    for I := MinValue to MaxValue do
    begin
      Dest.Write(Prefix + Names[I]);
      Prefix := ', ';
    end;
    Dest.Write(')');
  end
  else
    Dest.Write(Names[MinValue] + ' .. ' + Names[MaxValue]);
  if Name[1] <> '.' then
  begin
    Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
    Dest.Writeln('');
  end;
end;

//=== { TJclSetTypeInfo } ====================================================

function TJclSetTypeInfo.GetBaseType: IJclOrdinalTypeInfo;
begin
  Result := JclTypeInfo(TypeData.CompType{$IFDEF BORLAND}^{$ENDIF}) as IJclOrdinalTypeInfo;
end;

procedure TJclSetTypeInfo.GetAsList(const Value; const WantRanges: Boolean;
  const Strings: TStrings);
var
  BaseInfo: IJclOrdinalRangeTypeInfo;
  FirstBit: Byte;
  LastBit: Byte;
  Bit: Byte;
  StartBit: Integer;

  procedure AddRange;
  var
    FirstOrdNum: Int64;
    LastOrdNum: Int64;
    OrdNum: Int64;
  begin
    FirstOrdNum := (StartBit - FirstBit) + BaseInfo.MinValue;
    LastOrdNum := (Bit - 1 - FirstBit) + BaseInfo.MinValue;
    if WantRanges and (LastOrdNum <> FirstOrdNum) then
    begin
      if BaseInfo.TypeKind = tkEnumeration then
        Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[FirstOrdNum] +
          ' .. ' + (BaseInfo as IJclEnumerationTypeInfo).Names[LastOrdNum])
      else
        Strings.Add(IntToStr(FirstOrdNum) + ' .. ' + IntToStr(LastOrdNum));
    end
    else
    begin
      OrdNum := FirstOrdNum;
      while OrdNum <= LastOrdNum do
      begin
        if BaseInfo.TypeKind = tkEnumeration then
          Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[OrdNum])
        else
          Strings.Add(IntToStr(OrdNum));
        Inc(OrdNum);
      end;
    end;
  end;

begin
  BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;
  FirstBit := BaseInfo.MinValue mod 8;
  LastBit := BaseInfo.MaxValue - (BaseInfo.MinValue - FirstBit);
  Bit := FirstBit;
  StartBit := -1;
  Strings.BeginUpdate;
  try
    while Bit <= LastBit do
    begin
      if TestBitBuffer(Value, Bit) then
      begin
        if StartBit = -1 then
          StartBit := Bit;
      end
      else
      begin
        if StartBit <> -1 then
        begin
          AddRange;
          StartBit := -1;
        end;
      end;
      Inc(Bit);
    end;
    if StartBit <> -1 then
      AddRange;
  finally
    Strings.EndUpdate;
  end;
end;

procedure TJclSetTypeInfo.SetAsList(out Value; const Strings: TStrings);
var
  BaseInfo: IJclOrdinalRangeTypeInfo;
  FirstBit: Integer;
  I: Integer;
  FirstIdent: string;
  LastIdent: string;
  RangePos: Integer;
  FirstOrd: Int64;
  LastOrd: Int64;
  CurOrd: Integer;

  procedure ClearValue;
  var
    LastBit: Integer;
    ByteCount: Integer;
  begin
    LastBit := BaseInfo.MaxValue - BaseInfo.MinValue + 1 + FirstBit;
    ByteCount := (LastBit - FirstBit) div 8;
    if LastBit mod 8 <> 0 then
      Inc(ByteCount);
    ResetMemory(Value, ByteCount);
  end;

begin
  BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;
  FirstBit := BaseInfo.MinValue mod 8;
  ClearValue;
  Strings.BeginUpdate;
  try
  for I := 0 to Strings.Count - 1 do
    begin
      if Trim(Strings[I]) <> '' then
      begin
        FirstIdent := Trim(Strings[I]);
        RangePos := Pos('..', FirstIdent);
        if RangePos > 0 then
        begin
          LastIdent := Trim(StrRestOf(FirstIdent, RangePos + 2));
          FirstIdent := Trim(Copy(FirstIdent, 1, RangePos - 1));
        end
        else
          LastIdent := FirstIdent;
        if BaseInfo.TypeKind = tkEnumeration then
        begin
          FirstOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(FirstIdent);
          LastOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(LastIdent);
          if FirstOrd = -1 then
            raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [FirstIdent]);
          if LastOrd = -1 then
            raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [LastIdent]);
        end
        else
        begin
          FirstOrd := StrToInt(FirstIdent);
          LastOrd := StrToInt(LastIdent);
        end;
        Dec(FirstOrd, BaseInfo.MinValue);
        Dec(LastOrd, BaseInfo.MinValue);
        for CurOrd := FirstOrd to LastOrd do
          SetBitBuffer(Value, CurOrd + FirstBit);
      end;
    end;
  finally
    Strings.EndUpdate;
  end;
end;

procedure TJclSetTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIBasedOn));
  Dest.Indent;
  try
    BaseType.WriteTo(Dest);
  finally
    Dest.Outdent;
  end;
end;

procedure TJclSetTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Base: IJclOrdinalTypeInfo;
  BaseEnum: IJclEnumerationTypeInfo;
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = set of ');
  Base := BaseType;

  if Base.Name[1] = '.' then
  begin
    if Base.QueryInterface(IJclEnumerationTypeInfo, BaseEnum) = S_OK then
      BaseEnum.DeclarationTo(Dest)
    else
      Dest.Write(LoadResString(@RsRTTITypeError));
  end
  else
    Dest.Write(Base.Name);
  if Name[1] <> '.' then
  begin
    Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
    Dest.Writeln('');
  end;
end;

//=== { TJclFloatTypeInfo } ==================================================

function TJclFloatTypeInfo.GetFloatType: TFloatType;
begin
  Result := TypeData.FloatType;
end;

procedure TJclFloatTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIFloatType) +
    JclEnumValueToIdent(System.TypeInfo(TFloatType), TypeData.FloatType));
end;

procedure TJclFloatTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  S: string;
  FT: TFloatType;
begin
  FT := FloatType;
  S := StrRestOf(JclEnumValueToIdent(System.TypeInfo(TFloatType), FT), 3);
  Dest.Writeln(Name + ' = type ' + S + ';');
end;

//=== { TJclStringTypeInfo } =================================================

function TJclStringTypeInfo.GetMaxLength: Integer;
begin
  Result := TypeData.MaxLength;
end;

procedure TJclStringTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMaxLen) + IntToStr(MaxLength));
end;

procedure TJclStringTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ');
  Dest.Write('string[' + IntToStr(MaxLength) + ']');
  if Name[1] <> '.' then
    Dest.Writeln(';');
end;

//=== { TJclPropInfo } =======================================================

constructor TJclPropInfo.Create(const APropInfo: PPropInfo);
begin
  inherited Create;
  FPropInfo := APropInfo;
end;

function TJclPropInfo.GetPropInfo: PPropInfo;
begin
  Result := FPropInfo;
end;

function TJclPropInfo.GetPropType: IJclTypeInfo;
begin
  Result := JclTypeInfo(PropInfo.PropType{$IFDEF BORLAND}^{$ENDIF});
end;

function TJclPropInfo.GetReader: Pointer;
begin
  Result := PropInfo.GetProc;
end;

function TJclPropInfo.GetWriter: Pointer;
begin
  Result := PropInfo.SetProc;
end;

function TJclPropInfo.GetStoredProc: Pointer;
begin
  Result := PropInfo.StoredProc;
end;

function TJclPropInfo.GetIndex: Integer;
begin
  Result := PropInfo.Index;
end;

function TJclPropInfo.GetDefault: Longint;
begin
  Result := PropInfo.Default;
end;

function TJclPropInfo.GetNameIndex: Smallint;
begin
  Result := PropInfo.NameIndex;
end;

function TJclPropInfo.GetName: string;
begin
  Result := string(PropInfo.Name);
end;

function TJclPropInfo.GetSpecKind(const Value: TJclAddr): TJclPropSpecKind;
var
  P: Integer;
begin
  {$IFDEF CPU32}
  P := Value shr 24;
  {$ENDIF CPU32}
  {$IFDEF CPU64}
  P := Value shr 56;
  {$ENDIF CPU64}
  case P of
    $00:
      if Value < 2 then
        Result := pskConstant
      else
        Result := pskStaticMethod;
    $FE:
      Result := pskVirtualMethod;
    $FF:
      Result := pskField;
  else
    Result := pskStaticMethod;
  end;
end;

function TJclPropInfo.GetSpecValue(const Value: TJclAddr): TJclAddr;
begin
  case GetSpecKind(Value) of
    pskStaticMethod, pskConstant:
      Result := Value;
    pskVirtualMethod:
      {$IFDEF CPU32}
      Result := Value and $0000FFFF;
      {$ENDIF CPU32}
      {$IFDEF CPU64}
      Result := Value and $0000FFFFFFFFFFFF;
      {$ENDIF CPU64}
    pskField:
      {$IFDEF CPU32}
      Result := Value and $00FFFFFF;
      {$ENDIF CPU32}
      {$IFDEF CPU64}
      Result := Value and $00FFFFFFFFFFFFFF;
      {$ENDIF CPU64}
  else
    Result := 0;
  end;
end;

function TJclPropInfo.GetReaderType: TJclPropSpecKind;
begin
  Result := GetSpecKind(TJclAddr(Reader));
end;

function TJclPropInfo.GetWriterType: TJclPropSpecKind;
begin
  Result := GetSpecKind(TJclAddr(Writer));
end;

function TJclPropInfo.GetStoredType: TJclPropSpecKind;
begin
  Result := GetSpecKind(TJclAddr(StoredProc));
end;

function TJclPropInfo.GetReaderValue: TJclAddr;
begin
  Result := GetSpecValue(TJclAddr(Reader));
end;

function TJclPropInfo.GetWriterValue: TJclAddr;
begin
  Result := GetSpecValue(TJclAddr(Writer));
end;

function TJclPropInfo.GetStoredValue: TJclAddr;
begin
  Result := GetSpecValue(TJclAddr(StoredProc));
end;

function TJclPropInfo.IsStored(const AInstance: TObject): Boolean;
begin
  Result := IsStoredProp(AInstance, FPropInfo);
end;

function TJclPropInfo.HasDefault: Boolean;
begin
  Result := Longword(Default) <> $80000000;
end;

function TJclPropInfo.HasIndex: Boolean;
begin
  Result := Longword(Index) <> $80000000;
end;

//=== { TJclClassTypeInfo } ==================================================

function TJclClassTypeInfo.GetClassRef: TClass;
begin
  Result := TypeData.ClassType;
end;

function TJclClassTypeInfo.GetParent: IJclClassTypeInfo;
begin
  if (TypeData.ParentInfo <> nil) {$IFDEF BORLAND}and (TypeData.ParentInfo^ <> nil){$ENDIF BORLAND} then
    Result := JclTypeInfo(TypeData.ParentInfo{$IFDEF BORLAND}^{$ENDIF}) as IJclClassTypeInfo
  else
    Result := nil;
end;

function TJclClassTypeInfo.GetTotalPropertyCount: Integer;
begin
  Result := TypeData.PropCount;
end;

function TJclClassTypeInfo.GetPropertyCount: Integer;
var
  PropData: ^TPropData;
begin
  PropData := @TypeData.UnitName;
  Inc(TJclAddr(PropData), 1 + Length(GetUnitName));
  Result := PropData.PropCount;
end;

function TJclClassTypeInfo.GetProperties(const PropIdx: Integer): IJclPropInfo;
var
  PropData: ^TPropData;
  Prop: PPropInfo;
  Idx: Integer;
  RecSize: Integer;
begin
  PropData := @TypeData.UnitName;
  Inc(TJclAddr(PropData), 1 + Length(GetUnitName));
  if PropIdx + 1 > PropData.PropCount then
    Result := Parent.Properties[PropIdx - PropData.PropCount]
  else
  begin
    Prop := PPropInfo(PropData);
    Inc(TJclAddr(Prop), 2);
    if PropIdx > 0 then
    begin
      RecSize := SizeOf(TPropInfo) - SizeOf(ShortString);
      Idx := PropIdx;
      while Idx > 0 do
      begin
        Inc(TJclAddr(Prop), RecSize);
        Inc(TJclAddr(Prop), 1 + PByte(Prop)^);
        Dec(Idx);
      end;
    end;
    Result := TJclPropInfo.Create(Prop);
  end;
end;

function TJclClassTypeInfo.GetPropNames(const Name: string): IJclPropInfo;
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(TypeInfo, Name);
  if PropInfo <> nil then
    Result := TJclPropInfo.Create(PropInfo)
  else
    Result := nil;
end;

function TJclClassTypeInfo.GetUnitName: string;
begin
  Result := string(TypeData.UnitName);
end;

procedure TJclClassTypeInfo.WriteTo(const Dest: IJclInfoWriter);
const
  cFmt1 = '[%s %d]';
  cFmt2 = '[%s %s $%p]';
  cFmt3 = '[%s=%s]';
  cFmt4 = '[%s=%s $%p]';
var
  I: Integer;
  Prop: IJclPropInfo;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIClassName) + ClassRef.ClassName);
  Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.ClassRef.ClassName);
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);
  Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount) + ' (' +
    IntToStr(TotalPropertyCount) + ')');
  Dest.Indent;
  try
    for I := 0 to PropertyCount-1 do
    begin
      Prop := Properties[I];
      Dest.Writeln(Prop.Name + ': ' + Prop.PropType.Name);
      Dest.Indent;
      try
        if Prop.HasIndex then
          Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIIndex), Prop.Index]));
        if Prop.HasDefault then
          Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIDefault), Prop.Default]));
        case Prop.ReaderType of
          pskStaticMethod:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIStaticMethod),
              Pointer(Prop.ReaderValue)]));
          pskField:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIField),
              Pointer(Prop.ReaderValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIVirtualMethod),
              Pointer(Prop.ReaderValue)]));
        end;
        case Prop.WriterType of
          pskStaticMethod:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIStaticMethod),
              Pointer(Prop.WriterValue)]));
          pskField:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIField),
              Pointer(Prop.WriterValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIVirtualMethod),
              Pointer(Prop.WriterValue)]));
        end;
        case Prop.StoredType of
          pskConstant:
            if Boolean(Prop.StoredValue) then
              Dest.Writeln(Format(cFmt3, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTITrue)]))
            else
              Dest.Writeln(Format(cFmt3, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIFalse)]));
          pskStaticMethod:
            Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIStaticMethod),
              Pointer(Prop.StoredValue)]));
          pskField:
            Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIField),
              Pointer(Prop.StoredValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIVirtualMethod),
              Pointer(Prop.StoredValue)]));
        end;
      finally
        Dest.Outdent;
      end;
    end;
  finally
    Dest.Outdent;
  end;
end;

procedure TJclClassTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  IntfTbl: PInterfaceTable;
  I: Integer;
  Prop: IJclPropInfo;
begin
  if (Parent <> nil) and
     not AnsiSameText(Parent.Name, 'TObject') then
  begin
    Dest.Write(Name + ' = class(' + Parent.Name);
    IntfTbl := ClassRef.GetInterfaceTable;
    if IntfTbl <> nil then
      for I := 0 to IntfTbl.EntryCount-1 do
        {$IFDEF FPC}if IntfTbl.Entries[I].IID <> nil then{$ENDIF FPC}
        Dest.Write(', [''' + JclGUIDToString(IntfTbl.Entries[I].IID{$IFDEF FPC}^{$ENDIF}) + ''']');
    Dest.Writeln(') // unit ' + GetUnitName);
  end
  else
    Dest.Writeln(Name + ' = class // unit ' + GetUnitName);
  if PropertyCount > 0 then
  begin
    Dest.Writeln('published');
    Dest.Indent;
    try
      for I := 0 to PropertyCount-1 do
      begin
        Prop := Properties[I];
        Dest.Write('property ' + Prop.Name + ': ' +  Prop.PropType.Name);
        if Prop.HasIndex then
          Dest.Write(Format(' index %d', [Prop.Index]));

        case Prop.ReaderType of
          pskStaticMethod:
            Dest.Write(Format(' read [static method $%p]', [Pointer(Prop.ReaderValue)]));
          pskField:
            Dest.Write(Format(' read [field $%p]', [Pointer(Prop.ReaderValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' read [virtual method $%p]', [Pointer(Prop.ReaderValue)]));
        end;

        case Prop.WriterType of
          pskStaticMethod:
            Dest.Write(Format(' write [static method $%p]', [Pointer(Prop.WriterValue)]));
          pskField:
            Dest.Write(Format(' write [field $%p]', [Pointer(Prop.WriterValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' write [virtual method $%p]', [Pointer(Prop.WriterValue)]));
        end;

        case Prop.StoredType of
          pskConstant:
            if Boolean(Prop.StoredValue) then
              Dest.Write(' stored = True')
            else
              Dest.Write(' stored = False');
          pskStaticMethod:
            Dest.Write(Format(' stored = [static method $%p]', [Pointer(Prop.StoredValue)]));
          pskField:
            Dest.Write(Format(' stored = [field $%p]', [Pointer(Prop.StoredValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' stored = [virtual method $%p]', [Pointer(Prop.StoredValue)]));
        end;
        if Prop.HasDefault then
          Dest.Write(' default ' + IntToStr(Prop.Default));
        Dest.Writeln(';');
      end;
    finally
      Dest.Outdent;
    end;
  end;
  Dest.Writeln('end;');
end;

//=== { TJclEventParamInfo } =================================================

constructor TJclEventParamInfo.Create(const AParam: Pointer);
begin
  inherited Create;
  FParam := AParam;
end;

function TJclEventParamInfo.GetFlags: TParamFlags;
type
  PParamFlags = ^TParamFlags;
begin
  Result := PParamFlags(Param)^;
end;

function TJclEventParamInfo.GetName: string;
var
  PName: PShortString;
begin
  PName := Param;
  Inc(TJclAddr(PName));
  Result := string(PName^);
end;

function TJclEventParamInfo.GetRecSize: Integer;
begin
  Result := 3 + Length(Name) + Length(TypeName);
end;

function TJclEventParamInfo.GetTypeName: string;
var
  PName: PShortString;
begin
  PName := Param;
  Inc(TJclAddr(PName));
  Inc(TJclAddr(PName), PByte(PName)^ + 1);
  Result := string(PName^);
end;

function TJclEventParamInfo.GetParam: Pointer;
begin
  Result := FParam;
end;

//=== { TJclEventTypeInfo } ==================================================

function TJclEventTypeInfo.GetMethodKind: TMethodKind;
begin
  Result := TypeData.MethodKind;
end;

function TJclEventTypeInfo.GetParameterCount: Integer;
begin
  Result := TypeData.ParamCount;
end;

function TJclEventTypeInfo.GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
var
  I: Integer;
  Param: Pointer;
begin
  Result := nil;
  Param := @TypeData.ParamList[0];
  I := ParamIdx;
  while I >= 0 do
  begin
    Result := TJclEventParamInfo.Create(Param);
    Inc(TJclAddr(Param), Result.RecSize);
    Dec(I);
  end;
end;

function TJclEventTypeInfo.GetResultTypeName: string;
var
  LastParam: IJclEventParamInfo;
  ResPtr: PShortString;
begin
  if MethodKind = mkFunction then
  begin
    if ParameterCount > 0 then
    begin
      LastParam := Parameters[ParameterCount-1];
      ResPtr := Pointer(TJclAddr(LastParam.Param) + TJclAddr(LastParam.RecSize));
    end
    else
      ResPtr := @TypeData.ParamList[0];
    Result := string(ResPtr^);
  end
  else
    Result := '';
end;

procedure TJclEventTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  I: Integer;
  Param: IJclEventParamInfo;
  ParamFlags: TParamFlags;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMethodKind) +
    JclEnumValueToIdent(System.TypeInfo(TMethodKind), TypeData.MethodKind));
  Dest.Writeln(LoadResString(@RsRTTIParamCount) + IntToStr(ParameterCount));
  Dest.Indent;
  try
    for I := 0 to ParameterCount-1 do
    begin
      if I > 0 then
        Dest.Writeln('');
      Param := Parameters[I];
      ParamFlags := Param.Flags;
      Dest.Writeln(LoadResString(@RsRTTIName) + Param.Name);
      Dest.Writeln(LoadResString(@RsRTTIType) + Param.TypeName);
      Dest.Writeln(LoadResString(@RsRTTIFlags) +
        JclSetToStr(System.TypeInfo(TParamFlags), ParamFlags, True, False));
    end;
  finally
    Dest.Outdent;
  end;
  if MethodKind = mkFunction then
    Dest.Writeln(LoadResString(@RsRTTIReturnType) + ResultTypeName);
end;

procedure TJclEventTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Prefix: string;
  I: Integer;
  Param: IJclEventParamInfo;
begin
  Dest.Write(Name + ' = ');
  if MethodKind = mkFunction then
    Dest.Write('function')
  else
    Dest.Write('procedure');
  Prefix := '(';
  for I := 0 to ParameterCount-1 do
  begin
    Dest.Write(Prefix);
    Prefix := '; ';
    Param := Parameters[I];
    if pfVar in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIVar))
    else
    if pfConst in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIConst))
    else
    if pfOut in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIOut));
    Dest.Write(Param.Name);
    if Param.TypeName <> '' then
    begin
      Dest.Write(': ');
      if pfArray in Param.Flags then
        Dest.Write(LoadResString(@RsRTTIArrayOf));
      if AnsiSameText(Param.TypeName, 'TVarRec') and (pfArray in Param.Flags) then
        Dest.Write(TrimRight(LoadResString(@RsRTTIConst)))
      else
        Dest.Write(Param.TypeName);
    end;
  end;
  if ParameterCount <> 0 then
    Dest.Write(')');
  if MethodKind = mkFunction then
    Dest.Write(': ' + ResultTypeName);
  Dest.Writeln(' of object;');
end;

//=== { TJclInterfaceTypeInfo } ==============================================

function TJclInterfaceTypeInfo.GetParent: IJclInterfaceTypeInfo;
begin
  if (TypeData.IntfParent <> nil) {$IFDEF BORLAND}and (TypeData.IntfParent^ <> nil){$ENDIF BORLAND} then
    Result := JclTypeInfo(TypeData.IntfParent{$IFDEF BORLAND}^{$ENDIF}) as IJclInterfaceTypeInfo
  else
    Result := nil;
end;

function TJclInterfaceTypeInfo.GetFlags: TIntfFlagsBase;
begin
  Result := TypeData.IntfFlags;
end;

const
  NullGUID: TGUID = '{00000000-0000-0000-0000-000000000000}';

function TJclInterfaceTypeInfo.GetGUID: TGUID;
begin
  if ifHasGuid in Flags then
    Result := TypeData.Guid
  else
    Result := NullGUID;
end;

function TJclInterfaceTypeInfo.GetPropertyCount: Integer;
var
  PropData: ^TPropData;
begin
  PropData := @TypeData.IntfUnit;
  Inc(TJclAddr(PropData), 1 + Length(GetUnitName));
  Result := PropData.PropCount;
end;

function TJclInterfaceTypeInfo.GetUnitName: string;
begin
  Result := string(TypeData.IntfUnit);
end;

procedure TJclInterfaceTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  IntfFlags: TIntfFlagsBase;
begin
  inherited WriteTo(Dest);
  if ifHasGuid in Flags then
    Dest.Writeln(LoadResString(@RsRTTIGUID) + JclGuidToString(GUID));
  IntfFlags := Flags;
  Dest.Writeln(LoadResString(@RsRTTIFlags) + JclSetToStr(System.TypeInfo(TIntfFlagsBase),
    IntfFlags, True, False));
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);
  if Parent <> nil then
    Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.Name);
  Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount));
end;

procedure TJclInterfaceTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Write(Name + ' = ');
  if ifDispInterface in Flags then
    Dest.Write('dispinterface')
  else
    Dest.Write('interface');
  if (Parent <> nil) and not (ifDispInterface in Flags) and not
      AnsiSameText(Parent.Name, 'IUnknown') then
    Dest.Write('(' + Parent.Name + ')');
  Dest.Writeln(' // unit ' + GetUnitName);
  Dest.Indent;
  try
    if ifHasGuid in Flags then
      Dest.Writeln('[''' + JclGuidToString(GUID) + ''']');
  finally
    Dest.Outdent;
    Dest.Writeln('end;');
  end;
end;

//=== { TJclInt64TypeInfo } ==================================================

function TJclInt64TypeInfo.GetMinValue: Int64;
begin
  Result := TypeData.MinInt64Value;
end;

function TJclInt64TypeInfo.GetMaxValue: Int64;
begin
  Result := TypeData.MaxInt64Value;
end;

procedure TJclInt64TypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));
  Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));
end;

procedure TJclInt64TypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Writeln(Name + ' = ' + IntToStr(MinValue) + ' .. ' + IntToStr(MaxValue) + ';');
end;

//=== { TJclDynArrayTypeInfo } ===============================================

function TJclDynArrayTypeInfo.GetElementSize: Longint;
begin
  Result := TypeData.elSize;
end;

function TJclDynArrayTypeInfo.GetElementType: IJclTypeInfo;
begin
  if TypeData.elType = nil then
  begin
    if TypeData.elType2 <> nil then
      Result := JclTypeInfo(TypeData.elType2^)
    else
      Result := nil;
  end
  else
    Result := JclTypeInfo(TypeData.elType^);
end;

function TJclDynArrayTypeInfo.GetElementsNeedCleanup: Boolean;
begin
  Result := TypeData.elType <> nil;
end;

function TJclDynArrayTypeInfo.GetVarType: Integer;
begin
  Result := TypeData.varType;
end;

function TJclDynArrayTypeInfo.GetUnitName: string;
begin
  Result := string(TypeData.DynUnitName);
end;

procedure TJclDynArrayTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIElSize) + IntToStr(ElementSize));
  if ElementType = nil then
    Dest.Writeln(LoadResString(@RsRTTIElType) + RsRTTITypeError)
  else
  if ElementType.Name[1] <> '.' then
    Dest.Writeln(LoadResString(@RsRTTIElType) + ElementType.Name)
  else
  begin
    Dest.Writeln(LoadResString(@RsRTTIElType));
    Dest.Indent;
    try
      ElementType.WriteTo(Dest);
    finally
      Dest.Outdent;
    end;
  end;
  Dest.Write(LoadResString(@RsRTTIElNeedCleanup));
  if ElementsNeedCleanup then
    Dest.Writeln(LoadResString(@RsRTTITrue))
  else
    Dest.Writeln(LoadResString(@RsRTTIFalse));
  Dest.Writeln(LoadResString(@RsRTTIVarType) + IntToStr(VarType));
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);
end;

procedure TJclDynArrayTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ' + LoadResString(@RsRTTIArrayOf))
  else
    Dest.Write(LoadResString(@RsRTTIArrayOf));
  if ElementType = nil then
    Dest.Write(LoadResString(@RsRTTITypeError))
  else
  if ElementType.Name[1] = '.' then
    ElementType.DeclarationTo(Dest)
  else
    Dest.Write(ElementType.Name);
  if Name[1] <> '.' then
    Dest.Writeln('; // Unit ' + GetUnitName);
end;

//=== Typeinfo retrieval =====================================================

function JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;
begin
  case ATypeInfo.Kind of
    tkInteger, tkChar, tkWChar:
      Result := TJclOrdinalRangeTypeInfo.Create(ATypeInfo);
    tkEnumeration:
      Result := TJclEnumerationTypeInfo.Create(ATypeInfo);
    tkSet:
      Result := TJclSetTypeInfo.Create(ATypeInfo);
    tkFloat:
      Result := TJclFloatTypeInfo.Create(ATypeInfo);
    tkString:
      Result := TJclStringTypeInfo.Create(ATypeInfo);
    tkClass:
      Result := TJclClassTypeInfo.Create(ATypeInfo);
    tkMethod:
      Result := TJclEventTypeInfo.Create(ATypeInfo);
    tkInterface:
      Result := TJclInterfaceTypeInfo.Create(ATypeInfo);
    tkInt64:
      Result := TJclInt64TypeInfo.Create(ATypeInfo);
    tkDynArray:
      Result := TJclDynArrayTypeInfo.Create(ATypeInfo);
  else
    Result := TJclTypeInfo.Create(ATypeInfo);
  end;
end;

//=== User generated type info managment =====================================

var
  TypeList: TThreadList;

type
  PTypeItem = ^TTypeItem;
  TTypeItem = record
    TypeInfo: PTypeInfo;
    RefCount: Integer;
  end;

procedure FreeTypeData(const TypeInfo: PTypeInfo);
var
  TD: PTypeData;
begin
  TD := GetTypeData(TypeInfo);
  if TypeInfo.Kind = tkSet then
    RemoveTypeInfo(TD^.CompType{$IFDEF BORLAND}^{$ENDIF})
  else
  if (TypeInfo.Kind = tkEnumeration) and (TD^.BaseType{$IFDEF BORLAND}^{$ENDIF} <> TypeInfo) then
    RemoveTypeInfo(GetTypeData(TypeInfo)^.BaseType{$IFDEF BORLAND}^{$ENDIF});
  FreeMem(GetTypeData(TypeInfo)^.BaseType);
  FreeMem(TypeInfo);
end;

procedure AddType(const TypeInfo: PTypeInfo);
var
  Item: PTypeItem;
begin
  New(Item);
  try
    Item.TypeInfo := TypeInfo;
    Item.RefCount := 1;
    TypeList.Add(Item);
  except
    Dispose(Item);
    raise;
  end;
end;

procedure DeleteType(const TypeItem: PTypeItem);
begin
  FreeTypeData(TypeItem.TypeInfo);
  TypeList.Remove(TypeItem);
  Dispose(TypeItem);
end;

procedure DoRefType(const TypeInfo: PTypeInfo; Add: Integer);
var
  I: Integer;
  List: TList;
begin
  List := TypeList.LockList;
  try
    I := List.Count-1;
    while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do
      Dec(I);
    if I > -1 then
      Inc(PTypeItem(List[I]).RefCount, Add);
  finally
    TypeList.UnlockList;
  end;
end;

procedure ReferenceType(const TypeInfo: PTypeInfo);
begin
  DoRefType(TypeInfo, 1);
end;

procedure DeReferenceType(const TypeInfo: PTypeInfo);
begin
  DoRefType(TypeInfo, -1);
end;

procedure ClearInfoList;
var
  L: TList;
begin
  L := TypeList.LockList;
  try
    while L.Count > 0 do
      RemoveTypeInfo(PTypeItem(L[L.Count-1])^.TypeInfo);
  finally
    TypeList.UnlockList;
  end;
end;

procedure NewInfoItem(const TypeInfo: PTypeInfo);
begin
  TypeList.Add(TypeInfo);
end;

procedure RemoveTypeInfo(TypeInfo: PTypeInfo);
var
  I: Integer;
  List: TList;
  Item: PTypeItem;
begin
  Item := nil;
  List := TypeList.LockList;
  try
    I := List.Count-1;
    while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do
      Dec(I);
    if I > -1 then
      Item := PTypeItem(List[I]);
  finally
    TypeList.UnlockList;
  end;
  if Item <> nil then
  begin
    Dec(Item.RefCount);
    if Item.RefCount <= 0 then
      DeleteType(Item);
  end;
end;

//=== Enumerations ===========================================================

function JclEnumValueToIdent(TypeInfo: PTypeInfo;
  const Value): string;
var
  MinEnum: Integer;
  MaxEnum: Integer;
  EnumVal: Int64;
  OrdType: TOrdType;
begin
  OrdType := GetTypeData(TypeInfo).OrdType;
  MinEnum := GetTypeData(TypeInfo).MinValue;
  MaxEnum := GetTypeData(TypeInfo).MaxValue;
  case OrdType of
    otSByte:
      EnumVal := Smallint(Value);
    otUByte:
      EnumVal := Byte(Value);
    otSWord:
      EnumVal := Shortint(Value);
    otUWord:
      EnumVal := Word(Value);
    otSLong:
      EnumVal := Integer(Value);
    otULong:
      EnumVal := Longword(Value);
  else
    EnumVal := 0;
  end;
  // Check range...
  if (EnumVal < MinEnum) or (EnumVal > MaxEnum) then
    Result := Format(LoadResString(@RsRTTIValueOutOfRange),
      [LoadResString(@RsRTTIOrdinal) + IntToStr(EnumVal)])
  else
    Result := GetEnumName(TypeInfo, EnumVal);
end;

function JclGenerateEnumType(const TypeName: ShortString;
  const Literals: array of string): PTypeInfo;
var
  StringSize: Integer;
  I: Integer;
  TypeData: PTypeData;
  CurName: PShortString;
begin
  StringSize := 0;
  for I := Low(Literals) to High(Literals) do
    StringSize := StringSize + 1 + Length(Literals[I]);
  Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +
    (2*SizeOf(Integer)) + SizeOf(PPTypeInfo) +
    StringSize + 1);
  try
    with Result^ do
    begin
      Kind := tkEnumeration;
      Name := TypeName;
    end;
    TypeData := GetTypeData(Result);
    TypeData^.BaseType := AllocMem(SizeOf(Pointer));
    if Length(Literals) < 256 then
      TypeData^.OrdType := otUByte
    else
    if Length(Literals) < 65536 then
      TypeData^.OrdType := otUWord
    else
      TypeData^.OrdType := otULong;
    TypeData^.MinValue := 0;
    TypeData^.MaxValue := Length(Literals)-1;
    TypeData^.BaseType{$IFDEF BORLAND}^{$ENDIF} := Result;   // No sub-range: basetype points to itself
    CurName := @TypeData^.NameList;
    for I := Low(Literals) to High(Literals) do
    begin
      CurName^ := ShortString(Literals[I]);
      Inc(TJclAddr(CurName), Length(Literals[I])+1);
    end;
    CurName^ := ''; // Unit name unknown
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
end;

function JclGenerateEnumTypeBasedOn(const TypeName: ShortString;
  BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;
var
  BaseInfo: IJclTypeInfo;
  BaseKind: TTypeKind;
  Literals: array of string;
  I: Integer;
  S: string;
begin
  BaseInfo := JclTypeInfo(BaseType);
  BaseKind := BaseInfo.TypeKind;
  if BaseInfo.TypeKind <> tkEnumeration then
    raise EJclRTTIError.CreateResFmt(@RsRTTIInvalidBaseType, [BaseInfo.Name,
      JclEnumValueToIdent(System.TypeInfo(TTypeKind), BaseKind)]);
  with BaseInfo as IJclEnumerationTypeInfo do
  begin
    SetLength(Literals, MaxValue - MinValue + 1);
    for I := MinValue to MaxValue do
    begin
      S := Names[I];
      if PrefixCut = PREFIX_CUT_LOWERCASE then
        while (Length(S) > 0) and CharIsLower(S[1]) do
          Delete(S, 1, 1);
      if (PrefixCut > 0) and (PrefixCut < MaxPrefixCut) then
        Delete(S, 1, PrefixCut);
      if S = '' then
        S := Names[I];
      Literals[I- MinValue] := S;
    end;
    if PrefixCut = PREFIX_CUT_EQUAL then
    begin
      S := Literals[High(Literals)];
      I := High(Literals)-1;
      while (I >= 0) and (S > '') do
      begin
        while Copy(Literals[I], 1, Length(S)) <> S do
          Delete(S, Length(S), 1);
        Dec(I);
      end;
      if S > '' then
        for I := Low(Literals) to High(Literals) do
        begin
          Literals[I] := StrRestOf(Literals[I], Length(S));
          if Literals[I] = '' then
            Literals[I] := Names[I + MinValue];
        end;
    end;
  end;
  Result := JclGenerateEnumType(TypeName, Literals);
end;

function JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;
  const MinValue, MaxValue: Integer): PTypeInfo;
var
  TypeData: PTypeData;
begin
  Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +
    (2*SizeOf(Integer)) + SizeOf(PPTypeInfo));
  try
    with Result^ do
    begin
      Kind := BaseType^.Kind;
      Name := ShortString(TypeName);
    end;
    TypeData := GetTypeData(Result);
    TypeData^.OrdType := GetTypeData(BaseType)^.OrdType;
    TypeData^.MinValue := MinValue;
    TypeData^.MaxValue := MaxValue;
    TypeData^.BaseType := AllocMem(SizeOf(Pointer));
    TypeData^.BaseType{$IFDEF BORLAND}^{$ENDIF} := BaseType;
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
  ReferenceType(BaseType);
end;

//=== Integers ===============================================================

function JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;
var
  Conv: TIdentToInt;
  HaveConversion: Boolean;
  Info: IJclTypeInfo;
  RangeInfo: IJclOrdinalRangeTypeInfo;
  TmpVal: Int64;
begin
  if TypeInfo <> nil then
    Conv := FindIdentToInt(TypeInfo)
  else
    Conv := nil;
  Result := 0;
  HaveConversion := (@Conv <> nil) and Conv(Value, Result);
  if not HaveConversion then
  begin
    if TypeInfo <> nil then
    begin
      Info := JclTypeInfo(TypeInfo);
      if Info.QueryInterface(IJclOrdinalRangeTypeInfo, RangeInfo) <> S_OK then
        RangeInfo := nil;
      TmpVal := StrToInt64(Value);
      if (RangeInfo <> nil) and ((TmpVal < RangeInfo.MinValue) or
          (TmpVal > RangeInfo.MaxValue)) then
        raise EConvertError.CreateResFmt(@SInvalidInteger, [Value]);
      Result := Integer(TmpVal);
    end
    else
      Result := StrToInt(Value)
  end;
end;

function JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;
var
  Conv: TIntToIdent;
  HaveConversion: Boolean;
begin
  if TypeInfo <> nil then
    Conv := FindIntToIdent(TypeInfo)
  else
    Conv := nil;
  Result := '';
  HaveConversion := (@Conv <> nil) and Conv(Value, Result);
  if not HaveConversion then
  begin
    if (TypeInfo <> nil) and (GetTypeData(TypeInfo).OrdType = otULong) then
      Result := IntToStr(Int64(Cardinal(Value)))
    else
      Result := IntToStr(Value)
  end;
end;

//=== Sets ===================================================================

function JclSetToList(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean;
  const Strings: TStrings): string;
var
  SetType: IJclSetTypeInfo;
  I: Integer;
begin
  I := Strings.Count;
  Result := '';
  SetType := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;
  SetType.GetAsList(Value, WantRanges, Strings);
  for I := I to Strings.Count - 1 do
  begin
    if Result <> '' then
      Result := Result + ', ' + Strings[I]
    else
      Result := Result + Strings[I];
  end;
  if WantBrackets then
    Result := '[' + Result + ']';
end;

function JclSetToStr(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean): string;
var
  Dummy: TStringList;
begin
  Dummy := TStringList.Create;
  try
    Result := JclSetToList(TypeInfo, Value, WantBrackets, WantRanges, Dummy);
  finally
    Dummy.Free;
  end;
end;

procedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);
var
  SetInfo: IJclSetTypeInfo;
  S: TStringList;
begin
  SetInfo := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;
  S := TStringList.Create;
  try
    StrToStrings(Value, ',', S);
    if S.Count > 0 then
    begin
      if S[0][1] = '[' then
      begin
        S[0] := Copy(S[0], 2, Length(S[0]));
        S[S.Count-1] := Copy(S[S.Count-1], 1,
          Length(S[S.Count-1]) - 1);
      end;
    end;
    SetInfo.SetAsList(SetVar, S);
  finally
    S.Free;
  end;
end;

procedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);
var
  BitShift: Integer;
  TmpInt64: Int64;
  EnumMin: Integer;
  EnumMax: Integer;
  ResBytes: Integer;
  CompType: PTypeInfo;
begin
  CompType := GetTypeData(TypeInfo).CompType{$IFDEF BORLAND}^{$ENDIF};
  EnumMin := GetTypeData(CompType).MinValue;
  BitShift := EnumMin mod 8;
  TmpInt64 := Longword(Value) shl BitShift;
  EnumMax := GetTypeData(CompType).MaxValue;
  ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;
  Move(TmpInt64, SetVar, ResBytes);
end;

function JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;
var
  BitShift: Integer;
  TmpInt64: Int64;
  EnumMin: Integer;
  EnumMax: Integer;
  ResBytes: Integer;
  CompType: PTypeInfo;
begin
  CompType := GetTypeData(TypeInfo).CompType{$IFDEF BORLAND}^{$ENDIF};
  EnumMin := GetTypeData(CompType).MinValue;
  EnumMax := GetTypeData(CompType).MaxValue;
  ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;
  BitShift := EnumMin mod 8;
  if (EnumMax - EnumMin) > 32 then
    raise EJclRTTIError.CreateResFmt(@RsRTTIValueOutOfRange,
      [IntToStr(EnumMax - EnumMin) + ' ' + LoadResString(@RsRTTIBits)]);
  Result := 0;
  TmpInt64 := 0;
  Move(SetVar, TmpInt64, ResBytes + 1);
  TmpInt64 := TmpInt64 shr BitShift;
  Move(TmpInt64, Result, ResBytes);
end;

function JclGenerateSetType(BaseType: PTypeInfo;
  const TypeName: ShortString): PTypeInfo;
var
  TypeData: PTypeData;
  ValCount: Integer;
begin
  Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) + SizeOf(PPTypeInfo));
  try
    with Result^ do
    begin
      Kind := tkSet;
      Name := TypeName;
    end;
    with GetTypeData(BaseType)^ do
      ValCount := MaxValue - MinValue + (MinValue mod 8);
    TypeData := GetTypeData(Result);
    case ValCount of
      0..8:
        TypeData^.OrdType := otUByte;
      9..16:
        TypeData^.OrdType := otUWord;
      17..32:
        TypeData^.OrdType := otULong;
      33..64:
        Byte(TypeData^.OrdType) := 8;
      65..128:
        Byte(TypeData^.OrdType) := 16;
      129..256:
        Byte(TypeData^.OrdType) := 32;
    else
      Byte(TypeData^.OrdType) := 255;
    end;
    {$IFDEF BORLAND}
    TypeData^.CompType := AllocMem(SizeOf(Pointer));
    TypeData^.CompType^ := BaseType;
    {$ENDIF BORLAND}
    {$IFDEF FPC}
    TypeData^.CompType := BaseType;
    {$ENDIF FPC}
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
  ReferenceType(BaseType);
end;

//=== Is/As hooking ==========================================================

// Copied from System.pas (_IsClass function)

function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
asm
        {$IFDEF CPU32}
        // 32 --> EAX AnObj
        //        EDX AClass
        //    <-- AL  Result
        TEST    EAX,EAX
        JE      @@exit
@@loop:
        MOV     EAX,[EAX]
        CMP     EAX,EDX
        JE      @@success
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // 64 --> RCX AnObj
        //        RDX AClass
        //    <-- AL  Result
        MOV     RAX,RCX
        TEST    RAX,RAX
        JE      @@exit
@@loop:
        MOV     RAX,[RAX]
        CMP     RAX,RDX
        JE      @@success
        MOV     RAX,[RAX].vmtParent
        TEST    RAX,RAX
        {$ENDIF CPU64}
        JNE     @@loop
        JMP     @@exit
@@success:
        MOV     AL,1
@@exit:
end;

function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;
var
  CurClass: TClass;
  CurClass2: TClass;
begin
  Result := AnObj <> nil;
  if Result then
  begin
    CurClass := AnObj.ClassType;
    Result := False;
    while not Result and (CurClass <> nil) do
    begin
      Result := CurClass.ClassNameIs(AClass.ClassName);
      if not Result then
        CurClass := CurClass.ClassParent;
    end;
    if CurClass <> nil then
      CurClass := CurClass.ClassParent;
    CurClass2 := AClass.ClassParent;
    while Result and (CurClass <> nil) and (CurClass2 <> nil) do
    begin
      Result := CurClass.ClassNameIs(CurClass2.ClassName);
      if Result then
      begin
        CurClass := CurClass.ClassParent;
        CurClass2 := CurClass2.ClassParent;
      end;
    end;
    Result := Result and (CurClass = CurClass2);
  end;
end;

function JclAsClass(const AnObj: TObject; const AClass: TClass): TObject;
begin
  if (AnObj = nil) or (AnObj is AClass) then
    Result := AnObj
  else
    raise EInvalidCast.CreateRes(@SInvalidCast);
end;

initialization
  TypeList := TThreadList.Create;
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}
  ClearInfoList;
  FreeAndNil(TypeList);

end.