{*******************************************************}  //  XCL version of System
{                                                       }  // unit. Created Jun-2000
{       Borland Delphi Runtime Library                  }  // (C) by Kladov Vladimir
{       System Unit                                     }  //
{                                                       }  // purpose: make XCL Delphi
{       Copyright (C) 1988,99 Inprise Corporation       }  // programs even smaller.
{                                                       }  //
{*******************************************************}  // Changes are marked as {X}

unit System; { Predefined constants, types, procedures, }
             { and functions (such as True, Integer, or }
             { Writeln) do not have actual declarations.}
             { Instead they are built into the compiler }
             { and are treated as if they were declared }
             { at the beginning of the System unit.     }

{$H+,I-,S-}

{ L- should never be specified.

  The IDE needs to find debug hook (through the C++
  compiler sometimes) for integrated debugging to
  function properly.

  ILINK will generate debug info for DebugHook if
  the object module has not been compiled with debug info.

  ILINK will not generate debug info for DebugHook if
  the object module has been compiled with debug info.

  Thus, the Pascal compiler must be responsible for
  generating the debug information for that symbol
  when a debug-enabled object file is produced.
}

interface

const

{ Variant type codes (wtypes.h) }

  varEmpty    = $0000; { vt_empty       }
  varNull     = $0001; { vt_null        }
  varSmallint = $0002; { vt_i2          }
  varInteger  = $0003; { vt_i4          }
  varSingle   = $0004; { vt_r4          }
  varDouble   = $0005; { vt_r8          }
  varCurrency = $0006; { vt_cy          }
  varDate     = $0007; { vt_date        }
  varOleStr   = $0008; { vt_bstr        }
  varDispatch = $0009; { vt_dispatch    }
  varError    = $000A; { vt_error       }
  varBoolean  = $000B; { vt_bool        }
  varVariant  = $000C; { vt_variant     }
  varUnknown  = $000D; { vt_unknown     }
                       { vt_decimal $e  }
                       { undefined  $f  }
                       { vt_i1      $10 }
  varByte     = $0011; { vt_ui1         }
                       { vt_ui2     $12 }
                       { vt_ui4     $13 }
                       { vt_i8      $14 }
  { if adding new items, update varLast, BaseTypeMap and OpTypeMap }
  varStrArg   = $0048; { vt_clsid    }
  varString   = $0100; { Pascal string; not OLE compatible }
  varAny      = $0101;
  varTypeMask = $0FFF;
  varArray    = $2000;
  varByRef    = $4000;

{ TVarRec.VType values }

  vtInteger    = 0;
  vtBoolean    = 1;
  vtChar       = 2;
  vtExtended   = 3;
  vtString     = 4;
  vtPointer    = 5;
  vtPChar      = 6;
  vtObject     = 7;
  vtClass      = 8;
  vtWideChar   = 9;
  vtPWideChar  = 10;
  vtAnsiString = 11;
  vtCurrency   = 12;
  vtVariant    = 13;
  vtInterface  = 14;
  vtWideString = 15;
  vtInt64      = 16;

{ Virtual method table entries }

  vmtSelfPtr           = -76;
  vmtIntfTable         = -72;
  vmtAutoTable         = -68;
  vmtInitTable         = -64;
  vmtTypeInfo          = -60;
  vmtFieldTable        = -56;
  vmtMethodTable       = -52;
  vmtDynamicTable      = -48;
  vmtClassName         = -44;
  vmtInstanceSize      = -40;
  vmtParent            = -36;
  vmtSafeCallException = -32;
  vmtAfterConstruction = -28;
  vmtBeforeDestruction = -24;
  vmtDispatch          = -20;
  vmtDefaultHandler    = -16;
  vmtNewInstance       = -12;
  vmtFreeInstance      = -8;
  vmtDestroy           = -4;

  vmtQueryInterface    = 0;
  vmtAddRef            = 4;
  vmtRelease           = 8;
  vmtCreateObject      = 12;

type

  TObject = class;

  TClass = class of TObject;

  {$EXTERNALSYM HRESULT}
  HRESULT = type Longint;  { from WTYPES.H }

{$EXTERNALSYM IUnknown}
{$EXTERNALSYM IDispatch}

  PGUID = ^TGUID;
  TGUID = packed record
    D1: LongWord;
    D2: Word;
    D3: Word;
    D4: array[0..7] of Byte;
  end;

  PInterfaceEntry = ^TInterfaceEntry;
  TInterfaceEntry = packed record
    IID: TGUID;
    VTable: Pointer;
    IOffset: Integer;
    ImplGetter: Integer;
  end;

  PInterfaceTable = ^TInterfaceTable;
  TInterfaceTable = packed record
    EntryCount: Integer;
    Entries: array[0..9999] of TInterfaceEntry;
  end;

  TObject = class
    constructor Create;
    procedure Free;
    class function InitInstance(Instance: Pointer): TObject;
    procedure CleanupInstance;
    function ClassType: TClass;
    class function ClassName: ShortString;
    class function ClassNameIs(const Name: string): Boolean;
    class function ClassParent: TClass;
    class function ClassInfo: Pointer;
    class function InstanceSize: Longint;
    class function InheritsFrom(AClass: TClass): Boolean;
    class function MethodAddress(const Name: ShortString): Pointer;
    class function MethodName(Address: Pointer): ShortString;
    function FieldAddress(const Name: ShortString): Pointer;
    function GetInterface(const IID: TGUID; out Obj): Boolean;
    class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
    class function GetInterfaceTable: PInterfaceTable;
    function SafeCallException(ExceptObject: TObject;
      ExceptAddr: Pointer): HResult; virtual;
    procedure AfterConstruction; virtual;
    procedure BeforeDestruction; virtual;
    procedure Dispatch(var Message); virtual;
    procedure DefaultHandler(var Message); virtual;
    class function NewInstance: TObject; virtual;
    procedure FreeInstance; virtual;
    destructor Destroy; virtual;
  end;

  IUnknown = interface
    ['{00000000-0000-0000-C000-000000000046}']
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

  IDispatch = interface(IUnknown)
    ['{00020400-0000-0000-C000-000000000046}']
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  end;

  TInterfacedObject = class(TObject, IUnknown)
  protected
    FRefCount: Integer;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
    property RefCount: Integer read FRefCount;
  end;

  TInterfacedClass = class of TInterfacedObject;

  TVarArrayBound = packed record
    ElementCount: Integer;
    LowBound: Integer;
  end;

  PVarArray = ^TVarArray;
  TVarArray = packed record
    DimCount: Word;
    Flags: Word;
    ElementSize: Integer;
    LockCount: Integer;
    Data: Pointer;
    Bounds: array[0..255] of TVarArrayBound;
  end;

  PVarData = ^TVarData;
  TVarData = packed record
    VType: Word;
    Reserved1, Reserved2, Reserved3: Word;
    case Integer of
      varSmallint: (VSmallint: Smallint);
      varInteger:  (VInteger: Integer);
      varSingle:   (VSingle: Single);
      varDouble:   (VDouble: Double);
      varCurrency: (VCurrency: Currency);
      varDate:     (VDate: Double);
      varOleStr:   (VOleStr: PWideChar);
      varDispatch: (VDispatch: Pointer);
      varError:    (VError: LongWord);
      varBoolean:  (VBoolean: WordBool);
      varUnknown:  (VUnknown: Pointer);
      varByte:     (VByte: Byte);
      varString:   (VString: Pointer);
      varAny:      (VAny: Pointer);
      varArray:    (VArray: PVarArray);
      varByRef:    (VPointer: Pointer);
  end;

  PShortString = ^ShortString;
  PAnsiString = ^AnsiString;
  PWideString = ^WideString;
  PString = PAnsiString;

  PExtended = ^Extended;
  PCurrency = ^Currency;
  PVariant = ^Variant;
  POleVariant = ^OleVariant;
  PInt64 = ^Int64;

  TDateTime = type Double;
  PDateTime = ^TDateTime;

  PVarRec = ^TVarRec;
  TVarRec = record { do not pack this record; it is compiler-generated }
    case Byte of
      vtInteger:    (VInteger: Integer; VType: Byte);
      vtBoolean:    (VBoolean: Boolean);
      vtChar:       (VChar: Char);
      vtExtended:   (VExtended: PExtended);
      vtString:     (VString: PShortString);
      vtPointer:    (VPointer: Pointer);
      vtPChar:      (VPChar: PChar);
      vtObject:     (VObject: TObject);
      vtClass:      (VClass: TClass);
      vtWideChar:   (VWideChar: WideChar);
      vtPWideChar:  (VPWideChar: PWideChar);
      vtAnsiString: (VAnsiString: Pointer);
      vtCurrency:   (VCurrency: PCurrency);
      vtVariant:    (VVariant: PVariant);
      vtInterface:  (VInterface: Pointer);
      vtWideString: (VWideString: Pointer);
      vtInt64:      (VInt64: PInt64);
  end;

  PMemoryManager = ^TMemoryManager;
  TMemoryManager = record
    GetMem: function(Size: Integer): Pointer;
    FreeMem: function(P: Pointer): Integer;
    ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  end;

  THeapStatus = record
    TotalAddrSpace: Cardinal;
    TotalUncommitted: Cardinal;
    TotalCommitted: Cardinal;
    TotalAllocated: Cardinal;
    TotalFree: Cardinal;
    FreeSmall: Cardinal;
    FreeBig: Cardinal;
    Unused: Cardinal;
    Overhead: Cardinal;
    HeapErrorCode: Cardinal;
  end;

  PackageUnitEntry = packed record
    Init, FInit : procedure;
  end;

  { Compiler generated table to be processed sequentially to init & finit all package units }
  { Init: 0..Max-1; Final: Last Initialized..0                                              }
  UnitEntryTable = array [0..9999999] of PackageUnitEntry;
  PUnitEntryTable = ^UnitEntryTable;

  PackageInfoTable = packed record
    UnitCount : Integer;      { number of entries in UnitInfo array; always > 0 }
    UnitInfo : PUnitEntryTable;
  end;

  PackageInfo = ^PackageInfoTable;

  { Each package exports a '@GetPackageInfoTable' which can be used to retrieve }
  { the table which contains compiler generated information about the package DLL }
  GetPackageInfoTable = function : PackageInfo;





const
  advapi32 = 'advapi32.dll';
  kernel = 'kernel32.dll';
  user = 'user32.dll';
  oleaut = 'oleaut32.dll';

{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid
               creating of separate import block from kernel32.dll : }
//////////////////////////////////////////////////////////////////////////

function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
  external kernel name 'FreeLibrary';

function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall;
  external kernel name 'GetModuleFileNameA';

function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
  external kernel name 'GetModuleHandleA';

function LocalAlloc(flags, size: Integer): Pointer; stdcall;
  external kernel name 'LocalAlloc';

function LocalFree(addr: Pointer): Pointer; stdcall;
  external kernel name 'LocalFree';

function TlsAlloc: Integer; stdcall;
  external kernel name 'TlsAlloc';

function TlsFree(TlsIndex: Integer): Boolean; stdcall;
  external kernel name 'TlsFree';

function TlsGetValue(TlsIndex: Integer): Pointer; stdcall;
  external kernel name 'TlsGetValue';

function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall;
  external kernel name 'TlsSetValue';

function GetCommandLine: PChar; stdcall;
  external kernel name 'GetCommandLineA';

{X-}//////////////////////////////////////////////////////////////////////



{X} // following two procedures are optional and exclusive.
{X} // call it to provide error message: first - for GUI app,
{X} // second - for console app.
{X} procedure UseErrorMessageBox;
{X} procedure UseErrorMessageWrite;

{X} // call following procedure to initialize Input and Output
{X} // - for console app only:
{X} procedure UseInputOutput;

{X} // if your app uses FPU, call one of following procedures:
{X} procedure FpuInit;
{X} procedure FpuInitConsiderNECWindows;
{X} // the second additionally takes into consideration NEC
{X} // Windows keyboard (Japaneeze keyboard ???).

{X} // following variables are converted to a functions:
{X} function CmdShow : Integer;
{X} function CmdLine : PChar;

{X} procedure VarCastError;
{X} procedure VarInvalidOp;

{X} procedure DummyProc; // empty procedure

{X} procedure VariantAddRef;
{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use
{X} var VarAddRefProc : procedure = DummyProc;

{X} procedure VariantClr;
{X} // procedure to refer to _VarClr if SysVarnt.pas is in use
{X} var VarClrProc : procedure = DummyProc;

{X} procedure WStrAddRef;
{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use
{X} var WStrAddRefProc : procedure = DummyProc;

{X} procedure WStrClr;
{X} // procedure to refer to _WStrClr if SysWStr.pas is in use
{X} var WStrClrProc : procedure = DummyProc;

{X} procedure WStrArrayClr;
{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use
{X} var WStrArrayClrProc : procedure = DummyProc;

{X} // By default, now system memory management routines are used
{X} // to allocate memory. This can be slow sometimes, so if You
{X} // want to use custom Borland Delphi memory manager, call follow:
{X} procedure UseDelphiMemoryManager;
{X} function IsDelphiMemoryManagerSet : Boolean;
{X} function MemoryManagerNotUsed : Boolean;

{X} // Standard Delphi units initialization/finalization uses
{X} // try-except and raise constructions, which leads to permanent
{X} // usage of all exception handling routines. In this XCL-aware
{X} // implementation, "light" version of initialization/finalization
{X} // is used by default. To use standard Delphi initialization and
{X} // finalization method, allowing to flow execution control even
{X} // in initalization sections, include reference to SysSfIni.pas
{X} // into uses clause *as first as possible*.
{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer );
{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer );
{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer )
{X}        = InitUnitsLight;
{X} procedure FInitUnitsLight;
{X} procedure FInitUnitsHard;
{X} var FInitUnitsProc : procedure = FInitUnitsLight;
{X} procedure SetExceptionHandler;
{X} procedure UnsetExceptionHandler;
{X} var UnsetExceptionHandlerProc : procedure = DummyProc;

{X} var UnloadResProc: procedure = DummyProc;





function RaiseList: Pointer;  { Stack of current exception objects }
function SetRaiseList(NewPtr: Pointer): Pointer;  { returns previous value }
procedure SetInOutRes(NewValue: Integer);

var

  ExceptProc: Pointer;    { Unhandled exception handler }
  ErrorProc: Pointer;     { Error handler procedure }
  ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
  ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
  ExceptionClass: TClass; { Exception base class (must be Exception) }
  SafeCallErrorProc: Pointer; { Safecall error handler }
  AssertErrorProc: Pointer; { Assertion error handler }
  AbstractErrorProc: Pointer; { Abstract method error handler }
  HPrevInst: LongWord;    { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32}
  MainInstance: LongWord; { Handle of the main(.EXE) HInstance }
  MainThreadID: LongWord; { ThreadID of thread that module was initialized in }
  IsLibrary: Boolean;     { True if module is a DLL }
{X  CmdShow: Integer;       { CmdShow parameter for CreateWindow - converted to a function X}
{X  CmdLine: PChar;         { Command line pointer               - converted to a function X}
  InitProc: Pointer;      { Last installed initialization procedure }
  ExitCode: Integer;      { Program result }
  ExitProc: Pointer;      { Last installed exit procedure }
  ErrorAddr: Pointer;     { Address of run-time error }
  RandSeed: Longint;      { Base for random number generator }
  IsConsole: Boolean;     { True if compiled as console app }
  IsMultiThread: Boolean; { True if more than one thread }
  FileMode: Byte {X} = 2; { Standard mode for opening files }
  Test8086: Byte {X} = 2; { Will always be 2 (386 or later) }
  Test8087: Byte {X} = 3; { Will always be 3 (387 or later) }
  TestFDIV: Shortint;     { -1: Flawed Pentium, 0: Not determined, 1: Ok }
  Input: Text;            { Standard input }
  Output: Text;           { Standard output }

  ClearAnyProc: Pointer;  { Handler clearing a varAny }
  ChangeAnyProc: Pointer; { Handler to change any to variant }
  RefAnyProc: Pointer;    { Handler to add a reference to an varAny }

var
  Default8087CW: Word = $1332;{ Default 8087 control word.  FPU control
                                register is set to this value.
                                CAUTION:  Setting this to an invalid value
                                          could cause unpredictable behavior. }

  HeapAllocFlags: Word = 2;   { Heap allocation flags, gmem_Moveable }
  DebugHook: Byte = 0;        { 1 to notify debugger of non-Delphi exceptions
                                >1 to notify debugger of exception unwinding }
  JITEnable: Byte = 0;        { 1 to call UnhandledExceptionFilter if the exception
                                  is not a Pascal exception.
                                >1 to call UnhandledExceptionFilter for all exceptions }
  NoErrMsg: Boolean = False;  { True causes the base RTL to not display the message box
                                when a run-time error occurs }

var
  (* {X-} moved to SysVarnt.pas

  Unassigned: Variant;    { Unassigned standard constant }
  Null: Variant;          { Null standard constant }
  EmptyParam: OleVariant; { "Empty parameter" standard constant which can be
                            passed as an optional parameter on a dual interface. }
  {X+} *)

  AllocMemCount: Integer; { Number of allocated memory blocks }
  AllocMemSize: Integer;  { Total size of allocated memory blocks }

{ Memory manager support }

procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TMemoryManager);
{X} // following function is replaced with pointer to one
{X} // (initialized by another)
{X} //function IsMemoryManagerSet: Boolean;
var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed;

function SysGetMem(Size: Integer): Pointer;
function SysFreeMem(P: Pointer): Integer;
function SysReallocMem(P: Pointer; Size: Integer): Pointer;

function GetHeapStatus: THeapStatus;

{ Thread support }
type
  TThreadFunc = function(Parameter: Pointer): Integer;

function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
  ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
  var ThreadId: LongWord): Integer;

procedure EndThread(ExitCode: Integer);

{ Standard procedures and functions }

procedure _ChDir(const S: string);
procedure __Flush(var F: Text);
procedure _LGetDir(D: Byte; var S: string);
procedure _SGetDir(D: Byte; var S: ShortString);
function IOResult: Integer;
procedure _MkDir(const S: string);
procedure Move(const Source; var Dest; Count: Integer);
function ParamCount: Integer;
function ParamStr(Index: Integer): string;
procedure Randomize;
procedure _RmDir(const S: string);
function UpCase(Ch: Char): Char;

{ Control 8087 control word }

procedure Set8087CW(NewCW: Word);

{ Wide character support procedures and functions }

function WideCharToString(Source: PWideChar): string;
function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  var Dest: string);
function StringToWideChar(const Source: string; Dest: PWideChar;
  DestSize: Integer): PWideChar;

{ OLE string support procedures and functions }

function OleStrToString(Source: PWideChar): string;
procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
function StringToOleStr(const Source: string): PWideChar;

{ Variant support procedures and functions }

procedure _VarClear(var V : Variant);
procedure _VarCopy(var Dest : Variant; const Source: Variant);
procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
function VarType(const V: Variant): Integer;
function VarAsType(const V: Variant; VarType: Integer): Variant;
function VarIsEmpty(const V: Variant): Boolean;
function VarIsNull(const V: Variant): Boolean;
function VarToStr(const V: Variant): string;
function VarFromDateTime(DateTime: TDateTime): Variant;
function VarToDateTime(const V: Variant): TDateTime;

{ Variant array support procedures and functions }

function VarArrayCreate(const Bounds: array of Integer;
  VarType: Integer): Variant;
function VarArrayOf(const Values: array of Variant): Variant;
procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
function VarArrayDimCount(const A: Variant): Integer;
function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
function VarArrayLock(const A: Variant): Pointer;
procedure VarArrayUnlock(const A: Variant);
function VarArrayRef(const A: Variant): Variant;
function VarIsArray(const A: Variant): Boolean;

{ Variant IDispatch call support }

procedure _DispInvokeError;

var
  VarDispProc: Pointer = @_DispInvokeError;
  DispCallByIDProc: Pointer = @_DispInvokeError;

{ Package/Module registration and unregistration }

type
  PLibModule = ^TLibModule;
  TLibModule = record
    Next: PLibModule;
    Instance: LongWord;
    CodeInstance: LongWord;
    DataInstance: LongWord;
    ResInstance: LongWord;
    Reserved: Integer;
  end;

  TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean;
  {$EXTERNALSYM TEnumModuleFunc}
  TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean;
  {$EXTERNALSYM TEnumModuleFuncLW}
  TModuleUnloadProc = procedure (HInstance: Integer);
  {$EXTERNALSYM TModuleUnloadProc}
  TModuleUnloadProcLW = procedure (HInstance: LongWord);
  {$EXTERNALSYM TModuleUnloadProcLW}

  PModuleUnloadRec = ^TModuleUnloadRec;
  TModuleUnloadRec = record
    Next: PModuleUnloadRec;
    Proc: TModuleUnloadProcLW;
  end;

var
  LibModuleList: PLibModule = nil;
  ModuleUnloadList: PModuleUnloadRec = nil;

procedure RegisterModule(LibModule: PLibModule);
{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure }
{X} procedure UnregisterModuleLight(LibModule: PLibModule);
{X} procedure UnregisterModuleSafely(LibModule: PLibModule);
var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight;
function FindHInstance(Address: Pointer): LongWord;
function FindClassHInstance(ClassType: TClass): LongWord;
function FindResourceHInstance(Instance: LongWord): LongWord;
function LoadResourceModule(ModuleName: PChar): LongWord;
procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload;
procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload;
procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;

{ ResString support function/record }

type
  PResStringRec = ^TResStringRec;
  TResStringRec = packed record
    Module: ^Longint;
    Identifier: Integer;
  end;

function LoadResString(ResStringRec: PResStringRec): string;

{ Procedures and functions that need compiler magic }

procedure _COS;
procedure _EXP;
procedure _INT;
procedure _SIN;
procedure _FRAC;
procedure _ROUND;
procedure _TRUNC;

procedure _AbstractError;
procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
procedure _Append;
procedure _Assign(var T: Text; S: ShortString);
procedure _BlockRead;
procedure _BlockWrite;
procedure _Close;
procedure _PStrCat;
procedure _PStrNCat;
procedure _PStrCpy;
procedure _PStrNCpy;
procedure _EofFile;
procedure _EofText;
procedure _Eoln;
procedure _Erase;
procedure _FilePos;
procedure _FileSize;
procedure _FillChar;
procedure _FreeMem;
procedure _GetMem;
procedure _ReallocMem;
procedure _Halt;
procedure _Halt0;
procedure _Mark;
procedure _PStrCmp;
procedure _AStrCmp;
procedure _RandInt;
procedure _RandExt;
procedure _ReadRec;
procedure _ReadChar;
procedure _ReadLong;
procedure _ReadString;
procedure _ReadCString;
procedure _ReadLString;
procedure _ReadExt;
procedure _ReadLn;
procedure _Rename;
procedure _Release;
procedure _ResetText(var T: Text);
procedure _ResetFile;
procedure _RewritText(var T: Text);
procedure _RewritFile;
procedure _RunError;
procedure _Run0Error;
procedure _Seek;
procedure _SeekEof;
procedure _SeekEoln;
procedure _SetTextBuf;
procedure _StrLong;
procedure _Str0Long;
procedure _Truncate;
procedure _ValLong;
procedure _WriteRec;
procedure _WriteChar;
procedure _Write0Char;
procedure _WriteBool;
procedure _Write0Bool;
procedure _WriteLong;
procedure _Write0Long;
procedure _WriteString;
procedure _Write0String;
procedure _WriteCString;
procedure _Write0CString;
procedure _WriteLString;
procedure _Write0LString;
function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
function _Write0Variant(var T: Text; const V: Variant): Pointer;
procedure _Write2Ext;
procedure _Write1Ext;
procedure _Write0Ext;
procedure _WriteLn;

procedure __CToPasStr;
procedure __CLenToPasStr;
procedure __ArrayToPasStr;
procedure __PasToCStr;

procedure __IOTest;
procedure _Flush(var F: Text);

procedure _SetElem;
procedure _SetRange;
procedure _SetEq;
procedure _SetLe;
procedure _SetIntersect;
procedure _SetIntersect3; { BEG only }
procedure _SetUnion;
procedure _SetUnion3; { BEG only }
procedure _SetSub;
procedure _SetSub3; { BEG only }
procedure _SetExpand;

procedure _Str2Ext;
procedure _Str0Ext;
procedure _Str1Ext;
procedure _ValExt;
procedure _Pow10;
procedure _Real2Ext;
procedure _Ext2Real;

procedure _ObjSetup;
procedure _ObjCopy;
procedure _Fail;
procedure _BoundErr;
procedure _IntOver;
procedure _StartExe;
procedure _StartLib;
procedure _PackageLoad  (const Table : PackageInfo);
procedure _PackageUnload(const Table : PackageInfo);
procedure _InitResStrings;
procedure _InitResStringImports;
procedure _InitImports;
procedure _InitWideStrings;

procedure _ClassCreate;
procedure _ClassDestroy;
procedure _AfterConstruction;
procedure _BeforeDestruction;
procedure _IsClass;
procedure _AsClass;

procedure _RaiseExcept;
procedure _RaiseAgain;
procedure _DoneExcept;
procedure _TryFinallyExit;

procedure _CallDynaInst;
procedure _CallDynaClass;
procedure _FindDynaInst;
procedure _FindDynaClass;

procedure _LStrClr(var S: AnsiString);
procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
function _LStrLen{str: AnsiString}: Longint;
procedure _LStrCat{var dest: AnsiString; source: AnsiString};
procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
procedure _LStrCmp{left: AnsiString; right: AnsiString};
procedure _LStrAddRef{str: AnsiString};
procedure _LStrToPChar{str: AnsiString): PChar};
procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
procedure _Delete{ var s : openstring; index, count : Integer };
procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
procedure _SetLength{var s: ShortString; newLength: Integer};
procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};

procedure UniqueString(var str: string);
procedure _NewAnsiString{length: Longint};      { for debugger purposes only }

procedure _LStrCopy  { const s : AnsiString; index, count : Integer) : AnsiString};
procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };

procedure _WStrClr(var S: WideString);
procedure _WStrArrayClr(var StrArray; Count: Integer);
procedure _WStrAsg(var Dest: WideString; const Source: WideString);
procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
function _WStrToPWChar(const S: WideString): PWideChar;
function _WStrLen(const S: WideString): Integer;
procedure _WStrCat(var Dest: WideString; const Source: WideString);
procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
procedure _WStrCatN{var dest:WideString; argCnt: Integer; ...};
procedure _WStrCmp{left: WideString; right: WideString};
function _NewWideString(Length: Integer): PWideChar;
function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
procedure _WStrDelete(var S: WideString; Index, Count: Integer);
procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
procedure _WStrSetLength(var S: WideString; NewLength: Integer);
function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
procedure _WStrAddRef{var str: WideString};

procedure _Initialize;
procedure _InitializeArray;
procedure _InitializeRecord;
procedure _Finalize;
procedure _FinalizeArray;
procedure _FinalizeRecord;
procedure _AddRef;
procedure _AddRefArray;
procedure _AddRefRecord;
procedure _CopyArray;
procedure _CopyRecord;
procedure _CopyObject;

procedure _New;
procedure _Dispose;

procedure _DispInvoke; cdecl;
procedure _IntfDispCall; cdecl;
procedure _IntfVarCall; cdecl;

procedure _VarToInt;
procedure _VarToBool;
procedure _VarToReal;
procedure _VarToCurr;
procedure _VarToPStr(var S; const V: Variant);
procedure _VarToLStr(var S: string; const V: Variant);
procedure _VarToWStr(var S: WideString; const V: Variant);
procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);

procedure _VarFromInt;
procedure _VarFromBool;
procedure _VarFromReal;
procedure _VarFromTDateTime;
procedure _VarFromCurr;
procedure _VarFromPStr(var V: Variant; const Value: ShortString);
procedure _VarFromLStr(var V: Variant; const Value: string);
procedure _VarFromWStr(var V: Variant; const Value: WideString);
procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);

procedure _VarAdd;
procedure _VarSub;
procedure _VarMul;
procedure _VarDiv;
procedure _VarMod;
procedure _VarAnd;
procedure _VarOr;
procedure _VarXor;
procedure _VarShl;
procedure _VarShr;
procedure _VarRDiv;
procedure _VarCmp;

procedure _VarNeg;
procedure _VarNot;

procedure _VarCopyNoInd;
procedure _VarClr;
procedure _VarAddRef;

{ 64-bit Integer helper routines }

procedure __llmul;
procedure __lldiv;
procedure __lludiv;
procedure __llmod;
procedure __llmulo;
procedure __lldivo;
procedure __llmodo;
procedure __llumod;
procedure __llshl;
procedure __llushr;
procedure _WriteInt64;
procedure _Write0Int64;
procedure _ReadInt64;
function _StrInt64(val: Int64; width: Integer): ShortString;
function _Str0Int64(val: Int64): ShortString;
function _ValInt64(const s: AnsiString; var code: Integer): Int64;

{ Dynamic array helper functions }

procedure _DynArrayHigh;
procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer);
procedure _DynArrayLength;
procedure _DynArraySetLength;
procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
procedure _DynArrayAsg;
procedure _DynArrayAddRef;
procedure  DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
procedure  DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);

procedure _IntfClear(var Dest: IUnknown);
procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
procedure _IntfAddRef(const Dest: IUnknown);

function _VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
procedure _VarArrayPut(var A: Variant; const Value: Variant;
  IndexCount: Integer; Indices: Integer); cdecl;

procedure _HandleAnyException;
procedure _HandleOnException;
procedure _HandleFinally;
procedure _HandleAutoException;

procedure _FSafeDivide;
procedure _FSafeDivideR;

procedure _CheckAutoResult;

procedure FPower10;

procedure TextStart;

function  CompToDouble(acomp: Comp): Double; cdecl;
procedure DoubleToComp(adouble: Double; var result: Comp); cdecl;
function  CompToCurrency(acomp: Comp): Currency; cdecl;
procedure CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;

function GetMemory(Size: Integer): Pointer; cdecl;
function FreeMemory(P: Pointer): Integer; cdecl;
function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;

(* =================================================================== *)

implementation

uses
  SysInit;

{ Internal runtime error codes }

const
  reOutOfMemory       = 1;
  reInvalidPtr        = 2;
  reDivByZero         = 3;
  reRangeError        = 4;
  reIntOverflow       = 5;
  reInvalidOp         = 6;
  reZeroDivide        = 7;
  reOverflow          = 8;
  reUnderflow         = 9;
  reInvalidCast       = 10;
  reAccessViolation   = 11;
  reStackOverflow     = 12;
  reControlBreak      = 13;
  rePrivInstruction   = 14;
  reVarTypeCast       = 15;
  reVarInvalidOp      = 16;
  reVarDispatch       = 17;
  reVarArrayCreate    = 18;
  reVarNotArray       = 19;
  reVarArrayBounds    = 20;
  reAssertionFailed   = 21;
  reExternalException = 22;     { not used here; in SysUtils }
  reIntfCastError     = 23;
  reSafeCallError     = 24;

{ this procedure should be at the very beginning of the }
{ text segment. it is only used by _RunError to find    }
{ start address of the text segment so a nice error     }
{ location can be shown.                                                                }

procedure TextStart;
begin
end;

{ ----------------------------------------------------- }
{       NT Calls necessary for the .asm files           }
{ ----------------------------------------------------- }

type
  PMemInfo = ^TMemInfo;
  TMemInfo = packed record
    BaseAddress: Pointer;
    AllocationBase: Pointer;
    AllocationProtect: Longint;
    RegionSize: Longint;
    State: Longint;
    Protect: Longint;
    Type_9 : Longint;
  end;

  PStartupInfo = ^TStartupInfo;
  TStartupInfo = record
    cb: Longint;
    lpReserved: Pointer;
    lpDesktop: Pointer;
    lpTitle: Pointer;
    dwX: Longint;
    dwY: Longint;
    dwXSize: Longint;
    dwYSize: Longint;
    dwXCountChars: Longint;
    dwYCountChars: Longint;
    dwFillAttribute: Longint;
    dwFlags: Longint;
    wShowWindow: Word;
    cbReserved2: Word;
    lpReserved2: ^Byte;
    hStdInput: Integer;
    hStdOutput: Integer;
    hStdError: Integer;
  end;

  TWin32FindData = packed record
    dwFileAttributes: Integer;
    ftCreationTime: Int64;
    ftLastAccessTime: Int64;
    ftLastWriteTime: Int64;
    nFileSizeHigh: Integer;
    nFileSizeLow: Integer;
    dwReserved0: Integer;
    dwReserved1: Integer;
    cFileName: array[0..259] of Char;
    cAlternateFileName: array[0..13] of Char;
  end;




procedure CloseHandle;                  external kernel name 'CloseHandle';
procedure CreateFileA;                  external kernel name 'CreateFileA';
procedure DeleteFileA;                  external kernel name 'DeleteFileA';
procedure GetFileType;                  external kernel name 'GetFileType';
procedure GetSystemTime;                external kernel name 'GetSystemTime';
procedure GetFileSize;                  external kernel name 'GetFileSize';
procedure GetStdHandle;                 external kernel name 'GetStdHandle';
//procedure GetStartupInfo;               external kernel name 'GetStartupInfo';
procedure MoveFileA;                    external kernel name 'MoveFileA';
procedure RaiseException;               external kernel name 'RaiseException';
procedure ReadFile;                     external kernel name 'ReadFile';
procedure RtlUnwind;                    external kernel name 'RtlUnwind';
procedure SetEndOfFile;                 external kernel name 'SetEndOfFile';
procedure SetFilePointer;               external kernel name 'SetFilePointer';
procedure UnhandledExceptionFilter;     external kernel name 'UnhandledExceptionFilter';
procedure WriteFile;                    external kernel name 'WriteFile';

function CharNext(lpsz: PChar): PChar; stdcall;
  external user name 'CharNextA';

function CreateThread(SecurityAttributes: Pointer; StackSize: LongWord;
                     ThreadFunc: TThreadFunc; Parameter: Pointer;
                     CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;
  external kernel name 'CreateThread';

procedure ExitThread(ExitCode: Integer); stdcall;
  external kernel name 'ExitThread';

procedure ExitProcess(ExitCode: Integer); stdcall;
  external kernel name 'ExitProcess';

procedure MessageBox(Wnd: Integer; Text: PChar; Caption: PChar; Typ: Integer); stdcall;
  external user   name 'MessageBoxA';

function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall;
  external kernel name 'CreateDirectoryA';

function FindClose(FindFile: Integer): LongBool; stdcall;
  external kernel name 'FindClose';

function FindFirstFile(FileName: PChar; var FindFileData: TWIN32FindData): Integer; stdcall;
  external kernel name 'FindFirstFileA';

{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
{X} //  external kernel name 'FreeLibrary';

{X} //function GetCommandLine: PChar; stdcall;
{X} //  external kernel name 'GetCommandLineA';

function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall;
  external kernel name 'GetCurrentDirectoryA';

function GetLastError: Integer; stdcall;
  external kernel name 'GetLastError';

function GetLocaleInfo(Locale: Longint; LCType: Longint; lpLCData: PChar; cchData: Integer): Integer; stdcall;
  external kernel name 'GetLocaleInfoA';

{X} //function GetModuleFileName(Module: Integer; Filename: PChar;
{X} //  Size: Integer): Integer; stdcall;
{X} //  external kernel name 'GetModuleFileNameA';

{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
{X} //  external kernel name 'GetModuleHandleA';

function GetProcAddress(Module: Integer; ProcName: PChar): Pointer; stdcall;
  external kernel name 'GetProcAddress';

procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall;
  external kernel name 'GetStartupInfoA';

function GetThreadLocale: Longint; stdcall;
  external kernel name 'GetThreadLocale';

function LoadLibraryEx(LibName: PChar; hFile: Longint; Flags: Longint): Longint; stdcall;
  external kernel name 'LoadLibraryExA';

function LoadString(Instance: Longint; IDent: Integer; Buffer: PChar;
  Size: Integer): Integer; stdcall;
  external user name 'LoadStringA';

{function lstrcat(lpString1, lpString2: PChar): PChar; stdcall;
  external kernel name 'lstrcatA';}

function lstrcpy(lpString1, lpString2: PChar): PChar; stdcall;
  external kernel name 'lstrcpyA';

function lstrcpyn(lpString1, lpString2: PChar;
  iMaxLength: Integer): PChar; stdcall;
  external kernel name 'lstrcpynA';

function lstrlen(lpString: PChar): Integer; stdcall;
  external kernel name 'lstrlenA';

function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar;
  MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall;
  external kernel name 'MultiByteToWideChar';

function RegCloseKey(hKey: Integer): Longint; stdcall;
  external advapi32 name 'RegCloseKey';

function RegOpenKeyEx(hKey: LongWord; lpSubKey: PChar; ulOptions,
  samDesired: LongWord; var phkResult: LongWord): Longint; stdcall;
  external advapi32 name 'RegOpenKeyExA';

function RegQueryValueEx(hKey: LongWord; lpValueName: PChar;
  lpReserved: Pointer; lpType: Pointer; lpData: PChar; lpcbData: Pointer): Integer; stdcall;
  external advapi32 name 'RegQueryValueExA';

function RemoveDirectory(PathName: PChar): WordBool; stdcall;
  external kernel name 'RemoveDirectoryA';

function SetCurrentDirectory(PathName: PChar): WordBool; stdcall;
  external kernel name 'SetCurrentDirectoryA';

function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar;
  WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar;
  UsedDefaultChar: Pointer): Integer; stdcall;
  external kernel name 'WideCharToMultiByte';

function VirtualQuery(lpAddress: Pointer;
  var lpBuffer: TMemInfo; dwLength: Longint): Longint; stdcall;
  external kernel name 'VirtualQuery';

//function SysAllocString(P: PWideChar): PWideChar; stdcall;
//  external oleaut name 'SysAllocString';

function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall;
  external oleaut name 'SysAllocStringLen';

function SysReAllocStringLen(var S: WideString; P: PWideChar;
  Len: Integer): LongBool; stdcall;
  external oleaut name 'SysReAllocStringLen';

procedure SysFreeString(const S: WideString); stdcall;
  external oleaut name 'SysFreeString';

function SysStringLen(const S: WideString): Integer; stdcall;
  external oleaut name 'SysStringLen';

//procedure VariantInit(var V: Variant); stdcall;
//  external oleaut name 'VariantInit';

function VariantClear(var V: Variant): Integer; stdcall;
  external oleaut name 'VariantClear';

function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall;
  external oleaut name 'VariantCopy';

function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall;
  external oleaut name 'VariantCopyInd';

//function VariantChangeType(var Dest: Variant; const Source: Variant;
//  Flags: Word; VarType: Word): Integer; stdcall;
//  external oleaut name 'VariantChangeType';

function VariantChangeTypeEx(var Dest: Variant; const Source: Variant;
  LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall;
  external oleaut name 'VariantChangeTypeEx';

function SafeArrayCreate(VarType, DimCount: Integer;
  const Bounds): PVarArray; stdcall;
  external oleaut name 'SafeArrayCreate';

function SafeArrayRedim(VarArray: PVarArray;
  var NewBound: TVarArrayBound): Integer; stdcall;
  external oleaut name 'SafeArrayRedim';

function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
  var LBound: Integer): Integer; stdcall;
  external oleaut name 'SafeArrayGetLBound';

function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
  var UBound: Integer): Integer; stdcall;
  external oleaut name 'SafeArrayGetUBound';

function SafeArrayAccessData(VarArray: PVarArray;
  var Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayAccessData';

function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall;
  external oleaut name 'SafeArrayUnaccessData';

function SafeArrayGetElement(VarArray: PVarArray; Indices,
  Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayGetElement';

function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer;
  var pvData: Pointer): HResult; stdcall;
  external oleaut name 'SafeArrayPtrOfIndex';

function SafeArrayPutElement(VarArray: PVarArray; Indices,
  Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayPutElement';

function InterlockedIncrement(var Addend: Integer): Integer; stdcall;
  external kernel name 'InterlockedIncrement';

function InterlockedDecrement(var Addend: Integer): Integer; stdcall;
  external kernel name 'InterlockedDecrement';

var SaveCmdShow : Integer = -1;
function CmdShow: Integer;
var
  SI: TStartupInfo;
begin
  if SaveCmdShow < 0 then
  begin
    SaveCmdShow := 10;                  { SW_SHOWDEFAULT }
    GetStartupInfo(SI);
    if SI.dwFlags and 1 <> 0 then  { STARTF_USESHOWWINDOW }
      SaveCmdShow := SI.wShowWindow;
  end;
  Result := SaveCmdShow;
end;

{ ----------------------------------------------------- }
{       Memory manager                                                                          }
{ ----------------------------------------------------- }

procedure Error(errorCode: Byte); forward;

{$I GETMEM.INC }

{X- by default, system memory allocation routines (API calls)
    are used. To use Inprise's memory manager (Delphi standard)
    call UseDelphiMemoryManager procedure. }
var
  MemoryManager: TMemoryManager = (
    GetMem: DfltGetMem;
    FreeMem: DfltFreeMem;
    ReallocMem: DfltReallocMem);

const
  DelphiMemoryManager: TMemoryManager = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem);

procedure UseDelphiMemoryManager;
begin
  IsMemoryManagerSet := IsDelphiMemoryManagerSet; 
  SetMemoryManager( DelphiMemoryManager );
end;
{X+}

procedure _GetMem;
asm
        TEST    EAX,EAX
        JE      @@1
        CALL    MemoryManager.GetMem
        OR      EAX,EAX
        JE      @@2
@@1:    RET
@@2:    MOV     AL,reOutOfMemory
        JMP     Error
end;

procedure _FreeMem;
asm
        TEST    EAX,EAX
        JE      @@1
        CALL    MemoryManager.FreeMem
        OR      EAX,EAX
        JNE     @@2
@@1:    RET
@@2:    MOV     AL,reInvalidPtr
        JMP     Error
end;

procedure _ReallocMem;
asm
        MOV     ECX,[EAX]
        TEST    ECX,ECX
        JE      @@alloc
        TEST    EDX,EDX
        JE      @@free
@@resize:
        PUSH    EAX
        MOV     EAX,ECX
        CALL    MemoryManager.ReallocMem
        POP     ECX
        OR      EAX,EAX
        JE      @@allocError
        MOV     [ECX],EAX
        RET
@@freeError:
        MOV     AL,reInvalidPtr
        JMP     Error
@@free:
        MOV     [EAX],EDX
        MOV     EAX,ECX
        CALL    MemoryManager.FreeMem
        OR      EAX,EAX
        JNE     @@freeError
        RET
@@allocError:
        MOV     AL,reOutOfMemory
        JMP     Error
@@alloc:
        TEST    EDX,EDX
        JE      @@exit
        PUSH    EAX
        MOV     EAX,EDX
        CALL    MemoryManager.GetMem
        POP     ECX
        OR      EAX,EAX
        JE      @@allocError
        MOV     [ECX],EAX
@@exit:
end;

procedure GetMemoryManager(var MemMgr: TMemoryManager);
begin
  MemMgr := MemoryManager;
end;

procedure SetMemoryManager(const MemMgr: TMemoryManager);
begin
  MemoryManager := MemMgr;
end;

//{X} - function is replaced with pointer to one.
//  function IsMemoryManagerSet: Boolean;
function IsDelphiMemoryManagerSet;
begin
  with MemoryManager do
    Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
      (@ReallocMem <> @SysReallocMem);
end;

{X+ always returns False. Initial handler for IsMemoryManagerSet }
function MemoryManagerNotUsed : Boolean;
begin
  Result := False;
end;
{X-}

threadvar
  RaiseListPtr: pointer;
  InOutRes: Integer;

function RaiseList: Pointer;
asm
        CALL    SysInit.@GetTLS
        MOV     EAX, [EAX].RaiseListPtr
end;

function SetRaiseList(NewPtr: Pointer): Pointer;
asm
        MOV     ECX, EAX
        CALL    SysInit.@GetTLS
        MOV     EDX, [EAX].RaiseListPtr
        MOV     [EAX].RaiseListPtr, ECX
        MOV     EAX, EDX
end;

{ ----------------------------------------------------- }
{    local functions & procedures of the system unit    }
{ ----------------------------------------------------- }

procedure Error(errorCode: Byte);
asm
        AND     EAX,127
        MOV     ECX,ErrorProc
        TEST    ECX,ECX
        JE      @@term
        POP     EDX
        CALL    ECX
@@term:
        DEC     EAX
        MOV     AL,byte ptr @@errorTable[EAX]
        JNS     @@skip
        CALL    SysInit.@GetTLS
        MOV     EAX,[EAX].InOutRes
@@skip:
        JMP     _RunError

@@errorTable:
        DB      203     { reOutOfMemory }
        DB      204     { reInvalidPtr }
        DB      200     { reDivByZero }
        DB      201     { reRangeError }
{               210       abstract error }
        DB      215     { reIntOverflow }
        DB      207     { reInvalidOp }
        DB      200     { reZeroDivide }
        DB      205     { reOverflow }
        DB      206     { reUnderflow }
        DB      219     { reInvalidCast }
        DB      216     { Access violation }
        DB      202     { Stack overflow }
        DB      217     { Control-C }
        DB      218     { Privileged instruction }
        DB      220     { Invalid variant type cast }
        DB      221     { Invalid variant operation }
        DB      222     { No variant method call dispatcher }
        DB      223     { Cannot create variant array }
        DB      224     { Variant does not contain an array }
        DB      225     { Variant array bounds error }
{               226       thread init failure }
        DB      227     { reAssertionFailed }
        DB      0       { reExternalException not used here; in SysUtils }
        DB      228     { reIntfCastError }
        DB      229     { reSafeCallError }
end;

procedure       __IOTest;
asm
        PUSH    EAX
        PUSH    EDX
        PUSH    ECX
        CALL    SysInit.@GetTLS
        CMP     [EAX].InOutRes,0
        POP     ECX
        POP     EDX
        POP     EAX
        JNE     @error
        RET
@error:
        XOR     EAX,EAX
        JMP     Error
end;

procedure SetInOutRes;
asm
        PUSH    EAX
        CALL    SysInit.@GetTLS
        POP     [EAX].InOutRes
end;


procedure InOutError;
asm
        CALL    GetLastError
        JMP     SetInOutRes
end;

procedure _ChDir(const S: string);
begin
  if not SetCurrentDirectory(PChar(S)) then InOutError;
end;

procedure       _Copy{ s : ShortString; index, count : Integer ) : ShortString};
asm
{     ->EAX     Source string                   }
{       EDX     index                           }
{       ECX     count                           }
{       [ESP+4] Pointer to result string        }

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,[ESP+8+4]

        XOR     EAX,EAX
        OR      AL,[ESI]
        JZ      @@srcEmpty

{       limit index to satisfy 1 <= index <= Length(src) }

        TEST    EDX,EDX
        JLE     @@smallInx
        CMP     EDX,EAX
        JG      @@bigInx
@@cont1:

{       limit count to satisfy 0 <= count <= Length(src) - index + 1    }

        SUB     EAX,EDX { calculate Length(src) - index + 1     }
        INC     EAX
        TEST    ECX,ECX
        JL      @@smallCount
        CMP     ECX,EAX
        JG      @@bigCount
@@cont2:

        ADD     ESI,EDX

        MOV     [EDI],CL
        INC     EDI
        REP     MOVSB
        JMP     @@exit

@@smallInx:
        MOV     EDX,1
        JMP     @@cont1
@@bigInx:
{       MOV     EDX,EAX
        JMP     @@cont1 }
@@smallCount:
        XOR     ECX,ECX
        JMP     @@cont2
@@bigCount:
        MOV     ECX,EAX
        JMP     @@cont2
@@srcEmpty:
        MOV     [EDI],AL
@@exit:
        POP     EDI
        POP     ESI
    RET 4
end;

procedure       _Delete{ var s : openstring; index, count : Integer };
asm
{     ->EAX     Pointer to s    }
{       EDX     index           }
{       ECX     count           }

        PUSH    ESI
        PUSH    EDI

        MOV     EDI,EAX

        XOR     EAX,EAX
        MOV     AL,[EDI]

{       if index not in [1 .. Length(s)] do nothing     }

        TEST    EDX,EDX
        JLE     @@exit
        CMP     EDX,EAX
        JG      @@exit

{       limit count to [0 .. Length(s) - index + 1]     }

        TEST    ECX,ECX
        JLE     @@exit
        SUB     EAX,EDX         { calculate Length(s) - index + 1       }
        INC     EAX
        CMP     ECX,EAX
        JLE     @@1
        MOV     ECX,EAX
@@1:
        SUB     [EDI],CL        { reduce Length(s) by count                     }
        ADD     EDI,EDX         { point EDI to first char to be deleted }
        LEA     ESI,[EDI+ECX]   { point ESI to first char to be preserved       }
        SUB     EAX,ECX         { #chars = Length(s) - index + 1 - count        }
        MOV     ECX,EAX

        REP     MOVSB

@@exit:
        POP     EDI
        POP     ESI
end;

procedure       __Flush( var f : Text );
external;       {   Assign  }

procedure       _Flush( var f : Text );
external;       {   Assign  }

procedure _LGetDir(D: Byte; var S: string);
var
  Drive: array[0..3] of Char;
  DirBuf, SaveBuf: array[0..259] of Char;
begin
  if D <> 0 then
  begin
        Drive[0] := Chr(D + Ord('A') - 1);
        Drive[1] := ':';
        Drive[2] := #0;
        GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf);
        SetCurrentDirectory(Drive);
  end;
  GetCurrentDirectory(SizeOf(DirBuf), DirBuf);
  if D <> 0 then SetCurrentDirectory(SaveBuf);
  S := DirBuf;
end;

procedure _SGetDir(D: Byte; var S: ShortString);
var
  L: string;
begin
  GetDir(D, L);
  S := L;
end;

procedure       _Insert{ source : ShortString; var s : openstring; index : Integer };
asm
{     ->EAX     Pointer to source string        }
{       EDX     Pointer to destination string   }
{       ECX     Length of destination string    }
{       [ESP+4] Index                   }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    ECX
        MOV     ECX,[ESP+16+4]
        SUB     ESP,512         { VAR buf: ARRAY [0..511] of Char       }

        MOV     EBX,EDX         { save pointer to s for later   }
        MOV     ESI,EDX

        XOR     EDX,EDX
        MOV     DL,[ESI]
        INC     ESI

{       limit index to [1 .. Length(s)+1]       }

        INC     EDX
        TEST    ECX,ECX
        JLE     @@smallInx
        CMP     ECX,EDX
        JG      @@bigInx
@@cont1:
        DEC     EDX     { EDX = Length(s)               }
                        { EAX = Pointer to src  }
                        { ESI = EBX = Pointer to s      }
                        { ECX = Index           }

{       copy index-1 chars from s to buf        }

        MOV     EDI,ESP
        DEC     ECX
        SUB     EDX,ECX { EDX = remaining length of s   }
        REP     MOVSB

{       copy Length(src) chars from src to buf  }

        XCHG    EAX,ESI { save pointer into s, point ESI to src         }
        MOV     CL,[ESI]        { ECX = Length(src) (ECX was zero after rep)    }
        INC     ESI
        REP     MOVSB

{       copy remaining chars of s to buf        }

        MOV     ESI,EAX { restore pointer into s                }
        MOV     ECX,EDX { copy remaining bytes of s             }
        REP     MOVSB

{       calculate total chars in buf    }

        SUB     EDI,ESP         { length = bufPtr - buf         }
        MOV     ECX,[ESP+512]   { ECX = Min(length, destLength) }
{       MOV     ECX,[EBP-16]   }{ ECX = Min(length, destLength) }
        CMP     ECX,EDI
        JB      @@1
        MOV     ECX,EDI
@@1:
        MOV     EDI,EBX         { Point EDI to s                }
        MOV     ESI,ESP         { Point ESI to buf              }
        MOV     [EDI],CL        { Store length in s             }
        INC     EDI
        REP     MOVSB           { Copy length chars to s        }
        JMP     @@exit

@@smallInx:
        MOV     ECX,1
        JMP     @@cont1
@@bigInx:
        MOV     ECX,EDX
        JMP     @@cont1

@@exit:
        ADD     ESP,512+4
        POP     EDI
        POP     ESI
        POP     EBX
    RET 4
end;

function IOResult: Integer;
asm
        CALL    SysInit.@GetTLS
        XOR     EDX,EDX
        MOV     ECX,[EAX].InOutRes
        MOV     [EAX].InOutRes,EDX
        MOV     EAX,ECX
end;

procedure _MkDir(const S: string);
begin
  if not CreateDirectory(PChar(S), 0) then InOutError;
end;

procedure       Move( const Source; var Dest; count : Integer );
asm
{     ->EAX     Pointer to source       }
{       EDX     Pointer to destination  }
{       ECX     Count                   }

(*{X-} // original code.

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        MOV     EAX,ECX

        CMP     EDI,ESI
        JA      @@down
        JE      @@exit

        SAR     ECX,2           { copy count DIV 4 dwords       }
        JS      @@exit

        REP     MOVSD

        MOV     ECX,EAX
        AND     ECX,03H
        REP     MOVSB           { copy count MOD 4 bytes        }
        JMP     @@exit

@@down:
        LEA     ESI,[ESI+ECX-4] { point ESI to last dword of source     }
        LEA     EDI,[EDI+ECX-4] { point EDI to last dword of dest       }

        SAR     ECX,2           { copy count DIV 4 dwords       }
        JS      @@exit
        STD
        REP     MOVSD

        MOV     ECX,EAX
        AND     ECX,03H         { copy count MOD 4 bytes        }
        ADD     ESI,4-1         { point to last byte of rest    }
        ADD     EDI,4-1
        REP     MOVSB
        CLD
@@exit:
        POP     EDI
        POP     ESI
*){X+}
//---------------------------------------
(* {X+} // Let us write smaller:
        JCXZ    @@fin

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        MOV     EAX,ECX

        AND     ECX,3           { copy count mod 4 dwords       }

        CMP     EDI,ESI
        JE      @@exit
        JA      @@up

//down:
        LEA     ESI,[ESI+EAX-1] { point ESI to last byte of source     }
        LEA     EDI,[EDI+EAX-1] { point EDI to last byte of dest       }
        STD

        CMP     EAX, 4
        JL      @@up
        ADD     ECX, 3          { move 3 bytes more to correct pos }

@@up:
        REP     MOVSB

        SAR     EAX, 2
        JS      @@exit

        MOV     ECX, EAX
        REP     MOVSD

@@exit:
        CLD
        POP     EDI
        POP     ESI

@@fin:
*) {X-}
//---------------------------------------
{X+} // And now, let us write speedy:
        CMP      ECX, 4
        JGE      @@long
        JCXZ     @@fin

        CMP      EAX, EDX
        JE       @@fin

        PUSH     ESI
        PUSH     EDI
        MOV      ESI, EAX
        MOV      EDI, EDX
        JA       @@short_up

        LEA     ESI,[ESI+ECX-1] { point ESI to last byte of source     }
        LEA     EDI,[EDI+ECX-1] { point EDI to last byte of dest       }
        STD

@@short_up:
        REP     MOVSB
        JMP     @@exit_up

@@long:
        CMP     EAX, EDX
        JE      @@fin

        PUSH    ESI
        PUSH    EDI
        MOV     ESI, EAX
        MOV     EDI, EDX
        MOV     EAX, ECX

        JA      @@long_up

        {
        SAR     ECX, 2
        JS      @@exit

        LEA     ESI,[ESI+EAX-4]
        LEA     EDI,[EDI+EAX-4]
        STD
        REP     MOVSD

        MOV     ECX, EAX
        MOV     EAX, 3
        AND     ECX, EAX
        ADD     ESI, EAX
        ADD     EDI, EAX
        REP     MOVSB
        } // let's do it in other order - faster if data are aligned...

        AND     ECX, 3
        LEA     ESI,[ESI+EAX-1]
        LEA     EDI,[EDI+EAX-1]
        STD
        REP     MOVSB

        SAR     EAX, 2
        //JS    @@exit         // why to test this? but what does PC do?
        MOV     ECX, EAX
        MOV     EAX, 3
        SUB     ESI, EAX
        SUB     EDI, EAX
        REP     MOVSD

@@exit_up:
        CLD
        //JMP     @@exit
        DEC     ECX     // the same - loosing 2 tacts... but conveyer!

@@long_up:
        SAR     ECX, 2
        JS      @@exit

        REP     MOVSD

        AND     EAX, 3
        MOV     ECX, EAX
        REP     MOVSB

@@exit:
        POP     EDI
        POP     ESI

@@fin:
{X-}
end;

function GetParamStr(P: PChar; var Param: string): PChar;
var
  Len: Integer;
  Buffer: array[0..4095] of Char;
begin
  while True do
  begin
    while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
    if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  end;
  Len := 0;
  while (P[0] > ' ') and (Len < SizeOf(Buffer)) do
    if P[0] = '"' then
    begin
      Inc(P);
      while (P[0] <> #0) and (P[0] <> '"') do
      begin
        Buffer[Len] := P[0];
        Inc(Len);
        Inc(P);
      end;
      if P[0] <> #0 then Inc(P);
    end else
    begin
      Buffer[Len] := P[0];
      Inc(Len);
      Inc(P);
    end;
  SetString(Param, Buffer, Len);
  Result := P;
end;

function ParamCount: Integer;
var
  P: PChar;
  S: string;
begin
  P := GetParamStr(GetCommandLine, S);
  Result := 0;
  while True do
  begin
    P := GetParamStr(P, S);
    if S = '' then Break;
    Inc(Result);
  end;
end;

function ParamStr(Index: Integer): string;
var
  P: PChar;
  Buffer: array[0..260] of Char;
begin
  if Index = 0 then
    SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer)))
  else
  begin
    P := GetCommandLine;
    while True do
    begin
      P := GetParamStr(P, Result);
      if (Index = 0) or (Result = '') then Break;
      Dec(Index);
    end;
  end;
end;

procedure       _Pos{ substr : ShortString; s : ShortString ) : Integer};
asm
{     ->EAX     Pointer to substr               }
{       EDX     Pointer to string               }
{     <-EAX     Position of substr in s or 0    }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX { Point ESI to substr           }
        MOV     EDI,EDX { Point EDI to s                }

        XOR     ECX,ECX { ECX = Length(s)               }
        MOV     CL,[EDI]
        INC     EDI             { Point EDI to first char of s  }

        PUSH    EDI             { remember s position to calculate index        }

        XOR     EDX,EDX { EDX = Length(substr)          }
        MOV     DL,[ESI]
        INC     ESI             { Point ESI to first char of substr     }

        DEC     EDX             { EDX = Length(substr) - 1              }
        JS      @@fail  { < 0 ? return 0                        }
        MOV     AL,[ESI]        { AL = first char of substr             }
        INC     ESI             { Point ESI to 2'nd char of substr      }

        SUB     ECX,EDX { #positions in s to look at    }
                        { = Length(s) - Length(substr) + 1      }
        JLE     @@fail
@@loop:
        REPNE   SCASB
        JNE     @@fail
        MOV     EBX,ECX { save outer loop counter               }
        PUSH    ESI             { save outer loop substr pointer        }
        PUSH    EDI             { save outer loop s pointer             }

        MOV     ECX,EDX
        REPE    CMPSB
        POP     EDI             { restore outer loop s pointer  }
        POP     ESI             { restore outer loop substr pointer     }
        JE      @@found
        MOV     ECX,EBX { restore outer loop counter    }
        JMP     @@loop

@@fail:
        POP     EDX             { get rid of saved s pointer    }
        XOR     EAX,EAX
        JMP     @@exit

@@found:
        POP     EDX             { restore pointer to first char of s    }
        MOV     EAX,EDI { EDI points of char after match        }
        SUB     EAX,EDX { the difference is the correct index   }
@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure       _SetLength{var s: ShortString; newLength: Integer};
asm
        { ->    EAX pointer to string   }
        {       EDX new length          }

        MOV     [EAX],DL        { should also fill new space, parameter should be openstring }

end;

procedure       _SetString{var s: ShortString: buffer: PChar; len: Integer};
asm
        { ->    EAX pointer to string           }
        {       EDX pointer to buffer   }
        {       ECX len                         }

        MOV     [EAX],CL
        TEST    EDX,EDX
        JE      @@noMove
        XCHG    EAX,EDX
        INC     EDX
        CALL    Move
@@noMove:
end;

procedure       Randomize;
var
        systemTime :
        record
                wYear   : Word;
                wMonth  : Word;
                wDayOfWeek      : Word;
                wDay    : Word;
                wHour   : Word;
                wMinute : Word;
                wSecond : Word;
                wMilliSeconds: Word;
                reserved        : array [0..7] of char;
        end;
asm
        LEA     EAX,systemTime
        PUSH    EAX
        CALL    GetSystemTime
        MOVZX   EAX,systemTime.wHour
        IMUL    EAX,60
        ADD     AX,systemTime.wMinute   { sum = hours * 60 + minutes    }
        IMUL    EAX,60
        XOR     EDX,EDX
        MOV     DX,systemTime.wSecond
        ADD     EAX,EDX                 { sum = sum * 60 + seconds              }
        IMUL    EAX,1000
        MOV     DX,systemTime.wMilliSeconds
        ADD     EAX,EDX                 { sum = sum * 1000 + milliseconds       }
        MOV     RandSeed,EAX
end;

procedure _RmDir(const S: string);
begin
  if not RemoveDirectory(PChar(S)) then InOutError;
end;

function        UpCase( ch : Char ) : Char;
asm
{ ->    AL      Character       }
{ <-    AL      Result          }

        CMP     AL,'a'
        JB      @@exit
        CMP     AL,'z'
        JA      @@exit
        SUB     AL,'a' - 'A'
@@exit:
end;


procedure Set8087CW(NewCW: Word);
asm
        MOV     Default8087CW,AX
        FNCLEX  // don't raise pending exceptions enabled by the new flags
        FLDCW   Default8087CW
end;

{ ----------------------------------------------------- }
{       functions & procedures that need compiler magic }
{ ----------------------------------------------------- }

const cwChop : Word = $1F32;

procedure       _COS;
asm
        FCOS
        FNSTSW  AX
        SAHF
        JP      @@outOfRange
        RET
@@outOfRange:
        FSTP    st(0)   { for now, return 0. result would }
        FLDZ            { have little significance anyway }
end;

procedure       _EXP;
asm
        {       e**x = 2**(x*log2(e))   }

        FLDL2E              { y := x*log2e;      }
        FMUL
        FLD     ST(0)       { i := round(y);     }
        FRNDINT
        FSUB    ST(1), ST   { f := y - i;        }
        FXCH    ST(1)       { z := 2**f          }
        F2XM1
        FLD1
        FADD
        FSCALE              { result := z * 2**i }
        FSTP    ST(1)
end;

procedure       _INT;
asm
        SUB     ESP,4
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FRNDINT
        FWAIT
        FLDCW   [ESP]
        ADD     ESP,4
end;

procedure       _SIN;
asm
        FSIN
        FNSTSW  AX
        SAHF
        JP      @@outOfRange
        RET
@@outOfRange:
        FSTP    st(0)   { for now, return 0. result would       }
        FLDZ            { have little significance anyway       }
end;

procedure       _FRAC;
asm
        FLD     ST(0)
        SUB     ESP,4
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FRNDINT
        FWAIT
        FLDCW   [ESP]
        ADD     ESP,4
        FSUB
end;

procedure       _ROUND;
asm
        { ->    FST(0)  Extended argument       }
        { <-    EDX:EAX Result                  }

        SUB     ESP,8
        FISTP   qword ptr [ESP]
        FWAIT
        POP     EAX
        POP     EDX
end;

procedure       _TRUNC;
asm
        { ->    FST(0)   Extended argument       }
        { <-    EDX:EAX  Result                  }

        SUB     ESP,12
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FISTP   qword ptr [ESP+4]
        FWAIT
        FLDCW   [ESP]
        POP     ECX
        POP     EAX
        POP     EDX
end;

procedure       _AbstractError;
asm
        CMP     AbstractErrorProc, 0
        JE      @@NoAbstErrProc
        CALL    AbstractErrorProc

@@NoAbstErrProc:
        MOV     EAX,210
        JMP     _RunError
end;

procedure       _Append;                                external;       {   OpenText}
procedure       _Assign(var t: text; s: ShortString);   external;       {$L Assign  }
procedure       _BlockRead;                             external;       {$L BlockRea}
procedure       _BlockWrite;                            external;       {$L BlockWri}
procedure       _Close;                                 external;       {$L Close   }

procedure       _PStrCat;
asm
{     ->EAX = Pointer to destination string     }
{       EDX = Pointer to source string  }

        PUSH    ESI
        PUSH    EDI

{       load dest len into EAX  }

        MOV     EDI,EAX
        XOR     EAX,EAX
        MOV     AL,[EDI]

{       load source address in ESI, source len in ECX   }

        MOV     ESI,EDX
        XOR     ECX,ECX
        MOV     CL,[ESI]
        INC     ESI

{       calculate final length in DL and store it in the destination    }

        MOV     DL,AL
        ADD     DL,CL
        JC      @@trunc

@@cont:
        MOV     [EDI],DL

{       calculate final dest address    }

        INC     EDI
        ADD     EDI,EAX

{       do the copy     }

        REP     MOVSB

{       done    }

        POP     EDI
        POP     ESI
        RET

@@trunc:
        INC     DL      {       DL = #chars to truncate                 }
        SUB     CL,DL   {       CL = source len - #chars to truncate    }
        MOV     DL,255  {       DL = maximum length                     }
        JMP     @@cont
end;

procedure       _PStrNCat;
asm
{     ->EAX = Pointer to destination string                     }
{       EDX = Pointer to source string                          }
{       CL  = max length of result (allocated size of dest - 1) }

        PUSH    ESI
        PUSH    EDI

{       load dest len into EAX  }

        MOV     EDI,EAX
        XOR     EAX,EAX
        MOV     AL,[EDI]

{       load source address in ESI, source len in EDX   }

        MOV     ESI,EDX
        XOR     EDX,EDX
        MOV     DL,[ESI]
        INC     ESI

{       calculate final length in AL and store it in the destination    }

        ADD     AL,DL
        JC      @@trunc
        CMP     AL,CL
        JA      @@trunc

@@cont:
        MOV     ECX,EDX
        MOV     DL,[EDI]
        MOV     [EDI],AL

{       calculate final dest address    }

        INC     EDI
        ADD     EDI,EDX

{       do the copy     }

        REP     MOVSB

@@done:
        POP     EDI
        POP     ESI
        RET

@@trunc:
{       CL = maxlen     }

        MOV     AL,CL   { AL = final length = maxlen            }
        SUB     CL,[EDI]        { CL = length to copy = maxlen - destlen        }
        JBE     @@done
        MOV     DL,CL
        JMP     @@cont
end;

procedure       _PStrCpy;
asm
{     ->EAX = Pointer to dest string    }
{       EDX = Pointer to source string  }

        XOR     ECX,ECX

        PUSH    ESI
        PUSH    EDI

        MOV     CL,[EDX]

        MOV     EDI,EAX

        INC     ECX             { we must copy len+1 bytes      }

        MOV     ESI,EDX

        MOV     EAX,ECX
        SHR     ECX,2
        AND     EAX,3
        REP     MOVSD

        MOV     ECX,EAX
        REP     MOVSB

        POP     EDI
        POP     ESI
end;

procedure       _PStrNCpy;
asm
{     ->EAX = Pointer to dest string                            }
{       EDX = Pointer to source string                          }
{       CL  = Maximum length to copy (allocated size of dest - 1)       }

        PUSH    ESI
        PUSH    EDI

        MOV     EDI,EAX
        XOR     EAX,EAX
        MOV     ESI,EDX

        MOV     AL,[EDX]
        CMP     AL,CL
        JA      @@trunc

        INC     EAX

        MOV     ECX,EAX
        AND     EAX,3
        SHR     ECX,2
        REP     MOVSD

        MOV     ECX,EAX
        REP     MOVSB

        POP     EDI
        POP     ESI
        RET

@@trunc:
        MOV     [EDI],CL        { result length is maxLen       }
        INC     ESI             { advance pointers              }
        INC     EDI
        AND     ECX,0FFH        { should be cheaper than MOVZX  }
        REP     MOVSB   { copy maxLen bytes             }

        POP     EDI
        POP     ESI
end;

procedure       _PStrCmp;
asm
{     ->EAX = Pointer to left string    }
{       EDX = Pointer to right string   }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        XOR     EAX,EAX
        XOR     EDX,EDX
        MOV     AL,[ESI]
        MOV     DL,[EDI]
        INC     ESI
        INC     EDI

        SUB     EAX,EDX { eax = len1 - len2 }
        JA      @@skip1
        ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }

@@skip1:
        PUSH    EDX
        SHR     EDX,2
        JE      @@cmpRest
@@longLoop:
        MOV     ECX,[ESI]
        MOV     EBX,[EDI]
        CMP     ECX,EBX
        JNE     @@misMatch
        DEC     EDX
        JE      @@cmpRestP4
        MOV     ECX,[ESI+4]
        MOV     EBX,[EDI+4]
        CMP     ECX,EBX
        JNE     @@misMatch
        ADD     ESI,8
        ADD     EDI,8
        DEC     EDX
        JNE     @@longLoop
        JMP     @@cmpRest
@@cmpRestP4:
        ADD     ESI,4
        ADD     EDI,4
@@cmpRest:
        POP     EDX
        AND     EDX,3
        JE      @@equal

        MOV     CL,[ESI]
        CMP     CL,[EDI]
        JNE     @@exit
        DEC     EDX
        JE      @@equal
        MOV     CL,[ESI+1]
        CMP     CL,[EDI+1]
        JNE     @@exit
        DEC     EDX
        JE      @@equal
        MOV     CL,[ESI+2]
        CMP     CL,[EDI+2]
        JNE     @@exit

@@equal:
        ADD     EAX,EAX
        JMP     @@exit

@@misMatch:
        POP     EDX
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH
        JNE     @@exit
        SHR     ECX,16
        SHR     EBX,16
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure       _AStrCmp;
asm
{     ->EAX = Pointer to left string    }
{       EDX = Pointer to right string   }
{       ECX = Number of chars to compare}

        PUSH    EBX
        PUSH    ESI
        PUSH    ECX
        MOV     ESI,ECX
        SHR     ESI,2
        JE      @@cmpRest

@@longLoop:
        MOV     ECX,[EAX]
        MOV     EBX,[EDX]
        CMP     ECX,EBX
        JNE     @@misMatch
        DEC     ESI
        JE      @@cmpRestP4
        MOV     ECX,[EAX+4]
        MOV     EBX,[EDX+4]
        CMP     ECX,EBX
        JNE     @@misMatch
        ADD     EAX,8
        ADD     EDX,8
        DEC     ESI
        JNE     @@longLoop
        JMP     @@cmpRest
@@cmpRestp4:
        ADD     EAX,4
        ADD     EDX,4
@@cmpRest:
        POP     ESI
        AND     ESI,3
        JE      @@exit

        MOV     CL,[EAX]
        CMP     CL,[EDX]
        JNE     @@exit
        DEC     ESI
        JE      @@equal
        MOV     CL,[EAX+1]
        CMP     CL,[EDX+1]
        JNE     @@exit
        DEC     ESI
        JE      @@equal
        MOV     CL,[EAX+2]
        CMP     CL,[EDX+2]
        JNE     @@exit

@@equal:
        XOR     EAX,EAX
        JMP     @@exit

@@misMatch:
        POP     ESI
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH
        JNE     @@exit
        SHR     ECX,16
        SHR     EBX,16
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH

@@exit:
        POP     ESI
        POP     EBX
end;

procedure       _EofFile;                               external;       {$L EofFile }
procedure       _EofText;                               external;       {$L EofText }
procedure       _Eoln;                          external;       {$L Eoln    }
procedure       _Erase;                         external;       {$L Erase   }

procedure       _FSafeDivide;                           external;       {$L FDIV    }
procedure       _FSafeDivideR;                          external;       {   FDIV    }

procedure       _FilePos;                               external;       {$L FilePos }
procedure       _FileSize;                              external;       {$L FileSize}

procedure       _FillChar;
asm
{     ->EAX     Pointer to destination  }
{       EDX     count   }
{       CL      value   }

        PUSH    EDI

        MOV     EDI,EAX { Point EDI to destination              }

        MOV     CH,CL   { Fill EAX with value repeated 4 times  }
        MOV     EAX,ECX
        SHL     EAX,16
        MOV     AX,CX

        MOV     ECX,EDX
        SAR     ECX,2
        JS      @@exit

        REP     STOSD   { Fill count DIV 4 dwords       }

        MOV     ECX,EDX
        AND     ECX,3
        REP     STOSB   { Fill count MOD 4 bytes        }

@@exit:
        POP     EDI
end;

procedure       _Mark;
begin
  Error(reInvalidPtr);
end;

procedure       _RandInt;
asm
{     ->EAX     Range   }
{     <-EAX     Result  }
        IMUL    EDX,RandSeed,08088405H
        INC     EDX
        MOV     RandSeed,EDX
        MUL     EDX
        MOV     EAX,EDX
end;

procedure       _RandExt;
const two2neg32: double = ((1.0/$10000) / $10000);  // 2^-32
asm
{       FUNCTION _RandExt: Extended;    }

        IMUL    EDX,RandSeed,08088405H
        INC     EDX
        MOV     RandSeed,EDX

        FLD     two2neg32
        PUSH    0
        PUSH    EDX
        FILD    qword ptr [ESP]
        ADD     ESP,8
        FMULP  ST(1), ST(0)
end;

procedure       _ReadRec;                               external;       {$L ReadRec }

procedure       _ReadChar;                              external;       {$L ReadChar}
procedure       _ReadLong;                              external;       {$L ReadLong}
procedure       _ReadString;                    external;       {$L ReadStri}
procedure       _ReadCString;                   external;       {   ReadStri}

procedure       _ReadExt;                               external;       {$L ReadExt }
procedure       _ReadLn;                                external;       {$L ReadLn  }

procedure       _Rename;                                external;       {$L Rename  }

procedure       _Release;
begin
  Error(reInvalidPtr);
end;

procedure       _ResetText(var t: text);                external;       {$L OpenText}
procedure       _ResetFile;                             external;       {$L OpenFile}
procedure       _RewritText(var t: text);               external;       {   OpenText}
procedure       _RewritFile;                    external;       {   OpenFile}

procedure       _Seek;                          external;       {$L Seek    }
procedure       _SeekEof;                               external;       {$L SeekEof }
procedure       _SeekEoln;                              external;       {$L SeekEoln}

procedure       _SetTextBuf;                    external;       {$L SetTextB}

procedure       _StrLong;
asm
{       PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString );
      ->EAX     Value
        EDX     Width
        ECX     Pointer to string       }

        PUSH    EBX             { VAR i: Longint;               }
        PUSH    ESI             { VAR sign : Longint;           }
        PUSH    EDI
        PUSH    EDX             { store width on the stack      }
        SUB     ESP,20          { VAR a: array [0..19] of Char; }

        MOV     EDI,ECX

        MOV     ESI,EAX         { sign := val                   }

        CDQ                     { val := Abs(val);  canned sequence }
        XOR     EAX,EDX
        SUB     EAX,EDX

        MOV     ECX,10
        XOR     EBX,EBX         { i := 0;                       }

@@repeat1:                      { repeat                        }
        XOR     EDX,EDX         {   a[i] := Chr( val MOD 10 + Ord('0') );}

        DIV     ECX             {   val := val DIV 10;          }

        ADD     EDX,'0'
        MOV     [ESP+EBX],DL
        INC     EBX             {   i := i + 1;                 }
        TEST    EAX,EAX         { until val = 0;                }
        JNZ     @@repeat1

        TEST    ESI,ESI
        JGE     @@2
        MOV     byte ptr [ESP+EBX],'-'
        INC     EBX
@@2:
        MOV     [EDI],BL        { s^++ := Chr(i);               }
        INC     EDI

        MOV     ECX,[ESP+20]    { spaceCnt := width - i;        }
        CMP     ECX,255
        JLE     @@3
        MOV     ECX,255
@@3:
        SUB     ECX,EBX
        JLE     @@repeat2       { for k := 1 to spaceCnt do s^++ := ' ';        }
        ADD     [EDI-1],CL
        MOV     AL,' '
        REP     STOSB

@@repeat2:                      { repeat                        }
        MOV     AL,[ESP+EBX-1]  {   s^ := a[i-1];               }
        MOV     [EDI],AL
        INC     EDI             {   s := s + 1                  }
        DEC     EBX             {   i := i - 1;                 }
        JNZ     @@repeat2       { until i = 0;                  }

        ADD     ESP,20+4
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure       _Str0Long;
asm
{     ->EAX     Value           }
{       EDX     Pointer to string       }

        MOV     ECX,EDX
        XOR     EDX,EDX
        JMP     _StrLong
end;

procedure       _Truncate;                              external;       {$L Truncate}

procedure       _ValLong;
asm
{       FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint;        }
{     ->EAX     Pointer to string       }
{       EDX     Pointer to code result  }
{     <-EAX     Result                  }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        PUSH    EAX             { save for the error case       }

        TEST    EAX,EAX
        JE      @@empty

        XOR     EAX,EAX
        XOR     EBX,EBX
        MOV     EDI,07FFFFFFFH / 10     { limit }

@@blankLoop:
        MOV     BL,[ESI]
        INC     ESI
        CMP     BL,' '
        JE      @@blankLoop

@@endBlanks:
        MOV     CH,0
        CMP     BL,'-'
        JE      @@minus
        CMP     BL,'+'
        JE      @@plus
        CMP     BL,'$'
        JE      @@dollar

        CMP     BL, 'x'
        JE      @@dollar
        CMP     BL, 'X'
        JE      @@dollar
        CMP     BL, '0'
        JNE     @@firstDigit
        MOV     BL, [ESI]
        INC     ESI
        CMP     BL, 'x'
        JE      @@dollar
        CMP     BL, 'X'
        JE      @@dollar
        TEST    BL, BL
        JE      @@endDigits
        JMP     @@digLoop

@@firstDigit:
        TEST    BL,BL
        JE      @@error

@@digLoop:
        SUB     BL,'0'
        CMP     BL,9
        JA      @@error
        CMP     EAX,EDI         { value > limit ?       }
        JA      @@overFlow
        LEA     EAX,[EAX+EAX*4]
        ADD     EAX,EAX
        ADD     EAX,EBX         { fortunately, we can't have a carry    }

        MOV     BL,[ESI]
        INC     ESI

        TEST    BL,BL
        JNE     @@digLoop

@@endDigits:
        DEC     CH
        JE      @@negate
        TEST    EAX,EAX
        JL      @@overFlow

@@successExit:

        POP     ECX                     { saved copy of string pointer  }

        XOR     ESI,ESI         { signal no error to caller     }

@@exit:
        MOV     [EDX],ESI

        POP     EDI
        POP     ESI
        POP     EBX
        RET

@@empty:
        INC     ESI
        JMP     @@error

@@negate:
        NEG     EAX
        JLE     @@successExit
        JS      @@successExit           { to handle 2**31 correctly, where the negate overflows }

@@error:
@@overFlow:
        POP     EBX
        SUB     ESI,EBX
        JMP     @@exit

@@minus:
        INC     CH
@@plus:
        MOV     BL,[ESI]
        INC     ESI
        JMP     @@firstDigit

@@dollar:
        MOV     EDI,0FFFFFFFH

        MOV     BL,[ESI]
        INC     ESI
        TEST    BL,BL
        JZ      @@empty

@@hDigLoop:
        CMP     BL,'a'
        JB      @@upper
        SUB     BL,'a' - 'A'
@@upper:
        SUB     BL,'0'
        CMP     BL,9
        JBE     @@digOk
        SUB     BL,'A' - '0'
        CMP     BL,5
        JA      @@error
        ADD     BL,10
@@digOk:
        CMP     EAX,EDI
        JA      @@overFlow
        SHL     EAX,4
        ADD     EAX,EBX

        MOV     BL,[ESI]
        INC     ESI

        TEST    BL,BL
        JNE     @@hDigLoop

        JMP     @@successExit
end;

procedure       _WriteRec;                              external;       {$L WriteRec}

procedure       _WriteChar;                             external;       {   WriteStr}
procedure       _Write0Char;                    external;       {   WriteStr}

procedure       _WriteBool;
asm
{       PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint);       }
{     ->EAX     Pointer to file record  }
{       DL      Boolean value           }
{       ECX     Field width             }

        TEST    DL,DL
        JE      @@false
        MOV     EDX,offset @trueString
        JMP     _WriteString
@@false:
        MOV     EDX,offset @falseString
        JMP     _WriteString
@trueString:  db        4,'TRUE'
@falseString: db        5,'FALSE'
end;

procedure       _Write0Bool;
asm
{       PROCEDURE _Write0Bool( VAR t: Text; val: Boolean);      }
{     ->EAX     Pointer to file record  }
{       DL      Boolean value           }

        XOR     ECX,ECX
        JMP     _WriteBool
end;

procedure       _WriteLong;
asm
{       PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint);        }
{     ->EAX     Pointer to file record  }
{       EDX     Value                   }
{       ECX     Field width             }

        SUB     ESP,32          { VAR s: String[31];    }

        PUSH    EAX
        PUSH    ECX

        MOV     EAX,EDX         { Str( val : 0, s );    }
        XOR     EDX,EDX
        CMP     ECX,31
        JG      @@1
        MOV     EDX,ECX
@@1:
        LEA     ECX,[ESP+8]
        CALL    _StrLong

        POP     ECX
        POP     EAX

        MOV     EDX,ESP         { Write( t, s : width );}
        CALL    _WriteString

        ADD     ESP,32
end;

procedure       _Write0Long;
asm
{       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
{     ->EAX     Pointer to file record  }
{       EDX     Value                   }
        XOR     ECX,ECX
        JMP     _WriteLong
end;

procedure       _WriteString;                   external;       {$L WriteStr}
procedure       _Write0String;                  external;       {   WriteStr}

procedure       _WriteCString;                  external;       {   WriteStr}
procedure       _Write0CString;                 external;       {   WriteStr}

procedure       _WriteBytes;                    external;       {   WriteStr}
procedure       _WriteSpaces;                   external;       {   WriteStr}

procedure       _Write2Ext;
asm
{       PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint);
      ->EAX     Pointer to file record
        [ESP+4] Extended value
        EDX     Field width
        ECX     precision (<0: scientific, >= 0: fixed point)   }

        FLD     tbyte ptr [ESP+4]       { load value    }
        SUB     ESP,256         { VAR s: String;        }

        PUSH    EAX
        PUSH    EDX

{       Str( val, width, prec, s );     }

        SUB     ESP,12
        FSTP    tbyte ptr [ESP] { pass value            }
        MOV     EAX,EDX         { pass field width              }
        MOV     EDX,ECX         { pass precision                }
        LEA     ECX,[ESP+8+12]  { pass destination string       }
        CALL    _Str2Ext

{       Write( t, s, width );   }

        POP     ECX                     { pass width    }
        POP     EAX                     { pass text     }
        MOV     EDX,ESP         { pass string   }
        CALL    _WriteString

        ADD     ESP,256
        RET     12
end;

procedure       _Write1Ext;
asm
{       PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint);
  ->    EAX     Pointer to file record
        [ESP+4] Extended value
        EDX     Field width             }

        OR      ECX,-1
        JMP     _Write2Ext
end;

procedure       _Write0Ext;
asm
{       PROCEDURE _Write0Ext( VAR t: Text; val: Extended);
      ->EAX     Pointer to file record
        [ESP+4] Extended value  }

        MOV     EDX,23  { field width   }
        OR      ECX,-1
        JMP     _Write2Ext
end;

procedure       _WriteLn;                       external;       {   WriteStr}

procedure       __CToPasStr;
asm
{     ->EAX     Pointer to destination  }
{       EDX     Pointer to source       }

        PUSH    EAX             { save destination      }

        MOV     CL,255
@@loop:
        MOV     CH,[EDX]        { ch = *src++;          }
        INC     EDX
        TEST    CH,CH   { if (ch == 0) break    }
        JE      @@endLoop
        INC     EAX             { *++dest = ch;         }
        MOV     [EAX],CH
        DEC     CL
        JNE     @@loop

@@endLoop:
        POP     EDX
        SUB     EAX,EDX
        MOV     [EDX],AL
end;

procedure       __CLenToPasStr;
asm
{     ->EAX     Pointer to destination  }
{       EDX     Pointer to source       }
{       ECX     cnt                     }

        PUSH    EBX
        PUSH    EAX             { save destination      }

        CMP     ECX,255
        JBE     @@loop
    MOV ECX,255
@@loop:
        MOV     BL,[EDX]        { ch = *src++;          }
        INC     EDX
        TEST    BL,BL   { if (ch == 0) break    }
        JE      @@endLoop
        INC     EAX             { *++dest = ch;         }
        MOV     [EAX],BL
        DEC     ECX             { while (--cnt != 0)    }
        JNZ     @@loop

@@endLoop:
        POP     EDX
        SUB     EAX,EDX
        MOV     [EDX],AL
        POP     EBX
end;

procedure       __ArrayToPasStr;
asm
{     ->EAX     Pointer to destination  }
{       EDX     Pointer to source       }
{       ECX     cnt                     }

        XCHG    EAX,EDX

        {       limit the length to 255 }

        CMP     ECX,255
    JBE     @@skip
    MOV     ECX,255
@@skip:
    MOV     [EDX],CL

        {       copy the source to destination + 1 }

        INC     EDX
        JMP     Move
end;


procedure       __PasToCStr;
asm
{     ->EAX     Pointer to source       }
{       EDX     Pointer to destination  }

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        XOR     ECX,ECX
        MOV     CL,[ESI]
        INC     ESI

        REP     MOVSB
        MOV     byte ptr [EDI],CL       { Append terminator: CL is zero here }

        POP     EDI
        POP     ESI
end;

procedure       _SetElem;
asm
        {       PROCEDURE _SetElem( VAR d: SET; elem, size: Byte);      }
        {       EAX     =       dest address                            }
        {       DL      =       element number                          }
        {       CL      =       size of set                                     }

        PUSH    EBX
        PUSH    EDI

        MOV     EDI,EAX

        XOR     EBX,EBX { zero extend set size into ebx }
        MOV     BL,CL
        MOV     ECX,EBX { and use it for the fill       }

        XOR     EAX,EAX { for zero fill                 }
        REP     STOSB

        SUB     EDI,EBX { point edi at beginning of set again   }

        INC     EAX             { eax is still zero - make it 1 }
        MOV     CL,DL
        ROL     AL,CL   { generate a mask               }
        SHR     ECX,3   { generate the index            }
        CMP     ECX,EBX { if index >= siz then exit     }
        JAE     @@exit
        OR      [EDI+ECX],AL{ set bit                   }

@@exit:
        POP     EDI
        POP     EBX
end;

procedure       _SetRange;
asm
{       PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET );  }
{ ->AL  low limit of range      }
{       DL      high limit of range     }
{       ECX     Pointer to set          }
{       AH      size of set             }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        XOR     EBX,EBX { EBX = set size                }
        MOV     BL,AH
        MOVZX   ESI,AL  { ESI = low zero extended       }
        MOVZX   EDX,DL  { EDX = high zero extended      }
        MOV     EDI,ECX

{       clear the set                                   }

        MOV     ECX,EBX
        XOR     EAX,EAX
        REP     STOSB

{       prepare for setting the bits                    }

        SUB     EDI,EBX { point EDI at start of set     }
        SHL     EBX,3   { EBX = highest bit in set + 1  }
        CMP     EDX,EBX
        JB      @@inrange
        LEA     EDX,[EBX-1]     { ECX = highest bit in set      }

@@inrange:
        CMP     ESI,EDX { if lo > hi then exit;         }
        JA      @@exit

        DEC     EAX     { loMask = 0xff << (lo & 7)             }
        MOV     ECX,ESI
        AND     CL,07H
        SHL     AL,CL

        SHR     ESI,3   { loIndex = lo >> 3;            }

        MOV     CL,DL   { hiMask = 0xff >> (7 - (hi & 7));      }
        NOT     CL
        AND     CL,07
        SHR     AH,CL

        SHR     EDX,3   { hiIndex = hi >> 3;            }

        ADD     EDI,ESI { point EDI to set[loIndex]     }
        MOV     ECX,EDX
        SUB     ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0)     }
        JNE     @@else

        AND     AL,AH   { set[loIndex] = hiMask & loMask;       }
        MOV     [EDI],AL
        JMP     @@exit

@@else:
        STOSB           { set[loIndex++] = loMask;      }
        DEC     ECX
        MOV     AL,0FFH { while (loIndex < hiIndex)     }
        REP     STOSB   {   set[loIndex++] = 0xff;      }
        MOV     [EDI],AH        { set[hiIndex] = hiMask;        }

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure       _SetEq;
asm
{       FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode;   }
{       EAX     =       left operand    }
{       EDX     =       right operand   }
{       CL      =       size of set     }

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        AND     ECX,0FFH
        REP     CMPSB

        POP     EDI
        POP     ESI
end;

procedure       _SetLe;
asm
{       FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode;   }
{       EAX     =       left operand            }
{       EDX     =       right operand           }
{       CL      =       size of set (>0 && <= 32)       }

@@loop:
        MOV     CH,[EDX]
        NOT     CH
        AND     CH,[EAX]
        JNE     @@exit
        INC     EDX
        INC     EAX
        DEC     CL
        JNZ     @@loop
@@exit:
end;

procedure       _SetIntersect;
asm
{       PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);}
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       CL      =       size of set (0 < size <= 32)    }

@@loop:
        MOV     CH,[EDX]
        INC     EDX
        AND     [EAX],CH
        INC     EAX
        DEC     CL
        JNZ     @@loop
end;

procedure       _SetIntersect3;
asm
{       PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       ECX     =       size of set (0 < size <= 32)    }
{	[ESP+4]	=	2nd source operand		}

	PUSH	EBX
	PUSH	ESI
	MOV	ESI,[ESP+8+4]
@@loop:
        MOV     BL,[EDX+ECX-1]
	AND	BL,[ESI+ECX-1]
	MOV	[EAX+ECX-1],BL
        DEC     ECX
        JNZ     @@loop

	POP	ESI
	POP	EBX
end;

procedure       _SetUnion;
asm
{       PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte);        }
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       CL      =       size of set (0 < size <= 32)    }

@@loop:
        MOV     CH,[EDX]
        INC     EDX
        OR      [EAX],CH
        INC     EAX
        DEC     CL
        JNZ     @@loop
end;

procedure       _SetUnion3;
asm
{       PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       ECX     =       size of set (0 < size <= 32)    }
{	[ESP+4]	=	2nd source operand		}

	PUSH	EBX
	PUSH	ESI
	MOV	ESI,[ESP+8+4]
@@loop:
        MOV     BL,[EDX+ECX-1]
	OR	BL,[ESI+ECX-1]
	MOV	[EAX+ECX-1],BL
        DEC     ECX
        JNZ     @@loop

	POP	ESI
	POP	EBX
end;

procedure       _SetSub;
asm
{       PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte);  }
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       CL      =       size of set (0 < size <= 32)    }

@@loop:
        MOV     CH,[EDX]
        NOT     CH
        INC     EDX
        AND     [EAX],CH
        INC     EAX
        DEC     CL
        JNZ     @@loop
end;

procedure       _SetSub3;
asm
{       PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{       EAX     =       destination operand             }
{       EDX     =       source operand                  }
{       ECX     =       size of set (0 < size <= 32)    }
{	[ESP+4]	=	2nd source operand		}

	PUSH	EBX
	PUSH	ESI
	MOV	ESI,[ESP+8+4]
@@loop:
	MOV	BL,[ESI+ECX-1]
	NOT	BL
        AND     BL,[EDX+ECX-1]
	MOV	[EAX+ECX-1],BL
        DEC     ECX
        JNZ     @@loop

	POP	ESI
	POP	EBX
end;

procedure       _SetExpand;
asm
{       PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte);     }
{     ->EAX     Pointer to source (packed set)          }
{       EDX     Pointer to destination (expanded set)   }
{       CH      high byte of source                     }
{       CL      low byte of source                      }

{       algorithm:              }
{       clear low bytes         }
{       copy high-low+1 bytes   }
{       clear 31-high bytes     }

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        MOV     EDX,ECX { save low, high in dl, dh      }
        XOR     ECX,ECX
        XOR     EAX,EAX

        MOV     CL,DL   { clear low bytes               }
        REP     STOSB

        MOV     CL,DH   { copy high - low bytes }
        SUB     CL,DL
        REP     MOVSB

        MOV     CL,32   { copy 32 - high bytes  }
        SUB     CL,DH
        REP     STOSB

        POP     EDI
        POP     ESI
end;

procedure       _Str2Ext;                       external;       {$L StrExt  }
procedure       _Str0Ext;                       external;       {   StrExt  }
procedure       _Str1Ext;                       external;       {   StrExt  }

procedure       _ValExt;                        external;       {$L ValExt  }

procedure       _Pow10;                         external;       {$L Pow10   }
procedure       FPower10;                       external;       {   Pow10   }
procedure       _Real2Ext;                      external;       {$L Real2Ext}
procedure       _Ext2Real;                      external;       {$L Ext2Real}

const
        ovtInstanceSize = -8;   { Offset of instance size in OBJECTs    }
        ovtVmtPtrOffs   = -4;

procedure       _ObjSetup;
asm
{       FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
{     ->EAX     Pointer to self (possibly nil)  }
{       EDX     Pointer to vmt  (possibly nil)  }
{     <-EAX     Pointer to self                 }
{       EDX     <> 0: an object was allocated   }
{       Z-Flag  Set: failure, Cleared: Success  }

        CMP     EDX,1   { is vmt = 0, indicating a call         }
        JAE     @@skip1 { from a constructor?                   }
        RET                     { return immediately with Z-flag cleared        }

@@skip1:
        PUSH    ECX
        TEST    EAX,EAX { is self already allocated?            }
        JNE     @@noAlloc
        MOV     EAX,[EDX].ovtInstanceSize
        TEST    EAX,EAX
        JE      @@zeroSize
        PUSH    EDX
        CALL    MemoryManager.GetMem
        POP     EDX
        TEST    EAX,EAX
        JZ      @@fail

        {       Zero fill the memory }
        PUSH    EDI
        MOV     ECX,[EDX].ovtInstanceSize
        MOV     EDI,EAX
        PUSH    EAX
        XOR     EAX,EAX
        SHR     ECX,2
        REP     STOSD
        MOV     ECX,[EDX].ovtInstanceSize
        AND     ECX,3
        REP     STOSB
        POP     EAX
        POP     EDI

        MOV     ECX,[EDX].ovtVmtPtrOffs
        TEST    ECX,ECX
        JL      @@skip
        MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
@@skip:
        TEST    EAX,EAX { clear zero flag                               }
        POP     ECX
        RET

@@fail:
        XOR     EDX,EDX
        POP     ECX
        RET

@@zeroSize:
        XOR     EDX,EDX
        CMP     EAX,1   { clear zero flag - we were successful (kind of) }
        POP     ECX
        RET

@@noAlloc:
        MOV     ECX,[EDX].ovtVmtPtrOffs
        TEST    ECX,ECX
        JL      @@exit
        MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
@@exit:
        XOR     EDX,EDX { clear allocated flag                  }
        TEST    EAX,EAX { clear zero flag                               }
        POP     ECX
end;

procedure       _ObjCopy;
asm
{       PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint);    }
{     ->EAX     Pointer to destination          }
{       EDX     Pointer to source               }
{       ECX     Offset of vmt in those objects. }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EDX
        MOV     EDI,EAX

        LEA     EAX,[EDI+ECX]   { remember pointer to dest vmt pointer  }
        MOV     EDX,[EAX]       { fetch dest vmt pointer        }

        MOV     EBX,[EDX].ovtInstanceSize

        MOV     ECX,EBX { copy size DIV 4 dwords        }
        SHR     ECX,2
        REP     MOVSD

        MOV     ECX,EBX { copy size MOD 4 bytes }
        AND     ECX,3
        REP     MOVSB

        MOV     [EAX],EDX       { restore dest vmt              }

        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure       _Fail;
asm
{       FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT;     }
{     ->EAX     Pointer to self (possibly nil)  }
{       EDX     <> 0: Object must be deallocated        }
{     <-EAX     Nil                                     }

        TEST    EDX,EDX
        JE      @@exit  { if no object was allocated, return    }
        CALL    _FreeMem
@@exit:
        XOR     EAX,EAX
end;

function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall;
  external user name 'GetKeyboardType';

function _isNECWindows: Boolean;
var
  KbSubType: Integer;
begin
  Result := False;
  if GetKeyboardType(0) = $7 then
  begin
    KbSubType := GetKeyboardType(1) and $FF00;
    if (KbSubType = $0D00) or (KbSubType = $0400) then
      Result := True;
  end;
end;

procedure _FpuMaskInit;
const
  HKEY_LOCAL_MACHINE = $80000002;
  KEY_QUERY_VALUE    = $00000001;
  REG_DWORD          = 4;
  FPUMASKKEY  = 'SOFTWARE\Borland\Delphi\RTL';
  FPUMASKNAME = 'FPUMaskValue';
var
  phkResult: LongWord;
  lpData, DataSize: Longint;
begin
  lpData := Default8087CW;

  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then
  try
    DataSize := Sizeof(lpData);
    RegQueryValueEx(phkResult, FPUMASKNAME, nil,  nil, @lpData, @DataSize);
  finally
    RegCloseKey(phkResult);
  end;

  Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f);
end;

procedure       FpuInit;
//const cwDefault: Word = $1332 { $133F};
asm
        FNINIT
        FWAIT
        FLDCW   Default8087CW
end;

procedure FpuInitConsiderNECWindows;
begin
  if _isNECWindows then _FpuMaskInit;
  FpuInit();
end;

procedure       _BoundErr;
asm
        MOV     AL,reRangeError
        JMP     Error
end;

procedure       _IntOver;
asm
        MOV     AL,reIntOverflow
        JMP     Error
end;

function TObject.ClassType: TClass;
asm
        mov     eax,[eax]
end;

class function TObject.ClassName: ShortString;
asm
        { ->    EAX VMT                         }
        {       EDX Pointer to result string    }
        PUSH    ESI
        PUSH    EDI
        MOV     EDI,EDX
        MOV     ESI,[EAX].vmtClassName
        XOR     ECX,ECX
        MOV     CL,[ESI]
        INC     ECX
        REP     MOVSB
        POP     EDI
        POP     ESI
end;

class function TObject.ClassNameIs(const Name: string): Boolean;
asm
        PUSH    EBX
        XOR     EBX,EBX
        OR      EDX,EDX
        JE      @@exit
        MOV     EAX,[EAX].vmtClassName
        XOR     ECX,ECX
        MOV     CL,[EAX]
        CMP     ECX,[EDX-4]
        JNE     @@exit
        DEC     EDX
@@loop:
        MOV     BH,[EAX+ECX]
        XOR     BH,[EDX+ECX]
        AND     BH,0DFH
        JNE     @@exit
        DEC     ECX
        JNE     @@loop
        INC     EBX
@@exit:
        MOV     AL,BL
        POP     EBX
end;

class function TObject.ClassParent: TClass;
asm
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        JE      @@exit
        MOV     EAX,[EAX]
@@exit:
end;

class function TObject.NewInstance: TObject;
asm
        PUSH    EAX
        MOV     EAX,[EAX].vmtInstanceSize
        CALL    _GetMem
        MOV     EDX,EAX
        POP     EAX
        JMP     TObject.InitInstance
end;

procedure TObject.FreeInstance;
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EAX
@@loop:
        MOV     ESI,[ESI]
        MOV     EDX,[ESI].vmtInitTable
        MOV     ESI,[ESI].vmtParent
        TEST    EDX,EDX
        JE      @@skip
        CALL    _FinalizeRecord
        MOV     EAX,EBX
@@skip:
        TEST    ESI,ESI
        JNE     @@loop

        CALL    _FreeMem
        POP     ESI
        POP     EBX
end;

class function TObject.InstanceSize: Longint;
asm
        MOV     EAX,[EAX].vmtInstanceSize
end;

constructor TObject.Create;
begin
end;

destructor TObject.Destroy;
begin
end;

procedure TObject.Free;
asm
        TEST    EAX,EAX
        JE      @@exit
        MOV     ECX,[EAX]
        MOV     DL,1
        CALL    dword ptr [ECX].vmtDestroy
@@exit:
end;

class function TObject.InitInstance(Instance: Pointer): TObject;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     EDI,EDX
        STOSD
        MOV     ECX,[EBX].vmtInstanceSize
        XOR     EAX,EAX
        PUSH    ECX
        SHR     ECX,2
        DEC     ECX
        REP     STOSD
        POP     ECX
        AND     ECX,3
        REP     STOSB
        MOV     EAX,EDX
        MOV     EDX,ESP
@@0:    MOV     ECX,[EBX].vmtIntfTable
        TEST    ECX,ECX
        JE      @@1
        PUSH    ECX
@@1:    MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JE      @@2
        MOV     EBX,[EBX]
        JMP     @@0
@@2:    CMP     ESP,EDX
        JE      @@5
@@3:    POP     EBX
        MOV     ECX,[EBX].TInterfaceTable.EntryCount
        ADD     EBX,4
@@4:    MOV     ESI,[EBX].TInterfaceEntry.VTable
        TEST    ESI,ESI
        JE      @@4a
        MOV     EDI,[EBX].TInterfaceEntry.IOffset
        MOV     [EAX+EDI],ESI
@@4a:   ADD     EBX,TYPE TInterfaceEntry
        DEC     ECX
        JNE     @@4
        CMP     ESP,EDX
        JNE     @@3
@@5:    POP     EDI
        POP     ESI
        POP     EBX
end;

procedure TObject.CleanupInstance;
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EAX
@@loop:
        MOV     ESI,[ESI]
        MOV     EDX,[ESI].vmtInitTable
        MOV     ESI,[ESI].vmtParent
        TEST    EDX,EDX
        JE      @@skip
        CALL    _FinalizeRecord
        MOV     EAX,EBX
@@skip:
        TEST    ESI,ESI
        JNE     @@loop

        POP     ESI
        POP     EBX
end;

function InvokeImplGetter(Self: TObject; ImplGetter: Integer): IUnknown;
asm
        XCHG    EDX,ECX
        CMP     ECX,$FF000000
        JAE     @@isField
        CMP     ECX,$FE000000
        JB      @@isStaticMethod

        {       the GetProc is a virtual method }
        MOVSX   ECX,CX                  { sign extend slot offs }
        ADD     ECX,[EAX]               { vmt   + slotoffs      }
        JMP     dword ptr [ECX]         { call vmt[slot]        }

@@isStaticMethod:
        JMP     ECX

@@isField:
        AND     ECX,$00FFFFFF
        ADD     ECX,EAX
        MOV     EAX,EDX
        MOV     EDX,[ECX]
        JMP     _IntfCopy
end;

function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
var
  InterfaceEntry: PInterfaceEntry;
begin
  InterfaceEntry := GetInterfaceEntry(IID);
  if InterfaceEntry <> nil then
  begin
    if InterfaceEntry^.IOffset <> 0 then
      Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset)
    else
      IUnknown(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter);
    if Pointer(Obj) <> nil then
    begin
      if InterfaceEntry^.IOffset <> 0 then IUnknown(Obj)._AddRef;
      Result := True;
    end
    else
      Result := False;
  end else
  begin
    Pointer(Obj) := nil;
    Result := False;
  end;
end;

class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
@@1:    MOV     EAX,[EBX].vmtIntfTable
        TEST    EAX,EAX
        JE      @@4
        MOV     ECX,[EAX].TInterfaceTable.EntryCount
        ADD     EAX,4
@@2:    MOV     ESI,[EDX].Integer[0]
        CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[0]
        JNE     @@3
        MOV     ESI,[EDX].Integer[4]
        CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[4]
        JNE     @@3
        MOV     ESI,[EDX].Integer[8]
        CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[8]
        JNE     @@3
        MOV     ESI,[EDX].Integer[12]
        CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[12]
        JE      @@5
@@3:    ADD     EAX,type TInterfaceEntry
        DEC     ECX
        JNE     @@2
@@4:    MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JE      @@4a
        MOV     EBX,[EBX]
        JMP     @@1
@@4a:   XOR     EAX,EAX
@@5:    POP     ESI
        POP     EBX
end;

class function TObject.GetInterfaceTable: PInterfaceTable;
asm
        MOV     EAX,[EAX].vmtIntfTable
end;


procedure       _IsClass;
asm
        { ->    EAX     left operand (class)    }
        {       EDX VMT of right operand        }
        { <-    AL      left is derived from right      }
        TEST    EAX,EAX
        JE      @@exit
@@loop:
        MOV     EAX,[EAX]
        CMP     EAX,EDX
        JE      @@success
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        JNE     @@loop
        JMP     @@exit
@@success:
        MOV     AL,1
@@exit:
end;


procedure       _AsClass;
asm
        { ->    EAX     left operand (class)    }
        {       EDX VMT of right operand        }
        { <-    EAX      if left is derived from right, else runtime error      }
        TEST    EAX,EAX
        JE      @@exit
        MOV     ECX,EAX
@@loop:
        MOV     ECX,[ECX]
        CMP     ECX,EDX
        JE      @@exit
        MOV     ECX,[ECX].vmtParent
        TEST    ECX,ECX
        JNE     @@loop

        {       do runtime error        }
        MOV     AL,reInvalidCast
        JMP     Error

@@exit:
end;


procedure       GetDynaMethod;
{       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
asm
        { ->    EAX     vmt of class            }
        {       BX      dynamic method index    }
        { <-    EBX pointer to routine  }
        {       ZF = 0 if found         }
        {       trashes: EAX, ECX               }

        PUSH    EDI
        XCHG    EAX,EBX
        JMP     @@haveVMT
@@outerLoop:
        MOV     EBX,[EBX]
@@haveVMT:
        MOV     EDI,[EBX].vmtDynamicTable
        TEST    EDI,EDI
        JE      @@parent
        MOVZX   ECX,word ptr [EDI]
        PUSH    ECX
        ADD     EDI,2
        REPNE   SCASW
        JE      @@found
        POP     ECX
@@parent:
        MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JNE     @@outerLoop
        JMP     @@exit

@@found:
        POP     EAX
        ADD     EAX,EAX
        SUB     EAX,ECX         { this will always clear the Z-flag ! }
        MOV     EBX,[EDI+EAX*2-4]

@@exit:
        POP     EDI
end;

procedure       _CallDynaInst;
asm
        PUSH    EAX
        PUSH    ECX
        MOV     EAX,[EAX]
        CALL    GetDynaMethod
        POP     ECX
        POP     EAX
        JE      @@Abstract
        JMP     EBX
@@Abstract:
        POP     ECX
        JMP     _AbstractError
end;


procedure       _CallDynaClass;
asm
        PUSH    EAX
        PUSH    ECX
        CALL    GetDynaMethod
        POP     ECX
        POP     EAX
        JE      @@Abstract
        JMP     EBX
@@Abstract:
        POP     ECX
        JMP     _AbstractError
end;


procedure       _FindDynaInst;
asm
        PUSH    EBX
        MOV     EBX,EDX
        MOV     EAX,[EAX]
        CALL    GetDynaMethod
        MOV     EAX,EBX
        POP     EBX
        JNE     @@exit
        POP     ECX
        JMP     _AbstractError
@@exit:
end;


procedure       _FindDynaClass;
asm
        PUSH    EBX
        MOV     EBX,EDX
        CALL    GetDynaMethod
        MOV     EAX,EBX
        POP     EBX
        JNE     @@exit
        POP     ECX
        JMP     _AbstractError
@@exit:
end;


class function TObject.InheritsFrom(AClass: TClass): Boolean;
asm
        { ->    EAX     Pointer to our class    }
        {       EDX     Pointer to AClass               }
        { <-    AL      Boolean result          }
        JMP     @@haveVMT
@@loop:
        MOV     EAX,[EAX]
@@haveVMT:
        CMP     EAX,EDX
        JE      @@success
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        JNE     @@loop
        JMP     @@exit
@@success:
        MOV     AL,1
@@exit:
end;


class function TObject.ClassInfo: Pointer;
asm
        MOV     EAX,[EAX].vmtTypeInfo
end;


function TObject.SafeCallException(ExceptObject: TObject;
  ExceptAddr: Pointer): HResult;
begin
  Result := HResult($8000FFFF); { E_UNEXPECTED }
end;


procedure TObject.DefaultHandler(var Message);
begin
end;


procedure TObject.AfterConstruction;
begin
end;

procedure TObject.BeforeDestruction;
begin
end;

procedure TObject.Dispatch(var Message);
asm
        PUSH    EBX
        MOV     BX,[EDX]
        OR      BX,BX
        JE      @@default
        CMP     BX,0C000H
        JAE     @@default
        PUSH    EAX
        MOV     EAX,[EAX]
        CALL    GetDynaMethod
        POP     EAX
        JE      @@default
        MOV     ECX,EBX
        POP     EBX
        JMP     ECX

@@default:
        POP     EBX
        MOV     ECX,[EAX]
        JMP     dword ptr [ECX].vmtDefaultHandler
end;


class function TObject.MethodAddress(const Name: ShortString): Pointer;
asm
        { ->    EAX     Pointer to class        }
        {       EDX     Pointer to name }
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        XOR     ECX,ECX
        XOR     EDI,EDI
        MOV     BL,[EDX]
        JMP     @@haveVMT
@@outer:                                { upper 16 bits of ECX are 0 !  }
        MOV     EAX,[EAX]
@@haveVMT:
        MOV     ESI,[EAX].vmtMethodTable
        TEST    ESI,ESI
        JE      @@parent
        MOV     DI,[ESI]                { EDI := method count           }
        ADD     ESI,2
@@inner:                                { upper 16 bits of ECX are 0 !  }
        MOV     CL,[ESI+6]              { compare length of strings     }
        CMP     CL,BL
        JE      @@cmpChar
@@cont:                                 { upper 16 bits of ECX are 0 !  }
        MOV     CX,[ESI]                { fetch length of method desc   }
        ADD     ESI,ECX                 { point ESI to next method      }
        DEC     EDI
        JNZ     @@inner
@@parent:
        MOV     EAX,[EAX].vmtParent     { fetch parent vmt              }
        TEST    EAX,EAX
        JNE     @@outer
        JMP     @@exit                  { return NIL                    }

@@notEqual:
        MOV     BL,[EDX]                { restore BL to length of name  }
        JMP     @@cont

@@cmpChar:                              { upper 16 bits of ECX are 0 !  }
        MOV     CH,0                    { upper 24 bits of ECX are 0 !  }
@@cmpCharLoop:
        MOV     BL,[ESI+ECX+6]          { case insensitive string cmp   }
        XOR     BL,[EDX+ECX+0]          { last char is compared first   }
        AND     BL,$DF
        JNE     @@notEqual
        DEC     ECX                     { ECX serves as counter         }
        JNZ     @@cmpCharLoop

        { found it }
        MOV     EAX,[ESI+2]

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


class function TObject.MethodName(Address: Pointer): ShortString;
asm
        { ->    EAX     Pointer to class        }
        {       EDX     Address         }
        {       ECX Pointer to result   }
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EDI,ECX
        XOR     EBX,EBX
        XOR     ECX,ECX
        JMP     @@haveVMT
@@outer:
        MOV     EAX,[EAX]
@@haveVMT:
        MOV     ESI,[EAX].vmtMethodTable { fetch pointer to method table }
        TEST    ESI,ESI
        JE      @@parent
        MOV     CX,[ESI]
        ADD     ESI,2
@@inner:
        CMP     EDX,[ESI+2]
        JE      @@found
        MOV     BX,[ESI]
        ADD     ESI,EBX
        DEC     ECX
        JNZ     @@inner
@@parent:
        MOV     EAX,[EAX].vmtParent
        TEST    EAX,EAX
        JNE     @@outer
        MOV     [EDI],AL
        JMP     @@exit

@@found:
        ADD     ESI,6
        XOR     ECX,ECX
        MOV     CL,[ESI]
        INC     ECX
        REP     MOVSB

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


function TObject.FieldAddress(const Name: ShortString): Pointer;
asm
        { ->    EAX     Pointer to instance     }
        {       EDX     Pointer to name }
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        XOR     ECX,ECX
        XOR     EDI,EDI
        MOV     BL,[EDX]

        PUSH    EAX                     { save instance pointer         }

@@outer:
        MOV     EAX,[EAX]               { fetch class pointer           }
        MOV     ESI,[EAX].vmtFieldTable
        TEST    ESI,ESI
        JE      @@parent
        MOV     DI,[ESI]                { fetch count of fields         }
        ADD     ESI,6
@@inner:
        MOV     CL,[ESI+6]              { compare string lengths        }
        CMP     CL,BL
        JE      @@cmpChar
@@cont:
        LEA     ESI,[ESI+ECX+7] { point ESI to next field       }
        DEC     EDI
        JNZ     @@inner
@@parent:
        MOV     EAX,[EAX].vmtParent     { fetch parent VMT              }
        TEST    EAX,EAX
        JNE     @@outer
        POP     EDX                     { forget instance, return Nil   }
        JMP     @@exit

@@notEqual:
        MOV     BL,[EDX]                { restore BL to length of name  }
        MOV     CL,[ESI+6]              { ECX := length of field name   }
        JMP     @@cont

@@cmpChar:
        MOV     BL,[ESI+ECX+6]  { case insensitive string cmp   }
        XOR     BL,[EDX+ECX+0]  { starting with last char       }
        AND     BL,$DF
        JNE     @@notEqual
        DEC     ECX                     { ECX serves as counter         }
        JNZ     @@cmpChar

        { found it }
        MOV     EAX,[ESI]           { result is field offset plus ...   }
        POP     EDX
        ADD     EAX,EDX         { instance pointer              }

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


const { copied from xx.h }
  cContinuable        = 0;
  cNonContinuable     = 1;
  cUnwinding          = 2;
  cUnwindingForExit   = 4;
  cUnwindInProgress   = cUnwinding or cUnwindingForExit;
  cDelphiException    = $0EEDFADE;
  cDelphiReRaise      = $0EEDFADF;
  cDelphiExcept       = $0EEDFAE0;
  cDelphiFinally      = $0EEDFAE1;
  cDelphiTerminate    = $0EEDFAE2;
  cDelphiUnhandled    = $0EEDFAE3;
  cNonDelphiException = $0EEDFAE4;
  cDelphiExitFinally  = $0EEDFAE5;
  cCppException       = $0EEFFACE; { used by BCB }
  EXCEPTION_CONTINUE_SEARCH    = 0;
  EXCEPTION_EXECUTE_HANDLER    = 1;
  EXCEPTION_CONTINUE_EXECUTION = -1;

type
  JmpInstruction =
  packed record
    opCode:   Byte;
    distance: Longint;
  end;
  TExcDescEntry =
  record
    vTable:  Pointer;
    handler: Pointer;
  end;
  PExcDesc = ^TExcDesc;
  TExcDesc =
  packed record
    jmp: JmpInstruction;
    case Integer of
    0:      (instructions: array [0..0] of Byte);
    1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry);
  end;

  PExcFrame = ^TExcFrame;
  TExcFrame =
  record
    next: PExcFrame;
    desc: PExcDesc;
    hEBP: Pointer;
    case Integer of
    0:  ( );
    1:  ( ConstructedObject: Pointer );
    2:  ( SelfOfMethod: Pointer );
  end;

  PExceptionRecord = ^TExceptionRecord;
  TExceptionRecord =
  record
    ExceptionCode        : LongWord;
    ExceptionFlags       : LongWord;
    OuterException       : PExceptionRecord;
    ExceptionAddress     : Pointer;
    NumberParameters     : Longint;
    case {IsOsException:} Boolean of
    True:  (ExceptionInformation : array [0..14] of Longint);
    False: (ExceptAddr: Pointer; ExceptObject: Pointer);
  end;

  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = packed record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: PExceptionRecord;
  end;


procedure       _ClassCreate;
asm
        { ->    EAX = pointer to VMT      }
        { <-    EAX = pointer to instance }
        PUSH    EDX
        PUSH    ECX
        PUSH    EBX
        TEST    DL,DL
        JL      @@noAlloc
        CALL    dword ptr [EAX].vmtNewInstance
@@noAlloc:
        XOR     EDX,EDX
        LEA     ECX,[ESP+16]
        MOV     EBX,FS:[EDX]
        MOV     [ECX].TExcFrame.next,EBX
        MOV     [ECX].TExcFrame.hEBP,EBP
        MOV     [ECX].TExcFrame.desc,offset @desc
        MOV     [ECX].TexcFrame.ConstructedObject,EAX   { trick: remember copy to instance }
        MOV     FS:[EDX],ECX
        POP     EBX
        POP     ECX
        POP     EDX
        RET

@desc:
        JMP     _HandleAnyException

        {       destroy the object                                                      }

        MOV     EAX,[ESP+8+9*4]
        MOV     EAX,[EAX].TExcFrame.ConstructedObject
        TEST    EAX,EAX
        JE      @@skip
        MOV     ECX,[EAX]
        MOV     DL,$81
        PUSH    EAX
        CALL    dword ptr [ECX].vmtDestroy
        POP     EAX
        CALL    _ClassDestroy
@@skip:
        {       reraise the exception   }
        CALL    _RaiseAgain
end;


procedure       _ClassDestroy;
asm
        MOV     EDX,[EAX]
        CALL    dword ptr [EDX].vmtFreeInstance
end;


procedure _AfterConstruction;
asm
        { ->  EAX = pointer to instance }

        PUSH    EAX
        MOV     EDX,[EAX]
        CALL    dword ptr [EDX].vmtAfterConstruction
        POP     EAX
end;

procedure _BeforeDestruction;
asm
        { ->  EAX  = pointer to instance }
        {      DL  = dealloc flag        }

        TEST    DL,DL
        JG      @@outerMost
        RET
@@outerMost:
        PUSH    EAX
        PUSH    EDX
        MOV     EDX,[EAX]
        CALL    dword ptr [EDX].vmtBeforeDestruction
        POP     EDX
        POP     EAX
end;

{
  The following NotifyXXXX routines are used to "raise" special exceptions
  as a signaling mechanism to an interested debugger.  If the debugger sets
  the DebugHook flag to 1 or 2, then all exception processing is tracked by
  raising these special exceptions.  The debugger *MUST* respond to the
  debug event with DBG_CONTINE so that normal processing will occur.
}

{ tell the debugger that the next raise is a re-raise of the current non-Delphi
  exception }
procedure       NotifyReRaise;
asm
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    0
        PUSH    0
        PUSH    cContinuable
        PUSH    cDelphiReRaise
        CALL    RaiseException
@@1:
end;

{ tell the debugger about the raise of a non-Delphi exception }
procedure       NotifyNonDelphiException;
asm
        CMP     BYTE PTR DebugHook,0
        JE      @@1
        PUSH    EAX
        PUSH    EAX
        PUSH    EDX
        PUSH    ESP
        PUSH    2
        PUSH    cContinuable
        PUSH    cNonDelphiException
        CALL    RaiseException
        ADD     ESP,8
        POP     EAX
@@1:
end;

{ Tell the debugger where the handler for the current exception is located }
procedure       NotifyExcept;
asm
        PUSH    ESP
        PUSH    1
        PUSH    cContinuable
        PUSH    cDelphiExcept           { our magic exception code }
        CALL    RaiseException
        ADD     ESP,4
        POP     EAX
end;

procedure       NotifyOnExcept;
asm
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    EAX
        PUSH    [EBX].TExcDescEntry.handler
        JMP     NotifyExcept
@@1:
end;

procedure       NotifyAnyExcept;
asm
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    EAX
        PUSH    EBX
        JMP     NotifyExcept
@@1:
end;

procedure       CheckJmp;
asm
        TEST    ECX,ECX
        JE      @@3
        MOV     EAX,[ECX + 1]
        CMP     BYTE PTR [ECX],0E9H { near jmp }
        JE      @@1
        CMP     BYTE PTR [ECX],0EBH { short jmp }
        JNE     @@3
        MOVSX   EAX,AL
        INC     ECX
        INC     ECX
        JMP     @@2
@@1:
        ADD     ECX,5
@@2:
        ADD     ECX,EAX
@@3:
end;

{ Notify debugger of a finally during an exception unwind }
procedure       NotifyExceptFinally;
asm
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    EAX
        PUSH    EDX
        PUSH    ECX
        CALL    CheckJmp
        PUSH    ECX
        PUSH    ESP                     { pass pointer to arguments }
        PUSH    1                       { there is 1 argument }
        PUSH    cContinuable            { continuable execution }
        PUSH    cDelphiFinally          { our magic exception code }
        CALL    RaiseException
        POP     ECX
        POP     ECX
        POP     EDX
        POP     EAX
@@1:
end;


{ Tell the debugger that the current exception is handled and cleaned up.
  Also indicate where execution is about to resume. }
procedure       NotifyTerminate;
asm
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    EDX
        PUSH    ESP
        PUSH    1
        PUSH    cContinuable
        PUSH    cDelphiTerminate        { our magic exception code }
        CALL    RaiseException
        POP     EDX
@@1:
end;

{ Tell the debugger that there was no handler found for the current execption
  and we are about to go to the default handler }
procedure       NotifyUnhandled;
asm
        PUSH    EAX
        PUSH    EDX
        CMP     BYTE PTR DebugHook,1
        JBE     @@1
        PUSH    ESP
        PUSH    2
        PUSH    cContinuable
        PUSH    cDelphiUnhandled
        CALL    RaiseException
@@1:
        POP     EDX
        POP     EAX
end;


procedure       _HandleAnyException;
asm
        { ->    [ESP+ 4] excPtr: PExceptionRecord       }
        {       [ESP+ 8] errPtr: PExcFrame              }
        {       [ESP+12] ctxPtr: Pointer                }
        {       [ESP+16] dspPtr: Pointer                }
        { <-    EAX return value - always one   }

        MOV     EAX,[ESP+4]
        TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
        JNE     @@exit

        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        MOV     EDX,[EAX].TExceptionRecord.ExceptObject
        MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
        JE      @@DelphiException
        CLD
        CALL    FpuInit
        MOV     EDX,ExceptObjProc
        TEST    EDX,EDX
        JE      @@exit
        CALL    EDX
        TEST    EAX,EAX
        JE      @@exit
        MOV     EDX,[ESP+12]
        MOV     ECX,[ESP+4]
        CMP     [ECX].TExceptionRecord.ExceptionCode,cCppException
        JE      @@CppException
        CALL    NotifyNonDelphiException
        CMP     BYTE PTR JITEnable,0
        JBE     @@CppException
        CMP     BYTE PTR DebugHook,0
        JA      @@CppException                     { Do not JIT if debugging }
        LEA     ECX,[ESP+4]
        PUSH    EAX
        PUSH    ECX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        POP     EAX
        JE      @@exit
        MOV     EDX,EAX
        MOV     EAX,[ESP+4]
        MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
        JMP     @@GoUnwind

@@CppException:
        MOV     EDX,EAX
        MOV     EAX,[ESP+4]
        MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress

@@DelphiException:
        CMP     BYTE PTR JITEnable,1
        JBE     @@GoUnwind
        CMP     BYTE PTR DebugHook,0                { Do not JIT if debugging }
        JA      @@GoUnwind
        PUSH    EAX
        LEA     EAX,[ESP+8]
        PUSH    EDX
        PUSH    ECX
        PUSH    EAX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        POP     ECX
        POP     EDX
        POP     EAX
        JE      @@exit

@@GoUnwind:
        OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding

        PUSH    EBX
        XOR     EBX,EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EBX,FS:[EBX]
        PUSH    EBX                     { Save pointer to topmost frame }
        PUSH    EAX                     { Save OS exception pointer     }
        PUSH    EDX                     { Save exception object         }
        PUSH    ECX                     { Save exception address        }

        MOV     EDX,[ESP+8+8*4]

        PUSH    0
        PUSH    EAX
        PUSH    offset @@returnAddress
        PUSH    EDX
        CALL    RtlUnwind
@@returnAddress:

        MOV     EDI,[ESP+8+8*4]

        {       Make the RaiseList entry on the stack }

        CALL    SysInit.@GetTLS
        PUSH    [EAX].RaiseListPtr
        MOV     [EAX].RaiseListPtr,ESP

        MOV     EBP,[EDI].TExcFrame.hEBP
        MOV     EBX,[EDI].TExcFrame.desc
        MOV     [EDI].TExcFrame.desc,offset @@exceptFinally

        ADD     EBX,TExcDesc.instructions
        CALL    NotifyAnyExcept
        JMP     EBX

@@exceptFinally:
        JMP     _HandleFinally

@@destroyExcept:
        {       we come here if an exception handler has thrown yet another exception }
        {       we need to destroy the exception object and pop the raise list. }

        CALL    SysInit.@GetTLS
        MOV     ECX,[EAX].RaiseListPtr
        MOV     EDX,[ECX].TRaiseFrame.NextRaise
        MOV     [EAX].RaiseListPtr,EDX

        MOV     EAX,[ECX].TRaiseFrame.ExceptObject
        JMP     TObject.Free

@@exit:
        MOV     EAX,1
end;


procedure       _HandleOnException;
asm
        { ->    [ESP+ 4] excPtr: PExceptionRecord       }
        {       [ESP+ 8] errPtr: PExcFrame              }
        {       [ESP+12] ctxPtr: Pointer                }
        {       [ESP+16] dspPtr: Pointer                }
        { <-    EAX return value - always one   }

        MOV     EAX,[ESP+4]
        TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
        JNE     @@exit

        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        JE      @@DelphiException
        CLD
        CALL    FpuInit
        MOV     EDX,ExceptClsProc
        TEST    EDX,EDX
        JE      @@exit
        CALL    EDX
        TEST    EAX,EAX
        JNE     @@common
        JMP     @@exit

@@DelphiException:
        MOV     EAX,[EAX].TExceptionRecord.ExceptObject
        MOV     EAX,[EAX]                       { load vtable of exception object       }

@@common:

        MOV     EDX,[ESP+8]

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     ECX,[EDX].TExcFrame.desc
        MOV     EBX,[ECX].TExcDesc.cnt
        LEA     ESI,[ECX].TExcDesc.excTab       { point ECX to exc descriptor table }
        MOV     EBP,EAX                         { load vtable of exception object }

@@innerLoop:
        MOV     EAX,[ESI].TExcDescEntry.vTable
        TEST    EAX,EAX                         { catch all clause?                     }
        JE      @@doHandler                     { yes: go execute handler               }
        MOV     EDI,EBP                         { load vtable of exception object       }
        JMP     @@haveVMT

@@vtLoop:
        MOV     EDI,[EDI]
@@haveVMT:
        MOV     EAX,[EAX]
        CMP     EAX,EDI
        JE      @@doHandler

        MOV     ECX,[EAX].vmtInstanceSize
        CMP     ECX,[EDI].vmtInstanceSize
        JNE     @@parent

        MOV     EAX,[EAX].vmtClassName
        MOV     EDX,[EDI].vmtClassName

        XOR     ECX,ECX
        MOV     CL,[EAX]
        CMP     CL,[EDX]
        JNE     @@parent

        INC     EAX
        INC     EDX
        CALL    _AStrCmp
        JE      @@doHandler

@@parent:
        MOV     EDI,[EDI].vmtParent             { load vtable of parent         }
        MOV     EAX,[ESI].TExcDescEntry.vTable
        TEST    EDI,EDI
        JNE     @@vtLoop

        ADD     ESI,8
        DEC     EBX
        JNZ     @@innerLoop

        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     @@exit

@@doHandler:
        MOV     EAX,[ESP+4+4*4]
        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        MOV     EDX,[EAX].TExceptionRecord.ExceptObject
        MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
        JE      @@haveObject
        CALL    ExceptObjProc
        MOV     EDX,[ESP+12+4*4]
        CALL    NotifyNonDelphiException
        CMP     BYTE PTR JITEnable,0
        JBE     @@NoJIT
        CMP     BYTE PTR DebugHook,0
        JA      @@noJIT                 { Do not JIT if debugging }
        LEA     ECX,[ESP+4]
        PUSH    EAX
        PUSH    ECX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        POP     EAX
        JE      @@exit
@@noJIT:
        MOV     EDX,EAX
        MOV     EAX,[ESP+4+4*4]
        MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
        JMP     @@GoUnwind

@@haveObject:
        CMP     BYTE PTR JITEnable,1
        JBE     @@GoUnwind
        CMP     BYTE PTR DebugHook,0
        JA      @@GoUnwind
        PUSH    EAX
        LEA     EAX,[ESP+8]
        PUSH    EDX
        PUSH    ECX
        PUSH    EAX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        POP     ECX
        POP     EDX
        POP     EAX
        JE      @@exit

@@GoUnwind:
        XOR     EBX,EBX
        MOV     EBX,FS:[EBX]
        PUSH    EBX                     { Save topmost frame     }
        PUSH    EAX                     { Save exception record  }
        PUSH    EDX                     { Save exception object  }
        PUSH    ECX                     { Save exception address }

        MOV     EDX,[ESP+8+8*4]
        OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding

        PUSH    ESI                     { Save handler entry     }

        PUSH    0
        PUSH    EAX
        PUSH    offset @@returnAddress
        PUSH    EDX
        CALL    RtlUnwind
@@returnAddress:

        POP     EBX                     { Restore handler entry  }

        MOV     EDI,[ESP+8+8*4]

        {       Make the RaiseList entry on the stack }

        CALL    SysInit.@GetTLS
        PUSH    [EAX].RaiseListPtr
        MOV     [EAX].RaiseListPtr,ESP

        MOV     EBP,[EDI].TExcFrame.hEBP
        MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
        MOV     EAX,[ESP].TRaiseFrame.ExceptObject
        CALL    NotifyOnExcept
        JMP     [EBX].TExcDescEntry.handler

@@exceptFinally:
        JMP     _HandleFinally

@@destroyExcept:
        {       we come here if an exception handler has thrown yet another exception }
        {       we need to destroy the exception object and pop the raise list. }

        CALL    SysInit.@GetTLS
        MOV     ECX,[EAX].RaiseListPtr
        MOV     EDX,[ECX].TRaiseFrame.NextRaise
        MOV     [EAX].RaiseListPtr,EDX

        MOV     EAX,[ECX].TRaiseFrame.ExceptObject
        JMP     TObject.Free
@@exit:
        MOV     EAX,1
end;


procedure       _HandleFinally;
asm
        { ->    [ESP+ 4] excPtr: PExceptionRecord       }
        {       [ESP+ 8] errPtr: PExcFrame              }
        {       [ESP+12] ctxPtr: Pointer                }
        {       [ESP+16] dspPtr: Pointer                }
        { <-    EAX return value - always one   }

        MOV     EAX,[ESP+4]
        MOV     EDX,[ESP+8]
        TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
        JE      @@exit
        MOV     ECX,[EDX].TExcFrame.desc
        MOV     [EDX].TExcFrame.desc,offset @@exit

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EBP,[EDX].TExcFrame.hEBP
        ADD     ECX,TExcDesc.instructions
        CALL    NotifyExceptFinally
        CALL    ECX

        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX

@@exit:
        MOV     EAX,1
end;


procedure       _HandleAutoException;
asm
        { ->    [ESP+ 4] excPtr: PExceptionRecord       }
        {       [ESP+ 8] errPtr: PExcFrame              }
        {       [ESP+12] ctxPtr: Pointer                }
        {       [ESP+16] dspPtr: Pointer                }
        { <-    EAX return value - always one           }

        MOV     EAX,[ESP+4]
        TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
        JNE     @@exit

        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        CLD
        CALL    FpuInit
        JE      @@DelphiException
        CMP     BYTE PTR JITEnable,0
        JBE     @@DelphiException
        CMP     BYTE PTR DebugHook,0
        JA      @@DelphiException

@@DoUnhandled:
        LEA     EAX,[ESP+4]
        PUSH    EAX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        JE      @@exit
        MOV     EAX,[ESP+4]
        JMP     @@GoUnwind

@@DelphiException:
        CMP     BYTE PTR JITEnable,1
        JBE     @@GoUnwind
        CMP     BYTE PTR DebugHook,0
        JA      @@GoUnwind
        JMP     @@DoUnhandled

@@GoUnwind:
        OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding

        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EDX,[ESP+8+3*4]

        PUSH    0
        PUSH    EAX
        PUSH    offset @@returnAddress
        PUSH    EDX
        CALL    RtlUnwind

@@returnAddress:
        POP     EBP
        POP     EDI
        POP     ESI
        MOV     EAX,[ESP+4]
        MOV     EBX,8000FFFFH
        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        JNE     @@done

        MOV     EDX,[EAX].TExceptionRecord.ExceptObject
        MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
        MOV     EAX,[ESP+8]
        MOV     EAX,[EAX].TExcFrame.SelfOfMethod
        MOV     EBX,[EAX]
        CALL    [EBX].vmtSafeCallException.Pointer
        MOV     EBX,EAX
        MOV     EAX,[ESP+4]
        MOV     EAX,[EAX].TExceptionRecord.ExceptObject
        CALL    TObject.Free
@@done:
        XOR     EAX,EAX
        MOV     ESP,[ESP+8]
        POP     ECX
        MOV     FS:[EAX],ECX
        POP     EDX
        POP     EBP
        LEA     EDX,[EDX].TExcDesc.instructions
        POP     ECX
        JMP     EDX
@@exit:
        MOV     EAX,1
end;


procedure       _RaiseExcept;
asm
        { When making changes to the way Delphi Exceptions are raised, }
        { please realize that the C++ Exception handling code reraises }
        { some exceptions as Delphi Exceptions.  Of course we want to  }
        { keep exception raising compatible between Delphi and C++, so }
        { when you make changes here, consult with the relevant C++    }
        { exception handling engineer. The C++ code is in xx.cpp, in   }
        { the RTL sources, in function tossAnException.                }

        { ->    EAX     Pointer to exception object     }
        {       [ESP]   Error address           }

        POP     EDX

        PUSH    ESP
        PUSH    EBP
        PUSH    EDI
        PUSH    ESI
        PUSH    EBX
        PUSH    EAX                             { pass class argument           }
        PUSH    EDX                             { pass address argument         }

        PUSH    ESP                             { pass pointer to arguments             }
        PUSH    7                               { there are seven arguments               }
        PUSH    cNonContinuable                 { we can't continue execution   }
        PUSH    cDelphiException                { our magic exception code              }
        PUSH    EDX                             { pass the user's return address        }
        JMP     RaiseException
end;


procedure       _RaiseAgain;
asm
        { ->    [ESP        ] return address to user program }
        {       [ESP+ 4     ] raise list entry (4 dwords)    }
        {       [ESP+ 4+ 4*4] saved topmost frame            }
        {       [ESP+ 4+ 5*4] saved registers (4 dwords)     }
        {       [ESP+ 4+ 9*4] return address to OS           }
        { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
        {       [ESP+ 8+10*4] errPtr: PExcFrame              }

        { Point the error handler of the exception frame to something harmless }

        MOV     EAX,[ESP+8+10*4]
        MOV     [EAX].TExcFrame.desc,offset @@exit

        { Pop the RaiseList }

        CALL    SysInit.@GetTLS
        MOV     EDX,[EAX].RaiseListPtr
        MOV     ECX,[EDX].TRaiseFrame.NextRaise
        MOV     [EAX].RaiseListPtr,ECX

        { Destroy any objects created for non-delphi exceptions }

        MOV     EAX,[EDX].TRaiseFrame.ExceptionRecord
        AND     [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
        CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
        JE      @@delphiException
        MOV     EAX,[EDX].TRaiseFrame.ExceptObject
        CALL    TObject.Free
        CALL    NotifyReRaise

@@delphiException:

        XOR     EAX,EAX
        ADD     ESP,5*4
        MOV     EDX,FS:[EAX]
        POP     ECX
        MOV     EDX,[EDX].TExcFrame.next
        MOV     [ECX].TExcFrame.next,EDX

        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
@@exit:
        MOV     EAX,1
end;


procedure       _DoneExcept;
asm
        { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
        {       [ESP+ 8+10*4] errPtr: PExcFrame              }

        { Pop the RaiseList }

        CALL    SysInit.@GetTLS
        MOV     EDX,[EAX].RaiseListPtr
        MOV     ECX,[EDX].TRaiseFrame.NextRaise
        MOV     [EAX].RaiseListPtr,ECX

        { Destroy exception object }

        MOV     EAX,[EDX].TRaiseFrame.ExceptObject
        CALL    TObject.Free

        POP     EDX
        MOV     ESP,[ESP+8+9*4]
        XOR     EAX,EAX
        POP     ECX
        MOV     FS:[EAX],ECX
        POP     EAX
        POP     EBP
        CALL    NotifyTerminate
        JMP     EDX
end;


procedure   _TryFinallyExit;
asm
        XOR     EDX,EDX
        MOV     ECX,[ESP+4].TExcFrame.desc
        MOV     EAX,[ESP+4].TExcFrame.next
        ADD     ECX,TExcDesc.instructions
        MOV     FS:[EDX],EAX
        CALL    ECX
@@1:    RET     12
end;


type
  PInitContext = ^TInitContext;
  TInitContext = record
    OuterContext:   PInitContext;     { saved InitContext   }
    ExcFrame:       PExcFrame;        { bottom exc handler  }
    InitTable:      PackageInfo;      { unit init info      }
    InitCount:      Integer;          { how far we got      }
    Module:         PLibModule;       { ptr to module desc  }
    DLLSaveEBP:     Pointer;          { saved regs for DLLs }
    DLLSaveEBX:     Pointer;          { saved regs for DLLs }
    DLLSaveESI:     Pointer;          { saved regs for DLLs }
    DLLSaveEDI:     Pointer;          { saved regs for DLLs }
    DLLInitState:   Byte;
    ExitProcessTLS: procedure;        { Shutdown for TLS    }
  end;

var
  InitContext: TInitContext;

procedure       RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
asm
        MOV     [ESP],ErrorAddr
        JMP     _RunError
end;

procedure       MapToRunError(P: PExceptionRecord); stdcall;
const
  STATUS_ACCESS_VIOLATION         = $C0000005;
  STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
  STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
  STATUS_FLOAT_DIVIDE_BY_ZERO     = $C000008E;
  STATUS_FLOAT_INEXACT_RESULT     = $C000008F;
  STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
  STATUS_FLOAT_OVERFLOW           = $C0000091;
  STATUS_FLOAT_STACK_CHECK        = $C0000092;
  STATUS_FLOAT_UNDERFLOW          = $C0000093;
  STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
  STATUS_INTEGER_OVERFLOW         = $C0000095;
  STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
  STATUS_STACK_OVERFLOW           = $C00000FD;
  STATUS_CONTROL_C_EXIT           = $C000013A;
var
  ErrCode: Byte;
begin
  case P.ExceptionCode of
    STATUS_INTEGER_DIVIDE_BY_ZERO:  ErrCode := 200;
    STATUS_ARRAY_BOUNDS_EXCEEDED:   ErrCode := 201;
    STATUS_FLOAT_OVERFLOW:          ErrCode := 205;
    STATUS_FLOAT_INEXACT_RESULT,
    STATUS_FLOAT_INVALID_OPERATION,
    STATUS_FLOAT_STACK_CHECK:       ErrCode := 207;
    STATUS_FLOAT_DIVIDE_BY_ZERO:    ErrCode := 200;
    STATUS_INTEGER_OVERFLOW:        ErrCode := 215;
    STATUS_FLOAT_UNDERFLOW,
    STATUS_FLOAT_DENORMAL_OPERAND:  ErrCode := 206;
    STATUS_ACCESS_VIOLATION:        ErrCode := 216;
    STATUS_PRIVILEGED_INSTRUCTION:  ErrCode := 218;
    STATUS_CONTROL_C_EXIT:          ErrCode := 217;
    STATUS_STACK_OVERFLOW:          ErrCode := 202;
  else                              ErrCode := 255;
  end;
  RunErrorAt(ErrCode, P.ExceptionAddress);
end;

procedure       _ExceptionHandler;
asm
        MOV     EAX,[ESP+4]

        TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
        JNE     @@exit
        CMP     BYTE PTR DebugHook,0
        JA      @@ExecuteHandler
        LEA     EAX,[ESP+4]
        PUSH    EAX
        CALL    UnhandledExceptionFilter
        CMP     EAX,EXCEPTION_CONTINUE_SEARCH
        JNE     @@ExecuteHandler
        JMP     @@exit
//        MOV     EAX,1
//        RET

@@ExecuteHandler:
        MOV     EAX,[ESP+4]
        CLD
        CALL    FpuInit
        MOV     EDX,[ESP+8]

        PUSH    0
        PUSH    EAX
        PUSH    offset @@returnAddress
        PUSH    EDX
        CALL    RtlUnwind
@@returnAddress:

        MOV     EBX,[ESP+4]
        CMP     [EBX].TExceptionRecord.ExceptionCode,cDelphiException
        MOV     EDX,[EBX].TExceptionRecord.ExceptAddr
        MOV     EAX,[EBX].TExceptionRecord.ExceptObject
        JE      @@DelphiException2

        MOV     EDX,ExceptObjProc
        TEST    EDX,EDX
        JE      MapToRunError
        MOV     EAX,EBX
        CALL    EDX
        TEST    EAX,EAX
        JE      MapToRunError
        MOV     EDX,[EBX].TExceptionRecord.ExceptionAddress

@@DelphiException2:

        CALL    NotifyUnhandled
        MOV     ECX,ExceptProc
        TEST    ECX,ECX
        JE      @@noExceptProc
        CALL    ECX             { call ExceptProc(ExceptObject, ExceptAddr) }

@@noExceptProc:
        MOV     ECX,[ESP+4]
        MOV     EAX,217
        MOV     EDX,[ECX].TExceptionRecord.ExceptAddr
        MOV     [ESP],EDX
        JMP     _RunError

@@exit:
        XOR     EAX,EAX
end;


procedure       SetExceptionHandler;
asm
        XOR     EDX,EDX                 { using [EDX] saves some space over [0] }
{X}     // now we come here from another place, and EBP is used above for loop counter
{X}     // let us restore it...
{X}     PUSH    EBP
{X}     LEA     EBP, [ESP + $60]

        LEA     EAX,[EBP-12]

        MOV     ECX,FS:[EDX]            { ECX := head of chain                  }
        MOV     FS:[EDX],EAX            { head of chain := @exRegRec            }

        MOV     [EAX].TExcFrame.next,ECX
        MOV     [EAX].TExcFrame.desc,offset _ExceptionHandler
        MOV     [EAX].TExcFrame.hEBP,EBP
        MOV     InitContext.ExcFrame,EAX

{X}     POP     EBP
end;


procedure       UnsetExceptionHandler;
asm
        XOR     EDX,EDX
        MOV     EAX,InitContext.ExcFrame
        MOV     ECX,FS:[EDX]    { ECX := head of chain          }
        CMP     EAX,ECX         { simple case: our record is first      }
        JNE     @@search
        MOV     EAX,[EAX]       { head of chain := exRegRec.next        }
        MOV     FS:[EDX],EAX
        JMP     @@exit

@@loop:
        MOV     ECX,[ECX]
@@search:
        CMP     ECX,-1          { at end of list?                       }
        JE      @@exit          { yes - didn't find it          }
        CMP     [ECX],EAX       { is it the next one on the list?       }
        JNE     @@loop          { no - look at next one on list }
@@unlink:                       { yes - unlink our record               }
        MOV     EAX,[EAX]       { get next record on list               }
        MOV     [ECX],EAX       { unlink our record                     }
@@exit:
end;


{X+ see comments in InitUnits below }
//procedure FInitUnits; {X} - renamed to FInitUnitsHard
{X} procedure FInitUnitsHard;
var
  Count: Integer;
  Table: PUnitEntryTable;
  P: procedure;
begin
  if InitContext.InitTable = nil then
        exit;
  Count := InitContext.InitCount;
  Table := InitContext.InitTable^.UnitInfo;
  try
    while Count > 0 do
    begin
      Dec(Count);
      InitContext.InitCount := Count;
      P := Table^[Count].FInit;
      if Assigned(P) then
        P;
    end;
  except
    {X- rename: FInitUnits;  { try to finalize the others }
    FInitUnitsHard;
    raise;
  end;
end;

// This handler can be set in initialization section of
// unit SysSfIni.pas only.
procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer );
begin
  try
    InitUnitsLight( Table, Idx, Count );
  except
    FInitUnitsHard;
    raise;
  end;
end;

{X+ see comments in InitUnits below }
procedure FInitUnitsLight;
var
  Count: Integer;
  Table: PUnitEntryTable;
  P: procedure;
begin
  if InitContext.InitTable = nil then
        exit;
  Count := InitContext.InitCount;
  Table := InitContext.InitTable^.UnitInfo;
  while Count > 0 do
  begin
    Dec(Count);
    InitContext.InitCount := Count;
    P := Table^[Count].FInit;
    if Assigned(P) then
      P;
  end;
end;

{X+ see comments in InitUnits below }
procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer );
var P : procedure;
    Light : Boolean;
begin
  Light := @InitUnitsProc = @InitUnitsLight;
  while Idx < Count do
  begin
    P := Table^[ Idx ].Init;
    Inc( Idx );
    InitContext.InitCount := Idx;
    if Assigned( P ) then
      P;
    if Light and (@InitUnitsProc <> @InitUnitsLight) then
    begin
      InitUnitsProc( Table, Idx, Count );
      break;
    end;
  end;
end;

{X+ see comments in body of InitUnits below }
procedure InitUnits;
var
  Count, I: Integer;
  Table: PUnitEntryTable;
  {X- P: procedure; }
begin
  if InitContext.InitTable = nil then
    exit;
  Count := InitContext.InitTable^.UnitCount;
  I := 0;
  Table := InitContext.InitTable^.UnitInfo;
  {X- by default, Delphi InitUnits uses try-except & raise constructions,
      which leads to permanent use of all exception handler routines.
      Let us make this by another way.
  try
    while I < Count do
    begin
      P := Table^[I].Init;
      Inc(I);
      InitContext.InitCount := I;
      if Assigned(P) then
        P;
    end;
  except
    FInitUnits;
    raise;
  end;
  X+}
  InitUnitsProc( Table, I, Count );
end;


procedure _PackageLoad(const Table : PackageInfo);
var
  SavedContext: TInitContext;
begin
  SavedContext := InitContext;
  InitContext.DLLInitState := 0;
  InitContext.InitTable := Table;
  InitContext.InitCount := 0;
  InitContext.OuterContext := @SavedContext;
  try
    InitUnits;
  finally
    InitContext := SavedContext;
  end;
end;


procedure _PackageUnload(const Table : PackageInfo);
var
  SavedContext: TInitContext;
begin
  SavedContext := InitContext;
  InitContext.DLLInitState := 0;
  InitContext.InitTable := Table;
  InitContext.InitCount := Table^.UnitCount;
  InitContext.OuterContext := @SavedContext;
  try
  FInitUnitsProc;
  finally
  InitContext := SavedContext;
  end;
end;


procedure       _StartExe;
asm
        { ->    EAX InitTable   }
        {       EDX Module      }
        MOV     InitContext.InitTable,EAX
        XOR     EAX,EAX
        MOV     InitContext.InitCount,EAX
        MOV     InitContext.Module,EDX
        MOV     EAX,[EDX].TLibModule.Instance
        MOV     MainInstance,EAX

        {X CALL    SetExceptionHandler - moved to SysSfIni.pas }

        MOV     IsLibrary,0

        CALL    InitUnits;
end;


procedure       _StartLib;
asm
        { ->    EAX InitTable   }
        {       EDX Module      }
        {       ECX InitTLS     }
        {       [ESP+4] DllProc }
        {       [EBP+8] HInst   }
        {       [EBP+12] Reason }

        { Push some desperately needed registers }

        PUSH    ECX
        PUSH    ESI
        PUSH    EDI

        { Save the current init context into the stackframe of our caller }

        MOV     ESI,offset InitContext
        LEA     EDI,[EBP- (type TExcFrame) - (type TInitContext)]
        MOV     ECX,(type TInitContext)/4
        REP     MOVSD

        { Setup the current InitContext }

        POP     InitContext.DLLSaveEDI
        POP     InitContext.DLLSaveESI
        MOV     InitContext.DLLSaveEBP,EBP
        MOV     InitContext.DLLSaveEBX,EBX
        MOV     InitContext.InitTable,EAX
        MOV     InitContext.Module,EDX
        LEA     ECX,[EBP- (type TExcFrame) - (type TInitContext)]
        MOV     InitContext.OuterContext,ECX
        XOR     ECX,ECX
        CMP     dword ptr [EBP+12],0
        JNE     @@notShutDown
        MOV     ECX,[EAX].PackageInfoTable.UnitCount
@@notShutDown:
        MOV     InitContext.InitCount,ECX

        CALL    SetExceptionHandler {X-- could be moved to SysSfIni.pas but ...}

        MOV     EAX,[EBP+12]
        INC     EAX
        MOV     InitContext.DLLInitState,AL
        DEC     EAX

        { Init any needed TLS }

        POP     ECX
        MOV     EDX,[ECX]
        MOV     InitContext.ExitProcessTLS,EDX
        JE      @@noTLSproc
        CALL    dword ptr [ECX+EAX*4]
@@noTLSproc:

        { Call any DllProc }

        MOV     EDX,[ESP+4]
        TEST    EDX,EDX
        JE      @@noDllProc
        MOV     EAX,[EBP+12]
        CALL    EDX
@@noDllProc:

        { Set IsLibrary if there was no exe yet }

        CMP     MainInstance,0
        JNE     @@haveExe
        MOV     IsLibrary,1
        FNSTCW  Default8087CW   // save host exe's FPU preferences

@@haveExe:

        MOV     EAX,[EBP+12]
        DEC     EAX
        JNE     _Halt0
        CALL    InitUnits
        RET     4
end;


procedure _InitResStrings;
asm
        { ->    EAX     Pointer to init table               }
        {                 record                            }
        {                   cnt: Integer;                   }
        {                   tab: array [1..cnt] record      }
        {                      variableAddress: Pointer;    }
        {                      resStringAddress: Pointer;   }
        {                   end;                            }
        {                 end;                              }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,[EAX]
        LEA     ESI,[EAX+4]
@@loop:
        MOV     EAX,[ESI+4]   { load resStringAddress   }
        MOV     EDX,[ESI]         { load variableAddress    }
        CALL    LoadResString
        ADD     ESI,8
        DEC     EBX
        JNZ     @@loop

        POP     ESI
        POP     EBX
end;

procedure _InitResStringImports;
asm
        { ->    EAX     Pointer to init table               }
        {                 record                            }
        {                   cnt: Integer;                   }
        {                   tab: array [1..cnt] record      }
        {                      variableAddress: Pointer;    }
        {                      resStringAddress: ^Pointer;  }
        {                   end;                            }
        {                 end;                              }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,[EAX]
        LEA     ESI,[EAX+4]
@@loop:
        MOV     EAX,[ESI+4]     { load address of import    }
        MOV     EDX,[ESI]       { load address of variable  }
        MOV     EAX,[EAX]       { load contents of import   }
        CALL    LoadResString
        ADD     ESI,8
  DEC     EBX
  JNZ     @@loop

  POP     ESI
  POP     EBX
end;

procedure _InitImports;
asm
        { ->    EAX     Pointer to init table               }
        {                 record                            }
        {                   cnt: Integer;                   }
        {                   tab: array [1..cnt] record      }
        {                      variableAddress: Pointer;    }
        {                      sourceAddress: ^Pointer;     }
        {                      sourceOffset: Longint;       }
        {                   end;                            }
        {                 end;                              }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,[EAX]
        LEA     ESI,[EAX+4]
@@loop:
        MOV     EAX,[ESI+4]     { load address of import    }
        MOV     EDX,[ESI]       { load address of variable  }
        MOV     ECX,[ESI+8]     { load offset               }
        MOV     EAX,[EAX]       { load contents of import   }
        ADD     EAX,ECX         { calc address of variable  }
        MOV     [EDX],EAX       { store result              }
        ADD     ESI,12
        DEC     EBX
        JNZ     @@loop

        POP     ESI
        POP     EBX
end;

procedure _InitWideStrings;
asm
        { ->    EAX     Pointer to init table               }
        {                 record                            }
        {                   cnt: Integer;                   }
        {                   tab: array [1..cnt] record      }
        {                      variableAddress: Pointer;    }
        {                      stringAddress: ^Pointer;     }
        {                   end;                            }
        {                 end;                              }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,[EAX]
        LEA     ESI,[EAX+4]
@@loop:
  MOV     EDX,[ESI+4]     { load address of string    }
  MOV     EAX,[ESI]       { load address of variable  }
  CALL    _WStrAsg
  ADD     ESI,8
  DEC     EBX
  JNZ     @@loop

  POP     ESI
  POP     EBX
end;

var
  runErrMsg: array[0..29] of Char = 'Runtime error     at 00000000'#0;
                        // columns:  0123456789012345678901234567890
  errCaption: array[0..5] of Char = 'Error'#0;


procedure MakeErrorMessage;
const
  dig : array [0..15] of Char = '0123456789ABCDEF';
asm
        PUSH    EBX
        MOV     EAX,ExitCode
        MOV     EBX,offset runErrMsg + 16
        MOV     ECX,10

@@digLoop:
        XOR     EDX,EDX
        DIV     ECX
        ADD     DL,'0'
        MOV     [EBX],DL
        DEC     EBX
        TEST    EAX,EAX
        JNZ     @@digLoop

    MOV     EAX,ErrorAddr

        CALL    FindHInstance
        MOV     EDX, ErrorAddr
        XCHG    EAX, EDX
        SUB     EAX, EDX           { EAX <=> offset from start of code for HINSTANCE }
        MOV     EBX,offset runErrMsg + 28

@@hdigLoop:
        MOV     EDX,EAX
        AND     EDX,0FH
        MOV     DL,byte ptr dig[EDX]
        MOV     [EBX],DL
        DEC     EBX
        SHR     EAX,4
        JNE     @@hdigLoop
        POP     EBX
end;


procedure       ExitDll;
asm
        { Restore the InitContext }

        MOV     EDI,offset InitContext

        MOV     EBX,InitContext.DLLSaveEBX
        MOV     EBP,InitContext.DLLSaveEBP
        PUSH    [EDI].TInitContext.DLLSaveESI
        PUSH    [EDI].TInitContext.DLLSaveEDI

        MOV     ESI,[EDI].TInitContext.OuterContext
        MOV     ECX,(type TInitContext)/4
        REP     MOVSD
        POP     EDI
        POP     ESI

        { Return False if ExitCode <> 0, and set ExitCode to 0 }

        XOR     EAX,EAX
        XCHG    EAX,ExitCode
        NEG     EAX
        SBB     EAX,EAX
        INC     EAX
        LEAVE
        RET     12
end;

// {X} Procedure Halt0 refers to WriteLn and MessageBox
//     but actually such code can be not used really.
//     So, implementation changed to avoid such references.
//
//     Either call UseErrorMessageBox or UseErrorMessageWrite
//     to provide error message output in GUI or console app.
// {X}+

var ErrorMessageOutProc : procedure = DummyProc;

procedure ErrorMessageBox;
begin
  MakeErrorMessage;
  if not NoErrMsg then
     MessageBox(0, runErrMsg, errCaption, 0);
end;

procedure UseErrorMessageBox;
begin
  ErrorMessageOutProc := ErrorMessageBox;
end;

procedure ErrorMessageWrite;
begin
  MakeErrorMessage;
  WriteLn(PChar(@runErrMsg));
end;

procedure UseErrorMessageWrite;
begin
  ErrorMessageOutProc := ErrorMessageWrite;
end;

procedure DoCloseInputOutput;
begin
  Close( Input );
  Close( Output );
end;

var CloseInputOutput : procedure;

procedure UseInputOutput;
begin
  if not assigned( CloseInputOutput ) then
  begin
    CloseInputOutput := DoCloseInputOutput;
    _Assign( Input, '' );
    _Assign( Output, '' );
  end;
end;

// {X}-

procedure _Halt0;
var
  P: procedure;
begin

  if InitContext.DLLInitState = 0 then
    while ExitProc <> nil do
    begin
      @P := ExitProc;
      ExitProc := nil;
      P;
    end;

  { If there was some kind of runtime error, alert the user }

  if ErrorAddr <> nil then
  begin
    {X+}
    ErrorMessageOutProc;
    {
    MakeErrorMessage;
    if IsConsole then
      WriteLn(PChar(@runErrMsg))
    else if not NoErrMsg then
      MessageBox(0, runErrMsg, errCaption, 0);
    } {X-}

    {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr
        to make possible check ErrorAddr <> nil in finalization of rest units.
        If You want, You can uncomment it again: }
    //ErrorAddr := nil;
    {X+}
  end;

  { This loop exists because we might be nested in PackageLoad calls when }
  { Halt got called. We need to unwind these contexts.                    }

  while True do
  begin

    { If we are a library, and we are starting up fine, there are no units to finalize }

    if (InitContext.DLLInitState = 2) and (ExitCode = 0) then
      InitContext.InitCount := 0;

    { Undo any unit initializations accomplished so far }

    FInitUnitsProc;

    if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then
      if InitContext.Module <> nil then
        with InitContext do
        begin
          UnregisterModule(Module);
          if Module.ResInstance <> Module.Instance then
            FreeLibrary(Module.ResInstance);
        end;

    {X UnsetExceptionHandler; - changed to call of handler }
    UnsetExceptionHandlerProc;

    if InitContext.DllInitState = 1 then
      InitContext.ExitProcessTLS;

    if InitContext.DllInitState <> 0 then
      ExitDll;

    if InitContext.OuterContext = nil then
      ExitProcess(ExitCode);

    InitContext := InitContext.OuterContext^
  end;

  asm
    db 'Portions Copyright (c) 1983,99 Borland',0
  end;

end;


procedure _Halt;
asm
        MOV     ExitCode,EAX
        JMP     _Halt0
end;


procedure _Run0Error;
asm
        XOR     EAX,EAX
        JMP     _RunError
end;


procedure _RunError;
asm
        POP     ErrorAddr
        JMP     _Halt
end;


procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
asm
        CMP     AssertErrorProc,0
        JE      @@1
        PUSH    [ESP].Pointer
        CALL    AssertErrorProc
        RET
@@1:    MOV     AL,reAssertionFailed
        JMP     Error
end;

type
  PThreadRec = ^TThreadRec;
  TThreadRec = record
    Func: TThreadFunc;
    Parameter: Pointer;
  end;


function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
asm
        CALL    FpuInit
        XOR     ECX,ECX
        PUSH    EBP
        PUSH    offset _ExceptionHandler
        MOV     EDX,FS:[ECX]
        PUSH    EDX
        MOV     EAX,Parameter
        MOV     FS:[ECX],ESP

        MOV     ECX,[EAX].TThreadRec.Parameter
        MOV     EDX,[EAX].TThreadRec.Func
        PUSH    ECX
        PUSH    EDX
        CALL    _FreeMem
        POP     EDX
        POP     EAX
        CALL    EDX

        XOR     EDX,EDX
        POP     ECX
        MOV     FS:[EDX],ECX
        POP     ECX
        POP     EBP
end;


function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
  ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
  var ThreadId: LongWord): Integer;
var
  P: PThreadRec;
begin
  New(P);
  P.Func := ThreadFunc;
  P.Parameter := Parameter;
  IsMultiThread := TRUE;
  Result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
    CreationFlags, ThreadID);
end;


procedure EndThread(ExitCode: Integer);
begin
  ExitThread(ExitCode);
end;


type
  StrRec = packed record
    allocSiz: Longint;
    refCnt: Longint;
    length: Longint;
  end;

const
        skew = sizeof(StrRec);
        rOff = sizeof(StrRec) - sizeof(Longint); { refCnt offset }
        overHead = sizeof(StrRec) + 1;


procedure _LStrClr(var S: AnsiString);
asm
        { ->    EAX pointer to str      }

        MOV     EDX,[EAX]                       { fetch str                     }
        TEST    EDX,EDX                         { if nil, nothing to do         }
        JE      @@done
        MOV     dword ptr [EAX],0               { clear str                     }
        MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
        DEC     ECX                             { if < 0: literal str           }
        JL      @@done
{X LOCK} DEC     [EDX-skew].StrRec.refCnt        { NONthreadsafe dec refCount       }
        JNE     @@done
        PUSH    EAX
        LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
        CALL    _FreeMem
        POP     EAX
@@done:
end;


procedure       _LStrArrayClr{var str: AnsiString; cnt: longint};
asm
        { ->    EAX pointer to str      }
        {       EDX cnt         }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EDX

@@loop:
        MOV     EDX,[EBX]                       { fetch str                     }
        TEST    EDX,EDX                         { if nil, nothing to do         }
        JE      @@doneEntry
        MOV     dword ptr [EBX],0               { clear str                     }
        MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
        DEC     ECX                             { if < 0: literal str           }
        JL      @@doneEntry
{X LOCK} DEC     [EDX-skew].StrRec.refCnt        { NONthreadsafe dec refCount       }
        JNE     @@doneEntry
        LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
        CALL    _FreeMem
@@doneEntry:
        ADD     EBX,4
        DEC     ESI
        JNE     @@loop

        POP     ESI
        POP     EBX
end;

{ 99.03.11
  This function is used when assigning to global variables.

  Literals are copied to prevent a situation where a dynamically
  allocated DLL or package assigns a literal to a variable and then
  is unloaded -- thereby causing the string memory (in the code
  segment of the DLL) to be removed -- and therefore leaving the
  global variable pointing to invalid memory.
}
procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
asm
        { ->    EAX pointer to dest   str      }
        { ->    EDX pointer to source str      }

        TEST    EDX,EDX                           { have a source? }
        JE      @@2                               { no -> jump     }

        MOV     ECX,[EDX-skew].StrRec.refCnt
        INC     ECX
        JG      @@1                               { literal string -> jump not taken }

        PUSH    EAX
        PUSH    EDX
        MOV     EAX,[EDX-skew].StrRec.length
        CALL    _NewAnsiString
        MOV     EDX,EAX
        POP     EAX
        PUSH    EDX
        MOV     ECX,[EAX-skew].StrRec.length
        CALL    Move
        POP     EDX
        POP     EAX
        JMP     @@2

@@1:
   {X LOCK} INC     [EDX-skew].StrRec.refCnt

@@2:    XCHG    EDX,[EAX]
        TEST    EDX,EDX
        JE      @@3
        MOV     ECX,[EDX-skew].StrRec.refCnt
        DEC     ECX
        JL      @@3
   {X LOCK} DEC     [EDX-skew].StrRec.refCnt
        JNE     @@3
        LEA     EAX,[EDX-skew].StrRec.refCnt
        CALL    _FreeMem
@@3:
end;

procedure       _LStrLAsg{var dest: AnsiString; source: AnsiString};
asm
{ ->    EAX     pointer to dest }
{       EDX     source          }

        TEST    EDX,EDX
        JE      @@sourceDone

        { bump up the ref count of the source }

        MOV     ECX,[EDX-skew].StrRec.refCnt
        INC     ECX
        JLE     @@sourceDone                    { literal assignment -> jump taken }
{X LOCK} INC     [EDX-skew].StrRec.refCnt
@@sourceDone:

        { we need to release whatever the dest is pointing to   }

        XCHG    EDX,[EAX]                       { fetch str                    }
        TEST    EDX,EDX                         { if nil, nothing to do        }
        JE      @@done
        MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                 }
        DEC     ECX                             { if < 0: literal str          }
        JL      @@done
{X LOCK} DEC     [EDX-skew].StrRec.refCnt        { NONthreadsafe dec refCount      }
        JNE     @@done
        LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
        CALL    _FreeMem
@@done:
end;

procedure       _NewAnsiString{length: Longint};
asm
        { ->    EAX     length                  }
        { <-    EAX pointer to new string       }

        TEST    EAX,EAX
        JLE     @@null
        PUSH    EAX
        ADD     EAX,rOff+1
        CALL    _GetMem
        ADD     EAX,rOff
        POP     EDX
        MOV     [EAX-skew].StrRec.length,EDX
        MOV     [EAX-skew].StrRec.refCnt,1
        MOV     byte ptr [EAX+EDX],0
        RET

@@null:
        XOR     EAX,EAX
end;


procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
asm
        { ->    EAX     pointer to dest }
        {       EDX source              }
        {       ECX length              }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        { allocate new string }

        MOV     EAX,EDI

        CALL    _NewAnsiString
        MOV     ECX,EDI
        MOV     EDI,EAX

        TEST    ESI,ESI
        JE      @@noMove

        MOV     EDX,EAX
        MOV     EAX,ESI
        CALL    Move

        { assign the result to dest }

@@noMove:
        MOV     EAX,EBX
        CALL    _LStrClr
        MOV     [EBX],EDI

        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
var
  DestLen: Integer;
  Buffer: array[0..2047] of Char;
begin
  if Length <= 0 then
  begin
    _LStrClr(Dest);
    Exit;
  end;
  if Length < SizeOf(Buffer) div 2 then
  begin
    DestLen := WideCharToMultiByte(0, 0, Source, Length,
      Buffer, SizeOf(Buffer), nil, nil);
    if DestLen > 0 then
    begin
      _LStrFromPCharLen(Dest, Buffer, DestLen);
      Exit;
    end;
  end;
  DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
  _LStrFromPCharLen(Dest, nil, DestLen);
  WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil);
end;


procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
asm
        PUSH    EDX
        MOV     EDX,ESP
        MOV     ECX,1
        CALL    _LStrFromPCharLen
        POP     EDX
end;


procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
asm
        PUSH    EDX
        MOV     EDX,ESP
        MOV     ECX,1
        CALL    _LStrFromPWCharLen
        POP     EDX
end;


procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
asm
        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@5
        PUSH    EDX
@@0:    CMP     CL,[EDX+0]
        JE      @@4
        CMP     CL,[EDX+1]
        JE      @@3
        CMP     CL,[EDX+2]
        JE      @@2
        CMP     CL,[EDX+3]
        JE      @@1
        ADD     EDX,4
        JMP     @@0
@@1:    INC     EDX
@@2:    INC     EDX
@@3:    INC     EDX
@@4:    MOV     ECX,EDX
        POP     EDX
        SUB     ECX,EDX
@@5:    JMP     _LStrFromPCharLen
end;


procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
asm
        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@5
        PUSH    EDX
@@0:    CMP     CX,[EDX+0]
        JE      @@4
        CMP     CX,[EDX+2]
        JE      @@3
        CMP     CX,[EDX+4]
        JE      @@2
        CMP     CX,[EDX+6]
        JE      @@1
        ADD     EDX,8
        JMP     @@0
@@1:    ADD     EDX,2
@@2:    ADD     EDX,2
@@3:    ADD     EDX,2
@@4:    MOV     ECX,EDX
        POP     EDX
        SUB     ECX,EDX
        SHR     ECX,1
@@5:    JMP     _LStrFromPWCharLen
end;


procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
asm
        XOR     ECX,ECX
        MOV     CL,[EDX]
        INC     EDX
        JMP     _LStrFromPCharLen
end;


procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
asm
        PUSH    EDI
        PUSH    EAX
        PUSH    ECX
        MOV     EDI,EDX
        XOR     EAX,EAX
        REPNE   SCASB
        JNE     @@1
        NOT     ECX
@@1:    POP     EAX
        ADD     ECX,EAX
        POP     EAX
        POP     EDI
        JMP     _LStrFromPCharLen
end;


procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
asm
        PUSH    EDI
        PUSH    EAX
        PUSH    ECX
        MOV     EDI,EDX
        XOR     EAX,EAX
        REPNE   SCASW
        JNE     @@1
        NOT     ECX
@@1:    POP     EAX
        ADD     ECX,EAX
        POP     EAX
        POP     EDI
        JMP     _LStrFromPWCharLen
end;


procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
asm
        { ->    EAX pointer to dest              }
        {       EDX pointer to WideString data   }

        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@1
        MOV     ECX,[EDX-4]
        SHR     ECX,1
@@1:    JMP     _LStrFromPWCharLen
end;


procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
asm
        { ->    EAX pointer to result   }
        {       EDX AnsiString s        }
        {       ECX length of result    }

        PUSH    EBX
        TEST    EDX,EDX
        JE      @@empty
        MOV     EBX,[EDX-skew].StrRec.length
        TEST    EBX,EBX
        JE      @@empty

        CMP     ECX,EBX
        JL      @@truncate
        MOV     ECX,EBX
@@truncate:
        MOV     [EAX],CL
        INC     EAX

        XCHG    EAX,EDX
        CALL    Move

        JMP     @@exit

@@empty:
        MOV     byte ptr [EAX],0

@@exit:
        POP     EBX
end;


function        _LStrLen{str: AnsiString}: Longint;
asm
        { ->    EAX str }

        TEST    EAX,EAX
        JE      @@done
        MOV     EAX,[EAX-skew].StrRec.length;
@@done:
end;


procedure       _LStrCat{var dest: AnsiString; source: AnsiString};
asm
        { ->    EAX     pointer to dest }
        {       EDX source              }

        TEST    EDX,EDX
        JE      @@exit

        MOV     ECX,[EAX]
        TEST    ECX,ECX
        JE      _LStrAsg

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,[ECX-skew].StrRec.length

        MOV     EDX,[ESI-skew].StrRec.length
        ADD     EDX,EDI
        CMP     ESI,ECX
        JE      @@appendSelf

        CALL    _LStrSetLength
        MOV     EAX,ESI
        MOV     ECX,[ESI-skew].StrRec.length

@@appendStr:
        MOV     EDX,[EBX]
        ADD     EDX,EDI
        CALL    Move
        POP     EDI
        POP     ESI
        POP     EBX
        RET

@@appendSelf:
        CALL    _LStrSetLength
        MOV     EAX,[EBX]
        MOV     ECX,EDI
        JMP     @@appendStr

@@exit:
end;


procedure       _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
asm
        {     ->EAX = Pointer to dest   }
        {       EDX = source1           }
        {       ECX = source2           }

        TEST    EDX,EDX
        JE      @@assignSource2

        TEST    ECX,ECX
        JE      _LStrAsg

        CMP     EDX,[EAX]
        JE      @@appendToDest

        CMP     ECX,[EAX]
        JE      @@theHardWay

        PUSH    EAX
        PUSH    ECX
        CALL    _LStrAsg

        POP     EDX
        POP     EAX
        JMP     _LStrCat

@@theHardWay:

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EDX
        MOV     ESI,ECX
        PUSH    EAX

        MOV     EAX,[EBX-skew].StrRec.length
        ADD     EAX,[ESI-skew].StrRec.length
        CALL    _NewAnsiString

        MOV     EDI,EAX
        MOV     EDX,EAX
        MOV     EAX,EBX
        MOV     ECX,[EBX-skew].StrRec.length
        CALL    Move

        MOV     EDX,EDI
        MOV     EAX,ESI
        MOV     ECX,[ESI-skew].StrRec.length
        ADD     EDX,[EBX-skew].StrRec.length
        CALL    Move

        POP     EAX
        MOV     EDX,EDI
        TEST    EDI,EDI
        JE      @@skip
        DEC     [EDI-skew].StrRec.refCnt    // EDI = local temp str
@@skip:
        CALL    _LStrAsg

        POP     EDI
        POP     ESI
        POP     EBX

        JMP     @@exit

@@assignSource2:
        MOV     EDX,ECX
        JMP     _LStrAsg

@@appendToDest:
        MOV     EDX,ECX
        JMP     _LStrCat

@@exit:
end;


procedure       _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
asm
        {     ->EAX = Pointer to dest   }
        {       EDX = number of args (>= 3)     }
        {       [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDX
        PUSH    EAX
        MOV     EBX,EDX

        XOR     EAX,EAX
@@loop1:
        MOV     ECX,[ESP+EDX*4+4*4]
        TEST    ECX,ECX
        JE      @@1
        ADD     EAX,[ECX-skew].StrRec.length
@@1:
        DEC     EDX
        JNE     @@loop1

        CALL    _NewAnsiString
        PUSH    EAX
        MOV     ESI,EAX

@@loop2:
        MOV     EAX,[ESP+EBX*4+5*4]
        MOV     EDX,ESI
        TEST    EAX,EAX
        JE      @@2
        MOV     ECX,[EAX-skew].StrRec.length
        ADD     ESI,ECX
        CALL    Move
@@2:
        DEC     EBX
        JNE     @@loop2

        POP     EDX
        POP     EAX
        TEST    EDX,EDX
        JE      @@skip
        DEC     [EDX-skew].StrRec.refCnt   // EDX = local temp str
@@skip:
        CALL    _LStrAsg

        POP     EDX
        POP     ESI
        POP     EBX
        POP     EAX
        LEA     ESP,[ESP+EDX*4]
        JMP     EAX
end;


procedure       _LStrCmp{left: AnsiString; right: AnsiString};
asm
{     ->EAX = Pointer to left string    }
{       EDX = Pointer to right string   }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        CMP     EAX,EDX
        JE      @@exit

        TEST    ESI,ESI
        JE      @@str1null

        TEST    EDI,EDI
        JE      @@str2null

        MOV     EAX,[ESI-skew].StrRec.length
        MOV     EDX,[EDI-skew].StrRec.length

        SUB     EAX,EDX { eax = len1 - len2 }
        JA      @@skip1
        ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }

@@skip1:
        PUSH    EDX
        SHR     EDX,2
        JE      @@cmpRest
@@longLoop:
        MOV     ECX,[ESI]
        MOV     EBX,[EDI]
        CMP     ECX,EBX
        JNE     @@misMatch
        DEC     EDX
        JE      @@cmpRestP4
        MOV     ECX,[ESI+4]
        MOV     EBX,[EDI+4]
        CMP     ECX,EBX
        JNE     @@misMatch
        ADD     ESI,8
        ADD     EDI,8
        DEC     EDX
        JNE     @@longLoop
        JMP     @@cmpRest
@@cmpRestP4:
        ADD     ESI,4
        ADD     EDI,4
@@cmpRest:
        POP     EDX
        AND     EDX,3
        JE      @@equal

        MOV     ECX,[ESI]
        MOV     EBX,[EDI]
        CMP     CL,BL
        JNE     @@exit
        DEC     EDX
        JE      @@equal
        CMP     CH,BH
        JNE     @@exit
        DEC     EDX
        JE      @@equal
        AND     EBX,$00FF0000
        AND     ECX,$00FF0000
        CMP     ECX,EBX
        JNE     @@exit

@@equal:
        ADD     EAX,EAX
        JMP     @@exit

@@str1null:
        MOV     EDX,[EDI-skew].StrRec.length
        SUB     EAX,EDX
        JMP     @@exit

@@str2null:
        MOV     EAX,[ESI-skew].StrRec.length
        SUB     EAX,EDX
        JMP     @@exit

@@misMatch:
        POP     EDX
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH
        JNE     @@exit
        SHR     ECX,16
        SHR     EBX,16
        CMP     CL,BL
        JNE     @@exit
        CMP     CH,BH

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX

end;


procedure       _LStrAddRef{str: AnsiString};
asm
        { ->    EAX     str     }
        TEST    EAX,EAX
        JE      @@exit
        MOV     EDX,[EAX-skew].StrRec.refCnt
        INC     EDX
        JLE     @@exit
{X LOCK} INC     [EAX-skew].StrRec.refCnt
@@exit:
end;


procedure       _LStrToPChar{str: AnsiString): PChar};
asm
        { ->    EAX pointer to str              }
        { <-    EAX pointer to PChar    }

        TEST    EAX,EAX
        JE      @@handle0
        RET
@@zeroByte:
        DB      0
@@handle0:
        MOV     EAX,offset @@zeroByte
end;


procedure       UniqueString(var str: string);
asm
        { ->    EAX pointer to str              }
        { <-    EAX pointer to unique copy      }
        MOV     EDX,[EAX]
        TEST    EDX,EDX
        JE      @@exit
        MOV     ECX,[EDX-skew].StrRec.refCnt
        DEC     ECX
        JE      @@exit

        PUSH    EBX
        MOV     EBX,EAX
        MOV     EAX,[EDX-skew].StrRec.length
        CALL    _NewAnsiString
        MOV     EDX,EAX
        MOV     EAX,[EBX]
        MOV     [EBX],EDX
        MOV     ECX,[EAX-skew].StrRec.refCnt
        DEC     ECX
        JL      @@skip
{X LOCK} DEC     [EAX-skew].StrRec.refCnt
@@skip:
        MOV     ECX,[EAX-skew].StrRec.length
        CALL    Move
        MOV     EDX,[EBX]
        POP     EBX
@@exit:
        MOV     EAX,EDX
end;


procedure       _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
asm
        {     ->EAX     Source string                   }
        {       EDX     index                           }
        {       ECX     count                           }
        {       [ESP+4] Pointer to result string        }

        PUSH    EBX

        TEST    EAX,EAX
        JE      @@srcEmpty

        MOV     EBX,[EAX-skew].StrRec.length
        TEST    EBX,EBX
        JE      @@srcEmpty

{       make index 0-based and limit to 0 <= index < Length(src) }

        DEC     EDX
        JL      @@smallInx
        CMP     EDX,EBX
        JGE     @@bigInx

@@cont1:

{       limit count to satisfy 0 <= count <= Length(src) - index        }

        SUB     EBX,EDX { calculate Length(src) - index }
        TEST    ECX,ECX
        JL      @@smallCount
        CMP     ECX,EBX
        JG      @@bigCount

@@cont2:

        ADD     EDX,EAX
        MOV     EAX,[ESP+4+4]
        CALL    _LStrFromPCharLen
        JMP     @@exit

@@smallInx:
        XOR     EDX,EDX
        JMP     @@cont1
@@bigCount:
        MOV     ECX,EBX
        JMP     @@cont2
@@bigInx:
@@smallCount:
@@srcEmpty:
        MOV     EAX,[ESP+4+4]
        CALL    _LStrClr
@@exit:
        POP     EBX
        RET     4
end;


procedure       _LStrDelete{ var s : AnsiString; index, count : Integer };
asm
        {     ->EAX     Pointer to s    }
        {       EDX     index           }
        {       ECX     count           }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        CALL    UniqueString

        MOV     EDX,[EBX]
        TEST    EDX,EDX         { source already empty: nothing to do   }
        JE      @@exit

        MOV     ECX,[EDX-skew].StrRec.length

{       make index 0-based, if not in [0 .. Length(s)-1] do nothing     }

        DEC     ESI
        JL      @@exit
        CMP     ESI,ECX
        JGE     @@exit

{       limit count to [0 .. Length(s) - index] }

        TEST    EDI,EDI
        JLE     @@exit
        SUB     ECX,ESI         { ECX = Length(s) - index       }
        CMP     EDI,ECX
        JLE     @@1
        MOV     EDI,ECX
@@1:

{       move length - index - count characters from s+index+count to s+index }

        SUB     ECX,EDI         { ECX = Length(s) - index - count       }
        ADD     EDX,ESI         { EDX = s+index                 }
        LEA     EAX,[EDX+EDI]   { EAX = s+index+count           }
        CALL    Move

{       set length(s) to length(s) - count      }

        MOV     EDX,[EBX]
        MOV     EAX,EBX
        MOV     EDX,[EDX-skew].StrRec.length
        SUB     EDX,EDI
        CALL    _LStrSetLength

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure       _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
asm
        { ->    EAX source string                       }
        {       EDX     pointer to destination string   }
        {       ECX index                               }

        TEST    EAX,EAX
        JE      @@nothingToDo

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

{       make index 0-based and limit to 0 <= index <= Length(s) }

        MOV     EDX,[EDX]
        PUSH    EDX
        TEST    EDX,EDX
        JE      @@sIsNull
        MOV     EDX,[EDX-skew].StrRec.length
@@sIsNull:
        DEC     EDI
        JGE     @@indexNotLow
        XOR     EDI,EDI
@@indexNotLow:
        CMP     EDI,EDX
        JLE     @@indexNotHigh
        MOV     EDI,EDX
@@indexNotHigh:

        MOV     EBP,[EBX-skew].StrRec.length

{       set length of result to length(source) + length(s)      }

        MOV     EAX,ESI
        ADD     EDX,EBP
        CALL    _LStrSetLength
        POP     EAX

        CMP     EAX,EBX
        JNE     @@notInsertSelf
        MOV     EBX,[ESI]

@@notInsertSelf:

{       move length(s) - length(source) - index chars from s+index to s+index+length(source) }

        MOV     EAX,[ESI]                       { EAX = s       }
        LEA     EDX,[EDI+EBP]                   { EDX = index + length(source)  }
        MOV     ECX,[EAX-skew].StrRec.length
        SUB     ECX,EDX                         { ECX = length(s) - length(source) - index }
        ADD     EDX,EAX                         { EDX = s + index + length(source)      }
        ADD     EAX,EDI                         { EAX = s + index       }
        CALL    Move

{       copy length(source) chars from source to s+index        }

        MOV     EAX,EBX
        MOV     EDX,[ESI]
        MOV     ECX,EBP
        ADD     EDX,EDI
        CALL    Move

@@exit:
        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
@@nothingToDo:
end;


procedure       _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
asm
{     ->EAX     Pointer to substr               }
{       EDX     Pointer to string               }
{     <-EAX     Position of substr in s or 0    }

        TEST    EAX,EAX
        JE      @@noWork

        TEST    EDX,EDX
        JE      @@stringEmpty

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX                         { Point ESI to substr           }
        MOV     EDI,EDX                         { Point EDI to s                }

        MOV     ECX,[EDI-skew].StrRec.length    { ECX = Length(s)               }

        PUSH    EDI                             { remember s position to calculate index        }

        MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)          }

        DEC     EDX                             { EDX = Length(substr) - 1              }
        JS      @@fail                          { < 0 ? return 0                        }
        MOV     AL,[ESI]                        { AL = first char of substr             }
        INC     ESI                             { Point ESI to 2'nd char of substr      }

        SUB     ECX,EDX                         { #positions in s to look at    }
                                                { = Length(s) - Length(substr) + 1      }
        JLE     @@fail
@@loop:
        REPNE   SCASB
        JNE     @@fail
        MOV     EBX,ECX                         { save outer loop counter               }
        PUSH    ESI                             { save outer loop substr pointer        }
        PUSH    EDI                             { save outer loop s pointer             }

        MOV     ECX,EDX
        REPE    CMPSB
        POP     EDI                             { restore outer loop s pointer  }
        POP     ESI                             { restore outer loop substr pointer     }
        JE      @@found
        MOV     ECX,EBX                         { restore outer loop counter    }
        JMP     @@loop

@@fail:
        POP     EDX                             { get rid of saved s pointer    }
        XOR     EAX,EAX
        JMP     @@exit

@@stringEmpty:
        XOR     EAX,EAX
        JMP     @@noWork

@@found:
        POP     EDX                             { restore pointer to first char of s    }
        MOV     EAX,EDI                         { EDI points of char after match        }
        SUB     EAX,EDX                         { the difference is the correct index   }
@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
@@noWork:
end;


procedure       _LStrSetLength{ var str: AnsiString; newLength: Integer};
asm
        { ->    EAX     Pointer to str  }
        {       EDX new length  }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        XOR     EDI,EDI

        TEST    EDX,EDX
        JE      @@setString

        MOV     EAX,[EBX]
        TEST    EAX,EAX
        JE      @@copyString

        CMP     [EAX-skew].StrRec.refCnt,1
        JNE     @@copyString

        SUB     EAX,rOff
        ADD     EDX,rOff+1
        PUSH    EAX
        MOV     EAX,ESP
        CALL    _ReallocMem
        POP     EAX
        ADD     EAX,rOff
        MOV     [EBX],EAX
        MOV     [EAX-skew].StrRec.length,ESI
        MOV     BYTE PTR [EAX+ESI],0
        JMP     @@exit

@@copyString:
        MOV     EAX,EDX
        CALL    _NewAnsiString
        MOV     EDI,EAX

        MOV     EAX,[EBX]
        TEST    EAX,EAX
        JE      @@setString

        MOV     EDX,EDI
        MOV     ECX,[EAX-skew].StrRec.length
        CMP     ECX,ESI
        JL      @@moveString
        MOV     ECX,ESI

@@moveString:
        CALL    Move

@@setString:
        MOV     EAX,EBX
        CALL    _LStrClr
        MOV     [EBX],EDI

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure       _LStrOfChar{ c: Char; count: Integer): AnsiString };
asm
        { ->    AL      c               }
        {       EDX     count           }
        {       ECX     result  }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        MOV     EAX,ECX
        CALL    _LStrClr

        TEST    ESI,ESI
    JLE @@exit

        MOV     EAX,ESI
        CALL    _NewAnsiString

        MOV     [EDI],EAX

        MOV     EDX,ESI
        MOV     CL,BL

        CALL    _FillChar

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX

end;


procedure _Write0LString{ VAR t: Text; s: AnsiString };
asm
        { ->    EAX     Pointer to text record  }
        {       EDX     Pointer to AnsiString   }

        XOR     ECX,ECX
        JMP     _WriteLString
end;


procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
asm
        { ->    EAX     Pointer to text record  }
        {       EDX     Pointer to AnsiString   }
        {       ECX     Field width             }

        PUSH    EBX

        MOV     EBX,EDX

        MOV     EDX,ECX
        XOR     ECX,ECX
        TEST    EBX,EBX
        JE      @@skip
        MOV     ECX,[EBX-skew].StrRec.length
        SUB     EDX,ECX
@@skip:
        PUSH    ECX
        CALL    _WriteSpaces
        POP     ECX

        MOV     EDX,EBX
        POP     EBX
        JMP     _WriteBytes
end;


procedure       _ReadLString{var t: Text; var str: AnsiString};
asm
        { ->    EAX     pointer to Text         }
        {       EDX     pointer to AnsiString   }

        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EDX

        MOV     EAX,EDX
        CALL    _LStrClr

        SUB     ESP,256

        MOV     EAX,EBX
        MOV     EDX,ESP
        MOV     ECX,255
        CALL    _ReadString

        MOV     EAX,ESI
        MOV     EDX,ESP
        CALL    _LStrFromString

        CMP     byte ptr [ESP],255
        JNE     @@exit
@@loop:

        MOV     EAX,EBX
        MOV     EDX,ESP
        MOV     ECX,255
        CALL    _ReadString

        MOV     EDX,ESP
        PUSH    0
        MOV     EAX,ESP
        CALL    _LStrFromString

        MOV     EAX,ESI
        MOV     EDX,[ESP]
        CALL    _LStrCat

        MOV     EAX,ESP
        CALL    _LStrClr
        POP     EAX

        CMP     byte ptr [ESP],255
        JE      @@loop

@@exit:
        ADD     ESP,256
        POP     ESI
        POP     EBX
end;


procedure WStrError;
asm
        MOV     AL,reOutOfMemory
        JMP     Error
end;


procedure WStrSet(var S: WideString; P: PWideChar);
asm
        MOV     ECX,[EAX]
        MOV     [EAX],EDX
        TEST    ECX,ECX
        JE      @@1
        PUSH    ECX
        CALL    SysFreeString
@@1:
end;


procedure WStrClr;
asm
       JMP _WStrClr
end;

procedure _WStrClr(var S: WideString);
asm
        { ->    EAX     Pointer to WideString  }

        MOV     EDX,[EAX]
        TEST    EDX,EDX
        JE      @@1
        MOV     DWORD PTR [EAX],0
        PUSH    EAX
        PUSH    EDX
        CALL    SysFreeString
        POP     EAX
@@1:
end;


procedure WStrArrayClr;
asm
        JMP     _WStrArrayClr;
end;

procedure _WStrArrayClr(var StrArray; Count: Integer);
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EDX
@@1:    MOV     EAX,[EBX]
        TEST    EAX,EAX
        JE      @@2
        MOV     DWORD PTR [EBX],0
        PUSH    EAX
        CALL    SysFreeString
@@2:    ADD     EBX,4
        DEC     ESI
        JNE     @@1
        POP     ESI
        POP     EBX
end;


procedure _WStrAsg(var Dest: WideString; const Source: WideString);
asm
        { ->    EAX     Pointer to WideString }
        {       EDX     Pointer to data       }
        TEST    EDX,EDX
        JE      _WStrClr
        MOV     ECX,[EDX-4]
        SHR     ECX,1
        JE      _WStrClr
        PUSH    ECX
        PUSH    EDX
        PUSH    EAX
        CALL    SysReAllocStringLen
        TEST    EAX,EAX
        JE      WStrError
end;


procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
var
  DestLen: Integer;
  Buffer: array[0..1023] of WideChar;
begin
  if Length <= 0 then
  begin
    _WStrClr(Dest);
    Exit;
  end;
  if Length < SizeOf(Buffer) div 2 then
  begin
    DestLen := MultiByteToWideChar(0, 0, Source, Length,
      Buffer, SizeOf(Buffer) div 2);
    if DestLen > 0 then
    begin
      _WStrFromPWCharLen(Dest, Buffer, DestLen);
      Exit;
    end;
  end;
  DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0);
  _WStrFromPWCharLen(Dest, nil, DestLen);
  MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen);
end;


procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
asm
        { ->    EAX     Pointer to WideString (dest)      }
        {       EDX     Pointer to characters (source)    }
        {       ECX     number of characters  (not bytes) }
        TEST    ECX,ECX
        JE      _WStrClr

        PUSH    EAX

        PUSH    ECX
        PUSH    EDX
        CALL    SysAllocStringLen
        TEST    EAX,EAX
        JE      WStrError

        POP     EDX
        PUSH    [EDX].PWideChar
        MOV     [EDX],EAX

        CALL    SysFreeString
end;


procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
asm
        PUSH    EDX
        MOV     EDX,ESP
        MOV     ECX,1
        CALL    _WStrFromPCharLen
        POP     EDX
end;


procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
asm
        { ->    EAX     Pointer to WideString (dest)   }
        {       EDX     character             (source) }
        PUSH    EDX
        MOV     EDX,ESP
        MOV     ECX,1
        CALL    _WStrFromPWCharLen
        POP     EDX
end;


procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
asm
        { ->    EAX     Pointer to WideString (dest)   }
        {       EDX     Pointer to character  (source) }
        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@5
        PUSH    EDX
@@0:    CMP     CL,[EDX+0]
        JE      @@4
        CMP     CL,[EDX+1]
        JE      @@3
        CMP     CL,[EDX+2]
        JE      @@2
        CMP     CL,[EDX+3]
        JE      @@1
        ADD     EDX,4
        JMP     @@0
@@1:    INC     EDX
@@2:    INC     EDX
@@3:    INC     EDX
@@4:    MOV     ECX,EDX
        POP     EDX
        SUB     ECX,EDX
@@5:    JMP     _WStrFromPCharLen
end;


procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
asm
        { ->    EAX     Pointer to WideString (dest)   }
        {       EDX     Pointer to character  (source) }
        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@5
        PUSH    EDX
@@0:    CMP     CX,[EDX+0]
        JE      @@4
        CMP     CX,[EDX+2]
        JE      @@3
        CMP     CX,[EDX+4]
        JE      @@2
        CMP     CX,[EDX+6]
        JE      @@1
        ADD     EDX,8
        JMP     @@0
@@1:    ADD     EDX,2
@@2:    ADD     EDX,2
@@3:    ADD     EDX,2
@@4:    MOV     ECX,EDX
        POP     EDX
        SUB     ECX,EDX
        SHR     ECX,1
@@5:    JMP     _WStrFromPWCharLen
end;


procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
asm
        XOR     ECX,ECX
        MOV     CL,[EDX]
        INC     EDX
        JMP     _WStrFromPCharLen
end;


procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
asm
        PUSH    EDI
        PUSH    EAX
        PUSH    ECX
        MOV     EDI,EDX
        XOR     EAX,EAX
        REPNE   SCASB
        JNE     @@1
        NOT     ECX
@@1:    POP     EAX
        ADD     ECX,EAX
        POP     EAX
        POP     EDI
        JMP     _WStrFromPCharLen
end;


procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
asm
        PUSH    EDI
        PUSH    EAX
        PUSH    ECX
        MOV     EDI,EDX
        XOR     EAX,EAX
        REPNE   SCASW
        JNE     @@1
        NOT     ECX
@@1:    POP     EAX
        ADD     ECX,EAX
        POP     EAX
        POP     EDI
        JMP     _WStrFromPWCharLen
end;


procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
asm
        XOR     ECX,ECX
        TEST    EDX,EDX
        JE      @@1
        MOV     ECX,[EDX-4]
@@1:    JMP     _WStrFromPCharLen
end;


procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
var
  SourceLen, DestLen: Integer;
  Buffer: array[0..511] of Char;
begin
  SourceLen := Length(Source);
  if SourceLen >= 255 then SourceLen := 255;
  if SourceLen = 0 then DestLen := 0 else
  begin
    DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen,
      Buffer, SizeOf(Buffer), nil, nil);
    if DestLen > MaxLen then DestLen := MaxLen;
  end;
  Dest^[0] := Chr(DestLen);
  if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
end;


function _WStrToPWChar(const S: WideString): PWideChar;
asm
        TEST    EAX,EAX
        JE      @@1
        RET
        NOP
@@0:    DW      0
@@1:    MOV     EAX,OFFSET @@0
end;


function _WStrLen(const S: WideString): Integer;
asm
        { ->    EAX     Pointer to WideString data }
        TEST    EAX,EAX
        JE      @@1
        MOV     EAX,[EAX-4]
        SHR     EAX,1
@@1:
end;


procedure _WStrCat(var Dest: WideString; const Source: WideString);
var
  DestLen, SourceLen: Integer;
  NewStr: PWideChar;
begin
  SourceLen := Length(Source);
  if SourceLen <> 0 then
  begin
    DestLen := Length(Dest);
    NewStr := _NewWideString(DestLen + SourceLen);
    if DestLen > 0 then
      Move(Pointer(Dest)^, NewStr^, DestLen * 2);
    Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2);
    WStrSet(Dest, NewStr);
  end;
end;


procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
var
  Source1Len, Source2Len: Integer;
  NewStr: PWideChar;
begin
  Source1Len := Length(Source1);
  Source2Len := Length(Source2);
  if (Source1Len <> 0) or (Source2Len <> 0) then
  begin
    NewStr := _NewWideString(Source1Len + Source2Len);
    Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2);
    Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2);
    WStrSet(Dest, NewStr);
  end;
end;


procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...};
asm
        {     ->EAX = Pointer to dest }
        {       EDX = number of args (>= 3) }
        {       [ESP+4], [ESP+8], ... crgCnt WideString arguments }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDX
        PUSH    EAX
        MOV     EBX,EDX

        XOR     EAX,EAX
@@loop1:
        MOV     ECX,[ESP+EDX*4+4*4]
        TEST    ECX,ECX
        JE      @@1
        ADD     EAX,[ECX-4]
@@1:
        DEC     EDX
        JNE     @@loop1

        SHR     EAX,1
        CALL    _NewWideString
        PUSH    EAX
        MOV     ESI,EAX

@@loop2:
        MOV     EAX,[ESP+EBX*4+5*4]
        MOV     EDX,ESI
        TEST    EAX,EAX
        JE      @@2
        MOV     ECX,[EAX-4]
        ADD     ESI,ECX
        CALL    Move
@@2:
        DEC     EBX
        JNE     @@loop2

        POP     EDX
        POP     EAX
        CALL    WStrSet

        POP     EDX
        POP     ESI
        POP     EBX
        POP     EAX
        LEA     ESP,[ESP+EDX*4]
        JMP     EAX
end;


procedure _WStrCmp{left: WideString; right: WideString};
asm
{     ->EAX = Pointer to left string    }
{       EDX = Pointer to right string   }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        CMP     EAX,EDX
        JE      @@exit

        TEST    ESI,ESI
        JE      @@str1null

        TEST    EDI,EDI
        JE      @@str2null

        MOV     EAX,[ESI-4]
        MOV     EDX,[EDI-4]

        SUB     EAX,EDX { eax = len1 - len2 }
        JA      @@skip1
        ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }

@@skip1:
        PUSH    EDX
        SHR     EDX,2
        JE      @@cmpRest
@@longLoop:
        MOV     ECX,[ESI]
        MOV     EBX,[EDI]
        CMP     ECX,EBX
        JNE     @@misMatch
        DEC     EDX
        JE      @@cmpRestP4
        MOV     ECX,[ESI+4]
        MOV     EBX,[EDI+4]
        CMP     ECX,EBX
        JNE     @@misMatch
        ADD     ESI,8
        ADD     EDI,8
        DEC     EDX
        JNE     @@longLoop
        JMP     @@cmpRest
@@cmpRestP4:
        ADD     ESI,4
        ADD     EDI,4
@@cmpRest:
        POP     EDX
        AND     EDX,2
        JE      @@equal

        MOV     CX,[ESI]
        MOV     BX,[EDI]
        CMP     CX,BX
        JNE     @@exit

@@equal:
        ADD     EAX,EAX
        JMP     @@exit

@@str1null:
        MOV     EDX,[EDI-4]
        SUB     EAX,EDX
        JMP     @@exit

@@str2null:
        MOV     EAX,[ESI-4]
        SUB     EAX,EDX
        JMP     @@exit

@@misMatch:
        POP     EDX
        CMP     CX,BX
        JNE     @@exit
        SHR     ECX,16
        SHR     EBX,16
        CMP     CX,BX

@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;


function _NewWideString(Length: Integer): PWideChar;
asm
        TEST    EAX,EAX
        JE      @@1
        PUSH    EAX
        PUSH    0
        CALL    SysAllocStringLen
        TEST    EAX,EAX
        JE      WStrError
@@1:
end;


function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
var
  L, N: Integer;
begin
  L := Length(S);
  if Index < 1 then Index := 0 else
  begin
    Dec(Index);
    if Index > L then Index := L;
  end;
  if Count < 0 then N := 0 else
  begin
    N := L - Index;
    if N > Count then N := Count;
  end;
  _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N);
end;


procedure _WStrDelete(var S: WideString; Index, Count: Integer);
var
  L, N: Integer;
  NewStr: PWideChar;
begin
  L := Length(S);
  if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then
  begin
    Dec(Index);
    N := L - Index - Count;
    if N < 0 then N := 0;
    if (Index = 0) and (N = 0) then NewStr := nil else
    begin
      NewStr := _NewWideString(Index + N);
      if Index > 0 then
        Move(Pointer(S)^, NewStr^, Index * 2);
      if N > 0 then
        Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2);
    end;
    WStrSet(S, NewStr);
  end;
end;


procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
var
  SourceLen, DestLen: Integer;
  NewStr: PWideChar;
begin
  SourceLen := Length(Source);
  if SourceLen > 0 then
  begin
    DestLen := Length(Dest);
    if Index < 1 then Index := 0 else
    begin
      Dec(Index);
      if Index > DestLen then Index := DestLen;
    end;
    NewStr := _NewWideString(DestLen + SourceLen);
    if Index > 0 then
      Move(Pointer(Dest)^, NewStr^, Index * 2);
    Move(Pointer(Source)^, NewStr[Index], SourceLen * 2);
    if Index < DestLen then
      Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen],
        (DestLen - Index) * 2);
    WStrSet(Dest, NewStr);
  end;
end;


procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
asm
{     ->EAX     Pointer to substr               }
{       EDX     Pointer to string               }
{     <-EAX     Position of substr in s or 0    }

        TEST    EAX,EAX
        JE      @@noWork

        TEST    EDX,EDX
        JE      @@stringEmpty

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX                         { Point ESI to substr           }
        MOV     EDI,EDX                         { Point EDI to s                }

        MOV     ECX,[EDI-4]                     { ECX = Length(s)               }
        SHR     ECX,1

        PUSH    EDI                             { remember s position to calculate index        }

        MOV     EDX,[ESI-4]                     { EDX = Length(substr)          }
        SHR     EDX,1

        DEC     EDX                             { EDX = Length(substr) - 1              }
        JS      @@fail                          { < 0 ? return 0                        }
        MOV     AX,[ESI]                        { AL = first char of substr             }
        ADD     ESI,2                           { Point ESI to 2'nd char of substr      }

        SUB     ECX,EDX                         { #positions in s to look at    }
                                                { = Length(s) - Length(substr) + 1      }
        JLE     @@fail
@@loop:
        REPNE   SCASW
        JNE     @@fail
        MOV     EBX,ECX                         { save outer loop counter               }
        PUSH    ESI                             { save outer loop substr pointer        }
        PUSH    EDI                             { save outer loop s pointer             }

        MOV     ECX,EDX
        REPE    CMPSW
        POP     EDI                             { restore outer loop s pointer  }
        POP     ESI                             { restore outer loop substr pointer     }
        JE      @@found
        MOV     ECX,EBX                         { restore outer loop counter    }
        JMP     @@loop

@@fail:
        POP     EDX                             { get rid of saved s pointer    }
        XOR     EAX,EAX
        JMP     @@exit

@@stringEmpty:
        XOR     EAX,EAX
        JMP     @@noWork

@@found:
        POP     EDX                             { restore pointer to first char of s    }
        MOV     EAX,EDI                         { EDI points of char after match        }
        SUB     EAX,EDX                         { the difference is the correct index   }
        SHR     EAX,1
@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
@@noWork:
end;


procedure _WStrSetLength(var S: WideString; NewLength: Integer);
var
  NewStr: PWideChar;
  Count: Integer;
begin
  NewStr := nil;
  if NewLength > 0 then
  begin
    NewStr := _NewWideString(NewLength);
    Count := Length(S);
    if Count > 0 then
    begin
      if Count > NewLength then Count := NewLength;
      Move(Pointer(S)^, NewStr^, Count * 2);
    end;
  end;
  WStrSet(S, NewStr);
end;


function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
var
  P: PWideChar;
begin
  _WStrFromPWCharLen(Result, nil, Count);
  P := Pointer(Result);
  while Count > 0 do
  begin
    Dec(Count);
    P[Count] := Ch;
  end;
end;

procedure WStrAddRef;
asm
        JMP _WStrAddRef
end;

procedure _WStrAddRef{var str: WideString};
asm
        MOV     EDX,[EAX]
        TEST    EDX,EDX
        JE      @@1
        PUSH    EAX
        MOV     ECX,[EDX-4]
        SHR     ECX,1
        PUSH    ECX
        PUSH    EDX
        CALL    SysAllocStringLen
        POP     EDX
        TEST    EAX,EAX
        JE      WStrError
        MOV     [EDX],EAX
@@1:
end;


procedure       _InitializeRecord{ p: Pointer; typeInfo: Pointer };
asm
        { ->    EAX pointer to record to be initialized }
        {       EDX pointer to type info                }

        XOR     ECX,ECX

        PUSH    EBX
        MOV     CL,[EDX+1]                  { type name length }

        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        LEA     ESI,[EDX+ECX+2+8]           { address of destructable fields }
        MOV     EDI,[EDX+ECX+2+4]           { number of destructable fields }

@@loop:

        MOV     EDX,[ESI]
        MOV     EAX,[ESI+4]
        ADD     EAX,EBX
        MOV     EDX,[EDX]
        CALL    _Initialize
        ADD     ESI,8
        DEC     EDI
        JG      @@loop

        POP     EDI
        POP     ESI
        POP     EBX
end;


const
  tkLString   = 10;
  tkWString   = 11;
  tkVariant   = 12;
  tkArray     = 13;
  tkRecord    = 14;
  tkInterface = 15;
  tkDynArray  = 17;

procedure       _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
        { ->    EAX     pointer to data to be initialized       }
        {       EDX     pointer to type info describing data    }
        {       ECX number of elements of that type             }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        XOR     EDX,EDX
        MOV     AL,[ESI]
        MOV     DL,[ESI+1]
        XOR     ECX,ECX

        CMP     AL,tkLString
        JE      @@LString
        CMP     AL,tkWString
        JE      @@WString
        CMP     AL,tkVariant
        JE      @@Variant
        CMP     AL,tkArray
        JE      @@Array
        CMP     AL,tkRecord
        JE      @@Record
        CMP     AL,tkInterface
  JE      @@Interface
  CMP AL,tkDynArray
  JE  @@DynArray
        MOV     AL,reInvalidPtr
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     Error

@@LString:
@@WString:
@@Interface:
@@DynArray:
        MOV     [EBX],ECX
        ADD     EBX,4
        DEC     EDI
        JG      @@LString
        JMP     @@exit

@@Variant:
        MOV     [EBX   ],ECX
        MOV     [EBX+ 4],ECX
        MOV     [EBX+ 8],ECX
        MOV     [EBX+12],ECX
        ADD     EBX,16
        DEC     EDI
        JG      @@Variant
        JMP     @@exit

@@Array:
        PUSH    EBP
        MOV     EBP,EDX
@@ArrayLoop:
        MOV     EDX,[ESI+EBP+2+8]
        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     ECX,[ESI+EBP+2+4]
        MOV     EDX,[EDX]
        CALL    _InitializeArray
        DEC     EDI
        JG      @@ArrayLoop
        POP     EBP
        JMP     @@exit

@@Record:
        PUSH    EBP
        MOV     EBP,EDX
@@RecordLoop:
        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     EDX,ESI
        CALL    _InitializeRecord
        DEC     EDI
        JG      @@RecordLoop
        POP     EBP

@@exit:

        POP     EDI
        POP     ESI
    POP EBX
end;


procedure       _Initialize{ p: Pointer; typeInfo: Pointer};
asm
        MOV     ECX,1
        JMP     _InitializeArray
end;

procedure       _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
asm
        { ->    EAX pointer to record to be finalized   }
        {       EDX pointer to type info                }

        XOR     ECX,ECX

        PUSH    EBX
        MOV     CL,[EDX+1]

        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        LEA     ESI,[EDX+ECX+2+8]
        MOV     EDI,[EDX+ECX+2+4]

@@loop:

        MOV     EDX,[ESI]
        MOV     EAX,[ESI+4]
        ADD     EAX,EBX
        MOV     EDX,[EDX]
        CALL    _Finalize
        ADD     ESI,8
        DEC     EDI
        JG      @@loop

        MOV     EAX,EBX

        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure       _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
        { ->    EAX     pointer to data to be finalized         }
        {       EDX     pointer to type info describing data    }
        {       ECX number of elements of that type             }

        CMP     ECX, 0                        { no array -> nop }
        JE      @@zerolength

        PUSH    EAX
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        XOR     EDX,EDX
        MOV     AL,[ESI]
        MOV     DL,[ESI+1]

        CMP     AL,tkLString
        JE      @@LString

        CMP     AL,tkWString
        JE      @@WString

        CMP     AL,tkVariant
        JE      @@Variant

        CMP     AL,tkArray
        JE      @@Array

        CMP     AL,tkRecord
        JE      @@Record

        CMP     AL,tkInterface
        JE      @@Interface

        CMP     AL,tkDynArray
        JE      @@DynArray
        POP     EDI
        POP     ESI
        POP     EBX
        POP      EAX
        MOV     AL,reInvalidPtr
        JMP     Error

@@LString:
        CMP     ECX,1
        MOV     EAX,EBX
        JG      @@LStringArray
        CALL    _LStrClr
        JMP     @@exit
@@LStringArray:
        MOV     EDX,ECX
        CALL    _LStrArrayClr
        JMP     @@exit

@@WString:
        CMP     ECX,1
        MOV     EAX,EBX
        JG      @@WStringArray
        //CALL    _WStrClr
        CALL    [WStrClrProc]
        JMP     @@exit
@@WStringArray:
        MOV     EDX,ECX
        //CALL    _WStrArrayClr
        CALL    [WStrArrayClrProc]
        JMP     @@exit

@@Variant:
        MOV     EAX,EBX
        ADD     EBX,16
        //CALL    _VarClr
        CALL    [VarClrProc]
        DEC     EDI
        JG      @@Variant
        JMP     @@exit

@@Array:
        PUSH    EBP
        MOV     EBP,EDX
@@ArrayLoop:
        MOV     EDX,[ESI+EBP+2+8]
        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     ECX,[ESI+EBP+2+4]
        MOV     EDX,[EDX]
        CALL    _FinalizeArray
        DEC     EDI
        JG      @@ArrayLoop
        POP     EBP
        JMP     @@exit

@@Record:
        PUSH    EBP
        MOV     EBP,EDX
@@RecordLoop:
        { inv: EDI = number of array elements to finalize }

        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     EDX,ESI
        CALL    _FinalizeRecord
        DEC     EDI
        JG      @@RecordLoop
        POP     EBP
        JMP     @@exit

@@Interface:
        MOV     EAX,EBX
        ADD     EBX,4
        CALL    _IntfClear
        DEC     EDI
        JG      @@Interface
        JMP     @@exit

@@DynArray:
        MOV     EAX,EBX
        MOV     EDX,ESI
        ADD     EBX,4
        CALL    _DynArrayClear
        DEC     EDI
        JG      @@DynArray

@@exit:

        POP     EDI
        POP     ESI
        POP     EBX
        POP     EAX
@@zerolength:
end;


procedure       _Finalize{ p: Pointer; typeInfo: Pointer};
asm
        MOV     ECX,1
        JMP     _FinalizeArray
end;

procedure       _AddRefRecord{ p: Pointer; typeInfo: Pointer };
asm
        { ->    EAX pointer to record to be referenced  }
        {       EDX pointer to type info        }

        XOR     ECX,ECX

        PUSH    EBX
        MOV     CL,[EDX+1]

        PUSH    ESI
        PUSH    EDI

        MOV     EBX,EAX
        LEA     ESI,[EDX+ECX+2+8]
        MOV     EDI,[EDX+ECX+2+4]

@@loop:

        MOV     EDX,[ESI]
        MOV     EAX,[ESI+4]
        ADD     EAX,EBX
        MOV     EDX,[EDX]
        CALL    _AddRef
        ADD     ESI,8
        DEC     EDI
        JG      @@loop

        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure DummyProc;
begin
end;

procedure       _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
        { ->    EAX     pointer to data to be referenced        }
        {       EDX     pointer to type info describing data    }
        {       ECX number of elements of that type             }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX

        XOR     EDX,EDX
        MOV     AL,[ESI]
        MOV     DL,[ESI+1]

        CMP     AL,tkLString
        JE      @@LString
        CMP     AL,tkWString
        JE      @@WString
        CMP     AL,tkVariant
        JE      @@Variant
        CMP     AL,tkArray
        JE      @@Array
        CMP     AL,tkRecord
        JE      @@Record
        CMP     AL,tkInterface
        JE      @@Interface
        CMP     AL,tkDynArray
        JE      @@DynArray
        MOV     AL,reInvalidPtr
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     Error

@@LString:
        MOV     EAX,[EBX]
        ADD     EBX,4
        CALL    _LStrAddRef
        DEC     EDI
        JG      @@LString
        JMP     @@exit

@@WString:
        MOV     EAX,EBX
        ADD     EBX,4
        //CALL    _WStrAddRef
        CALL    [WStrAddRefProc]
        DEC     EDI
        JG      @@WString
        JMP     @@exit

@@Variant:
        MOV     EAX,EBX
        ADD     EBX,16
        //CALL    _VarAddRef
        CALL    [VarAddRefProc]
        DEC     EDI
        JG      @@Variant
        JMP     @@exit

@@Array:
        PUSH    EBP
        MOV     EBP,EDX
@@ArrayLoop:
        MOV     EDX,[ESI+EBP+2+8]
        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     ECX,[ESI+EBP+2+4]
        MOV     EDX,[EDX]
        CALL    _AddRefArray
        DEC     EDI
        JG      @@ArrayLoop
        POP     EBP
        JMP     @@exit

@@Record:
        PUSH    EBP
        MOV     EBP,EDX
@@RecordLoop:
        MOV     EAX,EBX
        ADD     EBX,[ESI+EBP+2]
        MOV     EDX,ESI
        CALL    _AddRefRecord
        DEC     EDI
        JG      @@RecordLoop
        POP     EBP
        JMP     @@exit

@@Interface:
        MOV     EAX,[EBX]
        ADD     EBX,4
        CALL    _IntfAddRef
        DEC     EDI
        JG      @@Interface
        JMP     @@exit

@@DynArray:
        MOV     EAX,[EBX]
        ADD     EBX,4
        CALL    _DynArrayAddRef
        DEC     EDI
        JG      @@DynArray
@@exit:

        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure       _AddRef{ p: Pointer; typeInfo: Pointer};
asm
        MOV     ECX,1
        JMP     _AddRefArray
end;


procedure       _CopyRecord{ dest, source, typeInfo: Pointer };
asm
        { ->    EAX pointer to dest             }
        {       EDX pointer to source           }
        {       ECX pointer to typeInfo         }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EBX,EAX
        MOV     ESI,EDX

        XOR     EAX,EAX
        MOV     AL,[ECX+1]

        LEA     EDI,[ECX+EAX+2+8]
        MOV     EBP,[EDI-4]
        XOR     EAX,EAX
        MOV     ECX,[EDI-8]
        PUSH    ECX
@@loop:
        MOV     ECX,[EDI+4]
        SUB     ECX,EAX
        JLE     @@nomove1
        MOV     EDX,EAX
        ADD     EAX,ESI
        ADD     EDX,EBX
        CALL    Move
@@noMove1:
        MOV     EAX,[EDI+4]

        MOV     EDX,[EDI]
        MOV     EDX,[EDX]
        MOV     CL,[EDX]

        CMP     CL,tkLString
        JE      @@LString
        CMP     CL,tkWString
        JE      @@WString
        CMP     CL,tkVariant
        JE      @@Variant
        CMP     CL,tkArray
        JE      @@Array
        CMP     CL,tkRecord
        JE      @@Record
        CMP     CL,tkInterface
        JE      @@Interface
        CMP     CL,tkDynArray
        JE      @@DynArray
        MOV     AL,reInvalidPtr
        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     Error

@@LString:
        MOV     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _LStrAsg
        MOV     EAX,4
        JMP     @@common

@@WString:
        MOV     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _WStrAsg
        MOV     EAX,4
        JMP     @@common

@@Variant:
        LEA     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _VarCopy
        MOV     EAX,16
        JMP     @@common

@@Array:
        XOR     ECX,ECX
        MOV     CL,[EDX+1]
        PUSH    dword ptr [EDX+ECX+2]
        PUSH    dword ptr [EDX+ECX+2+4]
        MOV     ECX,[EDX+ECX+2+8]
        MOV     ECX,[ECX]
        LEA     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _CopyArray
        POP     EAX
        JMP     @@common

@@Record:
        XOR     ECX,ECX
        MOV     CL,[EDX+1]
        MOV     ECX,[EDX+ECX+2]
        PUSH    ECX
        MOV     ECX,EDX
        LEA     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _CopyRecord
        POP     EAX
        JMP     @@common

@@Interface:
        MOV     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _IntfCopy
        MOV     EAX,4
        JMP     @@common

@@DynArray:
        MOV     ECX,EDX
        MOV     EDX,[ESI+EAX]
        ADD     EAX,EBX
        CALL    _DynArrayAsg
        MOV     EAX,4

@@common:
        ADD     EAX,[EDI+4]
        ADD     EDI,8
        DEC     EBP
        JNZ     @@loop

        POP     ECX
        SUB     ECX,EAX
        JLE     @@noMove2
        LEA     EDX,[EBX+EAX]
        ADD     EAX,ESI
        CALL    Move
@@noMove2:

        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
end;


procedure       _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer };
asm
        { ->    EAX pointer to dest             }
        {       EDX pointer to source           }
        {       ECX offset of vmt in object     }
        {       [ESP+4] pointer to typeInfo     }

        ADD     ECX,EAX                         { pointer to dest vmt }
        PUSH    dword ptr [ECX]                 { save dest vmt }
        PUSH    ECX
        MOV     ECX,[ESP+4+4+4]
        CALL    _CopyRecord
        POP     ECX
        POP     dword ptr [ECX]                 { restore dest vmt }
        RET     4

end;

procedure       _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer };
asm
        { ->    EAX pointer to dest             }
        {       EDX pointer to source           }
        {       ECX pointer to typeInfo         }
        {       [ESP+4] count                   }
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX
        MOV     EBP,[ESP+4+4*4]

        MOV     CL,[EDI]

        CMP     CL,tkLString
        JE      @@LString
        CMP     CL,tkWString
        JE      @@WString
        CMP     CL,tkVariant
        JE      @@Variant
        CMP     CL,tkArray
        JE      @@Array
        CMP     CL,tkRecord
        JE      @@Record
        CMP     CL,tkInterface
        JE      @@Interface
        CMP     CL,tkDynArray
        JE      @@DynArray
        MOV     AL,reInvalidPtr
        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     Error

@@LString:
        MOV     EAX,EBX
        MOV     EDX,[ESI]
        CALL    _LStrAsg
        ADD     EBX,4
        ADD     ESI,4
        DEC     EBP
        JNE     @@LString
        JMP     @@exit

@@WString:
        MOV     EAX,EBX
        MOV     EDX,[ESI]
        CALL    _WStrAsg
        ADD     EBX,4
        ADD     ESI,4
        DEC     EBP
        JNE     @@WString
        JMP     @@exit

@@Variant:
        MOV     EAX,EBX
        MOV     EDX,ESI
        CALL    _VarCopy
        ADD     EBX,16
        ADD     ESI,16
        DEC     EBP
        JNE     @@Variant
        JMP     @@exit

@@Array:
        XOR     ECX,ECX
        MOV     CL,[EDI+1]
        LEA     EDI,[EDI+ECX+2]
@@ArrayLoop:
        MOV     EAX,EBX
        MOV     EDX,ESI
        MOV     ECX,[EDI+8]
        PUSH    dword ptr [EDI+4]
        CALL    _CopyArray
        ADD     EBX,[EDI]
        ADD     ESI,[EDI]
        DEC     EBP
        JNE     @@ArrayLoop
        JMP     @@exit

@@Record:
        MOV     EAX,EBX
        MOV     EDX,ESI
        MOV     ECX,EDI
        CALL    _CopyRecord
        XOR     EAX,EAX
        MOV     AL,[EDI+1]
        ADD     EBX,[EDI+EAX+2]
        ADD     ESI,[EDI+EAX+2]
        DEC     EBP
        JNE     @@Record
        JMP     @@exit

@@Interface:
        MOV     EAX,EBX
        MOV     EDX,[ESI]
        CALL    _IntfCopy
        ADD     EBX,4
        ADD     ESI,4
        DEC     EBP
        JNE     @@Interface
        JMP     @@exit

@@DynArray:
        MOV     EAX,EBX
        MOV     EDX,[ESI]
        MOV     ECX,EDI
        CALL    _DynArrayAsg
        ADD     EBX,4
        ADD     ESI,4
        DEC     EBP
        JNE     @@DynArray

@@exit:
        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
        RET     4
end;


procedure       _New{ size: Longint; typeInfo: Pointer};
asm
        { ->    EAX size of object to allocate  }
        {       EDX pointer to typeInfo         }

        PUSH    EDX
        CALL    _GetMem
        POP     EDX
        TEST    EAX,EAX
        JE      @@exit
        PUSH    EAX
        CALL    _Initialize
        POP     EAX
@@exit:
end;

procedure       _Dispose{ p: Pointer; typeInfo: Pointer};
asm
        { ->    EAX     Pointer to object to be disposed        }
        {       EDX     Pointer to type info            }

        PUSH    EAX
        CALL    _Finalize
        POP     EAX
        CALL    _FreeMem
end;

{ ----------------------------------------------------- }
{       Wide character support                          }
{ ----------------------------------------------------- }

function WideCharToString(Source: PWideChar): string;
begin
  WideCharToStrVar(Source, Result);
end;

function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
begin
  WideCharLenToStrVar(Source, SourceLen, Result);
end;

procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
var
  SourceLen: Integer;
begin
  SourceLen := 0;
  while Source[SourceLen] <> #0 do Inc(SourceLen);
  WideCharLenToStrVar(Source, SourceLen, Dest);
end;

procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  var Dest: string);
var
  DestLen: Integer;
  Buffer: array[0..2047] of Char;
begin
  if SourceLen = 0 then
    Dest := ''
  else
    if SourceLen < SizeOf(Buffer) div 2 then
      SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
        Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
    else
    begin
      DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
        nil, 0, nil, nil);
      SetString(Dest, nil, DestLen);
      WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
        DestLen, nil, nil);
    end;
end;

function StringToWideChar(const Source: string; Dest: PWideChar;
  DestSize: Integer): PWideChar;
begin
  Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
    Dest, DestSize - 1)] := #0;
  Result := Dest;
end;

{ ----------------------------------------------------- }
{       OLE string support                              }
{ ----------------------------------------------------- }

function OleStrToString(Source: PWideChar): string;
begin
  OleStrToStrVar(Source, Result);
end;

procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
begin
  WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest);
end;

function StringToOleStr(const Source: string): PWideChar;
var
  SourceLen, ResultLen: Integer;
  Buffer: array[0..1023] of WideChar;
begin
  SourceLen := Length(Source);
  if Length(Source) < SizeOf(Buffer) div 2 then
    Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
      PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
  else
  begin
    ResultLen := MultiByteToWideChar(0, 0,
      Pointer(Source), SourceLen, nil, 0);
    Result := SysAllocStringLen(nil, ResultLen);
    MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
      Result, ResultLen);
  end;
end;

{ ----------------------------------------------------- }
{       Variant support                                 }
{ ----------------------------------------------------- }

type
  TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);

const
  varLast = varByte;

const
  BaseTypeMap: array[0..varLast] of TBaseType = (
    btErr,  { varEmpty    }
    btNul,  { varNull     }
    btInt,  { varSmallint }
    btInt,  { varInteger  }
    btFlt,  { varSingle   }
    btFlt,  { varDouble   }
    btCur,  { varCurrency }
    btDat,  { varDate     }
    btStr,  { varOleStr   }
    btErr,  { varDispatch }
    btErr,  { varError    }
    btBol,  { varBoolean  }
    btErr,  { varVariant  }
    btErr,  { varUnknown  }
    btErr,  { vt_decimal  }
    btErr,  { undefined   }
    btErr,  { vt_i1       }
    btInt); { varByte     }

const
  OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
    (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
    (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
    (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
    (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
    (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
    (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
    (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
    (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));

const
  C10000: Single = 10000;

const
  opAdd  = 0;
  opSub  = 1;
  opMul  = 2;
  opDvd  = 3;
  opDiv  = 4;
  opMod  = 5;
  opShl  = 6;
  opShr  = 7;
  opAnd  = 8;
  opOr   = 9;
  opXor  = 10;

procedure _DispInvoke;
asm
        { ->    [ESP+4] Pointer to result or nil }
        {       [ESP+8] Pointer to variant }
        {       [ESP+12]        Pointer to call descriptor }
        {       [ESP+16]        Additional parameters, if any }
        JMP     VarDispProc
end;


procedure _DispInvokeError;
asm
        MOV     AL,reVarDispatch
        JMP     Error
end;

procedure VarCastError;
asm
        MOV     AL,reVarTypeCast
        JMP     Error
end;

procedure VarInvalidOp;
asm
        MOV     AL,reVarInvalidOp
        JMP     Error
end;

procedure _VarClear(var V : Variant);
asm
        XOR     EDX,EDX
        MOV     DX,[EAX].TVarData.VType
        TEST    EDX,varByRef
        JNE     @@2
        CMP     EDX,varOleStr
        JB      @@2
        CMP     EDX,varString
        JE      @@1
        CMP     EDX,varAny
        JNE     @@3
        JMP     [ClearAnyProc]
@@1:    MOV     [EAX].TVarData.VType,varEmpty
        ADD     EAX,OFFSET TVarData.VString
        JMP     _LStrClr
@@2:    MOV     [EAX].TVarData.VType,varEmpty
        RET
@@3:    PUSH    EAX
        CALL    VariantClear
end;

procedure _VarCopy(var Dest : Variant; const Source: Variant);
asm
        CMP     EAX,EDX
        JE      @@9
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@3
        PUSH    EAX
        PUSH    EDX
        CMP     [EAX].TVarData.VType,varString
        JE      @@1
        CMP     [EAX].TVarData.VType,varAny
        JE      @@0
        PUSH    EAX
        CALL    VariantClear
        JMP     @@2
@@0:    CALL    [ClearAnyProc]
        JMP     @@2
@@1:    ADD     EAX,OFFSET TVarData.VString
        CALL    _LStrClr
@@2:    POP     EDX
        POP     EAX
@@3:    CMP     [EDX].TVarData.VType,varOleStr
        JAE     @@5
@@4:    MOV     ECX,[EDX]
        MOV     [EAX],ECX
        MOV     ECX,[EDX+8]
        MOV     [EAX+8],ECX
        MOV     ECX,[EDX+12]
        MOV     [EAX+12],ECX
        RET
@@5:    CMP     [EDX].TVarData.VType,varString
        JE      @@6
        CMP     [EDX].TVarData.VType,varAny
        JNE     @@8
        PUSH    EAX
        CALL    @@4
        POP     EAX
        JMP     [RefAnyProc]
@@6:    MOV     EDX,[EDX].TVarData.VString
        OR      EDX,EDX
        JE      @@7
        MOV     ECX,[EDX-skew].StrRec.refCnt
        INC     ECX
        JLE     @@7
{X LOCK} INC     [EDX-skew].StrRec.refCnt
@@7:    MOV     [EAX].TVarData.VType,varString
        MOV     [EAX].TVarData.VString,EDX
        RET
@@8:    MOV     [EAX].TVarData.VType,varEmpty
        PUSH    EDX
        PUSH    EAX
        CALL    VariantCopyInd
        OR      EAX,EAX
        JNE     VarInvalidOp
@@9:
end;

procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
asm
        CMP     EAX,EDX
        JE      @@9
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@3
        PUSH    EAX
        PUSH    EDX
        CMP     [EAX].TVarData.VType,varString
        JE      @@1
        CMP     [EAX].TVarData.VType,varAny
        JE      @@0
        PUSH    EAX
        CALL    VariantClear
        JMP     @@2
@@0:    CALL    [ClearAnyProc]
        JMP     @@2
@@1:    ADD     EAX,OFFSET TVarData.VString
        CALL    _LStrClr
@@2:    POP     EDX
        POP     EAX
@@3:    CMP     [EDX].TVarData.VType,varOleStr
        JAE     @@5
@@4:    MOV     ECX,[EDX]
        MOV     [EAX],ECX
        MOV     ECX,[EDX+8]
        MOV     [EAX+8],ECX
        MOV     ECX,[EDX+12]
        MOV     [EAX+12],ECX
        RET
@@5:    CMP     [EDX].TVarData.VType,varString
        JNE     @@6
        CMP     [EDX].TVarData.VType,varAny
        JNE     @@8
        CALL    @@4
        JMP     [RefAnyProc]
@@6:    MOV     EDX,[EDX].TVarData.VString
        OR      EDX,EDX
        JE      @@7
        MOV     ECX,[EDX-skew].StrRec.refCnt
        INC     ECX
        JLE     @@7
{X LOCK} INC     [EDX-skew].StrRec.refCnt
@@7:    MOV     [EAX].TVarData.VType,varString
        MOV     [EAX].TVarData.VString,EDX
        RET
@@8:    MOV     [EAX].TVarData.VType,varEmpty
        PUSH    EDX
        PUSH    EAX
        CALL    VariantCopy
@@9:
end;

type
  TAnyProc = procedure (var V: Variant);

procedure VarChangeType(var Dest: Variant; const Source: Variant;
  DestType: Word); forward;

procedure AnyChangeType(var Dest: Variant; Source: Variant; DestType: Word);
begin
  TAnyProc(ChangeAnyProc)(Source);
  VarChangeType(Dest, Source, DestType);
end;

procedure VarChangeType(var Dest: Variant; const Source: Variant;
  DestType: Word);
type
  TVarMem = array[0..3] of Integer;

  function ChangeSourceAny(var Dest: Variant; const Source: Variant;
    DestType: Word): Boolean;
  begin
    Result := False;
    if TVarData(Source).VType = varAny then
    begin
      AnyChangeType(Dest, Source, DestType);
      Result := True;
    end;
  end;

var
  Temp: TVarData;
begin
  case TVarData(Dest).VType of
    varString:
      begin
        if not ChangeSourceAny(Dest, Source, DestType) then
        begin
          Temp.VType := varEmpty;
          if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
          VarCastError;
          _VarClear(Dest);
          TVarMem(Dest)[0] := TVarMem(Temp)[0];
          TVarMem(Dest)[2] := TVarMem(Temp)[2];
          TVarMem(Dest)[3] := TVarMem(Temp)[3];
        end;
      end;
    varAny: AnyChangeType(Dest, Source, DestType);
  else if not ChangeSourceAny(Dest, Source, DestType) then
    if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
      VarCastError;
  end;
end;

procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
var
  StringPtr: Pointer;
begin
  StringPtr := nil;
  OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
  _VarClear(Dest);
  TVarData(Dest).VType := varString;
  TVarData(Dest).VString := StringPtr;
end;

procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
var
  OleStrPtr: PWideChar;
begin
  OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  _VarClear(Dest);
  TVarData(Dest).VType := varOleStr;
  TVarData(Dest).VOleStr := OleStrPtr;
end;

procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
var
  SourceType, DestType: Word;
  Temp: TVarData;
begin
  SourceType := TVarData(Source).VType;
  DestType := Word(VarType);
  if SourceType = DestType then
    _VarCopy(Dest, Source)
  else
  if SourceType = varString then
    if DestType = varOleStr then
      VarStringToOleStr(Variant(Dest), Source)
    else
    begin
      Temp.VType := varEmpty;
      VarStringToOleStr(Variant(Temp), Source);
      try
        VarChangeType(Variant(Dest), Variant(Temp), DestType);
      finally
        _VarClear(PVariant(@Temp)^);
      end;
    end
  else
  if (DestType = varString) and (SourceType <> varAny) then
    if SourceType = varOleStr then
      VarOleStrToString(Variant(Dest), Source)
    else
    begin
      Temp.VType := varEmpty;
      VarChangeType(Variant(Temp), Source, varOleStr);
      try
        VarOleStrToString(Variant(Dest), Variant(Temp));
      finally
        _VarClear(Variant(Temp));
      end;
    end
  else
    VarChangeType(Variant(Dest), Source, DestType);
end;

(* VarCast when the destination is OleVariant *)
procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
begin
  if (VarType = varString) or (VarType = varAny) then
    VarCastError
  else
    _VarCast(Dest, Source, VarType);
end;

procedure _VarToInt;
asm
        XOR     EDX,EDX
        MOV     DX,[EAX].TVarData.VType
        CMP     EDX,varInteger
        JE      @@0
        CMP     EDX,varSmallint
        JE      @@1
        CMP     EDX,varByte
        JE      @@2
        CMP     EDX,varDouble
        JE      @@5
        CMP     EDX,varSingle
        JE      @@4
        CMP     EDX,varCurrency
        JE      @@3
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EDX,EAX
        MOV     EAX,ESP
        MOV     ECX,varInteger
        CALL    _VarCast
        MOV     EAX,[ESP].TVarData.VInteger
        ADD     ESP,16
        RET
@@0:    MOV     EAX,[EAX].TVarData.VInteger
        RET
@@1:    MOVSX   EAX,[EAX].TVarData.VSmallint
        RET
@@2:    MOVZX   EAX,[EAX].TVarData.VByte
        RET
@@3:    FILD    [EAX].TVarData.VCurrency
        FDIV    C10000
        JMP     @@6
@@4:    FLD     [EAX].TVarData.VSingle
        JMP     @@6
@@5:    FLD     [EAX].TVarData.VDouble
@@6:    PUSH    EAX
        FISTP   DWORD PTR [ESP]
        FWAIT
        POP     EAX
end;

procedure _VarToBool;
asm
        CMP     [EAX].TVarData.VType,varBoolean
        JE      @@1
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EDX,EAX
        MOV     EAX,ESP
        MOV     ECX,varBoolean
        CALL    _VarCast
        MOV     AX,[ESP].TVarData.VBoolean
        ADD     ESP,16
        JMP     @@2
@@1:    MOV     AX,[EAX].TVarData.VBoolean
@@2:    NEG     AX
        SBB     EAX,EAX
        NEG     EAX
end;

procedure _VarToReal;
asm
        XOR     EDX,EDX
        MOV     DX,[EAX].TVarData.VType
        CMP     EDX,varDouble
        JE      @@1
        CMP     EDX,varSingle
        JE      @@2
        CMP     EDX,varCurrency
        JE      @@3
        CMP     EDX,varInteger
        JE      @@4
        CMP     EDX,varSmallint
        JE      @@5
        CMP     EDX,varDate
        JE      @@1
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EDX,EAX
        MOV     EAX,ESP
        MOV     ECX,varDouble
        CALL    _VarCast
        FLD     [ESP].TVarData.VDouble
        ADD     ESP,16
        RET
@@1:    FLD     [EAX].TVarData.VDouble
        RET
@@2:    FLD     [EAX].TVarData.VSingle
        RET
@@3:    FILD    [EAX].TVarData.VCurrency
        FDIV    C10000
        RET
@@4:    FILD    [EAX].TVarData.VInteger
        RET
@@5:    FILD    [EAX].TVarData.VSmallint
end;

procedure _VarToCurr;
asm
        XOR     EDX,EDX
        MOV     DX,[EAX].TVarData.VType
        CMP     EDX,varCurrency
        JE      @@1
        CMP     EDX,varDouble
        JE      @@2
        CMP     EDX,varSingle
        JE      @@3
        CMP     EDX,varInteger
        JE      @@4
        CMP     EDX,varSmallint
        JE      @@5
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EDX,EAX
        MOV     EAX,ESP
        MOV     ECX,varCurrency
        CALL    _VarCast
        FILD    [ESP].TVarData.VCurrency
        ADD     ESP,16
        RET
@@1:    FILD    [EAX].TVarData.VCurrency
        RET
@@2:    FLD     [EAX].TVarData.VDouble
        JMP     @@6
@@3:    FLD     [EAX].TVarData.VSingle
        JMP     @@6
@@4:    FILD    [EAX].TVarData.VInteger
        JMP     @@6
@@5:    FILD    [EAX].TVarData.VSmallint
@@6:    FMUL    C10000
end;

procedure _VarToPStr(var S; const V: Variant);
var
  Temp: string;
begin
  _VarToLStr(Temp, V);
  ShortString(S) := Temp;
end;

procedure _VarToLStr(var S: string; const V: Variant);
asm
        { -> EAX: destination string }
        {    EDX: source variant     }
        { <- none                    }

        CMP     [EDX].TVarData.VType,varString
        JNE     @@1
        MOV     EDX,[EDX].TVarData.VString
        JMP     _LStrAsg
@@1:    PUSH    EBX
        MOV     EBX,EAX
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EAX,ESP
        MOV     ECX,varString
        CALL    _VarCast
        MOV     EAX,EBX
        CALL    _LStrClr
        MOV     EAX,[ESP].TVarData.VString
        MOV     [EBX],EAX
        ADD     ESP,16
        POP     EBX
end;

procedure _VarToWStr(var S: WideString; const V: Variant);
asm
        CMP     [EDX].TVarData.VType,varOleStr
        JNE     @@1
        MOV     EDX,[EDX].TVarData.VOleStr
        JMP     _WStrAsg
@@1:    PUSH    EBX
        MOV     EBX,EAX
        SUB     ESP,16
        MOV     [ESP].TVarData.VType,varEmpty
        MOV     EAX,ESP
        MOV     ECX,varOleStr
        CALL    _VarCast
        MOV     EAX,EBX
        MOV     EDX,[ESP].TVarData.VOleStr
        CALL    WStrSet
        ADD     ESP,16
        POP     EBX
end;

procedure AnyToIntf(var Unknown: IUnknown; V: Variant);
begin
  TAnyProc(ChangeAnyProc)(V);
  if TVarData(V).VType <> varUnknown then
    VarCastError;
  Unknown := IUnknown(TVarData(V).VUnknown);
end;

procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
asm
        CMP     [EDX].TVarData.VType,varEmpty
        JE      _IntfClear
        CMP     [EDX].TVarData.VType,varUnknown
        JE      @@2
        CMP     [EDX].TVarData.VType,varDispatch
        JE      @@2
        CMP     [EDX].TVarData.VType,varUnknown+varByRef
        JE      @@1
        CMP     [EDX].TVarData.VType,varDispatch+varByRef
        JE      @@1
        CMP     [EDX].TVarData.VType,varAny
        JNE     VarCastError
        JMP     AnyToIntf
@@0:    CALL    _VarClear
        ADD     ESP,16
        JMP     VarCastError
@@1:    MOV     EDX,[EDX].TVarData.VPointer
        MOV     EDX,[EDX]
        JMP     _IntfCopy
@@2:    MOV     EDX,[EDX].TVarData.VUnknown
        JMP     _IntfCopy
end;

procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
asm
        CMP     [EDX].TVarData.VType,varEmpty
        JE      _IntfClear
        CMP     [EDX].TVarData.VType,varDispatch
        JE      @@1
        CMP     [EDX].TVarData.VType,varDispatch+varByRef
        JNE     VarCastError
        MOV     EDX,[EDX].TVarData.VPointer
        MOV     EDX,[EDX]
        JMP     _IntfCopy
@@1:    MOV     EDX,[EDX].TVarData.VDispatch
        JMP     _IntfCopy
end;

procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
asm
        CALL    DynArrayFromVariant
        OR      EAX, EAX
        JNZ     @@1
        JMP     VarCastError
@@1:
end;

procedure _VarFromInt;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varInteger
        MOV     [EAX].TVarData.VInteger,EDX
end;

procedure _VarFromBool;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varBoolean
        NEG     DL
        SBB     EDX,EDX
        MOV     [EAX].TVarData.VBoolean,DX
end;

procedure _VarFromReal;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        CALL    _VarClear
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varDouble
        FSTP    [EAX].TVarData.VDouble
        FWAIT
end;

procedure _VarFromTDateTime;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        CALL    _VarClear
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varDate
        FSTP    [EAX].TVarData.VDouble
        FWAIT
end;

procedure _VarFromCurr;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        CALL    _VarClear
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varCurrency
        FISTP   [EAX].TVarData.VCurrency
        FWAIT
end;

procedure _VarFromPStr(var V: Variant; const Value: ShortString);
begin
  _VarFromLStr(V, Value);
end;

procedure _VarFromLStr(var V: Variant; const Value: string);
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    TEST    EDX,EDX
        JE      @@3
        MOV     ECX,[EDX-skew].StrRec.refCnt
        INC     ECX
        JLE     @@2
{X LOCK} INC     [EDX-skew].StrRec.refCnt
        JMP     @@3
@@2:    PUSH    EAX
        PUSH    EDX
        MOV     EAX,[EDX-skew].StrRec.length
        CALL    _NewAnsiString
        MOV     EDX,EAX
        POP     EAX
        PUSH    EDX
        MOV     ECX,[EDX-skew].StrRec.length
        CALL    Move
        POP     EDX
        POP     EAX
@@3:    MOV     [EAX].TVarData.VType,varString
        MOV     [EAX].TVarData.VString,EDX
end;

procedure _VarFromWStr(var V: Variant; const Value: WideString);
asm
        PUSH    EAX
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
@@1:    XOR     EAX,EAX
        TEST    EDX,EDX
        JE      @@2
        MOV     EAX,[EDX-4]
        SHR     EAX,1
        JE      @@2
        PUSH    EAX
        PUSH    EDX
        CALL    SysAllocStringLen
        TEST    EAX,EAX
        JE      WStrError
@@2:    POP     EDX
        MOV     [EDX].TVarData.VType,varOleStr
        MOV     [EDX].TVarData.VOleStr,EAX
end;

procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varUnknown
        MOV     [EAX].TVarData.VUnknown,EDX
        TEST    EDX,EDX
        JE      @@2
        PUSH    EDX
        MOV     EAX,[EDX]
        CALL    [EAX].vmtAddRef.Pointer
@@2:
end;

procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varDispatch
        MOV     [EAX].TVarData.VDispatch,EDX
        TEST    EDX,EDX
        JE      @@2
        PUSH    EDX
        MOV     EAX,[EDX]
        CALL    [EAX].vmtAddRef.Pointer
@@2:
end;

procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
asm
        PUSH    EAX
        CALL    DynArrayToVariant
        POP     EAX
        CMP     [EAX].TVarData.VType,varEmpty
        JNE     @@1
        JMP     VarCastError
@@1:
end;

procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
begin
  _OleVarFromLStr(V, Value);
end;


procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varOleStr
        ADD     EAX,TVarData.VOleStr
        XOR     ECX,ECX
        MOV     [EAX],ECX
        JMP     _WStrFromLStr
end;

procedure OleVarFromAny(var V: OleVariant; Value: Variant);
begin
  TAnyProc(ChangeAnyProc)(Value);
  V := Value;
end;

procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
asm
        CMP     [EDX].TVarData.VType,varAny
        JE      OleVarFromAny
        CMP     [EDX].TVarData.VType,varString
        JNE     _VarCopy
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    EAX
        PUSH    EDX
        CALL    _VarClear
        POP     EDX
        POP     EAX
@@1:    MOV     [EAX].TVarData.VType,varOleStr
        ADD     EAX,TVarData.VOleStr
        ADD     EDX,TVarData.VString
        XOR     ECX,ECX
        MOV     EDX,[EDX]
        MOV     [EAX],ECX
        JMP     _WStrFromLStr
@@2:
end;


procedure VarStrCat(var Dest: Variant; const Source: Variant);
begin
  if TVarData(Dest).VType = varString then
    Dest := string(Dest) + string(Source)
  else
    Dest := WideString(Dest) + WideString(Source);
end;

procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer); forward;

procedure AnyOp(var Dest: Variant; Source: Variant; OpCode: Integer);
begin
  if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
  if TVarData(Source).VType = varAny then TAnyProc(ChangeAnyProc)(Source);
  VarOp(Dest, Source, OpCode);
end;

procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EDI,EAX
        MOV     ESI,EDX
        MOV     EBX,ECX
        MOV     EAX,[EDI].TVarData.VType.Integer
        MOV     EDX,[ESI].TVarData.VType.Integer
        AND     EAX,varTypeMask
        AND     EDX,varTypeMask
        CMP     EAX,varLast
        JBE     @@1
        CMP     EAX,varString
        JNE     @@4
        MOV     EAX,varOleStr
@@1:    CMP     EDX,varLast
        JBE     @@2
        CMP     EDX,varString
        JNE     @@3
        MOV     EDX,varOleStr
@@2:    MOV     AL,BaseTypeMap.Byte[EAX]
        MOV     DL,BaseTypeMap.Byte[EDX]
        MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
        CALL    @VarOpTable.Pointer[ECX*4]
        POP     EDI
        POP     ESI
        POP     EBX
        RET
@@3:    MOV     EAX,EDX
@@4:    CMP     EAX,varAny
        JNE     @InvalidOp
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     AnyOp

@VarOpTable:
        DD      @VarOpError
        DD      @VarOpNull
        DD      @VarOpInteger
        DD      @VarOpReal
        DD      @VarOpCurr
        DD      @VarOpString
        DD      @VarOpBoolean
        DD      @VarOpDate

@VarOpError:
        POP     EAX

@InvalidOp:
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     VarInvalidOp

@VarOpNull:
        MOV     EAX,EDI
        CALL    _VarClear
        MOV     [EDI].TVarData.VType,varNull
        RET

@VarOpInteger:
        CMP     BL,opDvd
        JE      @RealOp

@IntegerOp:
        MOV     EAX,ESI
        CALL    _VarToInt
        PUSH    EAX
        MOV     EAX,EDI
        CALL    _VarToInt
        POP     EDX
        CALL    @IntegerOpTable.Pointer[EBX*4]
        MOV     EDX,EAX
        MOV     EAX,EDI
        JMP     _VarFromInt

@IntegerOpTable:
        DD      @IntegerAdd
        DD      @IntegerSub
        DD      @IntegerMul
        DD      0
        DD      @IntegerDiv
        DD      @IntegerMod
        DD      @IntegerShl
        DD      @IntegerShr
        DD      @IntegerAnd
        DD      @IntegerOr
        DD      @IntegerXor

@IntegerAdd:
        ADD     EAX,EDX
        JO      @IntToRealOp
        RET

@IntegerSub:
        SUB     EAX,EDX
        JO      @IntToRealOp
        RET

@IntegerMul:
        IMUL    EDX
        JO      @IntToRealOp
        RET

@IntegerDiv:
        MOV     ECX,EDX
        CDQ
        IDIV    ECX
        RET

@IntegerMod:
        MOV     ECX,EDX
        CDQ
        IDIV    ECX
        MOV     EAX,EDX
        RET

@IntegerShl:
        MOV     ECX,EDX
        SHL     EAX,CL
        RET

@IntegerShr:
        MOV     ECX,EDX
        SHR     EAX,CL
        RET

@IntegerAnd:
        AND     EAX,EDX
        RET

@IntegerOr:
        OR      EAX,EDX
        RET

@IntegerXor:
        XOR     EAX,EDX
        RET

@IntToRealOp:
        POP     EAX
        JMP     @RealOp

@VarOpReal:
        CMP     BL,opDiv
        JAE     @IntegerOp

@RealOp:
        MOV     EAX,ESI
        CALL    _VarToReal
        SUB     ESP,12
        FSTP    TBYTE PTR [ESP]
        MOV     EAX,EDI
        CALL    _VarToReal
        FLD     TBYTE PTR [ESP]
        ADD     ESP,12
        CALL    @RealOpTable.Pointer[EBX*4]

@RealResult:
        MOV     EAX,EDI
        JMP     _VarFromReal

@VarOpCurr:
        CMP     BL,opDiv
        JAE     @IntegerOp
        CMP     BL,opMul
        JAE     @CurrMulDvd
        MOV     EAX,ESI
        CALL    _VarToCurr
        SUB     ESP,12
        FSTP    TBYTE PTR [ESP]
        MOV     EAX,EDI
        CALL    _VarToCurr
        FLD     TBYTE PTR [ESP]
        ADD     ESP,12
        CALL    @RealOpTable.Pointer[EBX*4]

@CurrResult:
        MOV     EAX,EDI
        JMP     _VarFromCurr

@CurrMulDvd:
        CMP     DL,btCur
        JE      @CurrOpCurr
        MOV     EAX,ESI
        CALL    _VarToReal
        FILD    [EDI].TVarData.VCurrency
        FXCH
        CALL    @RealOpTable.Pointer[EBX*4]
        JMP     @CurrResult

@CurrOpCurr:
        CMP     BL,opDvd
        JE      @CurrDvdCurr
        CMP     AL,btCur
        JE      @CurrMulCurr
        MOV     EAX,EDI
        CALL    _VarToReal
        FILD    [ESI].TVarData.VCurrency
        FMUL
        JMP     @CurrResult

@CurrMulCurr:
        FILD    [EDI].TVarData.VCurrency
        FILD    [ESI].TVarData.VCurrency
        FMUL
        FDIV    C10000
        JMP     @CurrResult

@CurrDvdCurr:
        MOV     EAX,EDI
        CALL    _VarToCurr
        FILD    [ESI].TVarData.VCurrency
        FDIV
        JMP     @RealResult

@RealOpTable:
        DD      @RealAdd
        DD      @RealSub
        DD      @RealMul
        DD      @RealDvd

@RealAdd:
        FADD
        RET

@RealSub:
        FSUB
        RET

@RealMul:
        FMUL
        RET

@RealDvd:
        FDIV
        RET

@VarOpString:
        CMP     BL,opAdd
        JNE     @VarOpReal
        MOV     EAX,EDI
        MOV     EDX,ESI
        JMP     VarStrCat

@VarOpBoolean:
        CMP     BL,opAnd
        JB      @VarOpReal
        MOV     EAX,ESI
        CALL    _VarToBool
        PUSH    EAX
        MOV     EAX,EDI
        CALL    _VarToBool
        POP     EDX
        CALL    @IntegerOpTable.Pointer[EBX*4]
        MOV     EDX,EAX
        MOV     EAX,EDI
        JMP     _VarFromBool

@VarOpDate:
        CMP     BL,opSub
        JA      @VarOpReal
        JB      @DateOp
        MOV     AH,DL
        CMP     AX,btDat+btDat*256
        JE      @RealOp

@DateOp:
        CALL    @RealOp
        MOV     [EDI].TVarData.VType,varDate
        RET
end;

procedure _VarAdd;
asm
        MOV     ECX,opAdd
        JMP     VarOp
end;

procedure _VarSub;
asm
        MOV     ECX,opSub
        JMP     VarOp
end;

procedure _VarMul;
asm
        MOV     ECX,opMul
        JMP     VarOp
end;

procedure _VarDiv;
asm
        MOV     ECX,opDiv
        JMP     VarOp
end;

procedure _VarMod;
asm
        MOV     ECX,opMod
        JMP     VarOp
end;

procedure _VarAnd;
asm
        MOV     ECX,opAnd
        JMP     VarOp
end;

procedure _VarOr;
asm
        MOV     ECX,opOr
        JMP     VarOp
end;

procedure _VarXor;
asm
        MOV     ECX,opXor
        JMP     VarOp
end;

procedure _VarShl;
asm
        MOV     ECX,opShl
        JMP     VarOp
end;

procedure _VarShr;
asm
        MOV     ECX,opShr
        JMP     VarOp
end;

procedure _VarRDiv;
asm
        MOV     ECX,opDvd
        JMP     VarOp
end;

function VarCompareString(const S1, S2: string): Integer;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EAX
        MOV     EDI,EDX
        OR      EAX,EAX
        JE      @@1
        MOV     EAX,[EAX-4]
@@1:    OR      EDX,EDX
        JE      @@2
        MOV     EDX,[EDX-4]
@@2:    MOV     ECX,EAX
        CMP     ECX,EDX
        JBE     @@3
        MOV     ECX,EDX
@@3:    CMP     ECX,ECX
        REPE    CMPSB
        JE      @@4
        MOVZX   EAX,BYTE PTR [ESI-1]
        MOVZX   EDX,BYTE PTR [EDI-1]
@@4:    SUB     EAX,EDX
        POP     EDI
        POP     ESI
end;

function VarCmpStr(const V1, V2: Variant): Integer;
begin
  Result := VarCompareString(V1, V2);
end;

function AnyCmp(var Dest: Variant; const Source: Variant): Integer;
var
  Temp: Variant;
  P: ^Variant;
begin
  asm
        PUSH    Dest
  end;
  P := @Source;
  if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
  if TVarData(Source).VType = varAny then
  begin
    Temp := Source;
    TAnyProc(ChangeAnyProc)(Temp);
    P := @Temp;
  end;
  asm
        MOV     EDX,P
        POP     EAX
        CALL    _VarCmp
        PUSHF
        POP     EAX
        MOV     Result,EAX
  end;
end;

procedure _VarCmp;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     EDI,EAX
        MOV     ESI,EDX
        MOV     EAX,[EDI].TVarData.VType.Integer
        MOV     EDX,[ESI].TVarData.VType.Integer
        AND     EAX,varTypeMask
        AND     EDX,varTypeMask
        CMP     EAX,varLast
        JBE     @@1
        CMP     EAX,varString
        JNE     @@4
        MOV     EAX,varOleStr
@@1:    CMP     EDX,varLast
        JBE     @@2
        CMP     EDX,varString
        JNE     @@3
        MOV     EDX,varOleStr
@@2:    MOV     AL,BaseTypeMap.Byte[EAX]
        MOV     DL,BaseTypeMap.Byte[EDX]
        MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
        JMP     @VarCmpTable.Pointer[ECX*4]
@@3:    MOV     EAX,EDX
@@4:    CMP     EAX,varAny
        JNE     @VarCmpError
        POP     EDI
        POP     ESI
        CALL    AnyCmp
        PUSH    EAX
        POPF
        RET

@VarCmpTable:
        DD      @VarCmpError
        DD      @VarCmpNull
        DD      @VarCmpInteger
        DD      @VarCmpReal
        DD      @VarCmpCurr
        DD      @VarCmpString
        DD      @VarCmpBoolean
        DD      @VarCmpDate

@VarCmpError:
        POP     EDI
        POP     ESI
        JMP     VarInvalidOp

@VarCmpNull:
        CMP     AL,DL
        JMP     @Exit

@VarCmpInteger:
        MOV     EAX,ESI
        CALL    _VarToInt
        XCHG    EAX,EDI
        CALL    _VarToInt
        CMP     EAX,EDI
        JMP     @Exit

@VarCmpReal:
@VarCmpDate:
        MOV     EAX,EDI
        CALL    _VarToReal
        SUB     ESP,12
        FSTP    TBYTE PTR [ESP]
        MOV     EAX,ESI
        CALL    _VarToReal
        FLD     TBYTE PTR [ESP]
        ADD     ESP,12

@RealCmp:
        FCOMPP
        FNSTSW  AX
        MOV     AL,AH   { Move CF into SF }
        AND     AX,4001H
        ROR     AL,1
        OR      AH,AL
        SAHF
        JMP     @Exit

@VarCmpCurr:
        MOV     EAX,EDI
        CALL    _VarToCurr
        SUB     ESP,12
        FSTP    TBYTE PTR [ESP]
        MOV     EAX,ESI
        CALL    _VarToCurr
        FLD     TBYTE PTR [ESP]
        ADD     ESP,12
        JMP     @RealCmp

@VarCmpString:
        MOV     EAX,EDI
        MOV     EDX,ESI
        CALL    VarCmpStr
        CMP     EAX,0
        JMP     @Exit

@VarCmpBoolean:
        MOV     EAX,ESI
        CALL    _VarToBool
        XCHG    EAX,EDI
        CALL    _VarToBool
        MOV     EDX,EDI
        CMP     AL,DL

@Exit:
        POP     EDI
        POP     ESI
end;

procedure _VarNeg;
asm
        MOV     EDX,[EAX].TVarData.VType.Integer
        AND     EDX,varTypeMask
        CMP     EDX,varLast
        JBE     @@1
        CMP     EDX,varString
        JNE     @VarNegError
        MOV     EDX,varOleStr
@@1:    MOV     DL,BaseTypeMap.Byte[EDX]
        JMP     @VarNegTable.Pointer[EDX*4]
@@2:    CMP     EAX,varAny
        JNE     @VarNegError
        PUSH    EAX
        CALL    [ChangeAnyProc]
        POP     EAX
        JMP     _VarNeg

@VarNegTable:
        DD      @VarNegError
        DD      @VarNegNull
        DD      @VarNegInteger
        DD      @VarNegReal
        DD      @VarNegCurr
        DD      @VarNegReal
        DD      @VarNegInteger
        DD      @VarNegDate

@VarNegError:
        JMP     VarInvalidOp

@VarNegNull:
        RET

@VarNegInteger:
        PUSH    EAX
        CALL    _VarToInt
        NEG     EAX
        MOV     EDX,EAX
        POP     EAX
        JMP     _VarFromInt

@VarNegReal:
        PUSH    EAX
        CALL    _VarToReal
        FCHS
        POP     EAX
        JMP     _VarFromReal

@VarNegCurr:
        FILD    [EAX].TVarData.VCurrency
        FCHS
        FISTP   [EAX].TVarData.VCurrency
        FWAIT
        RET

@VarNegDate:
        FLD     [EAX].TVarData.VDate
        FCHS
        FSTP    [EAX].TVarData.VDate
        FWAIT
end;

procedure _VarNot;
asm
        MOV     EDX,[EAX].TVarData.VType.Integer
        AND     EDX,varTypeMask
        JE      @@2
        CMP     EDX,varBoolean
        JE      @@3
        CMP     EDX,varNull
        JE      @@4
        CMP     EDX,varLast
        JBE     @@1
        CMP     EDX,varString
        JE      @@1
        CMP     EAX,varAny
        JNE     @@2
        PUSH    EAX
        CALL    [ChangeAnyProc]
        POP     EAX
        JMP     _VarNot
@@1:    PUSH    EAX
        CALL    _VarToInt
        NOT     EAX
        MOV     EDX,EAX
        POP     EAX
        JMP     _VarFromInt
@@2:    JMP     VarInvalidOp
@@3:    MOV     DX,[EAX].TVarData.VBoolean
        NEG     DX
        SBB     EDX,EDX
        NOT     EDX
        MOV     [EAX].TVarData.VBoolean,DX
@@4:
end;

procedure _VarCopyNoInd;
asm
        JMP     VarCopyNoInd
end;

procedure VariantClr;
asm
        JMP _VarClr
end;

procedure _VarClr;
asm
        PUSH    EAX
        CALL    _VarClear
        POP     EAX
end;

procedure VariantAddRef;
asm
	JMP	_VarAddRef
end;

procedure _VarAddRef;
asm
        CMP     [EAX].TVarData.VType,varOleStr
        JB      @@1
        PUSH    [EAX].Integer[12]
        PUSH    [EAX].Integer[8]
        PUSH    [EAX].Integer[4]
        PUSH    [EAX].Integer[0]
        MOV     [EAX].TVarData.VType,varEmpty
        MOV     EDX,ESP
        CALL    _VarCopy
        ADD     ESP,16
@@1:
end;

function VarType(const V: Variant): Integer;
asm
        MOVZX   EAX,[EAX].TVarData.VType
end;

function VarAsType(const V: Variant; VarType: Integer): Variant;
begin
  _VarCast(Result, V, VarType);
end;

function VarIsEmpty(const V: Variant): Boolean;
begin
  with TVarData(V) do
    Result := (VType = varEmpty) or ((VType = varDispatch) or
      (VType = varUnknown)) and (VDispatch = nil);
end;

function VarIsNull(const V: Variant): Boolean;
begin
  Result := TVarData(V).VType = varNull;
end;

function VarToStr(const V: Variant): string;
begin
  if TVarData(V).VType <> varNull then Result := V else Result := '';
end;

function VarFromDateTime(DateTime: TDateTime): Variant;
begin
  _VarClear(Result);
  TVarData(Result).VType := varDate;
  TVarData(Result).VDate := DateTime;
end;

function VarToDateTime(const V: Variant): TDateTime;
var
  Temp: TVarData;
begin
  Temp.VType := varEmpty;
  _VarCast(Variant(Temp), V, varDate);
  Result := Temp.VDate;
end;

function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
var
  S: string;
begin
  if TVarData(V).VType >= varSmallint then S := V;
  Write(T, S: Width);
  Result := @T;
end;

function _Write0Variant(var T: Text; const V: Variant): Pointer;
begin
  Result := _WriteVariant(T, V, 0);
end;

{ ----------------------------------------------------- }
{       Variant array support                           }
{ ----------------------------------------------------- }

function VarArrayCreate(const Bounds: array of Integer;
  VarType: Integer): Variant;
var
  I, DimCount: Integer;
  VarArrayRef: PVarArray;
  VarBounds: array[0..63] of TVarArrayBound;
begin
  if not Odd(High(Bounds)) or (High(Bounds) > 127) then
    Error(reVarArrayCreate);
  DimCount := (High(Bounds) + 1) div 2;
  for I := 0 to DimCount - 1 do
    with VarBounds[I] do
    begin
      LowBound := Bounds[I * 2];
      ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
    end;
  VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
  if VarArrayRef = nil then Error(reVarArrayCreate);
  _VarClear(Result);
  TVarData(Result).VType := VarType or varArray;
  TVarData(Result).VArray := VarArrayRef;
end;

function VarArrayOf(const Values: array of Variant): Variant;
var
  I: Integer;
begin
  Result := VarArrayCreate([0, High(Values)], varVariant);
  for I := 0 to High(Values) do Result[I] := Values[I];
end;

procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
var
  VarBound: TVarArrayBound;
begin
  if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
    Error(reVarNotArray);
  with TVarData(A).VArray^ do
    VarBound.LowBound := Bounds[DimCount - 1].LowBound;
  VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
  if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
    Error(reVarArrayCreate);
end;

function GetVarArray(const A: Variant): PVarArray;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  if TVarData(A).VType and varByRef <> 0 then
    Result := PVarArray(TVarData(A).VPointer^) else
    Result := TVarData(A).VArray;
end;

function VarArrayDimCount(const A: Variant): Integer;
begin
  if TVarData(A).VType and varArray <> 0 then
    Result := GetVarArray(A)^.DimCount else
    Result := 0;
end;

function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
begin
  if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
    Error(reVarArrayBounds);
end;

function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
begin
  if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
    Error(reVarArrayBounds);
end;

function VarArrayLock(const A: Variant): Pointer;
begin
  if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
    Error(reVarNotArray);
end;

procedure VarArrayUnlock(const A: Variant);
begin
  if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
    Error(reVarNotArray);
end;

function VarArrayRef(const A: Variant): Variant;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  _VarClear(Result);
  TVarData(Result).VType := TVarData(A).VType or varByRef;
  if TVarData(A).VType and varByRef <> 0 then
    TVarData(Result).VPointer := TVarData(A).VPointer else
    TVarData(Result).VPointer := @TVarData(A).VArray;
end;

function VarIsArray(const A: Variant): Boolean;
begin
  Result := TVarData(A).VType and varArray <> 0;
end;

function _VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  _VarClear(Result);
  if VarType = varVariant then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      Error(reVarArrayBounds);
    Result := PVariant(P)^;
  end else
  begin
  if SafeArrayGetElement(VarArrayPtr, @Indices,
      @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
    TVarData(Result).VType := VarType;
  end;
end;

procedure _VarArrayPut(var A: Variant; const Value: Variant;
  IndexCount: Integer; Indices: Integer); cdecl;
type
  TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer);
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
  Temp: TVarData;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      Error(reVarArrayBounds);
    PVariant(P)^ := Value;
  end else
  begin
    Temp.VType := varEmpty;
    try
      if VarType = varVariant then
      begin
        VarStringToOleStr(Variant(Temp), Value);
        P := @Temp;
      end else
      begin
        _VarCast(Variant(Temp), Value, VarType);
        case VarType of
          varOleStr, varDispatch, varUnknown:
            P := Temp.VPointer;
        else
          P := @Temp.VPointer;
        end;
      end;
      if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
        Error(reVarArrayBounds);
    finally
      _VarClear(Variant(Temp));
    end;
  end;
end;


function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
asm
        {     ->EAX     Pointer to A            }
        {       EDX     Pointer to Indices      }
        {       ECX     High bound of Indices   }
        {       [EBP+8] Pointer to result       }

        PUSH    EBX

        MOV     EBX,ECX
        INC     EBX
        JLE     @@endLoop
@@loop:
        PUSH    [EDX+ECX*4].Integer
        DEC     ECX
        JNS     @@loop
@@endLoop:
        PUSH    EBX
        PUSH    EAX
        MOV     EAX,[EBP+8]
        PUSH    EAX
        CALL    _VarArrayGet
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end;

procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Integer);
asm
        {     ->EAX     Pointer to A            }
        {       EDX     Pointer to Value        }
        {       ECX     Pointer to Indices      }
        {       [EBP+8] High bound of Indices   }

        PUSH    EBX

        MOV     EBX,[EBP+8]

        TEST    EBX,EBX
        JS      @@endLoop
@@loop:
        PUSH    [ECX+EBX*4].Integer
        DEC     EBX
        JNS     @@loop
@@endLoop:
        MOV     EBX,[EBP+8]
        INC     EBX
        PUSH    EBX
        PUSH    EDX
        PUSH    EAX
        CALL    _VarArrayPut
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end;


{ 64-bit Integer helper routines - recycling C++ RTL routines }

procedure __llmul;      external;    {$L _LL  }
procedure __lldiv;      external;    {   _LL  }
procedure __llmod;      external;    {   _LL  }
procedure __llmulo;     external;    {   _LL  (overflow version) }
procedure __lldivo;     external;    {   _LL  (overflow version) }
procedure __llmodo;     external;    {   _LL  (overflow version) }
procedure __llshl;      external;    {   _LL  }
procedure __llushr;     external;    {   _LL  }
procedure __llumod;     external;    {   _LL  }
procedure __lludiv;     external;    {   _LL  }

function _StrInt64(val: Int64; width: Integer): ShortString;
var
  d: array[0..31] of Char;  { need 19 digits and a sign }
  i, k: Integer;
  sign: Boolean;
  spaces: Integer;
begin
  { Produce an ASCII representation of the number in reverse order }
  i := 0;
  sign := val < 0;
  repeat
    d[i] := Chr( Abs(val mod 10) + Ord('0') );
    Inc(i);
    val := val div 10;
  until val = 0;
  if sign then
  begin
    d[i] := '-';
    Inc(i);
  end;

  { Fill the Result with the appropriate number of blanks }
  if width > 255 then
    width := 255;
  k := 1;
  spaces := width - i;
  while k <= spaces do
  begin
    Result[k] := ' ';
    Inc(k);
  end;

  { Fill the Result with the number }
  while i > 0 do
  begin
    Dec(i);
    Result[k] := d[i];
    Inc(k);
  end;

  { Result is k-1 characters long }
  SetLength(Result, k-1);

end;

function _Str0Int64(val: Int64): ShortString;
begin
  Result := _StrInt64(val, 0);
end;

procedure       _WriteInt64;
asm
{       PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint);        }
{     ->EAX     Pointer to file record  }
{       [ESP+4] Value                   }
{       EDX     Field width             }

        SUB     ESP,32          { VAR s: String[31];    }

        PUSH    EAX
        PUSH    EDX

        PUSH    dword ptr [ESP+8+32+8]    { Str( val : 0, s );    }
        PUSH    dword ptr [ESP+8+32+8]
        XOR     EAX,EAX
        LEA     EDX,[ESP+8+8]
        CALL    _StrInt64

        POP     ECX
        POP     EAX

        MOV     EDX,ESP         { Write( t, s : width );}
        CALL    _WriteString

        ADD     ESP,32
        RET     8
end;

procedure       _Write0Int64;
asm
{       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
{     ->EAX     Pointer to file record  }
{       EDX     Value                   }
        XOR     EDX,EDX
        JMP     _WriteInt64
end;

procedure       _ReadInt64;     external;       {$L ReadInt64 }

function _ValInt64(const s: AnsiString; var code: Integer): Int64;
var
  i: Integer;
  dig: Integer;
  sign: Boolean;
  empty: Boolean;
begin
  i := 1;
  dig := 0;
  Result := 0;
  if s = '' then
  begin
    code := i;
    exit;
  end;
  while s[i] = ' ' do
    Inc(i);
  sign := False;
  if s[i] = '-' then
  begin
    sign := True;
    Inc(i);
  end
  else if s[i] = '+' then
    Inc(i);
  empty := True;
  if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then
  begin
    if s[i] = '0' then
      Inc(i);
    Inc(i);
    while True do
    begin
      case s[i] of
      '0'..'9': dig := Ord(s[i]) -  Ord('0');
      'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10);
      'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10);
      else
        break;
      end;
      if (Result < 0) or (Result > $0FFFFFFFFFFFFFFF) then
        break;
      Result := Result shl 4 + dig;
      Inc(i);
      empty := False;
    end;
    if sign then
      Result := - Result;
  end
  else
  begin
    while True do
    begin
      case s[i] of
      '0'..'9': dig := Ord(s[i]) - Ord('0');
      else
        break;
      end;
      if (Result < 0) or (Result > $7FFFFFFFFFFFFFFF div 10) then
        break;
      Result := Result*10 + dig;
      Inc(i);
      empty := False;
    end;
    if sign then
      Result := - Result;
    if (Result <> 0) and (sign <> (Result < 0)) then
      Dec(i);
  end;
  if (s[i] <> #0) or empty then
    code := i
  else
    code := 0;
end;

procedure _DynArrayLength;
asm
{       FUNCTION _DynArrayLength(const a: array of ...): Longint; }
{     ->EAX     Pointer to array or nil                           }
{     <-EAX     High bound of array + 1 or 0                      }
        TEST    EAX,EAX
        JZ      @@skip
        MOV     EAX,[EAX-4]
@@skip:
end;

procedure _DynArrayHigh;
asm
{       FUNCTION _DynArrayHigh(const a: array of ...): Longint; }
{     ->EAX     Pointer to array or nil                         }
{     <-EAX     High bound of array or -1                       }
        CALL  _DynArrayLength
        DEC     EAX
end;

type
  PLongint = ^Longint;
  PointerArray = array [0..512*1024*1024 -2] of Pointer;
  PPointerArray = ^PointerArray;
  PDynArrayTypeInfo = ^TDynArrayTypeInfo;
  TDynArrayTypeInfo = packed record
    kind: Byte;
    name: string[0];
    elSize: Longint;
    elType: ^PDynArrayTypeInfo;
    varType: Integer;
  end;


procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer);
asm
        PUSH    dword ptr [EBP+8]
        CALL    _CopyArray
end;

procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer);
asm
        JMP     _FinalizeArray
end;

procedure DynArrayClear(var a: Pointer; typeInfo: Pointer);
asm
        CALL    _DynArrayClear
end;

procedure DynArraySetLength(var a: Pointer; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: PLongint);
var
  i: Integer;
  newLength, oldLength, minLength: Longint;
  elSize: Longint;
  neededSize: Longint;
  p, pp: Pointer;
begin
  p := a;

  // Fetch the new length of the array in this dimension, and the old length
  newLength := PLongint(lengthVec)^;
  if newLength <= 0 then
  begin
    if newLength < 0 then
      Error(reRangeError);
    DynArrayClear(a, typeInfo);
    exit;
  end;

  oldLength := 0;
  if p <> nil then
  begin
    Dec(PLongint(p));
    oldLength := PLongint(p)^;
    Dec(PLongint(p));
  end;

  // Calculate the needed size of the heap object
  Inc(PChar(typeInfo), Length(typeInfo.name));
  elSize := typeInfo.elSize;
  if typeInfo.elType <> nil then
    typeInfo := typeInfo.elType^
  else
    typeInfo := nil;
  neededSize := newLength*elSize;
  if neededSize div newLength <> elSize then
    Error(reRangeError);
  Inc(neededSize, Sizeof(Longint)*2);

  // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy
  if (p = nil) or (PLongint(p)^ = 1) then
  begin
    pp := p;
    if (newLength < oldLength) and (typeInfo <> nil) then
      FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength);
    ReallocMem(pp, neededSize);
    p := pp;
  end
  else
  begin
    Dec(PLongint(p)^);
    GetMem(p, neededSize);
    minLength := oldLength;
    if minLength > newLength then
      minLength := newLength;
    if typeInfo <> nil then
    begin
      FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0);
      CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength)
    end
    else
      Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize);
  end;

  // The heap object will now have a ref count of 1 and the new length
  PLongint(p)^ := 1;
  Inc(PLongint(p));
  PLongint(p)^ := newLength;
  Inc(PLongint(p));

  // Set the new memory to all zero bits
  FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0);

  // Take care of the inner dimensions, if any
  if dimCnt > 1 then
  begin
    Inc(lengthVec);
    Dec(dimCnt);
    for i := 0 to newLength-1 do
      DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec);
  end;
  a := p;
end;

procedure _DynArraySetLength;
asm
{       PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) }
{     ->EAX     Pointer to dynamic array (= pointer to pointer to heap object) }
{       EDX     Pointer to type info for the dynamic array                     }
{       ECX     number of dimensions                                           }
{       [ESP+4] dimensions                                                     }
        PUSH    ESP
        ADD     dword ptr [ESP],4
        CALL    DynArraySetLength
end;

procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
begin
  if a <> nil then
    _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result);
end;

procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
var
  arrayLength: Integer;
  elSize: Integer;
  typeInf: PDynArrayTypeInfo;
  p: Pointer;
begin
  p := nil;
  if a <> nil then
  begin
    typeInf := typeInfo;

    // Limit index and count to values within the array
    if index < 0 then
    begin
      Inc(count, index);
      index := 0;
    end;
    arrayLength := PLongint(PChar(a)-4)^;
    if index > arrayLength then
      index := arrayLength;
    if count > arrayLength - index then
      count := arrayLength - index;
    if count < 0 then
      count := 0;

    if count > 0 then
    begin
      // Figure out the size and type descriptor of the element type
      Inc(PChar(typeInf), Length(typeInf.name));
      elSize := typeInf.elSize;
      if typeInf.elType <> nil then
        typeInf := typeInf.elType^
      else
        typeInf := nil;

      // Allocate the amount of memory needed
      GetMem(p, count*elSize + Sizeof(Longint)*2);

      // The reference count of the new array is 1, the length is count
      PLongint(p)^ := 1;
      Inc(PLongint(p));
      PLongint(p)^ := count;
      Inc(PLongint(p));
      Inc(PChar(a), index*elSize);

      // If the element type needs destruction, we must copy each element,
      // otherwise we can just copy the bits
      if count > 0 then
      begin
        if typeInf <> nil then
        begin
          FillChar(p^, count*elSize, 0);
          CopyArray(p, a, typeInf, count)
        end
        else
          Move(a^, p^, count*elSize);
      end;
    end;
  end;
  DynArrayClear(Result, typeInfo);
  Result := p;
end;

procedure _DynArrayClear;
asm
{     ->EAX     Pointer to dynamic array (Pointer to pointer to heap object }
{       EDX     Pointer to type info                                        }

        {       Nothing to do if Pointer to heap object is nil }
        MOV     ECX,[EAX]
        TEST    ECX,ECX
        JE      @@exit

        {       Set the variable to be finalized to nil }
        MOV     dword ptr [EAX],0

        {       Decrement ref count. Nothing to do if not zero now. }
{X LOCK} DEC     dword ptr [ECX-8]
        JNE     @@exit

        {       Save the source - we're supposed to return it }
        PUSH    EAX
        MOV     EAX,ECX

        {       Fetch the type descriptor of the elements }
        XOR     ECX,ECX
        MOV     CL,[EDX].TDynArrayTypeInfo.name;
        MOV     EDX,[EDX+ECX].TDynArrayTypeInfo.elType;

        {       If it's non-nil, finalize the elements }
        TEST    EDX,EDX
        JE      @@noFinalize
        MOV     ECX,[EAX-4]
        TEST    ECX,ECX
        JE      @@noFinalize
        MOV     EDX,[EDX]
        CALL    _FinalizeArray
@@noFinalize:
        {       Now deallocate the array }
        SUB     EAX,8
        CALL    _FreeMem
        POP     EAX
@@exit:
end;


procedure _DynArrayAsg;
asm
{     ->EAX     Pointer to destination (pointer to pointer to heap object }
{       EDX     source (pointer to heap object }
{       ECX     Pointer to rtti describing dynamic array }

        PUSH    EBX
        MOV     EBX,[EAX]

        {       Increment ref count of source if non-nil }

        TEST    EDX,EDX
        JE      @@skipInc
{X LOCK} INC     dword ptr [EDX-8]
@@skipInc:
        {       Dec ref count of destination - if it becomes 0, clear dest }
        TEST    EBX,EBX
        JE  @@skipClear
{X LOCK} DEC     dword ptr[EBX-8]
        JNZ     @@skipClear
        PUSH    EAX
        PUSH    EDX
        MOV     EDX,ECX
        INC     dword ptr[EBX-8]
        CALL    _DynArrayClear
        POP     EDX
        POP     EAX
@@skipClear:
        {       Finally store source into destination }
        MOV     [EAX],EDX

        POP     EBX
end;

procedure _DynArrayAddRef;
asm
{     ->EAX     Pointer to heap object }
        TEST    EAX,EAX
        JE      @@exit
{X LOCK} INC     dword ptr [EAX-8]
@@exit:
end;


function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer;
asm
        {     ->EAX     P                       }
        {       EDX     Pointer to Indices      }
        {       ECX     High bound of Indices   }
        {       [EBP+8] TypInfo                 }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    EBP

        MOV     ESI,EDX
        MOV     EDI,[EBP+8]
        MOV     EBP,EAX

        XOR     EBX,EBX                 {  for i := 0 to High(Indices) do       }
        TEST    ECX,ECX
        JGE     @@start
@@loop:
        MOV     EBP,[EBP]
@@start:
        XOR     EAX,EAX
        MOV     AL,[EDI].TDynArrayTypeInfo.name
        ADD     EDI,EAX
        MOV     EAX,[ESI+EBX*4]         {    P := P + Indices[i]*TypInfo.elSize }
        MUL     [EDI].TDynArrayTypeInfo.elSize
        MOV     EDI,[EDI].TDynArrayTypeInfo.elType
        TEST    EDI,EDI
        JE      @@skip
        MOV     EDI,[EDI]
@@skip:
        ADD     EBP,EAX
        INC     EBX
        CMP     EBX,ECX
        JLE     @@loop

@@loopEnd:

        MOV     EAX,EBP

        POP     EBP
        POP     EDI
        POP     ESI
        POP     EBX
end;



type
  TBoundArray = array of Integer;
  PPointer    = ^Pointer;


{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo }
function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo;
begin
  Result := nil;
  if typeInfo <> nil then
  begin
    Inc(PChar(typeInfo), Length(typeInfo.name));
    if typeInfo.elType <> nil then
      Result := typeInfo.elType^;
  end;
end;

{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo}
function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer;
begin
  Result := 0;
  while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do
  begin
    Inc(Result);
    typeInfo := DynArrayElTypeInfo(typeInfo);
  end;
end;

{ Returns size of the Dynamic Array}
function DynArraySize(a: Pointer): Integer;
asm
        TEST EAX, EAX
        JZ   @@exit
        MOV  EAX, [EAX-4]
@@exit:
end;

// Returns whether array is rectangular
function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean;
var
  Dim, I, J, Size, SubSize: Integer;
  P: Pointer;
begin
  // Assume we have a rectangular array
  Result := True;

  P := DynArray;
  Dim := DynArrayDim(typeInfo);

  {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition}
  for I := 1 to dim-1 do
  begin
    if P <> nil then
    begin
      { Get size of this dimension }
      Size := DynArraySize(P);

      { Get Size of first sub. dimension }
      SubSize := DynArraySize(PPointerArray(P)[0]);

      { Walk through every dimension making sure they all have the same size}
      for J := 1  to Size-1 do
        if DynArraySize(PPointerArray(P)[J]) <> SubSize then
        begin
          Result := False;
          Exit;
        end;

      { Point to next dimension}
      P := PPointerArray(P)[0];
    end;
  end;
end;

// Returns Bounds of a DynamicArray in a format usable for creating a Variant.
//  i.e. The format of the bounds returns contains pairs of lo and hi bounds where
//       lo is always 0, and hi is the size dimension of the array-1.
function DynArrayVariantBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
var
  Dim, I: Integer;
  P: Pointer;
begin
  P := DynArray;

  Dim := DynArrayDim(typeInfo);
  SetLength(Result, Dim*2);

  I := 0;
  while I < dim*2 do
  begin
    Result[I] := 0;   // Always use 0 as low-bound in low/high pair
    Inc(I);
    if P <> nil then
    begin
      Result[I] := DynArraySize(P)-1; // Adjust for 0-base low-bound
      P := PPointerArray(p)[0];       // Assume rectangular arrays
    end;
    Inc(I);
  end;
end;

// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension
function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
var
  Dim, I: Integer;
  P: Pointer;
begin
  P := DynArray;

  Dim := DynArrayDim(typeInfo);
  SetLength(Result, Dim);

  for I := 0 to dim-1 do
    if P <> nil then
    begin
      Result[I] := DynArraySize(P)-1;
      P := PPointerArray(P)[0]; // Assume rectangular arrays
    end;
end;

// The dynamicArrayTypeInformation contains the VariantType of the element type
// when the kind == tkDynArray. This function returns that VariantType.
function DynArrayVarType(typeInfo: PDynArrayTypeInfo): Integer;
begin
  Result := varNull;
  if (typeInfo <> nil) and (typeInfo.Kind = tkDynArray) then
  begin
    Inc(PChar(typeInfo), Length(typeInfo.name));
    Result := typeInfo.varType;
  end;

  { NOTE: DECL.H and SYSTEM.PAS have different values for varString }
  if Result = $48 then
    Result := varString;
end;

type
  IntegerArray  = array[0..$effffff] of Integer;
  PIntegerArray = ^IntegerArray;
  PSmallInt     = ^SmallInt;
  PInteger      = ^Integer;
  PSingle       = ^Single;
  PDouble       = ^Double;
  PDate         = ^Double;
  PDispatch     = ^IDispatch;
  PPDispatch    = ^PDispatch;
  PError        = ^LongWord;
  PWordBool     = ^WordBool;
  PUnknown      = ^IUnknown;
  PPUnknown     = ^PUnknown;
  PByte         = ^Byte;
  PPWideChar    = ^PWideChar;

{ Decrements to next lower index - Returns True if successful }
{ Indices: Indices to be decremented }
{ Bounds : High bounds of each dimension }
function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean;
var
  I, J: Integer;
begin
  { Find out if we're done: all at zeroes }
  Result := False;
  for I := Low(Indices)  to High(Indices) do
    if Indices[I] <> 0  then
    begin
      Result := True;
      break;
    end;
  if not Result then
    Exit;

  { Two arrays must be of same length }
  Assert(Length(Indices) = Length(Bounds));

  { Find index of item to tweak }
  for I := High(Indices) downto Low(Bounds) do
  begin
    // If not reach zero, dec and bail out
    if Indices[I] <> 0 then
    begin
      Dec(Indices[I]);
      Exit;
    end
    else
    begin
      J := I;
      while Indices[J] = 0 do
      begin
        // Restore high bound when we've reached zero on a particular dimension
        Indices[J] := Bounds[J];
        // Move to higher dimension
        Dec(J);
        Assert(J >= 0);
      end;
      Dec(Indices[J]);
      Exit;
    end;
  end;
end;

// Copy Contents of Dynamic Array to Variant
// NOTE: The Dynamic array must be rectangular
//       The Dynamic array must contain items whose type is Automation compatible
// In case of failure, the function returns with a Variant of type VT_EMPTY.
procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
var
  VarBounds, Bounds, Indices: TBoundArray;
  DAVarType, VVarType, DynDim: Integer;
  PDAData: Pointer;
  Value: Variant;
begin
  VarBounds := nil;
  Bounds    := nil;
  { This resets the Variant to VT_EMPTY - flag which is used to determine whether the }
  { the cast to Variant succeeded or not }
  VarClear(V);

  { Get variantType code from DynArrayTypeInfo }
  DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));

  { Validate the Variant Type }
  if ((DAVarType > varNull) and (DAVarType <= varByte)) or (DAVarType = varString) then
  begin
    {NOTE: Map varString to varOleStr for SafeArrayCreate call }
    if DAVarType = varString then
      VVarType := varOleStr
    else
      VVarType := DAVarType;

    { Get dimension of Dynamic Array }
    DynDim := DynarrayDim(PDynArrayTypeInfo(TypeInfo));

    { If more than one dimension, make sure we're dealing with a rectangular array }
    if DynDim > 1 then
      if not IsDynArrayRectangular(DynArray, PDynArrayTypeInfo(TypeInfo)) then
        Exit;

    { Get Variant-style Bounds (lo/hi pair) of Dynamic Array }
    VarBounds := DynArrayVariantBounds(DynArray, TypeInfo);

    { Get DynArray Bounds }
    Bounds := DynArrayBounds(DynArray, TypeInfo);
    Indices:= Copy(Bounds);

    { Create Variant of SAFEARRAY }
    V := VarArrayCreate(VarBounds, VVarType);
    Assert(VarArrayDimCount(V) = DynDim);

    repeat
      PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
      if PDAData <> nil then
      begin
        case DAVarType of
          varSmallInt:  Value := PSmallInt(PDAData)^;
          varInteger:   Value := PInteger(PDAData)^;
          varSingle:    value := PSingle(PDAData)^;
          varDouble:    value := PDouble(PDAData)^;
          varCurrency:  Value := PCurrency(PDAData)^;
          varDate:      Value := PDouble(PDAData)^;
          varOleStr:    Value := PWideString(PDAData)^;
          varDispatch:  Value := PDispatch(PDAData)^;
          varError:     Value := PError(PDAData)^;
          varBoolean:   Value := PWordBool(PDAData)^;
          varVariant:   Value := PVariant(PDAData)^;
          varUnknown:   Value := PUnknown(PDAData)^;
          varByte:      Value := PByte(PDAData)^;
          varString:    Value := PString(PDAData)^;
        else
          VarClear(Value);
        end; { case }
        VarArrayPut(V, Value, Indices);
      end;
    until not DecIndices(Indices, Bounds);
  end;
end;

// Copies data from the Variant to the DynamicArray
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
var
  DADimCount, VDimCount : Integer;
  DAVarType, I: Integer;
  lengthVec: PLongInt;
  Bounds, Indices: TBoundArray;
  Value: Variant;
  PDAData: Pointer;
begin
  { Get Variant information }
  VDimCount:= VarArrayDimCount(V);

  { Allocate vector for lengths }
  GetMem(lengthVec, VDimCount * sizeof(Integer));

  { Initialize lengths - NOTE: VarArrayxxxxBound are 1-based.}
  for I := 0  to  VDimCount-1 do
    PIntegerArray(lengthVec)[I]:= (VarArrayHighBound(V, I+1) - VarArrayLowBound(V, I+1)) + 1;

  { Set Length of DynArray }
  DynArraySetLength(DynArray, PDynArrayTypeInfo(TypeInfo), VDimCount, lengthVec);

  { Get DynArray information }
  DADimCount:= DynArrayDim(PDynArrayTypeInfo(TypeInfo));
  DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));
  Assert(VDimCount = DADimCount);

  { Get DynArray Bounds }
  Bounds := DynArrayBounds(DynArray, TypeInfo);
  Indices:= Copy(Bounds);

  { Copy data over}
  repeat
    Value   := VarArrayGet(V, Indices);
    PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
    case DAVarType of
      varSmallInt:  PSmallInt(PDAData)^   := Value;
      varInteger:   PInteger(PDAData)^    := Value;
      varSingle:    PSingle(PDAData)^     := Value;
      varDouble:    PDouble(PDAData)^     := Value;
      varCurrency:  PCurrency(PDAData)^   := Value;
      varDate:      PDouble(PDAData)^     := Value;
      varOleStr:    PWideString(PDAData)^ := Value;
      varDispatch:  PDispatch(PDAData)^   := Value;
      varError:     PError(PDAData)^      := Value;
      varBoolean:   PWordBool(PDAData)^   := Value;
      varVariant:   PVariant(PDAData)^    := Value;
      varUnknown:   PUnknown(PDAData)^    := value;
      varByte:      PByte(PDAData)^       := Value;
      varString:    PString(PDAData)^     := Value;
    end; { case }
  until not DecIndices(Indices, Bounds);

  { Free vector of lengths }
  FreeMem(lengthVec);
end;



{ Package/Module registration/unregistration }

const
  LOCALE_SABBREVLANGNAME = $00000003;   { abbreviated language name }
  LOAD_LIBRARY_AS_DATAFILE = 2;
  HKEY_CURRENT_USER = $80000001;
  KEY_ALL_ACCESS = $000F003F;

  OldLocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize
  NewLocaleOverrideKey = 'Software\Borland\Locales'; // do not localize

function FindHInstance(Address: Pointer): LongWord;
var
  MemInfo: TMemInfo;
begin
  VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
  if MemInfo.State = $1000{MEM_COMMIT} then
    Result := Longint(MemInfo.AllocationBase)
  else Result := 0;
end;

function FindClassHInstance(ClassType: TClass): LongWord;
begin
  Result := FindHInstance(Pointer(ClassType));
end;

function FindResourceHInstance(Instance: LongWord): LongWord;
var
  CurModule: PLibModule;
begin
  CurModule := LibModuleList;
  while CurModule <> nil do
  begin
    if (Instance = CurModule.Instance) or
       (Instance = CurModule.CodeInstance) or
       (Instance = CurModule.DataInstance) then
    begin
      Result := CurModule.ResInstance;
      Exit;
    end;
    CurModule := CurModule.Next;
  end;
  Result := Instance;
end;

function LoadResourceModule(ModuleName: PChar): LongWord;
var
  FileName: array[0..260] of Char;
  Key: LongWord;
  LocaleName, LocaleOverride: array[0..4] of Char;
  Size: Integer;
  P: PChar;

  function FindBS(Current: PChar): PChar;
  begin
    Result := Current;
    while (Result^ <> #0) and (Result^ <> '\') do
      Result := CharNext(Result);
  end;

  function ToLongPath(AFileName: PChar): PChar;
  var
    CurrBS, NextBS: PChar;
    Handle, L: Integer;
    FindData: TWin32FindData;
    Buffer: array[0..260] of Char;
    GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar;
      cchBuffer: Integer): Integer stdcall;
  begin
    Result := AFileName;
    Handle := GetModuleHandle(kernel);
    if Handle <> 0 then
    begin
      @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA');
      if Assigned(GetLongPathName) and
         (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then
      begin
        lstrcpy(AFileName, Buffer);
        Exit;
      end;
    end;

    if AFileName[0] = '\' then
    begin
      if AFileName[1] <> '\' then Exit;
      CurrBS := FindBS(AFileName + 2);  // skip server name
      if CurrBS^ = #0 then Exit;
      CurrBS := FindBS(CurrBS + 1);     // skip share name
      if CurrBS^ = #0 then Exit;
    end else
      CurrBS := AFileName + 2;          // skip drive name

    L := CurrBS - AFileName;
    lstrcpyn(Buffer, AFileName, L + 1);
    while CurrBS^ <> #0 do
    begin
      NextBS := FindBS(CurrBS + 1);
      if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit;
      lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1);

      Handle := FindFirstFile(Buffer, FindData);
      if (Handle = -1) then Exit;
      FindClose(Handle);

      if L + 1 + lstrlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit;
      Buffer[L] := '\';
      lstrcpy(Buffer + L + 1, FindData.cFileName);
      Inc(L, lstrlen(FindData.cFileName) + 1);
      CurrBS := NextBS;
    end;
    lstrcpy(AFileName, Buffer);
  end;

begin
  GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host appliation name
  LocaleOverride[0] := #0;
  if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) or
   (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) then
  try
    Size := SizeOf(LocaleOverride);
    if RegQueryValueEx(Key, ToLongPath(FileName), nil, nil, LocaleOverride, @Size) <> 0 then
      RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size);
  finally
    RegCloseKey(Key);
  end;
  lstrcpy(FileName, ModuleName);
  GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
  Result := 0;
  if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then
  begin
    P := PChar(@FileName) + lstrlen(FileName);
    while (P^ <> '.') and (P <> @FileName) do Dec(P);
    if P <> @FileName then
    begin
      Inc(P);
      // First look for a locale registry override
      if LocaleOverride[0] <> #0 then
      begin
        lstrcpy(P, LocaleOverride);
        Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
      end;
      if (Result = 0) and (LocaleName[0] <> #0) then
      begin
        // Then look for a potential language/country translation
        lstrcpy(P, LocaleName);
        Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
        if Result = 0 then
        begin
          // Finally look for a language only translation
          LocaleName[2] := #0;
          lstrcpy(P, LocaleName);
          Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
        end;
      end;
    end;
  end;
end;

procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler;
begin
  EnumModules(TEnumModuleFuncLW(Func), Data);
end;

procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
begin
  EnumResourceModules(TEnumModuleFuncLW(Func), Data);
end;

procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer);
var
  CurModule: PLibModule;
begin
  CurModule := LibModuleList;
  while CurModule <> nil do
  begin
    if not Func(CurModule.Instance, Data) then Exit;
    CurModule := CurModule.Next;
  end;
end;

procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer);
var
  CurModule: PLibModule;
begin
  CurModule := LibModuleList;
  while CurModule <> nil do
  begin
    if not Func(CurModule.ResInstance, Data) then Exit;
    CurModule := CurModule.Next;
  end;
end;

procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
begin
  AddModuleUnloadProc(TModuleUnloadProcLW(Proc));
end;

procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
begin
  RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc));
end;

procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW);
var
  P: PModuleUnloadRec;
begin
  New(P);
  P.Next := ModuleUnloadList;
  @P.Proc := @Proc;
  ModuleUnloadList := P;
end;

procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW);
var
  P, C: PModuleUnloadRec;
begin
  P := ModuleUnloadList;
  if (P <> nil) and (@P.Proc = @Proc) then
  begin
    ModuleUnloadList := ModuleUnloadList.Next;
    Dispose(P);
  end else
  begin
    C := P;
    while C <> nil do
    begin
      if (C.Next <> nil) and (@C.Next.Proc = @Proc) then
      begin
        P := C.Next;
        C.Next := C.Next.Next;
        Dispose(P);
        Break;
      end;
      C := C.Next;
    end;
  end;
end;

procedure NotifyModuleUnload(HInstance: LongWord);
var
  P: PModuleUnloadRec;
begin
  P := ModuleUnloadList;
  while P <> nil do
  begin
    try
      P.Proc(HInstance);
    except
      // Make sure it doesn't stop notifications
    end;
    P := P.Next;
  end;
end;

procedure RegisterModule(LibModule: PLibModule);
begin
  LibModule.Next := LibModuleList;
  LibModuleList := LibModule;
end;

{X- procedure UnregisterModule(LibModule: PLibModule); -renamed }
procedure UnRegisterModuleSafely( LibModule: PLibModule );
var
  CurModule: PLibModule;
begin
  try
    NotifyModuleUnload(LibModule.Instance);
  finally
    if LibModule = LibModuleList then
      LibModuleList := LibModule.Next
    else
    begin
      CurModule := LibModuleList;
      while CurModule <> nil do
      begin
        if CurModule.Next = LibModule then
        begin
          CurModule.Next := LibModule.Next;
          Break;
        end;
        CurModule := CurModule.Next;
      end;
    end;
  end;
end;

{X+} // "Light" version of UnRegisterModule - without using of try-except
procedure UnRegisterModuleLight( LibModule: PLibModule );
var
  P: PModuleUnloadRec;
begin
  P := ModuleUnloadList;
  while P <> nil do
  begin
    P.Proc(LibModule.Instance);
    P := P.Next;
  end;
end;
{X-}

{ ResString support function }

function LoadResString(ResStringRec: PResStringRec): string;
var
  Buffer: array[0..1023] of Char;
begin
  if ResStringRec <> nil then
  if ResStringRec.Identifier < 64*1024 then
    SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^),
    ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
  else
    Result := PChar(ResStringRec.Identifier);
end;

procedure _IntfClear(var Dest: IUnknown);
asm
        MOV     EDX,[EAX]
        TEST    EDX,EDX
        JE      @@1
        MOV     DWORD PTR [EAX],0
        PUSH    EAX
        PUSH    EDX
        MOV     EAX,[EDX]
        CALL    [EAX].vmtRelease.Pointer
        POP     EAX
@@1:
end;

procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
asm
        MOV     ECX,[EAX]       { save dest }
        MOV     [EAX],EDX       { assign dest }
        TEST    EDX,EDX         { need to addref source before releasing dest }
        JE      @@1             { to make self assignment (I := I) work right }
        PUSH    ECX
        PUSH    EDX
        MOV     EAX,[EDX]
        CALL    [EAX].vmtAddRef.Pointer
        POP     ECX
@@1:    TEST    ECX,ECX
        JE      @@2
        PUSH    ECX
        MOV     EAX,[ECX]
        CALL    [EAX].vmtRelease.Pointer
@@2:
end;

procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
asm
        TEST    EDX,EDX
        JE      _IntfClear
        PUSH    EAX
        PUSH    ECX
        PUSH    EDX
        MOV     ECX,[EAX]
        TEST    ECX,ECX
        JE      @@1
        PUSH    ECX
        MOV     EAX,[ECX]
        CALL    [EAX].vmtRelease.Pointer
        MOV     EDX,[ESP]
@@1:    MOV     EAX,[EDX]
        CALL    [EAX].vmtQueryInterface.Pointer
        TEST    EAX,EAX
        JE      @@2
        MOV     AL,reIntfCastError
        JMP     Error
@@2:
end;

procedure _IntfAddRef(const Dest: IUnknown);
begin
  if Dest <> nil then Dest._AddRef;
end;

procedure TInterfacedObject.AfterConstruction;
begin
// Release the constructor's implicit refcount
  InterlockedDecrement(FRefCount);
end;

procedure TInterfacedObject.BeforeDestruction;
begin
  if RefCount <> 0 then Error(reInvalidPtr);
end;

// Set an implicit refcount so that refcounting
// during construction won't destroy the object.
class function TInterfacedObject.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TInterfacedObject(Result).FRefCount := 1;
end;

function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
const
  E_NOINTERFACE = HResult($80004002);
begin
  if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;

function TInterfacedObject._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TInterfacedObject._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

procedure _CheckAutoResult;
asm
        TEST    EAX,EAX
        JNS     @@2
        MOV     ECX,SafeCallErrorProc
        TEST    ECX,ECX
        JE      @@1
        MOV     EDX,[ESP]
        CALL    ECX
@@1:    MOV     AL,reSafeCallError
        JMP     Error
@@2:
end;


procedure _IntfDispCall;
asm
        JMP     DispCallByIDProc
end;


procedure _IntfVarCall;
asm
end;

function  CompToDouble(acomp: Comp): Double; cdecl;
begin
  Result := acomp;
end;

procedure  DoubleToComp(adouble: Double; var result: Comp); cdecl;
begin
  result := adouble;
end;

function  CompToCurrency(acomp: Comp): Currency; cdecl;
begin
  Result := acomp;
end;

procedure  CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;
begin
  result := acurrency
end;

function GetMemory(Size: Integer): Pointer; cdecl;
begin
  Result := {X- SysGetMem(Size); -replaced to use current memory manager}
            MemoryManager.GetMem( Size );
end;

function FreeMemory(P: Pointer): Integer; cdecl;
begin
  if P = nil then
    Result := 0
  else
    Result := {X- SysFreeMem(P); - replaced to use current memory manager}
              MemoryManager.FreeMem( P );
end;

function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
begin
  {X- Result := SysReallocMem(P, Size); - replaced to use current memory manager}
  Result := MemoryManager.ReallocMem( P, Size );
end;

function GetCurrentThreadId: DWORD; stdcall; external kernel name 'GetCurrentThreadId';

{X} // convert var CmdLine : PChar to a function:
{X} function CmdLine : PChar;
{X} begin
{X}   Result := GetCommandLine;
{X} end;

initialization

  {X- initialized by 0 anyway
  ExitCode  := 0;
  ErrorAddr := nil;

  RandSeed := 0;
  X+}

  {X- initialized statically
  FileMode := 2;

  Test8086 := 2;
  Test8087 := 3;
  X+}

  {X- moved to SysVarnt.pas

  TVarData(Unassigned).VType := varEmpty;
  TVarData(Null).VType := varNull;
  TVarData(EmptyParam).VType := varError;
  TVarData(EmptyParam).VError := $80020004; //DISP_E_PARAMNOTFOUND

  ClearAnyProc := @VarInvalidOp;
  ChangeAnyProc := @VarCastError;
  RefAnyProc := @VarInvalidOp;

  X+}

  {X-
  if _isNECWindows then _FpuMaskInit;
  FpuInit();
  X+}

  {X- to use Input/Output, call UseInputOutput (or include
      following two lines into your code and call Close(Input),
      Close(Output) at the end of execution).
  _Assign( Input, '' );
  _Assign( Output, '' );
  X+}

{X-  CmdLine := GetCommandLine; converted to a function }
{X-  CmdShow := GetCmdShow;     converted to a function }
  MainThreadID := GetCurrentThreadID;

finalization
  {X}if assigned( CloseInputOutput ) then
  {X}   CloseInputOutput;
  {X-
  Close(Input);
  Close(Output);
  X+}
{X  UninitAllocator; - replaced with call to UninitMemoryManager handler. }
  UninitMemoryManager;
end.