
{*******************************************************}
{                                                       }
{       Borland Delphi Runtime Library                  }
{       System Unit                                     }
{                                                       }
{       Copyright (C) 1988,98 Inprise Corporation       }
{                                                       }
{*******************************************************}

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-}

interface

const

{ Variant type codes }

  varEmpty    = $0000;
  varNull     = $0001;
  varSmallint = $0002;
  varInteger  = $0003;
  varSingle   = $0004;
  varDouble   = $0005;
  varCurrency = $0006;
  varDate     = $0007;
  varOleStr   = $0008;
  varDispatch = $0009;
  varError    = $000A;
  varBoolean  = $000B;
  varVariant  = $000C;
  varUnknown  = $000D;
  varByte     = $0011;
  varString   = $0100;
  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 LongWord;  { from WTYPES.H }

{$EXTERNALSYM IUnknown}
{$EXTERNALSYM IDispatch}

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

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

  PInterfaceTable = ^TInterfaceTable;
  TInterfaceTable = 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 BeforeDestruction; override;
    property RefCount: Integer read FRefCount;
  end;

  TInterfacedClass = class of TInterfacedObject;

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

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

  PVarData = ^TVarData;
  TVarData = 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
    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 = 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 = 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;

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 }
  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 }
  CmdShow: Integer;       { CmdShow parameter for CreateWindow }
  CmdLine: PChar;         { Command line pointer }
  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;         { Standard mode for opening files }
  Test8086: Byte;         { Will always be 2 (386 or later) }
  Test8087: Byte;         { 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 behaiour. }
  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 }

var
  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. }

  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);
function IsMemoryManagerSet: Boolean;

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;
  TModuleUnloadProc = procedure (HInstance: Integer);

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

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

procedure RegisterModule(LibModule: PLibModule);
procedure UnregisterModule(LibModule: PLibModule);
function FindHInstance(Address: Pointer): Longint;
function FindClassHInstance(ClassType: TClass): Longint;
function FindResourceHInstance(Instance: LongWord): Longint;
function LoadResourceModule(ModuleName: PChar): Longint;
procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer);
procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);

{ ResString support function/record }

type
  PResStringRec = ^TResStringRec;
  TResStringRec = 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 _SetUnion;
procedure _SetSub;
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;

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

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 WriteFile;                    external kernel name 'WriteFile';

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 FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
  external kernel name 'FreeLibrary';

function GetCommandLine: PChar; stdcall;
  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';

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

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

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

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

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

procedure Error(errorCode: Byte); forward;

{$I GETMEM.INC }

var
  MemoryManager: TMemoryManager = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem);

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;

function IsMemoryManagerSet: Boolean;
begin
  with MemoryManager do
    Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
      (@ReallocMem <> @SysReallocMem);
end;

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                   }

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

function GetParamStr(P: PChar; var Param: string): PChar;
var
  Len: Integer;
  Buffer: array[Byte] 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] > ' ' 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
        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   Minus32: double = -32.0;
asm
{       FUNCTION _RandExt: Extended;    }
{     ->EAX     Range   }

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

        FLD     Minus32
        PUSH    0
        PUSH    EDX
        FILD    qword ptr [ESP]
        ADD     ESP,8
        FSCALE
        FSTP    ST(1)
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       _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       _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       _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       _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
      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 := $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 }

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 = 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
@@CppException:
        MOV     EDX,EAX
        MOV     EAX,[ESP+4]
        MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress

@@DelphiException:
        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
        MOV     EDX,EAX
        MOV     EAX,[ESP+4+4*4]
        MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress

@@haveObject:
        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
        JE      @@DelphiException
        CLD
        CALL    _FpuInit

@@DelphiException:
        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
        { ->    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
        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] }
        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
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;


procedure FInitUnits;
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
    FInitUnits;  { try to finalize the others }
    raise;
  end;
end;


procedure InitUnits;
var
  Count, I: Integer;
  Table: PUnitEntryTable;
  P: procedure;
begin
  if InitContext.InitTable = nil then
    exit;
  Count := InitContext.InitTable^.UnitCount;
  I := 0;
  Table := InitContext.InitTable^.UnitInfo;
  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;
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
  FInitUnits;
  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

        CALL    SetExceptionHandler

        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

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


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
    MakeErrorMessage;
    if IsConsole then
      WriteLn(PChar(@runErrMsg))
    else
      MessageBox(0, runErrMsg, errCaption, 0);
  ErrorAddr := nil;
  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 }

    FInitUnits;

    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;

    UnsetExceptionHandler;

    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,97 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 = record
        allocSiz:       Longint;
        refCnt: Longint;
        length: Longint;
        end;

const
        skew = sizeof(StrRec);
        rOff = sizeof(StrRec) - sizeof(Longint);
        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
        MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
        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
        MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
        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;

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:    MOV     [EDX-skew].StrRec.refCnt,ECX

@@2:    XCHG    EDX,[EAX]
        TEST    EDX,EDX
        JE      @@3
        MOV     ECX,[EDX-skew].StrRec.refCnt
        DEC     ECX
        JL      @@3
        MOV     [EDX-skew].StrRec.refCnt,ECX
        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
        MOV     [EDX-skew].StrRec.refCnt,ECX
@@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
        MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back          }
        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
@@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
@@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
        MOV     [EAX-skew].StrRec.refCnt,EDX
@@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
        MOV     [EAX-skew].StrRec.refCnt,ECX
@@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(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(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{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             }

        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
        JMP     @@exit
@@WStringArray:
        MOV     EDX,ECX
        CALL    _WStrArrayClr
        JMP     @@exit

@@Variant:
        MOV     EAX,EBX
        ADD     EBX,16
        CALL    _VarClr
        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:
        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
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       _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
        DEC     EDI
        JG      @@WString
        JMP     @@exit

@@Variant:
        MOV     EAX,EBX
        ADD     EBX,16
        CALL    _VarAddRef
        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,  { Undefined }
    btErr,  { Undefined }
    btErr,  { Undefined }
    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
        MOV     [EDX-skew].StrRec.refCnt,ECX
@@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
        MOV     [EDX-skew].StrRec.refCnt,ECX
@@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;
var
  Temp: TVarData;
begin
  case TVarData(Dest).VType of
    varString:
      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;
    varAny: AnyChangeType(Dest, Source, DestType);
  else
    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
        MOV     [EDX-skew].StrRec.refCnt,ECX
        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
  Dest := string(Dest) + string(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 _VarClr;
asm
        PUSH    EAX
        CALL    _VarClear
        POP     EAX
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;
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 SafeArrayGetElement(VarArrayPtr, @Indices, @Result) <> 0 then
    Error(reVarArrayBounds);
  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 SafeArrayPutElement(VarArrayPtr, @Indices, @Value) <> 0 then
      Error(reVarArrayBounds);
  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, we can 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
   _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. }
        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
        INC     dword ptr [EDX-8]
@@skipInc:
        {       Dec ref count of destination - if it becomes 0, clear dest }
      TEST  EBX,EBX
        JE  @@skipClear
        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
        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);
      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)^;
      end; { case }
      VarArrayPut(V, Value, Indices);
    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): Longint;
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): Longint;
begin
  Result := FindHInstance(Pointer(ClassType));
end;

function FindResourceHInstance(Instance: LongWord): Longint;
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): Longint;
var
  FileName: array[0..260] of Char;
  Key: LongWord;
  LocaleName, LocaleOverride: array[0..4] of Char;
  Size: Integer;
  P: PChar;
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, 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);
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: TEnumModuleFunc; 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);
var
  P: PModuleUnloadRec;
begin
  New(P);
  P.Next := ModuleUnloadList;
  @P.Proc := @Proc;
  ModuleUnloadList := P;
end;

procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
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: Longint);
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;

procedure UnregisterModule(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;

{ 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.BeforeDestruction;
begin
  if RefCount <> 0 then Error(reInvalidPtr);
end;

function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
const
  E_NOINTERFACE = $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 := SysGetMem(Size);
end;

function FreeMemory(P: Pointer): Integer; cdecl;
begin
  if P = nil then
    Result := 0
  else
    Result := SysFreeMem(P);
end;

function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
begin
  Result := SysReallocMem(P, Size);
end;

function GetCurrentThreadId: DWORD; stdcall; external kernel name 'GetCurrentThreadId';

initialization

  ExitCode  := 0;
  ErrorAddr := nil;

  RandSeed := 0;
  FileMode := 2;

  Test8086 := 2;
  Test8087 := 3;

  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;

  if _isNECWindows then _FpuMaskInit;
  _FpuInit();

  _Assign( Input, '' );  { _ResetText( Input );   }
  _Assign( Output, '' );  { _RewritText( Output ); }

  CmdLine := GetCommandLine;
  CmdShow := GetCmdShow;
  MainThreadID := GetCurrentThreadID;

finalization
  Close(Input);
  Close(Output);
  UninitAllocator;
end.
