{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit Classes;

{$N+,P+,R-,S-,W-}
{$C PRELOAD}

interface

uses SysUtils, WinTypes, WinProcs;

const

{ Maximum TList size }

  MaxListSize = 65520 div SizeOf(Pointer);

{ TStream seek origins }

  soFromBeginning = 0;
  soFromCurrent = 1;
  soFromEnd = 2;

{ TFileStream create mode }

  fmCreate = $FFFF;

{ TParser special tokens }

  toEOF     = Char(0);
  toSymbol  = Char(1);
  toString  = Char(2);
  toInteger = Char(3);
  toFloat   = Char(4);

type

{ Text alignment types }

  TAlignment = (taLeftJustify, taRightJustify, taCenter);
  TLeftRight = taLeftJustify..taRightJustify;

{ Types used by standard events }

  TShiftState = set of (ssShift, ssAlt, ssCtrl,
    ssLeft, ssRight, ssMiddle, ssDouble);

  THelpContext = -MaxLongint..MaxLongint;

{ Standard events }

  TNotifyEvent = procedure(Sender: TObject) of object;
  THelpEvent = function (Command: Word; Data: Longint;
    var CallHelp: Boolean): Boolean of object;
  TGetStrProc = procedure(const S: string) of object;

{ Exception classes }

  EStreamError = class(Exception);
  EFCreateError = class(EStreamError);
  EFOpenError = class(EStreamError);
  EFilerError = class(EStreamError);
  EReadError = class(EFilerError);
  EWriteError = class(EFilerError);
  EClassNotFound = class(EFilerError);
  EMethodNotFound = class(EFilerError);
  EInvalidImage = class(EFilerError);
  EResNotFound = class(Exception);
  EListError = class(Exception);
  EStringListError = class(Exception);
  EComponentError = class(Exception);
  EParserError = class(Exception);

{ Forward class declarations }

  TStream = class;
  TFiler = class;
  TReader = class;
  TWriter = class;
  TComponent = class;

{ TList class }

  PPointerList = ^TPointerList;
  TPointerList = array[0..MaxListSize - 1] of Pointer;

  TList = class(TObject)
  private
    FList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;
  protected
    procedure Error; virtual;
    function Get(Index: Integer): Pointer;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: Pointer);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    destructor Destroy; override;
    function Add(Item: Pointer): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TList;
    function First: Pointer;
    function IndexOf(Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    function Last: Pointer;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: Pointer): Integer;
    procedure Pack;
    property Capacity: Integer read FCapacity write SetCapacity;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    property List: PPointerList read FList;
  end;

{ TPersistent abstract class }

{$M+}

  TPersistent = class(TObject)
  private
    procedure AssignError(Source: TPersistent);
  protected
    procedure AssignTo(Dest: TPersistent); virtual;
    procedure DefineProperties(Filer: TFiler); virtual;
  public
    procedure Assign(Source: TPersistent); virtual;
  end;

{$M-}

{ TPersistent class reference type }

  TPersistentClass = class of TPersistent;

{ TStrings class }

  TStrings = class(TPersistent)
  private
    FUpdateCount: Integer;
    function GetValue(const Name: string): string;
    function GetValueIndex(const Name: string; Value: PString): Integer;
    procedure ReadData(Reader: TReader);
    procedure SetValue(const Name, Value: string);
    procedure WriteData(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function Get(Index: Integer): string; virtual; abstract;
    function GetCount: Integer; virtual; abstract;
    function GetObject(Index: Integer): TObject; virtual;
    procedure Put(Index: Integer; const S: string); virtual;
    procedure PutObject(Index: Integer; AObject: TObject); virtual;
    procedure SetUpdateState(Updating: Boolean); virtual;
  public
    function Add(const S: string): Integer; virtual;
    function AddObject(const S: string; AObject: TObject): Integer; virtual;
    procedure AddStrings(Strings: TStrings); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure Clear; virtual; abstract;
    procedure Delete(Index: Integer); virtual; abstract;
    procedure EndUpdate;
    function Equals(Strings: TStrings): Boolean;
    procedure Exchange(Index1, Index2: Integer); virtual;
    function GetText: PChar; virtual;
    function IndexOf(const S: string): Integer; virtual;
    function IndexOfObject(AObject: TObject): Integer;
    procedure Insert(Index: Integer; const S: string); virtual; abstract;
    procedure InsertObject(Index: Integer; const S: string;
      AObject: TObject);
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure Move(CurIndex, NewIndex: Integer); virtual;
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream); virtual;
    procedure SetText(Text: PChar); virtual;
    property Count: Integer read GetCount;
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property Values[const Name: string]: string read GetValue write SetValue;
    property Strings[Index: Integer]: string read Get write Put; default;
  end;

{ TStringList class }

  TDuplicates = (dupIgnore, dupAccept, dupError);

  TStringList = class(TStrings)
  private
    FList: TList;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure QuickSort(L, R: Integer);
    procedure SetSorted(Value: Boolean);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    constructor Create;
    destructor Destroy; override;
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function Find(const S: string; var Index: Integer): Boolean; virtual;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Sort; virtual;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Sorted: Boolean read FSorted write SetSorted;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;

{ TStream abstract class }

  TStream = class(TObject)
  private
    function GetPosition: Longint;
    procedure SetPosition(Pos: Longint);
    function GetSize: Longint;
  public
    function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
    function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
    function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
    procedure ReadBuffer(var Buffer; Count: Longint);
    procedure WriteBuffer(const Buffer; Count: Longint);
    function CopyFrom(Source: TStream; Count: Longint): Longint;
    function ReadComponent(Instance: TComponent): TComponent;
    function ReadComponentRes(Instance: TComponent): TComponent;
    procedure WriteComponent(Instance: TComponent);
    procedure WriteComponentRes(const ResName: string; Instance: TComponent);
    procedure ReadResHeader;
    property Position: Longint read GetPosition write SetPosition;
    property Size: Longint read GetSize;
  end;

{ THandleStream class }

  THandleStream = class(TStream)
  private
    FHandle: Integer;
  public
    constructor Create(AHandle: Integer);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    property Handle: Integer read FHandle;
  end;

{ TFileStream class }

  TFileStream = class(THandleStream)
  public
    constructor Create(const FileName: string; Mode: Word);
    destructor Destroy; override;
  end;

{ TMemoryStream }

  TMemoryStream = class(TStream)
  private
    FMemory: Pointer;
    FSize, FCapacity, FPosition: Longint;
    procedure SetCapacity(Value: Longint);
  public
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SetSize(Size: Longint);
    procedure Clear;
    property Memory: Pointer read FMemory;
  end;

{ TFiler }

  TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
    vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet);

  TReaderProc = procedure(Reader: TReader) of object;
  TWriterProc = procedure(Writer: TWriter) of object;
  TStreamProc = procedure(Stream: TStream) of object;

  TFiler = class(TObject)
  private
    FStream: TStream;
    FBuffer: Pointer;
    FBufSize: Cardinal;
    FBufPos: Cardinal;
    FBufEnd: Cardinal;
    FRoot: TComponent;
  public
    constructor Create(Stream: TStream; BufSize: Cardinal);
    destructor Destroy; override;
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); virtual; abstract;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); virtual; abstract;
    property Root: TComponent read FRoot write FRoot;
  end;

{ TReader }

  TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
    var Address: Pointer; var Error: Boolean) of object;
  TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
    var Name: string) of object;
  TReadComponentsProc = procedure(Component: TComponent) of object;
  TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;

  TReader = class(TFiler)
  private
    FOwner: TComponent;
    FParent: TComponent;
    FFixups: TList;
    FLoaded: TList;
    FOnFindMethod: TFindMethodEvent;
    FOnSetName: TSetNameEvent;
    FOnError: TReaderError;
    FCanHandleExcepts: Boolean;
    FReserved: Byte;
    FPropName: string[63];
    procedure CheckValue(Value: TValueType);
    procedure FixupReferences;
    procedure FreeFixups;
    function NextValue: TValueType;
    procedure PropertyError;
    procedure ReadBuffer;
    function ReadComponent: TComponent;
    procedure ReadData(Instance: TComponent);
    procedure ReadDataInner(Instance: TComponent);
    procedure ReadProperty(AInstance: TComponent);
    procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
    function ReadSet(SetType: Pointer): Cardinal;
    function ReadValue: TValueType;
    procedure SkipSetBody;
    procedure SkipValue;
    procedure SkipProperty;
    procedure SkipComponent(SkipType: Boolean);
  protected
    function Error(const Message: string): Boolean; virtual;
    function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
    procedure SetName(Component: TComponent; var Name: string); virtual;
  public
    destructor Destroy; override;
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); override;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); override;
    function EndOfList: Boolean;
    procedure Read(var Buf; Count: Longint);
    function ReadBoolean: Boolean;
    function ReadChar: Char;
    procedure ReadComponents(AOwner, AParent: TComponent;
      Proc: TReadComponentsProc);
    function ReadFloat: Extended;
    function ReadIdent: string;
    function ReadInteger: Longint;
    procedure ReadListBegin;
    procedure ReadListEnd;
    function ReadRootComponent(Root: TComponent): TComponent;
    procedure ReadSignature;
    function ReadStr: string;
    function ReadString: string;
    property Owner: TComponent read FOwner write FOwner;
    property Parent: TComponent read FParent write FParent;
    property OnError: TReaderError read FOnError write FOnError;
    property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
    property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  end;

{ TWriter }

  TWriter = class(TFiler)
  private
    FPropPath: string;
    procedure WriteBinary(WriteData: TStreamProc);
    procedure WriteBuffer;
    procedure WriteData(Instance: TComponent);
    procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
    procedure WriteProperties(Instance: TPersistent);
    procedure WritePropName(const PropName: string);
    procedure WriteValue(Value: TValueType);
  public
    destructor Destroy; override;
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); override;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); override;
    procedure Write(const Buf; Count: Longint);
    procedure WriteBoolean(Value: Boolean);
    procedure WriteComponent(Component: TComponent);
    procedure WriteChar(Value: Char);
    procedure WriteFloat(Value: Extended);
    procedure WriteIdent(const Ident: string);
    procedure WriteInteger(Value: Longint);
    procedure WriteListBegin;
    procedure WriteListEnd;
    procedure WriteRootComponent(Root: TComponent);
    procedure WriteSignature;
    procedure WriteStr(const Value: string);
    procedure WriteString(const Value: string);
  end;

{ TParser }

  TParser = class(TObject)
  private
    FStream: TStream;
    FOrigin: Longint;
    FBuffer: PChar;
    FBufPtr: PChar;
    FBufEnd: PChar;
    FSourcePtr: PChar;
    FSourceEnd: PChar;
    FTokenPtr: PChar;
    FStringPtr: PChar;
    FSourceLine: Integer;
    FSaveChar: Char;
    FToken: Char;
    procedure ReadBuffer;
    procedure SkipBlanks;
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    procedure CheckToken(T: Char);
    procedure CheckTokenSymbol(const S: string);
    procedure Error(MessageID: Word);
    procedure ErrorStr(const Message: string);
    procedure HexToBinary(Stream: TStream);
    function NextToken: Char;
    function SourcePos: Longint;
    function TokenFloat: Extended;
    function TokenInt: Longint;
    function TokenString: string;
    function TokenSymbolIs(const S: string): Boolean;
    property SourceLine: Integer read FSourceLine;
    property Token: Char read FToken;
  end;

{ TComponent class }

  TOperation = (opInsert, opRemove);
  TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
    csDesigning);

  TComponentName = string[63];

  TComponent = class(TPersistent)
  private
    FOwner: TComponent;
    FName: PString;
    FTag: Longint;
    FComponents: TList;
    FDesignInfo: Longint;
    FComponentState: TComponentState;
    FReserved: Byte;
    function GetComponent(AIndex: Integer): TComponent;
    function GetComponentCount: Integer;
    function GetComponentIndex: Integer;
    function GetName: TComponentName;
    procedure Insert(AComponent: TComponent);
    procedure ReadLeft(Reader: TReader);
    procedure ReadTop(Reader: TReader);
    procedure Remove(AComponent: TComponent);
    procedure SetComponentIndex(Value: Integer);
    procedure SetReference(Enable: Boolean);
    procedure WriteLeft(Writer: TWriter);
    procedure WriteTop(Writer: TWriter);
  protected
    procedure ChangeName(const NewName: TComponentName);
    procedure DefineProperties(Filer: TFiler); override;
    function HasParent: Boolean; virtual;
    procedure Loaded; virtual;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); virtual;
    procedure ReadState(Reader: TReader); virtual;
    procedure SetDesigning(Value: Boolean);
    procedure SetName(const NewName: TComponentName); virtual;
    procedure ValidateRename(AComponent: TComponent;
      const CurName, NewName: string); virtual;
    procedure WriteComponents(Writer: TWriter); virtual;
    procedure WriteState(Writer: TWriter); virtual;
  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
    procedure DestroyComponents;
    procedure Destroying;
    function FindComponent(const AName: string): TComponent;
    procedure InsertComponent(AComponent: TComponent);
    procedure RemoveComponent(AComponent: TComponent);
    property Components[Index: Integer]: TComponent read GetComponent;
    property ComponentCount: Integer read GetComponentCount;
    property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
    property ComponentState: TComponentState read FComponentState;
    property DesignInfo: Longint read FDesignInfo write FDesignInfo;
    property Owner: TComponent read FOwner;
  published
    property Name: TComponentName read GetName write SetName stored False;
    property Tag: Longint read FTag write FTag default 0;
  end;

{ TComponent class reference type }

  TComponentClass = class of TComponent;

{ Component registration handlers }

const
  RegisterComponentsProc: procedure(const Page: string;
    ComponentClasses: array of TComponentClass) = nil;
  RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;

{ Point and rectangle constructors }

function Point(AX, AY: Integer): TPoint;
function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;

{ Class registration routines }

procedure RegisterClass(AClass: TPersistentClass);
procedure RegisterClasses(AClasses: array of TPersistentClass);
procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
procedure UnRegisterClass(AClass: TPersistentClass);
procedure UnRegisterClasses(AClasses: array of TPersistentClass);
function FindClass(const ClassName: string): TPersistentClass;
function GetClass(const ClassName: string): TPersistentClass;

{ Component registration routines }

procedure RegisterComponents(const Page: string;
  ComponentClasses: array of TComponentClass);
procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);

{ Object filing routines }

type
  TIdentToInt = function (const Ident: string; var Int: Longint): Boolean;
  TIntToIdent = function (Int: Longint; var Ident: string): Boolean;

procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  IntToIdent: TIntToIdent);
function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
procedure WriteComponentResFile(const FileName: string; Instance: TComponent);

{ Object conversion routines }

procedure ObjectBinaryToText(Input, Output: TStream);
procedure ObjectTextToBinary(Input, Output: TStream);

procedure ObjectResourceToText(Input, Output: TStream);
procedure ObjectTextToResource(Input, Output: TStream);

{ Utility routines }

function LineStart(Buffer, BufPos: PChar): PChar;

{ StrItem management, shared by TStringList and TStringSparseList }

type
  PStrItem = ^TStrItem;
  TStrItem = record
    FObject: TObject;
    FString: string;
  end;

function NewStrItem(const AString: string; AObject: TObject): PStrItem;
procedure DisposeStrItem(P: PStrItem);

implementation

uses Consts, TypInfo;

const
  FilerSignature: array[1..4] of Char = 'TPF0';

const
  ClassList: TList = nil;
  ClassAliasList: TStringList = nil;
  IntConstList: TList = nil;

type
  TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;

{ Windows functions }

procedure __AHSHIFT; far; external 'KERNEL' index 113;
procedure __AHINCR; far; external 'KERNEL' index 114;

{ Point and rectangle constructors }

function Point(AX, AY: Integer): TPoint;
begin
  with Result do
  begin
    X := AX;
    Y := AY;
  end;
end;

function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
begin
  with Result do
  begin
    Left := ALeft;
    Top := ATop;
    Right := ARight;
    Bottom := ABottom;
  end;
end;

function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
begin
  with Result do
  begin
    Left := ALeft;
    Top := ATop;
    Right := ALeft + AWidth;
    Bottom :=  ATop + AHeight;
  end;
end;

{ Class registration routines }

type
  PFieldClassTable = ^TFieldClassTable;
  TFieldClassTable = packed record
    Count: Smallint;
    Classes: array[0..8191] of TPersistentClass;
  end;

function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
asm
        XOR     AX,AX
        XOR     DX,DX
        LES     DI,AClass
        MOV     DI,ES:[DI-30]   { vtFieldTable }
        OR      DI,DI
        JE      @@1
        MOV     AX,ES:[DI+2]    { ftClassTable }
        MOV     DX,ES
@@1:
end;

procedure ClassNotFound(const ClassName: string);
begin
  raise EClassNotFound.Create(FmtLoadStr(SClassNotFound, [ClassName]));
end;

function GetClass(const ClassName: string): TPersistentClass;
var
  I: Integer;
begin
  for I := 0 to ClassList.Count - 1 do
  begin
    Result := ClassList[I];
    if CompareText(Result.ClassName, ClassName) = 0 then Exit;
  end;
  I := ClassAliasList.IndexOf(ClassName);
  if I >= 0 then
  begin
    Result := TPersistentClass(ClassAliasList.Objects[I]);
    Exit;
  end;
  Result := nil;
end;

function FindClass(const ClassName: string): TPersistentClass;
begin
  Result := GetClass(ClassName);
  if Result = nil then ClassNotFound(ClassName);
end;

function FindFieldClass(Instance: TObject;
  const ClassName: string): TPersistentClass;
var
  I: Integer;
  ClassTable: PFieldClassTable;
begin
  ClassTable := GetFieldClassTable(Instance.ClassType);
  if ClassTable <> nil then
    for I := 0 to ClassTable^.Count - 1 do
    begin
      Result := ClassTable^.Classes[I];
      if CompareText(Result.ClassName, ClassName) = 0 then Exit;
    end;
  Result := FindClass(ClassName);
end;

procedure RegisterClass(AClass: TPersistentClass);
var
  ClassName: string[63];
begin
  while ClassList.IndexOf(AClass) = -1 do
  begin
    ClassName := AClass.ClassName;
    if GetClass(ClassName) <> nil then
      raise EFilerError.Create(FmtLoadStr(SDuplicateClass, [ClassName]));
    ClassList.Add(AClass);
    if AClass = TPersistent then Break;
    AClass := TPersistentClass(AClass.ClassParent);
  end;
end;

procedure RegisterClasses(AClasses: array of TPersistentClass);
var
  I: Integer;
begin
  for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]);
end;

procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
begin
  RegisterClass(AClass);
  ClassAliasList.AddObject(Alias, TObject(AClass));
end;

procedure UnRegisterClass(AClass: TPersistentClass);
begin
  ClassList.Remove(AClass);
end;

procedure UnRegisterClasses(AClasses: array of TPersistentClass);
var
  I: Integer;
begin
  for I := Low(AClasses) to High(AClasses) do UnRegisterClass(AClasses[I]);
end;

{ Component registration routines }

procedure RegisterComponents(const Page: string;
  ComponentClasses: array of TComponentClass);
begin
  if Assigned(RegisterComponentsProc) then
    RegisterComponentsProc(Page, ComponentClasses)
  else
    raise EComponentError.Create(LoadStr(SRegisterError));
end;

procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
begin
  if Assigned(RegisterNoIconProc) then
    RegisterNoIconProc(ComponentClasses)
  else
    raise EComponentError.Create(LoadStr(SRegisterError));
end;

{ Component filing }

type
  TIntConst = class
    IntegerType: PTypeInfo;
    IdentToInt: TIdentToInt;
    IntToIdent: TIntToIdent;
    constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
      AIntToIdent: TIntToIdent);
  end;

constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
begin
  IntegerType := AIntegerType;
  IdentToInt := AIdentToInt;
  IntToIdent := AIntToIdent;
end;

procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  IntToIdent: TIntToIdent);
begin
  IntConstList.Add(TIntConst.Create(IntegerType, IdentToInt, IntToIdent));
end;

function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
var
  HResInfo: THandle;
  Handle: Integer;
  Stream: TStream;
  Name: array[0..63] of Char;
begin
  StrPLCopy(Name, ResName, SizeOf(Name) - 1);
  HResInfo := FindResource(HInstance, Name, rt_RCData);
  if HResInfo = 0 then
    raise EResNotFound.Create(FmtLoadStr(SResNotFound, [ResName]));
  Handle := AccessResource(HInstance, HResInfo);
  if Handle = 0 then
    raise EResNotFound.Create(FmtLoadStr(SResNotFound, [ResName]));
  try
    Stream := THandleStream.Create(Handle);
    try
      Result := Stream.ReadComponent(Instance);
    finally
      Stream.Free;
    end;
  finally
    FileClose(Handle);
  end;
end;

function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    Result := Stream.ReadComponentRes(Instance);
  finally
    Stream.Free;
  end;
end;

procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    Stream.WriteComponentRes(Instance.ClassName, Instance);
  finally
    Stream.Free;
  end;
end;

{ Utility routines }

function LineStart(Buffer, BufPos: PChar): PChar; assembler;
asm
        LES     DI,BufPos
        MOV     CX,DI
        SUB     CX,Buffer.Word[0]
        SUB     CX,1
        JBE     @@1
        DEC     DI
        MOV     AL,0AH
        STD
        REPNE   SCASB
        CLD
        JNE     @@1
        LEA     AX,[DI+2]
        MOV     DX,ES
        JMP     @@2
@@1:    MOV     AX,Buffer.Word[0]
        MOV     DX,Buffer.Word[2]
@@2:
end;

procedure ListError(Ident: Word);
begin
  raise EListError.Create(LoadStr(Ident));
end;

{ TList }

destructor TList.Destroy;
begin
  Clear;
end;

function TList.Add(Item: Pointer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then Grow;
  FList^[Result] := Item;
  Inc(FCount);
end;

procedure TList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

procedure TList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then Error;
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(Pointer));
end;

procedure TList.Error;
begin
  ListError(SListIndexError);
end;

procedure TList.Exchange(Index1, Index2: Integer);
var
  Item: Pointer;
begin
  if (Index1 < 0) or (Index1 >= FCount) or
    (Index2 < 0) or (Index2 >= FCount) then Error;
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TList.Expand: TList;
begin
  if FCount = FCapacity then Grow;
  Result := Self;
end;

function TList.First: Pointer;
begin
  Result := Get(0);
end;

function TList.Get(Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= FCount) then Error;
  Result := FList^[Index];
end;

procedure TList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 8 then Delta := 16 else
    if FCapacity > 4 then Delta := 8 else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TList.IndexOf(Item: Pointer): Integer;
begin
  Result := 0;
  while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  if Result = FCount then Result := -1;
end;

procedure TList.Insert(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index > FCount) then Error;
  if FCount = FCapacity then Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(Pointer));
  FList^[Index] := Item;
  Inc(FCount);
end;

function TList.Last: Pointer;
begin
  Result := Get(FCount - 1);
end;

procedure TList.Move(CurIndex, NewIndex: Integer);
var
  Item: Pointer;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) or (NewIndex >= FCount) then Error;
    Item := Get(CurIndex);
    Delete(CurIndex);
    Insert(NewIndex, Item);
  end;
end;

procedure TList.Put(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index >= FCount) then Error;
  FList^[Index] := Item;
end;

function TList.Remove(Item: Pointer): Integer;
begin
  Result := IndexOf(Item);
  if Result <> -1 then Delete(Result);
end;

procedure TList.Pack;
var
  I: Integer;
begin
  for I := FCount - 1 downto 0 do if Items[I] = nil then Delete(I);
end;

procedure TList.SetCapacity(NewCapacity: Integer);
var
  NewList: PPointerList;
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error;
  if NewCapacity <> FCapacity then
  begin
    if NewCapacity = 0 then NewList := nil else
    begin
      GetMem(NewList, NewCapacity * SizeOf(Pointer));
      if FCount <> 0 then
        System.Move(FList^, NewList^, FCount * SizeOf(Pointer));
    end;
    if FCapacity <> 0 then FreeMem(FList, FCapacity * SizeOf(Pointer));
    FList := NewList;
    FCapacity := NewCapacity;
  end;
end;

procedure TList.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then Error;
  if NewCount > FCapacity then SetCapacity(NewCount);
  if NewCount > FCount then
    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
  FCount := NewCount;
end;

{ TPersistent }

procedure TPersistent.Assign(Source: TPersistent);
begin
  if Source <> nil then Source.AssignTo(Self) else AssignError(nil);
end;

procedure TPersistent.AssignError(Source: TPersistent);
var
  SourceName: string[31];
begin
  if Source <> nil then
    SourceName := Source.ClassName else
    SourceName := 'nil';
  raise EConvertError.CreateResFmt(SAssignError, [SourceName, ClassName]);
end;

procedure TPersistent.AssignTo(Dest: TPersistent);
begin
  Dest.AssignError(Self);
end;

procedure TPersistent.DefineProperties(Filer: TFiler);
begin
end;

{ TStrings }

function GetString(BufPtr: PChar; var S: string): PChar; assembler;
asm
        PUSH    DS
        LDS     SI,BufPtr
        LES     DI,S
        XOR     BX,BX
        CLD
@@1:    LODSB
        CMP     AL,' '
        JB      @@3
@@2:    CMP     BX,255
        JE      @@1
        INC     BX
        MOV     ES:[DI+BX],AL
        JMP     @@1
@@3:    OR      AL,AL
        JE      @@4
        CMP     AL,1AH
        JE      @@4
        CMP     AL,0AH
        JE      @@5
        CMP     AL,0DH
        JNE     @@2
        LODSB
        CMP     AL,0AH
        JE      @@5
@@4:    DEC     SI
@@5:    MOV     ES:[DI],BL
        MOV     AX,SI
        MOV     DX,DS
        POP     DS
end;

function PutString(BufPtr: PChar; const S: string): PChar; assembler;
asm
        PUSH    DS
        LDS     SI,S
        LES     DI,BufPtr
        CLD
        LODSB
        MOV     CL,AL
        XOR     CH,CH
        REP     MOVSB
        MOV     AX,0A0DH
        STOSW
        MOV     AX,DI
        MOV     DX,ES
        POP     DS
end;

function TStrings.Add(const S: string): Integer;
begin
  Result := GetCount;
  Insert(Result, S);
end;

function TStrings.AddObject(const S: string; AObject: TObject): Integer;
begin
  Result := Add(S);
  PutObject(Result, AObject);
end;

procedure TStrings.AddStrings(Strings: TStrings);
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to Strings.Count - 1 do
      AddObject(Strings[I], Strings.Objects[I]);
  finally
    EndUpdate;
  end;
end;

procedure TStrings.Assign(Source: TPersistent);
begin
  if Source is TStrings then
  begin
    BeginUpdate;
    try
      Clear;
      AddStrings(TStrings(Source));
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TStrings.BeginUpdate;
begin
  if FUpdateCount = 0 then SetUpdateState(True);
  Inc(FUpdateCount);
end;

procedure TStrings.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Strings', ReadData, WriteData, Count > 0);
end;

procedure TStrings.EndUpdate;
begin
  Dec(FUpdateCount);
  if FUpdateCount = 0 then SetUpdateState(False);
end;

function TStrings.Equals(Strings: TStrings): Boolean;
var
  I, Count: Integer;
begin
  Result := False;
  Count := GetCount;
  if Count <> Strings.GetCount then Exit;
  for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit;
  Result := True;
end;

procedure TStrings.Exchange(Index1, Index2: Integer);
var
  TempObject: TObject;
  TempString: string;
begin
  TempString := Strings[Index1];
  TempObject := Objects[Index1];
  Strings[Index1] := Strings[Index2];
  Objects[Index1] := Objects[Index2];
  Strings[Index2] := TempString;
  Objects[Index2] := TempObject;
end;

function TStrings.GetObject(Index: Integer): TObject;
begin
  Result := nil;
end;

function TStrings.GetValue(const Name: string): string;
begin
  if GetValueIndex(Name, @Result) < 0 then Result := '';
end;

function TStrings.GetValueIndex(const Name: string; Value: PString): Integer;
var
  P: Integer;
  S: string;
begin
  for Result := 0 to GetCount - 1 do
  begin
    S := Get(Result);
    P := Pos('=', S);
    if (P <> 0) and (CompareText(Copy(S, 1, P - 1), Name) = 0) then
    begin
      if Value <> nil then Value^ := Copy(S, P + 1, 255);
      Exit;
    end;
  end;
  Result := -1;
end;

function TStrings.GetText: PChar;
var
  Size, L: Cardinal;
  Count, I, J: Integer;
  P: PChar;
begin
  Size := 1;
  Count := GetCount;
  I := 0;
  while I < Count do
  begin
    L := Length(Get(I)) + 2;
    if L > 65520 - Size then Break;
    Inc(Size, L);
    Inc(I);
  end;
  Result := StrAlloc(Size);
  P := Result;
  for J := 0 to I - 1 do P := PutString(P, Get(J));
  P[0] := #0;
end;

function TStrings.IndexOf(const S: string): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if CompareText(Get(Result), S) = 0 then Exit;
  Result := -1;
end;

function TStrings.IndexOfObject(AObject: TObject): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if GetObject(Result) = AObject then Exit;
  Result := -1;
end;

procedure TStrings.InsertObject(Index: Integer; const S: string;
  AObject: TObject);
begin
  Insert(Index, S);
  PutObject(Index, AObject);
end;

procedure TStrings.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TStrings.LoadFromStream(Stream: TStream);
const
  BufSize = 4096;
  EOF = Chr($1A);
var
  Count: Integer;
  Buffer, BufPtr, BufEnd, BufTop: PChar;
  S: string;
begin
  BeginUpdate;
  try
    GetMem(Buffer, BufSize);
    try
      Clear;
      BufEnd := Buffer + BufSize;
      BufTop := BufEnd;
      repeat
        Count := BufEnd - BufTop;
        if Count <> 0 then System.Move(BufTop[0], Buffer[0], Count);
        BufTop := Buffer + Count;
        BufTop := BufTop + Stream.Read(BufTop[0], BufEnd - BufTop);
        if BufTop < BufEnd then BufTop[0] := EOF else
        begin
          BufTop := LineStart(Buffer, BufTop);
          if BufTop = Buffer then
            raise EStreamError.Create(LoadStr(SLineTooLong));
        end;
        BufPtr := Buffer;
        while (BufPtr < BufTop) and (BufPtr[0] <> EOF) do
        begin
          BufPtr := GetString(BufPtr, S);
          Add(S);
        end;
      until (BufPtr < BufEnd) and (BufPtr[0] = EOF);
    finally
      FreeMem(Buffer, BufSize);
    end;
  finally
    EndUpdate;
  end;
end;

procedure TStrings.Move(CurIndex, NewIndex: Integer);
var
  TempObject: TObject;
  TempString: string;
begin
  if CurIndex <> NewIndex then
  begin
    TempString := Get(CurIndex);
    TempObject := GetObject(CurIndex);
    Delete(CurIndex);
    InsertObject(NewIndex, TempString, TempObject);
  end;
end;

procedure TStrings.Put(Index: Integer; const S: string);
var
  TempObject: TObject;
begin
  TempObject := GetObject(Index);
  Delete(Index);
  InsertObject(Index, S, TempObject);
end;

procedure TStrings.PutObject(Index: Integer; AObject: TObject);
begin
end;

procedure TStrings.ReadData(Reader: TReader);
begin
  Reader.ReadListBegin;
  Clear;
  while not Reader.EndOfList do Add(Reader.ReadString);
  Reader.ReadListEnd;
end;

procedure TStrings.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TStrings.SaveToStream(Stream: TStream);
const
  BufSize = 4096;
var
  I: Integer;
  Buffer, BufPtr: PChar;
begin
  GetMem(Buffer, BufSize);
  try
    BufPtr := Buffer;
    for I := 0 to GetCount - 1 do
    begin
      if BufPtr - Buffer >= BufSize - 256 then
      begin
        Stream.WriteBuffer(Buffer[0], BufPtr - Buffer);
        BufPtr := Buffer;
      end;
      BufPtr := PutString(BufPtr, Get(I));
    end;
    Stream.WriteBuffer(Buffer[0], BufPtr - Buffer);
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

procedure TStrings.SetValue(const Name, Value: string);
var
  I: Integer;
begin
  I := GetValueIndex(Name, nil);
  if Value <> '' then
  begin
    if I < 0 then I := Add('');
    Put(I, Name + '=' + Value);
  end else
  begin
    if I >= 0 then Delete(I);
  end;
end;

procedure TStrings.SetText(Text: PChar);
var
  P: PChar;
  S: string;
begin
  BeginUpdate;
  try
    Clear;
    P := Text;
    while not (P[0] in [#0, #$1A]) do
    begin
      P := GetString(P, S);
      Add(S);
    end;
  finally
    EndUpdate;
  end;
end;

procedure TStrings.SetUpdateState(Updating: Boolean);
begin
end;

procedure TStrings.WriteData(Writer: TWriter);
var
  I: Integer;
begin
  Writer.WriteListBegin;
  for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  Writer.WriteListEnd;
end;

{ TStringList }

function NewStrItem(const AString: string; AObject: TObject): PStrItem;
begin
  GetMem(Result, Length(AString) + 5);
  Result^.FObject := AObject;
  Result^.FString := AString;
end;

procedure DisposeStrItem(P: PStrItem);
begin
  FreeMem(P, Length(P^.FString) + 5);
end;

constructor TStringList.Create;
begin
  FList := TList.Create;
end;

destructor TStringList.Destroy;
begin
  FOnChange := nil;
  FOnChanging := nil;
  if FList <> nil then
  begin
    Clear;
    FList.Free;
  end;
end;

function TStringList.Add(const S: string): Integer;
begin
  if not Sorted then
    Result := FList.Count
  else
    if Find(S, Result) then
      case Duplicates of
        dupIgnore: Exit;
        dupError: ListError(SDuplicateString);
      end;
  Changing;
  FList.Expand.Insert(Result, NewStrItem(S, nil));
  Changed;
end;

procedure TStringList.Changed;
begin
  if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TStringList.Changing;
begin
  if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
end;

procedure TStringList.Clear;
var
  I: Integer;
begin
  Changing;
  for I := 0 to FList.Count - 1 do DisposeStrItem(FList[I]);
  FList.Clear;
  Changed;
end;

procedure TStringList.Delete(Index: Integer);
begin
  Changing;
  DisposeStrItem(FList[Index]);
  FList.Delete(Index);
  Changed;
end;

procedure TStringList.Exchange(Index1, Index2: Integer);
begin
  Changing;
  FList.Exchange(Index1, Index2);
  Changed;
end;

function TStringList.Find(const S: string; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := AnsiCompareText(PStrItem(FList[I])^.FString, S);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        if Duplicates <> dupAccept then L := I;
      end;
    end;
  end;
  Index := L;
end;

function TStringList.Get(Index: Integer): string;
begin
  Result := PStrItem(FList[Index])^.FString;
end;

function TStringList.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TStringList.GetObject(Index: Integer): TObject;
begin
  Result := PStrItem(FList[Index])^.FObject;
end;

function TStringList.IndexOf(const S: string): Integer;
begin
  if not Sorted then Result := inherited IndexOf(S) else
    if not Find(S, Result) then Result := -1;
end;

procedure TStringList.Insert(Index: Integer; const S: string);
begin
  Changing;
  if Sorted then ListError(SSortedListError);
  FList.Expand.Insert(Index, NewStrItem(S, nil));
  Changed;
end;

procedure TStringList.Put(Index: Integer; const S: string);
var
  P: PStrItem;
begin
  Changing;
  if Sorted then ListError(SSortedListError);
  P := FList[Index];
  FList[Index] := NewStrItem(S, P^.FObject);
  DisposeStrItem(P);
  Changed;
end;

procedure TStringList.PutObject(Index: Integer; AObject: TObject);
begin
  Changing;
  PStrItem(FList[Index])^.FObject := AObject;
  Changed;
end;

procedure TStringList.QuickSort(L, R: Integer);
var
  I, J: Integer;
  P: PStrItem;
begin
  I := L;
  J := R;
  P := PStrItem(FList[(L + R) shr 1]);
  repeat
    while AnsiCompareText(PStrItem(FList[I])^.FString, P^.FString) < 0 do Inc(I);
    while AnsiCompareText(PStrItem(FList[J])^.FString, P^.FString) > 0 do Dec(J);
    if I <= J then
    begin
      FList.Exchange(I, J);
      Inc(I);
      Dec(J);
    end;
  until I > J;
  if L < J then QuickSort(L, J);
  if I < R then QuickSort(I, R);
end;

procedure TStringList.SetSorted(Value: Boolean);
begin
  if FSorted <> Value then
  begin
    if Value then Sort;
    FSorted := Value;
  end;
end;

procedure TStringList.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;

procedure TStringList.Sort;
begin
  if not Sorted and (FList.Count > 1) then
  begin
    Changing;
    QuickSort(0, FList.Count - 1);
    Changed;
  end;
end;

{ TStream }

function TStream.GetPosition: Longint;
begin
  Result := Seek(0, 1);
end;

procedure TStream.SetPosition(Pos: Longint);
begin
  Seek(Pos, 0);
end;

function TStream.GetSize: Longint;
var
  Pos: Longint;
begin
  Pos := Seek(0, 1);
  Result := Seek(0, 2);
  Seek(Pos, 0);
end;

procedure TStream.ReadBuffer(var Buffer; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(LoadStr(SReadError));
end;

procedure TStream.WriteBuffer(const Buffer; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(LoadStr(SWriteError));
end;

function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
const
  MaxBufSize = $F000;
var
  BufSize, N: Cardinal;
  Buffer: PChar;
begin
  if Count = 0 then
  begin
    Source.Position := 0;
    Count := Source.Size;
  end;
  Result := Count;
  if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  GetMem(Buffer, BufSize);
  try
    while Count <> 0 do
    begin
      if Count > BufSize then N := BufSize else N := Count;
      Source.ReadBuffer(Buffer^, N);
      WriteBuffer(Buffer^, N);
      Dec(Count, N);
    end;
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

function TStream.ReadComponent(Instance: TComponent): TComponent;
var
  Reader: TReader;
begin
  Reader := TReader.Create(Self, 4096);
  try
    Result := Reader.ReadRootComponent(Instance);
  finally
    Reader.Free;
  end;
end;

procedure TStream.WriteComponent(Instance: TComponent);
var
  Writer: TWriter;
begin
  Writer := TWriter.Create(Self, 4096);
  try
    Writer.WriteRootComponent(Instance);
  finally
    Writer.Free;
  end;
end;

function TStream.ReadComponentRes(Instance: TComponent): TComponent;
begin
  ReadResHeader;
  Result := ReadComponent(Instance);
end;

procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
var
  HeaderSize: Integer;
  Origin, ImageSize: Longint;
  Header: array[0..79] of Char;
begin
  Byte((@Header[0])^) := $FF;
  Word((@Header[1])^) := 10;
  HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10;
  Word((@Header[HeaderSize - 6])^) := $1030;
  Longint((@Header[HeaderSize - 4])^) := 0;
  WriteBuffer(Header, HeaderSize);
  Origin := Position;
  WriteComponent(Instance);
  ImageSize := Position - Origin;
  Position := Origin - 4;
  WriteBuffer(ImageSize, SizeOf(Longint));
  Position := Origin + ImageSize;
end;

procedure TStream.ReadResHeader;
var
  ReadCount: Longint;
  Header: array[0..79] of Char;
begin
  FillChar(Header, SizeOf(Header), 0);
  ReadCount := Read(Header, SizeOf(Header) - 1);
  if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then
    Seek(StrLen(Header + 3) + 10 - ReadCount, 1)
  else
    raise EInvalidImage.Create(LoadStr(SInvalidImage));
end;

{ THandleStream }

constructor THandleStream.Create(AHandle: Integer);
begin
  FHandle := AHandle;
end;

function THandleStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := FileRead(FHandle, Buffer, Count);
  if Result = -1 then Result := 0;
end;

function THandleStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := FileWrite(FHandle, Buffer, Count);
  if Result = -1 then Result := 0;
end;

function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  Result := FileSeek(FHandle, Offset, Origin);
end;

{ TFileStream }

constructor TFileStream.Create(const FileName: string; Mode: Word);
begin
  if Mode = fmCreate then
  begin
    FHandle := FileCreate(FileName);
    if FHandle < 0 then
      raise EFCreateError.Create(FmtLoadStr(SFCreateError, [FileName]));
  end else
  begin
    FHandle := FileOpen(FileName, Mode);
    if FHandle < 0 then
      raise EFOpenError.Create(FmtLoadStr(SFOpenError, [FileName]));
  end;
end;

destructor TFileStream.Destroy;
begin
  if FHandle >= 0 then FileClose(FHandle);
end;

{ TMemoryStream }

const
  MemoryDelta = $2000; { Must be a power of 2 }


function OffsetPointer(P: Pointer; Ofs: Longint): Pointer; assembler;
asm
        MOV     AX,Ofs.Word[0]
        MOV     DX,Ofs.Word[2]
        ADD     AX,P.Word[0]
        ADC     DX,0
        MOV     CX,OFFSET __AHSHIFT
        SHL     DX,CL
        ADD     DX,P.Word[2]
end;


destructor TMemoryStream.Destroy;
begin
  Clear;
  inherited Destroy;
end;

function TMemoryStream.Read(var Buffer; Count: Longint): Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then Result := Count;
      hmemcpy(@Buffer, OffsetPointer(FMemory, FPosition), Result);
      Inc(FPosition, Result);
      Exit;
    end;
  end;
  Result := 0;
end;

function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
var
  Pos: Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FSize then
      begin
        if Pos > FCapacity then
          SetCapacity((Pos + (MemoryDelta - 1)) and not (MemoryDelta - 1));
        FSize := Pos;
      end;
      hmemcpy(OffsetPointer(FMemory, FPosition), @Buffer, Count);
      FPosition := Pos;
      Result := Count;
      Exit;
    end;
  end;
  Result := 0;
end;

function TMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    0: FPosition := Offset;
    1: Inc(FPosition, Offset);
    2: FPosition := FSize + Offset;
  end;
  Result := FPosition;
end;

procedure TMemoryStream.LoadFromStream(Stream: TStream);
var
  Count: Longint;
begin
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
end;

procedure TMemoryStream.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TMemoryStream.SaveToStream(Stream: TStream);
begin
  if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
end;

procedure TMemoryStream.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TMemoryStream.Clear;
begin
  SetCapacity(0);
  FSize := 0;
  FPosition := 0;
end;

procedure TMemoryStream.SetSize(Size: Longint);
begin
  Clear;
  SetCapacity(Size);
  FSize := Size;
end;

procedure TMemoryStream.SetCapacity(Value: Longint);
var
  P: Pointer;
begin
  if Value <> FCapacity then
  begin
    if Value = 0 then
    begin
      GlobalFreePtr(FMemory);
      FMemory := nil;
    end else
    begin
      if FCapacity = 0 then
        P := GlobalAllocPtr(HeapAllocFlags, Value)
      else
        P := GlobalReallocPtr(FMemory, Value, HeapAllocFlags);
      if P = nil then raise EStreamError.Create(LoadStr(SMemoryStreamError));
      FMemory := P;
    end;
    FCapacity := Value;
  end;
end;

{ TFiler }

constructor TFiler.Create(Stream: TStream; BufSize: Cardinal);
begin
  FStream := Stream;
  GetMem(FBuffer, BufSize);
  FBufSize := BufSize;
end;

destructor TFiler.Destroy;
begin
  if FBuffer <> nil then FreeMem(FBuffer, FBufSize);
end;

{ TPropFixup }

type
  PPropFixup = ^TPropFixup;
  TPropFixup = record
    Instance: TPersistent;
    PropInfo: PPropInfo;
    Name: string;
  end;

function CreatePropFixup(Instance: TPersistent; PropInfo: PPropInfo;
  const Name: string): PPropFixup;
begin
  GetMem(Result, Length(Name) + 9);
  Result^.Instance := Instance;
  Result^.PropInfo := PropInfo;
  Result^.Name := Name;
end;

procedure FreePropFixup(P: PPropFixup);
begin
  FreeMem(P, Length(P^.Name) + 9);
end;

{ TReader }

procedure ReadError(const Message: string);
begin
  raise EReadError.Create(Message);
end;

procedure PropValueError;
begin
  ReadError(LoadStr(SInvalidPropertyValue));
end;

procedure PropertyNotFound;
begin
  ReadError(LoadStr(SUnknownProperty));
end;

function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
begin
  Result := GetEnumValue(EnumType, EnumName);
  if Result = -1 then PropValueError;
end;

destructor TReader.Destroy;
begin
  FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1);
  inherited Destroy;
end;

procedure TReader.CheckValue(Value: TValueType);
begin
  if ReadValue <> Value then
  begin
    Dec(FBufPos);
    SkipValue;
    PropValueError;
  end;
end;

procedure TReader.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
begin
  if CompareText(Name, FPropName) = 0 then
  begin
    ReadData(Self);
    FPropName := '';
  end;
end;

procedure TReader.DefineBinaryProperty(const Name: string;
  ReadData, WriteData: TStreamProc; HasData: Boolean);
var
  Stream: TMemoryStream;
  Count: Longint;
begin
  if CompareText(Name, FPropName) = 0 then
  begin
    if ReadValue <> vaBinary then
    begin
      Dec(FBufPos);
      SkipValue;
      FCanHandleExcepts := True;
      PropValueError;
    end;
    Stream := TMemoryStream.Create;
    try
      Read(Count, SizeOf(Count));
      Stream.SetSize(Count);
      Read(Stream.Memory^, Count);
      FCanHandleExcepts := True;
      ReadData(Stream);
    finally
      Stream.Free;
    end;
    FPropName := '';
  end;
end;

function TReader.EndOfList: Boolean;
begin
  Result := ReadValue = vaNull;
  Dec(FBufPos);
end;

function TReader.Error(const Message: string): Boolean;
begin
  Result := False;
  if Assigned(FOnError) then FOnError(Self, Message, Result);
end;

function TReader.FindMethod(Root: TComponent; const MethodName: string): Pointer;
var
  Error: Boolean;
begin
  Result := Root.MethodAddress(MethodName);
  Error := Result = nil;
  if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error);
  if Error then PropValueError;
end;

procedure TReader.FixupReferences;
var
  I: Integer;
begin
  if FFixups <> nil then
    try
      for I := 0 to FFixups.Count - 1 do
        with PPropFixup(FFixups[I])^ do
          SetOrdProp(Instance, PropInfo, Longint(FRoot.FindComponent(Name)));
    finally
      FreeFixups;
    end;
end;

procedure TReader.FreeFixups;
var
  I: Integer;
begin
  if FFixups <> nil then
  begin
    for I := 0 to FFixups.Count - 1 do FreePropFixup(FFixups[I]);
    FFixups.Free;
    FFixups := nil;
  end;
end;

function TReader.NextValue: TValueType;
begin
  Result := ReadValue;
  Dec(FBufPos);
end;

procedure TReader.PropertyError;
begin
  SkipValue;
  PropertyNotFound;
end;

procedure TReader.Read(var Buf; Count: Longint); assembler;
asm
        MOV     AX,Count.Word[0]
        MOV     DX,Count.Word[2]
        JMP     @@6
@@1:    LES     DI,Self
        MOV     CX,ES:[DI].TReader.FBufEnd
        SUB     CX,ES:[DI].TReader.FBufPos
        JA      @@2
        PUSH    DX
        PUSH    AX
        PUSH    ES
        PUSH    DI
        CALL    TReader.ReadBuffer
        POP     AX
        POP     DX
        LES     DI,Self
        MOV     CX,ES:[DI].TReader.FBufEnd
@@2:    OR      DX,DX
        JNE     @@3
        CMP     CX,AX
        JB      @@3
        MOV     CX,AX
@@3:    MOV     BX,Buf.Word[0]
        NEG     BX
        JE      @@4
        CMP     CX,BX
        JB      @@4
        MOV     CX,BX
@@4:    PUSH    DS
        SUB     AX,CX
        SBB     DX,0
        LDS     SI,ES:[DI].TReader.FBuffer
        ADD     SI,ES:[DI].TReader.FBufPos
        ADD     ES:[DI].TReader.FBufPos,CX
        LES     DI,Buf
        ADD     Buf.Word[0],CX
        JNC     @@5
        ADD     Buf.Word[2],OFFSET __AHINCR
@@5:    CLD
        REP     MOVSB
        POP     DS
@@6:    MOV     CX,AX
        OR      CX,DX
        JNE     @@1
end;

procedure TReader.ReadBuffer;
begin
  FBufEnd := FStream.Read(FBuffer^, FBufSize);
  if FBufEnd = 0 then raise EReadError.Create(LoadStr(SReadError));
  FBufPos := 0;
end;

function TReader.ReadBoolean: Boolean;
begin
  Result := ReadValue = vaTrue;
end;

function TReader.ReadChar: Char;
begin
  CheckValue(vaString);
  Read(Result, 1);
  if Ord(Result) <> 1 then
  begin
    Dec(FBufPos);
    ReadStr;
    PropValueError;
  end;
  Read(Result, 1);
end;

function TReader.ReadComponent: TComponent;

  procedure CreateComponent;
  begin
    try
      Result := TComponentClass(FindFieldClass(Root, ReadStr)).Create(Owner);
    except
      on E: Exception do
      begin
        SkipComponent(False);
        Result := nil;
        if not Error(E.Message) then raise;
      end;
    end;
  end;

  procedure ReadName;
  var
    Name: string[63];
  begin
    try
      Name := ReadStr;
      SetName(Result, Name);
    except
      on E: Exception do
      begin
        SkipComponent(False);
        Result.Free;
        Result := nil;
        if not Error(E.Message) then raise;
      end;
    end;
  end;

begin
  CreateComponent;
  if Result = nil then Exit;
  try
    Include(Result.FComponentState, csLoading);
    ReadName;
    Include(Result.FComponentState, csReading);
    Result.ReadState(Self);
    Exclude(Result.FComponentState, csReading);
    FLoaded.Add(Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TReader.ReadData(Instance: TComponent);
var
  OldParent: TComponent;
begin
  if FFixups = nil then
  begin
    FFixups := TList.Create;
    try
      ReadDataInner(Instance);
      FixupReferences;
    finally
      FreeFixups;
    end;
  end else
    ReadDataInner(Instance);
end;

procedure TReader.ReadDataInner(Instance: TComponent);
var
  OldParent: TComponent;
begin
  while not EndOfList do ReadProperty(Instance);
  ReadListEnd;
  OldParent := Parent;
  Parent := Instance;
  try
    while not EndOfList do ReadComponent;
    ReadListEnd;
  finally
    Parent := OldParent;
  end;
end;

function TReader.ReadFloat: Extended;
begin
  CheckValue(vaExtended);
  Read(Result, SizeOf(Result));
end;

function TReader.ReadIdent: string;
begin
  case ReadValue of
    vaIdent:
      begin
        Read(Result[0], 1);
        Read(Result[1], Ord(Result[0]));
      end;
    vaFalse:
      Result := 'False';
    vaTrue:
      Result := 'True';
  end;
end;

function TReader.ReadInteger: Longint;
var
  S: Shortint;
  I: Smallint;
begin
  case ReadValue of
    vaInt8:
      begin
        Read(S, SizeOf(Shortint));
        Result := S;
      end;
    vaInt16:
      begin
        Read(I, SizeOf(I));
        Result := I;
      end;
    vaInt32:
      Read(Result, SizeOf(Result));
  else
    PropValueError;
  end;
end;

procedure TReader.ReadListBegin;
begin
  CheckValue(vaList);
end;

procedure TReader.ReadListEnd;
begin
  CheckValue(vaNull);
end;

procedure TReader.ReadProperty(AInstance: TComponent);
var
  I, J, L: Integer;
  Instance: TPersistent;
  PropInfo: PPropInfo;
  PropValue: TObject;
  PropPath: string;

  procedure HandleException(E: Exception);
  var
    Name: string[63];
  begin
    Name := AInstance.Name;
    if Name = '' then Name := AInstance.ClassName;
    ReadError(FmtLoadStr(SPropertyException, [Name, PropPath, E.Message]));
  end;

  procedure PropPathError;
  begin
    SkipValue;
    ReadError(LoadStr(SInvalidPropertyPath));
  end;

begin
  try
    PropPath := ReadStr;
    try
      I := 1;
      L := Length(PropPath);
      Instance := AInstance;
      FCanHandleExcepts := True;
      while True do
      begin
        J := I;
        while (I <= L) and (PropPath[I] <> '.') do Inc(I);
        FPropName := Copy(PropPath, J, I - J);
        if I > L then Break;
        PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
        if PropInfo = nil then PropertyError;
        PropValue := nil;
        if PropInfo^.PropType^.Kind = tkClass then
          PropValue := TObject(GetOrdProp(Instance, PropInfo));
        if not (PropValue is TPersistent) then PropPathError;
        Instance := TPersistent(PropValue);
        Inc(I);
      end;
      PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
      if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else
      begin
        { Cannot reliably recover from an error in a defined property }
        FCanHandleExcepts := False;
        Instance.DefineProperties(Self);
        FCanHandleExcepts := True;
        if FPropName <> '' then PropertyError;
      end;
    except
      on E: Exception do HandleException(E);
    end;
  except
    on E: Exception do
      if not FCanHandleExcepts or not Error(E.Message) then raise;
  end;
end;

procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
var
  PropType: PTypeInfo;
  Method: TMethod;

  procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
    const Ident: string);
  var
    I: Integer;
    V: Longint;
  begin
    for I := 0 to IntConstList.Count - 1 do
      with TIntConst(IntConstList[I]) do
        if PPropInfo(PropInfo)^.PropType = IntegerType then
          if IdentToInt(Ident, V) then
          begin
            SetOrdProp(Instance, PropInfo, V);
            Exit;
          end;
    ReadError(LoadStr(SInvalidPropertyValue));
  end;

begin
  if PPropInfo(PropInfo)^.SetProc = nil then
    ReadError(LoadStr(SReadOnlyProperty));
  PropType := PPropInfo(PropInfo)^.PropType;
  case PropType^.Kind of
    tkInteger:
      if NextValue = vaIdent then
        SetIntIdent(Instance, PropInfo, ReadIdent) else
        SetOrdProp(Instance, PropInfo, ReadInteger);
    tkChar:
      SetOrdProp(Instance, PropInfo, Ord(ReadChar));
    tkEnumeration:
      SetOrdProp(Instance, PropInfo, EnumValue(PropType, ReadIdent));
    tkFloat:
      SetFloatProp(Instance, PropInfo, ReadFloat);
    tkString:
      SetStrProp(Instance, PropInfo, ReadString);
    tkSet:
      SetOrdProp(Instance, PropInfo, ReadSet(PropType));
    tkClass:
      FFixups.Add(CreatePropFixup(Instance, PropInfo, ReadIdent));
    tkMethod:
      begin
        Method.Code :=  FindMethod(Root, ReadIdent);
        Method.Data := Root;
        if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
      end;
  end;
end;

function TReader.ReadRootComponent(Root: TComponent): TComponent;
var
  I: Integer;
begin
  ReadSignature;
  try
    Result := nil;
    if Root = nil then
    begin
      Result := TComponentClass(FindClass(ReadStr)).Create(nil);
      Result.Name := ReadStr;
    end else
    begin
      Result := Root;
      ReadStr; { Ignore class name }
      ReadStr; { Ignore object name }
    end;
    FRoot := Result;
    FLoaded := TList.Create;
    try
      FLoaded.Add(FRoot);
      FOwner := FRoot;
      Include(FRoot.FComponentState, csLoading);
      Include(FRoot.FComponentState, csReading);
      FRoot.ReadState(Self);
      Exclude(FRoot.FComponentState, csReading);
      for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
    finally
      FLoaded.Free;
      FLoaded := nil;
    end;
  except
    if Root = nil then Result.Free;
    raise;
  end;
end;

procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  Proc: TReadComponentsProc);
var
  I: Integer;
  Component: TComponent;
begin
  Root := AOwner;
  Owner := AOwner;
  Parent := AParent;
  FLoaded := TList.Create;
  try
    FFixups := TList.Create;
    try
      while not EndOfList do
      begin
        ReadSignature;
        Component := ReadComponent;
        Proc(Component);
      end;
      FixupReferences;
      for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
    finally
      FreeFixups;
    end;
  finally
    FLoaded.Free;
    FLoaded := nil;
  end;
end;

function TReader.ReadSet(SetType: Pointer): Cardinal;
var
  EnumType: PTypeInfo;
  EnumName: string[63];
begin
  try
    if ReadValue <> vaSet then PropValueError;
    EnumType := GetTypeData(SetType)^.CompType;
    Result := 0;
    while True do
    begin
      EnumName := ReadStr;
      if EnumName = '' then Break;
      Include(TCardinalSet(Result), EnumValue(EnumType, EnumName));
    end;
  except
    SkipSetBody;
    raise;
  end;
end;

procedure TReader.ReadSignature;
var
  Signature: Longint;
begin
  Read(Signature, SizeOf(Signature));
  if Signature <> Longint(FilerSignature) then
    ReadError(LoadStr(SInvalidImage));
end;

function TReader.ReadStr: string;
begin
  Read(Result[0], 1);
  Read(Result[1], Ord(Result[0]));
end;

function TReader.ReadString: string;
begin
  CheckValue(vaString);
  Read(Result[0], 1);
  Read(Result[1], Ord(Result[0]));
end;

function TReader.ReadValue: TValueType;
begin
  Read(Result, SizeOf(Result));
end;

procedure TReader.SkipSetBody;
begin
  while ReadStr <> '' do begin end;
end;

procedure TReader.SkipValue;

  procedure SkipList;
  begin
    while not EndOfList do SkipValue;
    ReadListEnd;
  end;

  procedure SkipBytes(Count: Longint);
  var
    Bytes: array[0..255] of Char;
  begin
    while Count > 0 do
      if Count > SizeOf(Bytes) then
      begin
        Read(Bytes, SizeOf(Bytes));
        Dec(Count, SizeOf(Bytes));
      end
      else
      begin
        Read(Bytes, Count);
        Count := 0;
      end;
  end;

  procedure SkipBinary;
  var
    Count: Longint;
  begin
    Read(Count, SizeOf(Count));
    SkipBytes(Count);
  end;

begin
  case ReadValue of
    vaNull: begin end;
    vaList: SkipList;
    vaInt8: SkipBytes(1);
    vaInt16: SkipBytes(2);
    vaInt32: SkipBytes(4);
    vaExtended: SkipBytes(SizeOf(Extended));
    vaString, vaIdent: ReadStr;
    vaFalse, vaTrue: begin end;
    vaBinary: SkipBinary;
    vaSet: SkipSetBody;
  end;
end;

procedure TReader.SkipProperty;
begin
  ReadStr; { Skips property name }
  SkipValue;
end;

procedure TReader.SkipComponent(SkipType: Boolean);
begin
  if SkipType then ReadStr;
  ReadStr;
  while not EndOfList do SkipProperty;
  ReadListEnd;
  while not EndOfList do SkipComponent(True);
  ReadListEnd;
end;

procedure TReader.SetName(Component: TComponent; var Name: string);
begin
  if Assigned(FOnSetName) then FOnSetName(Self, Component, Name);
  Component.Name := Name;
end;

{ TWriter }

destructor TWriter.Destroy;
begin
  WriteBuffer;
  inherited Destroy;
end;

procedure TWriter.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
begin
  if HasData then
  begin
    WritePropName(Name);
    WriteData(Self);
  end;
end;

procedure TWriter.DefineBinaryProperty(const Name: string;
  ReadData, WriteData: TStreamProc; HasData: Boolean);
begin
  if HasData then
  begin
    WritePropName(Name);
    WriteBinary(WriteData);
  end;
end;

procedure TWriter.Write(const Buf; Count: Longint); assembler;
asm
        MOV     AX,Count.Word[0]
        MOV     DX,Count.Word[2]
        JMP     @@6
@@1:    LES     DI,Self
        MOV     CX,ES:[DI].TWriter.FBufSize
        SUB     CX,ES:[DI].TWriter.FBufPos
        JA      @@2
        PUSH    DX
        PUSH    AX
        PUSH    ES
        PUSH    DI
        CALL    TWriter.WriteBuffer
        POP     AX
        POP     DX
        LES     DI,Self
        MOV     CX,ES:[DI].TWriter.FBufSize
@@2:    OR      DX,DX
        JNE     @@3
        CMP     CX,AX
        JB      @@3
        MOV     CX,AX
@@3:    MOV     BX,Buf.Word[0]
        NEG     BX
        JE      @@4
        CMP     CX,BX
        JB      @@4
        MOV     CX,BX
@@4:    PUSH    DS
        SUB     AX,CX
        SBB     DX,0
        MOV     BX,ES:[DI].TWriter.FBufPos
        ADD     ES:[DI].TWriter.FBufPos,CX
        LES     DI,ES:[DI].TWriter.FBuffer
        ADD     DI,BX
        LDS     SI,Buf
        ADD     Buf.Word[0],CX
        JNC     @@5
        ADD     Buf.Word[2],OFFSET __AHINCR
@@5:    CLD
        REP     MOVSB
        POP     DS
@@6:    MOV     CX,AX
        OR      CX,DX
        JNE     @@1
@@7:
end;

procedure TWriter.WriteBinary(WriteData: TStreamProc);
var
  Stream: TMemoryStream;
  Count: Longint;
begin
  Stream := TMemoryStream.Create;
  try
    WriteData(Stream);
    WriteValue(vaBinary);
    Count := Stream.Size;
    Write(Count, SizeOf(Count));
    Write(Stream.Memory^, Count);
  finally
    Stream.Free;
  end;
end;

procedure TWriter.WriteBuffer;
begin
  FStream.WriteBuffer(FBuffer^, FBufPos);
  FBufPos := 0;
end;

procedure TWriter.WriteBoolean(Value: Boolean);
begin
  if Value then
    WriteValue(vaTrue) else
    WriteValue(vaFalse);
end;

procedure TWriter.WriteChar(Value: Char);
begin
  WriteString(Value);
end;

procedure TWriter.WriteComponent(Component: TComponent);
begin
  Include(Component.FComponentState, csWriting);
  Component.WriteState(Self);
  Exclude(Component.FComponentState, csWriting);
end;

procedure TWriter.WriteData(Instance: TComponent);
var
  I: Integer;
  OwnedInstance: TComponent;
begin
  WriteStr(Instance.ClassName);
  WriteStr(Instance.Name);
  WriteProperties(Instance);
  WriteListEnd;
  Instance.WriteComponents(Self);
  if Instance = Root then
    for I := 0 to Root.ComponentCount - 1 do
    begin
      OwnedInstance := Root.Components[I];
      if not OwnedInstance.HasParent then WriteComponent(OwnedInstance);
    end;
  WriteListEnd;
end;

procedure TWriter.WriteFloat(Value: Extended);
begin
  WriteValue(vaExtended);
  Write(Value, SizeOf(Extended));
end;

procedure TWriter.WriteIdent(const Ident: string);
begin
  if Ident = 'False' then WriteValue(vaFalse) else
  if Ident = 'True' then WriteValue(vaTrue) else
  begin
    WriteValue(vaIdent);
    WriteStr(Ident);
  end;
end;

procedure TWriter.WriteInteger(Value: Longint);
begin
  if (Value >= -128) and (Value <= 127) then
  begin
    WriteValue(vaInt8);
    Write(Value, SizeOf(Shortint));
  end else
  if (Value >= -32768) and (Value <= 32767) then
  begin
    WriteValue(vaInt16);
    Write(Value, SizeOf(Smallint));
  end else
  begin
    WriteValue(vaInt32);
    Write(Value, SizeOf(Longint));
  end;
end;

procedure TWriter.WriteListBegin;
begin
  WriteValue(vaList);
end;

procedure TWriter.WriteListEnd;
begin
  WriteValue(vaNull);
end;

procedure TWriter.WriteProperties(Instance: TPersistent);
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Instance.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if IsStoredProp(Instance, PropInfo) then
          WriteProperty(Instance, PropInfo);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
  Instance.DefineProperties(Self);
end;

procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
var
  PropType: PTypeInfo;

  procedure WritePropPath;
  begin
    WritePropName(PPropInfo(PropInfo)^.Name);
  end;

  procedure WriteSet(Value: Cardinal);
  var
    I: Integer;
    BaseType: PTypeInfo;
  begin
    BaseType := GetTypeData(PropType)^.CompType;
    WriteValue(vaSet);
    for I := 0 to 15 do
      if I in TCardinalSet(Value) then WriteStr(GetEnumName(BaseType, I)^);
    WriteStr('');
  end;

  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  var
    I: Integer;
    Ident: string[64];
  begin
    for I := 0 to IntConstList.Count - 1 do
      with TIntConst(IntConstList[I]) do
        if IntType = IntegerType then
          if IntToIdent(Value, Ident) then
          begin
            WriteIdent(Ident);
            Exit;
          end
          else Break;
    WriteInteger(Value);
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    if Value <> PPropInfo(PropInfo)^.Default then
    begin
      WritePropPath;
      case PropType^.Kind of
        tkInteger:
          WriteIntProp(PPropInfo(PropInfo)^.PropType, Value);
        tkChar:
          WriteChar(Chr(Value));
        tkSet:
          WriteSet(Value);
        tkEnumeration:
          WriteIdent(GetEnumName(PropType, Value)^);
      end;
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    if Value <> 0 then
    begin
      WritePropPath;
      WriteFloat(Value);
    end;
  end;

  procedure WriteStrProp;
  var
    Value: string;
  begin
    Value := GetStrProp(Instance, PropInfo);
    if Value <> '' then
    begin
      WritePropPath;
      WriteString(Value);
    end;
  end;

  procedure WriteObjectProp;
  var
    Len: Integer;
    Value: TObject;
  begin
    Value := TObject(GetOrdProp(Instance, PropInfo));
    if Value is TPersistent then
      if Value is TComponent then
      begin
        WritePropPath;
        WriteIdent(TComponent(Value).Name);
      end else
      begin
        Len := Length(FPropPath);
        FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
        WriteProperties(TPersistent(Value));
        FPropPath[0] := Chr(Len);
      end;
  end;

  procedure WriteMethodProp;
  var
    Value: TMethod;
  begin
    Value := GetMethodProp(Instance, PropInfo);
    if (Value.Code <> nil) and (Value.Data = Root) then
    begin
      WritePropPath;
      WriteIdent(Root.MethodName(Value.Code));
    end;
  end;

begin
  if PPropInfo(PropInfo)^.SetProc <> nil then
  begin
    PropType := PPropInfo(PropInfo)^.PropType;
    case PropType^.Kind of
      tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
      tkFloat: WriteFloatProp;
      tkString: WriteStrProp;
      tkClass: WriteObjectProp;
      tkMethod: WriteMethodProp;
    end;
  end;
end;

procedure TWriter.WritePropName(const PropName: string);
begin
  WriteStr(FPropPath + PropName);
end;

procedure TWriter.WriteRootComponent(Root: TComponent);
begin
  FRoot := Root;
  WriteSignature;
  WriteComponent(Root);
end;

procedure TWriter.WriteSignature;
begin
  Write(FilerSignature, SizeOf(FilerSignature));
end;

procedure TWriter.WriteStr(const Value: string);
begin
  Write(Value, Length(Value) + 1);
end;

procedure TWriter.WriteString(const Value: string);
begin
  WriteValue(vaString);
  WriteStr(Value);
end;

procedure TWriter.WriteValue(Value: TValueType);
begin
  Write(Value, SizeOf(Value));
end;

{ TParser }

const
  ParseBufSize = 4096;

procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
asm
        PUSH    DS
        CLD
        LDS     SI,Buffer
        LES     DI,Text
        MOV     CX,BufSize
        MOV     BH,0
        JMP     @@1
@@0:    DB      '0123456789ABCDEF'
@@1:    LODSB
        MOV     BL,AL
        AND     BL,0FH
        MOV     AH,@@0.Byte[BX]
        MOV     BL,AL
        SHR     BL,4
        MOV     AL,@@0.Byte[BX]
        STOSW
        LOOP    @@1
        POP     DS
end;

function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
asm
        PUSH    DS
        CLD
        LDS     SI,Text
        LES     DI,Buffer
        MOV     CX,BufSize
        MOV     BH,0
        JMP     @@1
@@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
        DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
        DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
        DB      -1,10,11,12,13,14,15
@@1:    LODSW
        CMP     AL,'0'
        JB      @@2
        CMP     AL,'f'
        JA      @@2
        MOV     BL,AL
        MOV     AL,@@0.Byte[BX-'0']
        CMP     AL,-1
        JE      @@2
        SHL     AL,4
        CMP     AH,'0'
        JB      @@2
        CMP     AH,'f'
        JA      @@2
        MOV     BL,AH
        MOV     AH,@@0.Byte[BX-'0']
        CMP     AH,-1
        JE      @@2
        OR      AL,AH
        STOSB
        LOOP    @@1
@@2:    MOV     AX,DI
        SUB     AX,Buffer.Word[0]
        POP     DS
end;

constructor TParser.Create(Stream: TStream);
begin
  FStream := Stream;
  GetMem(FBuffer, ParseBufSize);
  FBuffer[0] := #0;
  FBufPtr := FBuffer;
  FBufEnd := FBuffer + ParseBufSize;
  FSourcePtr := FBuffer;
  FSourceEnd := FBuffer;
  FTokenPtr := FBuffer;
  FSourceLine := 1;
  NextToken;
end;

destructor TParser.Destroy;
begin
  if FBuffer <> nil then
  begin
    FStream.Seek(Longint(FTokenPtr) - Longint(FSourceEnd), 1);
    FreeMem(FBuffer, ParseBufSize);
  end;
end;

procedure TParser.CheckToken(T: Char);
begin
  if Token <> T then
    case T of
      toSymbol:
        Error(SIdentifierExpected);
      toString:
        Error(SStringExpected);
      toInteger, toFloat:
        Error(SNumberExpected);
    else
      ErrorStr(FmtLoadStr(SCharExpected, [T]));
    end;
end;

procedure TParser.CheckTokenSymbol(const S: string);
begin
  if not TokenSymbolIs(S) then ErrorStr(FmtLoadStr(SSymbolExpected, [S]));
end;

procedure TParser.Error(MessageID: Word);
begin
  ErrorStr(LoadStr(MessageID));
end;

procedure TParser.ErrorStr(const Message: string);
begin
  raise EParserError.Create(FmtLoadStr(SParseError, [Message, FSourceLine]));
end;

procedure TParser.HexToBinary(Stream: TStream);
var
  Count: Integer;
  Buffer: array[0..255] of Char;
begin
  SkipBlanks;
  while FSourcePtr^ <> '}' do
  begin
    Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
    if Count = 0 then Error(SInvalidBinary);
    Stream.Write(Buffer, Count);
    Inc(FSourcePtr, Count * 2);
    SkipBlanks;
  end;
  NextToken;
end;

function TParser.NextToken: Char;
var
  I: Integer;
  P, S: PChar;
begin
  SkipBlanks;
  P := FSourcePtr;
  FTokenPtr := P;
  case P^ of
    'A'..'Z', 'a'..'z', '_':
      begin
        Inc(P);
        while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
        Result := toSymbol;
      end;
    '#', '''':
      begin
        S := P;
        while True do
          case P^ of
            '#':
              begin
                Inc(P);
                I := 0;
                while P^ in ['0'..'9'] do
                begin
                  I := I * 10 + (Ord(P^) - Ord('0'));
                  Inc(P);
                end;
                S^ := Chr(I);
                Inc(S);
              end;
            '''':
              begin
                Inc(P);
                while True do
                begin
                  case P^ of
                    #0, #10, #13:
                      Error(SInvalidString);
                    '''':
                      begin
                        Inc(P);
                        if P^ <> '''' then Break;
                      end;
                  end;
                  S^ := P^;
                  Inc(S);
                  Inc(P);
                end;
              end;
          else
            Break;
          end;
        FStringPtr := S;
        Result := toString;
      end;
    '$':
      begin
        Inc(P);
        while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
        Result := toInteger;
      end;
    '-', '0'..'9':
      begin
        Inc(P);
        while P^ in ['0'..'9'] do Inc(P);
        Result := toInteger;
        while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
        begin
          Inc(P);
          Result := toFloat;
        end;
      end;
  else
    Result := P^;
    if Result <> toEOF then Inc(P);
  end;
  FSourcePtr := P;
  FToken := Result;
end;

procedure TParser.ReadBuffer;
var
  Count: Integer;
begin
  Inc(FOrigin, FSourcePtr - FBuffer);
  FSourceEnd[0] := FSaveChar;
  Count := FBufPtr - FSourcePtr;
  if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  FBufPtr := FBuffer + Count;
  Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  FSourcePtr := FBuffer;
  FSourceEnd := FBufPtr;
  if FSourceEnd = FBufEnd then
  begin
    FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
    if FSourceEnd = FBuffer then Error(SLineTooLong);
  end;
  FSaveChar := FSourceEnd[0];
  FSourceEnd[0] := #0;
end;

procedure TParser.SkipBlanks;
begin
  while True do
  begin
    case FSourcePtr^ of
      #0:
        begin
          ReadBuffer;
          if FSourcePtr^ = #0 then Exit;
          Continue;
        end;
      #10:
        Inc(FSourceLine);
      #33..#255:
        Exit;
    end;
    Inc(FSourcePtr);
  end;
end;

function TParser.SourcePos: Longint;
begin
  Result := FOrigin + (FTokenPtr - FBuffer);
end;

function TParser.TokenFloat: Extended;
begin
  Result := StrToFloat(TokenString);
end;

function TParser.TokenInt: Longint;
begin
  Result := StrToInt(TokenString);
end;

function TParser.TokenString: string;
var
  L: Integer;
begin
  if FToken = toString then
    L := FStringPtr - FTokenPtr else
    L := FSourcePtr - FTokenPtr;
  if L > 255 then L := 255;
  Result[0] := Char(L);
  Move(FTokenPtr[0], Result[1], L);
end;

function TParser.TokenSymbolIs(const S: string): Boolean;
begin
  Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
end;

{ Binary to text conversion }

procedure ObjectBinaryToText(Input, Output: TStream);
var
  NestingLevel: Integer;
  Reader: TReader;
  Writer: TWriter;

  procedure WriteIndent;
  const
    Blanks: array[0..1] of Char = '  ';
  var
    I: Integer;
  begin
    for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
  end;

  procedure WriteStr(const S: string);
  begin
    Writer.Write(S[1], Length(S));
  end;

  procedure NewLine;
  begin
    WriteStr(#13#10);
    WriteIndent;
  end;

  procedure ConvertHeader;
  var
    ClassName, ObjectName: string[63];
  begin
    ClassName := Reader.ReadStr;
    ObjectName := Reader.ReadStr;
    WriteIndent;
    WriteStr('object ');
    if ObjectName <> '' then
    begin
      WriteStr(ObjectName);
      WriteStr(': ');
    end;
    WriteStr(ClassName);
    WriteStr(#13#10);
  end;

  procedure ConvertBinary;
  const
    BytesPerLine = 32;
  var
    MultiLine: Boolean;
    I: Integer;
    Count: Longint;
    Buffer: array[0..BytesPerLine - 1] of Char;
    Text: array[0..BytesPerLine * 2 - 1] of Char;
  begin
    WriteStr('{');
    Inc(NestingLevel);
    Reader.Read(Count, SizeOf(Count));
    MultiLine := Count >= BytesPerLine;
    while Count > 0 do
    begin
      if MultiLine then NewLine;
      if Count >= 32 then I := 32 else I := Count;
      Reader.Read(Buffer, I);
      BinToHex(Buffer, Text, I);
      Writer.Write(Text, I * 2);
      Dec(Count, I);
    end;
    Dec(NestingLevel);
    WriteStr('}');
  end;

  procedure ConvertValue;
  var
    I, J, L: Integer;
    Int8: Shortint;
    Int16: Smallint;
    Int32: Longint;
    Ext: Extended;
    S: string;
  begin
    case Reader.ReadValue of
      vaList:
        begin
          WriteStr('(');
          Inc(NestingLevel);
          while not Reader.EndOfList do
          begin
            NewLine;
            ConvertValue;
          end;
          Reader.ReadListEnd;
          Dec(NestingLevel);
          WriteStr(')');
        end;
      vaInt8:
        begin
          Reader.Read(Int8, SizeOf(Int8));
          WriteStr(IntToStr(Int8));
        end;
      vaInt16:
        begin
          Reader.Read(Int16, SizeOf(Int16));
          WriteStr(IntToStr(Int16));
        end;
      vaInt32:
        begin
          Reader.Read(Int32, SizeOf(Int32));
          WriteStr(IntToStr(Int32));
        end;
      vaExtended:
        begin
          Reader.Read(Ext, SizeOf(Ext));
          WriteStr(FloatToStr(Ext));
        end;
      vaString:
        begin
          S := Reader.ReadStr;
          L := Length(S);
          if L = 0 then WriteStr('''''') else
          begin
            I := 1;
            repeat
              if (S[I] >= ' ') and (S[I] <> '''') then
              begin
                J := I;
                repeat Inc(I) until (I > L) or (S[I] < ' ') or (S[I] = '''');
                WriteStr('''');
                WriteStr(Copy(S, J, I - J));
                WriteStr('''');
              end else
              begin
                WriteStr('#');
                WriteStr(IntToStr(Ord(S[I])));
                Inc(I);
              end;
            until I > L;
          end;
        end;
      vaIdent:
        WriteStr(Reader.ReadStr);
      vaFalse:
        WriteStr('False');
      vaTrue:
        WriteStr('True');
      vaBinary:
        ConvertBinary;
      vaSet:
        begin
          WriteStr('[');
          I := 0;
          while True do
          begin
            S := Reader.ReadStr;
            if S = '' then Break;
            if I > 0 then WriteStr(', ');
            WriteStr(S);
            Inc(I);
          end;
          WriteStr(']');
        end;
    end;
  end;

  procedure ConvertProperty;
  begin
    WriteIndent;
    WriteStr(Reader.ReadStr);
    WriteStr(' = ');
    ConvertValue;
    WriteStr(#13#10);
  end;

  procedure ConvertObject;
  begin
    ConvertHeader;
    Inc(NestingLevel);
    while not Reader.EndOfList do ConvertProperty;
    Reader.ReadListEnd;
    while not Reader.EndOfList do ConvertObject;
    Reader.ReadListEnd;
    Dec(NestingLevel);
    WriteIndent;
    WriteStr('end'#13#10);
  end;

begin
  NestingLevel := 0;
  Reader := TReader.Create(Input, 4096);
  try
    Writer := TWriter.Create(Output, 4096);
    try
      Reader.ReadSignature;
      ConvertObject;
    finally
      Writer.Free;
    end;
  finally
    Reader.Free;
  end;
end;

{ Text to binary conversion }

procedure ObjectTextToBinary(Input, Output: TStream);
var
  Parser: TParser;
  Writer: TWriter;

  procedure ConvertHeader;
  var
    ClassName, ObjectName: string[63];
  begin
    Parser.CheckToken(toSymbol);
    ClassName := Parser.TokenString;
    ObjectName := '';
    if Parser.NextToken = ':' then
    begin
      Parser.NextToken;
      Parser.CheckToken(toSymbol);
      ObjectName := ClassName;
      ClassName := Parser.TokenString;
      Parser.NextToken;
    end;
    Writer.WriteStr(ClassName);
    Writer.WriteStr(ObjectName);
  end;

  procedure ConvertValue;
  begin
    case Parser.Token of
      toSymbol:
        Writer.WriteIdent(Parser.TokenString);
      toString:
        Writer.WriteString(Parser.TokenString);
      toInteger:
        Writer.WriteInteger(Parser.TokenInt);
      toFloat:
        Writer.WriteFloat(Parser.TokenFloat);
      '[':
        begin
          Parser.NextToken;
          Writer.WriteValue(vaSet);
          if Parser.Token <> ']' then
            while True do
            begin
              Parser.CheckToken(toSymbol);
              Writer.WriteStr(Parser.TokenString);
              if Parser.NextToken = ']' then Break;
              Parser.CheckToken(',');
              Parser.NextToken;
            end;
          Writer.WriteStr('');
        end;
      '(':
        begin
          Parser.NextToken;
          Writer.WriteListBegin;
          while Parser.Token <> ')' do ConvertValue;
          Writer.WriteListEnd;
        end;
      '{':
        Writer.WriteBinary(Parser.HexToBinary);
    else
      Parser.Error(SInvalidProperty);
    end;
    Parser.NextToken;
  end;

  procedure ConvertProperty;
  var
    PropName: string;
  begin
    Parser.CheckToken(toSymbol);
    PropName := Parser.TokenString;
    Parser.NextToken;
    while Parser.Token = '.' do
    begin
      Parser.NextToken;
      Parser.CheckToken(toSymbol);
      PropName := PropName + '.' + Parser.TokenString;
      Parser.NextToken;
    end;
    Writer.WriteStr(PropName);
    Parser.CheckToken('=');
    Parser.NextToken;
    ConvertValue;
  end;

  procedure ConvertObject;
  begin
    Parser.CheckTokenSymbol('OBJECT');
    Parser.NextToken;
    ConvertHeader;
    while not Parser.TokenSymbolIs('END') and
      not Parser.TokenSymbolIs('OBJECT') do ConvertProperty;
    Writer.WriteListEnd;
    while not Parser.TokenSymbolIs('END') do ConvertObject;
    Writer.WriteListEnd;
    Parser.NextToken;
  end;

begin
  Parser := TParser.Create(Input);
  try
    Writer := TWriter.Create(Output, 4096);
    try
      Writer.WriteSignature;
      ConvertObject;
    finally
      Writer.Free;
    end;
  finally
    Parser.Free;
  end;
end;

{ Resource to text conversion }

procedure ObjectResourceToText(Input, Output: TStream);
begin
  Input.ReadResHeader;
  ObjectBinaryToText(Input, Output);
end;

{ Text to resource conversion }

procedure ObjectTextToResource(Input, Output: TStream);
var
  Len: Byte;
  MemoryStream: TMemoryStream;
  MemorySize: Longint;
  Header: array[0..79] of Char;
begin
  MemoryStream := TMemoryStream.Create;
  try
    ObjectTextToBinary(Input, MemoryStream);
    MemorySize := MemoryStream.Size;
    FillChar(Header, SizeOf(Header), 0);
    MemoryStream.Position := SizeOf(Longint); { Skip header }
    MemoryStream.Read(Len, 1);
    MemoryStream.Read(Header[3], Len);
    StrUpper(@Header[3]);
    Byte((@Header[0])^) := $FF;
    Word((@Header[1])^) := 10;
    Word((@Header[Len + 4])^) := $1030;
    Longint((@Header[Len + 6])^) := MemorySize;
    Output.Write(Header, Len + 10);
    Output.Write(MemoryStream.Memory^, MemorySize);
  finally
    MemoryStream.Free;
  end;
end;

{ TComponent }

constructor TComponent.Create(AOwner: TComponent);
begin
  FName := NullStr;
  if AOwner <> nil then AOwner.InsertComponent(Self);
end;

destructor TComponent.Destroy;
begin
  Destroying;
  DestroyComponents;
  if FOwner <> nil then FOwner.RemoveComponent(Self);
  DisposeStr(FName);
end;

procedure TComponent.ReadLeft(Reader: TReader);
begin
  LongRec(FDesignInfo).Lo := Reader.ReadInteger;
end;

procedure TComponent.ReadTop(Reader: TReader);
begin
  LongRec(FDesignInfo).Hi := Reader.ReadInteger;
end;

procedure TComponent.WriteLeft(Writer: TWriter);
begin
  Writer.WriteInteger(LongRec(FDesignInfo).Lo);
end;

procedure TComponent.WriteTop(Writer: TWriter);
begin
  Writer.WriteInteger(LongRec(FDesignInfo).Hi);
end;

procedure TComponent.Insert(AComponent: TComponent);
begin
  if FComponents = nil then FComponents := TList.Create;
  FComponents.Add(AComponent);
  AComponent.FOwner := Self;
end;

procedure TComponent.Remove(AComponent: TComponent);
begin
  AComponent.FOwner := nil;
  FComponents.Remove(AComponent);
  if FComponents.Count = 0 then
  begin
    FComponents.Free;
    FComponents := nil;
  end;
end;

procedure TComponent.InsertComponent(AComponent: TComponent);
begin
  ValidateRename(AComponent, '', AComponent.FName^);
  Insert(AComponent);
  AComponent.SetReference(True);
  if csDesigning in ComponentState then
    AComponent.SetDesigning(True);
  Notification(AComponent, opInsert);
end;

procedure TComponent.RemoveComponent(AComponent: TComponent);
begin
  Notification(AComponent, opRemove);
  AComponent.SetReference(False);
  Remove(AComponent);
  AComponent.SetDesigning(False);
  ValidateRename(AComponent, AComponent.FName^, '');
end;

procedure TComponent.DestroyComponents;
var
  Instance: TComponent;
begin
  while FComponents <> nil do
  begin
    Instance := FComponents.Last;
    Remove(Instance);
    Instance.Destroy;
  end;
end;

procedure TComponent.Destroying;
var
  I: Integer;
begin
  if not (csDestroying in FComponentState) then
  begin
    Include(FComponentState, csDestroying);
    if FComponents <> nil then
      for I := 0 to FComponents.Count - 1 do
        TComponent(FComponents[I]).Destroying;
  end;
end;

procedure TComponent.Notification(AComponent: TComponent;
  Operation: TOperation);
var
  I: Integer;
begin
  if FComponents <> nil then
    for I := 0 to FComponents.Count - 1 do
      TComponent(FComponents[I]).Notification(AComponent, Operation);
end;

procedure TComponent.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Left', ReadLeft, WriteLeft, LongRec(FDesignInfo).Lo <> 0);
  Filer.DefineProperty('Top', ReadTop, WriteTop, LongRec(FDesignInfo).Hi <> 0);
end;

function TComponent.HasParent: Boolean;
begin
  Result := False;
end;

procedure TComponent.Loaded;
begin
  Exclude(FComponentState, csLoading);
end;

procedure TComponent.ReadState(Reader: TReader);
begin
  Reader.ReadData(Self);
end;

procedure TComponent.WriteComponents(Writer: TWriter);
begin
end;

procedure TComponent.WriteState(Writer: TWriter);
begin
  Writer.WriteData(Self);
end;

procedure TComponent.ValidateRename(AComponent: TComponent;
  const CurName, NewName: string);
begin
  if (AComponent <> nil) and (CompareText(CurName, NewName) <> 0) and
    (FindComponent(NewName) <> nil) then
    raise EComponentError.Create(FmtLoadStr(SDuplicateName, [NewName]));
end;

function TComponent.FindComponent(const AName: string): TComponent;
var
  I: Integer;
begin
  if (AName <> '') and (FComponents <> nil) then
    for I := 0 to FComponents.Count - 1 do
    begin
      Result := FComponents[I];
      if CompareText(Result.FName^, AName) = 0 then Exit;
    end;
  Result := nil;
end;

function TComponent.GetName: TComponentName;
begin
  GetName := FName^;
end;

procedure TComponent.SetName(const NewName: TComponentName);
begin
  if FName^ <> NewName then
  begin
    if (NewName <> '') and not IsValidIdent(NewName) then
      raise EComponentError.Create(FmtLoadStr(SInvalidName, [NewName]));
    if FOwner <> nil then
      FOwner.ValidateRename(Self, FName^, NewName) else
      ValidateRename(nil, FName^, NewName);
    SetReference(False);
    ChangeName(NewName);
    SetReference(True);
  end;
end;

procedure TComponent.ChangeName(const NewName: TComponentName);
begin
  AssignStr(FName, NewName);
end;

function TComponent.GetComponentIndex: Integer;
begin
  if (FOwner <> nil) and (FOwner.FComponents <> nil) then
    Result := FOwner.FComponents.IndexOf(Self) else
    Result := -1;
end;

function TComponent.GetComponent(AIndex: Integer): TComponent;
begin
  if FComponents <> nil then
    Result := FComponents[AIndex] else
    ListError(SListIndexError);
end;

function TComponent.GetComponentCount: Integer;
begin
  if FComponents <> nil then
    Result := FComponents.Count else
    Result := 0;
end;

procedure TComponent.SetComponentIndex(Value: Integer);
var
  I, Count: Integer;
begin
  if FOwner <> nil then
  begin
    I := FOwner.FComponents.IndexOf(Self);
    if I >= 0 then
    begin
      Count := FOwner.FComponents.Count;
      if Value < 0 then Value := 0;
      if Value >= Count then Value := Count - 1;
      if Value <> I then
      begin
        FOwner.FComponents.Delete(I);
        FOwner.FComponents.Insert(Value, Self);
      end;
    end;
  end;
end;

procedure TComponent.SetDesigning(Value: Boolean);
var
  I: Integer;
begin
  if Value then
    Include(FComponentState, csDesigning) else
    Exclude(FComponentState, csDesigning);
  for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value);
end;

procedure TComponent.SetReference(Enable: Boolean);
var
  Field: ^TComponent;
begin
  if FOwner <> nil then
  begin
    Field := FOwner.FieldAddress(FName^);
    if Field <> nil then
      if Enable then Field^ := Self else Field^ := nil;
  end;
end;

begin
  ClassList := TList.Create;
  ClassAliasList := TStringList.Create;
  IntConstList := TList.Create;
end.
