{**************************************************************************************************}
{                                                                                                  }
{ 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 documented in the accompanying                     }
{ help file JCL.chm. Portions created by these individuals are Copyright (C) of these individuals. }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ 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.                                                                                }
{                                                                                                  }
{ Unit owner: Marcel Bestebroer                                                                    }
{ Last modified: July 21, 2001                                                                     }
{                                                                                                  }
{**************************************************************************************************}

unit JclRTTI;

{$I jcl.inc}

interface

uses
  Windows, Classes, SysUtils, TypInfo,
  JclBase;

type
  EJclRTTI = class (EJclError);

//--------------------------------------------------------------------------------------------------
// TypeInfo writing
//--------------------------------------------------------------------------------------------------

type
  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
    function GetWrap: Integer;
    procedure SetWrap(const Value: Integer);
    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;
    procedure Indent;
    procedure Outdent;
    procedure Write(const S: string);
    procedure Writeln(const S: string = '');

    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 retreival
//--------------------------------------------------------------------------------------------------

type
  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;

  // Ordinal types
  IJclOrdinalTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5221-46EA-11D5-B0C0-4854E825F345}']
    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;

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

    function IndexOfName(const Name: string): Integer;

    property BaseType: IJclEnumerationTypeInfo read GetBaseType;
    property Names[const I: Integer]: string read GetNames; default;
    {$IFDEF COMPILER6_UP}
    property UnitName: string read GetUnitName;
    {$ENDIF COMPILER6_UP}
  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;

  // Float types
  IJclFloatTypeInfo = interface(IJclTypeInfo)
    ['{7DAD5225-46EA-11D5-B0C0-4854E825F345}']
    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;

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

  IJclPropInfo = interface
    ['{7DAD5227-46EA-11D5-B0C0-4854E825F345}']
    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: Integer;
    function GetWriterValue: Integer;
    function GetStoredValue: Integer;

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

    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: Integer read GetReaderValue;
    property WriterValue: Integer read GetWriterValue;
    property StoredValue: Integer 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 GetUnitName: string;

    property ClassRef: TClass read GetClassRef;
    property Parent: IJclClassTypeInfo read GetParent;
    property TotalPropertyCount: Integer read GetPropertyCount;
    property PropertyCount: Integer read GetPropertyCount;
    property Properties[const PropIdx: Integer]: IJclPropInfo
      read GetProperties;
    property UnitName: string read GetUnitName;
  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;

  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;

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

    property Parent: IJclInterfaceTypeInfo read GetParent;
    property Flags: TIntfFlagsBase read GetFlags;
    property GUID: TGUID read GetGUID;
    {$IFDEF COMPILER6_UP}
    property PropertyCount: Integer read GetPropertyCount;
    {$ENDIF COMPILER6_UP}
    property UnitName: string read GetUnitName;
  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;

  {$IFDEF COMPILER6_UP}
  // 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;
  {$ENDIF COMPILER6_UP}

function JclTypeInfo(const ATypeInfo: PTypeInfo): IJclTypeInfo;

//--------------------------------------------------------------------------------------------------
// Enumeration types
//--------------------------------------------------------------------------------------------------

const
  PREFIX_CUT_LOWERCASE = 255;
  PREFIX_CUT_EQUAL     = 254;

  MaxPrefixCut = 250;

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

//--------------------------------------------------------------------------------------------------
// Integer types
//--------------------------------------------------------------------------------------------------

{$IFDEF COMPILER5_UP}
function JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;
function JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;
{$ENDIF COMPILER5_UP}

//--------------------------------------------------------------------------------------------------
// Sets
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// GUID
//--------------------------------------------------------------------------------------------------

function JclGUIDToString(const GUID: TGUID): string;
function JclStringToGUID(const S: string): TGUID;

//--------------------------------------------------------------------------------------------------
// User generated type info managment
//--------------------------------------------------------------------------------------------------

procedure RemoveTypeInfo(const TypeInfo: PTypeInfo);

//--------------------------------------------------------------------------------------------------
// Is/As hooking
//--------------------------------------------------------------------------------------------------

type
  TJclIsFunc = function(const AnObj: TObject; const AClass: TClass): Boolean;

function JclHookIs(const IsProc: TJclIsFunc): Boolean;
function JclIsHooked: Boolean;
function JclUnhookIs: Boolean;

function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;

implementation

uses
  Consts, SysConst,
  JclLogic, JclResources, JclStrings, JclSysUtils;

{$IFNDEF COMPILER5_UP}
function VirtualProtect(lpAddress: Pointer; dwSize, flNewProtect: DWORD;
  var flOldProtect: DWORD): BOOL; stdcall; external 'kernel32.dll' name 'VirtualProtect';
{$ENDIF COMPILER5_UP}

//--------------------------------------------------------------------------------------------------
// TJclInfoWriter
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclInfoWriter.DoWrap;
var
  TmpLines: TStringList;
  I: Integer;
  TmpLines2: TStringList;
  EndedInCRLF: Boolean;
begin
  EndedInCRLF := Copy(CurLine, Length(CurLine) - 1, 2) = AnsiCrLf;
  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],
            AnsiCrLf + StringOfChar(' ', 2 * (IndentLevel+1)),
            [#0 .. ' ', '-'],
            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) - 1, 2);
    finally
      TmpLines2.Free;
    end;
  finally
    TmpLines.Free;
  end;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

destructor TJclInfoWriter.Destroy;
begin
  if CurLine <> '' then
    Writeln('');
  inherited Destroy;
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 + AnsiCrLf);
end;

//--------------------------------------------------------------------------------------------------
// TJclInfoStringsWriter
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// TJclTypeInfo
//--------------------------------------------------------------------------------------------------

type
  TJclTypeInfo = class(TInterfacedObject, IJclTypeInfo)
  private
    FTypeData: PTypeData;
    FTypeInfo: PTypeInfo;
  protected
    function GetName: string;
    function GetTypeData: PTypeData;
    function GetTypeInfo: PTypeInfo;
    function GetTypeKind: TTypeKind;
    procedure WriteTo(const Dest: IJclInfoWriter); virtual;
    procedure DeclarationTo(const Dest: IJclInfoWriter); virtual;
  public
    constructor Create(const ATypeInfo: PTypeInfo);

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

//--------------------------------------------------------------------------------------------------

function TJclTypeInfo.GetName: string;
begin
  Result := 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(RsRTTIName + Name);
  Dest.Writeln(RsRTTITypeKind + JclEnumValueToIdent(System.TypeInfo(TTypeKind),
    TypeInfo.Kind));
  Dest.Writeln(Format(RsRTTITypeInfoAt, [TypeInfo]));
end;

//--------------------------------------------------------------------------------------------------

procedure TJclTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Write('// Declaration for ''' + Name + ''' not supported.');
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// TJclOrdinalTypeInfo
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// TJclOrdinalRangeTypeInfo
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclOrdinalRangeTypeInfo.GetMinValue: Int64;
begin
  {$IFDEF COMPILER5_UP}
  if OrdinalType = otULong then
    Result := Longword(TypeData.MinValue)
  else
  {$ENDIF COMPILER5_UP}
    Result := TypeData.MinValue;
end;

//--------------------------------------------------------------------------------------------------

function TJclOrdinalRangeTypeInfo.GetMaxValue: Int64;
begin
  {$IFDEF COMPILER5_UP}
  if OrdinalType = otULong then
    Result := Longword(TypeData.MaxValue)
  else
  {$ENDIF COMPILER5_UP}
    Result := TypeData.MaxValue;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// TJclEnumerationTypeInfo
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclEnumerationTypeInfo.GetBaseType: IJclEnumerationTypeInfo;
begin
  if TypeData.BaseType^ = TypeInfo then
    Result := Self
  else
    Result := TJclEnumerationTypeInfo.Create(TypeData.BaseType^);
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(Integer(P), Length(P^) + 1);
    Dec(Idx);
  end;
  Result := P^;
end;

//--------------------------------------------------------------------------------------------------

{$IFDEF COMPILER6_UP}

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(Integer(P), Length(P^) + 1);
      Dec(I);
    end;
    Result := P^;
  end
  else
    Result := TypeData.NameList;
end;

{$ENDIF COMPILER6_UP}

//--------------------------------------------------------------------------------------------------

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);
  {$IFDEF COMPILER6_UP}
  Dest.Writeln(RsRTTIUnitName + UnitName);
  {$ENDIF COMPILER6_UP}
  Dest.Write(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
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclSetTypeInfo.GetBaseType: IJclOrdinalTypeInfo;
begin
  Result := JclTypeInfo(TypeData.CompType^) 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;
  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;
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);
    FillChar(Value, ByteCount, 0);
  end;

begin
  BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;
  FirstBit := BaseInfo.MinValue mod 8;
  ClearValue;
  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 EJclRTTI.CreateResRecFmt(@RsRTTIUnknownIdentifier, [FirstIdent]);
        if LastOrd = -1 then
          raise EJclRTTI.CreateResRecFmt(@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;
end;

//--------------------------------------------------------------------------------------------------

procedure TJclSetTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(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(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
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclFloatTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(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
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclStringTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(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
//--------------------------------------------------------------------------------------------------

type
  TJclPropInfo = class(TInterfacedObject, IJclPropInfo)
  private
    FPropInfo: PPropInfo;
  protected
    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: Integer): TJclPropSpecKind;
    function GetSpecValue(const Value: Integer): Integer;
    function GetReaderType: TJclPropSpecKind;
    function GetWriterType: TJclPropSpecKind;
    function GetStoredType: TJclPropSpecKind;
    function GetReaderValue: Integer;
    function GetWriterValue: Integer;
    function GetStoredValue: Integer;
  public
    constructor Create(const APropInfo: PPropInfo);
    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: Integer read GetReaderValue;
    property WriterValue: Integer read GetWriterValue;
    property StoredValue: Integer read GetStoredValue;
    property Index: Integer read GetIndex;
    property Default: Longint read GetDefault;
    property NameIndex: Smallint read GetNameIndex;
    property Name: string read GetName;
  end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclPropInfo.GetPropType: IJclTypeInfo;
begin
  Result := JclTypeInfo(PropInfo.PropType^);
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 := PropInfo.Name;
end;

//--------------------------------------------------------------------------------------------------

function TJclPropInfo.GetSpecKind(const Value: Integer): TJclPropSpecKind;
var
  P: Integer;

begin
  P := Value shr 24;
  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: Integer): Integer;
begin
  case GetSpecKind(Value) of
    pskStaticMethod, pskConstant:
      Result := Value;
    pskVirtualMethod:
      Result := Smallint(Value and $0000FFFF);
    pskField:
      Result := Value and $00FFFFFF;
  else
    Result := 0;
  end;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

constructor TJclPropInfo.Create(const APropInfo: PPropInfo);
begin
  inherited Create;
  FPropInfo := APropInfo;
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
//--------------------------------------------------------------------------------------------------

type
  TJclClassTypeInfo = class(TJclTypeInfo, IJclClassTypeInfo)
  private
  protected
    function GetClassRef: TClass;
    function GetParent: IJclClassTypeInfo;
    function GetTotalPropertyCount: Integer;
    function GetPropertyCount: Integer;
    function GetProperties(const PropIdx: Integer): IJclPropInfo;
    function GetUnitName: string;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    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 UnitName: string read GetUnitName;
  end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclClassTypeInfo.GetParent: IJclClassTypeInfo;
begin
  if (TypeData.ParentInfo <> nil) and (TypeData.ParentInfo^ <> nil) then
    Result := JclTypeInfo(TypeData.ParentInfo^) 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(Integer(PropData), 1 + Length(UnitName));
  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(Integer(PropData), 1 + Length(UnitName));
  if PropIdx + 1 > PropData.PropCount then
    Result := Parent.Properties[PropIdx - PropData.PropCount]
  else
  begin
    Prop := PPropInfo(PropData);
    Inc(Integer(Prop), 2);
    if PropIdx > 0 then
    begin
      RecSize := SizeOf(TPropInfo) - SizeOf(ShortString);
      Idx := PropIdx;
      while Idx > 0 do
      begin
        Inc(Integer(Prop), RecSize);
        Inc(Integer(Prop), 1 + PByte(Prop)^);
        Dec(Idx);
      end;
    end;
    Result := TJclPropInfo.Create(Prop);
  end;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclClassTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  I: Integer;
  Prop: IJclPropInfo;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(RsRTTIClassName + ClassRef.ClassName);
  Dest.Writeln(RsRTTIParent + Parent.ClassRef.ClassName);
  Dest.Writeln(RsRTTIUnitName + UnitName);
  Dest.Writeln(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('[%s %d]', [RsRTTIIndex, Prop.Index]));
        if Prop.HasDefault then
          Dest.Writeln(Format('[%s %d]', [RsRTTIDefault, Prop.Default]));
        case Prop.ReaderType of
          pskStaticMethod:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropRead, RsRTTIStaticMethod,
               Pointer(Prop.ReaderValue)]));
          pskField:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropRead, RsRTTIField,
               Pointer(Prop.ReaderValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropRead, RsRTTIVirtualMethod,
               Pointer(Prop.ReaderValue)]));
        end;
        case Prop.WriterType of
          pskStaticMethod:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropWrite, RsRTTIStaticMethod,
               Pointer(Prop.WriterValue)]));
          pskField:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropWrite, RsRTTIField,
               Pointer(Prop.WriterValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format('[%s %s $%p]',
              [RsRTTIPropWrite, RsRTTIVirtualMethod,
               Pointer(Prop.WriterValue)]));
        end;
        case Prop.StoredType of
          pskConstant:
            if Boolean(Prop.StoredValue) then
              Dest.Writeln(Format('[%s=%s]',
                [RsRTTIPropStored, RsRTTITrue]))
            else
              Dest.Writeln(Format('[%s=%s]',
                [RsRTTIPropStored, RsRTTIFalse]));
          pskStaticMethod:
            Dest.Writeln(Format('[%s=%s $%p]',
              [RsRTTIPropStored, RsRTTIStaticMethod,
               Pointer(Prop.StoredValue)]));
          pskField:
            Dest.Writeln(Format('[%s=%s $%p]',
              [RsRTTIPropStored, RsRTTIField,
               Pointer(Prop.StoredValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format('[%s=%s $%p]',
              [RsRTTIPropStored, 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
        Dest.Write(', [''' + JclGUIDToString(IntfTbl.Entries[I].IID) + ''']');
    Dest.Writeln(') // unit ' + UnitName);
  end
  else
    Dest.Writeln(Name + ' = class // unit ' + UnitName);
  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
//--------------------------------------------------------------------------------------------------

type
  TJclEventParamInfo = class(TInterfacedObject, IJclEventParamInfo)
  private
    FParam: Pointer;
  protected
    function GetFlags: TParamFlags;
    function GetName: string;
    function GetRecSize: Integer;
    function GetTypeName: string;
    function GetParam: Pointer;
  public
    constructor Create(const AParam: 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;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclEventParamInfo.GetName: string;
var
  PName: PShortString;
begin
  PName := Param;
  Inc(Integer(PName));
  Result := 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(Integer(PName));
  Inc(Integer(PName), PByte(PName)^ + 1);
  Result := PName^;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------
// TJclEventTypeInfo
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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
  Param := @TypeData.ParamList[0];
  I := ParamIdx;
  Result := nil;
  while I >= 0 do
  begin
    Result := TJclEventParamInfo.Create(Param);
    Inc(Integer(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(Longint(LastParam.Param) + LastParam.RecSize);
    end
    else
      ResPtr := @TypeData.ParamList[0];
    Result := ResPtr^;
  end
  else
    Result := '';
end;

//--------------------------------------------------------------------------------------------------

procedure TJclEventTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  I: Integer;
  Param: IJclEventParamInfo;
  ParamFlags: TParamFlags;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(RsRTTIMethodKind + JclEnumValueToIdent(
    System.TypeInfo(TMethodKind), TypeData.MethodKind));
  Dest.Writeln(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(RsRTTIName + Param.Name);
      Dest.Writeln(RsRTTIType + Param.TypeName);
      Dest.Writeln(RsRTTIFlags + JclSetToStr(System.TypeInfo(TParamFlags),
        ParamFlags, True, False));
    end;
  finally
    Dest.Outdent;
  end;
  if MethodKind = mkFunction then
    Dest.Writeln(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(RsRTTIVar)
    else
    if pfConst in Param.Flags then
      Dest.Write(RsRTTIConst)
    else
    if pfOut in Param.Flags then
      Dest.Write(RsRTTIOut);
    Dest.Write(Param.Name);
    if Param.TypeName <> '' then
    begin
      Dest.Write(': ');
      if pfArray in Param.Flags then
        Dest.Write(RsRTTIArrayOf);
      if AnsiSameText(Param.TypeName, 'TVarRec') and (pfArray in Param.Flags) then
        Dest.Write(TrimRight(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
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function TJclInterfaceTypeInfo.GetParent: IJclInterfaceTypeInfo;
begin
  if (TypeData.IntfParent <> nil) and (TypeData.IntfParent^ <> nil) then
    Result := JclTypeInfo(TypeData.IntfParent^) 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;

//--------------------------------------------------------------------------------------------------

{$IFDEF COMPILER6_UP}
function TJclInterfaceTypeInfo.GetPropertyCount: Integer;
var
  PropData: ^TPropData;
begin
  PropData := @TypeData.IntfUnit;
  Inc(Integer(PropData), 1 + Length(UnitName));
  Result := PropData.PropCount;
end;
{$ENDIF COMPILER6_UP}

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclInterfaceTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  IntfFlags: TIntfFlagsBase;
begin
  inherited WriteTo(Dest);
  if ifHasGuid in Flags then
    Dest.Writeln(RsRTTIGUID + JclGuidToString(GUID));
  IntfFlags := Flags;
  Dest.Writeln(RsRTTIFlags + JclSetToStr(System.TypeInfo(TIntfFlagsBase),
    IntfFlags, True, False));
  Dest.Writeln(RsRTTIUnitName + UnitName);
  if Parent <> nil then
    Dest.Writeln(RsRTTIParent + Parent.Name);
  {$IFDEF COMPILER6_UP}
  Dest.Writeln(RsRTTIPropCount + IntToStr(PropertyCount));
  {$ENDIF COMPILER6_UP}
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 ' + UnitName);
  Dest.Indent;
  try
    if ifHasGuid in Flags then
      Dest.Writeln('[''' + JclGuidToString(GUID) + ''']');
  finally
    Dest.Outdent;
    Dest.Writeln('end;');
  end;
end;

//--------------------------------------------------------------------------------------------------
// TJclInt64TypeInfo
//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

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(RsRTTIMinValue + IntToStr(MinValue));
  Dest.Writeln(RsRTTIMaxValue + IntToStr(MaxValue));
end;

//--------------------------------------------------------------------------------------------------

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

{$IFDEF COMPILER6_UP}
//--------------------------------------------------------------------------------------------------
// TJclDynArrayTypeInfo
//--------------------------------------------------------------------------------------------------

type
  TJclDynArrayTypeInfo = class(TJclTypeInfo, IJclDynArrayTypeInfo)
  private
  protected
    function GetElementSize: Longint;
    function GetElementType: IJclTypeInfo;
    function GetElementsNeedCleanup: Boolean;
    function GetVarType: Integer;
    function GetUnitName: string;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    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;

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 := TypeData.DynUnitName;
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

procedure TJclDynArrayTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ' + RsRTTIArrayOf)
  else
    Dest.Write(RsRTTIArrayOf);
  if ElementType = nil then
    Dest.Write(RsRTTITypeError)
  else
  if ElementType.Name[1] = '.' then
    ElementType.DeclarationTo(Dest)
  else
    Dest.Write(ElementType.Name);
  if Name[1] <> '.' then
    Dest.Writeln('; // Unit ' + UnitName);
end;
{$ENDIF COMPILER6_UP}

//--------------------------------------------------------------------------------------------------
// Typeinfo retreival
//--------------------------------------------------------------------------------------------------

function JclTypeInfo(const 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);
{$IFDEF COMPILER6_UP}
    tkDynArray:
      Result := TJclDynArrayTypeInfo.Create(ATypeInfo);
{$ENDIF COMPILER6_UP}
  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^)
  else
  if (TypeInfo.Kind = tkEnumeration) and (TD^.BaseType^ <> TypeInfo) then
    RemoveTypeInfo(GetTypeData(TypeInfo)^.BaseType^);
  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(const 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(const 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);
    {$IFDEF COMPILER5_UP}
    otULong:
      EnumVal := Longword(Value);
    {$ENDIF COMPILER5_UP}
  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;
type
  PInteger = ^Integer;

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 {$IFDEF COMPILER6_UP}+ 1{$ENDIF COMPILER6_UP});
  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
      {$IFDEF COMPILER5_UP}
      TypeData^.OrdType := otULong;
      {$ELSE}
      TypeData^.OrdType := otSLong;
      {$ENDIF COMPILER5_UP}
    TypeData^.MinValue := 0;
    TypeData^.MaxValue := Length(Literals)-1;
    TypeData^.BaseType^ := Result;   // No sub-range: basetype points to itself
    CurName := @TypeData^.NameList;
    for I := Low(Literals) to High(Literals) do
    begin
      CurName^ := Literals[I];
      Inc(Integer(CurName), Length(Literals[I])+1);
    end;
    {$IFDEF COMPILER6_UP}
    CurName^ := ''; // Unit name unknown
    {$ENDIF COMPILER6_UP}
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
end;

//--------------------------------------------------------------------------------------------------

function JclGenerateEnumTypeBasedOn(const TypeName: ShortString;
  const 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 EJclRTTI.CreateResRecFmt(@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 (S[1] in ['a' .. 'z']) 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(const 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 := TypeName;
    end;
    TypeData := GetTypeData(Result);
    TypeData^.OrdType := GetTypeData(BaseType)^.OrdType;
    TypeData^.MinValue := MinValue;
    TypeData^.MaxValue := MaxValue;
    TypeData^.BaseType := AllocMem(SizeOf(Pointer));
    TypeData^.BaseType^ := BaseType;
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
  ReferenceType(BaseType);
end;

//--------------------------------------------------------------------------------------------------
// Integers
//--------------------------------------------------------------------------------------------------

{$IFDEF COMPILER5_UP}
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;
  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.CreateFmt(LoadResString(@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;
  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;
{$ENDIF COMPILER_5_UP}

//--------------------------------------------------------------------------------------------------
// Sets
//--------------------------------------------------------------------------------------------------

function JclSetToList(const 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(const 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(const TypeInfo: PTypeInfo; var SetVar;
  const Value: string);
var
  SetInfo: IJclSetTypeInfo;
  S: TStrings;
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(const 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^;
  EnumMin := GetTypeData(CompType).MinValue;
  EnumMax := GetTypeData(CompType).MaxValue;
  ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;
  BitShift := EnumMin mod 8;
  TmpInt64 := Longword(Value) shl BitShift;
  Move(TmpInt64, SetVar, ResBytes);
end;

//--------------------------------------------------------------------------------------------------

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

//--------------------------------------------------------------------------------------------------

function JclGenerateSetType(const 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:
        {$IFDEF COMPILER5_UP}
        TypeData^.OrdType := otULong;
        {$ELSE}
        TypeData^.OrdType := otSLong;
        {$ENDIF COMPILER5_UP}
      33..64:
        Byte(TypeData^.OrdType) := 8;
      65..128:
        Byte(TypeData^.OrdType) := 16;
      129..256:
        Byte(TypeData^.OrdType) := 32;
    else
      Byte(TypeData^.OrdType) := 255;
    end;
    TypeData^.CompType := AllocMem(SizeOf(Pointer));
    TypeData^.CompType^ := BaseType;
    AddType(Result);
  except
    try
      ReallocMem(Result, 0);
    except
      Result := nil;
    end;
    raise;
  end;
  ReferenceType(BaseType);
end;

//--------------------------------------------------------------------------------------------------
// GUID
//--------------------------------------------------------------------------------------------------

function JclGUIDToString(const GUID: TGUID): string;
begin
  Result := Format('{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',
    [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2],
     GUID.D4[3], GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]);
end;

//--------------------------------------------------------------------------------------------------

function JclStringToGUID(const S: string): TGUID;
begin
  if (Length(S) <> 38) or (S[1] <> '{') or (S[10] <> '-') or (S[15] <> '-') or
      (S[20] <> '-') or (S[25] <> '-') or (S[38] <> '}') then
    raise EJclRTTI.CreateResRecFmt(@RsRTTIInvalidGUIDString, [S]);
  Result.D1 := StrToInt('$' + Copy(S, 2, 8));
  Result.D2 := StrToInt('$' + Copy(S, 11, 4));
  Result.D3 := StrToInt('$' + Copy(S, 16, 4));
  Result.D4[0] := StrToInt('$' + Copy(S, 21, 2));
  Result.D4[1] := StrToInt('$' + Copy(S, 23, 2));
  Result.D4[2] := StrToInt('$' + Copy(S, 26, 2));
  Result.D4[3] := StrToInt('$' + Copy(S, 28, 2));
  Result.D4[4] := StrToInt('$' + Copy(S, 30, 2));
  Result.D4[5] := StrToInt('$' + Copy(S, 32, 2));
  Result.D4[6] := StrToInt('$' + Copy(S, 34, 2));
  Result.D4[7] := StrToInt('$' + Copy(S, 36, 2));
end;

//--------------------------------------------------------------------------------------------------
// Is/As hooking
//--------------------------------------------------------------------------------------------------

type
  PReadLoc = ^TReadLoc;
  TReadLoc = packed record
    {$IFOPT O+}
    Code: array [0..9] of Byte;
    {$ELSE}
    Code: array [0..17] of Byte;
    {$ENDIF}
    OpCode_Call: Byte;
    CallOffset: Longint;
  end;

  PJmp = ^TJmp;
  TJmp = packed record
    case OpCodeJmp: Byte of
      $E9:
        (JmpOffset: Longint);
      $FF:
        (OpCode2: Byte;
         EntryOffset: Longint);
  end;

var
  OrgIsClass: Pointer;
  OrgAsClass: Pointer;
  IsHooked: Boolean;
  SavedIs: array [0..4] of Byte;
  SavedAs: array [0..4] of Byte;

//--------------------------------------------------------------------------------------------------
// Copied from System.pas (_IsClass function)

function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
asm
        { ->    EAX     left operand (class)    }
        {       EDX VMT of right operand        }
        { <-    AL      left is derived from right      }
        TEST    EAX,EAX
        JE      @@exit
@@loop:
        MOV     EAX,[EAX]
        CMP     EAX,EDX
        JE      @@success
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        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 is AClass then
    Result := AnObj
  else
    raise EInvalidCast.Create(SInvalidCast);
end;

//--------------------------------------------------------------------------------------------------

function JclHookIs(const IsProc: TJclIsFunc): Boolean;
var
  OldProt: DWORD;
begin
  if not JclIsHooked then
  begin
    if VirtualProtect(OrgIsClass, SizeOf(TJmp), PAGE_READWRITE, OldProt) then
      try
        PJmp(OrgIsClass).OpCodeJmp := $E9;
        PJmp(OrgIsClass).JmpOffset := Longword(Addr(IsProc)) -
          ((Longword(OrgIsClass) + SizeOf(TJmp)-1));
      finally
        VirtualProtect(OrgIsClass, SizeOf(TJmp), OldProt, OldProt);
      end;
    if VirtualProtect(OrgAsClass, SizeOf(TJmp), PAGE_READWRITE, OldProt) then
      try
        PJmp(OrgAsClass).OpCodeJmp := $E9;
        PJmp(OrgAsClass).JmpOffset := Longword(Addr(JclAsClass)) -
          ((Longword(OrgAsClass) + SizeOf(TJmp)-1));
      finally
        VirtualProtect(OrgAsClass, SizeOf(TJmp), OldProt, OldProt);
      end;
    IsHooked := True;
    Result := True;
  end
  else
    Result := False;
end;

//--------------------------------------------------------------------------------------------------

function JclIsHooked: Boolean;
begin
  Result := IsHooked;
end;

//--------------------------------------------------------------------------------------------------

function JclUnhookIs: Boolean;
var
  OldProt: DWORD;
begin
  Result := JclIsHooked;
  if Result then
  begin
    if VirtualProtect(OrgIsClass, SizeOf(TJmp), PAGE_EXECUTE_READWRITE,
        OldProt) then
      try
        Move(SavedIs, PChar(OrgIsClass), SizeOf(SavedIs));
      finally
        VirtualProtect(OrgIsClass, SizeOf(TJmp), OldProt, OldProt);
      end;
    if VirtualProtect(OrgAsClass, SizeOf(TJmp), PAGE_EXECUTE_READWRITE,
        OldProt) then
      try
        Move(SavedAs, PChar(OrgAsClass), SizeOf(SavedAs));
      finally
        VirtualProtect(OrgAsClass, SizeOf(TJmp), OldProt, OldProt);
      end;
    IsHooked := False;
  end;
end;

//--------------------------------------------------------------------------------------------------

function LocateIsClassHelper(const AnObj: TObject;
  const AClass: TClass): Boolean; register;
begin
  Result := AnObj is AClass;
end;

//--------------------------------------------------------------------------------------------------

function LocateAsClassHelper(const AnObj: TObject;
  const AClass: TClass): TObject; register;
begin
  Result := AnObj as AClass;
end;

//--------------------------------------------------------------------------------------------------

procedure LocateIsClass;
var
  AddrOfHelper: PReadLoc;
begin
  AddrOfHelper := PReadLoc(Addr(LocateIsClassHelper));
  OrgIsClass := Pointer(AddrOfHelper.CallOffset + Longint(AddrOfHelper) +
    SizeOf(TReadLoc));
  with PJmp(OrgIsClass)^ do
  begin
    if OpCodeJmp = $FF then
      // _IsClass is in a package. Obtain address in the package.
      OrgIsClass := Pointer(PInteger(EntryOffset)^);
  end;
  Move(PChar(OrgIsClass), SavedIs, SizeOf(SavedIs));
end;

//--------------------------------------------------------------------------------------------------

procedure LocateAsClass;
var
  AddrOfHelper: PReadLoc;
begin
  AddrOfHelper := PReadLoc(Addr(LocateAsClassHelper));
  OrgAsClass := Pointer(AddrOfHelper.CallOffset + Longint(AddrOfHelper) +
    SizeOf(TReadLoc));
  with PJmp(OrgAsClass)^ do
  begin
    if OpCodeJmp = $FF then
      // _AsClass is in a package. Obtain address in the package.
      OrgAsClass := Pointer(PInteger(EntryOffset)^);
  end;
  Move(PChar(OrgAsClass), SavedAs, SizeOf(SavedAs));
end;

//--------------------------------------------------------------------------------------------------

initialization
  TypeList := TThreadList.Create;
  LocateIsClass;
  LocateAsClass;

finalization
  if JclIsHooked then
    JclUnHookIs;
  ClearInfoList;
  FreeAndNil(TypeList);

end.
