home *** CD-ROM | disk | FTP | other *** search
/ Delphi 5 for Professionals / DELPHI5.iso / Runimage / Delphi50 / Source / Rtl / Sys / system.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  302.6 KB  |  11,514 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Runtime Library                  }
  5. {       System Unit                                     }
  6. {                                                       }
  7. {       Copyright (C) 1988,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit System; { Predefined constants, types, procedures, }
  12.              { and functions (such as True, Integer, or }
  13.              { Writeln) do not have actual declarations.}
  14.              { Instead they are built into the compiler }
  15.              { and are treated as if they were declared }
  16.              { at the beginning of the System unit.     }
  17.  
  18. {$H+,I-,S-}
  19.  
  20. { L- should never be specified.
  21.  
  22.   The IDE needs to find debug hook (through the C++
  23.   compiler sometimes) for integrated debugging to
  24.   function properly.
  25.  
  26.   ILINK will generate debug info for DebugHook if
  27.   the object module has not been compiled with debug info.
  28.  
  29.   ILINK will not generate debug info for DebugHook if
  30.   the object module has been compiled with debug info.
  31.  
  32.   Thus, the Pascal compiler must be responsible for
  33.   generating the debug information for that symbol
  34.   when a debug-enabled object file is produced.
  35. }
  36.  
  37. interface
  38.  
  39. const
  40.  
  41. { Variant type codes (wtypes.h) }
  42.  
  43.   varEmpty    = $0000; { vt_empty       }
  44.   varNull     = $0001; { vt_null        }
  45.   varSmallint = $0002; { vt_i2          }
  46.   varInteger  = $0003; { vt_i4          }
  47.   varSingle   = $0004; { vt_r4          }
  48.   varDouble   = $0005; { vt_r8          }
  49.   varCurrency = $0006; { vt_cy          }
  50.   varDate     = $0007; { vt_date        }
  51.   varOleStr   = $0008; { vt_bstr        }
  52.   varDispatch = $0009; { vt_dispatch    }
  53.   varError    = $000A; { vt_error       }
  54.   varBoolean  = $000B; { vt_bool        }
  55.   varVariant  = $000C; { vt_variant     }
  56.   varUnknown  = $000D; { vt_unknown     }
  57.                        { vt_decimal $e  }
  58.                        { undefined  $f  }
  59.                        { vt_i1      $10 }
  60.   varByte     = $0011; { vt_ui1         }
  61.                        { vt_ui2     $12 }
  62.                        { vt_ui4     $13 }
  63.                        { vt_i8      $14 }
  64.   { if adding new items, update varLast, BaseTypeMap and OpTypeMap }
  65.   varStrArg   = $0048; { vt_clsid    }
  66.   varString   = $0100; { Pascal string; not OLE compatible }
  67.   varAny      = $0101;
  68.   varTypeMask = $0FFF;
  69.   varArray    = $2000;
  70.   varByRef    = $4000;
  71.  
  72. { TVarRec.VType values }
  73.  
  74.   vtInteger    = 0;
  75.   vtBoolean    = 1;
  76.   vtChar       = 2;
  77.   vtExtended   = 3;
  78.   vtString     = 4;
  79.   vtPointer    = 5;
  80.   vtPChar      = 6;
  81.   vtObject     = 7;
  82.   vtClass      = 8;
  83.   vtWideChar   = 9;
  84.   vtPWideChar  = 10;
  85.   vtAnsiString = 11;
  86.   vtCurrency   = 12;
  87.   vtVariant    = 13;
  88.   vtInterface  = 14;
  89.   vtWideString = 15;
  90.   vtInt64      = 16;
  91.  
  92. { Virtual method table entries }
  93.  
  94.   vmtSelfPtr           = -76;
  95.   vmtIntfTable         = -72;
  96.   vmtAutoTable         = -68;
  97.   vmtInitTable         = -64;
  98.   vmtTypeInfo          = -60;
  99.   vmtFieldTable        = -56;
  100.   vmtMethodTable       = -52;
  101.   vmtDynamicTable      = -48;
  102.   vmtClassName         = -44;
  103.   vmtInstanceSize      = -40;
  104.   vmtParent            = -36;
  105.   vmtSafeCallException = -32;
  106.   vmtAfterConstruction = -28;
  107.   vmtBeforeDestruction = -24;
  108.   vmtDispatch          = -20;
  109.   vmtDefaultHandler    = -16;
  110.   vmtNewInstance       = -12;
  111.   vmtFreeInstance      = -8;
  112.   vmtDestroy           = -4;
  113.  
  114.   vmtQueryInterface    = 0;
  115.   vmtAddRef            = 4;
  116.   vmtRelease           = 8;
  117.   vmtCreateObject      = 12;
  118.  
  119. type
  120.  
  121.   TObject = class;
  122.  
  123.   TClass = class of TObject;
  124.  
  125.   {$EXTERNALSYM HRESULT}
  126.   HRESULT = type Longint;  { from WTYPES.H }
  127.  
  128. {$EXTERNALSYM IUnknown}
  129. {$EXTERNALSYM IDispatch}
  130.  
  131.   PGUID = ^TGUID;
  132.   TGUID = packed record
  133.     D1: LongWord;
  134.     D2: Word;
  135.     D3: Word;
  136.     D4: array[0..7] of Byte;
  137.   end;
  138.  
  139.   PInterfaceEntry = ^TInterfaceEntry;
  140.   TInterfaceEntry = packed record
  141.     IID: TGUID;
  142.     VTable: Pointer;
  143.     IOffset: Integer;
  144.     ImplGetter: Integer;
  145.   end;
  146.  
  147.   PInterfaceTable = ^TInterfaceTable;
  148.   TInterfaceTable = packed record
  149.     EntryCount: Integer;
  150.     Entries: array[0..9999] of TInterfaceEntry;
  151.   end;
  152.  
  153.   TObject = class
  154.     constructor Create;
  155.     procedure Free;
  156.     class function InitInstance(Instance: Pointer): TObject;
  157.     procedure CleanupInstance;
  158.     function ClassType: TClass;
  159.     class function ClassName: ShortString;
  160.     class function ClassNameIs(const Name: string): Boolean;
  161.     class function ClassParent: TClass;
  162.     class function ClassInfo: Pointer;
  163.     class function InstanceSize: Longint;
  164.     class function InheritsFrom(AClass: TClass): Boolean;
  165.     class function MethodAddress(const Name: ShortString): Pointer;
  166.     class function MethodName(Address: Pointer): ShortString;
  167.     function FieldAddress(const Name: ShortString): Pointer;
  168.     function GetInterface(const IID: TGUID; out Obj): Boolean;
  169.     class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
  170.     class function GetInterfaceTable: PInterfaceTable;
  171.     function SafeCallException(ExceptObject: TObject;
  172.       ExceptAddr: Pointer): HResult; virtual;
  173.     procedure AfterConstruction; virtual;
  174.     procedure BeforeDestruction; virtual;
  175.     procedure Dispatch(var Message); virtual;
  176.     procedure DefaultHandler(var Message); virtual;
  177.     class function NewInstance: TObject; virtual;
  178.     procedure FreeInstance; virtual;
  179.     destructor Destroy; virtual;
  180.   end;
  181.  
  182.   IUnknown = interface
  183.     ['{00000000-0000-0000-C000-000000000046}']
  184.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  185.     function _AddRef: Integer; stdcall;
  186.     function _Release: Integer; stdcall;
  187.   end;
  188.  
  189.   IDispatch = interface(IUnknown)
  190.     ['{00020400-0000-0000-C000-000000000046}']
  191.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  192.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  193.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  194.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  195.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  196.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  197.   end;
  198.  
  199.   TInterfacedObject = class(TObject, IUnknown)
  200.   protected
  201.     FRefCount: Integer;
  202.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  203.     function _AddRef: Integer; stdcall;
  204.     function _Release: Integer; stdcall;
  205.   public
  206.     procedure AfterConstruction; override;
  207.     procedure BeforeDestruction; override;
  208.     class function NewInstance: TObject; override;
  209.     property RefCount: Integer read FRefCount;
  210.   end;
  211.  
  212.   TInterfacedClass = class of TInterfacedObject;
  213.  
  214.   TVarArrayBound = packed record
  215.     ElementCount: Integer;
  216.     LowBound: Integer;
  217.   end;
  218.  
  219.   PVarArray = ^TVarArray;
  220.   TVarArray = packed record
  221.     DimCount: Word;
  222.     Flags: Word;
  223.     ElementSize: Integer;
  224.     LockCount: Integer;
  225.     Data: Pointer;
  226.     Bounds: array[0..255] of TVarArrayBound;
  227.   end;
  228.  
  229.   PVarData = ^TVarData;
  230.   TVarData = packed record
  231.     VType: Word;
  232.     Reserved1, Reserved2, Reserved3: Word;
  233.     case Integer of
  234.       varSmallint: (VSmallint: Smallint);
  235.       varInteger:  (VInteger: Integer);
  236.       varSingle:   (VSingle: Single);
  237.       varDouble:   (VDouble: Double);
  238.       varCurrency: (VCurrency: Currency);
  239.       varDate:     (VDate: Double);
  240.       varOleStr:   (VOleStr: PWideChar);
  241.       varDispatch: (VDispatch: Pointer);
  242.       varError:    (VError: LongWord);
  243.       varBoolean:  (VBoolean: WordBool);
  244.       varUnknown:  (VUnknown: Pointer);
  245.       varByte:     (VByte: Byte);
  246.       varString:   (VString: Pointer);
  247.       varAny:      (VAny: Pointer);
  248.       varArray:    (VArray: PVarArray);
  249.       varByRef:    (VPointer: Pointer);
  250.   end;
  251.  
  252.   PShortString = ^ShortString;
  253.   PAnsiString = ^AnsiString;
  254.   PWideString = ^WideString;
  255.   PString = PAnsiString;
  256.  
  257.   PExtended = ^Extended;
  258.   PCurrency = ^Currency;
  259.   PVariant = ^Variant;
  260.   POleVariant = ^OleVariant;
  261.   PInt64 = ^Int64;
  262.  
  263.   TDateTime = type Double;
  264.   PDateTime = ^TDateTime;
  265.  
  266.   PVarRec = ^TVarRec;
  267.   TVarRec = record { do not pack this record; it is compiler-generated }
  268.     case Byte of
  269.       vtInteger:    (VInteger: Integer; VType: Byte);
  270.       vtBoolean:    (VBoolean: Boolean);
  271.       vtChar:       (VChar: Char);
  272.       vtExtended:   (VExtended: PExtended);
  273.       vtString:     (VString: PShortString);
  274.       vtPointer:    (VPointer: Pointer);
  275.       vtPChar:      (VPChar: PChar);
  276.       vtObject:     (VObject: TObject);
  277.       vtClass:      (VClass: TClass);
  278.       vtWideChar:   (VWideChar: WideChar);
  279.       vtPWideChar:  (VPWideChar: PWideChar);
  280.       vtAnsiString: (VAnsiString: Pointer);
  281.       vtCurrency:   (VCurrency: PCurrency);
  282.       vtVariant:    (VVariant: PVariant);
  283.       vtInterface:  (VInterface: Pointer);
  284.       vtWideString: (VWideString: Pointer);
  285.       vtInt64:      (VInt64: PInt64);
  286.   end;
  287.  
  288.   PMemoryManager = ^TMemoryManager;
  289.   TMemoryManager = record
  290.     GetMem: function(Size: Integer): Pointer;
  291.     FreeMem: function(P: Pointer): Integer;
  292.     ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  293.   end;
  294.  
  295.   THeapStatus = record
  296.     TotalAddrSpace: Cardinal;
  297.     TotalUncommitted: Cardinal;
  298.     TotalCommitted: Cardinal;
  299.     TotalAllocated: Cardinal;
  300.     TotalFree: Cardinal;
  301.     FreeSmall: Cardinal;
  302.     FreeBig: Cardinal;
  303.     Unused: Cardinal;
  304.     Overhead: Cardinal;
  305.     HeapErrorCode: Cardinal;
  306.   end;
  307.  
  308.   PackageUnitEntry = packed record
  309.     Init, FInit : procedure;
  310.   end;
  311.  
  312.   { Compiler generated table to be processed sequentially to init & finit all package units }
  313.   { Init: 0..Max-1; Final: Last Initialized..0                                              }
  314.   UnitEntryTable = array [0..9999999] of PackageUnitEntry;
  315.   PUnitEntryTable = ^UnitEntryTable;
  316.  
  317.   PackageInfoTable = packed record
  318.     UnitCount : Integer;      { number of entries in UnitInfo array; always > 0 }
  319.     UnitInfo : PUnitEntryTable;
  320.   end;
  321.  
  322.   PackageInfo = ^PackageInfoTable;
  323.  
  324.   { Each package exports a '@GetPackageInfoTable' which can be used to retrieve }
  325.   { the table which contains compiler generated information about the package DLL }
  326.   GetPackageInfoTable = function : PackageInfo;
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  
  339.  
  340.  
  341.  
  342.  
  343. function RaiseList: Pointer;  { Stack of current exception objects }
  344. function SetRaiseList(NewPtr: Pointer): Pointer;  { returns previous value }
  345. procedure SetInOutRes(NewValue: Integer);
  346.  
  347. var
  348.  
  349.   ExceptProc: Pointer;    { Unhandled exception handler }
  350.   ErrorProc: Pointer;     { Error handler procedure }
  351.   ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
  352.   ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
  353.   ExceptionClass: TClass; { Exception base class (must be Exception) }
  354.   SafeCallErrorProc: Pointer; { Safecall error handler }
  355.   AssertErrorProc: Pointer; { Assertion error handler }
  356.   AbstractErrorProc: Pointer; { Abstract method error handler }
  357.   HPrevInst: LongWord;    { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32}
  358.   MainInstance: LongWord; { Handle of the main(.EXE) HInstance }
  359.   MainThreadID: LongWord; { ThreadID of thread that module was initialized in }
  360.   IsLibrary: Boolean;     { True if module is a DLL }
  361.   CmdShow: Integer;       { CmdShow parameter for CreateWindow }
  362.   CmdLine: PChar;         { Command line pointer }
  363.   InitProc: Pointer;      { Last installed initialization procedure }
  364.   ExitCode: Integer;      { Program result }
  365.   ExitProc: Pointer;      { Last installed exit procedure }
  366.   ErrorAddr: Pointer;     { Address of run-time error }
  367.   RandSeed: Longint;      { Base for random number generator }
  368.   IsConsole: Boolean;     { True if compiled as console app }
  369.   IsMultiThread: Boolean; { True if more than one thread }
  370.   FileMode: Byte;         { Standard mode for opening files }
  371.   Test8086: Byte;         { Will always be 2 (386 or later) }
  372.   Test8087: Byte;         { Will always be 3 (387 or later) }
  373.   TestFDIV: Shortint;     { -1: Flawed Pentium, 0: Not determined, 1: Ok }
  374.   Input: Text;            { Standard input }
  375.   Output: Text;           { Standard output }
  376.  
  377.   ClearAnyProc: Pointer;  { Handler clearing a varAny }
  378.   ChangeAnyProc: Pointer; { Handler to change any to variant }
  379.   RefAnyProc: Pointer;    { Handler to add a reference to an varAny }
  380.  
  381. var
  382.   Default8087CW: Word = $1332;{ Default 8087 control word.  FPU control
  383.                                 register is set to this value.
  384.                                 CAUTION:  Setting this to an invalid value
  385.                                           could cause unpredictable behavior. }
  386.  
  387.   HeapAllocFlags: Word = 2;   { Heap allocation flags, gmem_Moveable }
  388.   DebugHook: Byte = 0;        { 1 to notify debugger of non-Delphi exceptions
  389.                                 >1 to notify debugger of exception unwinding }
  390.   JITEnable: Byte = 0;        { 1 to call UnhandledExceptionFilter if the exception
  391.                                   is not a Pascal exception.
  392.                                 >1 to call UnhandledExceptionFilter for all exceptions }
  393.   NoErrMsg: Boolean = False;  { True causes the base RTL to not display the message box
  394.                                 when a run-time error occurs }
  395.  
  396. var
  397.   Unassigned: Variant;    { Unassigned standard constant }
  398.   Null: Variant;          { Null standard constant }
  399.   EmptyParam: OleVariant; { "Empty parameter" standard constant which can be
  400.                             passed as an optional parameter on a dual interface. }
  401.  
  402.   AllocMemCount: Integer; { Number of allocated memory blocks }
  403.   AllocMemSize: Integer;  { Total size of allocated memory blocks }
  404.  
  405. { Memory manager support }
  406.  
  407. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  408. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  409. function IsMemoryManagerSet: Boolean;
  410.  
  411. function SysGetMem(Size: Integer): Pointer;
  412. function SysFreeMem(P: Pointer): Integer;
  413. function SysReallocMem(P: Pointer; Size: Integer): Pointer;
  414.  
  415. function GetHeapStatus: THeapStatus;
  416.  
  417. { Thread support }
  418. type
  419.   TThreadFunc = function(Parameter: Pointer): Integer;
  420.  
  421. function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
  422.   ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
  423.   var ThreadId: LongWord): Integer;
  424.  
  425. procedure EndThread(ExitCode: Integer);
  426.  
  427. { Standard procedures and functions }
  428.  
  429. procedure _ChDir(const S: string);
  430. procedure __Flush(var F: Text);
  431. procedure _LGetDir(D: Byte; var S: string);
  432. procedure _SGetDir(D: Byte; var S: ShortString);
  433. function IOResult: Integer;
  434. procedure _MkDir(const S: string);
  435. procedure Move(const Source; var Dest; Count: Integer);
  436. function ParamCount: Integer;
  437. function ParamStr(Index: Integer): string;
  438. procedure Randomize;
  439. procedure _RmDir(const S: string);
  440. function UpCase(Ch: Char): Char;
  441.  
  442. { Control 8087 control word }
  443.  
  444. procedure Set8087CW(NewCW: Word);
  445.  
  446. { Wide character support procedures and functions }
  447.  
  448. function WideCharToString(Source: PWideChar): string;
  449. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  450. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  451. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  452.   var Dest: string);
  453. function StringToWideChar(const Source: string; Dest: PWideChar;
  454.   DestSize: Integer): PWideChar;
  455.  
  456. { OLE string support procedures and functions }
  457.  
  458. function OleStrToString(Source: PWideChar): string;
  459. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  460. function StringToOleStr(const Source: string): PWideChar;
  461.  
  462. { Variant support procedures and functions }
  463.  
  464. procedure _VarClear(var V : Variant);
  465. procedure _VarCopy(var Dest : Variant; const Source: Variant);
  466. procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
  467. procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
  468. procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
  469. function VarType(const V: Variant): Integer;
  470. function VarAsType(const V: Variant; VarType: Integer): Variant;
  471. function VarIsEmpty(const V: Variant): Boolean;
  472. function VarIsNull(const V: Variant): Boolean;
  473. function VarToStr(const V: Variant): string;
  474. function VarFromDateTime(DateTime: TDateTime): Variant;
  475. function VarToDateTime(const V: Variant): TDateTime;
  476.  
  477. { Variant array support procedures and functions }
  478.  
  479. function VarArrayCreate(const Bounds: array of Integer;
  480.   VarType: Integer): Variant;
  481. function VarArrayOf(const Values: array of Variant): Variant;
  482. procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
  483. function VarArrayDimCount(const A: Variant): Integer;
  484. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  485. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  486. function VarArrayLock(const A: Variant): Pointer;
  487. procedure VarArrayUnlock(const A: Variant);
  488. function VarArrayRef(const A: Variant): Variant;
  489. function VarIsArray(const A: Variant): Boolean;
  490.  
  491. { Variant IDispatch call support }
  492.  
  493. procedure _DispInvokeError;
  494.  
  495. var
  496.   VarDispProc: Pointer = @_DispInvokeError;
  497.   DispCallByIDProc: Pointer = @_DispInvokeError;
  498.  
  499. { Package/Module registration and unregistration }
  500.  
  501. type
  502.   PLibModule = ^TLibModule;
  503.   TLibModule = record
  504.     Next: PLibModule;
  505.     Instance: LongWord;
  506.     CodeInstance: LongWord;
  507.     DataInstance: LongWord;
  508.     ResInstance: LongWord;
  509.     Reserved: Integer;
  510.   end;
  511.  
  512.   TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean;
  513.   {$EXTERNALSYM TEnumModuleFunc}
  514.   TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean;
  515.   {$EXTERNALSYM TEnumModuleFuncLW}
  516.   TModuleUnloadProc = procedure (HInstance: Integer);
  517.   {$EXTERNALSYM TModuleUnloadProc}
  518.   TModuleUnloadProcLW = procedure (HInstance: LongWord);
  519.   {$EXTERNALSYM TModuleUnloadProcLW}
  520.  
  521.   PModuleUnloadRec = ^TModuleUnloadRec;
  522.   TModuleUnloadRec = record
  523.     Next: PModuleUnloadRec;
  524.     Proc: TModuleUnloadProcLW;
  525.   end;
  526.  
  527. var
  528.   LibModuleList: PLibModule = nil;
  529.   ModuleUnloadList: PModuleUnloadRec = nil;
  530.  
  531. procedure RegisterModule(LibModule: PLibModule);
  532. procedure UnregisterModule(LibModule: PLibModule);
  533. function FindHInstance(Address: Pointer): LongWord;
  534. function FindClassHInstance(ClassType: TClass): LongWord;
  535. function FindResourceHInstance(Instance: LongWord): LongWord;
  536. function LoadResourceModule(ModuleName: PChar): LongWord;
  537. procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload;
  538. procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload;
  539. procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
  540. procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
  541. procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload;
  542. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload;
  543. procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;
  544. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;
  545.  
  546. { ResString support function/record }
  547.  
  548. type
  549.   PResStringRec = ^TResStringRec;
  550.   TResStringRec = packed record
  551.     Module: ^Longint;
  552.     Identifier: Integer;
  553.   end;
  554.  
  555. function LoadResString(ResStringRec: PResStringRec): string;
  556.  
  557. { Procedures and functions that need compiler magic }
  558.  
  559. procedure _COS;
  560. procedure _EXP;
  561. procedure _INT;
  562. procedure _SIN;
  563. procedure _FRAC;
  564. procedure _ROUND;
  565. procedure _TRUNC;
  566.  
  567. procedure _AbstractError;
  568. procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
  569. procedure _Append;
  570. procedure _Assign(var T: Text; S: ShortString);
  571. procedure _BlockRead;
  572. procedure _BlockWrite;
  573. procedure _Close;
  574. procedure _PStrCat;
  575. procedure _PStrNCat;
  576. procedure _PStrCpy;
  577. procedure _PStrNCpy;
  578. procedure _EofFile;
  579. procedure _EofText;
  580. procedure _Eoln;
  581. procedure _Erase;
  582. procedure _FilePos;
  583. procedure _FileSize;
  584. procedure _FillChar;
  585. procedure _FreeMem;
  586. procedure _GetMem;
  587. procedure _ReallocMem;
  588. procedure _Halt;
  589. procedure _Halt0;
  590. procedure _Mark;
  591. procedure _PStrCmp;
  592. procedure _AStrCmp;
  593. procedure _RandInt;
  594. procedure _RandExt;
  595. procedure _ReadRec;
  596. procedure _ReadChar;
  597. procedure _ReadLong;
  598. procedure _ReadString;
  599. procedure _ReadCString;
  600. procedure _ReadLString;
  601. procedure _ReadExt;
  602. procedure _ReadLn;
  603. procedure _Rename;
  604. procedure _Release;
  605. procedure _ResetText(var T: Text);
  606. procedure _ResetFile;
  607. procedure _RewritText(var T: Text);
  608. procedure _RewritFile;
  609. procedure _RunError;
  610. procedure _Run0Error;
  611. procedure _Seek;
  612. procedure _SeekEof;
  613. procedure _SeekEoln;
  614. procedure _SetTextBuf;
  615. procedure _StrLong;
  616. procedure _Str0Long;
  617. procedure _Truncate;
  618. procedure _ValLong;
  619. procedure _WriteRec;
  620. procedure _WriteChar;
  621. procedure _Write0Char;
  622. procedure _WriteBool;
  623. procedure _Write0Bool;
  624. procedure _WriteLong;
  625. procedure _Write0Long;
  626. procedure _WriteString;
  627. procedure _Write0String;
  628. procedure _WriteCString;
  629. procedure _Write0CString;
  630. procedure _WriteLString;
  631. procedure _Write0LString;
  632. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  633. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  634. procedure _Write2Ext;
  635. procedure _Write1Ext;
  636. procedure _Write0Ext;
  637. procedure _WriteLn;
  638.  
  639. procedure __CToPasStr;
  640. procedure __CLenToPasStr;
  641. procedure __ArrayToPasStr;
  642. procedure __PasToCStr;
  643.  
  644. procedure __IOTest;
  645. procedure _Flush(var F: Text);
  646.  
  647. procedure _SetElem;
  648. procedure _SetRange;
  649. procedure _SetEq;
  650. procedure _SetLe;
  651. procedure _SetIntersect;
  652. procedure _SetIntersect3; { BEG only }
  653. procedure _SetUnion;
  654. procedure _SetUnion3; { BEG only }
  655. procedure _SetSub;
  656. procedure _SetSub3; { BEG only }
  657. procedure _SetExpand;
  658.  
  659. procedure _Str2Ext;
  660. procedure _Str0Ext;
  661. procedure _Str1Ext;
  662. procedure _ValExt;
  663. procedure _Pow10;
  664. procedure _Real2Ext;
  665. procedure _Ext2Real;
  666.  
  667. procedure _ObjSetup;
  668. procedure _ObjCopy;
  669. procedure _Fail;
  670. procedure _BoundErr;
  671. procedure _IntOver;
  672. procedure _StartExe;
  673. procedure _StartLib;
  674. procedure _PackageLoad  (const Table : PackageInfo);
  675. procedure _PackageUnload(const Table : PackageInfo);
  676. procedure _InitResStrings;
  677. procedure _InitResStringImports;
  678. procedure _InitImports;
  679. procedure _InitWideStrings;
  680.  
  681. procedure _ClassCreate;
  682. procedure _ClassDestroy;
  683. procedure _AfterConstruction;
  684. procedure _BeforeDestruction;
  685. procedure _IsClass;
  686. procedure _AsClass;
  687.  
  688. procedure _RaiseExcept;
  689. procedure _RaiseAgain;
  690. procedure _DoneExcept;
  691. procedure _TryFinallyExit;
  692.  
  693. procedure _CallDynaInst;
  694. procedure _CallDynaClass;
  695. procedure _FindDynaInst;
  696. procedure _FindDynaClass;
  697.  
  698. procedure _LStrClr(var S: AnsiString);
  699. procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
  700. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  701. procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
  702. procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  703. procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  704. procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
  705. procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
  706. procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
  707. procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
  708. procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
  709. procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  710. procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  711. procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
  712. procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
  713. function _LStrLen{str: AnsiString}: Longint;
  714. procedure _LStrCat{var dest: AnsiString; source: AnsiString};
  715. procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  716. procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  717. procedure _LStrCmp{left: AnsiString; right: AnsiString};
  718. procedure _LStrAddRef{str: AnsiString};
  719. procedure _LStrToPChar{str: AnsiString): PChar};
  720. procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  721. procedure _Delete{ var s : openstring; index, count : Integer };
  722. procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
  723. procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
  724. procedure _SetLength{var s: ShortString; newLength: Integer};
  725. procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};
  726.  
  727. procedure UniqueString(var str: string);
  728. procedure _NewAnsiString{length: Longint};      { for debugger purposes only }
  729.  
  730. procedure _LStrCopy  { const s : AnsiString; index, count : Integer) : AnsiString};
  731. procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
  732. procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  733. procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  734. procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
  735. procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };
  736.  
  737. procedure _WStrClr(var S: WideString);
  738. procedure _WStrArrayClr(var StrArray; Count: Integer);
  739. procedure _WStrAsg(var Dest: WideString; const Source: WideString);
  740. procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  741. procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
  742. procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
  743. procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
  744. procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
  745. procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
  746. procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
  747. procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  748. procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
  749. procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
  750. procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
  751. function _WStrToPWChar(const S: WideString): PWideChar;
  752. function _WStrLen(const S: WideString): Integer;
  753. procedure _WStrCat(var Dest: WideString; const Source: WideString);
  754. procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
  755. procedure _WStrCatN{var dest:WideString; argCnt: Integer; ...};
  756. procedure _WStrCmp{left: WideString; right: WideString};
  757. function _NewWideString(Length: Integer): PWideChar;
  758. function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
  759. procedure _WStrDelete(var S: WideString; Index, Count: Integer);
  760. procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
  761. procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
  762. procedure _WStrSetLength(var S: WideString; NewLength: Integer);
  763. function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
  764. procedure _WStrAddRef{var str: WideString};
  765.  
  766. procedure _Initialize;
  767. procedure _InitializeArray;
  768. procedure _InitializeRecord;
  769. procedure _Finalize;
  770. procedure _FinalizeArray;
  771. procedure _FinalizeRecord;
  772. procedure _AddRef;
  773. procedure _AddRefArray;
  774. procedure _AddRefRecord;
  775. procedure _CopyArray;
  776. procedure _CopyRecord;
  777. procedure _CopyObject;
  778.  
  779. procedure _New;
  780. procedure _Dispose;
  781.  
  782. procedure _DispInvoke; cdecl;
  783. procedure _IntfDispCall; cdecl;
  784. procedure _IntfVarCall; cdecl;
  785.  
  786. procedure _VarToInt;
  787. procedure _VarToBool;
  788. procedure _VarToReal;
  789. procedure _VarToCurr;
  790. procedure _VarToPStr(var S; const V: Variant);
  791. procedure _VarToLStr(var S: string; const V: Variant);
  792. procedure _VarToWStr(var S: WideString; const V: Variant);
  793. procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
  794. procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
  795. procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
  796.  
  797. procedure _VarFromInt;
  798. procedure _VarFromBool;
  799. procedure _VarFromReal;
  800. procedure _VarFromTDateTime;
  801. procedure _VarFromCurr;
  802. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  803. procedure _VarFromLStr(var V: Variant; const Value: string);
  804. procedure _VarFromWStr(var V: Variant; const Value: WideString);
  805. procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
  806. procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
  807. procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
  808. procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
  809. procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
  810. procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
  811.  
  812. procedure _VarAdd;
  813. procedure _VarSub;
  814. procedure _VarMul;
  815. procedure _VarDiv;
  816. procedure _VarMod;
  817. procedure _VarAnd;
  818. procedure _VarOr;
  819. procedure _VarXor;
  820. procedure _VarShl;
  821. procedure _VarShr;
  822. procedure _VarRDiv;
  823. procedure _VarCmp;
  824.  
  825. procedure _VarNeg;
  826. procedure _VarNot;
  827.  
  828. procedure _VarCopyNoInd;
  829. procedure _VarClr;
  830. procedure _VarAddRef;
  831.  
  832. { 64-bit Integer helper routines }
  833.  
  834. procedure __llmul;
  835. procedure __lldiv;
  836. procedure __lludiv;
  837. procedure __llmod;
  838. procedure __llmulo;
  839. procedure __lldivo;
  840. procedure __llmodo;
  841. procedure __llumod;
  842. procedure __llshl;
  843. procedure __llushr;
  844. procedure _WriteInt64;
  845. procedure _Write0Int64;
  846. procedure _ReadInt64;
  847. function _StrInt64(val: Int64; width: Integer): ShortString;
  848. function _Str0Int64(val: Int64): ShortString;
  849. function _ValInt64(const s: AnsiString; var code: Integer): Int64;
  850.  
  851. { Dynamic array helper functions }
  852.  
  853. procedure _DynArrayHigh;
  854. procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer);
  855. procedure _DynArrayLength;
  856. procedure _DynArraySetLength;
  857. procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
  858. procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
  859. procedure _DynArrayAsg;
  860. procedure _DynArrayAddRef;
  861. procedure  DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
  862. procedure  DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
  863.  
  864. procedure _IntfClear(var Dest: IUnknown);
  865. procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
  866. procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
  867. procedure _IntfAddRef(const Dest: IUnknown);
  868.  
  869. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  870.   Indices: Integer): Variant; cdecl;
  871. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  872.   IndexCount: Integer; Indices: Integer); cdecl;
  873.  
  874. procedure _HandleAnyException;
  875. procedure _HandleOnException;
  876. procedure _HandleFinally;
  877. procedure _HandleAutoException;
  878.  
  879. procedure _FSafeDivide;
  880. procedure _FSafeDivideR;
  881.  
  882. procedure _CheckAutoResult;
  883.  
  884. procedure FPower10;
  885.  
  886. procedure TextStart;
  887.  
  888. function  CompToDouble(acomp: Comp): Double; cdecl;
  889. procedure DoubleToComp(adouble: Double; var result: Comp); cdecl;
  890. function  CompToCurrency(acomp: Comp): Currency; cdecl;
  891. procedure CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;
  892.  
  893. function GetMemory(Size: Integer): Pointer; cdecl;
  894. function FreeMemory(P: Pointer): Integer; cdecl;
  895. function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
  896.  
  897. (* =================================================================== *)
  898.  
  899. implementation
  900.  
  901. uses
  902.   SysInit;
  903.  
  904. { Internal runtime error codes }
  905.  
  906. const
  907.   reOutOfMemory       = 1;
  908.   reInvalidPtr        = 2;
  909.   reDivByZero         = 3;
  910.   reRangeError        = 4;
  911.   reIntOverflow       = 5;
  912.   reInvalidOp         = 6;
  913.   reZeroDivide        = 7;
  914.   reOverflow          = 8;
  915.   reUnderflow         = 9;
  916.   reInvalidCast       = 10;
  917.   reAccessViolation   = 11;
  918.   reStackOverflow     = 12;
  919.   reControlBreak      = 13;
  920.   rePrivInstruction   = 14;
  921.   reVarTypeCast       = 15;
  922.   reVarInvalidOp      = 16;
  923.   reVarDispatch       = 17;
  924.   reVarArrayCreate    = 18;
  925.   reVarNotArray       = 19;
  926.   reVarArrayBounds    = 20;
  927.   reAssertionFailed   = 21;
  928.   reExternalException = 22;     { not used here; in SysUtils }
  929.   reIntfCastError     = 23;
  930.   reSafeCallError     = 24;
  931.  
  932. { this procedure should be at the very beginning of the }
  933. { text segment. it is only used by _RunError to find    }
  934. { start address of the text segment so a nice error     }
  935. { location can be shown.                                                                }
  936.  
  937. procedure TextStart;
  938. begin
  939. end;
  940.  
  941. { ----------------------------------------------------- }
  942. {       NT Calls necessary for the .asm files           }
  943. { ----------------------------------------------------- }
  944.  
  945. type
  946.   PMemInfo = ^TMemInfo;
  947.   TMemInfo = packed record
  948.     BaseAddress: Pointer;
  949.     AllocationBase: Pointer;
  950.     AllocationProtect: Longint;
  951.     RegionSize: Longint;
  952.     State: Longint;
  953.     Protect: Longint;
  954.     Type_9 : Longint;
  955.   end;
  956.  
  957.   PStartupInfo = ^TStartupInfo;
  958.   TStartupInfo = record
  959.     cb: Longint;
  960.     lpReserved: Pointer;
  961.     lpDesktop: Pointer;
  962.     lpTitle: Pointer;
  963.     dwX: Longint;
  964.     dwY: Longint;
  965.     dwXSize: Longint;
  966.     dwYSize: Longint;
  967.     dwXCountChars: Longint;
  968.     dwYCountChars: Longint;
  969.     dwFillAttribute: Longint;
  970.     dwFlags: Longint;
  971.     wShowWindow: Word;
  972.     cbReserved2: Word;
  973.     lpReserved2: ^Byte;
  974.     hStdInput: Integer;
  975.     hStdOutput: Integer;
  976.     hStdError: Integer;
  977.   end;
  978.  
  979.   TWin32FindData = packed record
  980.     dwFileAttributes: Integer;
  981.     ftCreationTime: Int64;
  982.     ftLastAccessTime: Int64;
  983.     ftLastWriteTime: Int64;
  984.     nFileSizeHigh: Integer;
  985.     nFileSizeLow: Integer;
  986.     dwReserved0: Integer;
  987.     dwReserved1: Integer;
  988.     cFileName: array[0..259] of Char;
  989.     cAlternateFileName: array[0..13] of Char;
  990.   end;
  991.  
  992. const
  993.   advapi32 = 'advapi32.dll';
  994.   kernel = 'kernel32.dll';
  995.   user = 'user32.dll';
  996.   oleaut = 'oleaut32.dll';
  997.  
  998. procedure CloseHandle;                  external kernel name 'CloseHandle';
  999. procedure CreateFileA;                  external kernel name 'CreateFileA';
  1000. procedure DeleteFileA;                  external kernel name 'DeleteFileA';
  1001. procedure GetFileType;                  external kernel name 'GetFileType';
  1002. procedure GetSystemTime;                external kernel name 'GetSystemTime';
  1003. procedure GetFileSize;                  external kernel name 'GetFileSize';
  1004. procedure GetStdHandle;                 external kernel name 'GetStdHandle';
  1005. //procedure GetStartupInfo;               external kernel name 'GetStartupInfo';
  1006. procedure MoveFileA;                    external kernel name 'MoveFileA';
  1007. procedure RaiseException;               external kernel name 'RaiseException';
  1008. procedure ReadFile;                     external kernel name 'ReadFile';
  1009. procedure RtlUnwind;                    external kernel name 'RtlUnwind';
  1010. procedure SetEndOfFile;                 external kernel name 'SetEndOfFile';
  1011. procedure SetFilePointer;               external kernel name 'SetFilePointer';
  1012. procedure UnhandledExceptionFilter;     external kernel name 'UnhandledExceptionFilter';
  1013. procedure WriteFile;                    external kernel name 'WriteFile';
  1014.  
  1015. function CharNext(lpsz: PChar): PChar; stdcall;
  1016.   external user name 'CharNextA';
  1017.  
  1018. function CreateThread(SecurityAttributes: Pointer; StackSize: LongWord;
  1019.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  1020.                      CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;
  1021.   external kernel name 'CreateThread';
  1022.  
  1023. procedure ExitThread(ExitCode: Integer); stdcall;
  1024.   external kernel name 'ExitThread';
  1025.  
  1026. procedure ExitProcess(ExitCode: Integer); stdcall;
  1027.   external kernel name 'ExitProcess';
  1028.  
  1029. procedure MessageBox(Wnd: Integer; Text: PChar; Caption: PChar; Typ: Integer); stdcall;
  1030.   external user   name 'MessageBoxA';
  1031.  
  1032. function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall;
  1033.   external kernel name 'CreateDirectoryA';
  1034.  
  1035. function FindClose(FindFile: Integer): LongBool; stdcall;
  1036.   external kernel name 'FindClose';
  1037.  
  1038. function FindFirstFile(FileName: PChar; var FindFileData: TWIN32FindData): Integer; stdcall;
  1039.   external kernel name 'FindFirstFileA';
  1040.  
  1041. function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
  1042.   external kernel name 'FreeLibrary';
  1043.  
  1044. function GetCommandLine: PChar; stdcall;
  1045.   external kernel name 'GetCommandLineA';
  1046.  
  1047. function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall;
  1048.   external kernel name 'GetCurrentDirectoryA';
  1049.  
  1050. function GetLastError: Integer; stdcall;
  1051.   external kernel name 'GetLastError';
  1052.  
  1053. function GetLocaleInfo(Locale: Longint; LCType: Longint; lpLCData: PChar; cchData: Integer): Integer; stdcall;
  1054.   external kernel name 'GetLocaleInfoA';
  1055.  
  1056. function GetModuleFileName(Module: Integer; Filename: PChar;
  1057.   Size: Integer): Integer; stdcall;
  1058.   external kernel name 'GetModuleFileNameA';
  1059.  
  1060. function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
  1061.   external kernel name 'GetModuleHandleA';
  1062.  
  1063. function GetProcAddress(Module: Integer; ProcName: PChar): Pointer; stdcall;
  1064.   external kernel name 'GetProcAddress';
  1065.  
  1066. procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall;
  1067.   external kernel name 'GetStartupInfoA';
  1068.  
  1069. function GetThreadLocale: Longint; stdcall;
  1070.   external kernel name 'GetThreadLocale';
  1071.  
  1072. function LoadLibraryEx(LibName: PChar; hFile: Longint; Flags: Longint): Longint; stdcall;
  1073.   external kernel name 'LoadLibraryExA';
  1074.  
  1075. function LoadString(Instance: Longint; IDent: Integer; Buffer: PChar;
  1076.   Size: Integer): Integer; stdcall;
  1077.   external user name 'LoadStringA';
  1078.  
  1079. {function lstrcat(lpString1, lpString2: PChar): PChar; stdcall;
  1080.   external kernel name 'lstrcatA';}
  1081.  
  1082. function lstrcpy(lpString1, lpString2: PChar): PChar; stdcall;
  1083.   external kernel name 'lstrcpyA';
  1084.  
  1085. function lstrcpyn(lpString1, lpString2: PChar;
  1086.   iMaxLength: Integer): PChar; stdcall;
  1087.   external kernel name 'lstrcpynA';
  1088.  
  1089. function lstrlen(lpString: PChar): Integer; stdcall;
  1090.   external kernel name 'lstrlenA';
  1091.  
  1092. function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar;
  1093.   MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall;
  1094.   external kernel name 'MultiByteToWideChar';
  1095.  
  1096. function RegCloseKey(hKey: Integer): Longint; stdcall;
  1097.   external advapi32 name 'RegCloseKey';
  1098.  
  1099. function RegOpenKeyEx(hKey: LongWord; lpSubKey: PChar; ulOptions,
  1100.   samDesired: LongWord; var phkResult: LongWord): Longint; stdcall;
  1101.   external advapi32 name 'RegOpenKeyExA';
  1102.  
  1103. function RegQueryValueEx(hKey: LongWord; lpValueName: PChar;
  1104.   lpReserved: Pointer; lpType: Pointer; lpData: PChar; lpcbData: Pointer): Integer; stdcall;
  1105.   external advapi32 name 'RegQueryValueExA';
  1106.  
  1107. function RemoveDirectory(PathName: PChar): WordBool; stdcall;
  1108.   external kernel name 'RemoveDirectoryA';
  1109.  
  1110. function SetCurrentDirectory(PathName: PChar): WordBool; stdcall;
  1111.   external kernel name 'SetCurrentDirectoryA';
  1112.  
  1113. function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar;
  1114.   WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar;
  1115.   UsedDefaultChar: Pointer): Integer; stdcall;
  1116.   external kernel name 'WideCharToMultiByte';
  1117.  
  1118. function VirtualQuery(lpAddress: Pointer;
  1119.   var lpBuffer: TMemInfo; dwLength: Longint): Longint; stdcall;
  1120.   external kernel name 'VirtualQuery';
  1121.  
  1122. //function SysAllocString(P: PWideChar): PWideChar; stdcall;
  1123. //  external oleaut name 'SysAllocString';
  1124.  
  1125. function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall;
  1126.   external oleaut name 'SysAllocStringLen';
  1127.  
  1128. function SysReAllocStringLen(var S: WideString; P: PWideChar;
  1129.   Len: Integer): LongBool; stdcall;
  1130.   external oleaut name 'SysReAllocStringLen';
  1131.  
  1132. procedure SysFreeString(const S: WideString); stdcall;
  1133.   external oleaut name 'SysFreeString';
  1134.  
  1135. function SysStringLen(const S: WideString): Integer; stdcall;
  1136.   external oleaut name 'SysStringLen';
  1137.  
  1138. //procedure VariantInit(var V: Variant); stdcall;
  1139. //  external oleaut name 'VariantInit';
  1140.  
  1141. function VariantClear(var V: Variant): Integer; stdcall;
  1142.   external oleaut name 'VariantClear';
  1143.  
  1144. function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall;
  1145.   external oleaut name 'VariantCopy';
  1146.  
  1147. function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall;
  1148.   external oleaut name 'VariantCopyInd';
  1149.  
  1150. //function VariantChangeType(var Dest: Variant; const Source: Variant;
  1151. //  Flags: Word; VarType: Word): Integer; stdcall;
  1152. //  external oleaut name 'VariantChangeType';
  1153.  
  1154. function VariantChangeTypeEx(var Dest: Variant; const Source: Variant;
  1155.   LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall;
  1156.   external oleaut name 'VariantChangeTypeEx';
  1157.  
  1158. function SafeArrayCreate(VarType, DimCount: Integer;
  1159.   const Bounds): PVarArray; stdcall;
  1160.   external oleaut name 'SafeArrayCreate';
  1161.  
  1162. function SafeArrayRedim(VarArray: PVarArray;
  1163.   var NewBound: TVarArrayBound): Integer; stdcall;
  1164.   external oleaut name 'SafeArrayRedim';
  1165.  
  1166. function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
  1167.   var LBound: Integer): Integer; stdcall;
  1168.   external oleaut name 'SafeArrayGetLBound';
  1169.  
  1170. function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
  1171.   var UBound: Integer): Integer; stdcall;
  1172.   external oleaut name 'SafeArrayGetUBound';
  1173.  
  1174. function SafeArrayAccessData(VarArray: PVarArray;
  1175.   var Data: Pointer): Integer; stdcall;
  1176.   external oleaut name 'SafeArrayAccessData';
  1177.  
  1178. function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall;
  1179.   external oleaut name 'SafeArrayUnaccessData';
  1180.  
  1181. function SafeArrayGetElement(VarArray: PVarArray; Indices,
  1182.   Data: Pointer): Integer; stdcall;
  1183.   external oleaut name 'SafeArrayGetElement';
  1184.  
  1185. function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer;
  1186.   var pvData: Pointer): HResult; stdcall;
  1187.   external oleaut name 'SafeArrayPtrOfIndex';
  1188.  
  1189. function SafeArrayPutElement(VarArray: PVarArray; Indices,
  1190.   Data: Pointer): Integer; stdcall;
  1191.   external oleaut name 'SafeArrayPutElement';
  1192.  
  1193. function InterlockedIncrement(var Addend: Integer): Integer; stdcall;
  1194.   external kernel name 'InterlockedIncrement';
  1195.  
  1196. function InterlockedDecrement(var Addend: Integer): Integer; stdcall;
  1197.   external kernel name 'InterlockedDecrement';
  1198.  
  1199. function GetCmdShow: Integer;
  1200. var
  1201.   SI: TStartupInfo;
  1202. begin
  1203.   Result := 10;                  { SW_SHOWDEFAULT }
  1204.   GetStartupInfo(SI);
  1205.   if SI.dwFlags and 1 <> 0 then  { STARTF_USESHOWWINDOW }
  1206.     Result := SI.wShowWindow;
  1207. end;
  1208.  
  1209. { ----------------------------------------------------- }
  1210. {       Memory manager                                                                          }
  1211. { ----------------------------------------------------- }
  1212.  
  1213. procedure Error(errorCode: Byte); forward;
  1214.  
  1215. {$I GETMEM.INC }
  1216.  
  1217. var
  1218.   MemoryManager: TMemoryManager = (
  1219.     GetMem: SysGetMem;
  1220.     FreeMem: SysFreeMem;
  1221.     ReallocMem: SysReallocMem);
  1222.  
  1223. procedure _GetMem;
  1224. asm
  1225.         TEST    EAX,EAX
  1226.         JE      @@1
  1227.         CALL    MemoryManager.GetMem
  1228.         OR      EAX,EAX
  1229.         JE      @@2
  1230. @@1:    RET
  1231. @@2:    MOV     AL,reOutOfMemory
  1232.         JMP     Error
  1233. end;
  1234.  
  1235. procedure _FreeMem;
  1236. asm
  1237.         TEST    EAX,EAX
  1238.         JE      @@1
  1239.         CALL    MemoryManager.FreeMem
  1240.         OR      EAX,EAX
  1241.         JNE     @@2
  1242. @@1:    RET
  1243. @@2:    MOV     AL,reInvalidPtr
  1244.         JMP     Error
  1245. end;
  1246.  
  1247. procedure _ReallocMem;
  1248. asm
  1249.         MOV     ECX,[EAX]
  1250.         TEST    ECX,ECX
  1251.         JE      @@alloc
  1252.         TEST    EDX,EDX
  1253.         JE      @@free
  1254. @@resize:
  1255.         PUSH    EAX
  1256.         MOV     EAX,ECX
  1257.         CALL    MemoryManager.ReallocMem
  1258.         POP     ECX
  1259.         OR      EAX,EAX
  1260.         JE      @@allocError
  1261.         MOV     [ECX],EAX
  1262.         RET
  1263. @@freeError:
  1264.         MOV     AL,reInvalidPtr
  1265.         JMP     Error
  1266. @@free:
  1267.         MOV     [EAX],EDX
  1268.         MOV     EAX,ECX
  1269.         CALL    MemoryManager.FreeMem
  1270.         OR      EAX,EAX
  1271.         JNE     @@freeError
  1272.         RET
  1273. @@allocError:
  1274.         MOV     AL,reOutOfMemory
  1275.         JMP     Error
  1276. @@alloc:
  1277.         TEST    EDX,EDX
  1278.         JE      @@exit
  1279.         PUSH    EAX
  1280.         MOV     EAX,EDX
  1281.         CALL    MemoryManager.GetMem
  1282.         POP     ECX
  1283.         OR      EAX,EAX
  1284.         JE      @@allocError
  1285.         MOV     [ECX],EAX
  1286. @@exit:
  1287. end;
  1288.  
  1289. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  1290. begin
  1291.   MemMgr := MemoryManager;
  1292. end;
  1293.  
  1294. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  1295. begin
  1296.   MemoryManager := MemMgr;
  1297. end;
  1298.  
  1299. function IsMemoryManagerSet: Boolean;
  1300. begin
  1301.   with MemoryManager do
  1302.     Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
  1303.       (@ReallocMem <> @SysReallocMem);
  1304. end;
  1305.  
  1306. threadvar
  1307.   RaiseListPtr: pointer;
  1308.   InOutRes: Integer;
  1309.  
  1310. function RaiseList: Pointer;
  1311. asm
  1312.         CALL    SysInit.@GetTLS
  1313.         MOV     EAX, [EAX].RaiseListPtr
  1314. end;
  1315.  
  1316. function SetRaiseList(NewPtr: Pointer): Pointer;
  1317. asm
  1318.         MOV     ECX, EAX
  1319.         CALL    SysInit.@GetTLS
  1320.         MOV     EDX, [EAX].RaiseListPtr
  1321.         MOV     [EAX].RaiseListPtr, ECX
  1322.         MOV     EAX, EDX
  1323. end;
  1324.  
  1325. { ----------------------------------------------------- }
  1326. {    local functions & procedures of the system unit    }
  1327. { ----------------------------------------------------- }
  1328.  
  1329. procedure Error(errorCode: Byte);
  1330. asm
  1331.         AND     EAX,127
  1332.         MOV     ECX,ErrorProc
  1333.         TEST    ECX,ECX
  1334.         JE      @@term
  1335.         POP     EDX
  1336.         CALL    ECX
  1337. @@term:
  1338.         DEC     EAX
  1339.         MOV     AL,byte ptr @@errorTable[EAX]
  1340.         JNS     @@skip
  1341.         CALL    SysInit.@GetTLS
  1342.         MOV     EAX,[EAX].InOutRes
  1343. @@skip:
  1344.         JMP     _RunError
  1345.  
  1346. @@errorTable:
  1347.         DB      203     { reOutOfMemory }
  1348.         DB      204     { reInvalidPtr }
  1349.         DB      200     { reDivByZero }
  1350.         DB      201     { reRangeError }
  1351. {               210       abstract error }
  1352.         DB      215     { reIntOverflow }
  1353.         DB      207     { reInvalidOp }
  1354.         DB      200     { reZeroDivide }
  1355.         DB      205     { reOverflow }
  1356.         DB      206     { reUnderflow }
  1357.         DB      219     { reInvalidCast }
  1358.         DB      216     { Access violation }
  1359.         DB      202     { Stack overflow }
  1360.         DB      217     { Control-C }
  1361.         DB      218     { Privileged instruction }
  1362.         DB      220     { Invalid variant type cast }
  1363.         DB      221     { Invalid variant operation }
  1364.         DB      222     { No variant method call dispatcher }
  1365.         DB      223     { Cannot create variant array }
  1366.         DB      224     { Variant does not contain an array }
  1367.         DB      225     { Variant array bounds error }
  1368. {               226       thread init failure }
  1369.         DB      227     { reAssertionFailed }
  1370.         DB      0       { reExternalException not used here; in SysUtils }
  1371.         DB      228     { reIntfCastError }
  1372.         DB      229     { reSafeCallError }
  1373. end;
  1374.  
  1375. procedure       __IOTest;
  1376. asm
  1377.         PUSH    EAX
  1378.         PUSH    EDX
  1379.         PUSH    ECX
  1380.         CALL    SysInit.@GetTLS
  1381.         CMP     [EAX].InOutRes,0
  1382.         POP     ECX
  1383.         POP     EDX
  1384.         POP     EAX
  1385.         JNE     @error
  1386.         RET
  1387. @error:
  1388.         XOR     EAX,EAX
  1389.         JMP     Error
  1390. end;
  1391.  
  1392. procedure SetInOutRes;
  1393. asm
  1394.         PUSH    EAX
  1395.         CALL    SysInit.@GetTLS
  1396.         POP     [EAX].InOutRes
  1397. end;
  1398.  
  1399.  
  1400. procedure InOutError;
  1401. asm
  1402.         CALL    GetLastError
  1403.         JMP     SetInOutRes
  1404. end;
  1405.  
  1406. procedure _ChDir(const S: string);
  1407. begin
  1408.   if not SetCurrentDirectory(PChar(S)) then InOutError;
  1409. end;
  1410.  
  1411. procedure       _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  1412. asm
  1413. {     ->EAX     Source string                   }
  1414. {       EDX     index                           }
  1415. {       ECX     count                           }
  1416. {       [ESP+4] Pointer to result string        }
  1417.  
  1418.         PUSH    ESI
  1419.         PUSH    EDI
  1420.  
  1421.         MOV     ESI,EAX
  1422.         MOV     EDI,[ESP+8+4]
  1423.  
  1424.         XOR     EAX,EAX
  1425.         OR      AL,[ESI]
  1426.         JZ      @@srcEmpty
  1427.  
  1428. {       limit index to satisfy 1 <= index <= Length(src) }
  1429.  
  1430.         TEST    EDX,EDX
  1431.         JLE     @@smallInx
  1432.         CMP     EDX,EAX
  1433.         JG      @@bigInx
  1434. @@cont1:
  1435.  
  1436. {       limit count to satisfy 0 <= count <= Length(src) - index + 1    }
  1437.  
  1438.         SUB     EAX,EDX { calculate Length(src) - index + 1     }
  1439.         INC     EAX
  1440.         TEST    ECX,ECX
  1441.         JL      @@smallCount
  1442.         CMP     ECX,EAX
  1443.         JG      @@bigCount
  1444. @@cont2:
  1445.  
  1446.         ADD     ESI,EDX
  1447.  
  1448.         MOV     [EDI],CL
  1449.         INC     EDI
  1450.         REP     MOVSB
  1451.         JMP     @@exit
  1452.  
  1453. @@smallInx:
  1454.         MOV     EDX,1
  1455.         JMP     @@cont1
  1456. @@bigInx:
  1457. {       MOV     EDX,EAX
  1458.         JMP     @@cont1 }
  1459. @@smallCount:
  1460.         XOR     ECX,ECX
  1461.         JMP     @@cont2
  1462. @@bigCount:
  1463.         MOV     ECX,EAX
  1464.         JMP     @@cont2
  1465. @@srcEmpty:
  1466.         MOV     [EDI],AL
  1467. @@exit:
  1468.         POP     EDI
  1469.         POP     ESI
  1470.     RET 4
  1471. end;
  1472.  
  1473. procedure       _Delete{ var s : openstring; index, count : Integer };
  1474. asm
  1475. {     ->EAX     Pointer to s    }
  1476. {       EDX     index           }
  1477. {       ECX     count           }
  1478.  
  1479.         PUSH    ESI
  1480.         PUSH    EDI
  1481.  
  1482.         MOV     EDI,EAX
  1483.  
  1484.         XOR     EAX,EAX
  1485.         MOV     AL,[EDI]
  1486.  
  1487. {       if index not in [1 .. Length(s)] do nothing     }
  1488.  
  1489.         TEST    EDX,EDX
  1490.         JLE     @@exit
  1491.         CMP     EDX,EAX
  1492.         JG      @@exit
  1493.  
  1494. {       limit count to [0 .. Length(s) - index + 1]     }
  1495.  
  1496.         TEST    ECX,ECX
  1497.         JLE     @@exit
  1498.         SUB     EAX,EDX         { calculate Length(s) - index + 1       }
  1499.         INC     EAX
  1500.         CMP     ECX,EAX
  1501.         JLE     @@1
  1502.         MOV     ECX,EAX
  1503. @@1:
  1504.         SUB     [EDI],CL        { reduce Length(s) by count                     }
  1505.         ADD     EDI,EDX         { point EDI to first char to be deleted }
  1506.         LEA     ESI,[EDI+ECX]   { point ESI to first char to be preserved       }
  1507.         SUB     EAX,ECX         { #chars = Length(s) - index + 1 - count        }
  1508.         MOV     ECX,EAX
  1509.  
  1510.         REP     MOVSB
  1511.  
  1512. @@exit:
  1513.         POP     EDI
  1514.         POP     ESI
  1515. end;
  1516.  
  1517. procedure       __Flush( var f : Text );
  1518. external;       {   Assign  }
  1519.  
  1520. procedure       _Flush( var f : Text );
  1521. external;       {   Assign  }
  1522.  
  1523. procedure _LGetDir(D: Byte; var S: string);
  1524. var
  1525.   Drive: array[0..3] of Char;
  1526.   DirBuf, SaveBuf: array[0..259] of Char;
  1527. begin
  1528.   if D <> 0 then
  1529.   begin
  1530.         Drive[0] := Chr(D + Ord('A') - 1);
  1531.         Drive[1] := ':';
  1532.         Drive[2] := #0;
  1533.         GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf);
  1534.         SetCurrentDirectory(Drive);
  1535.   end;
  1536.   GetCurrentDirectory(SizeOf(DirBuf), DirBuf);
  1537.   if D <> 0 then SetCurrentDirectory(SaveBuf);
  1538.   S := DirBuf;
  1539. end;
  1540.  
  1541. procedure _SGetDir(D: Byte; var S: ShortString);
  1542. var
  1543.   L: string;
  1544. begin
  1545.   GetDir(D, L);
  1546.   S := L;
  1547. end;
  1548.  
  1549. procedure       _Insert{ source : ShortString; var s : openstring; index : Integer };
  1550. asm
  1551. {     ->EAX     Pointer to source string        }
  1552. {       EDX     Pointer to destination string   }
  1553. {       ECX     Length of destination string    }
  1554. {       [ESP+4] Index                   }
  1555.  
  1556.         PUSH    EBX
  1557.         PUSH    ESI
  1558.         PUSH    EDI
  1559.         PUSH    ECX
  1560.         MOV     ECX,[ESP+16+4]
  1561.         SUB     ESP,512         { VAR buf: ARRAY [0..511] of Char       }
  1562.  
  1563.         MOV     EBX,EDX         { save pointer to s for later   }
  1564.         MOV     ESI,EDX
  1565.  
  1566.         XOR     EDX,EDX
  1567.         MOV     DL,[ESI]
  1568.         INC     ESI
  1569.  
  1570. {       limit index to [1 .. Length(s)+1]       }
  1571.  
  1572.         INC     EDX
  1573.         TEST    ECX,ECX
  1574.         JLE     @@smallInx
  1575.         CMP     ECX,EDX
  1576.         JG      @@bigInx
  1577. @@cont1:
  1578.         DEC     EDX     { EDX = Length(s)               }
  1579.                         { EAX = Pointer to src  }
  1580.                         { ESI = EBX = Pointer to s      }
  1581.                         { ECX = Index           }
  1582.  
  1583. {       copy index-1 chars from s to buf        }
  1584.  
  1585.         MOV     EDI,ESP
  1586.         DEC     ECX
  1587.         SUB     EDX,ECX { EDX = remaining length of s   }
  1588.         REP     MOVSB
  1589.  
  1590. {       copy Length(src) chars from src to buf  }
  1591.  
  1592.         XCHG    EAX,ESI { save pointer into s, point ESI to src         }
  1593.         MOV     CL,[ESI]        { ECX = Length(src) (ECX was zero after rep)    }
  1594.         INC     ESI
  1595.         REP     MOVSB
  1596.  
  1597. {       copy remaining chars of s to buf        }
  1598.  
  1599.         MOV     ESI,EAX { restore pointer into s                }
  1600.         MOV     ECX,EDX { copy remaining bytes of s             }
  1601.         REP     MOVSB
  1602.  
  1603. {       calculate total chars in buf    }
  1604.  
  1605.         SUB     EDI,ESP         { length = bufPtr - buf         }
  1606.         MOV     ECX,[ESP+512]   { ECX = Min(length, destLength) }
  1607. {       MOV     ECX,[EBP-16]   }{ ECX = Min(length, destLength) }
  1608.         CMP     ECX,EDI
  1609.         JB      @@1
  1610.         MOV     ECX,EDI
  1611. @@1:
  1612.         MOV     EDI,EBX         { Point EDI to s                }
  1613.         MOV     ESI,ESP         { Point ESI to buf              }
  1614.         MOV     [EDI],CL        { Store length in s             }
  1615.         INC     EDI
  1616.         REP     MOVSB           { Copy length chars to s        }
  1617.         JMP     @@exit
  1618.  
  1619. @@smallInx:
  1620.         MOV     ECX,1
  1621.         JMP     @@cont1
  1622. @@bigInx:
  1623.         MOV     ECX,EDX
  1624.         JMP     @@cont1
  1625.  
  1626. @@exit:
  1627.         ADD     ESP,512+4
  1628.         POP     EDI
  1629.         POP     ESI
  1630.         POP     EBX
  1631.     RET 4
  1632. end;
  1633.  
  1634. function IOResult: Integer;
  1635. asm
  1636.         CALL    SysInit.@GetTLS
  1637.         XOR     EDX,EDX
  1638.         MOV     ECX,[EAX].InOutRes
  1639.         MOV     [EAX].InOutRes,EDX
  1640.         MOV     EAX,ECX
  1641. end;
  1642.  
  1643. procedure _MkDir(const S: string);
  1644. begin
  1645.   if not CreateDirectory(PChar(S), 0) then InOutError;
  1646. end;
  1647.  
  1648. procedure       Move( const Source; var Dest; count : Integer );
  1649. asm
  1650. {     ->EAX     Pointer to source       }
  1651. {       EDX     Pointer to destination  }
  1652. {       ECX     Count                   }
  1653.  
  1654.         PUSH    ESI
  1655.         PUSH    EDI
  1656.  
  1657.         MOV     ESI,EAX
  1658.         MOV     EDI,EDX
  1659.  
  1660.         MOV     EAX,ECX
  1661.  
  1662.         CMP     EDI,ESI
  1663.         JA      @@down
  1664.         JE      @@exit
  1665.  
  1666.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1667.         JS      @@exit
  1668.  
  1669.         REP     MOVSD
  1670.  
  1671.         MOV     ECX,EAX
  1672.         AND     ECX,03H
  1673.         REP     MOVSB           { copy count MOD 4 bytes        }
  1674.         JMP     @@exit
  1675.  
  1676. @@down:
  1677.         LEA     ESI,[ESI+ECX-4] { point ESI to last dword of source     }
  1678.         LEA     EDI,[EDI+ECX-4] { point EDI to last dword of dest       }
  1679.  
  1680.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1681.         JS      @@exit
  1682.         STD
  1683.         REP     MOVSD
  1684.  
  1685.         MOV     ECX,EAX
  1686.         AND     ECX,03H         { copy count MOD 4 bytes        }
  1687.         ADD     ESI,4-1         { point to last byte of rest    }
  1688.         ADD     EDI,4-1
  1689.         REP     MOVSB
  1690.         CLD
  1691. @@exit:
  1692.         POP     EDI
  1693.         POP     ESI
  1694. end;
  1695.  
  1696. function GetParamStr(P: PChar; var Param: string): PChar;
  1697. var
  1698.   Len: Integer;
  1699.   Buffer: array[0..4095] of Char;
  1700. begin
  1701.   while True do
  1702.   begin
  1703.     while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
  1704.     if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  1705.   end;
  1706.   Len := 0;
  1707.   while (P[0] > ' ') and (Len < SizeOf(Buffer)) do
  1708.     if P[0] = '"' then
  1709.     begin
  1710.       Inc(P);
  1711.       while (P[0] <> #0) and (P[0] <> '"') do
  1712.       begin
  1713.         Buffer[Len] := P[0];
  1714.         Inc(Len);
  1715.         Inc(P);
  1716.       end;
  1717.       if P[0] <> #0 then Inc(P);
  1718.     end else
  1719.     begin
  1720.       Buffer[Len] := P[0];
  1721.       Inc(Len);
  1722.       Inc(P);
  1723.     end;
  1724.   SetString(Param, Buffer, Len);
  1725.   Result := P;
  1726. end;
  1727.  
  1728. function ParamCount: Integer;
  1729. var
  1730.   P: PChar;
  1731.   S: string;
  1732. begin
  1733.   P := GetParamStr(GetCommandLine, S);
  1734.   Result := 0;
  1735.   while True do
  1736.   begin
  1737.     P := GetParamStr(P, S);
  1738.     if S = '' then Break;
  1739.     Inc(Result);
  1740.   end;
  1741. end;
  1742.  
  1743. function ParamStr(Index: Integer): string;
  1744. var
  1745.   P: PChar;
  1746.   Buffer: array[0..260] of Char;
  1747. begin
  1748.   if Index = 0 then
  1749.     SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer)))
  1750.   else
  1751.   begin
  1752.     P := GetCommandLine;
  1753.     while True do
  1754.     begin
  1755.       P := GetParamStr(P, Result);
  1756.       if (Index = 0) or (Result = '') then Break;
  1757.       Dec(Index);
  1758.     end;
  1759.   end;
  1760. end;
  1761.  
  1762. procedure       _Pos{ substr : ShortString; s : ShortString ) : Integer};
  1763. asm
  1764. {     ->EAX     Pointer to substr               }
  1765. {       EDX     Pointer to string               }
  1766. {     <-EAX     Position of substr in s or 0    }
  1767.  
  1768.         PUSH    EBX
  1769.         PUSH    ESI
  1770.         PUSH    EDI
  1771.  
  1772.         MOV     ESI,EAX { Point ESI to substr           }
  1773.         MOV     EDI,EDX { Point EDI to s                }
  1774.  
  1775.         XOR     ECX,ECX { ECX = Length(s)               }
  1776.         MOV     CL,[EDI]
  1777.         INC     EDI             { Point EDI to first char of s  }
  1778.  
  1779.         PUSH    EDI             { remember s position to calculate index        }
  1780.  
  1781.         XOR     EDX,EDX { EDX = Length(substr)          }
  1782.         MOV     DL,[ESI]
  1783.         INC     ESI             { Point ESI to first char of substr     }
  1784.  
  1785.         DEC     EDX             { EDX = Length(substr) - 1              }
  1786.         JS      @@fail  { < 0 ? return 0                        }
  1787.         MOV     AL,[ESI]        { AL = first char of substr             }
  1788.         INC     ESI             { Point ESI to 2'nd char of substr      }
  1789.  
  1790.         SUB     ECX,EDX { #positions in s to look at    }
  1791.                         { = Length(s) - Length(substr) + 1      }
  1792.         JLE     @@fail
  1793. @@loop:
  1794.         REPNE   SCASB
  1795.         JNE     @@fail
  1796.         MOV     EBX,ECX { save outer loop counter               }
  1797.         PUSH    ESI             { save outer loop substr pointer        }
  1798.         PUSH    EDI             { save outer loop s pointer             }
  1799.  
  1800.         MOV     ECX,EDX
  1801.         REPE    CMPSB
  1802.         POP     EDI             { restore outer loop s pointer  }
  1803.         POP     ESI             { restore outer loop substr pointer     }
  1804.         JE      @@found
  1805.         MOV     ECX,EBX { restore outer loop counter    }
  1806.         JMP     @@loop
  1807.  
  1808. @@fail:
  1809.         POP     EDX             { get rid of saved s pointer    }
  1810.         XOR     EAX,EAX
  1811.         JMP     @@exit
  1812.  
  1813. @@found:
  1814.         POP     EDX             { restore pointer to first char of s    }
  1815.         MOV     EAX,EDI { EDI points of char after match        }
  1816.         SUB     EAX,EDX { the difference is the correct index   }
  1817. @@exit:
  1818.         POP     EDI
  1819.         POP     ESI
  1820.         POP     EBX
  1821. end;
  1822.  
  1823. procedure       _SetLength{var s: ShortString; newLength: Integer};
  1824. asm
  1825.         { ->    EAX pointer to string   }
  1826.         {       EDX new length          }
  1827.  
  1828.         MOV     [EAX],DL        { should also fill new space, parameter should be openstring }
  1829.  
  1830. end;
  1831.  
  1832. procedure       _SetString{var s: ShortString: buffer: PChar; len: Integer};
  1833. asm
  1834.         { ->    EAX pointer to string           }
  1835.         {       EDX pointer to buffer   }
  1836.         {       ECX len                         }
  1837.  
  1838.         MOV     [EAX],CL
  1839.         TEST    EDX,EDX
  1840.         JE      @@noMove
  1841.         XCHG    EAX,EDX
  1842.         INC     EDX
  1843.         CALL    Move
  1844. @@noMove:
  1845. end;
  1846.  
  1847. procedure       Randomize;
  1848. var
  1849.         systemTime :
  1850.         record
  1851.                 wYear   : Word;
  1852.                 wMonth  : Word;
  1853.                 wDayOfWeek      : Word;
  1854.                 wDay    : Word;
  1855.                 wHour   : Word;
  1856.                 wMinute : Word;
  1857.                 wSecond : Word;
  1858.                 wMilliSeconds: Word;
  1859.                 reserved        : array [0..7] of char;
  1860.         end;
  1861. asm
  1862.         LEA     EAX,systemTime
  1863.         PUSH    EAX
  1864.         CALL    GetSystemTime
  1865.         MOVZX   EAX,systemTime.wHour
  1866.         IMUL    EAX,60
  1867.         ADD     AX,systemTime.wMinute   { sum = hours * 60 + minutes    }
  1868.         IMUL    EAX,60
  1869.         XOR     EDX,EDX
  1870.         MOV     DX,systemTime.wSecond
  1871.         ADD     EAX,EDX                 { sum = sum * 60 + seconds              }
  1872.         IMUL    EAX,1000
  1873.         MOV     DX,systemTime.wMilliSeconds
  1874.         ADD     EAX,EDX                 { sum = sum * 1000 + milliseconds       }
  1875.         MOV     RandSeed,EAX
  1876. end;
  1877.  
  1878. procedure _RmDir(const S: string);
  1879. begin
  1880.   if not RemoveDirectory(PChar(S)) then InOutError;
  1881. end;
  1882.  
  1883. function        UpCase( ch : Char ) : Char;
  1884. asm
  1885. { ->    AL      Character       }
  1886. { <-    AL      Result          }
  1887.  
  1888.         CMP     AL,'a'
  1889.         JB      @@exit
  1890.         CMP     AL,'z'
  1891.         JA      @@exit
  1892.         SUB     AL,'a' - 'A'
  1893. @@exit:
  1894. end;
  1895.  
  1896.  
  1897. procedure Set8087CW(NewCW: Word);
  1898. asm
  1899.         MOV     Default8087CW,AX
  1900.         FNCLEX  // don't raise pending exceptions enabled by the new flags
  1901.         FLDCW   Default8087CW
  1902. end;
  1903.  
  1904. { ----------------------------------------------------- }
  1905. {       functions & procedures that need compiler magic }
  1906. { ----------------------------------------------------- }
  1907.  
  1908. const cwChop : Word = $1F32;
  1909.  
  1910. procedure       _COS;
  1911. asm
  1912.         FCOS
  1913.         FNSTSW  AX
  1914.         SAHF
  1915.         JP      @@outOfRange
  1916.         RET
  1917. @@outOfRange:
  1918.         FSTP    st(0)   { for now, return 0. result would }
  1919.         FLDZ            { have little significance anyway }
  1920. end;
  1921.  
  1922. procedure       _EXP;
  1923. asm
  1924.         {       e**x = 2**(x*log2(e))   }
  1925.  
  1926.         FLDL2E              { y := x*log2e;      }
  1927.         FMUL
  1928.         FLD     ST(0)       { i := round(y);     }
  1929.         FRNDINT
  1930.         FSUB    ST(1), ST   { f := y - i;        }
  1931.         FXCH    ST(1)       { z := 2**f          }
  1932.         F2XM1
  1933.         FLD1
  1934.         FADD
  1935.         FSCALE              { result := z * 2**i }
  1936.         FSTP    ST(1)
  1937. end;
  1938.  
  1939. procedure       _INT;
  1940. asm
  1941.         SUB     ESP,4
  1942.         FSTCW   [ESP]
  1943.         FWAIT
  1944.         FLDCW   cwChop
  1945.         FRNDINT
  1946.         FWAIT
  1947.         FLDCW   [ESP]
  1948.         ADD     ESP,4
  1949. end;
  1950.  
  1951. procedure       _SIN;
  1952. asm
  1953.         FSIN
  1954.         FNSTSW  AX
  1955.         SAHF
  1956.         JP      @@outOfRange
  1957.         RET
  1958. @@outOfRange:
  1959.         FSTP    st(0)   { for now, return 0. result would       }
  1960.         FLDZ            { have little significance anyway       }
  1961. end;
  1962.  
  1963. procedure       _FRAC;
  1964. asm
  1965.         FLD     ST(0)
  1966.         SUB     ESP,4
  1967.         FSTCW   [ESP]
  1968.         FWAIT
  1969.         FLDCW   cwChop
  1970.         FRNDINT
  1971.         FWAIT
  1972.         FLDCW   [ESP]
  1973.         ADD     ESP,4
  1974.         FSUB
  1975. end;
  1976.  
  1977. procedure       _ROUND;
  1978. asm
  1979.         { ->    FST(0)  Extended argument       }
  1980.         { <-    EDX:EAX Result                  }
  1981.  
  1982.         SUB     ESP,8
  1983.         FISTP   qword ptr [ESP]
  1984.         FWAIT
  1985.         POP     EAX
  1986.         POP     EDX
  1987. end;
  1988.  
  1989. procedure       _TRUNC;
  1990. asm
  1991.         { ->    FST(0)   Extended argument       }
  1992.         { <-    EDX:EAX  Result                  }
  1993.  
  1994.         SUB     ESP,12
  1995.         FSTCW   [ESP]
  1996.         FWAIT
  1997.         FLDCW   cwChop
  1998.         FISTP   qword ptr [ESP+4]
  1999.         FWAIT
  2000.         FLDCW   [ESP]
  2001.         POP     ECX
  2002.         POP     EAX
  2003.         POP     EDX
  2004. end;
  2005.  
  2006. procedure       _AbstractError;
  2007. asm
  2008.         CMP     AbstractErrorProc, 0
  2009.         JE      @@NoAbstErrProc
  2010.         CALL    AbstractErrorProc
  2011.  
  2012. @@NoAbstErrProc:
  2013.         MOV     EAX,210
  2014.         JMP     _RunError
  2015. end;
  2016.  
  2017. procedure       _Append;                                external;       {   OpenText}
  2018. procedure       _Assign(var t: text; s: ShortString);   external;       {$L Assign  }
  2019. procedure       _BlockRead;                             external;       {$L BlockRea}
  2020. procedure       _BlockWrite;                            external;       {$L BlockWri}
  2021. procedure       _Close;                                 external;       {$L Close   }
  2022.  
  2023. procedure       _PStrCat;
  2024. asm
  2025. {     ->EAX = Pointer to destination string     }
  2026. {       EDX = Pointer to source string  }
  2027.  
  2028.         PUSH    ESI
  2029.         PUSH    EDI
  2030.  
  2031. {       load dest len into EAX  }
  2032.  
  2033.         MOV     EDI,EAX
  2034.         XOR     EAX,EAX
  2035.         MOV     AL,[EDI]
  2036.  
  2037. {       load source address in ESI, source len in ECX   }
  2038.  
  2039.         MOV     ESI,EDX
  2040.         XOR     ECX,ECX
  2041.         MOV     CL,[ESI]
  2042.         INC     ESI
  2043.  
  2044. {       calculate final length in DL and store it in the destination    }
  2045.  
  2046.         MOV     DL,AL
  2047.         ADD     DL,CL
  2048.         JC      @@trunc
  2049.  
  2050. @@cont:
  2051.         MOV     [EDI],DL
  2052.  
  2053. {       calculate final dest address    }
  2054.  
  2055.         INC     EDI
  2056.         ADD     EDI,EAX
  2057.  
  2058. {       do the copy     }
  2059.  
  2060.         REP     MOVSB
  2061.  
  2062. {       done    }
  2063.  
  2064.         POP     EDI
  2065.         POP     ESI
  2066.         RET
  2067.  
  2068. @@trunc:
  2069.         INC     DL      {       DL = #chars to truncate                 }
  2070.         SUB     CL,DL   {       CL = source len - #chars to truncate    }
  2071.         MOV     DL,255  {       DL = maximum length                     }
  2072.         JMP     @@cont
  2073. end;
  2074.  
  2075. procedure       _PStrNCat;
  2076. asm
  2077. {     ->EAX = Pointer to destination string                     }
  2078. {       EDX = Pointer to source string                          }
  2079. {       CL  = max length of result (allocated size of dest - 1) }
  2080.  
  2081.         PUSH    ESI
  2082.         PUSH    EDI
  2083.  
  2084. {       load dest len into EAX  }
  2085.  
  2086.         MOV     EDI,EAX
  2087.         XOR     EAX,EAX
  2088.         MOV     AL,[EDI]
  2089.  
  2090. {       load source address in ESI, source len in EDX   }
  2091.  
  2092.         MOV     ESI,EDX
  2093.         XOR     EDX,EDX
  2094.         MOV     DL,[ESI]
  2095.         INC     ESI
  2096.  
  2097. {       calculate final length in AL and store it in the destination    }
  2098.  
  2099.         ADD     AL,DL
  2100.         JC      @@trunc
  2101.         CMP     AL,CL
  2102.         JA      @@trunc
  2103.  
  2104. @@cont:
  2105.         MOV     ECX,EDX
  2106.         MOV     DL,[EDI]
  2107.         MOV     [EDI],AL
  2108.  
  2109. {       calculate final dest address    }
  2110.  
  2111.         INC     EDI
  2112.         ADD     EDI,EDX
  2113.  
  2114. {       do the copy     }
  2115.  
  2116.         REP     MOVSB
  2117.  
  2118. @@done:
  2119.         POP     EDI
  2120.         POP     ESI
  2121.         RET
  2122.  
  2123. @@trunc:
  2124. {       CL = maxlen     }
  2125.  
  2126.         MOV     AL,CL   { AL = final length = maxlen            }
  2127.         SUB     CL,[EDI]        { CL = length to copy = maxlen - destlen        }
  2128.         JBE     @@done
  2129.         MOV     DL,CL
  2130.         JMP     @@cont
  2131. end;
  2132.  
  2133. procedure       _PStrCpy;
  2134. asm
  2135. {     ->EAX = Pointer to dest string    }
  2136. {       EDX = Pointer to source string  }
  2137.  
  2138.         XOR     ECX,ECX
  2139.  
  2140.         PUSH    ESI
  2141.         PUSH    EDI
  2142.  
  2143.         MOV     CL,[EDX]
  2144.  
  2145.         MOV     EDI,EAX
  2146.  
  2147.         INC     ECX             { we must copy len+1 bytes      }
  2148.  
  2149.         MOV     ESI,EDX
  2150.  
  2151.         MOV     EAX,ECX
  2152.         SHR     ECX,2
  2153.         AND     EAX,3
  2154.         REP     MOVSD
  2155.  
  2156.         MOV     ECX,EAX
  2157.         REP     MOVSB
  2158.  
  2159.         POP     EDI
  2160.         POP     ESI
  2161. end;
  2162.  
  2163. procedure       _PStrNCpy;
  2164. asm
  2165. {     ->EAX = Pointer to dest string                            }
  2166. {       EDX = Pointer to source string                          }
  2167. {       CL  = Maximum length to copy (allocated size of dest - 1)       }
  2168.  
  2169.         PUSH    ESI
  2170.         PUSH    EDI
  2171.  
  2172.         MOV     EDI,EAX
  2173.         XOR     EAX,EAX
  2174.         MOV     ESI,EDX
  2175.  
  2176.         MOV     AL,[EDX]
  2177.         CMP     AL,CL
  2178.         JA      @@trunc
  2179.  
  2180.         INC     EAX
  2181.  
  2182.         MOV     ECX,EAX
  2183.         AND     EAX,3
  2184.         SHR     ECX,2
  2185.         REP     MOVSD
  2186.  
  2187.         MOV     ECX,EAX
  2188.         REP     MOVSB
  2189.  
  2190.         POP     EDI
  2191.         POP     ESI
  2192.         RET
  2193.  
  2194. @@trunc:
  2195.         MOV     [EDI],CL        { result length is maxLen       }
  2196.         INC     ESI             { advance pointers              }
  2197.         INC     EDI
  2198.         AND     ECX,0FFH        { should be cheaper than MOVZX  }
  2199.         REP     MOVSB   { copy maxLen bytes             }
  2200.  
  2201.         POP     EDI
  2202.         POP     ESI
  2203. end;
  2204.  
  2205. procedure       _PStrCmp;
  2206. asm
  2207. {     ->EAX = Pointer to left string    }
  2208. {       EDX = Pointer to right string   }
  2209.  
  2210.         PUSH    EBX
  2211.         PUSH    ESI
  2212.         PUSH    EDI
  2213.  
  2214.         MOV     ESI,EAX
  2215.         MOV     EDI,EDX
  2216.  
  2217.         XOR     EAX,EAX
  2218.         XOR     EDX,EDX
  2219.         MOV     AL,[ESI]
  2220.         MOV     DL,[EDI]
  2221.         INC     ESI
  2222.         INC     EDI
  2223.  
  2224.         SUB     EAX,EDX { eax = len1 - len2 }
  2225.         JA      @@skip1
  2226.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  2227.  
  2228. @@skip1:
  2229.         PUSH    EDX
  2230.         SHR     EDX,2
  2231.         JE      @@cmpRest
  2232. @@longLoop:
  2233.         MOV     ECX,[ESI]
  2234.         MOV     EBX,[EDI]
  2235.         CMP     ECX,EBX
  2236.         JNE     @@misMatch
  2237.         DEC     EDX
  2238.         JE      @@cmpRestP4
  2239.         MOV     ECX,[ESI+4]
  2240.         MOV     EBX,[EDI+4]
  2241.         CMP     ECX,EBX
  2242.         JNE     @@misMatch
  2243.         ADD     ESI,8
  2244.         ADD     EDI,8
  2245.         DEC     EDX
  2246.         JNE     @@longLoop
  2247.         JMP     @@cmpRest
  2248. @@cmpRestP4:
  2249.         ADD     ESI,4
  2250.         ADD     EDI,4
  2251. @@cmpRest:
  2252.         POP     EDX
  2253.         AND     EDX,3
  2254.         JE      @@equal
  2255.  
  2256.         MOV     CL,[ESI]
  2257.         CMP     CL,[EDI]
  2258.         JNE     @@exit
  2259.         DEC     EDX
  2260.         JE      @@equal
  2261.         MOV     CL,[ESI+1]
  2262.         CMP     CL,[EDI+1]
  2263.         JNE     @@exit
  2264.         DEC     EDX
  2265.         JE      @@equal
  2266.         MOV     CL,[ESI+2]
  2267.         CMP     CL,[EDI+2]
  2268.         JNE     @@exit
  2269.  
  2270. @@equal:
  2271.         ADD     EAX,EAX
  2272.         JMP     @@exit
  2273.  
  2274. @@misMatch:
  2275.         POP     EDX
  2276.         CMP     CL,BL
  2277.         JNE     @@exit
  2278.         CMP     CH,BH
  2279.         JNE     @@exit
  2280.         SHR     ECX,16
  2281.         SHR     EBX,16
  2282.         CMP     CL,BL
  2283.         JNE     @@exit
  2284.         CMP     CH,BH
  2285.  
  2286. @@exit:
  2287.         POP     EDI
  2288.         POP     ESI
  2289.         POP     EBX
  2290. end;
  2291.  
  2292. procedure       _AStrCmp;
  2293. asm
  2294. {     ->EAX = Pointer to left string    }
  2295. {       EDX = Pointer to right string   }
  2296. {       ECX = Number of chars to compare}
  2297.  
  2298.         PUSH    EBX
  2299.         PUSH    ESI
  2300.         PUSH    ECX
  2301.         MOV     ESI,ECX
  2302.         SHR     ESI,2
  2303.         JE      @@cmpRest
  2304.  
  2305. @@longLoop:
  2306.         MOV     ECX,[EAX]
  2307.         MOV     EBX,[EDX]
  2308.         CMP     ECX,EBX
  2309.         JNE     @@misMatch
  2310.         DEC     ESI
  2311.         JE      @@cmpRestP4
  2312.         MOV     ECX,[EAX+4]
  2313.         MOV     EBX,[EDX+4]
  2314.         CMP     ECX,EBX
  2315.         JNE     @@misMatch
  2316.         ADD     EAX,8
  2317.         ADD     EDX,8
  2318.         DEC     ESI
  2319.         JNE     @@longLoop
  2320.         JMP     @@cmpRest
  2321. @@cmpRestp4:
  2322.         ADD     EAX,4
  2323.         ADD     EDX,4
  2324. @@cmpRest:
  2325.         POP     ESI
  2326.         AND     ESI,3
  2327.         JE      @@exit
  2328.  
  2329.         MOV     CL,[EAX]
  2330.         CMP     CL,[EDX]
  2331.         JNE     @@exit
  2332.         DEC     ESI
  2333.         JE      @@equal
  2334.         MOV     CL,[EAX+1]
  2335.         CMP     CL,[EDX+1]
  2336.         JNE     @@exit
  2337.         DEC     ESI
  2338.         JE      @@equal
  2339.         MOV     CL,[EAX+2]
  2340.         CMP     CL,[EDX+2]
  2341.         JNE     @@exit
  2342.  
  2343. @@equal:
  2344.         XOR     EAX,EAX
  2345.         JMP     @@exit
  2346.  
  2347. @@misMatch:
  2348.         POP     ESI
  2349.         CMP     CL,BL
  2350.         JNE     @@exit
  2351.         CMP     CH,BH
  2352.         JNE     @@exit
  2353.         SHR     ECX,16
  2354.         SHR     EBX,16
  2355.         CMP     CL,BL
  2356.         JNE     @@exit
  2357.         CMP     CH,BH
  2358.  
  2359. @@exit:
  2360.         POP     ESI
  2361.         POP     EBX
  2362. end;
  2363.  
  2364. procedure       _EofFile;                               external;       {$L EofFile }
  2365. procedure       _EofText;                               external;       {$L EofText }
  2366. procedure       _Eoln;                          external;       {$L Eoln    }
  2367. procedure       _Erase;                         external;       {$L Erase   }
  2368.  
  2369. procedure       _FSafeDivide;                           external;       {$L FDIV    }
  2370. procedure       _FSafeDivideR;                          external;       {   FDIV    }
  2371.  
  2372. procedure       _FilePos;                               external;       {$L FilePos }
  2373. procedure       _FileSize;                              external;       {$L FileSize}
  2374.  
  2375. procedure       _FillChar;
  2376. asm
  2377. {     ->EAX     Pointer to destination  }
  2378. {       EDX     count   }
  2379. {       CL      value   }
  2380.  
  2381.         PUSH    EDI
  2382.  
  2383.         MOV     EDI,EAX { Point EDI to destination              }
  2384.  
  2385.         MOV     CH,CL   { Fill EAX with value repeated 4 times  }
  2386.         MOV     EAX,ECX
  2387.         SHL     EAX,16
  2388.         MOV     AX,CX
  2389.  
  2390.         MOV     ECX,EDX
  2391.         SAR     ECX,2
  2392.         JS      @@exit
  2393.  
  2394.         REP     STOSD   { Fill count DIV 4 dwords       }
  2395.  
  2396.         MOV     ECX,EDX
  2397.         AND     ECX,3
  2398.         REP     STOSB   { Fill count MOD 4 bytes        }
  2399.  
  2400. @@exit:
  2401.         POP     EDI
  2402. end;
  2403.  
  2404. procedure       _Mark;
  2405. begin
  2406.   Error(reInvalidPtr);
  2407. end;
  2408.  
  2409. procedure       _RandInt;
  2410. asm
  2411. {     ->EAX     Range   }
  2412. {     <-EAX     Result  }
  2413.         IMUL    EDX,RandSeed,08088405H
  2414.         INC     EDX
  2415.         MOV     RandSeed,EDX
  2416.         MUL     EDX
  2417.         MOV     EAX,EDX
  2418. end;
  2419.  
  2420. procedure       _RandExt;
  2421. const two2neg32: double = ((1.0/$10000) / $10000);  // 2^-32
  2422. asm
  2423. {       FUNCTION _RandExt: Extended;    }
  2424.  
  2425.         IMUL    EDX,RandSeed,08088405H
  2426.         INC     EDX
  2427.         MOV     RandSeed,EDX
  2428.  
  2429.         FLD     two2neg32
  2430.         PUSH    0
  2431.         PUSH    EDX
  2432.         FILD    qword ptr [ESP]
  2433.         ADD     ESP,8
  2434.         FMULP  ST(1), ST(0)
  2435. end;
  2436.  
  2437. procedure       _ReadRec;                               external;       {$L ReadRec }
  2438.  
  2439. procedure       _ReadChar;                              external;       {$L ReadChar}
  2440. procedure       _ReadLong;                              external;       {$L ReadLong}
  2441. procedure       _ReadString;                    external;       {$L ReadStri}
  2442. procedure       _ReadCString;                   external;       {   ReadStri}
  2443.  
  2444. procedure       _ReadExt;                               external;       {$L ReadExt }
  2445. procedure       _ReadLn;                                external;       {$L ReadLn  }
  2446.  
  2447. procedure       _Rename;                                external;       {$L Rename  }
  2448.  
  2449. procedure       _Release;
  2450. begin
  2451.   Error(reInvalidPtr);
  2452. end;
  2453.  
  2454. procedure       _ResetText(var t: text);                external;       {$L OpenText}
  2455. procedure       _ResetFile;                             external;       {$L OpenFile}
  2456. procedure       _RewritText(var t: text);               external;       {   OpenText}
  2457. procedure       _RewritFile;                    external;       {   OpenFile}
  2458.  
  2459. procedure       _Seek;                          external;       {$L Seek    }
  2460. procedure       _SeekEof;                               external;       {$L SeekEof }
  2461. procedure       _SeekEoln;                              external;       {$L SeekEoln}
  2462.  
  2463. procedure       _SetTextBuf;                    external;       {$L SetTextB}
  2464.  
  2465. procedure       _StrLong;
  2466. asm
  2467. {       PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString );
  2468.       ->EAX     Value
  2469.         EDX     Width
  2470.         ECX     Pointer to string       }
  2471.  
  2472.         PUSH    EBX             { VAR i: Longint;               }
  2473.         PUSH    ESI             { VAR sign : Longint;           }
  2474.         PUSH    EDI
  2475.         PUSH    EDX             { store width on the stack      }
  2476.         SUB     ESP,20          { VAR a: array [0..19] of Char; }
  2477.  
  2478.         MOV     EDI,ECX
  2479.  
  2480.         MOV     ESI,EAX         { sign := val                   }
  2481.  
  2482.         CDQ                     { val := Abs(val);  canned sequence }
  2483.         XOR     EAX,EDX
  2484.         SUB     EAX,EDX
  2485.  
  2486.         MOV     ECX,10
  2487.         XOR     EBX,EBX         { i := 0;                       }
  2488.  
  2489. @@repeat1:                      { repeat                        }
  2490.         XOR     EDX,EDX         {   a[i] := Chr( val MOD 10 + Ord('0') );}
  2491.  
  2492.         DIV     ECX             {   val := val DIV 10;          }
  2493.  
  2494.         ADD     EDX,'0'
  2495.         MOV     [ESP+EBX],DL
  2496.         INC     EBX             {   i := i + 1;                 }
  2497.         TEST    EAX,EAX         { until val = 0;                }
  2498.         JNZ     @@repeat1
  2499.  
  2500.         TEST    ESI,ESI
  2501.         JGE     @@2
  2502.         MOV     byte ptr [ESP+EBX],'-'
  2503.         INC     EBX
  2504. @@2:
  2505.         MOV     [EDI],BL        { s^++ := Chr(i);               }
  2506.         INC     EDI
  2507.  
  2508.         MOV     ECX,[ESP+20]    { spaceCnt := width - i;        }
  2509.         CMP     ECX,255
  2510.         JLE     @@3
  2511.         MOV     ECX,255
  2512. @@3:
  2513.         SUB     ECX,EBX
  2514.         JLE     @@repeat2       { for k := 1 to spaceCnt do s^++ := ' ';        }
  2515.         ADD     [EDI-1],CL
  2516.         MOV     AL,' '
  2517.         REP     STOSB
  2518.  
  2519. @@repeat2:                      { repeat                        }
  2520.         MOV     AL,[ESP+EBX-1]  {   s^ := a[i-1];               }
  2521.         MOV     [EDI],AL
  2522.         INC     EDI             {   s := s + 1                  }
  2523.         DEC     EBX             {   i := i - 1;                 }
  2524.         JNZ     @@repeat2       { until i = 0;                  }
  2525.  
  2526.         ADD     ESP,20+4
  2527.         POP     EDI
  2528.         POP     ESI
  2529.         POP     EBX
  2530. end;
  2531.  
  2532. procedure       _Str0Long;
  2533. asm
  2534. {     ->EAX     Value           }
  2535. {       EDX     Pointer to string       }
  2536.  
  2537.         MOV     ECX,EDX
  2538.         XOR     EDX,EDX
  2539.         JMP     _StrLong
  2540. end;
  2541.  
  2542. procedure       _Truncate;                              external;       {$L Truncate}
  2543.  
  2544. procedure       _ValLong;
  2545. asm
  2546. {       FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint;        }
  2547. {     ->EAX     Pointer to string       }
  2548. {       EDX     Pointer to code result  }
  2549. {     <-EAX     Result                  }
  2550.  
  2551.         PUSH    EBX
  2552.         PUSH    ESI
  2553.         PUSH    EDI
  2554.  
  2555.         MOV     ESI,EAX
  2556.         PUSH    EAX             { save for the error case       }
  2557.  
  2558.         TEST    EAX,EAX
  2559.         JE      @@empty
  2560.  
  2561.         XOR     EAX,EAX
  2562.         XOR     EBX,EBX
  2563.         MOV     EDI,07FFFFFFFH / 10     { limit }
  2564.  
  2565. @@blankLoop:
  2566.         MOV     BL,[ESI]
  2567.         INC     ESI
  2568.         CMP     BL,' '
  2569.         JE      @@blankLoop
  2570.  
  2571. @@endBlanks:
  2572.         MOV     CH,0
  2573.         CMP     BL,'-'
  2574.         JE      @@minus
  2575.         CMP     BL,'+'
  2576.         JE      @@plus
  2577.         CMP     BL,'$'
  2578.         JE      @@dollar
  2579.  
  2580.         CMP     BL, 'x'
  2581.         JE      @@dollar
  2582.         CMP     BL, 'X'
  2583.         JE      @@dollar
  2584.         CMP     BL, '0'
  2585.         JNE     @@firstDigit
  2586.         MOV     BL, [ESI]
  2587.         INC     ESI
  2588.         CMP     BL, 'x'
  2589.         JE      @@dollar
  2590.         CMP     BL, 'X'
  2591.         JE      @@dollar
  2592.         TEST    BL, BL
  2593.         JE      @@endDigits
  2594.         JMP     @@digLoop
  2595.  
  2596. @@firstDigit:
  2597.         TEST    BL,BL
  2598.         JE      @@error
  2599.  
  2600. @@digLoop:
  2601.         SUB     BL,'0'
  2602.         CMP     BL,9
  2603.         JA      @@error
  2604.         CMP     EAX,EDI         { value > limit ?       }
  2605.         JA      @@overFlow
  2606.         LEA     EAX,[EAX+EAX*4]
  2607.         ADD     EAX,EAX
  2608.         ADD     EAX,EBX         { fortunately, we can't have a carry    }
  2609.  
  2610.         MOV     BL,[ESI]
  2611.         INC     ESI
  2612.  
  2613.         TEST    BL,BL
  2614.         JNE     @@digLoop
  2615.  
  2616. @@endDigits:
  2617.         DEC     CH
  2618.         JE      @@negate
  2619.         TEST    EAX,EAX
  2620.         JL      @@overFlow
  2621.  
  2622. @@successExit:
  2623.  
  2624.         POP     ECX                     { saved copy of string pointer  }
  2625.  
  2626.         XOR     ESI,ESI         { signal no error to caller     }
  2627.  
  2628. @@exit:
  2629.         MOV     [EDX],ESI
  2630.  
  2631.         POP     EDI
  2632.         POP     ESI
  2633.         POP     EBX
  2634.         RET
  2635.  
  2636. @@empty:
  2637.         INC     ESI
  2638.         JMP     @@error
  2639.  
  2640. @@negate:
  2641.         NEG     EAX
  2642.         JLE     @@successExit
  2643.         JS      @@successExit           { to handle 2**31 correctly, where the negate overflows }
  2644.  
  2645. @@error:
  2646. @@overFlow:
  2647.         POP     EBX
  2648.         SUB     ESI,EBX
  2649.         JMP     @@exit
  2650.  
  2651. @@minus:
  2652.         INC     CH
  2653. @@plus:
  2654.         MOV     BL,[ESI]
  2655.         INC     ESI
  2656.         JMP     @@firstDigit
  2657.  
  2658. @@dollar:
  2659.         MOV     EDI,0FFFFFFFH
  2660.  
  2661.         MOV     BL,[ESI]
  2662.         INC     ESI
  2663.         TEST    BL,BL
  2664.         JZ      @@empty
  2665.  
  2666. @@hDigLoop:
  2667.         CMP     BL,'a'
  2668.         JB      @@upper
  2669.         SUB     BL,'a' - 'A'
  2670. @@upper:
  2671.         SUB     BL,'0'
  2672.         CMP     BL,9
  2673.         JBE     @@digOk
  2674.         SUB     BL,'A' - '0'
  2675.         CMP     BL,5
  2676.         JA      @@error
  2677.         ADD     BL,10
  2678. @@digOk:
  2679.         CMP     EAX,EDI
  2680.         JA      @@overFlow
  2681.         SHL     EAX,4
  2682.         ADD     EAX,EBX
  2683.  
  2684.         MOV     BL,[ESI]
  2685.         INC     ESI
  2686.  
  2687.         TEST    BL,BL
  2688.         JNE     @@hDigLoop
  2689.  
  2690.         JMP     @@successExit
  2691. end;
  2692.  
  2693. procedure       _WriteRec;                              external;       {$L WriteRec}
  2694.  
  2695. procedure       _WriteChar;                             external;       {   WriteStr}
  2696. procedure       _Write0Char;                    external;       {   WriteStr}
  2697.  
  2698. procedure       _WriteBool;
  2699. asm
  2700. {       PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint);       }
  2701. {     ->EAX     Pointer to file record  }
  2702. {       DL      Boolean value           }
  2703. {       ECX     Field width             }
  2704.  
  2705.         TEST    DL,DL
  2706.         JE      @@false
  2707.         MOV     EDX,offset @trueString
  2708.         JMP     _WriteString
  2709. @@false:
  2710.         MOV     EDX,offset @falseString
  2711.         JMP     _WriteString
  2712. @trueString:  db        4,'TRUE'
  2713. @falseString: db        5,'FALSE'
  2714. end;
  2715.  
  2716. procedure       _Write0Bool;
  2717. asm
  2718. {       PROCEDURE _Write0Bool( VAR t: Text; val: Boolean);      }
  2719. {     ->EAX     Pointer to file record  }
  2720. {       DL      Boolean value           }
  2721.  
  2722.         XOR     ECX,ECX
  2723.         JMP     _WriteBool
  2724. end;
  2725.  
  2726. procedure       _WriteLong;
  2727. asm
  2728. {       PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint);        }
  2729. {     ->EAX     Pointer to file record  }
  2730. {       EDX     Value                   }
  2731. {       ECX     Field width             }
  2732.  
  2733.         SUB     ESP,32          { VAR s: String[31];    }
  2734.  
  2735.         PUSH    EAX
  2736.         PUSH    ECX
  2737.  
  2738.         MOV     EAX,EDX         { Str( val : 0, s );    }
  2739.         XOR     EDX,EDX
  2740.         CMP     ECX,31
  2741.         JG      @@1
  2742.         MOV     EDX,ECX
  2743. @@1:
  2744.         LEA     ECX,[ESP+8]
  2745.         CALL    _StrLong
  2746.  
  2747.         POP     ECX
  2748.         POP     EAX
  2749.  
  2750.         MOV     EDX,ESP         { Write( t, s : width );}
  2751.         CALL    _WriteString
  2752.  
  2753.         ADD     ESP,32
  2754. end;
  2755.  
  2756. procedure       _Write0Long;
  2757. asm
  2758. {       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
  2759. {     ->EAX     Pointer to file record  }
  2760. {       EDX     Value                   }
  2761.         XOR     ECX,ECX
  2762.         JMP     _WriteLong
  2763. end;
  2764.  
  2765. procedure       _WriteString;                   external;       {$L WriteStr}
  2766. procedure       _Write0String;                  external;       {   WriteStr}
  2767.  
  2768. procedure       _WriteCString;                  external;       {   WriteStr}
  2769. procedure       _Write0CString;                 external;       {   WriteStr}
  2770.  
  2771. procedure       _WriteBytes;                    external;       {   WriteStr}
  2772. procedure       _WriteSpaces;                   external;       {   WriteStr}
  2773.  
  2774. procedure       _Write2Ext;
  2775. asm
  2776. {       PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint);
  2777.       ->EAX     Pointer to file record
  2778.         [ESP+4] Extended value
  2779.         EDX     Field width
  2780.         ECX     precision (<0: scientific, >= 0: fixed point)   }
  2781.  
  2782.         FLD     tbyte ptr [ESP+4]       { load value    }
  2783.         SUB     ESP,256         { VAR s: String;        }
  2784.  
  2785.         PUSH    EAX
  2786.         PUSH    EDX
  2787.  
  2788. {       Str( val, width, prec, s );     }
  2789.  
  2790.         SUB     ESP,12
  2791.         FSTP    tbyte ptr [ESP] { pass value            }
  2792.         MOV     EAX,EDX         { pass field width              }
  2793.         MOV     EDX,ECX         { pass precision                }
  2794.         LEA     ECX,[ESP+8+12]  { pass destination string       }
  2795.         CALL    _Str2Ext
  2796.  
  2797. {       Write( t, s, width );   }
  2798.  
  2799.         POP     ECX                     { pass width    }
  2800.         POP     EAX                     { pass text     }
  2801.         MOV     EDX,ESP         { pass string   }
  2802.         CALL    _WriteString
  2803.  
  2804.         ADD     ESP,256
  2805.         RET     12
  2806. end;
  2807.  
  2808. procedure       _Write1Ext;
  2809. asm
  2810. {       PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint);
  2811.   ->    EAX     Pointer to file record
  2812.         [ESP+4] Extended value
  2813.         EDX     Field width             }
  2814.  
  2815.         OR      ECX,-1
  2816.         JMP     _Write2Ext
  2817. end;
  2818.  
  2819. procedure       _Write0Ext;
  2820. asm
  2821. {       PROCEDURE _Write0Ext( VAR t: Text; val: Extended);
  2822.       ->EAX     Pointer to file record
  2823.         [ESP+4] Extended value  }
  2824.  
  2825.         MOV     EDX,23  { field width   }
  2826.         OR      ECX,-1
  2827.         JMP     _Write2Ext
  2828. end;
  2829.  
  2830. procedure       _WriteLn;                       external;       {   WriteStr}
  2831.  
  2832. procedure       __CToPasStr;
  2833. asm
  2834. {     ->EAX     Pointer to destination  }
  2835. {       EDX     Pointer to source       }
  2836.  
  2837.         PUSH    EAX             { save destination      }
  2838.  
  2839.         MOV     CL,255
  2840. @@loop:
  2841.         MOV     CH,[EDX]        { ch = *src++;          }
  2842.         INC     EDX
  2843.         TEST    CH,CH   { if (ch == 0) break    }
  2844.         JE      @@endLoop
  2845.         INC     EAX             { *++dest = ch;         }
  2846.         MOV     [EAX],CH
  2847.         DEC     CL
  2848.         JNE     @@loop
  2849.  
  2850. @@endLoop:
  2851.         POP     EDX
  2852.         SUB     EAX,EDX
  2853.         MOV     [EDX],AL
  2854. end;
  2855.  
  2856. procedure       __CLenToPasStr;
  2857. asm
  2858. {     ->EAX     Pointer to destination  }
  2859. {       EDX     Pointer to source       }
  2860. {       ECX     cnt                     }
  2861.  
  2862.         PUSH    EBX
  2863.         PUSH    EAX             { save destination      }
  2864.  
  2865.         CMP     ECX,255
  2866.         JBE     @@loop
  2867.     MOV ECX,255
  2868. @@loop:
  2869.         MOV     BL,[EDX]        { ch = *src++;          }
  2870.         INC     EDX
  2871.         TEST    BL,BL   { if (ch == 0) break    }
  2872.         JE      @@endLoop
  2873.         INC     EAX             { *++dest = ch;         }
  2874.         MOV     [EAX],BL
  2875.         DEC     ECX             { while (--cnt != 0)    }
  2876.         JNZ     @@loop
  2877.  
  2878. @@endLoop:
  2879.         POP     EDX
  2880.         SUB     EAX,EDX
  2881.         MOV     [EDX],AL
  2882.         POP     EBX
  2883. end;
  2884.  
  2885. procedure       __ArrayToPasStr;
  2886. asm
  2887. {     ->EAX     Pointer to destination  }
  2888. {       EDX     Pointer to source       }
  2889. {       ECX     cnt                     }
  2890.  
  2891.         XCHG    EAX,EDX
  2892.  
  2893.         {       limit the length to 255 }
  2894.  
  2895.         CMP     ECX,255
  2896.     JBE     @@skip
  2897.     MOV     ECX,255
  2898. @@skip:
  2899.     MOV     [EDX],CL
  2900.  
  2901.         {       copy the source to destination + 1 }
  2902.  
  2903.         INC     EDX
  2904.         JMP     Move
  2905. end;
  2906.  
  2907.  
  2908. procedure       __PasToCStr;
  2909. asm
  2910. {     ->EAX     Pointer to source       }
  2911. {       EDX     Pointer to destination  }
  2912.  
  2913.         PUSH    ESI
  2914.         PUSH    EDI
  2915.  
  2916.         MOV     ESI,EAX
  2917.         MOV     EDI,EDX
  2918.  
  2919.         XOR     ECX,ECX
  2920.         MOV     CL,[ESI]
  2921.         INC     ESI
  2922.  
  2923.         REP     MOVSB
  2924.         MOV     byte ptr [EDI],CL       { Append terminator: CL is zero here }
  2925.  
  2926.         POP     EDI
  2927.         POP     ESI
  2928. end;
  2929.  
  2930. procedure       _SetElem;
  2931. asm
  2932.         {       PROCEDURE _SetElem( VAR d: SET; elem, size: Byte);      }
  2933.         {       EAX     =       dest address                            }
  2934.         {       DL      =       element number                          }
  2935.         {       CL      =       size of set                                     }
  2936.  
  2937.         PUSH    EBX
  2938.         PUSH    EDI
  2939.  
  2940.         MOV     EDI,EAX
  2941.  
  2942.         XOR     EBX,EBX { zero extend set size into ebx }
  2943.         MOV     BL,CL
  2944.         MOV     ECX,EBX { and use it for the fill       }
  2945.  
  2946.         XOR     EAX,EAX { for zero fill                 }
  2947.         REP     STOSB
  2948.  
  2949.         SUB     EDI,EBX { point edi at beginning of set again   }
  2950.  
  2951.         INC     EAX             { eax is still zero - make it 1 }
  2952.         MOV     CL,DL
  2953.         ROL     AL,CL   { generate a mask               }
  2954.         SHR     ECX,3   { generate the index            }
  2955.         CMP     ECX,EBX { if index >= siz then exit     }
  2956.         JAE     @@exit
  2957.         OR      [EDI+ECX],AL{ set bit                   }
  2958.  
  2959. @@exit:
  2960.         POP     EDI
  2961.         POP     EBX
  2962. end;
  2963.  
  2964. procedure       _SetRange;
  2965. asm
  2966. {       PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET );  }
  2967. { ->AL  low limit of range      }
  2968. {       DL      high limit of range     }
  2969. {       ECX     Pointer to set          }
  2970. {       AH      size of set             }
  2971.  
  2972.         PUSH    EBX
  2973.         PUSH    ESI
  2974.         PUSH    EDI
  2975.  
  2976.         XOR     EBX,EBX { EBX = set size                }
  2977.         MOV     BL,AH
  2978.         MOVZX   ESI,AL  { ESI = low zero extended       }
  2979.         MOVZX   EDX,DL  { EDX = high zero extended      }
  2980.         MOV     EDI,ECX
  2981.  
  2982. {       clear the set                                   }
  2983.  
  2984.         MOV     ECX,EBX
  2985.         XOR     EAX,EAX
  2986.         REP     STOSB
  2987.  
  2988. {       prepare for setting the bits                    }
  2989.  
  2990.         SUB     EDI,EBX { point EDI at start of set     }
  2991.         SHL     EBX,3   { EBX = highest bit in set + 1  }
  2992.         CMP     EDX,EBX
  2993.         JB      @@inrange
  2994.         LEA     EDX,[EBX-1]     { ECX = highest bit in set      }
  2995.  
  2996. @@inrange:
  2997.         CMP     ESI,EDX { if lo > hi then exit;         }
  2998.         JA      @@exit
  2999.  
  3000.         DEC     EAX     { loMask = 0xff << (lo & 7)             }
  3001.         MOV     ECX,ESI
  3002.         AND     CL,07H
  3003.         SHL     AL,CL
  3004.  
  3005.         SHR     ESI,3   { loIndex = lo >> 3;            }
  3006.  
  3007.         MOV     CL,DL   { hiMask = 0xff >> (7 - (hi & 7));      }
  3008.         NOT     CL
  3009.         AND     CL,07
  3010.         SHR     AH,CL
  3011.  
  3012.         SHR     EDX,3   { hiIndex = hi >> 3;            }
  3013.  
  3014.         ADD     EDI,ESI { point EDI to set[loIndex]     }
  3015.         MOV     ECX,EDX
  3016.         SUB     ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0)     }
  3017.         JNE     @@else
  3018.  
  3019.         AND     AL,AH   { set[loIndex] = hiMask & loMask;       }
  3020.         MOV     [EDI],AL
  3021.         JMP     @@exit
  3022.  
  3023. @@else:
  3024.         STOSB           { set[loIndex++] = loMask;      }
  3025.         DEC     ECX
  3026.         MOV     AL,0FFH { while (loIndex < hiIndex)     }
  3027.         REP     STOSB   {   set[loIndex++] = 0xff;      }
  3028.         MOV     [EDI],AH        { set[hiIndex] = hiMask;        }
  3029.  
  3030. @@exit:
  3031.         POP     EDI
  3032.         POP     ESI
  3033.         POP     EBX
  3034. end;
  3035.  
  3036. procedure       _SetEq;
  3037. asm
  3038. {       FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode;   }
  3039. {       EAX     =       left operand    }
  3040. {       EDX     =       right operand   }
  3041. {       CL      =       size of set     }
  3042.  
  3043.         PUSH    ESI
  3044.         PUSH    EDI
  3045.  
  3046.         MOV     ESI,EAX
  3047.         MOV     EDI,EDX
  3048.  
  3049.         AND     ECX,0FFH
  3050.         REP     CMPSB
  3051.  
  3052.         POP     EDI
  3053.         POP     ESI
  3054. end;
  3055.  
  3056. procedure       _SetLe;
  3057. asm
  3058. {       FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode;   }
  3059. {       EAX     =       left operand            }
  3060. {       EDX     =       right operand           }
  3061. {       CL      =       size of set (>0 && <= 32)       }
  3062.  
  3063. @@loop:
  3064.         MOV     CH,[EDX]
  3065.         NOT     CH
  3066.         AND     CH,[EAX]
  3067.         JNE     @@exit
  3068.         INC     EDX
  3069.         INC     EAX
  3070.         DEC     CL
  3071.         JNZ     @@loop
  3072. @@exit:
  3073. end;
  3074.  
  3075. procedure       _SetIntersect;
  3076. asm
  3077. {       PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);}
  3078. {       EAX     =       destination operand             }
  3079. {       EDX     =       source operand                  }
  3080. {       CL      =       size of set (0 < size <= 32)    }
  3081.  
  3082. @@loop:
  3083.         MOV     CH,[EDX]
  3084.         INC     EDX
  3085.         AND     [EAX],CH
  3086.         INC     EAX
  3087.         DEC     CL
  3088.         JNZ     @@loop
  3089. end;
  3090.  
  3091. procedure       _SetIntersect3;
  3092. asm
  3093. {       PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
  3094. {       EAX     =       destination operand             }
  3095. {       EDX     =       source operand                  }
  3096. {       ECX     =       size of set (0 < size <= 32)    }
  3097. {    [ESP+4]    =    2nd source operand        }
  3098.  
  3099.     PUSH    EBX
  3100.     PUSH    ESI
  3101.     MOV    ESI,[ESP+8+4]
  3102. @@loop:
  3103.         MOV     BL,[EDX+ECX-1]
  3104.     AND    BL,[ESI+ECX-1]
  3105.     MOV    [EAX+ECX-1],BL
  3106.         DEC     ECX
  3107.         JNZ     @@loop
  3108.  
  3109.     POP    ESI
  3110.     POP    EBX
  3111. end;
  3112.  
  3113. procedure       _SetUnion;
  3114. asm
  3115. {       PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte);        }
  3116. {       EAX     =       destination operand             }
  3117. {       EDX     =       source operand                  }
  3118. {       CL      =       size of set (0 < size <= 32)    }
  3119.  
  3120. @@loop:
  3121.         MOV     CH,[EDX]
  3122.         INC     EDX
  3123.         OR      [EAX],CH
  3124.         INC     EAX
  3125.         DEC     CL
  3126.         JNZ     @@loop
  3127. end;
  3128.  
  3129. procedure       _SetUnion3;
  3130. asm
  3131. {       PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
  3132. {       EAX     =       destination operand             }
  3133. {       EDX     =       source operand                  }
  3134. {       ECX     =       size of set (0 < size <= 32)    }
  3135. {    [ESP+4]    =    2nd source operand        }
  3136.  
  3137.     PUSH    EBX
  3138.     PUSH    ESI
  3139.     MOV    ESI,[ESP+8+4]
  3140. @@loop:
  3141.         MOV     BL,[EDX+ECX-1]
  3142.     OR    BL,[ESI+ECX-1]
  3143.     MOV    [EAX+ECX-1],BL
  3144.         DEC     ECX
  3145.         JNZ     @@loop
  3146.  
  3147.     POP    ESI
  3148.     POP    EBX
  3149. end;
  3150.  
  3151. procedure       _SetSub;
  3152. asm
  3153. {       PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte);  }
  3154. {       EAX     =       destination operand             }
  3155. {       EDX     =       source operand                  }
  3156. {       CL      =       size of set (0 < size <= 32)    }
  3157.  
  3158. @@loop:
  3159.         MOV     CH,[EDX]
  3160.         NOT     CH
  3161.         INC     EDX
  3162.         AND     [EAX],CH
  3163.         INC     EAX
  3164.         DEC     CL
  3165.         JNZ     @@loop
  3166. end;
  3167.  
  3168. procedure       _SetSub3;
  3169. asm
  3170. {       PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
  3171. {       EAX     =       destination operand             }
  3172. {       EDX     =       source operand                  }
  3173. {       ECX     =       size of set (0 < size <= 32)    }
  3174. {    [ESP+4]    =    2nd source operand        }
  3175.  
  3176.     PUSH    EBX
  3177.     PUSH    ESI
  3178.     MOV    ESI,[ESP+8+4]
  3179. @@loop:
  3180.     MOV    BL,[ESI+ECX-1]
  3181.     NOT    BL
  3182.         AND     BL,[EDX+ECX-1]
  3183.     MOV    [EAX+ECX-1],BL
  3184.         DEC     ECX
  3185.         JNZ     @@loop
  3186.  
  3187.     POP    ESI
  3188.     POP    EBX
  3189. end;
  3190.  
  3191. procedure       _SetExpand;
  3192. asm
  3193. {       PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte);     }
  3194. {     ->EAX     Pointer to source (packed set)          }
  3195. {       EDX     Pointer to destination (expanded set)   }
  3196. {       CH      high byte of source                     }
  3197. {       CL      low byte of source                      }
  3198.  
  3199. {       algorithm:              }
  3200. {       clear low bytes         }
  3201. {       copy high-low+1 bytes   }
  3202. {       clear 31-high bytes     }
  3203.  
  3204.         PUSH    ESI
  3205.         PUSH    EDI
  3206.  
  3207.         MOV     ESI,EAX
  3208.         MOV     EDI,EDX
  3209.  
  3210.         MOV     EDX,ECX { save low, high in dl, dh      }
  3211.         XOR     ECX,ECX
  3212.         XOR     EAX,EAX
  3213.  
  3214.         MOV     CL,DL   { clear low bytes               }
  3215.         REP     STOSB
  3216.  
  3217.         MOV     CL,DH   { copy high - low bytes }
  3218.         SUB     CL,DL
  3219.         REP     MOVSB
  3220.  
  3221.         MOV     CL,32   { copy 32 - high bytes  }
  3222.         SUB     CL,DH
  3223.         REP     STOSB
  3224.  
  3225.         POP     EDI
  3226.         POP     ESI
  3227. end;
  3228.  
  3229. procedure       _Str2Ext;                       external;       {$L StrExt  }
  3230. procedure       _Str0Ext;                       external;       {   StrExt  }
  3231. procedure       _Str1Ext;                       external;       {   StrExt  }
  3232.  
  3233. procedure       _ValExt;                        external;       {$L ValExt  }
  3234.  
  3235. procedure       _Pow10;                         external;       {$L Pow10   }
  3236. procedure       FPower10;                       external;       {   Pow10   }
  3237. procedure       _Real2Ext;                      external;       {$L Real2Ext}
  3238. procedure       _Ext2Real;                      external;       {$L Ext2Real}
  3239.  
  3240. const
  3241.         ovtInstanceSize = -8;   { Offset of instance size in OBJECTs    }
  3242.         ovtVmtPtrOffs   = -4;
  3243.  
  3244. procedure       _ObjSetup;
  3245. asm
  3246. {       FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
  3247. {     ->EAX     Pointer to self (possibly nil)  }
  3248. {       EDX     Pointer to vmt  (possibly nil)  }
  3249. {     <-EAX     Pointer to self                 }
  3250. {       EDX     <> 0: an object was allocated   }
  3251. {       Z-Flag  Set: failure, Cleared: Success  }
  3252.  
  3253.         CMP     EDX,1   { is vmt = 0, indicating a call         }
  3254.         JAE     @@skip1 { from a constructor?                   }
  3255.         RET                     { return immediately with Z-flag cleared        }
  3256.  
  3257. @@skip1:
  3258.         PUSH    ECX
  3259.         TEST    EAX,EAX { is self already allocated?            }
  3260.         JNE     @@noAlloc
  3261.         MOV     EAX,[EDX].ovtInstanceSize
  3262.         TEST    EAX,EAX
  3263.         JE      @@zeroSize
  3264.         PUSH    EDX
  3265.         CALL    MemoryManager.GetMem
  3266.         POP     EDX
  3267.         TEST    EAX,EAX
  3268.         JZ      @@fail
  3269.  
  3270.         {       Zero fill the memory }
  3271.         PUSH    EDI
  3272.         MOV     ECX,[EDX].ovtInstanceSize
  3273.         MOV     EDI,EAX
  3274.         PUSH    EAX
  3275.         XOR     EAX,EAX
  3276.         SHR     ECX,2
  3277.         REP     STOSD
  3278.         MOV     ECX,[EDX].ovtInstanceSize
  3279.         AND     ECX,3
  3280.         REP     STOSB
  3281.         POP     EAX
  3282.         POP     EDI
  3283.  
  3284.         MOV     ECX,[EDX].ovtVmtPtrOffs
  3285.         TEST    ECX,ECX
  3286.         JL      @@skip
  3287.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  3288. @@skip:
  3289.         TEST    EAX,EAX { clear zero flag                               }
  3290.         POP     ECX
  3291.         RET
  3292.  
  3293. @@fail:
  3294.         XOR     EDX,EDX
  3295.         POP     ECX
  3296.         RET
  3297.  
  3298. @@zeroSize:
  3299.         XOR     EDX,EDX
  3300.         CMP     EAX,1   { clear zero flag - we were successful (kind of) }
  3301.         POP     ECX
  3302.         RET
  3303.  
  3304. @@noAlloc:
  3305.         MOV     ECX,[EDX].ovtVmtPtrOffs
  3306.         TEST    ECX,ECX
  3307.         JL      @@exit
  3308.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  3309. @@exit:
  3310.         XOR     EDX,EDX { clear allocated flag                  }
  3311.         TEST    EAX,EAX { clear zero flag                               }
  3312.         POP     ECX
  3313. end;
  3314.  
  3315. procedure       _ObjCopy;
  3316. asm
  3317. {       PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint);    }
  3318. {     ->EAX     Pointer to destination          }
  3319. {       EDX     Pointer to source               }
  3320. {       ECX     Offset of vmt in those objects. }
  3321.  
  3322.         PUSH    EBX
  3323.         PUSH    ESI
  3324.         PUSH    EDI
  3325.  
  3326.         MOV     ESI,EDX
  3327.         MOV     EDI,EAX
  3328.  
  3329.         LEA     EAX,[EDI+ECX]   { remember pointer to dest vmt pointer  }
  3330.         MOV     EDX,[EAX]       { fetch dest vmt pointer        }
  3331.  
  3332.         MOV     EBX,[EDX].ovtInstanceSize
  3333.  
  3334.         MOV     ECX,EBX { copy size DIV 4 dwords        }
  3335.         SHR     ECX,2
  3336.         REP     MOVSD
  3337.  
  3338.         MOV     ECX,EBX { copy size MOD 4 bytes }
  3339.         AND     ECX,3
  3340.         REP     MOVSB
  3341.  
  3342.         MOV     [EAX],EDX       { restore dest vmt              }
  3343.  
  3344.         POP     EDI
  3345.         POP     ESI
  3346.         POP     EBX
  3347. end;
  3348.  
  3349. procedure       _Fail;
  3350. asm
  3351. {       FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT;     }
  3352. {     ->EAX     Pointer to self (possibly nil)  }
  3353. {       EDX     <> 0: Object must be deallocated        }
  3354. {     <-EAX     Nil                                     }
  3355.  
  3356.         TEST    EDX,EDX
  3357.         JE      @@exit  { if no object was allocated, return    }
  3358.         CALL    _FreeMem
  3359. @@exit:
  3360.         XOR     EAX,EAX
  3361. end;
  3362.  
  3363. function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall;
  3364.   external user name 'GetKeyboardType';
  3365.  
  3366. function _isNECWindows: Boolean;
  3367. var
  3368.   KbSubType: Integer;
  3369. begin
  3370.   Result := False;
  3371.   if GetKeyboardType(0) = $7 then
  3372.   begin
  3373.     KbSubType := GetKeyboardType(1) and $FF00;
  3374.     if (KbSubType = $0D00) or (KbSubType = $0400) then
  3375.       Result := True;
  3376.   end;
  3377. end;
  3378.  
  3379. procedure _FpuMaskInit;
  3380. const
  3381.   HKEY_LOCAL_MACHINE = $80000002;
  3382.   KEY_QUERY_VALUE    = $00000001;
  3383.   REG_DWORD          = 4;
  3384.   FPUMASKKEY  = 'SOFTWARE\Borland\Delphi\RTL';
  3385.   FPUMASKNAME = 'FPUMaskValue';
  3386. var
  3387.   phkResult: LongWord;
  3388.   lpData, DataSize: Longint;
  3389. begin
  3390.   lpData := Default8087CW;
  3391.  
  3392.   if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then
  3393.   try
  3394.     DataSize := Sizeof(lpData);
  3395.     RegQueryValueEx(phkResult, FPUMASKNAME, nil,  nil, @lpData, @DataSize);
  3396.   finally
  3397.     RegCloseKey(phkResult);
  3398.   end;
  3399.  
  3400.   Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f);
  3401. end;
  3402.  
  3403. procedure       _FpuInit;
  3404. //const cwDefault: Word = $1332 { $133F};
  3405. asm
  3406.         FNINIT
  3407.         FWAIT
  3408.         FLDCW   Default8087CW
  3409. end;
  3410.  
  3411. procedure       _BoundErr;
  3412. asm
  3413.         MOV     AL,reRangeError
  3414.         JMP     Error
  3415. end;
  3416.  
  3417. procedure       _IntOver;
  3418. asm
  3419.         MOV     AL,reIntOverflow
  3420.         JMP     Error
  3421. end;
  3422.  
  3423. function TObject.ClassType: TClass;
  3424. asm
  3425.         mov     eax,[eax]
  3426. end;
  3427.  
  3428. class function TObject.ClassName: ShortString;
  3429. asm
  3430.         { ->    EAX VMT                         }
  3431.         {       EDX Pointer to result string    }
  3432.         PUSH    ESI
  3433.         PUSH    EDI
  3434.         MOV     EDI,EDX
  3435.         MOV     ESI,[EAX].vmtClassName
  3436.         XOR     ECX,ECX
  3437.         MOV     CL,[ESI]
  3438.         INC     ECX
  3439.         REP     MOVSB
  3440.         POP     EDI
  3441.         POP     ESI
  3442. end;
  3443.  
  3444. class function TObject.ClassNameIs(const Name: string): Boolean;
  3445. asm
  3446.         PUSH    EBX
  3447.         XOR     EBX,EBX
  3448.         OR      EDX,EDX
  3449.         JE      @@exit
  3450.         MOV     EAX,[EAX].vmtClassName
  3451.         XOR     ECX,ECX
  3452.         MOV     CL,[EAX]
  3453.         CMP     ECX,[EDX-4]
  3454.         JNE     @@exit
  3455.         DEC     EDX
  3456. @@loop:
  3457.         MOV     BH,[EAX+ECX]
  3458.         XOR     BH,[EDX+ECX]
  3459.         AND     BH,0DFH
  3460.         JNE     @@exit
  3461.         DEC     ECX
  3462.         JNE     @@loop
  3463.         INC     EBX
  3464. @@exit:
  3465.         MOV     AL,BL
  3466.         POP     EBX
  3467. end;
  3468.  
  3469. class function TObject.ClassParent: TClass;
  3470. asm
  3471.         MOV     EAX,[EAX].vmtParent
  3472.         TEST    EAX,EAX
  3473.         JE      @@exit
  3474.         MOV     EAX,[EAX]
  3475. @@exit:
  3476. end;
  3477.  
  3478. class function TObject.NewInstance: TObject;
  3479. asm
  3480.         PUSH    EAX
  3481.         MOV     EAX,[EAX].vmtInstanceSize
  3482.         CALL    _GetMem
  3483.         MOV     EDX,EAX
  3484.         POP     EAX
  3485.         JMP     TObject.InitInstance
  3486. end;
  3487.  
  3488. procedure TObject.FreeInstance;
  3489. asm
  3490.         PUSH    EBX
  3491.         PUSH    ESI
  3492.         MOV     EBX,EAX
  3493.         MOV     ESI,EAX
  3494. @@loop:
  3495.         MOV     ESI,[ESI]
  3496.         MOV     EDX,[ESI].vmtInitTable
  3497.         MOV     ESI,[ESI].vmtParent
  3498.         TEST    EDX,EDX
  3499.         JE      @@skip
  3500.         CALL    _FinalizeRecord
  3501.         MOV     EAX,EBX
  3502. @@skip:
  3503.         TEST    ESI,ESI
  3504.         JNE     @@loop
  3505.  
  3506.         CALL    _FreeMem
  3507.         POP     ESI
  3508.         POP     EBX
  3509. end;
  3510.  
  3511. class function TObject.InstanceSize: Longint;
  3512. asm
  3513.         MOV     EAX,[EAX].vmtInstanceSize
  3514. end;
  3515.  
  3516. constructor TObject.Create;
  3517. begin
  3518. end;
  3519.  
  3520. destructor TObject.Destroy;
  3521. begin
  3522. end;
  3523.  
  3524. procedure TObject.Free;
  3525. asm
  3526.         TEST    EAX,EAX
  3527.         JE      @@exit
  3528.         MOV     ECX,[EAX]
  3529.         MOV     DL,1
  3530.         CALL    dword ptr [ECX].vmtDestroy
  3531. @@exit:
  3532. end;
  3533.  
  3534. class function TObject.InitInstance(Instance: Pointer): TObject;
  3535. asm
  3536.         PUSH    EBX
  3537.         PUSH    ESI
  3538.         PUSH    EDI
  3539.         MOV     EBX,EAX
  3540.         MOV     EDI,EDX
  3541.         STOSD
  3542.         MOV     ECX,[EBX].vmtInstanceSize
  3543.         XOR     EAX,EAX
  3544.         PUSH    ECX
  3545.         SHR     ECX,2
  3546.         DEC     ECX
  3547.         REP     STOSD
  3548.         POP     ECX
  3549.         AND     ECX,3
  3550.         REP     STOSB
  3551.         MOV     EAX,EDX
  3552.         MOV     EDX,ESP
  3553. @@0:    MOV     ECX,[EBX].vmtIntfTable
  3554.         TEST    ECX,ECX
  3555.         JE      @@1
  3556.         PUSH    ECX
  3557. @@1:    MOV     EBX,[EBX].vmtParent
  3558.         TEST    EBX,EBX
  3559.         JE      @@2
  3560.         MOV     EBX,[EBX]
  3561.         JMP     @@0
  3562. @@2:    CMP     ESP,EDX
  3563.         JE      @@5
  3564. @@3:    POP     EBX
  3565.         MOV     ECX,[EBX].TInterfaceTable.EntryCount
  3566.         ADD     EBX,4
  3567. @@4:    MOV     ESI,[EBX].TInterfaceEntry.VTable
  3568.         TEST    ESI,ESI
  3569.         JE      @@4a
  3570.         MOV     EDI,[EBX].TInterfaceEntry.IOffset
  3571.         MOV     [EAX+EDI],ESI
  3572. @@4a:   ADD     EBX,TYPE TInterfaceEntry
  3573.         DEC     ECX
  3574.         JNE     @@4
  3575.         CMP     ESP,EDX
  3576.         JNE     @@3
  3577. @@5:    POP     EDI
  3578.         POP     ESI
  3579.         POP     EBX
  3580. end;
  3581.  
  3582. procedure TObject.CleanupInstance;
  3583. asm
  3584.         PUSH    EBX
  3585.         PUSH    ESI
  3586.         MOV     EBX,EAX
  3587.         MOV     ESI,EAX
  3588. @@loop:
  3589.         MOV     ESI,[ESI]
  3590.         MOV     EDX,[ESI].vmtInitTable
  3591.         MOV     ESI,[ESI].vmtParent
  3592.         TEST    EDX,EDX
  3593.         JE      @@skip
  3594.         CALL    _FinalizeRecord
  3595.         MOV     EAX,EBX
  3596. @@skip:
  3597.         TEST    ESI,ESI
  3598.         JNE     @@loop
  3599.  
  3600.         POP     ESI
  3601.         POP     EBX
  3602. end;
  3603.  
  3604. function InvokeImplGetter(Self: TObject; ImplGetter: Integer): IUnknown;
  3605. asm
  3606.         XCHG    EDX,ECX
  3607.         CMP     ECX,$FF000000
  3608.         JAE     @@isField
  3609.         CMP     ECX,$FE000000
  3610.         JB      @@isStaticMethod
  3611.  
  3612.         {       the GetProc is a virtual method }
  3613.         MOVSX   ECX,CX                  { sign extend slot offs }
  3614.         ADD     ECX,[EAX]               { vmt   + slotoffs      }
  3615.         JMP     dword ptr [ECX]         { call vmt[slot]        }
  3616.  
  3617. @@isStaticMethod:
  3618.         JMP     ECX
  3619.  
  3620. @@isField:
  3621.         AND     ECX,$00FFFFFF
  3622.         ADD     ECX,EAX
  3623.         MOV     EAX,EDX
  3624.         MOV     EDX,[ECX]
  3625.         JMP     _IntfCopy
  3626. end;
  3627.  
  3628. function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
  3629. var
  3630.   InterfaceEntry: PInterfaceEntry;
  3631. begin
  3632.   InterfaceEntry := GetInterfaceEntry(IID);
  3633.   if InterfaceEntry <> nil then
  3634.   begin
  3635.     if InterfaceEntry^.IOffset <> 0 then
  3636.       Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset)
  3637.     else
  3638.       IUnknown(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter);
  3639.     if Pointer(Obj) <> nil then
  3640.     begin
  3641.       if InterfaceEntry^.IOffset <> 0 then IUnknown(Obj)._AddRef;
  3642.       Result := True;
  3643.     end
  3644.     else
  3645.       Result := False;
  3646.   end else
  3647.   begin
  3648.     Pointer(Obj) := nil;
  3649.     Result := False;
  3650.   end;
  3651. end;
  3652.  
  3653. class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
  3654. asm
  3655.         PUSH    EBX
  3656.         PUSH    ESI
  3657.         MOV     EBX,EAX
  3658. @@1:    MOV     EAX,[EBX].vmtIntfTable
  3659.         TEST    EAX,EAX
  3660.         JE      @@4
  3661.         MOV     ECX,[EAX].TInterfaceTable.EntryCount
  3662.         ADD     EAX,4
  3663. @@2:    MOV     ESI,[EDX].Integer[0]
  3664.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[0]
  3665.         JNE     @@3
  3666.         MOV     ESI,[EDX].Integer[4]
  3667.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[4]
  3668.         JNE     @@3
  3669.         MOV     ESI,[EDX].Integer[8]
  3670.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[8]
  3671.         JNE     @@3
  3672.         MOV     ESI,[EDX].Integer[12]
  3673.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[12]
  3674.         JE      @@5
  3675. @@3:    ADD     EAX,type TInterfaceEntry
  3676.         DEC     ECX
  3677.         JNE     @@2
  3678. @@4:    MOV     EBX,[EBX].vmtParent
  3679.         TEST    EBX,EBX
  3680.         JE      @@4a
  3681.         MOV     EBX,[EBX]
  3682.         JMP     @@1
  3683. @@4a:   XOR     EAX,EAX
  3684. @@5:    POP     ESI
  3685.         POP     EBX
  3686. end;
  3687.  
  3688. class function TObject.GetInterfaceTable: PInterfaceTable;
  3689. asm
  3690.         MOV     EAX,[EAX].vmtIntfTable
  3691. end;
  3692.  
  3693.  
  3694. procedure       _IsClass;
  3695. asm
  3696.         { ->    EAX     left operand (class)    }
  3697.         {       EDX VMT of right operand        }
  3698.         { <-    AL      left is derived from right      }
  3699.         TEST    EAX,EAX
  3700.         JE      @@exit
  3701. @@loop:
  3702.         MOV     EAX,[EAX]
  3703.         CMP     EAX,EDX
  3704.         JE      @@success
  3705.         MOV     EAX,[EAX].vmtParent
  3706.         TEST    EAX,EAX
  3707.         JNE     @@loop
  3708.         JMP     @@exit
  3709. @@success:
  3710.         MOV     AL,1
  3711. @@exit:
  3712. end;
  3713.  
  3714.  
  3715. procedure       _AsClass;
  3716. asm
  3717.         { ->    EAX     left operand (class)    }
  3718.         {       EDX VMT of right operand        }
  3719.         { <-    EAX      if left is derived from right, else runtime error      }
  3720.         TEST    EAX,EAX
  3721.         JE      @@exit
  3722.         MOV     ECX,EAX
  3723. @@loop:
  3724.         MOV     ECX,[ECX]
  3725.         CMP     ECX,EDX
  3726.         JE      @@exit
  3727.         MOV     ECX,[ECX].vmtParent
  3728.         TEST    ECX,ECX
  3729.         JNE     @@loop
  3730.  
  3731.         {       do runtime error        }
  3732.         MOV     AL,reInvalidCast
  3733.         JMP     Error
  3734.  
  3735. @@exit:
  3736. end;
  3737.  
  3738.  
  3739. procedure       GetDynaMethod;
  3740. {       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
  3741. asm
  3742.         { ->    EAX     vmt of class            }
  3743.         {       BX      dynamic method index    }
  3744.         { <-    EBX pointer to routine  }
  3745.         {       ZF = 0 if found         }
  3746.         {       trashes: EAX, ECX               }
  3747.  
  3748.         PUSH    EDI
  3749.         XCHG    EAX,EBX
  3750.         JMP     @@haveVMT
  3751. @@outerLoop:
  3752.         MOV     EBX,[EBX]
  3753. @@haveVMT:
  3754.         MOV     EDI,[EBX].vmtDynamicTable
  3755.         TEST    EDI,EDI
  3756.         JE      @@parent
  3757.         MOVZX   ECX,word ptr [EDI]
  3758.         PUSH    ECX
  3759.         ADD     EDI,2
  3760.         REPNE   SCASW
  3761.         JE      @@found
  3762.         POP     ECX
  3763. @@parent:
  3764.         MOV     EBX,[EBX].vmtParent
  3765.         TEST    EBX,EBX
  3766.         JNE     @@outerLoop
  3767.         JMP     @@exit
  3768.  
  3769. @@found:
  3770.         POP     EAX
  3771.         ADD     EAX,EAX
  3772.         SUB     EAX,ECX         { this will always clear the Z-flag ! }
  3773.         MOV     EBX,[EDI+EAX*2-4]
  3774.  
  3775. @@exit:
  3776.         POP     EDI
  3777. end;
  3778.  
  3779. procedure       _CallDynaInst;
  3780. asm
  3781.         PUSH    EAX
  3782.         PUSH    ECX
  3783.         MOV     EAX,[EAX]
  3784.         CALL    GetDynaMethod
  3785.         POP     ECX
  3786.         POP     EAX
  3787.         JE      @@Abstract
  3788.         JMP     EBX
  3789. @@Abstract:
  3790.         POP     ECX
  3791.         JMP     _AbstractError
  3792. end;
  3793.  
  3794.  
  3795. procedure       _CallDynaClass;
  3796. asm
  3797.         PUSH    EAX
  3798.         PUSH    ECX
  3799.         CALL    GetDynaMethod
  3800.         POP     ECX
  3801.         POP     EAX
  3802.         JE      @@Abstract
  3803.         JMP     EBX
  3804. @@Abstract:
  3805.         POP     ECX
  3806.         JMP     _AbstractError
  3807. end;
  3808.  
  3809.  
  3810. procedure       _FindDynaInst;
  3811. asm
  3812.         PUSH    EBX
  3813.         MOV     EBX,EDX
  3814.         MOV     EAX,[EAX]
  3815.         CALL    GetDynaMethod
  3816.         MOV     EAX,EBX
  3817.         POP     EBX
  3818.         JNE     @@exit
  3819.         POP     ECX
  3820.         JMP     _AbstractError
  3821. @@exit:
  3822. end;
  3823.  
  3824.  
  3825. procedure       _FindDynaClass;
  3826. asm
  3827.         PUSH    EBX
  3828.         MOV     EBX,EDX
  3829.         CALL    GetDynaMethod
  3830.         MOV     EAX,EBX
  3831.         POP     EBX
  3832.         JNE     @@exit
  3833.         POP     ECX
  3834.         JMP     _AbstractError
  3835. @@exit:
  3836. end;
  3837.  
  3838.  
  3839. class function TObject.InheritsFrom(AClass: TClass): Boolean;
  3840. asm
  3841.         { ->    EAX     Pointer to our class    }
  3842.         {       EDX     Pointer to AClass               }
  3843.         { <-    AL      Boolean result          }
  3844.         JMP     @@haveVMT
  3845. @@loop:
  3846.         MOV     EAX,[EAX]
  3847. @@haveVMT:
  3848.         CMP     EAX,EDX
  3849.         JE      @@success
  3850.         MOV     EAX,[EAX].vmtParent
  3851.         TEST    EAX,EAX
  3852.         JNE     @@loop
  3853.         JMP     @@exit
  3854. @@success:
  3855.         MOV     AL,1
  3856. @@exit:
  3857. end;
  3858.  
  3859.  
  3860. class function TObject.ClassInfo: Pointer;
  3861. asm
  3862.         MOV     EAX,[EAX].vmtTypeInfo
  3863. end;
  3864.  
  3865.  
  3866. function TObject.SafeCallException(ExceptObject: TObject;
  3867.   ExceptAddr: Pointer): HResult;
  3868. begin
  3869.   Result := HResult($8000FFFF); { E_UNEXPECTED }
  3870. end;
  3871.  
  3872.  
  3873. procedure TObject.DefaultHandler(var Message);
  3874. begin
  3875. end;
  3876.  
  3877.  
  3878. procedure TObject.AfterConstruction;
  3879. begin
  3880. end;
  3881.  
  3882. procedure TObject.BeforeDestruction;
  3883. begin
  3884. end;
  3885.  
  3886. procedure TObject.Dispatch(var Message);
  3887. asm
  3888.         PUSH    EBX
  3889.         MOV     BX,[EDX]
  3890.         OR      BX,BX
  3891.         JE      @@default
  3892.         CMP     BX,0C000H
  3893.         JAE     @@default
  3894.         PUSH    EAX
  3895.         MOV     EAX,[EAX]
  3896.         CALL    GetDynaMethod
  3897.         POP     EAX
  3898.         JE      @@default
  3899.         MOV     ECX,EBX
  3900.         POP     EBX
  3901.         JMP     ECX
  3902.  
  3903. @@default:
  3904.         POP     EBX
  3905.         MOV     ECX,[EAX]
  3906.         JMP     dword ptr [ECX].vmtDefaultHandler
  3907. end;
  3908.  
  3909.  
  3910. class function TObject.MethodAddress(const Name: ShortString): Pointer;
  3911. asm
  3912.         { ->    EAX     Pointer to class        }
  3913.         {       EDX     Pointer to name }
  3914.         PUSH    EBX
  3915.         PUSH    ESI
  3916.         PUSH    EDI
  3917.         XOR     ECX,ECX
  3918.         XOR     EDI,EDI
  3919.         MOV     BL,[EDX]
  3920.         JMP     @@haveVMT
  3921. @@outer:                                { upper 16 bits of ECX are 0 !  }
  3922.         MOV     EAX,[EAX]
  3923. @@haveVMT:
  3924.         MOV     ESI,[EAX].vmtMethodTable
  3925.         TEST    ESI,ESI
  3926.         JE      @@parent
  3927.         MOV     DI,[ESI]                { EDI := method count           }
  3928.         ADD     ESI,2
  3929. @@inner:                                { upper 16 bits of ECX are 0 !  }
  3930.         MOV     CL,[ESI+6]              { compare length of strings     }
  3931.         CMP     CL,BL
  3932.         JE      @@cmpChar
  3933. @@cont:                                 { upper 16 bits of ECX are 0 !  }
  3934.         MOV     CX,[ESI]                { fetch length of method desc   }
  3935.         ADD     ESI,ECX                 { point ESI to next method      }
  3936.         DEC     EDI
  3937.         JNZ     @@inner
  3938. @@parent:
  3939.         MOV     EAX,[EAX].vmtParent     { fetch parent vmt              }
  3940.         TEST    EAX,EAX
  3941.         JNE     @@outer
  3942.         JMP     @@exit                  { return NIL                    }
  3943.  
  3944. @@notEqual:
  3945.         MOV     BL,[EDX]                { restore BL to length of name  }
  3946.         JMP     @@cont
  3947.  
  3948. @@cmpChar:                              { upper 16 bits of ECX are 0 !  }
  3949.         MOV     CH,0                    { upper 24 bits of ECX are 0 !  }
  3950. @@cmpCharLoop:
  3951.         MOV     BL,[ESI+ECX+6]          { case insensitive string cmp   }
  3952.         XOR     BL,[EDX+ECX+0]          { last char is compared first   }
  3953.         AND     BL,$DF
  3954.         JNE     @@notEqual
  3955.         DEC     ECX                     { ECX serves as counter         }
  3956.         JNZ     @@cmpCharLoop
  3957.  
  3958.         { found it }
  3959.         MOV     EAX,[ESI+2]
  3960.  
  3961. @@exit:
  3962.         POP     EDI
  3963.         POP     ESI
  3964.         POP     EBX
  3965. end;
  3966.  
  3967.  
  3968. class function TObject.MethodName(Address: Pointer): ShortString;
  3969. asm
  3970.         { ->    EAX     Pointer to class        }
  3971.         {       EDX     Address         }
  3972.         {       ECX Pointer to result   }
  3973.         PUSH    EBX
  3974.         PUSH    ESI
  3975.         PUSH    EDI
  3976.         MOV     EDI,ECX
  3977.         XOR     EBX,EBX
  3978.         XOR     ECX,ECX
  3979.         JMP     @@haveVMT
  3980. @@outer:
  3981.         MOV     EAX,[EAX]
  3982. @@haveVMT:
  3983.         MOV     ESI,[EAX].vmtMethodTable { fetch pointer to method table }
  3984.         TEST    ESI,ESI
  3985.         JE      @@parent
  3986.         MOV     CX,[ESI]
  3987.         ADD     ESI,2
  3988. @@inner:
  3989.         CMP     EDX,[ESI+2]
  3990.         JE      @@found
  3991.         MOV     BX,[ESI]
  3992.         ADD     ESI,EBX
  3993.         DEC     ECX
  3994.         JNZ     @@inner
  3995. @@parent:
  3996.         MOV     EAX,[EAX].vmtParent
  3997.         TEST    EAX,EAX
  3998.         JNE     @@outer
  3999.         MOV     [EDI],AL
  4000.         JMP     @@exit
  4001.  
  4002. @@found:
  4003.         ADD     ESI,6
  4004.         XOR     ECX,ECX
  4005.         MOV     CL,[ESI]
  4006.         INC     ECX
  4007.         REP     MOVSB
  4008.  
  4009. @@exit:
  4010.         POP     EDI
  4011.         POP     ESI
  4012.         POP     EBX
  4013. end;
  4014.  
  4015.  
  4016. function TObject.FieldAddress(const Name: ShortString): Pointer;
  4017. asm
  4018.         { ->    EAX     Pointer to instance     }
  4019.         {       EDX     Pointer to name }
  4020.         PUSH    EBX
  4021.         PUSH    ESI
  4022.         PUSH    EDI
  4023.         XOR     ECX,ECX
  4024.         XOR     EDI,EDI
  4025.         MOV     BL,[EDX]
  4026.  
  4027.         PUSH    EAX                     { save instance pointer         }
  4028.  
  4029. @@outer:
  4030.         MOV     EAX,[EAX]               { fetch class pointer           }
  4031.         MOV     ESI,[EAX].vmtFieldTable
  4032.         TEST    ESI,ESI
  4033.         JE      @@parent
  4034.         MOV     DI,[ESI]                { fetch count of fields         }
  4035.         ADD     ESI,6
  4036. @@inner:
  4037.         MOV     CL,[ESI+6]              { compare string lengths        }
  4038.         CMP     CL,BL
  4039.         JE      @@cmpChar
  4040. @@cont:
  4041.         LEA     ESI,[ESI+ECX+7] { point ESI to next field       }
  4042.         DEC     EDI
  4043.         JNZ     @@inner
  4044. @@parent:
  4045.         MOV     EAX,[EAX].vmtParent     { fetch parent VMT              }
  4046.         TEST    EAX,EAX
  4047.         JNE     @@outer
  4048.         POP     EDX                     { forget instance, return Nil   }
  4049.         JMP     @@exit
  4050.  
  4051. @@notEqual:
  4052.         MOV     BL,[EDX]                { restore BL to length of name  }
  4053.         MOV     CL,[ESI+6]              { ECX := length of field name   }
  4054.         JMP     @@cont
  4055.  
  4056. @@cmpChar:
  4057.         MOV     BL,[ESI+ECX+6]  { case insensitive string cmp   }
  4058.         XOR     BL,[EDX+ECX+0]  { starting with last char       }
  4059.         AND     BL,$DF
  4060.         JNE     @@notEqual
  4061.         DEC     ECX                     { ECX serves as counter         }
  4062.         JNZ     @@cmpChar
  4063.  
  4064.         { found it }
  4065.         MOV     EAX,[ESI]           { result is field offset plus ...   }
  4066.         POP     EDX
  4067.         ADD     EAX,EDX         { instance pointer              }
  4068.  
  4069. @@exit:
  4070.         POP     EDI
  4071.         POP     ESI
  4072.         POP     EBX
  4073. end;
  4074.  
  4075.  
  4076. const { copied from xx.h }
  4077.   cContinuable        = 0;
  4078.   cNonContinuable     = 1;
  4079.   cUnwinding          = 2;
  4080.   cUnwindingForExit   = 4;
  4081.   cUnwindInProgress   = cUnwinding or cUnwindingForExit;
  4082.   cDelphiException    = $0EEDFADE;
  4083.   cDelphiReRaise      = $0EEDFADF;
  4084.   cDelphiExcept       = $0EEDFAE0;
  4085.   cDelphiFinally      = $0EEDFAE1;
  4086.   cDelphiTerminate    = $0EEDFAE2;
  4087.   cDelphiUnhandled    = $0EEDFAE3;
  4088.   cNonDelphiException = $0EEDFAE4;
  4089.   cDelphiExitFinally  = $0EEDFAE5;
  4090.   cCppException       = $0EEFFACE; { used by BCB }
  4091.   EXCEPTION_CONTINUE_SEARCH    = 0;
  4092.   EXCEPTION_EXECUTE_HANDLER    = 1;
  4093.   EXCEPTION_CONTINUE_EXECUTION = -1;
  4094.  
  4095. type
  4096.   JmpInstruction =
  4097.   packed record
  4098.     opCode:   Byte;
  4099.     distance: Longint;
  4100.   end;
  4101.   TExcDescEntry =
  4102.   record
  4103.     vTable:  Pointer;
  4104.     handler: Pointer;
  4105.   end;
  4106.   PExcDesc = ^TExcDesc;
  4107.   TExcDesc =
  4108.   packed record
  4109.     jmp: JmpInstruction;
  4110.     case Integer of
  4111.     0:      (instructions: array [0..0] of Byte);
  4112.     1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry);
  4113.   end;
  4114.  
  4115.   PExcFrame = ^TExcFrame;
  4116.   TExcFrame =
  4117.   record
  4118.     next: PExcFrame;
  4119.     desc: PExcDesc;
  4120.     hEBP: Pointer;
  4121.     case Integer of
  4122.     0:  ( );
  4123.     1:  ( ConstructedObject: Pointer );
  4124.     2:  ( SelfOfMethod: Pointer );
  4125.   end;
  4126.  
  4127.   PExceptionRecord = ^TExceptionRecord;
  4128.   TExceptionRecord =
  4129.   record
  4130.     ExceptionCode        : LongWord;
  4131.     ExceptionFlags       : LongWord;
  4132.     OuterException       : PExceptionRecord;
  4133.     ExceptionAddress     : Pointer;
  4134.     NumberParameters     : Longint;
  4135.     case {IsOsException:} Boolean of
  4136.     True:  (ExceptionInformation : array [0..14] of Longint);
  4137.     False: (ExceptAddr: Pointer; ExceptObject: Pointer);
  4138.   end;
  4139.  
  4140.   PRaiseFrame = ^TRaiseFrame;
  4141.   TRaiseFrame = packed record
  4142.     NextRaise: PRaiseFrame;
  4143.     ExceptAddr: Pointer;
  4144.     ExceptObject: TObject;
  4145.     ExceptionRecord: PExceptionRecord;
  4146.   end;
  4147.  
  4148.  
  4149. procedure       _ClassCreate;
  4150. asm
  4151.         { ->    EAX = pointer to VMT      }
  4152.         { <-    EAX = pointer to instance }
  4153.         PUSH    EDX
  4154.         PUSH    ECX
  4155.         PUSH    EBX
  4156.         TEST    DL,DL
  4157.         JL      @@noAlloc
  4158.         CALL    dword ptr [EAX].vmtNewInstance
  4159. @@noAlloc:
  4160.         XOR     EDX,EDX
  4161.         LEA     ECX,[ESP+16]
  4162.         MOV     EBX,FS:[EDX]
  4163.         MOV     [ECX].TExcFrame.next,EBX
  4164.         MOV     [ECX].TExcFrame.hEBP,EBP
  4165.         MOV     [ECX].TExcFrame.desc,offset @desc
  4166.         MOV     [ECX].TexcFrame.ConstructedObject,EAX   { trick: remember copy to instance }
  4167.         MOV     FS:[EDX],ECX
  4168.         POP     EBX
  4169.         POP     ECX
  4170.         POP     EDX
  4171.         RET
  4172.  
  4173. @desc:
  4174.         JMP     _HandleAnyException
  4175.  
  4176.         {       destroy the object                                                      }
  4177.  
  4178.         MOV     EAX,[ESP+8+9*4]
  4179.         MOV     EAX,[EAX].TExcFrame.ConstructedObject
  4180.         TEST    EAX,EAX
  4181.         JE      @@skip
  4182.         MOV     ECX,[EAX]
  4183.         MOV     DL,$81
  4184.         PUSH    EAX
  4185.         CALL    dword ptr [ECX].vmtDestroy
  4186.         POP     EAX
  4187.         CALL    _ClassDestroy
  4188. @@skip:
  4189.         {       reraise the exception   }
  4190.         CALL    _RaiseAgain
  4191. end;
  4192.  
  4193.  
  4194. procedure       _ClassDestroy;
  4195. asm
  4196.         MOV     EDX,[EAX]
  4197.         CALL    dword ptr [EDX].vmtFreeInstance
  4198. end;
  4199.  
  4200.  
  4201. procedure _AfterConstruction;
  4202. asm
  4203.         { ->  EAX = pointer to instance }
  4204.  
  4205.         PUSH    EAX
  4206.         MOV     EDX,[EAX]
  4207.         CALL    dword ptr [EDX].vmtAfterConstruction
  4208.         POP     EAX
  4209. end;
  4210.  
  4211. procedure _BeforeDestruction;
  4212. asm
  4213.         { ->  EAX  = pointer to instance }
  4214.         {      DL  = dealloc flag        }
  4215.  
  4216.         TEST    DL,DL
  4217.         JG      @@outerMost
  4218.         RET
  4219. @@outerMost:
  4220.         PUSH    EAX
  4221.         PUSH    EDX
  4222.         MOV     EDX,[EAX]
  4223.         CALL    dword ptr [EDX].vmtBeforeDestruction
  4224.         POP     EDX
  4225.         POP     EAX
  4226. end;
  4227.  
  4228. {
  4229.   The following NotifyXXXX routines are used to "raise" special exceptions
  4230.   as a signaling mechanism to an interested debugger.  If the debugger sets
  4231.   the DebugHook flag to 1 or 2, then all exception processing is tracked by
  4232.   raising these special exceptions.  The debugger *MUST* respond to the
  4233.   debug event with DBG_CONTINE so that normal processing will occur.
  4234. }
  4235.  
  4236. { tell the debugger that the next raise is a re-raise of the current non-Delphi
  4237.   exception }
  4238. procedure       NotifyReRaise;
  4239. asm
  4240.         CMP     BYTE PTR DebugHook,1
  4241.         JBE     @@1
  4242.         PUSH    0
  4243.         PUSH    0
  4244.         PUSH    cContinuable
  4245.         PUSH    cDelphiReRaise
  4246.         CALL    RaiseException
  4247. @@1:
  4248. end;
  4249.  
  4250. { tell the debugger about the raise of a non-Delphi exception }
  4251. procedure       NotifyNonDelphiException;
  4252. asm
  4253.         CMP     BYTE PTR DebugHook,0
  4254.         JE      @@1
  4255.         PUSH    EAX
  4256.         PUSH    EAX
  4257.         PUSH    EDX
  4258.         PUSH    ESP
  4259.         PUSH    2
  4260.         PUSH    cContinuable
  4261.         PUSH    cNonDelphiException
  4262.         CALL    RaiseException
  4263.         ADD     ESP,8
  4264.         POP     EAX
  4265. @@1:
  4266. end;
  4267.  
  4268. { Tell the debugger where the handler for the current exception is located }
  4269. procedure       NotifyExcept;
  4270. asm
  4271.         PUSH    ESP
  4272.         PUSH    1
  4273.         PUSH    cContinuable
  4274.         PUSH    cDelphiExcept           { our magic exception code }
  4275.         CALL    RaiseException
  4276.         ADD     ESP,4
  4277.         POP     EAX
  4278. end;
  4279.  
  4280. procedure       NotifyOnExcept;
  4281. asm
  4282.         CMP     BYTE PTR DebugHook,1
  4283.         JBE     @@1
  4284.         PUSH    EAX
  4285.         PUSH    [EBX].TExcDescEntry.handler
  4286.         JMP     NotifyExcept
  4287. @@1:
  4288. end;
  4289.  
  4290. procedure       NotifyAnyExcept;
  4291. asm
  4292.         CMP     BYTE PTR DebugHook,1
  4293.         JBE     @@1
  4294.         PUSH    EAX
  4295.         PUSH    EBX
  4296.         JMP     NotifyExcept
  4297. @@1:
  4298. end;
  4299.  
  4300. procedure       CheckJmp;
  4301. asm
  4302.         TEST    ECX,ECX
  4303.         JE      @@3
  4304.         MOV     EAX,[ECX + 1]
  4305.         CMP     BYTE PTR [ECX],0E9H { near jmp }
  4306.         JE      @@1
  4307.         CMP     BYTE PTR [ECX],0EBH { short jmp }
  4308.         JNE     @@3
  4309.         MOVSX   EAX,AL
  4310.         INC     ECX
  4311.         INC     ECX
  4312.         JMP     @@2
  4313. @@1:
  4314.         ADD     ECX,5
  4315. @@2:
  4316.         ADD     ECX,EAX
  4317. @@3:
  4318. end;
  4319.  
  4320. { Notify debugger of a finally during an exception unwind }
  4321. procedure       NotifyExceptFinally;
  4322. asm
  4323.         CMP     BYTE PTR DebugHook,1
  4324.         JBE     @@1
  4325.         PUSH    EAX
  4326.         PUSH    EDX
  4327.         PUSH    ECX
  4328.         CALL    CheckJmp
  4329.         PUSH    ECX
  4330.         PUSH    ESP                     { pass pointer to arguments }
  4331.         PUSH    1                       { there is 1 argument }
  4332.         PUSH    cContinuable            { continuable execution }
  4333.         PUSH    cDelphiFinally          { our magic exception code }
  4334.         CALL    RaiseException
  4335.         POP     ECX
  4336.         POP     ECX
  4337.         POP     EDX
  4338.         POP     EAX
  4339. @@1:
  4340. end;
  4341.  
  4342.  
  4343. { Tell the debugger that the current exception is handled and cleaned up.
  4344.   Also indicate where execution is about to resume. }
  4345. procedure       NotifyTerminate;
  4346. asm
  4347.         CMP     BYTE PTR DebugHook,1
  4348.         JBE     @@1
  4349.         PUSH    EDX
  4350.         PUSH    ESP
  4351.         PUSH    1
  4352.         PUSH    cContinuable
  4353.         PUSH    cDelphiTerminate        { our magic exception code }
  4354.         CALL    RaiseException
  4355.         POP     EDX
  4356. @@1:
  4357. end;
  4358.  
  4359. { Tell the debugger that there was no handler found for the current execption
  4360.   and we are about to go to the default handler }
  4361. procedure       NotifyUnhandled;
  4362. asm
  4363.         PUSH    EAX
  4364.         PUSH    EDX
  4365.         CMP     BYTE PTR DebugHook,1
  4366.         JBE     @@1
  4367.         PUSH    ESP
  4368.         PUSH    2
  4369.         PUSH    cContinuable
  4370.         PUSH    cDelphiUnhandled
  4371.         CALL    RaiseException
  4372. @@1:
  4373.         POP     EDX
  4374.         POP     EAX
  4375. end;
  4376.  
  4377.  
  4378. procedure       _HandleAnyException;
  4379. asm
  4380.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4381.         {       [ESP+ 8] errPtr: PExcFrame              }
  4382.         {       [ESP+12] ctxPtr: Pointer                }
  4383.         {       [ESP+16] dspPtr: Pointer                }
  4384.         { <-    EAX return value - always one   }
  4385.  
  4386.         MOV     EAX,[ESP+4]
  4387.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4388.         JNE     @@exit
  4389.  
  4390.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4391.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4392.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4393.         JE      @@DelphiException
  4394.         CLD
  4395.         CALL    _FpuInit
  4396.         MOV     EDX,ExceptObjProc
  4397.         TEST    EDX,EDX
  4398.         JE      @@exit
  4399.         CALL    EDX
  4400.         TEST    EAX,EAX
  4401.         JE      @@exit
  4402.         MOV     EDX,[ESP+12]
  4403.         MOV     ECX,[ESP+4]
  4404.         CMP     [ECX].TExceptionRecord.ExceptionCode,cCppException
  4405.         JE      @@CppException
  4406.         CALL    NotifyNonDelphiException
  4407.         CMP     BYTE PTR JITEnable,0
  4408.         JBE     @@CppException
  4409.         CMP     BYTE PTR DebugHook,0
  4410.         JA      @@CppException                     { Do not JIT if debugging }
  4411.         LEA     ECX,[ESP+4]
  4412.         PUSH    EAX
  4413.         PUSH    ECX
  4414.         CALL    UnhandledExceptionFilter
  4415.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  4416.         POP     EAX
  4417.         JE      @@exit
  4418.         MOV     EDX,EAX
  4419.         MOV     EAX,[ESP+4]
  4420.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  4421.         JMP     @@GoUnwind
  4422.  
  4423. @@CppException:
  4424.         MOV     EDX,EAX
  4425.         MOV     EAX,[ESP+4]
  4426.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  4427.  
  4428. @@DelphiException:
  4429.         CMP     BYTE PTR JITEnable,1
  4430.         JBE     @@GoUnwind
  4431.         CMP     BYTE PTR DebugHook,0                { Do not JIT if debugging }
  4432.         JA      @@GoUnwind
  4433.         PUSH    EAX
  4434.         LEA     EAX,[ESP+8]
  4435.         PUSH    EDX
  4436.         PUSH    ECX
  4437.         PUSH    EAX
  4438.         CALL    UnhandledExceptionFilter
  4439.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  4440.         POP     ECX
  4441.         POP     EDX
  4442.         POP     EAX
  4443.         JE      @@exit
  4444.  
  4445. @@GoUnwind:
  4446.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  4447.  
  4448.         PUSH    EBX
  4449.         XOR     EBX,EBX
  4450.         PUSH    ESI
  4451.         PUSH    EDI
  4452.         PUSH    EBP
  4453.  
  4454.         MOV     EBX,FS:[EBX]
  4455.         PUSH    EBX                     { Save pointer to topmost frame }
  4456.         PUSH    EAX                     { Save OS exception pointer     }
  4457.         PUSH    EDX                     { Save exception object         }
  4458.         PUSH    ECX                     { Save exception address        }
  4459.  
  4460.         MOV     EDX,[ESP+8+8*4]
  4461.  
  4462.         PUSH    0
  4463.         PUSH    EAX
  4464.         PUSH    offset @@returnAddress
  4465.         PUSH    EDX
  4466.         CALL    RtlUnwind
  4467. @@returnAddress:
  4468.  
  4469.         MOV     EDI,[ESP+8+8*4]
  4470.  
  4471.         {       Make the RaiseList entry on the stack }
  4472.  
  4473.         CALL    SysInit.@GetTLS
  4474.         PUSH    [EAX].RaiseListPtr
  4475.         MOV     [EAX].RaiseListPtr,ESP
  4476.  
  4477.         MOV     EBP,[EDI].TExcFrame.hEBP
  4478.         MOV     EBX,[EDI].TExcFrame.desc
  4479.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  4480.  
  4481.         ADD     EBX,TExcDesc.instructions
  4482.         CALL    NotifyAnyExcept
  4483.         JMP     EBX
  4484.  
  4485. @@exceptFinally:
  4486.         JMP     _HandleFinally
  4487.  
  4488. @@destroyExcept:
  4489.         {       we come here if an exception handler has thrown yet another exception }
  4490.         {       we need to destroy the exception object and pop the raise list. }
  4491.  
  4492.         CALL    SysInit.@GetTLS
  4493.         MOV     ECX,[EAX].RaiseListPtr
  4494.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  4495.         MOV     [EAX].RaiseListPtr,EDX
  4496.  
  4497.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  4498.         JMP     TObject.Free
  4499.  
  4500. @@exit:
  4501.         MOV     EAX,1
  4502. end;
  4503.  
  4504.  
  4505. procedure       _HandleOnException;
  4506. asm
  4507.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4508.         {       [ESP+ 8] errPtr: PExcFrame              }
  4509.         {       [ESP+12] ctxPtr: Pointer                }
  4510.         {       [ESP+16] dspPtr: Pointer                }
  4511.         { <-    EAX return value - always one   }
  4512.  
  4513.         MOV     EAX,[ESP+4]
  4514.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4515.         JNE     @@exit
  4516.  
  4517.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4518.         JE      @@DelphiException
  4519.         CLD
  4520.         CALL    _FpuInit
  4521.         MOV     EDX,ExceptClsProc
  4522.         TEST    EDX,EDX
  4523.         JE      @@exit
  4524.         CALL    EDX
  4525.         TEST    EAX,EAX
  4526.         JNE     @@common
  4527.         JMP     @@exit
  4528.  
  4529. @@DelphiException:
  4530.         MOV     EAX,[EAX].TExceptionRecord.ExceptObject
  4531.         MOV     EAX,[EAX]                       { load vtable of exception object       }
  4532.  
  4533. @@common:
  4534.  
  4535.         MOV     EDX,[ESP+8]
  4536.  
  4537.         PUSH    EBX
  4538.         PUSH    ESI
  4539.         PUSH    EDI
  4540.         PUSH    EBP
  4541.  
  4542.         MOV     ECX,[EDX].TExcFrame.desc
  4543.         MOV     EBX,[ECX].TExcDesc.cnt
  4544.         LEA     ESI,[ECX].TExcDesc.excTab       { point ECX to exc descriptor table }
  4545.         MOV     EBP,EAX                         { load vtable of exception object }
  4546.  
  4547. @@innerLoop:
  4548.         MOV     EAX,[ESI].TExcDescEntry.vTable
  4549.         TEST    EAX,EAX                         { catch all clause?                     }
  4550.         JE      @@doHandler                     { yes: go execute handler               }
  4551.         MOV     EDI,EBP                         { load vtable of exception object       }
  4552.         JMP     @@haveVMT
  4553.  
  4554. @@vtLoop:
  4555.         MOV     EDI,[EDI]
  4556. @@haveVMT:
  4557.         MOV     EAX,[EAX]
  4558.         CMP     EAX,EDI
  4559.         JE      @@doHandler
  4560.  
  4561.         MOV     ECX,[EAX].vmtInstanceSize
  4562.         CMP     ECX,[EDI].vmtInstanceSize
  4563.         JNE     @@parent
  4564.  
  4565.         MOV     EAX,[EAX].vmtClassName
  4566.         MOV     EDX,[EDI].vmtClassName
  4567.  
  4568.         XOR     ECX,ECX
  4569.         MOV     CL,[EAX]
  4570.         CMP     CL,[EDX]
  4571.         JNE     @@parent
  4572.  
  4573.         INC     EAX
  4574.         INC     EDX
  4575.         CALL    _AStrCmp
  4576.         JE      @@doHandler
  4577.  
  4578. @@parent:
  4579.         MOV     EDI,[EDI].vmtParent             { load vtable of parent         }
  4580.         MOV     EAX,[ESI].TExcDescEntry.vTable
  4581.         TEST    EDI,EDI
  4582.         JNE     @@vtLoop
  4583.  
  4584.         ADD     ESI,8
  4585.         DEC     EBX
  4586.         JNZ     @@innerLoop
  4587.  
  4588.         POP     EBP
  4589.         POP     EDI
  4590.         POP     ESI
  4591.         POP     EBX
  4592.         JMP     @@exit
  4593.  
  4594. @@doHandler:
  4595.         MOV     EAX,[ESP+4+4*4]
  4596.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4597.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4598.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4599.         JE      @@haveObject
  4600.         CALL    ExceptObjProc
  4601.         MOV     EDX,[ESP+12+4*4]
  4602.         CALL    NotifyNonDelphiException
  4603.         CMP     BYTE PTR JITEnable,0
  4604.         JBE     @@NoJIT
  4605.         CMP     BYTE PTR DebugHook,0
  4606.         JA      @@noJIT                 { Do not JIT if debugging }
  4607.         LEA     ECX,[ESP+4]
  4608.         PUSH    EAX
  4609.         PUSH    ECX
  4610.         CALL    UnhandledExceptionFilter
  4611.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  4612.         POP     EAX
  4613.         JE      @@exit
  4614. @@noJIT:
  4615.         MOV     EDX,EAX
  4616.         MOV     EAX,[ESP+4+4*4]
  4617.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  4618.         JMP     @@GoUnwind
  4619.  
  4620. @@haveObject:
  4621.         CMP     BYTE PTR JITEnable,1
  4622.         JBE     @@GoUnwind
  4623.         CMP     BYTE PTR DebugHook,0
  4624.         JA      @@GoUnwind
  4625.         PUSH    EAX
  4626.         LEA     EAX,[ESP+8]
  4627.         PUSH    EDX
  4628.         PUSH    ECX
  4629.         PUSH    EAX
  4630.         CALL    UnhandledExceptionFilter
  4631.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  4632.         POP     ECX
  4633.         POP     EDX
  4634.         POP     EAX
  4635.         JE      @@exit
  4636.  
  4637. @@GoUnwind:
  4638.         XOR     EBX,EBX
  4639.         MOV     EBX,FS:[EBX]
  4640.         PUSH    EBX                     { Save topmost frame     }
  4641.         PUSH    EAX                     { Save exception record  }
  4642.         PUSH    EDX                     { Save exception object  }
  4643.         PUSH    ECX                     { Save exception address }
  4644.  
  4645.         MOV     EDX,[ESP+8+8*4]
  4646.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  4647.  
  4648.         PUSH    ESI                     { Save handler entry     }
  4649.  
  4650.         PUSH    0
  4651.         PUSH    EAX
  4652.         PUSH    offset @@returnAddress
  4653.         PUSH    EDX
  4654.         CALL    RtlUnwind
  4655. @@returnAddress:
  4656.  
  4657.         POP     EBX                     { Restore handler entry  }
  4658.  
  4659.         MOV     EDI,[ESP+8+8*4]
  4660.  
  4661.         {       Make the RaiseList entry on the stack }
  4662.  
  4663.         CALL    SysInit.@GetTLS
  4664.         PUSH    [EAX].RaiseListPtr
  4665.         MOV     [EAX].RaiseListPtr,ESP
  4666.  
  4667.         MOV     EBP,[EDI].TExcFrame.hEBP
  4668.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  4669.         MOV     EAX,[ESP].TRaiseFrame.ExceptObject
  4670.         CALL    NotifyOnExcept
  4671.         JMP     [EBX].TExcDescEntry.handler
  4672.  
  4673. @@exceptFinally:
  4674.         JMP     _HandleFinally
  4675.  
  4676. @@destroyExcept:
  4677.         {       we come here if an exception handler has thrown yet another exception }
  4678.         {       we need to destroy the exception object and pop the raise list. }
  4679.  
  4680.         CALL    SysInit.@GetTLS
  4681.         MOV     ECX,[EAX].RaiseListPtr
  4682.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  4683.         MOV     [EAX].RaiseListPtr,EDX
  4684.  
  4685.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  4686.         JMP     TObject.Free
  4687. @@exit:
  4688.         MOV     EAX,1
  4689. end;
  4690.  
  4691.  
  4692. procedure       _HandleFinally;
  4693. asm
  4694.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4695.         {       [ESP+ 8] errPtr: PExcFrame              }
  4696.         {       [ESP+12] ctxPtr: Pointer                }
  4697.         {       [ESP+16] dspPtr: Pointer                }
  4698.         { <-    EAX return value - always one   }
  4699.  
  4700.         MOV     EAX,[ESP+4]
  4701.         MOV     EDX,[ESP+8]
  4702.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4703.         JE      @@exit
  4704.         MOV     ECX,[EDX].TExcFrame.desc
  4705.         MOV     [EDX].TExcFrame.desc,offset @@exit
  4706.  
  4707.         PUSH    EBX
  4708.         PUSH    ESI
  4709.         PUSH    EDI
  4710.         PUSH    EBP
  4711.  
  4712.         MOV     EBP,[EDX].TExcFrame.hEBP
  4713.         ADD     ECX,TExcDesc.instructions
  4714.         CALL    NotifyExceptFinally
  4715.         CALL    ECX
  4716.  
  4717.         POP     EBP
  4718.         POP     EDI
  4719.         POP     ESI
  4720.         POP     EBX
  4721.  
  4722. @@exit:
  4723.         MOV     EAX,1
  4724. end;
  4725.  
  4726.  
  4727. procedure       _HandleAutoException;
  4728. asm
  4729.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4730.         {       [ESP+ 8] errPtr: PExcFrame              }
  4731.         {       [ESP+12] ctxPtr: Pointer                }
  4732.         {       [ESP+16] dspPtr: Pointer                }
  4733.         { <-    EAX return value - always one           }
  4734.  
  4735.         MOV     EAX,[ESP+4]
  4736.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4737.         JNE     @@exit
  4738.  
  4739.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4740.         CLD
  4741.         CALL    _FpuInit
  4742.         JE      @@DelphiException
  4743.         CMP     BYTE PTR JITEnable,0
  4744.         JBE     @@DelphiException
  4745.         CMP     BYTE PTR DebugHook,0
  4746.         JA      @@DelphiException
  4747.  
  4748. @@DoUnhandled:
  4749.         LEA     EAX,[ESP+4]
  4750.         PUSH    EAX
  4751.         CALL    UnhandledExceptionFilter
  4752.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  4753.         JE      @@exit
  4754.         MOV     EAX,[ESP+4]
  4755.         JMP     @@GoUnwind
  4756.  
  4757. @@DelphiException:
  4758.         CMP     BYTE PTR JITEnable,1
  4759.         JBE     @@GoUnwind
  4760.         CMP     BYTE PTR DebugHook,0
  4761.         JA      @@GoUnwind
  4762.         JMP     @@DoUnhandled
  4763.  
  4764. @@GoUnwind:
  4765.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  4766.  
  4767.         PUSH    ESI
  4768.         PUSH    EDI
  4769.         PUSH    EBP
  4770.  
  4771.         MOV     EDX,[ESP+8+3*4]
  4772.  
  4773.         PUSH    0
  4774.         PUSH    EAX
  4775.         PUSH    offset @@returnAddress
  4776.         PUSH    EDX
  4777.         CALL    RtlUnwind
  4778.  
  4779. @@returnAddress:
  4780.         POP     EBP
  4781.         POP     EDI
  4782.         POP     ESI
  4783.         MOV     EAX,[ESP+4]
  4784.         MOV     EBX,8000FFFFH
  4785.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4786.         JNE     @@done
  4787.  
  4788.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4789.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4790.         MOV     EAX,[ESP+8]
  4791.         MOV     EAX,[EAX].TExcFrame.SelfOfMethod
  4792.         MOV     EBX,[EAX]
  4793.         CALL    [EBX].vmtSafeCallException.Pointer
  4794.         MOV     EBX,EAX
  4795.         MOV     EAX,[ESP+4]
  4796.         MOV     EAX,[EAX].TExceptionRecord.ExceptObject
  4797.         CALL    TObject.Free
  4798. @@done:
  4799.         XOR     EAX,EAX
  4800.         MOV     ESP,[ESP+8]
  4801.         POP     ECX
  4802.         MOV     FS:[EAX],ECX
  4803.         POP     EDX
  4804.         POP     EBP
  4805.         LEA     EDX,[EDX].TExcDesc.instructions
  4806.         POP     ECX
  4807.         JMP     EDX
  4808. @@exit:
  4809.         MOV     EAX,1
  4810. end;
  4811.  
  4812.  
  4813. procedure       _RaiseExcept;
  4814. asm
  4815.         { When making changes to the way Delphi Exceptions are raised, }
  4816.         { please realize that the C++ Exception handling code reraises }
  4817.         { some exceptions as Delphi Exceptions.  Of course we want to  }
  4818.         { keep exception raising compatible between Delphi and C++, so }
  4819.         { when you make changes here, consult with the relevant C++    }
  4820.         { exception handling engineer. The C++ code is in xx.cpp, in   }
  4821.         { the RTL sources, in function tossAnException.                }
  4822.  
  4823.         { ->    EAX     Pointer to exception object     }
  4824.         {       [ESP]   Error address           }
  4825.  
  4826.         POP     EDX
  4827.  
  4828.         PUSH    ESP
  4829.         PUSH    EBP
  4830.         PUSH    EDI
  4831.         PUSH    ESI
  4832.         PUSH    EBX
  4833.         PUSH    EAX                             { pass class argument           }
  4834.         PUSH    EDX                             { pass address argument         }
  4835.  
  4836.         PUSH    ESP                             { pass pointer to arguments             }
  4837.         PUSH    7                               { there are seven arguments               }
  4838.         PUSH    cNonContinuable                 { we can't continue execution   }
  4839.         PUSH    cDelphiException                { our magic exception code              }
  4840.         PUSH    EDX                             { pass the user's return address        }
  4841.         JMP     RaiseException
  4842. end;
  4843.  
  4844.  
  4845. procedure       _RaiseAgain;
  4846. asm
  4847.         { ->    [ESP        ] return address to user program }
  4848.         {       [ESP+ 4     ] raise list entry (4 dwords)    }
  4849.         {       [ESP+ 4+ 4*4] saved topmost frame            }
  4850.         {       [ESP+ 4+ 5*4] saved registers (4 dwords)     }
  4851.         {       [ESP+ 4+ 9*4] return address to OS           }
  4852.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4853.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4854.  
  4855.         { Point the error handler of the exception frame to something harmless }
  4856.  
  4857.         MOV     EAX,[ESP+8+10*4]
  4858.         MOV     [EAX].TExcFrame.desc,offset @@exit
  4859.  
  4860.         { Pop the RaiseList }
  4861.  
  4862.         CALL    SysInit.@GetTLS
  4863.         MOV     EDX,[EAX].RaiseListPtr
  4864.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4865.         MOV     [EAX].RaiseListPtr,ECX
  4866.  
  4867.         { Destroy any objects created for non-delphi exceptions }
  4868.  
  4869.         MOV     EAX,[EDX].TRaiseFrame.ExceptionRecord
  4870.         AND     [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
  4871.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4872.         JE      @@delphiException
  4873.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4874.         CALL    TObject.Free
  4875.         CALL    NotifyReRaise
  4876.  
  4877. @@delphiException:
  4878.  
  4879.         XOR     EAX,EAX
  4880.         ADD     ESP,5*4
  4881.         MOV     EDX,FS:[EAX]
  4882.         POP     ECX
  4883.         MOV     EDX,[EDX].TExcFrame.next
  4884.         MOV     [ECX].TExcFrame.next,EDX
  4885.  
  4886.         POP     EBP
  4887.         POP     EDI
  4888.         POP     ESI
  4889.         POP     EBX
  4890. @@exit:
  4891.         MOV     EAX,1
  4892. end;
  4893.  
  4894.  
  4895. procedure       _DoneExcept;
  4896. asm
  4897.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4898.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4899.  
  4900.         { Pop the RaiseList }
  4901.  
  4902.         CALL    SysInit.@GetTLS
  4903.         MOV     EDX,[EAX].RaiseListPtr
  4904.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4905.         MOV     [EAX].RaiseListPtr,ECX
  4906.  
  4907.         { Destroy exception object }
  4908.  
  4909.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4910.         CALL    TObject.Free
  4911.  
  4912.         POP     EDX
  4913.         MOV     ESP,[ESP+8+9*4]
  4914.         XOR     EAX,EAX
  4915.         POP     ECX
  4916.         MOV     FS:[EAX],ECX
  4917.         POP     EAX
  4918.         POP     EBP
  4919.         CALL    NotifyTerminate
  4920.         JMP     EDX
  4921. end;
  4922.  
  4923.  
  4924. procedure   _TryFinallyExit;
  4925. asm
  4926.         XOR     EDX,EDX
  4927.         MOV     ECX,[ESP+4].TExcFrame.desc
  4928.         MOV     EAX,[ESP+4].TExcFrame.next
  4929.         ADD     ECX,TExcDesc.instructions
  4930.         MOV     FS:[EDX],EAX
  4931.         CALL    ECX
  4932. @@1:    RET     12
  4933. end;
  4934.  
  4935.  
  4936. type
  4937.   PInitContext = ^TInitContext;
  4938.   TInitContext = record
  4939.     OuterContext:   PInitContext;     { saved InitContext   }
  4940.     ExcFrame:       PExcFrame;        { bottom exc handler  }
  4941.     InitTable:      PackageInfo;      { unit init info      }
  4942.     InitCount:      Integer;          { how far we got      }
  4943.     Module:         PLibModule;       { ptr to module desc  }
  4944.     DLLSaveEBP:     Pointer;          { saved regs for DLLs }
  4945.     DLLSaveEBX:     Pointer;          { saved regs for DLLs }
  4946.     DLLSaveESI:     Pointer;          { saved regs for DLLs }
  4947.     DLLSaveEDI:     Pointer;          { saved regs for DLLs }
  4948.     DLLInitState:   Byte;
  4949.     ExitProcessTLS: procedure;        { Shutdown for TLS    }
  4950.   end;
  4951.  
  4952. var
  4953.   InitContext: TInitContext;
  4954.  
  4955.  
  4956. procedure       RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
  4957. asm
  4958.         MOV     [ESP],ErrorAddr
  4959.         JMP     _RunError
  4960. end;
  4961.  
  4962. procedure       MapToRunError(P: PExceptionRecord); stdcall;
  4963. const
  4964.   STATUS_ACCESS_VIOLATION         = $C0000005;
  4965.   STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
  4966.   STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
  4967.   STATUS_FLOAT_DIVIDE_BY_ZERO     = $C000008E;
  4968.   STATUS_FLOAT_INEXACT_RESULT     = $C000008F;
  4969.   STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
  4970.   STATUS_FLOAT_OVERFLOW           = $C0000091;
  4971.   STATUS_FLOAT_STACK_CHECK        = $C0000092;
  4972.   STATUS_FLOAT_UNDERFLOW          = $C0000093;
  4973.   STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
  4974.   STATUS_INTEGER_OVERFLOW         = $C0000095;
  4975.   STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
  4976.   STATUS_STACK_OVERFLOW           = $C00000FD;
  4977.   STATUS_CONTROL_C_EXIT           = $C000013A;
  4978. var
  4979.   ErrCode: Byte;
  4980. begin
  4981.   case P.ExceptionCode of
  4982.     STATUS_INTEGER_DIVIDE_BY_ZERO:  ErrCode := 200;
  4983.     STATUS_ARRAY_BOUNDS_EXCEEDED:   ErrCode := 201;
  4984.     STATUS_FLOAT_OVERFLOW:          ErrCode := 205;
  4985.     STATUS_FLOAT_INEXACT_RESULT,
  4986.     STATUS_FLOAT_INVALID_OPERATION,
  4987.     STATUS_FLOAT_STACK_CHECK:       ErrCode := 207;
  4988.     STATUS_FLOAT_DIVIDE_BY_ZERO:    ErrCode := 200;
  4989.     STATUS_INTEGER_OVERFLOW:        ErrCode := 215;
  4990.     STATUS_FLOAT_UNDERFLOW,
  4991.     STATUS_FLOAT_DENORMAL_OPERAND:  ErrCode := 206;
  4992.     STATUS_ACCESS_VIOLATION:        ErrCode := 216;
  4993.     STATUS_PRIVILEGED_INSTRUCTION:  ErrCode := 218;
  4994.     STATUS_CONTROL_C_EXIT:          ErrCode := 217;
  4995.     STATUS_STACK_OVERFLOW:          ErrCode := 202;
  4996.   else                              ErrCode := 255;
  4997.   end;
  4998.   RunErrorAt(ErrCode, P.ExceptionAddress);
  4999. end;
  5000.  
  5001. procedure       _ExceptionHandler;
  5002. asm
  5003.         MOV     EAX,[ESP+4]
  5004.  
  5005.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  5006.         JNE     @@exit
  5007.         CMP     BYTE PTR DebugHook,0
  5008.         JA      @@ExecuteHandler
  5009.         LEA     EAX,[ESP+4]
  5010.         PUSH    EAX
  5011.         CALL    UnhandledExceptionFilter
  5012.         CMP     EAX,EXCEPTION_CONTINUE_SEARCH
  5013.         JNE     @@ExecuteHandler
  5014.         JMP     @@exit
  5015. //        MOV     EAX,1
  5016. //        RET
  5017.  
  5018. @@ExecuteHandler:
  5019.         MOV     EAX,[ESP+4]
  5020.         CLD
  5021.         CALL    _FpuInit
  5022.         MOV     EDX,[ESP+8]
  5023.  
  5024.         PUSH    0
  5025.         PUSH    EAX
  5026.         PUSH    offset @@returnAddress
  5027.         PUSH    EDX
  5028.         CALL    RtlUnwind
  5029. @@returnAddress:
  5030.  
  5031.         MOV     EBX,[ESP+4]
  5032.         CMP     [EBX].TExceptionRecord.ExceptionCode,cDelphiException
  5033.         MOV     EDX,[EBX].TExceptionRecord.ExceptAddr
  5034.         MOV     EAX,[EBX].TExceptionRecord.ExceptObject
  5035.         JE      @@DelphiException2
  5036.  
  5037.         MOV     EDX,ExceptObjProc
  5038.         TEST    EDX,EDX
  5039.         JE      MapToRunError
  5040.         MOV     EAX,EBX
  5041.         CALL    EDX
  5042.         TEST    EAX,EAX
  5043.         JE      MapToRunError
  5044.         MOV     EDX,[EBX].TExceptionRecord.ExceptionAddress
  5045.  
  5046. @@DelphiException2:
  5047.  
  5048.         CALL    NotifyUnhandled
  5049.         MOV     ECX,ExceptProc
  5050.         TEST    ECX,ECX
  5051.         JE      @@noExceptProc
  5052.         CALL    ECX             { call ExceptProc(ExceptObject, ExceptAddr) }
  5053.  
  5054. @@noExceptProc:
  5055.         MOV     ECX,[ESP+4]
  5056.         MOV     EAX,217
  5057.         MOV     EDX,[ECX].TExceptionRecord.ExceptAddr
  5058.         MOV     [ESP],EDX
  5059.         JMP     _RunError
  5060.  
  5061. @@exit:
  5062.         XOR     EAX,EAX
  5063. end;
  5064.  
  5065.  
  5066. procedure       SetExceptionHandler;
  5067. asm
  5068.         XOR     EDX,EDX                 { using [EDX] saves some space over [0] }
  5069.         LEA     EAX,[EBP-12]
  5070.         MOV     ECX,FS:[EDX]            { ECX := head of chain                  }
  5071.         MOV     FS:[EDX],EAX            { head of chain := @exRegRec            }
  5072.  
  5073.         MOV     [EAX].TExcFrame.next,ECX
  5074.         MOV     [EAX].TExcFrame.desc,offset _ExceptionHandler
  5075.         MOV     [EAX].TExcFrame.hEBP,EBP
  5076.         MOV     InitContext.ExcFrame,EAX
  5077. end;
  5078.  
  5079.  
  5080. procedure       UnsetExceptionHandler;
  5081. asm
  5082.         XOR     EDX,EDX
  5083.         MOV     EAX,InitContext.ExcFrame
  5084.         MOV     ECX,FS:[EDX]    { ECX := head of chain          }
  5085.         CMP     EAX,ECX         { simple case: our record is first      }
  5086.         JNE     @@search
  5087.         MOV     EAX,[EAX]       { head of chain := exRegRec.next        }
  5088.         MOV     FS:[EDX],EAX
  5089.         JMP     @@exit
  5090.  
  5091. @@loop:
  5092.         MOV     ECX,[ECX]
  5093. @@search:
  5094.         CMP     ECX,-1          { at end of list?                       }
  5095.         JE      @@exit          { yes - didn't find it          }
  5096.         CMP     [ECX],EAX       { is it the next one on the list?       }
  5097.         JNE     @@loop          { no - look at next one on list }
  5098. @@unlink:                       { yes - unlink our record               }
  5099.         MOV     EAX,[EAX]       { get next record on list               }
  5100.         MOV     [ECX],EAX       { unlink our record                     }
  5101. @@exit:
  5102. end;
  5103.  
  5104.  
  5105. procedure FInitUnits;
  5106. var
  5107.   Count: Integer;
  5108.   Table: PUnitEntryTable;
  5109.   P: procedure;
  5110. begin
  5111.   if InitContext.InitTable = nil then
  5112.         exit;
  5113.   Count := InitContext.InitCount;
  5114.   Table := InitContext.InitTable^.UnitInfo;
  5115.   try
  5116.     while Count > 0 do
  5117.     begin
  5118.       Dec(Count);
  5119.       InitContext.InitCount := Count;
  5120.       P := Table^[Count].FInit;
  5121.       if Assigned(P) then
  5122.         P;
  5123.     end;
  5124.   except
  5125.     FInitUnits;  { try to finalize the others }
  5126.     raise;
  5127.   end;
  5128. end;
  5129.  
  5130.  
  5131. procedure InitUnits;
  5132. var
  5133.   Count, I: Integer;
  5134.   Table: PUnitEntryTable;
  5135.   P: procedure;
  5136. begin
  5137.   if InitContext.InitTable = nil then
  5138.     exit;
  5139.   Count := InitContext.InitTable^.UnitCount;
  5140.   I := 0;
  5141.   Table := InitContext.InitTable^.UnitInfo;
  5142.   try
  5143.     while I < Count do
  5144.     begin
  5145.       P := Table^[I].Init;
  5146.       Inc(I);
  5147.       InitContext.InitCount := I;
  5148.       if Assigned(P) then
  5149.         P;
  5150.     end;
  5151.   except
  5152.     FInitUnits;
  5153.     raise;
  5154.   end;
  5155. end;
  5156.  
  5157.  
  5158. procedure _PackageLoad(const Table : PackageInfo);
  5159. var
  5160.   SavedContext: TInitContext;
  5161. begin
  5162.   SavedContext := InitContext;
  5163.   InitContext.DLLInitState := 0;
  5164.   InitContext.InitTable := Table;
  5165.   InitContext.InitCount := 0;
  5166.   InitContext.OuterContext := @SavedContext;
  5167.   try
  5168.     InitUnits;
  5169.   finally
  5170.     InitContext := SavedContext;
  5171.   end;
  5172. end;
  5173.  
  5174.  
  5175. procedure _PackageUnload(const Table : PackageInfo);
  5176. var
  5177.   SavedContext: TInitContext;
  5178. begin
  5179.   SavedContext := InitContext;
  5180.   InitContext.DLLInitState := 0;
  5181.   InitContext.InitTable := Table;
  5182.   InitContext.InitCount := Table^.UnitCount;
  5183.   InitContext.OuterContext := @SavedContext;
  5184.   try
  5185.   FInitUnits;
  5186.   finally
  5187.   InitContext := SavedContext;
  5188.   end;
  5189. end;
  5190.  
  5191.  
  5192. procedure       _StartExe;
  5193. asm
  5194.         { ->    EAX InitTable   }
  5195.         {       EDX Module      }
  5196.         MOV     InitContext.InitTable,EAX
  5197.         XOR     EAX,EAX
  5198.         MOV     InitContext.InitCount,EAX
  5199.         MOV     InitContext.Module,EDX
  5200.         MOV     EAX,[EDX].TLibModule.Instance
  5201.         MOV     MainInstance,EAX
  5202.  
  5203.         CALL    SetExceptionHandler
  5204.  
  5205.         MOV     IsLibrary,0
  5206.  
  5207.         CALL    InitUnits;
  5208. end;
  5209.  
  5210.  
  5211. procedure       _StartLib;
  5212. asm
  5213.         { ->    EAX InitTable   }
  5214.         {       EDX Module      }
  5215.         {       ECX InitTLS     }
  5216.         {       [ESP+4] DllProc }
  5217.         {       [EBP+8] HInst   }
  5218.         {       [EBP+12] Reason }
  5219.  
  5220.         { Push some desperately needed registers }
  5221.  
  5222.         PUSH    ECX
  5223.         PUSH    ESI
  5224.         PUSH    EDI
  5225.  
  5226.         { Save the current init context into the stackframe of our caller }
  5227.  
  5228.         MOV     ESI,offset InitContext
  5229.         LEA     EDI,[EBP- (type TExcFrame) - (type TInitContext)]
  5230.         MOV     ECX,(type TInitContext)/4
  5231.         REP     MOVSD
  5232.  
  5233.         { Setup the current InitContext }
  5234.  
  5235.         POP     InitContext.DLLSaveEDI
  5236.         POP     InitContext.DLLSaveESI
  5237.         MOV     InitContext.DLLSaveEBP,EBP
  5238.         MOV     InitContext.DLLSaveEBX,EBX
  5239.         MOV     InitContext.InitTable,EAX
  5240.         MOV     InitContext.Module,EDX
  5241.         LEA     ECX,[EBP- (type TExcFrame) - (type TInitContext)]
  5242.         MOV     InitContext.OuterContext,ECX
  5243.         XOR     ECX,ECX
  5244.         CMP     dword ptr [EBP+12],0
  5245.         JNE     @@notShutDown
  5246.         MOV     ECX,[EAX].PackageInfoTable.UnitCount
  5247. @@notShutDown:
  5248.         MOV     InitContext.InitCount,ECX
  5249.  
  5250.         CALL    SetExceptionHandler
  5251.  
  5252.         MOV     EAX,[EBP+12]
  5253.         INC     EAX
  5254.         MOV     InitContext.DLLInitState,AL
  5255.         DEC     EAX
  5256.  
  5257.         { Init any needed TLS }
  5258.  
  5259.         POP     ECX
  5260.         MOV     EDX,[ECX]
  5261.         MOV     InitContext.ExitProcessTLS,EDX
  5262.         JE      @@noTLSproc
  5263.         CALL    dword ptr [ECX+EAX*4]
  5264. @@noTLSproc:
  5265.  
  5266.         { Call any DllProc }
  5267.  
  5268.         MOV     EDX,[ESP+4]
  5269.         TEST    EDX,EDX
  5270.         JE      @@noDllProc
  5271.         MOV     EAX,[EBP+12]
  5272.         CALL    EDX
  5273. @@noDllProc:
  5274.  
  5275.         { Set IsLibrary if there was no exe yet }
  5276.  
  5277.         CMP     MainInstance,0
  5278.         JNE     @@haveExe
  5279.         MOV     IsLibrary,1
  5280.         FNSTCW  Default8087CW   // save host exe's FPU preferences
  5281.  
  5282. @@haveExe:
  5283.  
  5284.         MOV     EAX,[EBP+12]
  5285.         DEC     EAX
  5286.         JNE     _Halt0
  5287.         CALL    InitUnits
  5288.         RET     4
  5289. end;
  5290.  
  5291.  
  5292. procedure _InitResStrings;
  5293. asm
  5294.         { ->    EAX     Pointer to init table               }
  5295.         {                 record                            }
  5296.         {                   cnt: Integer;                   }
  5297.         {                   tab: array [1..cnt] record      }
  5298.         {                      variableAddress: Pointer;    }
  5299.         {                      resStringAddress: Pointer;   }
  5300.         {                   end;                            }
  5301.         {                 end;                              }
  5302.  
  5303.         PUSH    EBX
  5304.         PUSH    ESI
  5305.         MOV     EBX,[EAX]
  5306.         LEA     ESI,[EAX+4]
  5307. @@loop:
  5308.         MOV     EAX,[ESI+4]   { load resStringAddress   }
  5309.         MOV     EDX,[ESI]         { load variableAddress    }
  5310.         CALL    LoadResString
  5311.         ADD     ESI,8
  5312.         DEC     EBX
  5313.         JNZ     @@loop
  5314.  
  5315.         POP     ESI
  5316.         POP     EBX
  5317. end;
  5318.  
  5319. procedure _InitResStringImports;
  5320. asm
  5321.         { ->    EAX     Pointer to init table               }
  5322.         {                 record                            }
  5323.         {                   cnt: Integer;                   }
  5324.         {                   tab: array [1..cnt] record      }
  5325.         {                      variableAddress: Pointer;    }
  5326.         {                      resStringAddress: ^Pointer;  }
  5327.         {                   end;                            }
  5328.         {                 end;                              }
  5329.  
  5330.         PUSH    EBX
  5331.         PUSH    ESI
  5332.         MOV     EBX,[EAX]
  5333.         LEA     ESI,[EAX+4]
  5334. @@loop:
  5335.         MOV     EAX,[ESI+4]     { load address of import    }
  5336.         MOV     EDX,[ESI]       { load address of variable  }
  5337.         MOV     EAX,[EAX]       { load contents of import   }
  5338.         CALL    LoadResString
  5339.         ADD     ESI,8
  5340.   DEC     EBX
  5341.   JNZ     @@loop
  5342.  
  5343.   POP     ESI
  5344.   POP     EBX
  5345. end;
  5346.  
  5347. procedure _InitImports;
  5348. asm
  5349.         { ->    EAX     Pointer to init table               }
  5350.         {                 record                            }
  5351.         {                   cnt: Integer;                   }
  5352.         {                   tab: array [1..cnt] record      }
  5353.         {                      variableAddress: Pointer;    }
  5354.         {                      sourceAddress: ^Pointer;     }
  5355.         {                      sourceOffset: Longint;       }
  5356.         {                   end;                            }
  5357.         {                 end;                              }
  5358.  
  5359.         PUSH    EBX
  5360.         PUSH    ESI
  5361.         MOV     EBX,[EAX]
  5362.         LEA     ESI,[EAX+4]
  5363. @@loop:
  5364.         MOV     EAX,[ESI+4]     { load address of import    }
  5365.         MOV     EDX,[ESI]       { load address of variable  }
  5366.         MOV     ECX,[ESI+8]     { load offset               }
  5367.         MOV     EAX,[EAX]       { load contents of import   }
  5368.         ADD     EAX,ECX         { calc address of variable  }
  5369.         MOV     [EDX],EAX       { store result              }
  5370.         ADD     ESI,12
  5371.         DEC     EBX
  5372.         JNZ     @@loop
  5373.  
  5374.         POP     ESI
  5375.         POP     EBX
  5376. end;
  5377.  
  5378. procedure _InitWideStrings;
  5379. asm
  5380.         { ->    EAX     Pointer to init table               }
  5381.         {                 record                            }
  5382.         {                   cnt: Integer;                   }
  5383.         {                   tab: array [1..cnt] record      }
  5384.         {                      variableAddress: Pointer;    }
  5385.         {                      stringAddress: ^Pointer;     }
  5386.         {                   end;                            }
  5387.         {                 end;                              }
  5388.  
  5389.         PUSH    EBX
  5390.         PUSH    ESI
  5391.         MOV     EBX,[EAX]
  5392.         LEA     ESI,[EAX+4]
  5393. @@loop:
  5394.   MOV     EDX,[ESI+4]     { load address of string    }
  5395.   MOV     EAX,[ESI]       { load address of variable  }
  5396.   CALL    _WStrAsg
  5397.   ADD     ESI,8
  5398.   DEC     EBX
  5399.   JNZ     @@loop
  5400.  
  5401.   POP     ESI
  5402.   POP     EBX
  5403. end;
  5404.  
  5405. var
  5406.   runErrMsg: array[0..29] of Char = 'Runtime error     at 00000000'#0;
  5407.                         // columns:  0123456789012345678901234567890
  5408.   errCaption: array[0..5] of Char = 'Error'#0;
  5409.  
  5410.  
  5411. procedure MakeErrorMessage;
  5412. const
  5413.   dig : array [0..15] of Char = '0123456789ABCDEF';
  5414. asm
  5415.         PUSH    EBX
  5416.         MOV     EAX,ExitCode
  5417.         MOV     EBX,offset runErrMsg + 16
  5418.         MOV     ECX,10
  5419.  
  5420. @@digLoop:
  5421.         XOR     EDX,EDX
  5422.         DIV     ECX
  5423.         ADD     DL,'0'
  5424.         MOV     [EBX],DL
  5425.         DEC     EBX
  5426.         TEST    EAX,EAX
  5427.         JNZ     @@digLoop
  5428.  
  5429.     MOV     EAX,ErrorAddr
  5430.  
  5431.         CALL    FindHInstance
  5432.         MOV     EDX, ErrorAddr
  5433.         XCHG    EAX, EDX
  5434.         SUB     EAX, EDX           { EAX <=> offset from start of code for HINSTANCE }
  5435.         MOV     EBX,offset runErrMsg + 28
  5436.  
  5437. @@hdigLoop:
  5438.         MOV     EDX,EAX
  5439.         AND     EDX,0FH
  5440.         MOV     DL,byte ptr dig[EDX]
  5441.         MOV     [EBX],DL
  5442.         DEC     EBX
  5443.         SHR     EAX,4
  5444.         JNE     @@hdigLoop
  5445.         POP     EBX
  5446. end;
  5447.  
  5448.  
  5449. procedure       ExitDll;
  5450. asm
  5451.         { Restore the InitContext }
  5452.  
  5453.         MOV     EDI,offset InitContext
  5454.  
  5455.         MOV     EBX,InitContext.DLLSaveEBX
  5456.         MOV     EBP,InitContext.DLLSaveEBP
  5457.         PUSH    [EDI].TInitContext.DLLSaveESI
  5458.         PUSH    [EDI].TInitContext.DLLSaveEDI
  5459.  
  5460.         MOV     ESI,[EDI].TInitContext.OuterContext
  5461.         MOV     ECX,(type TInitContext)/4
  5462.         REP     MOVSD
  5463.         POP     EDI
  5464.         POP     ESI
  5465.  
  5466.         { Return False if ExitCode <> 0, and set ExitCode to 0 }
  5467.  
  5468.         XOR     EAX,EAX
  5469.         XCHG    EAX,ExitCode
  5470.         NEG     EAX
  5471.         SBB     EAX,EAX
  5472.         INC     EAX
  5473.         LEAVE
  5474.         RET     12
  5475. end;
  5476.  
  5477.  
  5478. procedure _Halt0;
  5479. var
  5480.   P: procedure;
  5481. begin
  5482.  
  5483.   if InitContext.DLLInitState = 0 then
  5484.     while ExitProc <> nil do
  5485.     begin
  5486.       @P := ExitProc;
  5487.       ExitProc := nil;
  5488.       P;
  5489.     end;
  5490.  
  5491.   { If there was some kind of runtime error, alert the user }
  5492.  
  5493.   if ErrorAddr <> nil then
  5494.   begin
  5495.     MakeErrorMessage;
  5496.     if IsConsole then
  5497.       WriteLn(PChar(@runErrMsg))
  5498.     else if not NoErrMsg then
  5499.       MessageBox(0, runErrMsg, errCaption, 0);
  5500.     ErrorAddr := nil;
  5501.   end;
  5502.  
  5503.   { This loop exists because we might be nested in PackageLoad calls when }
  5504.   { Halt got called. We need to unwind these contexts.                    }
  5505.  
  5506.   while True do
  5507.   begin
  5508.  
  5509.     { If we are a library, and we are starting up fine, there are no units to finalize }
  5510.  
  5511.     if (InitContext.DLLInitState = 2) and (ExitCode = 0) then
  5512.       InitContext.InitCount := 0;
  5513.  
  5514.     { Undo any unit initializations accomplished so far }
  5515.  
  5516.     FInitUnits;
  5517.  
  5518.     if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then
  5519.       if InitContext.Module <> nil then
  5520.         with InitContext do
  5521.         begin
  5522.           UnregisterModule(Module);
  5523.           if Module.ResInstance <> Module.Instance then
  5524.             FreeLibrary(Module.ResInstance);
  5525.         end;
  5526.  
  5527.     UnsetExceptionHandler;
  5528.  
  5529.     if InitContext.DllInitState = 1 then
  5530.       InitContext.ExitProcessTLS;
  5531.  
  5532.     if InitContext.DllInitState <> 0 then
  5533.       ExitDll;
  5534.  
  5535.     if InitContext.OuterContext = nil then
  5536.       ExitProcess(ExitCode);
  5537.  
  5538.     InitContext := InitContext.OuterContext^
  5539.   end;
  5540.  
  5541.   asm
  5542.     db 'Portions Copyright (c) 1983,99 Borland',0
  5543.   end;
  5544.  
  5545. end;
  5546.  
  5547.  
  5548. procedure _Halt;
  5549. asm
  5550.         MOV     ExitCode,EAX
  5551.         JMP     _Halt0
  5552. end;
  5553.  
  5554.  
  5555. procedure _Run0Error;
  5556. asm
  5557.         XOR     EAX,EAX
  5558.         JMP     _RunError
  5559. end;
  5560.  
  5561.  
  5562. procedure _RunError;
  5563. asm
  5564.         POP     ErrorAddr
  5565.         JMP     _Halt
  5566. end;
  5567.  
  5568.  
  5569. procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
  5570. asm
  5571.         CMP     AssertErrorProc,0
  5572.         JE      @@1
  5573.         PUSH    [ESP].Pointer
  5574.         CALL    AssertErrorProc
  5575.         RET
  5576. @@1:    MOV     AL,reAssertionFailed
  5577.         JMP     Error
  5578. end;
  5579.  
  5580. type
  5581.   PThreadRec = ^TThreadRec;
  5582.   TThreadRec = record
  5583.     Func: TThreadFunc;
  5584.     Parameter: Pointer;
  5585.   end;
  5586.  
  5587.  
  5588. function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
  5589. asm
  5590.         CALL    _FpuInit
  5591.         XOR     ECX,ECX
  5592.         PUSH    EBP
  5593.         PUSH    offset _ExceptionHandler
  5594.         MOV     EDX,FS:[ECX]
  5595.         PUSH    EDX
  5596.         MOV     EAX,Parameter
  5597.         MOV     FS:[ECX],ESP
  5598.  
  5599.         MOV     ECX,[EAX].TThreadRec.Parameter
  5600.         MOV     EDX,[EAX].TThreadRec.Func
  5601.         PUSH    ECX
  5602.         PUSH    EDX
  5603.         CALL    _FreeMem
  5604.         POP     EDX
  5605.         POP     EAX
  5606.         CALL    EDX
  5607.  
  5608.         XOR     EDX,EDX
  5609.         POP     ECX
  5610.         MOV     FS:[EDX],ECX
  5611.         POP     ECX
  5612.         POP     EBP
  5613. end;
  5614.  
  5615.  
  5616. function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
  5617.   ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
  5618.   var ThreadId: LongWord): Integer;
  5619. var
  5620.   P: PThreadRec;
  5621. begin
  5622.   New(P);
  5623.   P.Func := ThreadFunc;
  5624.   P.Parameter := Parameter;
  5625.   IsMultiThread := TRUE;
  5626.   Result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
  5627.     CreationFlags, ThreadID);
  5628. end;
  5629.  
  5630.  
  5631. procedure EndThread(ExitCode: Integer);
  5632. begin
  5633.   ExitThread(ExitCode);
  5634. end;
  5635.  
  5636.  
  5637. type
  5638.   StrRec = packed record
  5639.     allocSiz: Longint;
  5640.     refCnt: Longint;
  5641.     length: Longint;
  5642.   end;
  5643.  
  5644. const
  5645.         skew = sizeof(StrRec);
  5646.         rOff = sizeof(StrRec) - sizeof(Longint); { refCnt offset }
  5647.         overHead = sizeof(StrRec) + 1;
  5648.  
  5649.  
  5650. procedure _LStrClr(var S: AnsiString);
  5651. asm
  5652.         { ->    EAX pointer to str      }
  5653.  
  5654.         MOV     EDX,[EAX]                       { fetch str                     }
  5655.         TEST    EDX,EDX                         { if nil, nothing to do         }
  5656.         JE      @@done
  5657.         MOV     dword ptr [EAX],0               { clear str                     }
  5658.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  5659.         DEC     ECX                             { if < 0: literal str           }
  5660.         JL      @@done
  5661.    LOCK DEC     [EDX-skew].StrRec.refCnt        { threadsafe dec refCount       }
  5662.         JNE     @@done
  5663.         PUSH    EAX
  5664.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5665.         CALL    _FreeMem
  5666.         POP     EAX
  5667. @@done:
  5668. end;
  5669.  
  5670.  
  5671. procedure       _LStrArrayClr{var str: AnsiString; cnt: longint};
  5672. asm
  5673.         { ->    EAX pointer to str      }
  5674.         {       EDX cnt         }
  5675.  
  5676.         PUSH    EBX
  5677.         PUSH    ESI
  5678.         MOV     EBX,EAX
  5679.         MOV     ESI,EDX
  5680.  
  5681. @@loop:
  5682.         MOV     EDX,[EBX]                       { fetch str                     }
  5683.         TEST    EDX,EDX                         { if nil, nothing to do         }
  5684.         JE      @@doneEntry
  5685.         MOV     dword ptr [EBX],0               { clear str                     }
  5686.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  5687.         DEC     ECX                             { if < 0: literal str           }
  5688.         JL      @@doneEntry
  5689.    LOCK DEC     [EDX-skew].StrRec.refCnt        { threadsafe dec refCount       }
  5690.         JNE     @@doneEntry
  5691.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5692.         CALL    _FreeMem
  5693. @@doneEntry:
  5694.         ADD     EBX,4
  5695.         DEC     ESI
  5696.         JNE     @@loop
  5697.  
  5698.         POP     ESI
  5699.         POP     EBX
  5700. end;
  5701.  
  5702. { 99.03.11
  5703.   This function is used when assigning to global variables.
  5704.  
  5705.   Literals are copied to prevent a situation where a dynamically
  5706.   allocated DLL or package assigns a literal to a variable and then
  5707.   is unloaded -- thereby causing the string memory (in the code
  5708.   segment of the DLL) to be removed -- and therefore leaving the
  5709.   global variable pointing to invalid memory.
  5710. }
  5711. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  5712. asm
  5713.         { ->    EAX pointer to dest   str      }
  5714.         { ->    EDX pointer to source str      }
  5715.  
  5716.         TEST    EDX,EDX                           { have a source? }
  5717.         JE      @@2                               { no -> jump     }
  5718.  
  5719.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5720.         INC     ECX
  5721.         JG      @@1                               { literal string -> jump not taken }
  5722.  
  5723.         PUSH    EAX
  5724.         PUSH    EDX
  5725.         MOV     EAX,[EDX-skew].StrRec.length
  5726.         CALL    _NewAnsiString
  5727.         MOV     EDX,EAX
  5728.         POP     EAX
  5729.         PUSH    EDX
  5730.         MOV     ECX,[EAX-skew].StrRec.length
  5731.         CALL    Move
  5732.         POP     EDX
  5733.         POP     EAX
  5734.         JMP     @@2
  5735.  
  5736. @@1:
  5737.    LOCK INC     [EDX-skew].StrRec.refCnt
  5738.  
  5739. @@2:    XCHG    EDX,[EAX]
  5740.         TEST    EDX,EDX
  5741.         JE      @@3
  5742.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5743.         DEC     ECX
  5744.         JL      @@3
  5745.    LOCK DEC     [EDX-skew].StrRec.refCnt
  5746.         JNE     @@3
  5747.         LEA     EAX,[EDX-skew].StrRec.refCnt
  5748.         CALL    _FreeMem
  5749. @@3:
  5750. end;
  5751.  
  5752. procedure       _LStrLAsg{var dest: AnsiString; source: AnsiString};
  5753. asm
  5754. { ->    EAX     pointer to dest }
  5755. {       EDX     source          }
  5756.  
  5757.         TEST    EDX,EDX
  5758.         JE      @@sourceDone
  5759.  
  5760.         { bump up the ref count of the source }
  5761.  
  5762.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5763.         INC     ECX
  5764.         JLE     @@sourceDone                    { literal assignment -> jump taken }
  5765.    LOCK INC     [EDX-skew].StrRec.refCnt
  5766. @@sourceDone:
  5767.  
  5768.         { we need to release whatever the dest is pointing to   }
  5769.  
  5770.         XCHG    EDX,[EAX]                       { fetch str                    }
  5771.         TEST    EDX,EDX                         { if nil, nothing to do        }
  5772.         JE      @@done
  5773.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                 }
  5774.         DEC     ECX                             { if < 0: literal str          }
  5775.         JL      @@done
  5776.    LOCK DEC     [EDX-skew].StrRec.refCnt        { threadsafe dec refCount      }
  5777.         JNE     @@done
  5778.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5779.         CALL    _FreeMem
  5780. @@done:
  5781. end;
  5782.  
  5783. procedure       _NewAnsiString{length: Longint};
  5784. asm
  5785.         { ->    EAX     length                  }
  5786.         { <-    EAX pointer to new string       }
  5787.  
  5788.         TEST    EAX,EAX
  5789.         JLE     @@null
  5790.         PUSH    EAX
  5791.         ADD     EAX,rOff+1
  5792.         CALL    _GetMem
  5793.         ADD     EAX,rOff
  5794.         POP     EDX
  5795.         MOV     [EAX-skew].StrRec.length,EDX
  5796.         MOV     [EAX-skew].StrRec.refCnt,1
  5797.         MOV     byte ptr [EAX+EDX],0
  5798.         RET
  5799.  
  5800. @@null:
  5801.         XOR     EAX,EAX
  5802. end;
  5803.  
  5804.  
  5805. procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5806. asm
  5807.         { ->    EAX     pointer to dest }
  5808.         {       EDX source              }
  5809.         {       ECX length              }
  5810.  
  5811.         PUSH    EBX
  5812.         PUSH    ESI
  5813.         PUSH    EDI
  5814.  
  5815.         MOV     EBX,EAX
  5816.         MOV     ESI,EDX
  5817.         MOV     EDI,ECX
  5818.  
  5819.         { allocate new string }
  5820.  
  5821.         MOV     EAX,EDI
  5822.  
  5823.         CALL    _NewAnsiString
  5824.         MOV     ECX,EDI
  5825.         MOV     EDI,EAX
  5826.  
  5827.         TEST    ESI,ESI
  5828.         JE      @@noMove
  5829.  
  5830.         MOV     EDX,EAX
  5831.         MOV     EAX,ESI
  5832.         CALL    Move
  5833.  
  5834.         { assign the result to dest }
  5835.  
  5836. @@noMove:
  5837.         MOV     EAX,EBX
  5838.         CALL    _LStrClr
  5839.         MOV     [EBX],EDI
  5840.  
  5841.         POP     EDI
  5842.         POP     ESI
  5843.         POP     EBX
  5844. end;
  5845.  
  5846.  
  5847. procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5848. var
  5849.   DestLen: Integer;
  5850.   Buffer: array[0..2047] of Char;
  5851. begin
  5852.   if Length <= 0 then
  5853.   begin
  5854.     _LStrClr(Dest);
  5855.     Exit;
  5856.   end;
  5857.   if Length < SizeOf(Buffer) div 2 then
  5858.   begin
  5859.     DestLen := WideCharToMultiByte(0, 0, Source, Length,
  5860.       Buffer, SizeOf(Buffer), nil, nil);
  5861.     if DestLen > 0 then
  5862.     begin
  5863.       _LStrFromPCharLen(Dest, Buffer, DestLen);
  5864.       Exit;
  5865.     end;
  5866.   end;
  5867.   DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
  5868.   _LStrFromPCharLen(Dest, nil, DestLen);
  5869.   WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil);
  5870. end;
  5871.  
  5872.  
  5873. procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
  5874. asm
  5875.         PUSH    EDX
  5876.         MOV     EDX,ESP
  5877.         MOV     ECX,1
  5878.         CALL    _LStrFromPCharLen
  5879.         POP     EDX
  5880. end;
  5881.  
  5882.  
  5883. procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
  5884. asm
  5885.         PUSH    EDX
  5886.         MOV     EDX,ESP
  5887.         MOV     ECX,1
  5888.         CALL    _LStrFromPWCharLen
  5889.         POP     EDX
  5890. end;
  5891.  
  5892.  
  5893. procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
  5894. asm
  5895.         XOR     ECX,ECX
  5896.         TEST    EDX,EDX
  5897.         JE      @@5
  5898.         PUSH    EDX
  5899. @@0:    CMP     CL,[EDX+0]
  5900.         JE      @@4
  5901.         CMP     CL,[EDX+1]
  5902.         JE      @@3
  5903.         CMP     CL,[EDX+2]
  5904.         JE      @@2
  5905.         CMP     CL,[EDX+3]
  5906.         JE      @@1
  5907.         ADD     EDX,4
  5908.         JMP     @@0
  5909. @@1:    INC     EDX
  5910. @@2:    INC     EDX
  5911. @@3:    INC     EDX
  5912. @@4:    MOV     ECX,EDX
  5913.         POP     EDX
  5914.         SUB     ECX,EDX
  5915. @@5:    JMP     _LStrFromPCharLen
  5916. end;
  5917.  
  5918.  
  5919. procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
  5920. asm
  5921.         XOR     ECX,ECX
  5922.         TEST    EDX,EDX
  5923.         JE      @@5
  5924.         PUSH    EDX
  5925. @@0:    CMP     CX,[EDX+0]
  5926.         JE      @@4
  5927.         CMP     CX,[EDX+2]
  5928.         JE      @@3
  5929.         CMP     CX,[EDX+4]
  5930.         JE      @@2
  5931.         CMP     CX,[EDX+6]
  5932.         JE      @@1
  5933.         ADD     EDX,8
  5934.         JMP     @@0
  5935. @@1:    ADD     EDX,2
  5936. @@2:    ADD     EDX,2
  5937. @@3:    ADD     EDX,2
  5938. @@4:    MOV     ECX,EDX
  5939.         POP     EDX
  5940.         SUB     ECX,EDX
  5941.         SHR     ECX,1
  5942. @@5:    JMP     _LStrFromPWCharLen
  5943. end;
  5944.  
  5945.  
  5946. procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
  5947. asm
  5948.         XOR     ECX,ECX
  5949.         MOV     CL,[EDX]
  5950.         INC     EDX
  5951.         JMP     _LStrFromPCharLen
  5952. end;
  5953.  
  5954.  
  5955. procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5956. asm
  5957.         PUSH    EDI
  5958.         PUSH    EAX
  5959.         PUSH    ECX
  5960.         MOV     EDI,EDX
  5961.         XOR     EAX,EAX
  5962.         REPNE   SCASB
  5963.         JNE     @@1
  5964.         NOT     ECX
  5965. @@1:    POP     EAX
  5966.         ADD     ECX,EAX
  5967.         POP     EAX
  5968.         POP     EDI
  5969.         JMP     _LStrFromPCharLen
  5970. end;
  5971.  
  5972.  
  5973. procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5974. asm
  5975.         PUSH    EDI
  5976.         PUSH    EAX
  5977.         PUSH    ECX
  5978.         MOV     EDI,EDX
  5979.         XOR     EAX,EAX
  5980.         REPNE   SCASW
  5981.         JNE     @@1
  5982.         NOT     ECX
  5983. @@1:    POP     EAX
  5984.         ADD     ECX,EAX
  5985.         POP     EAX
  5986.         POP     EDI
  5987.         JMP     _LStrFromPWCharLen
  5988. end;
  5989.  
  5990.  
  5991. procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
  5992. asm
  5993.         { ->    EAX pointer to dest              }
  5994.         {       EDX pointer to WideString data   }
  5995.  
  5996.         XOR     ECX,ECX
  5997.         TEST    EDX,EDX
  5998.         JE      @@1
  5999.         MOV     ECX,[EDX-4]
  6000.         SHR     ECX,1
  6001. @@1:    JMP     _LStrFromPWCharLen
  6002. end;
  6003.  
  6004.  
  6005. procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
  6006. asm
  6007.         { ->    EAX pointer to result   }
  6008.         {       EDX AnsiString s        }
  6009.         {       ECX length of result    }
  6010.  
  6011.         PUSH    EBX
  6012.         TEST    EDX,EDX
  6013.         JE      @@empty
  6014.         MOV     EBX,[EDX-skew].StrRec.length
  6015.         TEST    EBX,EBX
  6016.         JE      @@empty
  6017.  
  6018.         CMP     ECX,EBX
  6019.         JL      @@truncate
  6020.         MOV     ECX,EBX
  6021. @@truncate:
  6022.         MOV     [EAX],CL
  6023.         INC     EAX
  6024.  
  6025.         XCHG    EAX,EDX
  6026.         CALL    Move
  6027.  
  6028.         JMP     @@exit
  6029.  
  6030. @@empty:
  6031.         MOV     byte ptr [EAX],0
  6032.  
  6033. @@exit:
  6034.         POP     EBX
  6035. end;
  6036.  
  6037.  
  6038. function        _LStrLen{str: AnsiString}: Longint;
  6039. asm
  6040.         { ->    EAX str }
  6041.  
  6042.         TEST    EAX,EAX
  6043.         JE      @@done
  6044.         MOV     EAX,[EAX-skew].StrRec.length;
  6045. @@done:
  6046. end;
  6047.  
  6048.  
  6049. procedure       _LStrCat{var dest: AnsiString; source: AnsiString};
  6050. asm
  6051.         { ->    EAX     pointer to dest }
  6052.         {       EDX source              }
  6053.  
  6054.         TEST    EDX,EDX
  6055.         JE      @@exit
  6056.  
  6057.         MOV     ECX,[EAX]
  6058.         TEST    ECX,ECX
  6059.         JE      _LStrAsg
  6060.  
  6061.         PUSH    EBX
  6062.         PUSH    ESI
  6063.         PUSH    EDI
  6064.         MOV     EBX,EAX
  6065.         MOV     ESI,EDX
  6066.         MOV     EDI,[ECX-skew].StrRec.length
  6067.  
  6068.         MOV     EDX,[ESI-skew].StrRec.length
  6069.         ADD     EDX,EDI
  6070.         CMP     ESI,ECX
  6071.         JE      @@appendSelf
  6072.  
  6073.         CALL    _LStrSetLength
  6074.         MOV     EAX,ESI
  6075.         MOV     ECX,[ESI-skew].StrRec.length
  6076.  
  6077. @@appendStr:
  6078.         MOV     EDX,[EBX]
  6079.         ADD     EDX,EDI
  6080.         CALL    Move
  6081.         POP     EDI
  6082.         POP     ESI
  6083.         POP     EBX
  6084.         RET
  6085.  
  6086. @@appendSelf:
  6087.         CALL    _LStrSetLength
  6088.         MOV     EAX,[EBX]
  6089.         MOV     ECX,EDI
  6090.         JMP     @@appendStr
  6091.  
  6092. @@exit:
  6093. end;
  6094.  
  6095.  
  6096. procedure       _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  6097. asm
  6098.         {     ->EAX = Pointer to dest   }
  6099.         {       EDX = source1           }
  6100.         {       ECX = source2           }
  6101.  
  6102.         TEST    EDX,EDX
  6103.         JE      @@assignSource2
  6104.  
  6105.         TEST    ECX,ECX
  6106.         JE      _LStrAsg
  6107.  
  6108.         CMP     EDX,[EAX]
  6109.         JE      @@appendToDest
  6110.  
  6111.         CMP     ECX,[EAX]
  6112.         JE      @@theHardWay
  6113.  
  6114.         PUSH    EAX
  6115.         PUSH    ECX
  6116.         CALL    _LStrAsg
  6117.  
  6118.         POP     EDX
  6119.         POP     EAX
  6120.         JMP     _LStrCat
  6121.  
  6122. @@theHardWay:
  6123.  
  6124.         PUSH    EBX
  6125.         PUSH    ESI
  6126.         PUSH    EDI
  6127.  
  6128.         MOV     EBX,EDX
  6129.         MOV     ESI,ECX
  6130.         PUSH    EAX
  6131.  
  6132.         MOV     EAX,[EBX-skew].StrRec.length
  6133.         ADD     EAX,[ESI-skew].StrRec.length
  6134.         CALL    _NewAnsiString
  6135.  
  6136.         MOV     EDI,EAX
  6137.         MOV     EDX,EAX
  6138.         MOV     EAX,EBX
  6139.         MOV     ECX,[EBX-skew].StrRec.length
  6140.         CALL    Move
  6141.  
  6142.         MOV     EDX,EDI
  6143.         MOV     EAX,ESI
  6144.         MOV     ECX,[ESI-skew].StrRec.length
  6145.         ADD     EDX,[EBX-skew].StrRec.length
  6146.         CALL    Move
  6147.  
  6148.         POP     EAX
  6149.         MOV     EDX,EDI
  6150.         TEST    EDI,EDI
  6151.         JE      @@skip
  6152.         DEC     [EDI-skew].StrRec.refCnt    // EDI = local temp str
  6153. @@skip:
  6154.         CALL    _LStrAsg
  6155.  
  6156.         POP     EDI
  6157.         POP     ESI
  6158.         POP     EBX
  6159.  
  6160.         JMP     @@exit
  6161.  
  6162. @@assignSource2:
  6163.         MOV     EDX,ECX
  6164.         JMP     _LStrAsg
  6165.  
  6166. @@appendToDest:
  6167.         MOV     EDX,ECX
  6168.         JMP     _LStrCat
  6169.  
  6170. @@exit:
  6171. end;
  6172.  
  6173.  
  6174. procedure       _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  6175. asm
  6176.         {     ->EAX = Pointer to dest   }
  6177.         {       EDX = number of args (>= 3)     }
  6178.         {       [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }
  6179.  
  6180.         PUSH    EBX
  6181.         PUSH    ESI
  6182.         PUSH    EDX
  6183.         PUSH    EAX
  6184.         MOV     EBX,EDX
  6185.  
  6186.         XOR     EAX,EAX
  6187. @@loop1:
  6188.         MOV     ECX,[ESP+EDX*4+4*4]
  6189.         TEST    ECX,ECX
  6190.         JE      @@1
  6191.         ADD     EAX,[ECX-skew].StrRec.length
  6192. @@1:
  6193.         DEC     EDX
  6194.         JNE     @@loop1
  6195.  
  6196.         CALL    _NewAnsiString
  6197.         PUSH    EAX
  6198.         MOV     ESI,EAX
  6199.  
  6200. @@loop2:
  6201.         MOV     EAX,[ESP+EBX*4+5*4]
  6202.         MOV     EDX,ESI
  6203.         TEST    EAX,EAX
  6204.         JE      @@2
  6205.         MOV     ECX,[EAX-skew].StrRec.length
  6206.         ADD     ESI,ECX
  6207.         CALL    Move
  6208. @@2:
  6209.         DEC     EBX
  6210.         JNE     @@loop2
  6211.  
  6212.         POP     EDX
  6213.         POP     EAX
  6214.         TEST    EDX,EDX
  6215.         JE      @@skip
  6216.         DEC     [EDX-skew].StrRec.refCnt   // EDX = local temp str
  6217. @@skip:
  6218.         CALL    _LStrAsg
  6219.  
  6220.         POP     EDX
  6221.         POP     ESI
  6222.         POP     EBX
  6223.         POP     EAX
  6224.         LEA     ESP,[ESP+EDX*4]
  6225.         JMP     EAX
  6226. end;
  6227.  
  6228.  
  6229. procedure       _LStrCmp{left: AnsiString; right: AnsiString};
  6230. asm
  6231. {     ->EAX = Pointer to left string    }
  6232. {       EDX = Pointer to right string   }
  6233.  
  6234.         PUSH    EBX
  6235.         PUSH    ESI
  6236.         PUSH    EDI
  6237.  
  6238.         MOV     ESI,EAX
  6239.         MOV     EDI,EDX
  6240.  
  6241.         CMP     EAX,EDX
  6242.         JE      @@exit
  6243.  
  6244.         TEST    ESI,ESI
  6245.         JE      @@str1null
  6246.  
  6247.         TEST    EDI,EDI
  6248.         JE      @@str2null
  6249.  
  6250.         MOV     EAX,[ESI-skew].StrRec.length
  6251.         MOV     EDX,[EDI-skew].StrRec.length
  6252.  
  6253.         SUB     EAX,EDX { eax = len1 - len2 }
  6254.         JA      @@skip1
  6255.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  6256.  
  6257. @@skip1:
  6258.         PUSH    EDX
  6259.         SHR     EDX,2
  6260.         JE      @@cmpRest
  6261. @@longLoop:
  6262.         MOV     ECX,[ESI]
  6263.         MOV     EBX,[EDI]
  6264.         CMP     ECX,EBX
  6265.         JNE     @@misMatch
  6266.         DEC     EDX
  6267.         JE      @@cmpRestP4
  6268.         MOV     ECX,[ESI+4]
  6269.         MOV     EBX,[EDI+4]
  6270.         CMP     ECX,EBX
  6271.         JNE     @@misMatch
  6272.         ADD     ESI,8
  6273.         ADD     EDI,8
  6274.         DEC     EDX
  6275.         JNE     @@longLoop
  6276.         JMP     @@cmpRest
  6277. @@cmpRestP4:
  6278.         ADD     ESI,4
  6279.         ADD     EDI,4
  6280. @@cmpRest:
  6281.         POP     EDX
  6282.         AND     EDX,3
  6283.         JE      @@equal
  6284.  
  6285.         MOV     ECX,[ESI]
  6286.         MOV     EBX,[EDI]
  6287.         CMP     CL,BL
  6288.         JNE     @@exit
  6289.         DEC     EDX
  6290.         JE      @@equal
  6291.         CMP     CH,BH
  6292.         JNE     @@exit
  6293.         DEC     EDX
  6294.         JE      @@equal
  6295.         AND     EBX,$00FF0000
  6296.         AND     ECX,$00FF0000
  6297.         CMP     ECX,EBX
  6298.         JNE     @@exit
  6299.  
  6300. @@equal:
  6301.         ADD     EAX,EAX
  6302.         JMP     @@exit
  6303.  
  6304. @@str1null:
  6305.         MOV     EDX,[EDI-skew].StrRec.length
  6306.         SUB     EAX,EDX
  6307.         JMP     @@exit
  6308.  
  6309. @@str2null:
  6310.         MOV     EAX,[ESI-skew].StrRec.length
  6311.         SUB     EAX,EDX
  6312.         JMP     @@exit
  6313.  
  6314. @@misMatch:
  6315.         POP     EDX
  6316.         CMP     CL,BL
  6317.         JNE     @@exit
  6318.         CMP     CH,BH
  6319.         JNE     @@exit
  6320.         SHR     ECX,16
  6321.         SHR     EBX,16
  6322.         CMP     CL,BL
  6323.         JNE     @@exit
  6324.         CMP     CH,BH
  6325.  
  6326. @@exit:
  6327.         POP     EDI
  6328.         POP     ESI
  6329.         POP     EBX
  6330.  
  6331. end;
  6332.  
  6333.  
  6334. procedure       _LStrAddRef{str: AnsiString};
  6335. asm
  6336.         { ->    EAX     str     }
  6337.         TEST    EAX,EAX
  6338.         JE      @@exit
  6339.         MOV     EDX,[EAX-skew].StrRec.refCnt
  6340.         INC     EDX
  6341.         JLE     @@exit
  6342.    LOCK INC     [EAX-skew].StrRec.refCnt
  6343. @@exit:
  6344. end;
  6345.  
  6346.  
  6347. procedure       _LStrToPChar{str: AnsiString): PChar};
  6348. asm
  6349.         { ->    EAX pointer to str              }
  6350.         { <-    EAX pointer to PChar    }
  6351.  
  6352.         TEST    EAX,EAX
  6353.         JE      @@handle0
  6354.         RET
  6355. @@zeroByte:
  6356.         DB      0
  6357. @@handle0:
  6358.         MOV     EAX,offset @@zeroByte
  6359. end;
  6360.  
  6361.  
  6362. procedure       UniqueString(var str: string);
  6363. asm
  6364.         { ->    EAX pointer to str              }
  6365.         { <-    EAX pointer to unique copy      }
  6366.         MOV     EDX,[EAX]
  6367.         TEST    EDX,EDX
  6368.         JE      @@exit
  6369.         MOV     ECX,[EDX-skew].StrRec.refCnt
  6370.         DEC     ECX
  6371.         JE      @@exit
  6372.  
  6373.         PUSH    EBX
  6374.         MOV     EBX,EAX
  6375.         MOV     EAX,[EDX-skew].StrRec.length
  6376.         CALL    _NewAnsiString
  6377.         MOV     EDX,EAX
  6378.         MOV     EAX,[EBX]
  6379.         MOV     [EBX],EDX
  6380.         MOV     ECX,[EAX-skew].StrRec.refCnt
  6381.         DEC     ECX
  6382.         JL      @@skip
  6383.    LOCK DEC     [EAX-skew].StrRec.refCnt
  6384. @@skip:
  6385.         MOV     ECX,[EAX-skew].StrRec.length
  6386.         CALL    Move
  6387.         MOV     EDX,[EBX]
  6388.         POP     EBX
  6389. @@exit:
  6390.         MOV     EAX,EDX
  6391. end;
  6392.  
  6393.  
  6394. procedure       _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
  6395. asm
  6396.         {     ->EAX     Source string                   }
  6397.         {       EDX     index                           }
  6398.         {       ECX     count                           }
  6399.         {       [ESP+4] Pointer to result string        }
  6400.  
  6401.         PUSH    EBX
  6402.  
  6403.         TEST    EAX,EAX
  6404.         JE      @@srcEmpty
  6405.  
  6406.         MOV     EBX,[EAX-skew].StrRec.length
  6407.         TEST    EBX,EBX
  6408.         JE      @@srcEmpty
  6409.  
  6410. {       make index 0-based and limit to 0 <= index < Length(src) }
  6411.  
  6412.         DEC     EDX
  6413.         JL      @@smallInx
  6414.         CMP     EDX,EBX
  6415.         JGE     @@bigInx
  6416.  
  6417. @@cont1:
  6418.  
  6419. {       limit count to satisfy 0 <= count <= Length(src) - index        }
  6420.  
  6421.         SUB     EBX,EDX { calculate Length(src) - index }
  6422.         TEST    ECX,ECX
  6423.         JL      @@smallCount
  6424.         CMP     ECX,EBX
  6425.         JG      @@bigCount
  6426.  
  6427. @@cont2:
  6428.  
  6429.         ADD     EDX,EAX
  6430.         MOV     EAX,[ESP+4+4]
  6431.         CALL    _LStrFromPCharLen
  6432.         JMP     @@exit
  6433.  
  6434. @@smallInx:
  6435.         XOR     EDX,EDX
  6436.         JMP     @@cont1
  6437. @@bigCount:
  6438.         MOV     ECX,EBX
  6439.         JMP     @@cont2
  6440. @@bigInx:
  6441. @@smallCount:
  6442. @@srcEmpty:
  6443.         MOV     EAX,[ESP+4+4]
  6444.         CALL    _LStrClr
  6445. @@exit:
  6446.         POP     EBX
  6447.         RET     4
  6448. end;
  6449.  
  6450.  
  6451. procedure       _LStrDelete{ var s : AnsiString; index, count : Integer };
  6452. asm
  6453.         {     ->EAX     Pointer to s    }
  6454.         {       EDX     index           }
  6455.         {       ECX     count           }
  6456.  
  6457.         PUSH    EBX
  6458.         PUSH    ESI
  6459.         PUSH    EDI
  6460.  
  6461.         MOV     EBX,EAX
  6462.         MOV     ESI,EDX
  6463.         MOV     EDI,ECX
  6464.  
  6465.         CALL    UniqueString
  6466.  
  6467.         MOV     EDX,[EBX]
  6468.         TEST    EDX,EDX         { source already empty: nothing to do   }
  6469.         JE      @@exit
  6470.  
  6471.         MOV     ECX,[EDX-skew].StrRec.length
  6472.  
  6473. {       make index 0-based, if not in [0 .. Length(s)-1] do nothing     }
  6474.  
  6475.         DEC     ESI
  6476.         JL      @@exit
  6477.         CMP     ESI,ECX
  6478.         JGE     @@exit
  6479.  
  6480. {       limit count to [0 .. Length(s) - index] }
  6481.  
  6482.         TEST    EDI,EDI
  6483.         JLE     @@exit
  6484.         SUB     ECX,ESI         { ECX = Length(s) - index       }
  6485.         CMP     EDI,ECX
  6486.         JLE     @@1
  6487.         MOV     EDI,ECX
  6488. @@1:
  6489.  
  6490. {       move length - index - count characters from s+index+count to s+index }
  6491.  
  6492.         SUB     ECX,EDI         { ECX = Length(s) - index - count       }
  6493.         ADD     EDX,ESI         { EDX = s+index                 }
  6494.         LEA     EAX,[EDX+EDI]   { EAX = s+index+count           }
  6495.         CALL    Move
  6496.  
  6497. {       set length(s) to length(s) - count      }
  6498.  
  6499.         MOV     EDX,[EBX]
  6500.         MOV     EAX,EBX
  6501.         MOV     EDX,[EDX-skew].StrRec.length
  6502.         SUB     EDX,EDI
  6503.         CALL    _LStrSetLength
  6504.  
  6505. @@exit:
  6506.         POP     EDI
  6507.         POP     ESI
  6508.         POP     EBX
  6509. end;
  6510.  
  6511.  
  6512. procedure       _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  6513. asm
  6514.         { ->    EAX source string                       }
  6515.         {       EDX     pointer to destination string   }
  6516.         {       ECX index                               }
  6517.  
  6518.         TEST    EAX,EAX
  6519.         JE      @@nothingToDo
  6520.  
  6521.         PUSH    EBX
  6522.         PUSH    ESI
  6523.         PUSH    EDI
  6524.         PUSH    EBP
  6525.  
  6526.         MOV     EBX,EAX
  6527.         MOV     ESI,EDX
  6528.         MOV     EDI,ECX
  6529.  
  6530. {       make index 0-based and limit to 0 <= index <= Length(s) }
  6531.  
  6532.         MOV     EDX,[EDX]
  6533.         PUSH    EDX
  6534.         TEST    EDX,EDX
  6535.         JE      @@sIsNull
  6536.         MOV     EDX,[EDX-skew].StrRec.length
  6537. @@sIsNull:
  6538.         DEC     EDI
  6539.         JGE     @@indexNotLow
  6540.         XOR     EDI,EDI
  6541. @@indexNotLow:
  6542.         CMP     EDI,EDX
  6543.         JLE     @@indexNotHigh
  6544.         MOV     EDI,EDX
  6545. @@indexNotHigh:
  6546.  
  6547.         MOV     EBP,[EBX-skew].StrRec.length
  6548.  
  6549. {       set length of result to length(source) + length(s)      }
  6550.  
  6551.         MOV     EAX,ESI
  6552.         ADD     EDX,EBP
  6553.         CALL    _LStrSetLength
  6554.         POP     EAX
  6555.  
  6556.         CMP     EAX,EBX
  6557.         JNE     @@notInsertSelf
  6558.         MOV     EBX,[ESI]
  6559.  
  6560. @@notInsertSelf:
  6561.  
  6562. {       move length(s) - length(source) - index chars from s+index to s+index+length(source) }
  6563.  
  6564.         MOV     EAX,[ESI]                       { EAX = s       }
  6565.         LEA     EDX,[EDI+EBP]                   { EDX = index + length(source)  }
  6566.         MOV     ECX,[EAX-skew].StrRec.length
  6567.         SUB     ECX,EDX                         { ECX = length(s) - length(source) - index }
  6568.         ADD     EDX,EAX                         { EDX = s + index + length(source)      }
  6569.         ADD     EAX,EDI                         { EAX = s + index       }
  6570.         CALL    Move
  6571.  
  6572. {       copy length(source) chars from source to s+index        }
  6573.  
  6574.         MOV     EAX,EBX
  6575.         MOV     EDX,[ESI]
  6576.         MOV     ECX,EBP
  6577.         ADD     EDX,EDI
  6578.         CALL    Move
  6579.  
  6580. @@exit:
  6581.         POP     EBP
  6582.         POP     EDI
  6583.         POP     ESI
  6584.         POP     EBX
  6585. @@nothingToDo:
  6586. end;
  6587.  
  6588.  
  6589. procedure       _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  6590. asm
  6591. {     ->EAX     Pointer to substr               }
  6592. {       EDX     Pointer to string               }
  6593. {     <-EAX     Position of substr in s or 0    }
  6594.  
  6595.         TEST    EAX,EAX
  6596.         JE      @@noWork
  6597.  
  6598.         TEST    EDX,EDX
  6599.         JE      @@stringEmpty
  6600.  
  6601.         PUSH    EBX
  6602.         PUSH    ESI
  6603.         PUSH    EDI
  6604.  
  6605.         MOV     ESI,EAX                         { Point ESI to substr           }
  6606.         MOV     EDI,EDX                         { Point EDI to s                }
  6607.  
  6608.         MOV     ECX,[EDI-skew].StrRec.length    { ECX = Length(s)               }
  6609.  
  6610.         PUSH    EDI                             { remember s position to calculate index        }
  6611.  
  6612.         MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)          }
  6613.  
  6614.         DEC     EDX                             { EDX = Length(substr) - 1              }
  6615.         JS      @@fail                          { < 0 ? return 0                        }
  6616.         MOV     AL,[ESI]                        { AL = first char of substr             }
  6617.         INC     ESI                             { Point ESI to 2'nd char of substr      }
  6618.  
  6619.         SUB     ECX,EDX                         { #positions in s to look at    }
  6620.                                                 { = Length(s) - Length(substr) + 1      }
  6621.         JLE     @@fail
  6622. @@loop:
  6623.         REPNE   SCASB
  6624.         JNE     @@fail
  6625.         MOV     EBX,ECX                         { save outer loop counter               }
  6626.         PUSH    ESI                             { save outer loop substr pointer        }
  6627.         PUSH    EDI                             { save outer loop s pointer             }
  6628.  
  6629.         MOV     ECX,EDX
  6630.         REPE    CMPSB
  6631.         POP     EDI                             { restore outer loop s pointer  }
  6632.         POP     ESI                             { restore outer loop substr pointer     }
  6633.         JE      @@found
  6634.         MOV     ECX,EBX                         { restore outer loop counter    }
  6635.         JMP     @@loop
  6636.  
  6637. @@fail:
  6638.         POP     EDX                             { get rid of saved s pointer    }
  6639.         XOR     EAX,EAX
  6640.         JMP     @@exit
  6641.  
  6642. @@stringEmpty:
  6643.         XOR     EAX,EAX
  6644.         JMP     @@noWork
  6645.  
  6646. @@found:
  6647.         POP     EDX                             { restore pointer to first char of s    }
  6648.         MOV     EAX,EDI                         { EDI points of char after match        }
  6649.         SUB     EAX,EDX                         { the difference is the correct index   }
  6650. @@exit:
  6651.         POP     EDI
  6652.         POP     ESI
  6653.         POP     EBX
  6654. @@noWork:
  6655. end;
  6656.  
  6657.  
  6658. procedure       _LStrSetLength{ var str: AnsiString; newLength: Integer};
  6659. asm
  6660.         { ->    EAX     Pointer to str  }
  6661.         {       EDX new length  }
  6662.  
  6663.         PUSH    EBX
  6664.         PUSH    ESI
  6665.         PUSH    EDI
  6666.         MOV     EBX,EAX
  6667.         MOV     ESI,EDX
  6668.         XOR     EDI,EDI
  6669.  
  6670.         TEST    EDX,EDX
  6671.         JE      @@setString
  6672.  
  6673.         MOV     EAX,[EBX]
  6674.         TEST    EAX,EAX
  6675.         JE      @@copyString
  6676.  
  6677.         CMP     [EAX-skew].StrRec.refCnt,1
  6678.         JNE     @@copyString
  6679.  
  6680.         SUB     EAX,rOff
  6681.         ADD     EDX,rOff+1
  6682.         PUSH    EAX
  6683.         MOV     EAX,ESP
  6684.         CALL    _ReallocMem
  6685.         POP     EAX
  6686.         ADD     EAX,rOff
  6687.         MOV     [EBX],EAX
  6688.         MOV     [EAX-skew].StrRec.length,ESI
  6689.         MOV     BYTE PTR [EAX+ESI],0
  6690.         JMP     @@exit
  6691.  
  6692. @@copyString:
  6693.         MOV     EAX,EDX
  6694.         CALL    _NewAnsiString
  6695.         MOV     EDI,EAX
  6696.  
  6697.         MOV     EAX,[EBX]
  6698.         TEST    EAX,EAX
  6699.         JE      @@setString
  6700.  
  6701.         MOV     EDX,EDI
  6702.         MOV     ECX,[EAX-skew].StrRec.length
  6703.         CMP     ECX,ESI
  6704.         JL      @@moveString
  6705.         MOV     ECX,ESI
  6706.  
  6707. @@moveString:
  6708.         CALL    Move
  6709.  
  6710. @@setString:
  6711.         MOV     EAX,EBX
  6712.         CALL    _LStrClr
  6713.         MOV     [EBX],EDI
  6714.  
  6715. @@exit:
  6716.         POP     EDI
  6717.         POP     ESI
  6718.         POP     EBX
  6719. end;
  6720.  
  6721.  
  6722. procedure       _LStrOfChar{ c: Char; count: Integer): AnsiString };
  6723. asm
  6724.         { ->    AL      c               }
  6725.         {       EDX     count           }
  6726.         {       ECX     result  }
  6727.  
  6728.         PUSH    EBX
  6729.         PUSH    ESI
  6730.         PUSH    EDI
  6731.  
  6732.         MOV     EBX,EAX
  6733.         MOV     ESI,EDX
  6734.         MOV     EDI,ECX
  6735.  
  6736.         MOV     EAX,ECX
  6737.         CALL    _LStrClr
  6738.  
  6739.         TEST    ESI,ESI
  6740.     JLE @@exit
  6741.  
  6742.         MOV     EAX,ESI
  6743.         CALL    _NewAnsiString
  6744.  
  6745.         MOV     [EDI],EAX
  6746.  
  6747.         MOV     EDX,ESI
  6748.         MOV     CL,BL
  6749.  
  6750.         CALL    _FillChar
  6751.  
  6752. @@exit:
  6753.         POP     EDI
  6754.         POP     ESI
  6755.         POP     EBX
  6756.  
  6757. end;
  6758.  
  6759.  
  6760. procedure _Write0LString{ VAR t: Text; s: AnsiString };
  6761. asm
  6762.         { ->    EAX     Pointer to text record  }
  6763.         {       EDX     Pointer to AnsiString   }
  6764.  
  6765.         XOR     ECX,ECX
  6766.         JMP     _WriteLString
  6767. end;
  6768.  
  6769.  
  6770. procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
  6771. asm
  6772.         { ->    EAX     Pointer to text record  }
  6773.         {       EDX     Pointer to AnsiString   }
  6774.         {       ECX     Field width             }
  6775.  
  6776.         PUSH    EBX
  6777.  
  6778.         MOV     EBX,EDX
  6779.  
  6780.         MOV     EDX,ECX
  6781.         XOR     ECX,ECX
  6782.         TEST    EBX,EBX
  6783.         JE      @@skip
  6784.         MOV     ECX,[EBX-skew].StrRec.length
  6785.         SUB     EDX,ECX
  6786. @@skip:
  6787.         PUSH    ECX
  6788.         CALL    _WriteSpaces
  6789.         POP     ECX
  6790.  
  6791.         MOV     EDX,EBX
  6792.         POP     EBX
  6793.         JMP     _WriteBytes
  6794. end;
  6795.  
  6796.  
  6797. procedure       _ReadLString{var t: Text; var str: AnsiString};
  6798. asm
  6799.         { ->    EAX     pointer to Text         }
  6800.         {       EDX     pointer to AnsiString   }
  6801.  
  6802.         PUSH    EBX
  6803.         PUSH    ESI
  6804.         MOV     EBX,EAX
  6805.         MOV     ESI,EDX
  6806.  
  6807.         MOV     EAX,EDX
  6808.         CALL    _LStrClr
  6809.  
  6810.         SUB     ESP,256
  6811.  
  6812.         MOV     EAX,EBX
  6813.         MOV     EDX,ESP
  6814.         MOV     ECX,255
  6815.         CALL    _ReadString
  6816.  
  6817.         MOV     EAX,ESI
  6818.         MOV     EDX,ESP
  6819.         CALL    _LStrFromString
  6820.  
  6821.         CMP     byte ptr [ESP],255
  6822.         JNE     @@exit
  6823. @@loop:
  6824.  
  6825.         MOV     EAX,EBX
  6826.         MOV     EDX,ESP
  6827.         MOV     ECX,255
  6828.         CALL    _ReadString
  6829.  
  6830.         MOV     EDX,ESP
  6831.         PUSH    0
  6832.         MOV     EAX,ESP
  6833.         CALL    _LStrFromString
  6834.  
  6835.         MOV     EAX,ESI
  6836.         MOV     EDX,[ESP]
  6837.         CALL    _LStrCat
  6838.  
  6839.         MOV     EAX,ESP
  6840.         CALL    _LStrClr
  6841.         POP     EAX
  6842.  
  6843.         CMP     byte ptr [ESP],255
  6844.         JE      @@loop
  6845.  
  6846. @@exit:
  6847.         ADD     ESP,256
  6848.         POP     ESI
  6849.         POP     EBX
  6850. end;
  6851.  
  6852.  
  6853. procedure WStrError;
  6854. asm
  6855.         MOV     AL,reOutOfMemory
  6856.         JMP     Error
  6857. end;
  6858.  
  6859.  
  6860. procedure WStrSet(var S: WideString; P: PWideChar);
  6861. asm
  6862.         MOV     ECX,[EAX]
  6863.         MOV     [EAX],EDX
  6864.         TEST    ECX,ECX
  6865.         JE      @@1
  6866.         PUSH    ECX
  6867.         CALL    SysFreeString
  6868. @@1:
  6869. end;
  6870.  
  6871.  
  6872. procedure _WStrClr(var S: WideString);
  6873. asm
  6874.         { ->    EAX     Pointer to WideString  }
  6875.  
  6876.         MOV     EDX,[EAX]
  6877.         TEST    EDX,EDX
  6878.         JE      @@1
  6879.         MOV     DWORD PTR [EAX],0
  6880.         PUSH    EAX
  6881.         PUSH    EDX
  6882.         CALL    SysFreeString
  6883.         POP     EAX
  6884. @@1:
  6885. end;
  6886.  
  6887.  
  6888. procedure _WStrArrayClr(var StrArray; Count: Integer);
  6889. asm
  6890.         PUSH    EBX
  6891.         PUSH    ESI
  6892.         MOV     EBX,EAX
  6893.         MOV     ESI,EDX
  6894. @@1:    MOV     EAX,[EBX]
  6895.         TEST    EAX,EAX
  6896.         JE      @@2
  6897.         MOV     DWORD PTR [EBX],0
  6898.         PUSH    EAX
  6899.         CALL    SysFreeString
  6900. @@2:    ADD     EBX,4
  6901.         DEC     ESI
  6902.         JNE     @@1
  6903.         POP     ESI
  6904.         POP     EBX
  6905. end;
  6906.  
  6907.  
  6908. procedure _WStrAsg(var Dest: WideString; const Source: WideString);
  6909. asm
  6910.         { ->    EAX     Pointer to WideString }
  6911.         {       EDX     Pointer to data       }
  6912.         TEST    EDX,EDX
  6913.         JE      _WStrClr
  6914.         MOV     ECX,[EDX-4]
  6915.         SHR     ECX,1
  6916.         JE      _WStrClr
  6917.         PUSH    ECX
  6918.         PUSH    EDX
  6919.         PUSH    EAX
  6920.         CALL    SysReAllocStringLen
  6921.         TEST    EAX,EAX
  6922.         JE      WStrError
  6923. end;
  6924.  
  6925.  
  6926. procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  6927. var
  6928.   DestLen: Integer;
  6929.   Buffer: array[0..1023] of WideChar;
  6930. begin
  6931.   if Length <= 0 then
  6932.   begin
  6933.     _WStrClr(Dest);
  6934.     Exit;
  6935.   end;
  6936.   if Length < SizeOf(Buffer) div 2 then
  6937.   begin
  6938.     DestLen := MultiByteToWideChar(0, 0, Source, Length,
  6939.       Buffer, SizeOf(Buffer) div 2);
  6940.     if DestLen > 0 then
  6941.     begin
  6942.       _WStrFromPWCharLen(Dest, Buffer, DestLen);
  6943.       Exit;
  6944.     end;
  6945.   end;
  6946.   DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0);
  6947.   _WStrFromPWCharLen(Dest, nil, DestLen);
  6948.   MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen);
  6949. end;
  6950.  
  6951.  
  6952. procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
  6953. asm
  6954.         { ->    EAX     Pointer to WideString (dest)      }
  6955.         {       EDX     Pointer to characters (source)    }
  6956.         {       ECX     number of characters  (not bytes) }
  6957.         TEST    ECX,ECX
  6958.         JE      _WStrClr
  6959.  
  6960.         PUSH    EAX
  6961.  
  6962.         PUSH    ECX
  6963.         PUSH    EDX
  6964.         CALL    SysAllocStringLen
  6965.         TEST    EAX,EAX
  6966.         JE      WStrError
  6967.  
  6968.         POP     EDX
  6969.         PUSH    [EDX].PWideChar
  6970.         MOV     [EDX],EAX
  6971.  
  6972.         CALL    SysFreeString
  6973. end;
  6974.  
  6975.  
  6976. procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
  6977. asm
  6978.         PUSH    EDX
  6979.         MOV     EDX,ESP
  6980.         MOV     ECX,1
  6981.         CALL    _WStrFromPCharLen
  6982.         POP     EDX
  6983. end;
  6984.  
  6985.  
  6986. procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
  6987. asm
  6988.         { ->    EAX     Pointer to WideString (dest)   }
  6989.         {       EDX     character             (source) }
  6990.         PUSH    EDX
  6991.         MOV     EDX,ESP
  6992.         MOV     ECX,1
  6993.         CALL    _WStrFromPWCharLen
  6994.         POP     EDX
  6995. end;
  6996.  
  6997.  
  6998. procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
  6999. asm
  7000.         { ->    EAX     Pointer to WideString (dest)   }
  7001.         {       EDX     Pointer to character  (source) }
  7002.         XOR     ECX,ECX
  7003.         TEST    EDX,EDX
  7004.         JE      @@5
  7005.         PUSH    EDX
  7006. @@0:    CMP     CL,[EDX+0]
  7007.         JE      @@4
  7008.         CMP     CL,[EDX+1]
  7009.         JE      @@3
  7010.         CMP     CL,[EDX+2]
  7011.         JE      @@2
  7012.         CMP     CL,[EDX+3]
  7013.         JE      @@1
  7014.         ADD     EDX,4
  7015.         JMP     @@0
  7016. @@1:    INC     EDX
  7017. @@2:    INC     EDX
  7018. @@3:    INC     EDX
  7019. @@4:    MOV     ECX,EDX
  7020.         POP     EDX
  7021.         SUB     ECX,EDX
  7022. @@5:    JMP     _WStrFromPCharLen
  7023. end;
  7024.  
  7025.  
  7026. procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
  7027. asm
  7028.         { ->    EAX     Pointer to WideString (dest)   }
  7029.         {       EDX     Pointer to character  (source) }
  7030.         XOR     ECX,ECX
  7031.         TEST    EDX,EDX
  7032.         JE      @@5
  7033.         PUSH    EDX
  7034. @@0:    CMP     CX,[EDX+0]
  7035.         JE      @@4
  7036.         CMP     CX,[EDX+2]
  7037.         JE      @@3
  7038.         CMP     CX,[EDX+4]
  7039.         JE      @@2
  7040.         CMP     CX,[EDX+6]
  7041.         JE      @@1
  7042.         ADD     EDX,8
  7043.         JMP     @@0
  7044. @@1:    ADD     EDX,2
  7045. @@2:    ADD     EDX,2
  7046. @@3:    ADD     EDX,2
  7047. @@4:    MOV     ECX,EDX
  7048.         POP     EDX
  7049.         SUB     ECX,EDX
  7050.         SHR     ECX,1
  7051. @@5:    JMP     _WStrFromPWCharLen
  7052. end;
  7053.  
  7054.  
  7055. procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
  7056. asm
  7057.         XOR     ECX,ECX
  7058.         MOV     CL,[EDX]
  7059.         INC     EDX
  7060.         JMP     _WStrFromPCharLen
  7061. end;
  7062.  
  7063.  
  7064. procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  7065. asm
  7066.         PUSH    EDI
  7067.         PUSH    EAX
  7068.         PUSH    ECX
  7069.         MOV     EDI,EDX
  7070.         XOR     EAX,EAX
  7071.         REPNE   SCASB
  7072.         JNE     @@1
  7073.         NOT     ECX
  7074. @@1:    POP     EAX
  7075.         ADD     ECX,EAX
  7076.         POP     EAX
  7077.         POP     EDI
  7078.         JMP     _WStrFromPCharLen
  7079. end;
  7080.  
  7081.  
  7082. procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
  7083. asm
  7084.         PUSH    EDI
  7085.         PUSH    EAX
  7086.         PUSH    ECX
  7087.         MOV     EDI,EDX
  7088.         XOR     EAX,EAX
  7089.         REPNE   SCASW
  7090.         JNE     @@1
  7091.         NOT     ECX
  7092. @@1:    POP     EAX
  7093.         ADD     ECX,EAX
  7094.         POP     EAX
  7095.         POP     EDI
  7096.         JMP     _WStrFromPWCharLen
  7097. end;
  7098.  
  7099.  
  7100. procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
  7101. asm
  7102.         XOR     ECX,ECX
  7103.         TEST    EDX,EDX
  7104.         JE      @@1
  7105.         MOV     ECX,[EDX-4]
  7106. @@1:    JMP     _WStrFromPCharLen
  7107. end;
  7108.  
  7109.  
  7110. procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
  7111. var
  7112.   SourceLen, DestLen: Integer;
  7113.   Buffer: array[0..511] of Char;
  7114. begin
  7115.   SourceLen := Length(Source);
  7116.   if SourceLen >= 255 then SourceLen := 255;
  7117.   if SourceLen = 0 then DestLen := 0 else
  7118.   begin
  7119.     DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen,
  7120.       Buffer, SizeOf(Buffer), nil, nil);
  7121.     if DestLen > MaxLen then DestLen := MaxLen;
  7122.   end;
  7123.   Dest^[0] := Chr(DestLen);
  7124.   if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
  7125. end;
  7126.  
  7127.  
  7128. function _WStrToPWChar(const S: WideString): PWideChar;
  7129. asm
  7130.         TEST    EAX,EAX
  7131.         JE      @@1
  7132.         RET
  7133.         NOP
  7134. @@0:    DW      0
  7135. @@1:    MOV     EAX,OFFSET @@0
  7136. end;
  7137.  
  7138.  
  7139. function _WStrLen(const S: WideString): Integer;
  7140. asm
  7141.         { ->    EAX     Pointer to WideString data }
  7142.         TEST    EAX,EAX
  7143.         JE      @@1
  7144.         MOV     EAX,[EAX-4]
  7145.         SHR     EAX,1
  7146. @@1:
  7147. end;
  7148.  
  7149.  
  7150. procedure _WStrCat(var Dest: WideString; const Source: WideString);
  7151. var
  7152.   DestLen, SourceLen: Integer;
  7153.   NewStr: PWideChar;
  7154. begin
  7155.   SourceLen := Length(Source);
  7156.   if SourceLen <> 0 then
  7157.   begin
  7158.     DestLen := Length(Dest);
  7159.     NewStr := _NewWideString(DestLen + SourceLen);
  7160.     if DestLen > 0 then
  7161.       Move(Pointer(Dest)^, NewStr^, DestLen * 2);
  7162.     Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2);
  7163.     WStrSet(Dest, NewStr);
  7164.   end;
  7165. end;
  7166.  
  7167.  
  7168. procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
  7169. var
  7170.   Source1Len, Source2Len: Integer;
  7171.   NewStr: PWideChar;
  7172. begin
  7173.   Source1Len := Length(Source1);
  7174.   Source2Len := Length(Source2);
  7175.   if (Source1Len <> 0) or (Source2Len <> 0) then
  7176.   begin
  7177.     NewStr := _NewWideString(Source1Len + Source2Len);
  7178.     Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2);
  7179.     Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2);
  7180.     WStrSet(Dest, NewStr);
  7181.   end;
  7182. end;
  7183.  
  7184.  
  7185. procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...};
  7186. asm
  7187.         {     ->EAX = Pointer to dest }
  7188.         {       EDX = number of args (>= 3) }
  7189.         {       [ESP+4], [ESP+8], ... crgCnt WideString arguments }
  7190.  
  7191.         PUSH    EBX
  7192.         PUSH    ESI
  7193.         PUSH    EDX
  7194.         PUSH    EAX
  7195.         MOV     EBX,EDX
  7196.  
  7197.         XOR     EAX,EAX
  7198. @@loop1:
  7199.         MOV     ECX,[ESP+EDX*4+4*4]
  7200.         TEST    ECX,ECX
  7201.         JE      @@1
  7202.         ADD     EAX,[ECX-4]
  7203. @@1:
  7204.         DEC     EDX
  7205.         JNE     @@loop1
  7206.  
  7207.         SHR     EAX,1
  7208.         CALL    _NewWideString
  7209.         PUSH    EAX
  7210.         MOV     ESI,EAX
  7211.  
  7212. @@loop2:
  7213.         MOV     EAX,[ESP+EBX*4+5*4]
  7214.         MOV     EDX,ESI
  7215.         TEST    EAX,EAX
  7216.         JE      @@2
  7217.         MOV     ECX,[EAX-4]
  7218.         ADD     ESI,ECX
  7219.         CALL    Move
  7220. @@2:
  7221.         DEC     EBX
  7222.         JNE     @@loop2
  7223.  
  7224.         POP     EDX
  7225.         POP     EAX
  7226.         CALL    WStrSet
  7227.  
  7228.         POP     EDX
  7229.         POP     ESI
  7230.         POP     EBX
  7231.         POP     EAX
  7232.         LEA     ESP,[ESP+EDX*4]
  7233.         JMP     EAX
  7234. end;
  7235.  
  7236.  
  7237. procedure _WStrCmp{left: WideString; right: WideString};
  7238. asm
  7239. {     ->EAX = Pointer to left string    }
  7240. {       EDX = Pointer to right string   }
  7241.  
  7242.         PUSH    EBX
  7243.         PUSH    ESI
  7244.         PUSH    EDI
  7245.  
  7246.         MOV     ESI,EAX
  7247.         MOV     EDI,EDX
  7248.  
  7249.         CMP     EAX,EDX
  7250.         JE      @@exit
  7251.  
  7252.         TEST    ESI,ESI
  7253.         JE      @@str1null
  7254.  
  7255.         TEST    EDI,EDI
  7256.         JE      @@str2null
  7257.  
  7258.         MOV     EAX,[ESI-4]
  7259.         MOV     EDX,[EDI-4]
  7260.  
  7261.         SUB     EAX,EDX { eax = len1 - len2 }
  7262.         JA      @@skip1
  7263.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  7264.  
  7265. @@skip1:
  7266.         PUSH    EDX
  7267.         SHR     EDX,2
  7268.         JE      @@cmpRest
  7269. @@longLoop:
  7270.         MOV     ECX,[ESI]
  7271.         MOV     EBX,[EDI]
  7272.         CMP     ECX,EBX
  7273.         JNE     @@misMatch
  7274.         DEC     EDX
  7275.         JE      @@cmpRestP4
  7276.         MOV     ECX,[ESI+4]
  7277.         MOV     EBX,[EDI+4]
  7278.         CMP     ECX,EBX
  7279.         JNE     @@misMatch
  7280.         ADD     ESI,8
  7281.         ADD     EDI,8
  7282.         DEC     EDX
  7283.         JNE     @@longLoop
  7284.         JMP     @@cmpRest
  7285. @@cmpRestP4:
  7286.         ADD     ESI,4
  7287.         ADD     EDI,4
  7288. @@cmpRest:
  7289.         POP     EDX
  7290.         AND     EDX,2
  7291.         JE      @@equal
  7292.  
  7293.         MOV     CX,[ESI]
  7294.         MOV     BX,[EDI]
  7295.         CMP     CX,BX
  7296.         JNE     @@exit
  7297.  
  7298. @@equal:
  7299.         ADD     EAX,EAX
  7300.         JMP     @@exit
  7301.  
  7302. @@str1null:
  7303.         MOV     EDX,[EDI-4]
  7304.         SUB     EAX,EDX
  7305.         JMP     @@exit
  7306.  
  7307. @@str2null:
  7308.         MOV     EAX,[ESI-4]
  7309.         SUB     EAX,EDX
  7310.         JMP     @@exit
  7311.  
  7312. @@misMatch:
  7313.         POP     EDX
  7314.         CMP     CX,BX
  7315.         JNE     @@exit
  7316.         SHR     ECX,16
  7317.         SHR     EBX,16
  7318.         CMP     CX,BX
  7319.  
  7320. @@exit:
  7321.         POP     EDI
  7322.         POP     ESI
  7323.         POP     EBX
  7324. end;
  7325.  
  7326.  
  7327. function _NewWideString(Length: Integer): PWideChar;
  7328. asm
  7329.         TEST    EAX,EAX
  7330.         JE      @@1
  7331.         PUSH    EAX
  7332.         PUSH    0
  7333.         CALL    SysAllocStringLen
  7334.         TEST    EAX,EAX
  7335.         JE      WStrError
  7336. @@1:
  7337. end;
  7338.  
  7339.  
  7340. function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
  7341. var
  7342.   L, N: Integer;
  7343. begin
  7344.   L := Length(S);
  7345.   if Index < 1 then Index := 0 else
  7346.   begin
  7347.     Dec(Index);
  7348.     if Index > L then Index := L;
  7349.   end;
  7350.   if Count < 0 then N := 0 else
  7351.   begin
  7352.     N := L - Index;
  7353.     if N > Count then N := Count;
  7354.   end;
  7355.   _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N);
  7356. end;
  7357.  
  7358.  
  7359. procedure _WStrDelete(var S: WideString; Index, Count: Integer);
  7360. var
  7361.   L, N: Integer;
  7362.   NewStr: PWideChar;
  7363. begin
  7364.   L := Length(S);
  7365.   if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then
  7366.   begin
  7367.     Dec(Index);
  7368.     N := L - Index - Count;
  7369.     if N < 0 then N := 0;
  7370.     if (Index = 0) and (N = 0) then NewStr := nil else
  7371.     begin
  7372.       NewStr := _NewWideString(Index + N);
  7373.       if Index > 0 then
  7374.         Move(Pointer(S)^, NewStr^, Index * 2);
  7375.       if N > 0 then
  7376.         Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2);
  7377.     end;
  7378.     WStrSet(S, NewStr);
  7379.   end;
  7380. end;
  7381.  
  7382.  
  7383. procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
  7384. var
  7385.   SourceLen, DestLen: Integer;
  7386.   NewStr: PWideChar;
  7387. begin
  7388.   SourceLen := Length(Source);
  7389.   if SourceLen > 0 then
  7390.   begin
  7391.     DestLen := Length(Dest);
  7392.     if Index < 1 then Index := 0 else
  7393.     begin
  7394.       Dec(Index);
  7395.       if Index > DestLen then Index := DestLen;
  7396.     end;
  7397.     NewStr := _NewWideString(DestLen + SourceLen);
  7398.     if Index > 0 then
  7399.       Move(Pointer(Dest)^, NewStr^, Index * 2);
  7400.     Move(Pointer(Source)^, NewStr[Index], SourceLen * 2);
  7401.     if Index < DestLen then
  7402.       Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen],
  7403.         (DestLen - Index) * 2);
  7404.     WStrSet(Dest, NewStr);
  7405.   end;
  7406. end;
  7407.  
  7408.  
  7409. procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
  7410. asm
  7411. {     ->EAX     Pointer to substr               }
  7412. {       EDX     Pointer to string               }
  7413. {     <-EAX     Position of substr in s or 0    }
  7414.  
  7415.         TEST    EAX,EAX
  7416.         JE      @@noWork
  7417.  
  7418.         TEST    EDX,EDX
  7419.         JE      @@stringEmpty
  7420.  
  7421.         PUSH    EBX
  7422.         PUSH    ESI
  7423.         PUSH    EDI
  7424.  
  7425.         MOV     ESI,EAX                         { Point ESI to substr           }
  7426.         MOV     EDI,EDX                         { Point EDI to s                }
  7427.  
  7428.         MOV     ECX,[EDI-4]                     { ECX = Length(s)               }
  7429.         SHR     ECX,1
  7430.  
  7431.         PUSH    EDI                             { remember s position to calculate index        }
  7432.  
  7433.         MOV     EDX,[ESI-4]                     { EDX = Length(substr)          }
  7434.         SHR     EDX,1
  7435.  
  7436.         DEC     EDX                             { EDX = Length(substr) - 1              }
  7437.         JS      @@fail                          { < 0 ? return 0                        }
  7438.         MOV     AX,[ESI]                        { AL = first char of substr             }
  7439.         ADD     ESI,2                           { Point ESI to 2'nd char of substr      }
  7440.  
  7441.         SUB     ECX,EDX                         { #positions in s to look at    }
  7442.                                                 { = Length(s) - Length(substr) + 1      }
  7443.         JLE     @@fail
  7444. @@loop:
  7445.         REPNE   SCASW
  7446.         JNE     @@fail
  7447.         MOV     EBX,ECX                         { save outer loop counter               }
  7448.         PUSH    ESI                             { save outer loop substr pointer        }
  7449.         PUSH    EDI                             { save outer loop s pointer             }
  7450.  
  7451.         MOV     ECX,EDX
  7452.         REPE    CMPSW
  7453.         POP     EDI                             { restore outer loop s pointer  }
  7454.         POP     ESI                             { restore outer loop substr pointer     }
  7455.         JE      @@found
  7456.         MOV     ECX,EBX                         { restore outer loop counter    }
  7457.         JMP     @@loop
  7458.  
  7459. @@fail:
  7460.         POP     EDX                             { get rid of saved s pointer    }
  7461.         XOR     EAX,EAX
  7462.         JMP     @@exit
  7463.  
  7464. @@stringEmpty:
  7465.         XOR     EAX,EAX
  7466.         JMP     @@noWork
  7467.  
  7468. @@found:
  7469.         POP     EDX                             { restore pointer to first char of s    }
  7470.         MOV     EAX,EDI                         { EDI points of char after match        }
  7471.         SUB     EAX,EDX                         { the difference is the correct index   }
  7472.         SHR     EAX,1
  7473. @@exit:
  7474.         POP     EDI
  7475.         POP     ESI
  7476.         POP     EBX
  7477. @@noWork:
  7478. end;
  7479.  
  7480.  
  7481. procedure _WStrSetLength(var S: WideString; NewLength: Integer);
  7482. var
  7483.   NewStr: PWideChar;
  7484.   Count: Integer;
  7485. begin
  7486.   NewStr := nil;
  7487.   if NewLength > 0 then
  7488.   begin
  7489.     NewStr := _NewWideString(NewLength);
  7490.     Count := Length(S);
  7491.     if Count > 0 then
  7492.     begin
  7493.       if Count > NewLength then Count := NewLength;
  7494.       Move(Pointer(S)^, NewStr^, Count * 2);
  7495.     end;
  7496.   end;
  7497.   WStrSet(S, NewStr);
  7498. end;
  7499.  
  7500.  
  7501. function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
  7502. var
  7503.   P: PWideChar;
  7504. begin
  7505.   _WStrFromPWCharLen(Result, nil, Count);
  7506.   P := Pointer(Result);
  7507.   while Count > 0 do
  7508.   begin
  7509.     Dec(Count);
  7510.     P[Count] := Ch;
  7511.   end;
  7512. end;
  7513.  
  7514.  
  7515. procedure _WStrAddRef{var str: WideString};
  7516. asm
  7517.         MOV     EDX,[EAX]
  7518.         TEST    EDX,EDX
  7519.         JE      @@1
  7520.         PUSH    EAX
  7521.         MOV     ECX,[EDX-4]
  7522.         SHR     ECX,1
  7523.         PUSH    ECX
  7524.         PUSH    EDX
  7525.         CALL    SysAllocStringLen
  7526.         POP     EDX
  7527.         TEST    EAX,EAX
  7528.         JE      WStrError
  7529.         MOV     [EDX],EAX
  7530. @@1:
  7531. end;
  7532.  
  7533.  
  7534. procedure       _InitializeRecord{ p: Pointer; typeInfo: Pointer };
  7535. asm
  7536.         { ->    EAX pointer to record to be initialized }
  7537.         {       EDX pointer to type info                }
  7538.  
  7539.         XOR     ECX,ECX
  7540.  
  7541.         PUSH    EBX
  7542.         MOV     CL,[EDX+1]                  { type name length }
  7543.  
  7544.         PUSH    ESI
  7545.         PUSH    EDI
  7546.  
  7547.         MOV     EBX,EAX
  7548.         LEA     ESI,[EDX+ECX+2+8]           { address of destructable fields }
  7549.         MOV     EDI,[EDX+ECX+2+4]           { number of destructable fields }
  7550.  
  7551. @@loop:
  7552.  
  7553.         MOV     EDX,[ESI]
  7554.         MOV     EAX,[ESI+4]
  7555.         ADD     EAX,EBX
  7556.         MOV     EDX,[EDX]
  7557.         CALL    _Initialize
  7558.         ADD     ESI,8
  7559.         DEC     EDI
  7560.         JG      @@loop
  7561.  
  7562.         POP     EDI
  7563.         POP     ESI
  7564.         POP     EBX
  7565. end;
  7566.  
  7567.  
  7568. const
  7569.   tkLString   = 10;
  7570.   tkWString   = 11;
  7571.   tkVariant   = 12;
  7572.   tkArray     = 13;
  7573.   tkRecord    = 14;
  7574.   tkInterface = 15;
  7575.   tkDynArray  = 17;
  7576.  
  7577. procedure       _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7578. asm
  7579.         { ->    EAX     pointer to data to be initialized       }
  7580.         {       EDX     pointer to type info describing data    }
  7581.         {       ECX number of elements of that type             }
  7582.  
  7583.         PUSH    EBX
  7584.         PUSH    ESI
  7585.         PUSH    EDI
  7586.         MOV     EBX,EAX
  7587.         MOV     ESI,EDX
  7588.         MOV     EDI,ECX
  7589.  
  7590.         XOR     EDX,EDX
  7591.         MOV     AL,[ESI]
  7592.         MOV     DL,[ESI+1]
  7593.         XOR     ECX,ECX
  7594.  
  7595.         CMP     AL,tkLString
  7596.         JE      @@LString
  7597.         CMP     AL,tkWString
  7598.         JE      @@WString
  7599.         CMP     AL,tkVariant
  7600.         JE      @@Variant
  7601.         CMP     AL,tkArray
  7602.         JE      @@Array
  7603.         CMP     AL,tkRecord
  7604.         JE      @@Record
  7605.         CMP     AL,tkInterface
  7606.   JE      @@Interface
  7607.   CMP AL,tkDynArray
  7608.   JE  @@DynArray
  7609.         MOV     AL,reInvalidPtr
  7610.         POP     EDI
  7611.         POP     ESI
  7612.         POP     EBX
  7613.         JMP     Error
  7614.  
  7615. @@LString:
  7616. @@WString:
  7617. @@Interface:
  7618. @@DynArray:
  7619.         MOV     [EBX],ECX
  7620.         ADD     EBX,4
  7621.         DEC     EDI
  7622.         JG      @@LString
  7623.         JMP     @@exit
  7624.  
  7625. @@Variant:
  7626.         MOV     [EBX   ],ECX
  7627.         MOV     [EBX+ 4],ECX
  7628.         MOV     [EBX+ 8],ECX
  7629.         MOV     [EBX+12],ECX
  7630.         ADD     EBX,16
  7631.         DEC     EDI
  7632.         JG      @@Variant
  7633.         JMP     @@exit
  7634.  
  7635. @@Array:
  7636.         PUSH    EBP
  7637.         MOV     EBP,EDX
  7638. @@ArrayLoop:
  7639.         MOV     EDX,[ESI+EBP+2+8]
  7640.         MOV     EAX,EBX
  7641.         ADD     EBX,[ESI+EBP+2]
  7642.         MOV     ECX,[ESI+EBP+2+4]
  7643.         MOV     EDX,[EDX]
  7644.         CALL    _InitializeArray
  7645.         DEC     EDI
  7646.         JG      @@ArrayLoop
  7647.         POP     EBP
  7648.         JMP     @@exit
  7649.  
  7650. @@Record:
  7651.         PUSH    EBP
  7652.         MOV     EBP,EDX
  7653. @@RecordLoop:
  7654.         MOV     EAX,EBX
  7655.         ADD     EBX,[ESI+EBP+2]
  7656.         MOV     EDX,ESI
  7657.         CALL    _InitializeRecord
  7658.         DEC     EDI
  7659.         JG      @@RecordLoop
  7660.         POP     EBP
  7661.  
  7662. @@exit:
  7663.  
  7664.         POP     EDI
  7665.         POP     ESI
  7666.     POP EBX
  7667. end;
  7668.  
  7669.  
  7670. procedure       _Initialize{ p: Pointer; typeInfo: Pointer};
  7671. asm
  7672.         MOV     ECX,1
  7673.         JMP     _InitializeArray
  7674. end;
  7675.  
  7676. procedure       _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
  7677. asm
  7678.         { ->    EAX pointer to record to be finalized   }
  7679.         {       EDX pointer to type info                }
  7680.  
  7681.         XOR     ECX,ECX
  7682.  
  7683.         PUSH    EBX
  7684.         MOV     CL,[EDX+1]
  7685.  
  7686.         PUSH    ESI
  7687.         PUSH    EDI
  7688.  
  7689.         MOV     EBX,EAX
  7690.         LEA     ESI,[EDX+ECX+2+8]
  7691.         MOV     EDI,[EDX+ECX+2+4]
  7692.  
  7693. @@loop:
  7694.  
  7695.         MOV     EDX,[ESI]
  7696.         MOV     EAX,[ESI+4]
  7697.         ADD     EAX,EBX
  7698.         MOV     EDX,[EDX]
  7699.         CALL    _Finalize
  7700.         ADD     ESI,8
  7701.         DEC     EDI
  7702.         JG      @@loop
  7703.  
  7704.         MOV     EAX,EBX
  7705.  
  7706.         POP     EDI
  7707.         POP     ESI
  7708.         POP     EBX
  7709. end;
  7710.  
  7711.  
  7712. procedure       _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7713. asm
  7714.         { ->    EAX     pointer to data to be finalized         }
  7715.         {       EDX     pointer to type info describing data    }
  7716.         {       ECX number of elements of that type             }
  7717.  
  7718.         CMP     ECX, 0                        { no array -> nop }
  7719.         JE      @@zerolength
  7720.  
  7721.         PUSH    EAX
  7722.         PUSH    EBX
  7723.         PUSH    ESI
  7724.         PUSH    EDI
  7725.         MOV     EBX,EAX
  7726.         MOV     ESI,EDX
  7727.         MOV     EDI,ECX
  7728.  
  7729.         XOR     EDX,EDX
  7730.         MOV     AL,[ESI]
  7731.         MOV     DL,[ESI+1]
  7732.  
  7733.         CMP     AL,tkLString
  7734.         JE      @@LString
  7735.  
  7736.         CMP     AL,tkWString
  7737.         JE      @@WString
  7738.  
  7739.         CMP     AL,tkVariant
  7740.         JE      @@Variant
  7741.  
  7742.         CMP     AL,tkArray
  7743.         JE      @@Array
  7744.  
  7745.         CMP     AL,tkRecord
  7746.         JE      @@Record
  7747.  
  7748.         CMP     AL,tkInterface
  7749.         JE      @@Interface
  7750.  
  7751.         CMP     AL,tkDynArray
  7752.         JE      @@DynArray
  7753.         POP     EDI
  7754.         POP     ESI
  7755.         POP     EBX
  7756.         POP      EAX
  7757.         MOV     AL,reInvalidPtr
  7758.         JMP     Error
  7759.  
  7760. @@LString:
  7761.         CMP     ECX,1
  7762.         MOV     EAX,EBX
  7763.         JG      @@LStringArray
  7764.         CALL    _LStrClr
  7765.         JMP     @@exit
  7766. @@LStringArray:
  7767.         MOV     EDX,ECX
  7768.         CALL    _LStrArrayClr
  7769.         JMP     @@exit
  7770.  
  7771. @@WString:
  7772.         CMP     ECX,1
  7773.         MOV     EAX,EBX
  7774.         JG      @@WStringArray
  7775.         CALL    _WStrClr
  7776.         JMP     @@exit
  7777. @@WStringArray:
  7778.         MOV     EDX,ECX
  7779.         CALL    _WStrArrayClr
  7780.         JMP     @@exit
  7781.  
  7782. @@Variant:
  7783.         MOV     EAX,EBX
  7784.         ADD     EBX,16
  7785.         CALL    _VarClr
  7786.         DEC     EDI
  7787.         JG      @@Variant
  7788.         JMP     @@exit
  7789.  
  7790. @@Array:
  7791.         PUSH    EBP
  7792.         MOV     EBP,EDX
  7793. @@ArrayLoop:
  7794.         MOV     EDX,[ESI+EBP+2+8]
  7795.         MOV     EAX,EBX
  7796.         ADD     EBX,[ESI+EBP+2]
  7797.         MOV     ECX,[ESI+EBP+2+4]
  7798.         MOV     EDX,[EDX]
  7799.         CALL    _FinalizeArray
  7800.         DEC     EDI
  7801.         JG      @@ArrayLoop
  7802.         POP     EBP
  7803.         JMP     @@exit
  7804.  
  7805. @@Record:
  7806.         PUSH    EBP
  7807.         MOV     EBP,EDX
  7808. @@RecordLoop:
  7809.         { inv: EDI = number of array elements to finalize }
  7810.  
  7811.         MOV     EAX,EBX
  7812.         ADD     EBX,[ESI+EBP+2]
  7813.         MOV     EDX,ESI
  7814.         CALL    _FinalizeRecord
  7815.         DEC     EDI
  7816.         JG      @@RecordLoop
  7817.         POP     EBP
  7818.         JMP     @@exit
  7819.  
  7820. @@Interface:
  7821.         MOV     EAX,EBX
  7822.         ADD     EBX,4
  7823.         CALL    _IntfClear
  7824.         DEC     EDI
  7825.         JG      @@Interface
  7826.         JMP     @@exit
  7827.  
  7828. @@DynArray:
  7829.         MOV     EAX,EBX
  7830.         MOV     EDX,ESI
  7831.         ADD     EBX,4
  7832.         CALL    _DynArrayClear
  7833.         DEC     EDI
  7834.         JG      @@DynArray
  7835.  
  7836. @@exit:
  7837.  
  7838.         POP     EDI
  7839.         POP     ESI
  7840.         POP     EBX
  7841.         POP     EAX
  7842. @@zerolength:
  7843. end;
  7844.  
  7845.  
  7846. procedure       _Finalize{ p: Pointer; typeInfo: Pointer};
  7847. asm
  7848.         MOV     ECX,1
  7849.         JMP     _FinalizeArray
  7850. end;
  7851.  
  7852. procedure       _AddRefRecord{ p: Pointer; typeInfo: Pointer };
  7853. asm
  7854.         { ->    EAX pointer to record to be referenced  }
  7855.         {       EDX pointer to type info        }
  7856.  
  7857.         XOR     ECX,ECX
  7858.  
  7859.         PUSH    EBX
  7860.         MOV     CL,[EDX+1]
  7861.  
  7862.         PUSH    ESI
  7863.         PUSH    EDI
  7864.  
  7865.         MOV     EBX,EAX
  7866.         LEA     ESI,[EDX+ECX+2+8]
  7867.         MOV     EDI,[EDX+ECX+2+4]
  7868.  
  7869. @@loop:
  7870.  
  7871.         MOV     EDX,[ESI]
  7872.         MOV     EAX,[ESI+4]
  7873.         ADD     EAX,EBX
  7874.         MOV     EDX,[EDX]
  7875.         CALL    _AddRef
  7876.         ADD     ESI,8
  7877.         DEC     EDI
  7878.         JG      @@loop
  7879.  
  7880.         POP     EDI
  7881.         POP     ESI
  7882.         POP     EBX
  7883. end;
  7884.  
  7885.  
  7886. procedure       _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7887. asm
  7888.         { ->    EAX     pointer to data to be referenced        }
  7889.         {       EDX     pointer to type info describing data    }
  7890.         {       ECX number of elements of that type             }
  7891.  
  7892.         PUSH    EBX
  7893.         PUSH    ESI
  7894.         PUSH    EDI
  7895.         MOV     EBX,EAX
  7896.         MOV     ESI,EDX
  7897.         MOV     EDI,ECX
  7898.  
  7899.         XOR     EDX,EDX
  7900.         MOV     AL,[ESI]
  7901.         MOV     DL,[ESI+1]
  7902.  
  7903.         CMP     AL,tkLString
  7904.         JE      @@LString
  7905.         CMP     AL,tkWString
  7906.         JE      @@WString
  7907.         CMP     AL,tkVariant
  7908.         JE      @@Variant
  7909.         CMP     AL,tkArray
  7910.         JE      @@Array
  7911.         CMP     AL,tkRecord
  7912.         JE      @@Record
  7913.         CMP     AL,tkInterface
  7914.         JE      @@Interface
  7915.         CMP     AL,tkDynArray
  7916.         JE      @@DynArray
  7917.         MOV     AL,reInvalidPtr
  7918.         POP     EDI
  7919.         POP     ESI
  7920.         POP     EBX
  7921.         JMP     Error
  7922.  
  7923. @@LString:
  7924.         MOV     EAX,[EBX]
  7925.         ADD     EBX,4
  7926.         CALL    _LStrAddRef
  7927.         DEC     EDI
  7928.         JG      @@LString
  7929.         JMP     @@exit
  7930.  
  7931. @@WString:
  7932.         MOV     EAX,EBX
  7933.         ADD     EBX,4
  7934.         CALL    _WStrAddRef
  7935.         DEC     EDI
  7936.         JG      @@WString
  7937.         JMP     @@exit
  7938.  
  7939. @@Variant:
  7940.         MOV     EAX,EBX
  7941.         ADD     EBX,16
  7942.         CALL    _VarAddRef
  7943.         DEC     EDI
  7944.         JG      @@Variant
  7945.         JMP     @@exit
  7946.  
  7947. @@Array:
  7948.         PUSH    EBP
  7949.         MOV     EBP,EDX
  7950. @@ArrayLoop:
  7951.         MOV     EDX,[ESI+EBP+2+8]
  7952.         MOV     EAX,EBX
  7953.         ADD     EBX,[ESI+EBP+2]
  7954.         MOV     ECX,[ESI+EBP+2+4]
  7955.         MOV     EDX,[EDX]
  7956.         CALL    _AddRefArray
  7957.         DEC     EDI
  7958.         JG      @@ArrayLoop
  7959.         POP     EBP
  7960.         JMP     @@exit
  7961.  
  7962. @@Record:
  7963.         PUSH    EBP
  7964.         MOV     EBP,EDX
  7965. @@RecordLoop:
  7966.         MOV     EAX,EBX
  7967.         ADD     EBX,[ESI+EBP+2]
  7968.         MOV     EDX,ESI
  7969.         CALL    _AddRefRecord
  7970.         DEC     EDI
  7971.         JG      @@RecordLoop
  7972.         POP     EBP
  7973.         JMP     @@exit
  7974.  
  7975. @@Interface:
  7976.         MOV     EAX,[EBX]
  7977.         ADD     EBX,4
  7978.         CALL    _IntfAddRef
  7979.         DEC     EDI
  7980.         JG      @@Interface
  7981.         JMP     @@exit
  7982.  
  7983. @@DynArray:
  7984.         MOV     EAX,[EBX]
  7985.         ADD     EBX,4
  7986.         CALL    _DynArrayAddRef
  7987.         DEC     EDI
  7988.         JG      @@DynArray
  7989. @@exit:
  7990.  
  7991.         POP     EDI
  7992.         POP     ESI
  7993.         POP     EBX
  7994. end;
  7995.  
  7996.  
  7997. procedure       _AddRef{ p: Pointer; typeInfo: Pointer};
  7998. asm
  7999.         MOV     ECX,1
  8000.         JMP     _AddRefArray
  8001. end;
  8002.  
  8003.  
  8004. procedure       _CopyRecord{ dest, source, typeInfo: Pointer };
  8005. asm
  8006.         { ->    EAX pointer to dest             }
  8007.         {       EDX pointer to source           }
  8008.         {       ECX pointer to typeInfo         }
  8009.  
  8010.         PUSH    EBX
  8011.         PUSH    ESI
  8012.         PUSH    EDI
  8013.         PUSH    EBP
  8014.  
  8015.         MOV     EBX,EAX
  8016.         MOV     ESI,EDX
  8017.  
  8018.         XOR     EAX,EAX
  8019.         MOV     AL,[ECX+1]
  8020.  
  8021.         LEA     EDI,[ECX+EAX+2+8]
  8022.         MOV     EBP,[EDI-4]
  8023.         XOR     EAX,EAX
  8024.         MOV     ECX,[EDI-8]
  8025.         PUSH    ECX
  8026. @@loop:
  8027.         MOV     ECX,[EDI+4]
  8028.         SUB     ECX,EAX
  8029.         JLE     @@nomove1
  8030.         MOV     EDX,EAX
  8031.         ADD     EAX,ESI
  8032.         ADD     EDX,EBX
  8033.         CALL    Move
  8034. @@noMove1:
  8035.         MOV     EAX,[EDI+4]
  8036.  
  8037.         MOV     EDX,[EDI]
  8038.         MOV     EDX,[EDX]
  8039.         MOV     CL,[EDX]
  8040.  
  8041.         CMP     CL,tkLString
  8042.         JE      @@LString
  8043.         CMP     CL,tkWString
  8044.         JE      @@WString
  8045.         CMP     CL,tkVariant
  8046.         JE      @@Variant
  8047.         CMP     CL,tkArray
  8048.         JE      @@Array
  8049.         CMP     CL,tkRecord
  8050.         JE      @@Record
  8051.         CMP     CL,tkInterface
  8052.         JE      @@Interface
  8053.         CMP     CL,tkDynArray
  8054.         JE      @@DynArray
  8055.         MOV     AL,reInvalidPtr
  8056.         POP     EBP
  8057.         POP     EDI
  8058.         POP     ESI
  8059.         POP     EBX
  8060.         JMP     Error
  8061.  
  8062. @@LString:
  8063.         MOV     EDX,[ESI+EAX]
  8064.         ADD     EAX,EBX
  8065.         CALL    _LStrAsg
  8066.         MOV     EAX,4
  8067.         JMP     @@common
  8068.  
  8069. @@WString:
  8070.         MOV     EDX,[ESI+EAX]
  8071.         ADD     EAX,EBX
  8072.         CALL    _WStrAsg
  8073.         MOV     EAX,4
  8074.         JMP     @@common
  8075.  
  8076. @@Variant:
  8077.         LEA     EDX,[ESI+EAX]
  8078.         ADD     EAX,EBX
  8079.         CALL    _VarCopy
  8080.         MOV     EAX,16
  8081.         JMP     @@common
  8082.  
  8083. @@Array:
  8084.         XOR     ECX,ECX
  8085.         MOV     CL,[EDX+1]
  8086.         PUSH    dword ptr [EDX+ECX+2]
  8087.         PUSH    dword ptr [EDX+ECX+2+4]
  8088.         MOV     ECX,[EDX+ECX+2+8]
  8089.         MOV     ECX,[ECX]
  8090.         LEA     EDX,[ESI+EAX]
  8091.         ADD     EAX,EBX
  8092.         CALL    _CopyArray
  8093.         POP     EAX
  8094.         JMP     @@common
  8095.  
  8096. @@Record:
  8097.         XOR     ECX,ECX
  8098.         MOV     CL,[EDX+1]
  8099.         MOV     ECX,[EDX+ECX+2]
  8100.         PUSH    ECX
  8101.         MOV     ECX,EDX
  8102.         LEA     EDX,[ESI+EAX]
  8103.         ADD     EAX,EBX
  8104.         CALL    _CopyRecord
  8105.         POP     EAX
  8106.         JMP     @@common
  8107.  
  8108. @@Interface:
  8109.         MOV     EDX,[ESI+EAX]
  8110.         ADD     EAX,EBX
  8111.         CALL    _IntfCopy
  8112.         MOV     EAX,4
  8113.         JMP     @@common
  8114.  
  8115. @@DynArray:
  8116.         MOV     ECX,EDX
  8117.         MOV     EDX,[ESI+EAX]
  8118.         ADD     EAX,EBX
  8119.         CALL    _DynArrayAsg
  8120.         MOV     EAX,4
  8121.  
  8122. @@common:
  8123.         ADD     EAX,[EDI+4]
  8124.         ADD     EDI,8
  8125.         DEC     EBP
  8126.         JNZ     @@loop
  8127.  
  8128.         POP     ECX
  8129.         SUB     ECX,EAX
  8130.         JLE     @@noMove2
  8131.         LEA     EDX,[EBX+EAX]
  8132.         ADD     EAX,ESI
  8133.         CALL    Move
  8134. @@noMove2:
  8135.  
  8136.         POP     EBP
  8137.         POP     EDI
  8138.         POP     ESI
  8139.         POP     EBX
  8140. end;
  8141.  
  8142.  
  8143. procedure       _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer };
  8144. asm
  8145.         { ->    EAX pointer to dest             }
  8146.         {       EDX pointer to source           }
  8147.         {       ECX offset of vmt in object     }
  8148.         {       [ESP+4] pointer to typeInfo     }
  8149.  
  8150.         ADD     ECX,EAX                         { pointer to dest vmt }
  8151.         PUSH    dword ptr [ECX]                 { save dest vmt }
  8152.         PUSH    ECX
  8153.         MOV     ECX,[ESP+4+4+4]
  8154.         CALL    _CopyRecord
  8155.         POP     ECX
  8156.         POP     dword ptr [ECX]                 { restore dest vmt }
  8157.         RET     4
  8158.  
  8159. end;
  8160.  
  8161. procedure       _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer };
  8162. asm
  8163.         { ->    EAX pointer to dest             }
  8164.         {       EDX pointer to source           }
  8165.         {       ECX pointer to typeInfo         }
  8166.         {       [ESP+4] count                   }
  8167.         PUSH    EBX
  8168.         PUSH    ESI
  8169.         PUSH    EDI
  8170.         PUSH    EBP
  8171.  
  8172.         MOV     EBX,EAX
  8173.         MOV     ESI,EDX
  8174.         MOV     EDI,ECX
  8175.         MOV     EBP,[ESP+4+4*4]
  8176.  
  8177.         MOV     CL,[EDI]
  8178.  
  8179.         CMP     CL,tkLString
  8180.         JE      @@LString
  8181.         CMP     CL,tkWString
  8182.         JE      @@WString
  8183.         CMP     CL,tkVariant
  8184.         JE      @@Variant
  8185.         CMP     CL,tkArray
  8186.         JE      @@Array
  8187.         CMP     CL,tkRecord
  8188.         JE      @@Record
  8189.         CMP     CL,tkInterface
  8190.         JE      @@Interface
  8191.         CMP     CL,tkDynArray
  8192.         JE      @@DynArray
  8193.         MOV     AL,reInvalidPtr
  8194.         POP     EBP
  8195.         POP     EDI
  8196.         POP     ESI
  8197.         POP     EBX
  8198.         JMP     Error
  8199.  
  8200. @@LString:
  8201.         MOV     EAX,EBX
  8202.         MOV     EDX,[ESI]
  8203.         CALL    _LStrAsg
  8204.         ADD     EBX,4
  8205.         ADD     ESI,4
  8206.         DEC     EBP
  8207.         JNE     @@LString
  8208.         JMP     @@exit
  8209.  
  8210. @@WString:
  8211.         MOV     EAX,EBX
  8212.         MOV     EDX,[ESI]
  8213.         CALL    _WStrAsg
  8214.         ADD     EBX,4
  8215.         ADD     ESI,4
  8216.         DEC     EBP
  8217.         JNE     @@WString
  8218.         JMP     @@exit
  8219.  
  8220. @@Variant:
  8221.         MOV     EAX,EBX
  8222.         MOV     EDX,ESI
  8223.         CALL    _VarCopy
  8224.         ADD     EBX,16
  8225.         ADD     ESI,16
  8226.         DEC     EBP
  8227.         JNE     @@Variant
  8228.         JMP     @@exit
  8229.  
  8230. @@Array:
  8231.         XOR     ECX,ECX
  8232.         MOV     CL,[EDI+1]
  8233.         LEA     EDI,[EDI+ECX+2]
  8234. @@ArrayLoop:
  8235.         MOV     EAX,EBX
  8236.         MOV     EDX,ESI
  8237.         MOV     ECX,[EDI+8]
  8238.         PUSH    dword ptr [EDI+4]
  8239.         CALL    _CopyArray
  8240.         ADD     EBX,[EDI]
  8241.         ADD     ESI,[EDI]
  8242.         DEC     EBP
  8243.         JNE     @@ArrayLoop
  8244.         JMP     @@exit
  8245.  
  8246. @@Record:
  8247.         MOV     EAX,EBX
  8248.         MOV     EDX,ESI
  8249.         MOV     ECX,EDI
  8250.         CALL    _CopyRecord
  8251.         XOR     EAX,EAX
  8252.         MOV     AL,[EDI+1]
  8253.         ADD     EBX,[EDI+EAX+2]
  8254.         ADD     ESI,[EDI+EAX+2]
  8255.         DEC     EBP
  8256.         JNE     @@Record
  8257.         JMP     @@exit
  8258.  
  8259. @@Interface:
  8260.         MOV     EAX,EBX
  8261.         MOV     EDX,[ESI]
  8262.         CALL    _IntfCopy
  8263.         ADD     EBX,4
  8264.         ADD     ESI,4
  8265.         DEC     EBP
  8266.         JNE     @@Interface
  8267.         JMP     @@exit
  8268.  
  8269. @@DynArray:
  8270.         MOV     EAX,EBX
  8271.         MOV     EDX,[ESI]
  8272.         MOV     ECX,EDI
  8273.         CALL    _DynArrayAsg
  8274.         ADD     EBX,4
  8275.         ADD     ESI,4
  8276.         DEC     EBP
  8277.         JNE     @@DynArray
  8278.  
  8279. @@exit:
  8280.         POP     EBP
  8281.         POP     EDI
  8282.         POP     ESI
  8283.         POP     EBX
  8284.         RET     4
  8285. end;
  8286.  
  8287.  
  8288. procedure       _New{ size: Longint; typeInfo: Pointer};
  8289. asm
  8290.         { ->    EAX size of object to allocate  }
  8291.         {       EDX pointer to typeInfo         }
  8292.  
  8293.         PUSH    EDX
  8294.         CALL    _GetMem
  8295.         POP     EDX
  8296.         TEST    EAX,EAX
  8297.         JE      @@exit
  8298.         PUSH    EAX
  8299.         CALL    _Initialize
  8300.         POP     EAX
  8301. @@exit:
  8302. end;
  8303.  
  8304. procedure       _Dispose{ p: Pointer; typeInfo: Pointer};
  8305. asm
  8306.         { ->    EAX     Pointer to object to be disposed        }
  8307.         {       EDX     Pointer to type info            }
  8308.  
  8309.         PUSH    EAX
  8310.         CALL    _Finalize
  8311.         POP     EAX
  8312.         CALL    _FreeMem
  8313. end;
  8314.  
  8315. { ----------------------------------------------------- }
  8316. {       Wide character support                          }
  8317. { ----------------------------------------------------- }
  8318.  
  8319. function WideCharToString(Source: PWideChar): string;
  8320. begin
  8321.   WideCharToStrVar(Source, Result);
  8322. end;
  8323.  
  8324. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  8325. begin
  8326.   WideCharLenToStrVar(Source, SourceLen, Result);
  8327. end;
  8328.  
  8329. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  8330. var
  8331.   SourceLen: Integer;
  8332. begin
  8333.   SourceLen := 0;
  8334.   while Source[SourceLen] <> #0 do Inc(SourceLen);
  8335.   WideCharLenToStrVar(Source, SourceLen, Dest);
  8336. end;
  8337.  
  8338. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  8339.   var Dest: string);
  8340. var
  8341.   DestLen: Integer;
  8342.   Buffer: array[0..2047] of Char;
  8343. begin
  8344.   if SourceLen = 0 then
  8345.     Dest := ''
  8346.   else
  8347.     if SourceLen < SizeOf(Buffer) div 2 then
  8348.       SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
  8349.         Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
  8350.     else
  8351.     begin
  8352.       DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
  8353.         nil, 0, nil, nil);
  8354.       SetString(Dest, nil, DestLen);
  8355.       WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
  8356.         DestLen, nil, nil);
  8357.     end;
  8358. end;
  8359.  
  8360. function StringToWideChar(const Source: string; Dest: PWideChar;
  8361.   DestSize: Integer): PWideChar;
  8362. begin
  8363.   Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
  8364.     Dest, DestSize - 1)] := #0;
  8365.   Result := Dest;
  8366. end;
  8367.  
  8368. { ----------------------------------------------------- }
  8369. {       OLE string support                              }
  8370. { ----------------------------------------------------- }
  8371.  
  8372. function OleStrToString(Source: PWideChar): string;
  8373. begin
  8374.   OleStrToStrVar(Source, Result);
  8375. end;
  8376.  
  8377. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  8378. begin
  8379.   WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest);
  8380. end;
  8381.  
  8382. function StringToOleStr(const Source: string): PWideChar;
  8383. var
  8384.   SourceLen, ResultLen: Integer;
  8385.   Buffer: array[0..1023] of WideChar;
  8386. begin
  8387.   SourceLen := Length(Source);
  8388.   if Length(Source) < SizeOf(Buffer) div 2 then
  8389.     Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
  8390.       PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
  8391.   else
  8392.   begin
  8393.     ResultLen := MultiByteToWideChar(0, 0,
  8394.       Pointer(Source), SourceLen, nil, 0);
  8395.     Result := SysAllocStringLen(nil, ResultLen);
  8396.     MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
  8397.       Result, ResultLen);
  8398.   end;
  8399. end;
  8400.  
  8401. { ----------------------------------------------------- }
  8402. {       Variant support                                 }
  8403. { ----------------------------------------------------- }
  8404.  
  8405. type
  8406.   TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);
  8407.  
  8408. const
  8409.   varLast = varByte;
  8410.  
  8411. const
  8412.   BaseTypeMap: array[0..varLast] of TBaseType = (
  8413.     btErr,  { varEmpty    }
  8414.     btNul,  { varNull     }
  8415.     btInt,  { varSmallint }
  8416.     btInt,  { varInteger  }
  8417.     btFlt,  { varSingle   }
  8418.     btFlt,  { varDouble   }
  8419.     btCur,  { varCurrency }
  8420.     btDat,  { varDate     }
  8421.     btStr,  { varOleStr   }
  8422.     btErr,  { varDispatch }
  8423.     btErr,  { varError    }
  8424.     btBol,  { varBoolean  }
  8425.     btErr,  { varVariant  }
  8426.     btErr,  { varUnknown  }
  8427.     btErr,  { vt_decimal  }
  8428.     btErr,  { undefined   }
  8429.     btErr,  { vt_i1       }
  8430.     btInt); { varByte     }
  8431.  
  8432. const
  8433.   OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
  8434.     (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
  8435.     (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
  8436.     (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
  8437.     (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
  8438.     (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
  8439.     (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
  8440.     (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
  8441.     (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));
  8442.  
  8443. const
  8444.   C10000: Single = 10000;
  8445.  
  8446. const
  8447.   opAdd  = 0;
  8448.   opSub  = 1;
  8449.   opMul  = 2;
  8450.   opDvd  = 3;
  8451.   opDiv  = 4;
  8452.   opMod  = 5;
  8453.   opShl  = 6;
  8454.   opShr  = 7;
  8455.   opAnd  = 8;
  8456.   opOr   = 9;
  8457.   opXor  = 10;
  8458.  
  8459. procedure _DispInvoke;
  8460. asm
  8461.         { ->    [ESP+4] Pointer to result or nil }
  8462.         {       [ESP+8] Pointer to variant }
  8463.         {       [ESP+12]        Pointer to call descriptor }
  8464.         {       [ESP+16]        Additional parameters, if any }
  8465.         JMP     VarDispProc
  8466. end;
  8467.  
  8468.  
  8469. procedure _DispInvokeError;
  8470. asm
  8471.         MOV     AL,reVarDispatch
  8472.         JMP     Error
  8473. end;
  8474.  
  8475. procedure VarCastError;
  8476. asm
  8477.         MOV     AL,reVarTypeCast
  8478.         JMP     Error
  8479. end;
  8480.  
  8481. procedure VarInvalidOp;
  8482. asm
  8483.         MOV     AL,reVarInvalidOp
  8484.         JMP     Error
  8485. end;
  8486.  
  8487. procedure _VarClear(var V : Variant);
  8488. asm
  8489.         XOR     EDX,EDX
  8490.         MOV     DX,[EAX].TVarData.VType
  8491.         TEST    EDX,varByRef
  8492.         JNE     @@2
  8493.         CMP     EDX,varOleStr
  8494.         JB      @@2
  8495.         CMP     EDX,varString
  8496.         JE      @@1
  8497.         CMP     EDX,varAny
  8498.         JNE     @@3
  8499.         JMP     [ClearAnyProc]
  8500. @@1:    MOV     [EAX].TVarData.VType,varEmpty
  8501.         ADD     EAX,OFFSET TVarData.VString
  8502.         JMP     _LStrClr
  8503. @@2:    MOV     [EAX].TVarData.VType,varEmpty
  8504.         RET
  8505. @@3:    PUSH    EAX
  8506.         CALL    VariantClear
  8507. end;
  8508.  
  8509. procedure _VarCopy(var Dest : Variant; const Source: Variant);
  8510. asm
  8511.         CMP     EAX,EDX
  8512.         JE      @@9
  8513.         CMP     [EAX].TVarData.VType,varOleStr
  8514.         JB      @@3
  8515.         PUSH    EAX
  8516.         PUSH    EDX
  8517.         CMP     [EAX].TVarData.VType,varString
  8518.         JE      @@1
  8519.         CMP     [EAX].TVarData.VType,varAny
  8520.         JE      @@0
  8521.         PUSH    EAX
  8522.         CALL    VariantClear
  8523.         JMP     @@2
  8524. @@0:    CALL    [ClearAnyProc]
  8525.         JMP     @@2
  8526. @@1:    ADD     EAX,OFFSET TVarData.VString
  8527.         CALL    _LStrClr
  8528. @@2:    POP     EDX
  8529.         POP     EAX
  8530. @@3:    CMP     [EDX].TVarData.VType,varOleStr
  8531.         JAE     @@5
  8532. @@4:    MOV     ECX,[EDX]
  8533.         MOV     [EAX],ECX
  8534.         MOV     ECX,[EDX+8]
  8535.         MOV     [EAX+8],ECX
  8536.         MOV     ECX,[EDX+12]
  8537.         MOV     [EAX+12],ECX
  8538.         RET
  8539. @@5:    CMP     [EDX].TVarData.VType,varString
  8540.         JE      @@6
  8541.         CMP     [EDX].TVarData.VType,varAny
  8542.         JNE     @@8
  8543.         PUSH    EAX
  8544.         CALL    @@4
  8545.         POP     EAX
  8546.         JMP     [RefAnyProc]
  8547. @@6:    MOV     EDX,[EDX].TVarData.VString
  8548.         OR      EDX,EDX
  8549.         JE      @@7
  8550.         MOV     ECX,[EDX-skew].StrRec.refCnt
  8551.         INC     ECX
  8552.         JLE     @@7
  8553.    LOCK INC     [EDX-skew].StrRec.refCnt
  8554. @@7:    MOV     [EAX].TVarData.VType,varString
  8555.         MOV     [EAX].TVarData.VString,EDX
  8556.         RET
  8557. @@8:    MOV     [EAX].TVarData.VType,varEmpty
  8558.         PUSH    EDX
  8559.         PUSH    EAX
  8560.         CALL    VariantCopyInd
  8561.         OR      EAX,EAX
  8562.         JNE     VarInvalidOp
  8563. @@9:
  8564. end;
  8565.  
  8566. procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
  8567. asm
  8568.         CMP     EAX,EDX
  8569.         JE      @@9
  8570.         CMP     [EAX].TVarData.VType,varOleStr
  8571.         JB      @@3
  8572.         PUSH    EAX
  8573.         PUSH    EDX
  8574.         CMP     [EAX].TVarData.VType,varString
  8575.         JE      @@1
  8576.         CMP     [EAX].TVarData.VType,varAny
  8577.         JE      @@0
  8578.         PUSH    EAX
  8579.         CALL    VariantClear
  8580.         JMP     @@2
  8581. @@0:    CALL    [ClearAnyProc]
  8582.         JMP     @@2
  8583. @@1:    ADD     EAX,OFFSET TVarData.VString
  8584.         CALL    _LStrClr
  8585. @@2:    POP     EDX
  8586.         POP     EAX
  8587. @@3:    CMP     [EDX].TVarData.VType,varOleStr
  8588.         JAE     @@5
  8589. @@4:    MOV     ECX,[EDX]
  8590.         MOV     [EAX],ECX
  8591.         MOV     ECX,[EDX+8]
  8592.         MOV     [EAX+8],ECX
  8593.         MOV     ECX,[EDX+12]
  8594.         MOV     [EAX+12],ECX
  8595.         RET
  8596. @@5:    CMP     [EDX].TVarData.VType,varString
  8597.         JNE     @@6
  8598.         CMP     [EDX].TVarData.VType,varAny
  8599.         JNE     @@8
  8600.         CALL    @@4
  8601.         JMP     [RefAnyProc]
  8602. @@6:    MOV     EDX,[EDX].TVarData.VString
  8603.         OR      EDX,EDX
  8604.         JE      @@7
  8605.         MOV     ECX,[EDX-skew].StrRec.refCnt
  8606.         INC     ECX
  8607.         JLE     @@7
  8608.    LOCK INC     [EDX-skew].StrRec.refCnt
  8609. @@7:    MOV     [EAX].TVarData.VType,varString
  8610.         MOV     [EAX].TVarData.VString,EDX
  8611.         RET
  8612. @@8:    MOV     [EAX].TVarData.VType,varEmpty
  8613.         PUSH    EDX
  8614.         PUSH    EAX
  8615.         CALL    VariantCopy
  8616. @@9:
  8617. end;
  8618.  
  8619. type
  8620.   TAnyProc = procedure (var V: Variant);
  8621.  
  8622. procedure VarChangeType(var Dest: Variant; const Source: Variant;
  8623.   DestType: Word); forward;
  8624.  
  8625. procedure AnyChangeType(var Dest: Variant; Source: Variant; DestType: Word);
  8626. begin
  8627.   TAnyProc(ChangeAnyProc)(Source);
  8628.   VarChangeType(Dest, Source, DestType);
  8629. end;
  8630.  
  8631. procedure VarChangeType(var Dest: Variant; const Source: Variant;
  8632.   DestType: Word);
  8633. type
  8634.   TVarMem = array[0..3] of Integer;
  8635.  
  8636.   function ChangeSourceAny(var Dest: Variant; const Source: Variant;
  8637.     DestType: Word): Boolean;
  8638.   begin
  8639.     Result := False;
  8640.     if TVarData(Source).VType = varAny then
  8641.     begin
  8642.       AnyChangeType(Dest, Source, DestType);
  8643.       Result := True;
  8644.     end;
  8645.   end;
  8646.  
  8647. var
  8648.   Temp: TVarData;
  8649. begin
  8650.   case TVarData(Dest).VType of
  8651.     varString:
  8652.       begin
  8653.         if not ChangeSourceAny(Dest, Source, DestType) then
  8654.         begin
  8655.           Temp.VType := varEmpty;
  8656.           if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
  8657.           VarCastError;
  8658.           _VarClear(Dest);
  8659.           TVarMem(Dest)[0] := TVarMem(Temp)[0];
  8660.           TVarMem(Dest)[2] := TVarMem(Temp)[2];
  8661.           TVarMem(Dest)[3] := TVarMem(Temp)[3];
  8662.         end;
  8663.       end;
  8664.     varAny: AnyChangeType(Dest, Source, DestType);
  8665.   else if not ChangeSourceAny(Dest, Source, DestType) then
  8666.     if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
  8667.       VarCastError;
  8668.   end;
  8669. end;
  8670.  
  8671. procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
  8672. var
  8673.   StringPtr: Pointer;
  8674. begin
  8675.   StringPtr := nil;
  8676.   OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
  8677.   _VarClear(Dest);
  8678.   TVarData(Dest).VType := varString;
  8679.   TVarData(Dest).VString := StringPtr;
  8680. end;
  8681.  
  8682. procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
  8683. var
  8684.   OleStrPtr: PWideChar;
  8685. begin
  8686.   OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  8687.   _VarClear(Dest);
  8688.   TVarData(Dest).VType := varOleStr;
  8689.   TVarData(Dest).VOleStr := OleStrPtr;
  8690. end;
  8691.  
  8692. procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
  8693. var
  8694.   SourceType, DestType: Word;
  8695.   Temp: TVarData;
  8696. begin
  8697.   SourceType := TVarData(Source).VType;
  8698.   DestType := Word(VarType);
  8699.   if SourceType = DestType then
  8700.     _VarCopy(Dest, Source)
  8701.   else
  8702.   if SourceType = varString then
  8703.     if DestType = varOleStr then
  8704.       VarStringToOleStr(Variant(Dest), Source)
  8705.     else
  8706.     begin
  8707.       Temp.VType := varEmpty;
  8708.       VarStringToOleStr(Variant(Temp), Source);
  8709.       try
  8710.         VarChangeType(Variant(Dest), Variant(Temp), DestType);
  8711.       finally
  8712.         _VarClear(PVariant(@Temp)^);
  8713.       end;
  8714.     end
  8715.   else
  8716.   if (DestType = varString) and (SourceType <> varAny) then
  8717.     if SourceType = varOleStr then
  8718.       VarOleStrToString(Variant(Dest), Source)
  8719.     else
  8720.     begin
  8721.       Temp.VType := varEmpty;
  8722.       VarChangeType(Variant(Temp), Source, varOleStr);
  8723.       try
  8724.         VarOleStrToString(Variant(Dest), Variant(Temp));
  8725.       finally
  8726.         _VarClear(Variant(Temp));
  8727.       end;
  8728.     end
  8729.   else
  8730.     VarChangeType(Variant(Dest), Source, DestType);
  8731. end;
  8732.  
  8733. (* VarCast when the destination is OleVariant *)
  8734. procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
  8735. begin
  8736.   if (VarType = varString) or (VarType = varAny) then
  8737.     VarCastError
  8738.   else
  8739.     _VarCast(Dest, Source, VarType);
  8740. end;
  8741.  
  8742. procedure _VarToInt;
  8743. asm
  8744.         XOR     EDX,EDX
  8745.         MOV     DX,[EAX].TVarData.VType
  8746.         CMP     EDX,varInteger
  8747.         JE      @@0
  8748.         CMP     EDX,varSmallint
  8749.         JE      @@1
  8750.         CMP     EDX,varByte
  8751.         JE      @@2
  8752.         CMP     EDX,varDouble
  8753.         JE      @@5
  8754.         CMP     EDX,varSingle
  8755.         JE      @@4
  8756.         CMP     EDX,varCurrency
  8757.         JE      @@3
  8758.         SUB     ESP,16
  8759.         MOV     [ESP].TVarData.VType,varEmpty
  8760.         MOV     EDX,EAX
  8761.         MOV     EAX,ESP
  8762.         MOV     ECX,varInteger
  8763.         CALL    _VarCast
  8764.         MOV     EAX,[ESP].TVarData.VInteger
  8765.         ADD     ESP,16
  8766.         RET
  8767. @@0:    MOV     EAX,[EAX].TVarData.VInteger
  8768.         RET
  8769. @@1:    MOVSX   EAX,[EAX].TVarData.VSmallint
  8770.         RET
  8771. @@2:    MOVZX   EAX,[EAX].TVarData.VByte
  8772.         RET
  8773. @@3:    FILD    [EAX].TVarData.VCurrency
  8774.         FDIV    C10000
  8775.         JMP     @@6
  8776. @@4:    FLD     [EAX].TVarData.VSingle
  8777.         JMP     @@6
  8778. @@5:    FLD     [EAX].TVarData.VDouble
  8779. @@6:    PUSH    EAX
  8780.         FISTP   DWORD PTR [ESP]
  8781.         FWAIT
  8782.         POP     EAX
  8783. end;
  8784.  
  8785. procedure _VarToBool;
  8786. asm
  8787.         CMP     [EAX].TVarData.VType,varBoolean
  8788.         JE      @@1
  8789.         SUB     ESP,16
  8790.         MOV     [ESP].TVarData.VType,varEmpty
  8791.         MOV     EDX,EAX
  8792.         MOV     EAX,ESP
  8793.         MOV     ECX,varBoolean
  8794.         CALL    _VarCast
  8795.         MOV     AX,[ESP].TVarData.VBoolean
  8796.         ADD     ESP,16
  8797.         JMP     @@2
  8798. @@1:    MOV     AX,[EAX].TVarData.VBoolean
  8799. @@2:    NEG     AX
  8800.         SBB     EAX,EAX
  8801.         NEG     EAX
  8802. end;
  8803.  
  8804. procedure _VarToReal;
  8805. asm
  8806.         XOR     EDX,EDX
  8807.         MOV     DX,[EAX].TVarData.VType
  8808.         CMP     EDX,varDouble
  8809.         JE      @@1
  8810.         CMP     EDX,varSingle
  8811.         JE      @@2
  8812.         CMP     EDX,varCurrency
  8813.         JE      @@3
  8814.         CMP     EDX,varInteger
  8815.         JE      @@4
  8816.         CMP     EDX,varSmallint
  8817.         JE      @@5
  8818.         CMP     EDX,varDate
  8819.         JE      @@1
  8820.         SUB     ESP,16
  8821.         MOV     [ESP].TVarData.VType,varEmpty
  8822.         MOV     EDX,EAX
  8823.         MOV     EAX,ESP
  8824.         MOV     ECX,varDouble
  8825.         CALL    _VarCast
  8826.         FLD     [ESP].TVarData.VDouble
  8827.         ADD     ESP,16
  8828.         RET
  8829. @@1:    FLD     [EAX].TVarData.VDouble
  8830.         RET
  8831. @@2:    FLD     [EAX].TVarData.VSingle
  8832.         RET
  8833. @@3:    FILD    [EAX].TVarData.VCurrency
  8834.         FDIV    C10000
  8835.         RET
  8836. @@4:    FILD    [EAX].TVarData.VInteger
  8837.         RET
  8838. @@5:    FILD    [EAX].TVarData.VSmallint
  8839. end;
  8840.  
  8841. procedure _VarToCurr;
  8842. asm
  8843.         XOR     EDX,EDX
  8844.         MOV     DX,[EAX].TVarData.VType
  8845.         CMP     EDX,varCurrency
  8846.         JE      @@1
  8847.         CMP     EDX,varDouble
  8848.         JE      @@2
  8849.         CMP     EDX,varSingle
  8850.         JE      @@3
  8851.         CMP     EDX,varInteger
  8852.         JE      @@4
  8853.         CMP     EDX,varSmallint
  8854.         JE      @@5
  8855.         SUB     ESP,16
  8856.         MOV     [ESP].TVarData.VType,varEmpty
  8857.         MOV     EDX,EAX
  8858.         MOV     EAX,ESP
  8859.         MOV     ECX,varCurrency
  8860.         CALL    _VarCast
  8861.         FILD    [ESP].TVarData.VCurrency
  8862.         ADD     ESP,16
  8863.         RET
  8864. @@1:    FILD    [EAX].TVarData.VCurrency
  8865.         RET
  8866. @@2:    FLD     [EAX].TVarData.VDouble
  8867.         JMP     @@6
  8868. @@3:    FLD     [EAX].TVarData.VSingle
  8869.         JMP     @@6
  8870. @@4:    FILD    [EAX].TVarData.VInteger
  8871.         JMP     @@6
  8872. @@5:    FILD    [EAX].TVarData.VSmallint
  8873. @@6:    FMUL    C10000
  8874. end;
  8875.  
  8876. procedure _VarToPStr(var S; const V: Variant);
  8877. var
  8878.   Temp: string;
  8879. begin
  8880.   _VarToLStr(Temp, V);
  8881.   ShortString(S) := Temp;
  8882. end;
  8883.  
  8884. procedure _VarToLStr(var S: string; const V: Variant);
  8885. asm
  8886.         { -> EAX: destination string }
  8887.         {    EDX: source variant     }
  8888.         { <- none                    }
  8889.  
  8890.         CMP     [EDX].TVarData.VType,varString
  8891.         JNE     @@1
  8892.         MOV     EDX,[EDX].TVarData.VString
  8893.         JMP     _LStrAsg
  8894. @@1:    PUSH    EBX
  8895.         MOV     EBX,EAX
  8896.         SUB     ESP,16
  8897.         MOV     [ESP].TVarData.VType,varEmpty
  8898.         MOV     EAX,ESP
  8899.         MOV     ECX,varString
  8900.         CALL    _VarCast
  8901.         MOV     EAX,EBX
  8902.         CALL    _LStrClr
  8903.         MOV     EAX,[ESP].TVarData.VString
  8904.         MOV     [EBX],EAX
  8905.         ADD     ESP,16
  8906.         POP     EBX
  8907. end;
  8908.  
  8909. procedure _VarToWStr(var S: WideString; const V: Variant);
  8910. asm
  8911.         CMP     [EDX].TVarData.VType,varOleStr
  8912.         JNE     @@1
  8913.         MOV     EDX,[EDX].TVarData.VOleStr
  8914.         JMP     _WStrAsg
  8915. @@1:    PUSH    EBX
  8916.         MOV     EBX,EAX
  8917.         SUB     ESP,16
  8918.         MOV     [ESP].TVarData.VType,varEmpty
  8919.         MOV     EAX,ESP
  8920.         MOV     ECX,varOleStr
  8921.         CALL    _VarCast
  8922.         MOV     EAX,EBX
  8923.         MOV     EDX,[ESP].TVarData.VOleStr
  8924.         CALL    WStrSet
  8925.         ADD     ESP,16
  8926.         POP     EBX
  8927. end;
  8928.  
  8929. procedure AnyToIntf(var Unknown: IUnknown; V: Variant);
  8930. begin
  8931.   TAnyProc(ChangeAnyProc)(V);
  8932.   if TVarData(V).VType <> varUnknown then
  8933.     VarCastError;
  8934.   Unknown := IUnknown(TVarData(V).VUnknown);
  8935. end;
  8936.  
  8937. procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
  8938. asm
  8939.         CMP     [EDX].TVarData.VType,varEmpty
  8940.         JE      _IntfClear
  8941.         CMP     [EDX].TVarData.VType,varUnknown
  8942.         JE      @@2
  8943.         CMP     [EDX].TVarData.VType,varDispatch
  8944.         JE      @@2
  8945.         CMP     [EDX].TVarData.VType,varUnknown+varByRef
  8946.         JE      @@1
  8947.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8948.         JE      @@1
  8949.         CMP     [EDX].TVarData.VType,varAny
  8950.         JNE     VarCastError
  8951.         JMP     AnyToIntf
  8952. @@0:    CALL    _VarClear
  8953.         ADD     ESP,16
  8954.         JMP     VarCastError
  8955. @@1:    MOV     EDX,[EDX].TVarData.VPointer
  8956.         MOV     EDX,[EDX]
  8957.         JMP     _IntfCopy
  8958. @@2:    MOV     EDX,[EDX].TVarData.VUnknown
  8959.         JMP     _IntfCopy
  8960. end;
  8961.  
  8962. procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
  8963. asm
  8964.         CMP     [EDX].TVarData.VType,varEmpty
  8965.         JE      _IntfClear
  8966.         CMP     [EDX].TVarData.VType,varDispatch
  8967.         JE      @@1
  8968.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8969.         JNE     VarCastError
  8970.         MOV     EDX,[EDX].TVarData.VPointer
  8971.         MOV     EDX,[EDX]
  8972.         JMP     _IntfCopy
  8973. @@1:    MOV     EDX,[EDX].TVarData.VDispatch
  8974.         JMP     _IntfCopy
  8975. end;
  8976.  
  8977. procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
  8978. asm
  8979.         CALL    DynArrayFromVariant
  8980.         OR      EAX, EAX
  8981.         JNZ     @@1
  8982.         JMP     VarCastError
  8983. @@1:
  8984. end;
  8985.  
  8986. procedure _VarFromInt;
  8987. asm
  8988.         CMP     [EAX].TVarData.VType,varOleStr
  8989.         JB      @@1
  8990.         PUSH    EAX
  8991.         PUSH    EDX
  8992.         CALL    _VarClear
  8993.         POP     EDX
  8994.         POP     EAX
  8995. @@1:    MOV     [EAX].TVarData.VType,varInteger
  8996.         MOV     [EAX].TVarData.VInteger,EDX
  8997. end;
  8998.  
  8999. procedure _VarFromBool;
  9000. asm
  9001.         CMP     [EAX].TVarData.VType,varOleStr
  9002.         JB      @@1
  9003.         PUSH    EAX
  9004.         PUSH    EDX
  9005.         CALL    _VarClear
  9006.         POP     EDX
  9007.         POP     EAX
  9008. @@1:    MOV     [EAX].TVarData.VType,varBoolean
  9009.         NEG     DL
  9010.         SBB     EDX,EDX
  9011.         MOV     [EAX].TVarData.VBoolean,DX
  9012. end;
  9013.  
  9014. procedure _VarFromReal;
  9015. asm
  9016.         CMP     [EAX].TVarData.VType,varOleStr
  9017.         JB      @@1
  9018.         PUSH    EAX
  9019.         CALL    _VarClear
  9020.         POP     EAX
  9021. @@1:    MOV     [EAX].TVarData.VType,varDouble
  9022.         FSTP    [EAX].TVarData.VDouble
  9023.         FWAIT
  9024. end;
  9025.  
  9026. procedure _VarFromTDateTime;
  9027. asm
  9028.         CMP     [EAX].TVarData.VType,varOleStr
  9029.         JB      @@1
  9030.         PUSH    EAX
  9031.         CALL    _VarClear
  9032.         POP     EAX
  9033. @@1:    MOV     [EAX].TVarData.VType,varDate
  9034.         FSTP    [EAX].TVarData.VDouble
  9035.         FWAIT
  9036. end;
  9037.  
  9038. procedure _VarFromCurr;
  9039. asm
  9040.         CMP     [EAX].TVarData.VType,varOleStr
  9041.         JB      @@1
  9042.         PUSH    EAX
  9043.         CALL    _VarClear
  9044.         POP     EAX
  9045. @@1:    MOV     [EAX].TVarData.VType,varCurrency
  9046.         FISTP   [EAX].TVarData.VCurrency
  9047.         FWAIT
  9048. end;
  9049.  
  9050. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  9051. begin
  9052.   _VarFromLStr(V, Value);
  9053. end;
  9054.  
  9055. procedure _VarFromLStr(var V: Variant; const Value: string);
  9056. asm
  9057.         CMP     [EAX].TVarData.VType,varOleStr
  9058.         JB      @@1
  9059.         PUSH    EAX
  9060.         PUSH    EDX
  9061.         CALL    _VarClear
  9062.         POP     EDX
  9063.         POP     EAX
  9064. @@1:    TEST    EDX,EDX
  9065.         JE      @@3
  9066.         MOV     ECX,[EDX-skew].StrRec.refCnt
  9067.         INC     ECX
  9068.         JLE     @@2
  9069.    LOCK INC     [EDX-skew].StrRec.refCnt
  9070.         JMP     @@3
  9071. @@2:    PUSH    EAX
  9072.         PUSH    EDX
  9073.         MOV     EAX,[EDX-skew].StrRec.length
  9074.         CALL    _NewAnsiString
  9075.         MOV     EDX,EAX
  9076.         POP     EAX
  9077.         PUSH    EDX
  9078.         MOV     ECX,[EDX-skew].StrRec.length
  9079.         CALL    Move
  9080.         POP     EDX
  9081.         POP     EAX
  9082. @@3:    MOV     [EAX].TVarData.VType,varString
  9083.         MOV     [EAX].TVarData.VString,EDX
  9084. end;
  9085.  
  9086. procedure _VarFromWStr(var V: Variant; const Value: WideString);
  9087. asm
  9088.         PUSH    EAX
  9089.         CMP     [EAX].TVarData.VType,varOleStr
  9090.         JB      @@1
  9091.         PUSH    EDX
  9092.         CALL    _VarClear
  9093.         POP     EDX
  9094. @@1:    XOR     EAX,EAX
  9095.         TEST    EDX,EDX
  9096.         JE      @@2
  9097.         MOV     EAX,[EDX-4]
  9098.         SHR     EAX,1
  9099.         JE      @@2
  9100.         PUSH    EAX
  9101.         PUSH    EDX
  9102.         CALL    SysAllocStringLen
  9103.         TEST    EAX,EAX
  9104.         JE      WStrError
  9105. @@2:    POP     EDX
  9106.         MOV     [EDX].TVarData.VType,varOleStr
  9107.         MOV     [EDX].TVarData.VOleStr,EAX
  9108. end;
  9109.  
  9110. procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
  9111. asm
  9112.         CMP     [EAX].TVarData.VType,varOleStr
  9113.         JB      @@1
  9114.         PUSH    EAX
  9115.         PUSH    EDX
  9116.         CALL    _VarClear
  9117.         POP     EDX
  9118.         POP     EAX
  9119. @@1:    MOV     [EAX].TVarData.VType,varUnknown
  9120.         MOV     [EAX].TVarData.VUnknown,EDX
  9121.         TEST    EDX,EDX
  9122.         JE      @@2
  9123.         PUSH    EDX
  9124.         MOV     EAX,[EDX]
  9125.         CALL    [EAX].vmtAddRef.Pointer
  9126. @@2:
  9127. end;
  9128.  
  9129. procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
  9130. asm
  9131.         CMP     [EAX].TVarData.VType,varOleStr
  9132.         JB      @@1
  9133.         PUSH    EAX
  9134.         PUSH    EDX
  9135.         CALL    _VarClear
  9136.         POP     EDX
  9137.         POP     EAX
  9138. @@1:    MOV     [EAX].TVarData.VType,varDispatch
  9139.         MOV     [EAX].TVarData.VDispatch,EDX
  9140.         TEST    EDX,EDX
  9141.         JE      @@2
  9142.         PUSH    EDX
  9143.         MOV     EAX,[EDX]
  9144.         CALL    [EAX].vmtAddRef.Pointer
  9145. @@2:
  9146. end;
  9147.  
  9148. procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
  9149. asm
  9150.         PUSH    EAX
  9151.         CALL    DynArrayToVariant
  9152.         POP     EAX
  9153.         CMP     [EAX].TVarData.VType,varEmpty
  9154.         JNE     @@1
  9155.         JMP     VarCastError
  9156. @@1:
  9157. end;
  9158.  
  9159. procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
  9160. begin
  9161.   _OleVarFromLStr(V, Value);
  9162. end;
  9163.  
  9164.  
  9165. procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
  9166. asm
  9167.         CMP     [EAX].TVarData.VType,varOleStr
  9168.         JB      @@1
  9169.         PUSH    EAX
  9170.         PUSH    EDX
  9171.         CALL    _VarClear
  9172.         POP     EDX
  9173.         POP     EAX
  9174. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  9175.         ADD     EAX,TVarData.VOleStr
  9176.         XOR     ECX,ECX
  9177.         MOV     [EAX],ECX
  9178.         JMP     _WStrFromLStr
  9179. end;
  9180.  
  9181. procedure OleVarFromAny(var V: OleVariant; Value: Variant);
  9182. begin
  9183.   TAnyProc(ChangeAnyProc)(Value);
  9184.   V := Value;
  9185. end;
  9186.  
  9187. procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
  9188. asm
  9189.         CMP     [EDX].TVarData.VType,varAny
  9190.         JE      OleVarFromAny
  9191.         CMP     [EDX].TVarData.VType,varString
  9192.         JNE     _VarCopy
  9193.         CMP     [EAX].TVarData.VType,varOleStr
  9194.         JB      @@1
  9195.         PUSH    EAX
  9196.         PUSH    EDX
  9197.         CALL    _VarClear
  9198.         POP     EDX
  9199.         POP     EAX
  9200. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  9201.         ADD     EAX,TVarData.VOleStr
  9202.         ADD     EDX,TVarData.VString
  9203.         XOR     ECX,ECX
  9204.         MOV     EDX,[EDX]
  9205.         MOV     [EAX],ECX
  9206.         JMP     _WStrFromLStr
  9207. @@2:
  9208. end;
  9209.  
  9210.  
  9211. procedure VarStrCat(var Dest: Variant; const Source: Variant);
  9212. begin
  9213.   if TVarData(Dest).VType = varString then
  9214.     Dest := string(Dest) + string(Source)
  9215.   else
  9216.     Dest := WideString(Dest) + WideString(Source);
  9217. end;
  9218.  
  9219. procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer); forward;
  9220.  
  9221. procedure AnyOp(var Dest: Variant; Source: Variant; OpCode: Integer);
  9222. begin
  9223.   if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
  9224.   if TVarData(Source).VType = varAny then TAnyProc(ChangeAnyProc)(Source);
  9225.   VarOp(Dest, Source, OpCode);
  9226. end;
  9227.  
  9228. procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
  9229. asm
  9230.         PUSH    EBX
  9231.         PUSH    ESI
  9232.         PUSH    EDI
  9233.         MOV     EDI,EAX
  9234.         MOV     ESI,EDX
  9235.         MOV     EBX,ECX
  9236.         MOV     EAX,[EDI].TVarData.VType.Integer
  9237.         MOV     EDX,[ESI].TVarData.VType.Integer
  9238.         AND     EAX,varTypeMask
  9239.         AND     EDX,varTypeMask
  9240.         CMP     EAX,varLast
  9241.         JBE     @@1
  9242.         CMP     EAX,varString
  9243.         JNE     @@4
  9244.         MOV     EAX,varOleStr
  9245. @@1:    CMP     EDX,varLast
  9246.         JBE     @@2
  9247.         CMP     EDX,varString
  9248.         JNE     @@3
  9249.         MOV     EDX,varOleStr
  9250. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  9251.         MOV     DL,BaseTypeMap.Byte[EDX]
  9252.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  9253.         CALL    @VarOpTable.Pointer[ECX*4]
  9254.         POP     EDI
  9255.         POP     ESI
  9256.         POP     EBX
  9257.         RET
  9258. @@3:    MOV     EAX,EDX
  9259. @@4:    CMP     EAX,varAny
  9260.         JNE     @InvalidOp
  9261.         POP     EDI
  9262.         POP     ESI
  9263.         POP     EBX
  9264.         JMP     AnyOp
  9265.  
  9266. @VarOpTable:
  9267.         DD      @VarOpError
  9268.         DD      @VarOpNull
  9269.         DD      @VarOpInteger
  9270.         DD      @VarOpReal
  9271.         DD      @VarOpCurr
  9272.         DD      @VarOpString
  9273.         DD      @VarOpBoolean
  9274.         DD      @VarOpDate
  9275.  
  9276. @VarOpError:
  9277.         POP     EAX
  9278.  
  9279. @InvalidOp:
  9280.         POP     EDI
  9281.         POP     ESI
  9282.         POP     EBX
  9283.         JMP     VarInvalidOp
  9284.  
  9285. @VarOpNull:
  9286.         MOV     EAX,EDI
  9287.         CALL    _VarClear
  9288.         MOV     [EDI].TVarData.VType,varNull
  9289.         RET
  9290.  
  9291. @VarOpInteger:
  9292.         CMP     BL,opDvd
  9293.         JE      @RealOp
  9294.  
  9295. @IntegerOp:
  9296.         MOV     EAX,ESI
  9297.         CALL    _VarToInt
  9298.         PUSH    EAX
  9299.         MOV     EAX,EDI
  9300.         CALL    _VarToInt
  9301.         POP     EDX
  9302.         CALL    @IntegerOpTable.Pointer[EBX*4]
  9303.         MOV     EDX,EAX
  9304.         MOV     EAX,EDI
  9305.         JMP     _VarFromInt
  9306.  
  9307. @IntegerOpTable:
  9308.         DD      @IntegerAdd
  9309.         DD      @IntegerSub
  9310.         DD      @IntegerMul
  9311.         DD      0
  9312.         DD      @IntegerDiv
  9313.         DD      @IntegerMod
  9314.         DD      @IntegerShl
  9315.         DD      @IntegerShr
  9316.         DD      @IntegerAnd
  9317.         DD      @IntegerOr
  9318.         DD      @IntegerXor
  9319.  
  9320. @IntegerAdd:
  9321.         ADD     EAX,EDX
  9322.         JO      @IntToRealOp
  9323.         RET
  9324.  
  9325. @IntegerSub:
  9326.         SUB     EAX,EDX
  9327.         JO      @IntToRealOp
  9328.         RET
  9329.  
  9330. @IntegerMul:
  9331.         IMUL    EDX
  9332.         JO      @IntToRealOp
  9333.         RET
  9334.  
  9335. @IntegerDiv:
  9336.         MOV     ECX,EDX
  9337.         CDQ
  9338.         IDIV    ECX
  9339.         RET
  9340.  
  9341. @IntegerMod:
  9342.         MOV     ECX,EDX
  9343.         CDQ
  9344.         IDIV    ECX
  9345.         MOV     EAX,EDX
  9346.         RET
  9347.  
  9348. @IntegerShl:
  9349.         MOV     ECX,EDX
  9350.         SHL     EAX,CL
  9351.         RET
  9352.  
  9353. @IntegerShr:
  9354.         MOV     ECX,EDX
  9355.         SHR     EAX,CL
  9356.         RET
  9357.  
  9358. @IntegerAnd:
  9359.         AND     EAX,EDX
  9360.         RET
  9361.  
  9362. @IntegerOr:
  9363.         OR      EAX,EDX
  9364.         RET
  9365.  
  9366. @IntegerXor:
  9367.         XOR     EAX,EDX
  9368.         RET
  9369.  
  9370. @IntToRealOp:
  9371.         POP     EAX
  9372.         JMP     @RealOp
  9373.  
  9374. @VarOpReal:
  9375.         CMP     BL,opDiv
  9376.         JAE     @IntegerOp
  9377.  
  9378. @RealOp:
  9379.         MOV     EAX,ESI
  9380.         CALL    _VarToReal
  9381.         SUB     ESP,12
  9382.         FSTP    TBYTE PTR [ESP]
  9383.         MOV     EAX,EDI
  9384.         CALL    _VarToReal
  9385.         FLD     TBYTE PTR [ESP]
  9386.         ADD     ESP,12
  9387.         CALL    @RealOpTable.Pointer[EBX*4]
  9388.  
  9389. @RealResult:
  9390.         MOV     EAX,EDI
  9391.         JMP     _VarFromReal
  9392.  
  9393. @VarOpCurr:
  9394.         CMP     BL,opDiv
  9395.         JAE     @IntegerOp
  9396.         CMP     BL,opMul
  9397.         JAE     @CurrMulDvd
  9398.         MOV     EAX,ESI
  9399.         CALL    _VarToCurr
  9400.         SUB     ESP,12
  9401.         FSTP    TBYTE PTR [ESP]
  9402.         MOV     EAX,EDI
  9403.         CALL    _VarToCurr
  9404.         FLD     TBYTE PTR [ESP]
  9405.         ADD     ESP,12
  9406.         CALL    @RealOpTable.Pointer[EBX*4]
  9407.  
  9408. @CurrResult:
  9409.         MOV     EAX,EDI
  9410.         JMP     _VarFromCurr
  9411.  
  9412. @CurrMulDvd:
  9413.         CMP     DL,btCur
  9414.         JE      @CurrOpCurr
  9415.         MOV     EAX,ESI
  9416.         CALL    _VarToReal
  9417.         FILD    [EDI].TVarData.VCurrency
  9418.         FXCH
  9419.         CALL    @RealOpTable.Pointer[EBX*4]
  9420.         JMP     @CurrResult
  9421.  
  9422. @CurrOpCurr:
  9423.         CMP     BL,opDvd
  9424.         JE      @CurrDvdCurr
  9425.         CMP     AL,btCur
  9426.         JE      @CurrMulCurr
  9427.         MOV     EAX,EDI
  9428.         CALL    _VarToReal
  9429.         FILD    [ESI].TVarData.VCurrency
  9430.         FMUL
  9431.         JMP     @CurrResult
  9432.  
  9433. @CurrMulCurr:
  9434.         FILD    [EDI].TVarData.VCurrency
  9435.         FILD    [ESI].TVarData.VCurrency
  9436.         FMUL
  9437.         FDIV    C10000
  9438.         JMP     @CurrResult
  9439.  
  9440. @CurrDvdCurr:
  9441.         MOV     EAX,EDI
  9442.         CALL    _VarToCurr
  9443.         FILD    [ESI].TVarData.VCurrency
  9444.         FDIV
  9445.         JMP     @RealResult
  9446.  
  9447. @RealOpTable:
  9448.         DD      @RealAdd
  9449.         DD      @RealSub
  9450.         DD      @RealMul
  9451.         DD      @RealDvd
  9452.  
  9453. @RealAdd:
  9454.         FADD
  9455.         RET
  9456.  
  9457. @RealSub:
  9458.         FSUB
  9459.         RET
  9460.  
  9461. @RealMul:
  9462.         FMUL
  9463.         RET
  9464.  
  9465. @RealDvd:
  9466.         FDIV
  9467.         RET
  9468.  
  9469. @VarOpString:
  9470.         CMP     BL,opAdd
  9471.         JNE     @VarOpReal
  9472.         MOV     EAX,EDI
  9473.         MOV     EDX,ESI
  9474.         JMP     VarStrCat
  9475.  
  9476. @VarOpBoolean:
  9477.         CMP     BL,opAnd
  9478.         JB      @VarOpReal
  9479.         MOV     EAX,ESI
  9480.         CALL    _VarToBool
  9481.         PUSH    EAX
  9482.         MOV     EAX,EDI
  9483.         CALL    _VarToBool
  9484.         POP     EDX
  9485.         CALL    @IntegerOpTable.Pointer[EBX*4]
  9486.         MOV     EDX,EAX
  9487.         MOV     EAX,EDI
  9488.         JMP     _VarFromBool
  9489.  
  9490. @VarOpDate:
  9491.         CMP     BL,opSub
  9492.         JA      @VarOpReal
  9493.         JB      @DateOp
  9494.         MOV     AH,DL
  9495.         CMP     AX,btDat+btDat*256
  9496.         JE      @RealOp
  9497.  
  9498. @DateOp:
  9499.         CALL    @RealOp
  9500.         MOV     [EDI].TVarData.VType,varDate
  9501.         RET
  9502. end;
  9503.  
  9504. procedure _VarAdd;
  9505. asm
  9506.         MOV     ECX,opAdd
  9507.         JMP     VarOp
  9508. end;
  9509.  
  9510. procedure _VarSub;
  9511. asm
  9512.         MOV     ECX,opSub
  9513.         JMP     VarOp
  9514. end;
  9515.  
  9516. procedure _VarMul;
  9517. asm
  9518.         MOV     ECX,opMul
  9519.         JMP     VarOp
  9520. end;
  9521.  
  9522. procedure _VarDiv;
  9523. asm
  9524.         MOV     ECX,opDiv
  9525.         JMP     VarOp
  9526. end;
  9527.  
  9528. procedure _VarMod;
  9529. asm
  9530.         MOV     ECX,opMod
  9531.         JMP     VarOp
  9532. end;
  9533.  
  9534. procedure _VarAnd;
  9535. asm
  9536.         MOV     ECX,opAnd
  9537.         JMP     VarOp
  9538. end;
  9539.  
  9540. procedure _VarOr;
  9541. asm
  9542.         MOV     ECX,opOr
  9543.         JMP     VarOp
  9544. end;
  9545.  
  9546. procedure _VarXor;
  9547. asm
  9548.         MOV     ECX,opXor
  9549.         JMP     VarOp
  9550. end;
  9551.  
  9552. procedure _VarShl;
  9553. asm
  9554.         MOV     ECX,opShl
  9555.         JMP     VarOp
  9556. end;
  9557.  
  9558. procedure _VarShr;
  9559. asm
  9560.         MOV     ECX,opShr
  9561.         JMP     VarOp
  9562. end;
  9563.  
  9564. procedure _VarRDiv;
  9565. asm
  9566.         MOV     ECX,opDvd
  9567.         JMP     VarOp
  9568. end;
  9569.  
  9570. function VarCompareString(const S1, S2: string): Integer;
  9571. asm
  9572.         PUSH    ESI
  9573.         PUSH    EDI
  9574.         MOV     ESI,EAX
  9575.         MOV     EDI,EDX
  9576.         OR      EAX,EAX
  9577.         JE      @@1
  9578.         MOV     EAX,[EAX-4]
  9579. @@1:    OR      EDX,EDX
  9580.         JE      @@2
  9581.         MOV     EDX,[EDX-4]
  9582. @@2:    MOV     ECX,EAX
  9583.         CMP     ECX,EDX
  9584.         JBE     @@3
  9585.         MOV     ECX,EDX
  9586. @@3:    CMP     ECX,ECX
  9587.         REPE    CMPSB
  9588.         JE      @@4
  9589.         MOVZX   EAX,BYTE PTR [ESI-1]
  9590.         MOVZX   EDX,BYTE PTR [EDI-1]
  9591. @@4:    SUB     EAX,EDX
  9592.         POP     EDI
  9593.         POP     ESI
  9594. end;
  9595.  
  9596. function VarCmpStr(const V1, V2: Variant): Integer;
  9597. begin
  9598.   Result := VarCompareString(V1, V2);
  9599. end;
  9600.  
  9601. function AnyCmp(var Dest: Variant; const Source: Variant): Integer;
  9602. var
  9603.   Temp: Variant;
  9604.   P: ^Variant;
  9605. begin
  9606.   asm
  9607.         PUSH    Dest
  9608.   end;
  9609.   P := @Source;
  9610.   if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
  9611.   if TVarData(Source).VType = varAny then
  9612.   begin
  9613.     Temp := Source;
  9614.     TAnyProc(ChangeAnyProc)(Temp);
  9615.     P := @Temp;
  9616.   end;
  9617.   asm
  9618.         MOV     EDX,P
  9619.         POP     EAX
  9620.         CALL    _VarCmp
  9621.         PUSHF
  9622.         POP     EAX
  9623.         MOV     Result,EAX
  9624.   end;
  9625. end;
  9626.  
  9627. procedure _VarCmp;
  9628. asm
  9629.         PUSH    ESI
  9630.         PUSH    EDI
  9631.         MOV     EDI,EAX
  9632.         MOV     ESI,EDX
  9633.         MOV     EAX,[EDI].TVarData.VType.Integer
  9634.         MOV     EDX,[ESI].TVarData.VType.Integer
  9635.         AND     EAX,varTypeMask
  9636.         AND     EDX,varTypeMask
  9637.         CMP     EAX,varLast
  9638.         JBE     @@1
  9639.         CMP     EAX,varString
  9640.         JNE     @@4
  9641.         MOV     EAX,varOleStr
  9642. @@1:    CMP     EDX,varLast
  9643.         JBE     @@2
  9644.         CMP     EDX,varString
  9645.         JNE     @@3
  9646.         MOV     EDX,varOleStr
  9647. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  9648.         MOV     DL,BaseTypeMap.Byte[EDX]
  9649.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  9650.         JMP     @VarCmpTable.Pointer[ECX*4]
  9651. @@3:    MOV     EAX,EDX
  9652. @@4:    CMP     EAX,varAny
  9653.         JNE     @VarCmpError
  9654.         POP     EDI
  9655.         POP     ESI
  9656.         CALL    AnyCmp
  9657.         PUSH    EAX
  9658.         POPF
  9659.         RET
  9660.  
  9661. @VarCmpTable:
  9662.         DD      @VarCmpError
  9663.         DD      @VarCmpNull
  9664.         DD      @VarCmpInteger
  9665.         DD      @VarCmpReal
  9666.         DD      @VarCmpCurr
  9667.         DD      @VarCmpString
  9668.         DD      @VarCmpBoolean
  9669.         DD      @VarCmpDate
  9670.  
  9671. @VarCmpError:
  9672.         POP     EDI
  9673.         POP     ESI
  9674.         JMP     VarInvalidOp
  9675.  
  9676. @VarCmpNull:
  9677.         CMP     AL,DL
  9678.         JMP     @Exit
  9679.  
  9680. @VarCmpInteger:
  9681.         MOV     EAX,ESI
  9682.         CALL    _VarToInt
  9683.         XCHG    EAX,EDI
  9684.         CALL    _VarToInt
  9685.         CMP     EAX,EDI
  9686.         JMP     @Exit
  9687.  
  9688. @VarCmpReal:
  9689. @VarCmpDate:
  9690.         MOV     EAX,EDI
  9691.         CALL    _VarToReal
  9692.         SUB     ESP,12
  9693.         FSTP    TBYTE PTR [ESP]
  9694.         MOV     EAX,ESI
  9695.         CALL    _VarToReal
  9696.         FLD     TBYTE PTR [ESP]
  9697.         ADD     ESP,12
  9698.  
  9699. @RealCmp:
  9700.         FCOMPP
  9701.         FNSTSW  AX
  9702.         MOV     AL,AH   { Move CF into SF }
  9703.         AND     AX,4001H
  9704.         ROR     AL,1
  9705.         OR      AH,AL
  9706.         SAHF
  9707.         JMP     @Exit
  9708.  
  9709. @VarCmpCurr:
  9710.         MOV     EAX,EDI
  9711.         CALL    _VarToCurr
  9712.         SUB     ESP,12
  9713.         FSTP    TBYTE PTR [ESP]
  9714.         MOV     EAX,ESI
  9715.         CALL    _VarToCurr
  9716.         FLD     TBYTE PTR [ESP]
  9717.         ADD     ESP,12
  9718.         JMP     @RealCmp
  9719.  
  9720. @VarCmpString:
  9721.         MOV     EAX,EDI
  9722.         MOV     EDX,ESI
  9723.         CALL    VarCmpStr
  9724.         CMP     EAX,0
  9725.         JMP     @Exit
  9726.  
  9727. @VarCmpBoolean:
  9728.         MOV     EAX,ESI
  9729.         CALL    _VarToBool
  9730.         XCHG    EAX,EDI
  9731.         CALL    _VarToBool
  9732.         MOV     EDX,EDI
  9733.         CMP     AL,DL
  9734.  
  9735. @Exit:
  9736.         POP     EDI
  9737.         POP     ESI
  9738. end;
  9739.  
  9740. procedure _VarNeg;
  9741. asm
  9742.         MOV     EDX,[EAX].TVarData.VType.Integer
  9743.         AND     EDX,varTypeMask
  9744.         CMP     EDX,varLast
  9745.         JBE     @@1
  9746.         CMP     EDX,varString
  9747.         JNE     @VarNegError
  9748.         MOV     EDX,varOleStr
  9749. @@1:    MOV     DL,BaseTypeMap.Byte[EDX]
  9750.         JMP     @VarNegTable.Pointer[EDX*4]
  9751. @@2:    CMP     EAX,varAny
  9752.         JNE     @VarNegError
  9753.         PUSH    EAX
  9754.         CALL    [ChangeAnyProc]
  9755.         POP     EAX
  9756.         JMP     _VarNeg
  9757.  
  9758. @VarNegTable:
  9759.         DD      @VarNegError
  9760.         DD      @VarNegNull
  9761.         DD      @VarNegInteger
  9762.         DD      @VarNegReal
  9763.         DD      @VarNegCurr
  9764.         DD      @VarNegReal
  9765.         DD      @VarNegInteger
  9766.         DD      @VarNegDate
  9767.  
  9768. @VarNegError:
  9769.         JMP     VarInvalidOp
  9770.  
  9771. @VarNegNull:
  9772.         RET
  9773.  
  9774. @VarNegInteger:
  9775.         PUSH    EAX
  9776.         CALL    _VarToInt
  9777.         NEG     EAX
  9778.         MOV     EDX,EAX
  9779.         POP     EAX
  9780.         JMP     _VarFromInt
  9781.  
  9782. @VarNegReal:
  9783.         PUSH    EAX
  9784.         CALL    _VarToReal
  9785.         FCHS
  9786.         POP     EAX
  9787.         JMP     _VarFromReal
  9788.  
  9789. @VarNegCurr:
  9790.         FILD    [EAX].TVarData.VCurrency
  9791.         FCHS
  9792.         FISTP   [EAX].TVarData.VCurrency
  9793.         FWAIT
  9794.         RET
  9795.  
  9796. @VarNegDate:
  9797.         FLD     [EAX].TVarData.VDate
  9798.         FCHS
  9799.         FSTP    [EAX].TVarData.VDate
  9800.         FWAIT
  9801. end;
  9802.  
  9803. procedure _VarNot;
  9804. asm
  9805.         MOV     EDX,[EAX].TVarData.VType.Integer
  9806.         AND     EDX,varTypeMask
  9807.         JE      @@2
  9808.         CMP     EDX,varBoolean
  9809.         JE      @@3
  9810.         CMP     EDX,varNull
  9811.         JE      @@4
  9812.         CMP     EDX,varLast
  9813.         JBE     @@1
  9814.         CMP     EDX,varString
  9815.         JE      @@1
  9816.         CMP     EAX,varAny
  9817.         JNE     @@2
  9818.         PUSH    EAX
  9819.         CALL    [ChangeAnyProc]
  9820.         POP     EAX
  9821.         JMP     _VarNot
  9822. @@1:    PUSH    EAX
  9823.         CALL    _VarToInt
  9824.         NOT     EAX
  9825.         MOV     EDX,EAX
  9826.         POP     EAX
  9827.         JMP     _VarFromInt
  9828. @@2:    JMP     VarInvalidOp
  9829. @@3:    MOV     DX,[EAX].TVarData.VBoolean
  9830.         NEG     DX
  9831.         SBB     EDX,EDX
  9832.         NOT     EDX
  9833.         MOV     [EAX].TVarData.VBoolean,DX
  9834. @@4:
  9835. end;
  9836.  
  9837. procedure _VarCopyNoInd;
  9838. asm
  9839.         JMP     VarCopyNoInd
  9840. end;
  9841.  
  9842. procedure _VarClr;
  9843. asm
  9844.         PUSH    EAX
  9845.         CALL    _VarClear
  9846.         POP     EAX
  9847. end;
  9848.  
  9849. procedure _VarAddRef;
  9850. asm
  9851.         CMP     [EAX].TVarData.VType,varOleStr
  9852.         JB      @@1
  9853.         PUSH    [EAX].Integer[12]
  9854.         PUSH    [EAX].Integer[8]
  9855.         PUSH    [EAX].Integer[4]
  9856.         PUSH    [EAX].Integer[0]
  9857.         MOV     [EAX].TVarData.VType,varEmpty
  9858.         MOV     EDX,ESP
  9859.         CALL    _VarCopy
  9860.         ADD     ESP,16
  9861. @@1:
  9862. end;
  9863.  
  9864. function VarType(const V: Variant): Integer;
  9865. asm
  9866.         MOVZX   EAX,[EAX].TVarData.VType
  9867. end;
  9868.  
  9869. function VarAsType(const V: Variant; VarType: Integer): Variant;
  9870. begin
  9871.   _VarCast(Result, V, VarType);
  9872. end;
  9873.  
  9874. function VarIsEmpty(const V: Variant): Boolean;
  9875. begin
  9876.   with TVarData(V) do
  9877.     Result := (VType = varEmpty) or ((VType = varDispatch) or
  9878.       (VType = varUnknown)) and (VDispatch = nil);
  9879. end;
  9880.  
  9881. function VarIsNull(const V: Variant): Boolean;
  9882. begin
  9883.   Result := TVarData(V).VType = varNull;
  9884. end;
  9885.  
  9886. function VarToStr(const V: Variant): string;
  9887. begin
  9888.   if TVarData(V).VType <> varNull then Result := V else Result := '';
  9889. end;
  9890.  
  9891. function VarFromDateTime(DateTime: TDateTime): Variant;
  9892. begin
  9893.   _VarClear(Result);
  9894.   TVarData(Result).VType := varDate;
  9895.   TVarData(Result).VDate := DateTime;
  9896. end;
  9897.  
  9898. function VarToDateTime(const V: Variant): TDateTime;
  9899. var
  9900.   Temp: TVarData;
  9901. begin
  9902.   Temp.VType := varEmpty;
  9903.   _VarCast(Variant(Temp), V, varDate);
  9904.   Result := Temp.VDate;
  9905. end;
  9906.  
  9907. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  9908. var
  9909.   S: string;
  9910. begin
  9911.   if TVarData(V).VType >= varSmallint then S := V;
  9912.   Write(T, S: Width);
  9913.   Result := @T;
  9914. end;
  9915.  
  9916. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  9917. begin
  9918.   Result := _WriteVariant(T, V, 0);
  9919. end;
  9920.  
  9921. { ----------------------------------------------------- }
  9922. {       Variant array support                           }
  9923. { ----------------------------------------------------- }
  9924.  
  9925. function VarArrayCreate(const Bounds: array of Integer;
  9926.   VarType: Integer): Variant;
  9927. var
  9928.   I, DimCount: Integer;
  9929.   VarArrayRef: PVarArray;
  9930.   VarBounds: array[0..63] of TVarArrayBound;
  9931. begin
  9932.   if not Odd(High(Bounds)) or (High(Bounds) > 127) then
  9933.     Error(reVarArrayCreate);
  9934.   DimCount := (High(Bounds) + 1) div 2;
  9935.   for I := 0 to DimCount - 1 do
  9936.     with VarBounds[I] do
  9937.     begin
  9938.       LowBound := Bounds[I * 2];
  9939.       ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
  9940.     end;
  9941.   VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
  9942.   if VarArrayRef = nil then Error(reVarArrayCreate);
  9943.   _VarClear(Result);
  9944.   TVarData(Result).VType := VarType or varArray;
  9945.   TVarData(Result).VArray := VarArrayRef;
  9946. end;
  9947.  
  9948. function VarArrayOf(const Values: array of Variant): Variant;
  9949. var
  9950.   I: Integer;
  9951. begin
  9952.   Result := VarArrayCreate([0, High(Values)], varVariant);
  9953.   for I := 0 to High(Values) do Result[I] := Values[I];
  9954. end;
  9955.  
  9956. procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
  9957. var
  9958.   VarBound: TVarArrayBound;
  9959. begin
  9960.   if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
  9961.     Error(reVarNotArray);
  9962.   with TVarData(A).VArray^ do
  9963.     VarBound.LowBound := Bounds[DimCount - 1].LowBound;
  9964.   VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
  9965.   if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
  9966.     Error(reVarArrayCreate);
  9967. end;
  9968.  
  9969. function GetVarArray(const A: Variant): PVarArray;
  9970. begin
  9971.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9972.   if TVarData(A).VType and varByRef <> 0 then
  9973.     Result := PVarArray(TVarData(A).VPointer^) else
  9974.     Result := TVarData(A).VArray;
  9975. end;
  9976.  
  9977. function VarArrayDimCount(const A: Variant): Integer;
  9978. begin
  9979.   if TVarData(A).VType and varArray <> 0 then
  9980.     Result := GetVarArray(A)^.DimCount else
  9981.     Result := 0;
  9982. end;
  9983.  
  9984. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  9985. begin
  9986.   if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
  9987.     Error(reVarArrayBounds);
  9988. end;
  9989.  
  9990. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  9991. begin
  9992.   if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
  9993.     Error(reVarArrayBounds);
  9994. end;
  9995.  
  9996. function VarArrayLock(const A: Variant): Pointer;
  9997. begin
  9998.   if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
  9999.     Error(reVarNotArray);
  10000. end;
  10001.  
  10002. procedure VarArrayUnlock(const A: Variant);
  10003. begin
  10004.   if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
  10005.     Error(reVarNotArray);
  10006. end;
  10007.  
  10008. function VarArrayRef(const A: Variant): Variant;
  10009. begin
  10010.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  10011.   _VarClear(Result);
  10012.   TVarData(Result).VType := TVarData(A).VType or varByRef;
  10013.   if TVarData(A).VType and varByRef <> 0 then
  10014.     TVarData(Result).VPointer := TVarData(A).VPointer else
  10015.     TVarData(Result).VPointer := @TVarData(A).VArray;
  10016. end;
  10017.  
  10018. function VarIsArray(const A: Variant): Boolean;
  10019. begin
  10020.   Result := TVarData(A).VType and varArray <> 0;
  10021. end;
  10022.  
  10023. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  10024.   Indices: Integer): Variant; cdecl;
  10025. var
  10026.   VarArrayPtr: PVarArray;
  10027.   VarType: Integer;
  10028.   P: Pointer;
  10029. begin
  10030.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  10031.   VarArrayPtr := GetVarArray(A);
  10032.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  10033.   VarType := TVarData(A).VType and varTypeMask;
  10034.   _VarClear(Result);
  10035.   if VarType = varVariant then
  10036.   begin
  10037.     if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
  10038.       Error(reVarArrayBounds);
  10039.     Result := PVariant(P)^;
  10040.   end else
  10041.   begin
  10042.   if SafeArrayGetElement(VarArrayPtr, @Indices,
  10043.       @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
  10044.     TVarData(Result).VType := VarType;
  10045.   end;
  10046. end;
  10047.  
  10048. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  10049.   IndexCount: Integer; Indices: Integer); cdecl;
  10050. type
  10051.   TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer);
  10052. var
  10053.   VarArrayPtr: PVarArray;
  10054.   VarType: Integer;
  10055.   P: Pointer;
  10056.   Temp: TVarData;
  10057. begin
  10058.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  10059.   VarArrayPtr := GetVarArray(A);
  10060.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  10061.   VarType := TVarData(A).VType and varTypeMask;
  10062.   if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  10063.   begin
  10064.     if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
  10065.       Error(reVarArrayBounds);
  10066.     PVariant(P)^ := Value;
  10067.   end else
  10068.   begin
  10069.     Temp.VType := varEmpty;
  10070.     try
  10071.       if VarType = varVariant then
  10072.       begin
  10073.         VarStringToOleStr(Variant(Temp), Value);
  10074.         P := @Temp;
  10075.       end else
  10076.       begin
  10077.         _VarCast(Variant(Temp), Value, VarType);
  10078.         case VarType of
  10079.           varOleStr, varDispatch, varUnknown:
  10080.             P := Temp.VPointer;
  10081.         else
  10082.           P := @Temp.VPointer;
  10083.         end;
  10084.       end;
  10085.       if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
  10086.         Error(reVarArrayBounds);
  10087.     finally
  10088.       _VarClear(Variant(Temp));
  10089.     end;
  10090.   end;
  10091. end;
  10092.  
  10093.  
  10094. function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
  10095. asm
  10096.         {     ->EAX     Pointer to A            }
  10097.         {       EDX     Pointer to Indices      }
  10098.         {       ECX     High bound of Indices   }
  10099.         {       [EBP+8] Pointer to result       }
  10100.  
  10101.         PUSH    EBX
  10102.  
  10103.         MOV     EBX,ECX
  10104.         INC     EBX
  10105.         JLE     @@endLoop
  10106. @@loop:
  10107.         PUSH    [EDX+ECX*4].Integer
  10108.         DEC     ECX
  10109.         JNS     @@loop
  10110. @@endLoop:
  10111.         PUSH    EBX
  10112.         PUSH    EAX
  10113.         MOV     EAX,[EBP+8]
  10114.         PUSH    EAX
  10115.         CALL    _VarArrayGet
  10116.         LEA     ESP,[ESP+EBX*4+3*4]
  10117.  
  10118.         POP     EBX
  10119. end;
  10120.  
  10121. procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Integer);
  10122. asm
  10123.         {     ->EAX     Pointer to A            }
  10124.         {       EDX     Pointer to Value        }
  10125.         {       ECX     Pointer to Indices      }
  10126.         {       [EBP+8] High bound of Indices   }
  10127.  
  10128.         PUSH    EBX
  10129.  
  10130.         MOV     EBX,[EBP+8]
  10131.  
  10132.         TEST    EBX,EBX
  10133.         JS      @@endLoop
  10134. @@loop:
  10135.         PUSH    [ECX+EBX*4].Integer
  10136.         DEC     EBX
  10137.         JNS     @@loop
  10138. @@endLoop:
  10139.         MOV     EBX,[EBP+8]
  10140.         INC     EBX
  10141.         PUSH    EBX
  10142.         PUSH    EDX
  10143.         PUSH    EAX
  10144.         CALL    _VarArrayPut
  10145.         LEA     ESP,[ESP+EBX*4+3*4]
  10146.  
  10147.         POP     EBX
  10148. end;
  10149.  
  10150.  
  10151. { 64-bit Integer helper routines - recycling C++ RTL routines }
  10152.  
  10153. procedure __llmul;      external;    {$L _LL  }
  10154. procedure __lldiv;      external;    {   _LL  }
  10155. procedure __llmod;      external;    {   _LL  }
  10156. procedure __llmulo;     external;    {   _LL  (overflow version) }
  10157. procedure __lldivo;     external;    {   _LL  (overflow version) }
  10158. procedure __llmodo;     external;    {   _LL  (overflow version) }
  10159. procedure __llshl;      external;    {   _LL  }
  10160. procedure __llushr;     external;    {   _LL  }
  10161. procedure __llumod;     external;    {   _LL  }
  10162. procedure __lludiv;     external;    {   _LL  }
  10163.  
  10164. function _StrInt64(val: Int64; width: Integer): ShortString;
  10165. var
  10166.   d: array[0..31] of Char;  { need 19 digits and a sign }
  10167.   i, k: Integer;
  10168.   sign: Boolean;
  10169.   spaces: Integer;
  10170. begin
  10171.   { Produce an ASCII representation of the number in reverse order }
  10172.   i := 0;
  10173.   sign := val < 0;
  10174.   repeat
  10175.     d[i] := Chr( Abs(val mod 10) + Ord('0') );
  10176.     Inc(i);
  10177.     val := val div 10;
  10178.   until val = 0;
  10179.   if sign then
  10180.   begin
  10181.     d[i] := '-';
  10182.     Inc(i);
  10183.   end;
  10184.  
  10185.   { Fill the Result with the appropriate number of blanks }
  10186.   if width > 255 then
  10187.     width := 255;
  10188.   k := 1;
  10189.   spaces := width - i;
  10190.   while k <= spaces do
  10191.   begin
  10192.     Result[k] := ' ';
  10193.     Inc(k);
  10194.   end;
  10195.  
  10196.   { Fill the Result with the number }
  10197.   while i > 0 do
  10198.   begin
  10199.     Dec(i);
  10200.     Result[k] := d[i];
  10201.     Inc(k);
  10202.   end;
  10203.  
  10204.   { Result is k-1 characters long }
  10205.   SetLength(Result, k-1);
  10206.  
  10207. end;
  10208.  
  10209. function _Str0Int64(val: Int64): ShortString;
  10210. begin
  10211.   Result := _StrInt64(val, 0);
  10212. end;
  10213.  
  10214. procedure       _WriteInt64;
  10215. asm
  10216. {       PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint);        }
  10217. {     ->EAX     Pointer to file record  }
  10218. {       [ESP+4] Value                   }
  10219. {       EDX     Field width             }
  10220.  
  10221.         SUB     ESP,32          { VAR s: String[31];    }
  10222.  
  10223.         PUSH    EAX
  10224.         PUSH    EDX
  10225.  
  10226.         PUSH    dword ptr [ESP+8+32+8]    { Str( val : 0, s );    }
  10227.         PUSH    dword ptr [ESP+8+32+8]
  10228.         XOR     EAX,EAX
  10229.         LEA     EDX,[ESP+8+8]
  10230.         CALL    _StrInt64
  10231.  
  10232.         POP     ECX
  10233.         POP     EAX
  10234.  
  10235.         MOV     EDX,ESP         { Write( t, s : width );}
  10236.         CALL    _WriteString
  10237.  
  10238.         ADD     ESP,32
  10239.         RET     8
  10240. end;
  10241.  
  10242. procedure       _Write0Int64;
  10243. asm
  10244. {       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
  10245. {     ->EAX     Pointer to file record  }
  10246. {       EDX     Value                   }
  10247.         XOR     EDX,EDX
  10248.         JMP     _WriteInt64
  10249. end;
  10250.  
  10251. procedure       _ReadInt64;     external;       {$L ReadInt64 }
  10252.  
  10253. function _ValInt64(const s: AnsiString; var code: Integer): Int64;
  10254. var
  10255.   i: Integer;
  10256.   dig: Integer;
  10257.   sign: Boolean;
  10258.   empty: Boolean;
  10259. begin
  10260.   i := 1;
  10261.   dig := 0;
  10262.   Result := 0;
  10263.   if s = '' then
  10264.   begin
  10265.     code := i;
  10266.     exit;
  10267.   end;
  10268.   while s[i] = ' ' do
  10269.     Inc(i);
  10270.   sign := False;
  10271.   if s[i] = '-' then
  10272.   begin
  10273.     sign := True;
  10274.     Inc(i);
  10275.   end
  10276.   else if s[i] = '+' then
  10277.     Inc(i);
  10278.   empty := True;
  10279.   if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then
  10280.   begin
  10281.     if s[i] = '0' then
  10282.       Inc(i);
  10283.     Inc(i);
  10284.     while True do
  10285.     begin
  10286.       case s[i] of
  10287.       '0'..'9': dig := Ord(s[i]) -  Ord('0');
  10288.       'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10);
  10289.       'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10);
  10290.       else
  10291.         break;
  10292.       end;
  10293.       if (Result < 0) or (Result > $0FFFFFFFFFFFFFFF) then
  10294.         break;
  10295.       Result := Result shl 4 + dig;
  10296.       Inc(i);
  10297.       empty := False;
  10298.     end;
  10299.     if sign then
  10300.       Result := - Result;
  10301.   end
  10302.   else
  10303.   begin
  10304.     while True do
  10305.     begin
  10306.       case s[i] of
  10307.       '0'..'9': dig := Ord(s[i]) - Ord('0');
  10308.       else
  10309.         break;
  10310.       end;
  10311.       if (Result < 0) or (Result > $7FFFFFFFFFFFFFFF div 10) then
  10312.         break;
  10313.       Result := Result*10 + dig;
  10314.       Inc(i);
  10315.       empty := False;
  10316.     end;
  10317.     if sign then
  10318.       Result := - Result;
  10319.     if (Result <> 0) and (sign <> (Result < 0)) then
  10320.       Dec(i);
  10321.   end;
  10322.   if (s[i] <> #0) or empty then
  10323.     code := i
  10324.   else
  10325.     code := 0;
  10326. end;
  10327.  
  10328. procedure _DynArrayLength;
  10329. asm
  10330. {       FUNCTION _DynArrayLength(const a: array of ...): Longint; }
  10331. {     ->EAX     Pointer to array or nil                           }
  10332. {     <-EAX     High bound of array + 1 or 0                      }
  10333.         TEST    EAX,EAX
  10334.         JZ      @@skip
  10335.         MOV     EAX,[EAX-4]
  10336. @@skip:
  10337. end;
  10338.  
  10339. procedure _DynArrayHigh;
  10340. asm
  10341. {       FUNCTION _DynArrayHigh(const a: array of ...): Longint; }
  10342. {     ->EAX     Pointer to array or nil                         }
  10343. {     <-EAX     High bound of array or -1                       }
  10344.         CALL  _DynArrayLength
  10345.         DEC     EAX
  10346. end;
  10347.  
  10348. type
  10349.   PLongint = ^Longint;
  10350.   PointerArray = array [0..512*1024*1024 -2] of Pointer;
  10351.   PPointerArray = ^PointerArray;
  10352.   PDynArrayTypeInfo = ^TDynArrayTypeInfo;
  10353.   TDynArrayTypeInfo = packed record
  10354.     kind: Byte;
  10355.     name: string[0];
  10356.     elSize: Longint;
  10357.     elType: ^PDynArrayTypeInfo;
  10358.     varType: Integer;
  10359.   end;
  10360.  
  10361.  
  10362. procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer);
  10363. asm
  10364.         PUSH    dword ptr [EBP+8]
  10365.         CALL    _CopyArray
  10366. end;
  10367.  
  10368. procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer);
  10369. asm
  10370.         JMP     _FinalizeArray
  10371. end;
  10372.  
  10373. procedure DynArrayClear(var a: Pointer; typeInfo: Pointer);
  10374. asm
  10375.         CALL    _DynArrayClear
  10376. end;
  10377.  
  10378. procedure DynArraySetLength(var a: Pointer; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: PLongint);
  10379. var
  10380.   i: Integer;
  10381.   newLength, oldLength, minLength: Longint;
  10382.   elSize: Longint;
  10383.   neededSize: Longint;
  10384.   p, pp: Pointer;
  10385. begin
  10386.   p := a;
  10387.  
  10388.   // Fetch the new length of the array in this dimension, and the old length
  10389.   newLength := PLongint(lengthVec)^;
  10390.   if newLength <= 0 then
  10391.   begin
  10392.     if newLength < 0 then
  10393.       Error(reRangeError);
  10394.     DynArrayClear(a, typeInfo);
  10395.     exit;
  10396.   end;
  10397.  
  10398.   oldLength := 0;
  10399.   if p <> nil then
  10400.   begin
  10401.     Dec(PLongint(p));
  10402.     oldLength := PLongint(p)^;
  10403.     Dec(PLongint(p));
  10404.   end;
  10405.  
  10406.   // Calculate the needed size of the heap object
  10407.   Inc(PChar(typeInfo), Length(typeInfo.name));
  10408.   elSize := typeInfo.elSize;
  10409.   if typeInfo.elType <> nil then
  10410.     typeInfo := typeInfo.elType^
  10411.   else
  10412.     typeInfo := nil;
  10413.   neededSize := newLength*elSize;
  10414.   if neededSize div newLength <> elSize then
  10415.     Error(reRangeError);
  10416.   Inc(neededSize, Sizeof(Longint)*2);
  10417.  
  10418.   // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy
  10419.   if (p = nil) or (PLongint(p)^ = 1) then
  10420.   begin
  10421.     pp := p;
  10422.     if (newLength < oldLength) and (typeInfo <> nil) then
  10423.       FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength);
  10424.     ReallocMem(pp, neededSize);
  10425.     p := pp;
  10426.   end
  10427.   else
  10428.   begin
  10429.     Dec(PLongint(p)^);
  10430.     GetMem(p, neededSize);
  10431.     minLength := oldLength;
  10432.     if minLength > newLength then
  10433.       minLength := newLength;
  10434.     if typeInfo <> nil then
  10435.     begin
  10436.       FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0);
  10437.       CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength)
  10438.     end
  10439.     else
  10440.       Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize);
  10441.   end;
  10442.  
  10443.   // The heap object will now have a ref count of 1 and the new length
  10444.   PLongint(p)^ := 1;
  10445.   Inc(PLongint(p));
  10446.   PLongint(p)^ := newLength;
  10447.   Inc(PLongint(p));
  10448.  
  10449.   // Set the new memory to all zero bits
  10450.   FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0);
  10451.  
  10452.   // Take care of the inner dimensions, if any
  10453.   if dimCnt > 1 then
  10454.   begin
  10455.     Inc(lengthVec);
  10456.     Dec(dimCnt);
  10457.     for i := 0 to newLength-1 do
  10458.       DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec);
  10459.   end;
  10460.   a := p;
  10461. end;
  10462.  
  10463. procedure _DynArraySetLength;
  10464. asm
  10465. {       PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) }
  10466. {     ->EAX     Pointer to dynamic array (= pointer to pointer to heap object) }
  10467. {       EDX     Pointer to type info for the dynamic array                     }
  10468. {       ECX     number of dimensions                                           }
  10469. {       [ESP+4] dimensions                                                     }
  10470.         PUSH    ESP
  10471.         ADD     dword ptr [ESP],4
  10472.         CALL    DynArraySetLength
  10473. end;
  10474.  
  10475. procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
  10476. begin
  10477.   if a <> nil then
  10478.     _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result);
  10479. end;
  10480.  
  10481. procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
  10482. var
  10483.   arrayLength: Integer;
  10484.   elSize: Integer;
  10485.   typeInf: PDynArrayTypeInfo;
  10486.   p: Pointer;
  10487. begin
  10488.   p := nil;
  10489.   if a <> nil then
  10490.   begin
  10491.     typeInf := typeInfo;
  10492.  
  10493.     // Limit index and count to values within the array
  10494.     if index < 0 then
  10495.     begin
  10496.       Inc(count, index);
  10497.       index := 0;
  10498.     end;
  10499.     arrayLength := PLongint(PChar(a)-4)^;
  10500.     if index > arrayLength then
  10501.       index := arrayLength;
  10502.     if count > arrayLength - index then
  10503.       count := arrayLength - index;
  10504.     if count < 0 then
  10505.       count := 0;
  10506.  
  10507.     if count > 0 then
  10508.     begin
  10509.       // Figure out the size and type descriptor of the element type
  10510.       Inc(PChar(typeInf), Length(typeInf.name));
  10511.       elSize := typeInf.elSize;
  10512.       if typeInf.elType <> nil then
  10513.         typeInf := typeInf.elType^
  10514.       else
  10515.         typeInf := nil;
  10516.  
  10517.       // Allocate the amount of memory needed
  10518.       GetMem(p, count*elSize + Sizeof(Longint)*2);
  10519.  
  10520.       // The reference count of the new array is 1, the length is count
  10521.       PLongint(p)^ := 1;
  10522.       Inc(PLongint(p));
  10523.       PLongint(p)^ := count;
  10524.       Inc(PLongint(p));
  10525.       Inc(PChar(a), index*elSize);
  10526.  
  10527.       // If the element type needs destruction, we must copy each element,
  10528.       // otherwise we can just copy the bits
  10529.       if count > 0 then
  10530.       begin
  10531.         if typeInf <> nil then
  10532.         begin
  10533.           FillChar(p^, count*elSize, 0);
  10534.           CopyArray(p, a, typeInf, count)
  10535.         end
  10536.         else
  10537.           Move(a^, p^, count*elSize);
  10538.       end;
  10539.     end;
  10540.   end;
  10541.   DynArrayClear(Result, typeInfo);
  10542.   Result := p;
  10543. end;
  10544.  
  10545. procedure _DynArrayClear;
  10546. asm
  10547. {     ->EAX     Pointer to dynamic array (Pointer to pointer to heap object }
  10548. {       EDX     Pointer to type info                                        }
  10549.  
  10550.         {       Nothing to do if Pointer to heap object is nil }
  10551.         MOV     ECX,[EAX]
  10552.         TEST    ECX,ECX
  10553.         JE      @@exit
  10554.  
  10555.         {       Set the variable to be finalized to nil }
  10556.         MOV     dword ptr [EAX],0
  10557.  
  10558.         {       Decrement ref count. Nothing to do if not zero now. }
  10559.    LOCK DEC     dword ptr [ECX-8]
  10560.         JNE     @@exit
  10561.  
  10562.         {       Save the source - we're supposed to return it }
  10563.         PUSH    EAX
  10564.         MOV     EAX,ECX
  10565.  
  10566.         {       Fetch the type descriptor of the elements }
  10567.         XOR     ECX,ECX
  10568.         MOV     CL,[EDX].TDynArrayTypeInfo.name;
  10569.         MOV     EDX,[EDX+ECX].TDynArrayTypeInfo.elType;
  10570.  
  10571.         {       If it's non-nil, finalize the elements }
  10572.         TEST    EDX,EDX
  10573.         JE      @@noFinalize
  10574.         MOV     ECX,[EAX-4]
  10575.         TEST    ECX,ECX
  10576.         JE      @@noFinalize
  10577.         MOV     EDX,[EDX]
  10578.         CALL    _FinalizeArray
  10579. @@noFinalize:
  10580.         {       Now deallocate the array }
  10581.         SUB     EAX,8
  10582.         CALL    _FreeMem
  10583.         POP     EAX
  10584. @@exit:
  10585. end;
  10586.  
  10587.  
  10588. procedure _DynArrayAsg;
  10589. asm
  10590. {     ->EAX     Pointer to destination (pointer to pointer to heap object }
  10591. {       EDX     source (pointer to heap object }
  10592. {       ECX     Pointer to rtti describing dynamic array }
  10593.  
  10594.         PUSH    EBX
  10595.         MOV     EBX,[EAX]
  10596.  
  10597.         {       Increment ref count of source if non-nil }
  10598.  
  10599.         TEST    EDX,EDX
  10600.         JE      @@skipInc
  10601.    LOCK INC     dword ptr [EDX-8]
  10602. @@skipInc:
  10603.         {       Dec ref count of destination - if it becomes 0, clear dest }
  10604.         TEST    EBX,EBX
  10605.         JE  @@skipClear
  10606.    LOCK DEC     dword ptr[EBX-8]
  10607.         JNZ     @@skipClear
  10608.         PUSH    EAX
  10609.         PUSH    EDX
  10610.         MOV     EDX,ECX
  10611.         INC     dword ptr[EBX-8]
  10612.         CALL    _DynArrayClear
  10613.         POP     EDX
  10614.         POP     EAX
  10615. @@skipClear:
  10616.         {       Finally store source into destination }
  10617.         MOV     [EAX],EDX
  10618.  
  10619.         POP     EBX
  10620. end;
  10621.  
  10622. procedure _DynArrayAddRef;
  10623. asm
  10624. {     ->EAX     Pointer to heap object }
  10625.         TEST    EAX,EAX
  10626.         JE      @@exit
  10627.    LOCK INC     dword ptr [EAX-8]
  10628. @@exit:
  10629. end;
  10630.  
  10631.  
  10632. function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer;
  10633. asm
  10634.         {     ->EAX     P                       }
  10635.         {       EDX     Pointer to Indices      }
  10636.         {       ECX     High bound of Indices   }
  10637.         {       [EBP+8] TypInfo                 }
  10638.  
  10639.         PUSH    EBX
  10640.         PUSH    ESI
  10641.         PUSH    EDI
  10642.         PUSH    EBP
  10643.  
  10644.         MOV     ESI,EDX
  10645.         MOV     EDI,[EBP+8]
  10646.         MOV     EBP,EAX
  10647.  
  10648.         XOR     EBX,EBX                 {  for i := 0 to High(Indices) do       }
  10649.         TEST    ECX,ECX
  10650.         JGE     @@start
  10651. @@loop:
  10652.         MOV     EBP,[EBP]
  10653. @@start:
  10654.         XOR     EAX,EAX
  10655.         MOV     AL,[EDI].TDynArrayTypeInfo.name
  10656.         ADD     EDI,EAX
  10657.         MOV     EAX,[ESI+EBX*4]         {    P := P + Indices[i]*TypInfo.elSize }
  10658.         MUL     [EDI].TDynArrayTypeInfo.elSize
  10659.         MOV     EDI,[EDI].TDynArrayTypeInfo.elType
  10660.         TEST    EDI,EDI
  10661.         JE      @@skip
  10662.         MOV     EDI,[EDI]
  10663. @@skip:
  10664.         ADD     EBP,EAX
  10665.         INC     EBX
  10666.         CMP     EBX,ECX
  10667.         JLE     @@loop
  10668.  
  10669. @@loopEnd:
  10670.  
  10671.         MOV     EAX,EBP
  10672.  
  10673.         POP     EBP
  10674.         POP     EDI
  10675.         POP     ESI
  10676.         POP     EBX
  10677. end;
  10678.  
  10679.  
  10680.  
  10681. type
  10682.   TBoundArray = array of Integer;
  10683.   PPointer    = ^Pointer;
  10684.  
  10685.  
  10686. { Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo }
  10687. function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo;
  10688. begin
  10689.   Result := nil;
  10690.   if typeInfo <> nil then
  10691.   begin
  10692.     Inc(PChar(typeInfo), Length(typeInfo.name));
  10693.     if typeInfo.elType <> nil then
  10694.       Result := typeInfo.elType^;
  10695.   end;
  10696. end;
  10697.  
  10698. { Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo}
  10699. function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer;
  10700. begin
  10701.   Result := 0;
  10702.   while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do
  10703.   begin
  10704.     Inc(Result);
  10705.     typeInfo := DynArrayElTypeInfo(typeInfo);
  10706.   end;
  10707. end;
  10708.  
  10709. { Returns size of the Dynamic Array}
  10710. function DynArraySize(a: Pointer): Integer;
  10711. asm
  10712.         TEST EAX, EAX
  10713.         JZ   @@exit
  10714.         MOV  EAX, [EAX-4]
  10715. @@exit:
  10716. end;
  10717.  
  10718. // Returns whether array is rectangular
  10719. function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean;
  10720. var
  10721.   Dim, I, J, Size, SubSize: Integer;
  10722.   P: Pointer;
  10723. begin
  10724.   // Assume we have a rectangular array
  10725.   Result := True;
  10726.  
  10727.   P := DynArray;
  10728.   Dim := DynArrayDim(typeInfo);
  10729.  
  10730.   {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition}
  10731.   for I := 1 to dim-1 do
  10732.   begin
  10733.     if P <> nil then
  10734.     begin
  10735.       { Get size of this dimension }
  10736.       Size := DynArraySize(P);
  10737.  
  10738.       { Get Size of first sub. dimension }
  10739.       SubSize := DynArraySize(PPointerArray(P)[0]);
  10740.  
  10741.       { Walk through every dimension making sure they all have the same size}
  10742.       for J := 1  to Size-1 do
  10743.         if DynArraySize(PPointerArray(P)[J]) <> SubSize then
  10744.         begin
  10745.           Result := False;
  10746.           Exit;
  10747.         end;
  10748.  
  10749.       { Point to next dimension}
  10750.       P := PPointerArray(P)[0];
  10751.     end;
  10752.   end;
  10753. end;
  10754.  
  10755. // Returns Bounds of a DynamicArray in a format usable for creating a Variant.
  10756. //  i.e. The format of the bounds returns contains pairs of lo and hi bounds where
  10757. //       lo is always 0, and hi is the size dimension of the array-1.
  10758. function DynArrayVariantBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
  10759. var
  10760.   Dim, I: Integer;
  10761.   P: Pointer;
  10762. begin
  10763.   P := DynArray;
  10764.  
  10765.   Dim := DynArrayDim(typeInfo);
  10766.   SetLength(Result, Dim*2);
  10767.  
  10768.   I := 0;
  10769.   while I < dim*2 do
  10770.   begin
  10771.     Result[I] := 0;   // Always use 0 as low-bound in low/high pair
  10772.     Inc(I);
  10773.     if P <> nil then
  10774.     begin
  10775.       Result[I] := DynArraySize(P)-1; // Adjust for 0-base low-bound
  10776.       P := PPointerArray(p)[0];       // Assume rectangular arrays
  10777.     end;
  10778.     Inc(I);
  10779.   end;
  10780. end;
  10781.  
  10782. // Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension
  10783. function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
  10784. var
  10785.   Dim, I: Integer;
  10786.   P: Pointer;
  10787. begin
  10788.   P := DynArray;
  10789.  
  10790.   Dim := DynArrayDim(typeInfo);
  10791.   SetLength(Result, Dim);
  10792.  
  10793.   for I := 0 to dim-1 do
  10794.     if P <> nil then
  10795.     begin
  10796.       Result[I] := DynArraySize(P)-1;
  10797.       P := PPointerArray(P)[0]; // Assume rectangular arrays
  10798.     end;
  10799. end;
  10800.  
  10801. // The dynamicArrayTypeInformation contains the VariantType of the element type
  10802. // when the kind == tkDynArray. This function returns that VariantType.
  10803. function DynArrayVarType(typeInfo: PDynArrayTypeInfo): Integer;
  10804. begin
  10805.   Result := varNull;
  10806.   if (typeInfo <> nil) and (typeInfo.Kind = tkDynArray) then
  10807.   begin
  10808.     Inc(PChar(typeInfo), Length(typeInfo.name));
  10809.     Result := typeInfo.varType;
  10810.   end;
  10811.  
  10812.   { NOTE: DECL.H and SYSTEM.PAS have different values for varString }
  10813.   if Result = $48 then
  10814.     Result := varString;
  10815. end;
  10816.  
  10817. type
  10818.   IntegerArray  = array[0..$effffff] of Integer;
  10819.   PIntegerArray = ^IntegerArray;
  10820.   PSmallInt     = ^SmallInt;
  10821.   PInteger      = ^Integer;
  10822.   PSingle       = ^Single;
  10823.   PDouble       = ^Double;
  10824.   PDate         = ^Double;
  10825.   PDispatch     = ^IDispatch;
  10826.   PPDispatch    = ^PDispatch;
  10827.   PError        = ^LongWord;
  10828.   PWordBool     = ^WordBool;
  10829.   PUnknown      = ^IUnknown;
  10830.   PPUnknown     = ^PUnknown;
  10831.   PByte         = ^Byte;
  10832.   PPWideChar    = ^PWideChar;
  10833.  
  10834. { Decrements to next lower index - Returns True if successful }
  10835. { Indices: Indices to be decremented }
  10836. { Bounds : High bounds of each dimension }
  10837. function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean;
  10838. var
  10839.   I, J: Integer;
  10840. begin
  10841.   { Find out if we're done: all at zeroes }
  10842.   Result := False;
  10843.   for I := Low(Indices)  to High(Indices) do
  10844.     if Indices[I] <> 0  then
  10845.     begin
  10846.       Result := True;
  10847.       break;
  10848.     end;
  10849.   if not Result then
  10850.     Exit;
  10851.  
  10852.   { Two arrays must be of same length }
  10853.   Assert(Length(Indices) = Length(Bounds));
  10854.  
  10855.   { Find index of item to tweak }
  10856.   for I := High(Indices) downto Low(Bounds) do
  10857.   begin
  10858.     // If not reach zero, dec and bail out
  10859.     if Indices[I] <> 0 then
  10860.     begin
  10861.       Dec(Indices[I]);
  10862.       Exit;
  10863.     end
  10864.     else
  10865.     begin
  10866.       J := I;
  10867.       while Indices[J] = 0 do
  10868.       begin
  10869.         // Restore high bound when we've reached zero on a particular dimension
  10870.         Indices[J] := Bounds[J];
  10871.         // Move to higher dimension
  10872.         Dec(J);
  10873.         Assert(J >= 0);
  10874.       end;
  10875.       Dec(Indices[J]);
  10876.       Exit;
  10877.     end;
  10878.   end;
  10879. end;
  10880.  
  10881. // Copy Contents of Dynamic Array to Variant
  10882. // NOTE: The Dynamic array must be rectangular
  10883. //       The Dynamic array must contain items whose type is Automation compatible
  10884. // In case of failure, the function returns with a Variant of type VT_EMPTY.
  10885. procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
  10886. var
  10887.   VarBounds, Bounds, Indices: TBoundArray;
  10888.   DAVarType, VVarType, DynDim: Integer;
  10889.   PDAData: Pointer;
  10890.   Value: Variant;
  10891. begin
  10892.   VarBounds := nil;
  10893.   Bounds    := nil;
  10894.   { This resets the Variant to VT_EMPTY - flag which is used to determine whether the }
  10895.   { the cast to Variant succeeded or not }
  10896.   VarClear(V);
  10897.  
  10898.   { Get variantType code from DynArrayTypeInfo }
  10899.   DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));
  10900.  
  10901.   { Validate the Variant Type }
  10902.   if ((DAVarType > varNull) and (DAVarType <= varByte)) or (DAVarType = varString) then
  10903.   begin
  10904.     {NOTE: Map varString to varOleStr for SafeArrayCreate call }
  10905.     if DAVarType = varString then
  10906.       VVarType := varOleStr
  10907.     else
  10908.       VVarType := DAVarType;
  10909.  
  10910.     { Get dimension of Dynamic Array }
  10911.     DynDim := DynarrayDim(PDynArrayTypeInfo(TypeInfo));
  10912.  
  10913.     { If more than one dimension, make sure we're dealing with a rectangular array }
  10914.     if DynDim > 1 then
  10915.       if not IsDynArrayRectangular(DynArray, PDynArrayTypeInfo(TypeInfo)) then
  10916.         Exit;
  10917.  
  10918.     { Get Variant-style Bounds (lo/hi pair) of Dynamic Array }
  10919.     VarBounds := DynArrayVariantBounds(DynArray, TypeInfo);
  10920.  
  10921.     { Get DynArray Bounds }
  10922.     Bounds := DynArrayBounds(DynArray, TypeInfo);
  10923.     Indices:= Copy(Bounds);
  10924.  
  10925.     { Create Variant of SAFEARRAY }
  10926.     V := VarArrayCreate(VarBounds, VVarType);
  10927.     Assert(VarArrayDimCount(V) = DynDim);
  10928.  
  10929.     repeat
  10930.       PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
  10931.       if PDAData <> nil then
  10932.       begin
  10933.         case DAVarType of
  10934.           varSmallInt:  Value := PSmallInt(PDAData)^;
  10935.           varInteger:   Value := PInteger(PDAData)^;
  10936.           varSingle:    value := PSingle(PDAData)^;
  10937.           varDouble:    value := PDouble(PDAData)^;
  10938.           varCurrency:  Value := PCurrency(PDAData)^;
  10939.           varDate:      Value := PDouble(PDAData)^;
  10940.           varOleStr:    Value := PWideString(PDAData)^;
  10941.           varDispatch:  Value := PDispatch(PDAData)^;
  10942.           varError:     Value := PError(PDAData)^;
  10943.           varBoolean:   Value := PWordBool(PDAData)^;
  10944.           varVariant:   Value := PVariant(PDAData)^;
  10945.           varUnknown:   Value := PUnknown(PDAData)^;
  10946.           varByte:      Value := PByte(PDAData)^;
  10947.           varString:    Value := PString(PDAData)^;
  10948.         else
  10949.           VarClear(Value);
  10950.         end; { case }
  10951.         VarArrayPut(V, Value, Indices);
  10952.       end;
  10953.     until not DecIndices(Indices, Bounds);
  10954.   end;
  10955. end;
  10956.  
  10957. // Copies data from the Variant to the DynamicArray
  10958. procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
  10959. var
  10960.   DADimCount, VDimCount : Integer;
  10961.   DAVarType, I: Integer;
  10962.   lengthVec: PLongInt;
  10963.   Bounds, Indices: TBoundArray;
  10964.   Value: Variant;
  10965.   PDAData: Pointer;
  10966. begin
  10967.   { Get Variant information }
  10968.   VDimCount:= VarArrayDimCount(V);
  10969.  
  10970.   { Allocate vector for lengths }
  10971.   GetMem(lengthVec, VDimCount * sizeof(Integer));
  10972.  
  10973.   { Initialize lengths - NOTE: VarArrayxxxxBound are 1-based.}
  10974.   for I := 0  to  VDimCount-1 do
  10975.     PIntegerArray(lengthVec)[I]:= (VarArrayHighBound(V, I+1) - VarArrayLowBound(V, I+1)) + 1;
  10976.  
  10977.   { Set Length of DynArray }
  10978.   DynArraySetLength(DynArray, PDynArrayTypeInfo(TypeInfo), VDimCount, lengthVec);
  10979.  
  10980.   { Get DynArray information }
  10981.   DADimCount:= DynArrayDim(PDynArrayTypeInfo(TypeInfo));
  10982.   DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));
  10983.   Assert(VDimCount = DADimCount);
  10984.  
  10985.   { Get DynArray Bounds }
  10986.   Bounds := DynArrayBounds(DynArray, TypeInfo);
  10987.   Indices:= Copy(Bounds);
  10988.  
  10989.   { Copy data over}
  10990.   repeat
  10991.     Value   := VarArrayGet(V, Indices);
  10992.     PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
  10993.     case DAVarType of
  10994.       varSmallInt:  PSmallInt(PDAData)^   := Value;
  10995.       varInteger:   PInteger(PDAData)^    := Value;
  10996.       varSingle:    PSingle(PDAData)^     := Value;
  10997.       varDouble:    PDouble(PDAData)^     := Value;
  10998.       varCurrency:  PCurrency(PDAData)^   := Value;
  10999.       varDate:      PDouble(PDAData)^     := Value;
  11000.       varOleStr:    PWideString(PDAData)^ := Value;
  11001.       varDispatch:  PDispatch(PDAData)^   := Value;
  11002.       varError:     PError(PDAData)^      := Value;
  11003.       varBoolean:   PWordBool(PDAData)^   := Value;
  11004.       varVariant:   PVariant(PDAData)^    := Value;
  11005.       varUnknown:   PUnknown(PDAData)^    := value;
  11006.       varByte:      PByte(PDAData)^       := Value;
  11007.       varString:    PString(PDAData)^     := Value;
  11008.     end; { case }
  11009.   until not DecIndices(Indices, Bounds);
  11010.  
  11011.   { Free vector of lengths }
  11012.   FreeMem(lengthVec);
  11013. end;
  11014.  
  11015.  
  11016.  
  11017. { Package/Module registration/unregistration }
  11018.  
  11019. const
  11020.   LOCALE_SABBREVLANGNAME = $00000003;   { abbreviated language name }
  11021.   LOAD_LIBRARY_AS_DATAFILE = 2;
  11022.   HKEY_CURRENT_USER = $80000001;
  11023.   KEY_ALL_ACCESS = $000F003F;
  11024.  
  11025.   OldLocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize
  11026.   NewLocaleOverrideKey = 'Software\Borland\Locales'; // do not localize
  11027.  
  11028. function FindHInstance(Address: Pointer): LongWord;
  11029. var
  11030.   MemInfo: TMemInfo;
  11031. begin
  11032.   VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
  11033.   if MemInfo.State = $1000{MEM_COMMIT} then
  11034.     Result := Longint(MemInfo.AllocationBase)
  11035.   else Result := 0;
  11036. end;
  11037.  
  11038. function FindClassHInstance(ClassType: TClass): LongWord;
  11039. begin
  11040.   Result := FindHInstance(Pointer(ClassType));
  11041. end;
  11042.  
  11043. function FindResourceHInstance(Instance: LongWord): LongWord;
  11044. var
  11045.   CurModule: PLibModule;
  11046. begin
  11047.   CurModule := LibModuleList;
  11048.   while CurModule <> nil do
  11049.   begin
  11050.     if (Instance = CurModule.Instance) or
  11051.        (Instance = CurModule.CodeInstance) or
  11052.        (Instance = CurModule.DataInstance) then
  11053.     begin
  11054.       Result := CurModule.ResInstance;
  11055.       Exit;
  11056.     end;
  11057.     CurModule := CurModule.Next;
  11058.   end;
  11059.   Result := Instance;
  11060. end;
  11061.  
  11062. function LoadResourceModule(ModuleName: PChar): LongWord;
  11063. var
  11064.   FileName: array[0..260] of Char;
  11065.   Key: LongWord;
  11066.   LocaleName, LocaleOverride: array[0..4] of Char;
  11067.   Size: Integer;
  11068.   P: PChar;
  11069.  
  11070.   function FindBS(Current: PChar): PChar;
  11071.   begin
  11072.     Result := Current;
  11073.     while (Result^ <> #0) and (Result^ <> '\') do
  11074.       Result := CharNext(Result);
  11075.   end;
  11076.  
  11077.   function ToLongPath(AFileName: PChar): PChar;
  11078.   var
  11079.     CurrBS, NextBS: PChar;
  11080.     Handle, L: Integer;
  11081.     FindData: TWin32FindData;
  11082.     Buffer: array[0..260] of Char;
  11083.     GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar;
  11084.       cchBuffer: Integer): Integer stdcall;
  11085.   begin
  11086.     Result := AFileName;
  11087.     Handle := GetModuleHandle(kernel);
  11088.     if Handle <> 0 then
  11089.     begin
  11090.       @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA');
  11091.       if Assigned(GetLongPathName) and
  11092.          (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then
  11093.       begin
  11094.         lstrcpy(AFileName, Buffer);
  11095.         Exit;
  11096.       end;
  11097.     end;
  11098.  
  11099.     if AFileName[0] = '\' then
  11100.     begin
  11101.       if AFileName[1] <> '\' then Exit;
  11102.       CurrBS := FindBS(AFileName + 2);  // skip server name
  11103.       if CurrBS^ = #0 then Exit;
  11104.       CurrBS := FindBS(CurrBS + 1);     // skip share name
  11105.       if CurrBS^ = #0 then Exit;
  11106.     end else
  11107.       CurrBS := AFileName + 2;          // skip drive name
  11108.  
  11109.     L := CurrBS - AFileName;
  11110.     lstrcpyn(Buffer, AFileName, L + 1);
  11111.     while CurrBS^ <> #0 do
  11112.     begin
  11113.       NextBS := FindBS(CurrBS + 1);
  11114.       if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit;
  11115.       lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1);
  11116.  
  11117.       Handle := FindFirstFile(Buffer, FindData);
  11118.       if (Handle = -1) then Exit;
  11119.       FindClose(Handle);
  11120.  
  11121.       if L + 1 + lstrlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit;
  11122.       Buffer[L] := '\';
  11123.       lstrcpy(Buffer + L + 1, FindData.cFileName);
  11124.       Inc(L, lstrlen(FindData.cFileName) + 1);
  11125.       CurrBS := NextBS;
  11126.     end;
  11127.     lstrcpy(AFileName, Buffer);
  11128.   end;
  11129.  
  11130. begin
  11131.   GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host appliation name
  11132.   LocaleOverride[0] := #0;
  11133.   if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) or
  11134.    (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) then
  11135.   try
  11136.     Size := SizeOf(LocaleOverride);
  11137.     if RegQueryValueEx(Key, ToLongPath(FileName), nil, nil, LocaleOverride, @Size) <> 0 then
  11138.       RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size);
  11139.   finally
  11140.     RegCloseKey(Key);
  11141.   end;
  11142.   lstrcpy(FileName, ModuleName);
  11143.   GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
  11144.   Result := 0;
  11145.   if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then
  11146.   begin
  11147.     P := PChar(@FileName) + lstrlen(FileName);
  11148.     while (P^ <> '.') and (P <> @FileName) do Dec(P);
  11149.     if P <> @FileName then
  11150.     begin
  11151.       Inc(P);
  11152.       // First look for a locale registry override
  11153.       if LocaleOverride[0] <> #0 then
  11154.       begin
  11155.         lstrcpy(P, LocaleOverride);
  11156.         Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  11157.       end;
  11158.       if (Result = 0) and (LocaleName[0] <> #0) then
  11159.       begin
  11160.         // Then look for a potential language/country translation
  11161.         lstrcpy(P, LocaleName);
  11162.         Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  11163.         if Result = 0 then
  11164.         begin
  11165.           // Finally look for a language only translation
  11166.           LocaleName[2] := #0;
  11167.           lstrcpy(P, LocaleName);
  11168.           Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  11169.         end;
  11170.       end;
  11171.     end;
  11172.   end;
  11173. end;
  11174.  
  11175. procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler;
  11176. begin
  11177.   EnumModules(TEnumModuleFuncLW(Func), Data);
  11178. end;
  11179.  
  11180. procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
  11181. begin
  11182.   EnumResourceModules(TEnumModuleFuncLW(Func), Data);
  11183. end;
  11184.  
  11185. procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer);
  11186. var
  11187.   CurModule: PLibModule;
  11188. begin
  11189.   CurModule := LibModuleList;
  11190.   while CurModule <> nil do
  11191.   begin
  11192.     if not Func(CurModule.Instance, Data) then Exit;
  11193.     CurModule := CurModule.Next;
  11194.   end;
  11195. end;
  11196.  
  11197. procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer);
  11198. var
  11199.   CurModule: PLibModule;
  11200. begin
  11201.   CurModule := LibModuleList;
  11202.   while CurModule <> nil do
  11203.   begin
  11204.     if not Func(CurModule.ResInstance, Data) then Exit;
  11205.     CurModule := CurModule.Next;
  11206.   end;
  11207. end;
  11208.  
  11209. procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
  11210. begin
  11211.   AddModuleUnloadProc(TModuleUnloadProcLW(Proc));
  11212. end;
  11213.  
  11214. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
  11215. begin
  11216.   RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc));
  11217. end;
  11218.  
  11219. procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW);
  11220. var
  11221.   P: PModuleUnloadRec;
  11222. begin
  11223.   New(P);
  11224.   P.Next := ModuleUnloadList;
  11225.   @P.Proc := @Proc;
  11226.   ModuleUnloadList := P;
  11227. end;
  11228.  
  11229. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW);
  11230. var
  11231.   P, C: PModuleUnloadRec;
  11232. begin
  11233.   P := ModuleUnloadList;
  11234.   if (P <> nil) and (@P.Proc = @Proc) then
  11235.   begin
  11236.     ModuleUnloadList := ModuleUnloadList.Next;
  11237.     Dispose(P);
  11238.   end else
  11239.   begin
  11240.     C := P;
  11241.     while C <> nil do
  11242.     begin
  11243.       if (C.Next <> nil) and (@C.Next.Proc = @Proc) then
  11244.       begin
  11245.         P := C.Next;
  11246.         C.Next := C.Next.Next;
  11247.         Dispose(P);
  11248.         Break;
  11249.       end;
  11250.       C := C.Next;
  11251.     end;
  11252.   end;
  11253. end;
  11254.  
  11255. procedure NotifyModuleUnload(HInstance: LongWord);
  11256. var
  11257.   P: PModuleUnloadRec;
  11258. begin
  11259.   P := ModuleUnloadList;
  11260.   while P <> nil do
  11261.   begin
  11262.     try
  11263.       P.Proc(HInstance);
  11264.     except
  11265.       // Make sure it doesn't stop notifications
  11266.     end;
  11267.     P := P.Next;
  11268.   end;
  11269. end;
  11270.  
  11271. procedure RegisterModule(LibModule: PLibModule);
  11272. begin
  11273.   LibModule.Next := LibModuleList;
  11274.   LibModuleList := LibModule;
  11275. end;
  11276.  
  11277. procedure UnregisterModule(LibModule: PLibModule);
  11278. var
  11279.   CurModule: PLibModule;
  11280. begin
  11281.   try
  11282.     NotifyModuleUnload(LibModule.Instance);
  11283.   finally
  11284.     if LibModule = LibModuleList then
  11285.       LibModuleList := LibModule.Next
  11286.     else
  11287.     begin
  11288.       CurModule := LibModuleList;
  11289.       while CurModule <> nil do
  11290.       begin
  11291.         if CurModule.Next = LibModule then
  11292.         begin
  11293.           CurModule.Next := LibModule.Next;
  11294.           Break;
  11295.         end;
  11296.         CurModule := CurModule.Next;
  11297.       end;
  11298.     end;
  11299.   end;
  11300. end;
  11301.  
  11302. { ResString support function }
  11303.  
  11304. function LoadResString(ResStringRec: PResStringRec): string;
  11305. var
  11306.   Buffer: array[0..1023] of Char;
  11307. begin
  11308.   if ResStringRec <> nil then
  11309.   if ResStringRec.Identifier < 64*1024 then
  11310.     SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^),
  11311.     ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
  11312.   else
  11313.     Result := PChar(ResStringRec.Identifier);
  11314. end;
  11315.  
  11316. procedure _IntfClear(var Dest: IUnknown);
  11317. asm
  11318.         MOV     EDX,[EAX]
  11319.         TEST    EDX,EDX
  11320.         JE      @@1
  11321.         MOV     DWORD PTR [EAX],0
  11322.         PUSH    EAX
  11323.         PUSH    EDX
  11324.         MOV     EAX,[EDX]
  11325.         CALL    [EAX].vmtRelease.Pointer
  11326.         POP     EAX
  11327. @@1:
  11328. end;
  11329.  
  11330. procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
  11331. asm
  11332.         MOV     ECX,[EAX]       { save dest }
  11333.         MOV     [EAX],EDX       { assign dest }
  11334.         TEST    EDX,EDX         { need to addref source before releasing dest }
  11335.         JE      @@1             { to make self assignment (I := I) work right }
  11336.         PUSH    ECX
  11337.         PUSH    EDX
  11338.         MOV     EAX,[EDX]
  11339.         CALL    [EAX].vmtAddRef.Pointer
  11340.         POP     ECX
  11341. @@1:    TEST    ECX,ECX
  11342.         JE      @@2
  11343.         PUSH    ECX
  11344.         MOV     EAX,[ECX]
  11345.         CALL    [EAX].vmtRelease.Pointer
  11346. @@2:
  11347. end;
  11348.  
  11349. procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
  11350. asm
  11351.         TEST    EDX,EDX
  11352.         JE      _IntfClear
  11353.         PUSH    EAX
  11354.         PUSH    ECX
  11355.         PUSH    EDX
  11356.         MOV     ECX,[EAX]
  11357.         TEST    ECX,ECX
  11358.         JE      @@1
  11359.         PUSH    ECX
  11360.         MOV     EAX,[ECX]
  11361.         CALL    [EAX].vmtRelease.Pointer
  11362.         MOV     EDX,[ESP]
  11363. @@1:    MOV     EAX,[EDX]
  11364.         CALL    [EAX].vmtQueryInterface.Pointer
  11365.         TEST    EAX,EAX
  11366.         JE      @@2
  11367.         MOV     AL,reIntfCastError
  11368.         JMP     Error
  11369. @@2:
  11370. end;
  11371.  
  11372. procedure _IntfAddRef(const Dest: IUnknown);
  11373. begin
  11374.   if Dest <> nil then Dest._AddRef;
  11375. end;
  11376.  
  11377. procedure TInterfacedObject.AfterConstruction;
  11378. begin
  11379. // Release the constructor's implicit refcount
  11380.   InterlockedDecrement(FRefCount);
  11381. end;
  11382.  
  11383. procedure TInterfacedObject.BeforeDestruction;
  11384. begin
  11385.   if RefCount <> 0 then Error(reInvalidPtr);
  11386. end;
  11387.  
  11388. // Set an implicit refcount so that refcounting
  11389. // during construction won't destroy the object.
  11390. class function TInterfacedObject.NewInstance: TObject;
  11391. begin
  11392.   Result := inherited NewInstance;
  11393.   TInterfacedObject(Result).FRefCount := 1;
  11394. end;
  11395.  
  11396. function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
  11397. const
  11398.   E_NOINTERFACE = HResult($80004002);
  11399. begin
  11400.   if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
  11401. end;
  11402.  
  11403. function TInterfacedObject._AddRef: Integer;
  11404. begin
  11405.   Result := InterlockedIncrement(FRefCount);
  11406. end;
  11407.  
  11408. function TInterfacedObject._Release: Integer;
  11409. begin
  11410.   Result := InterlockedDecrement(FRefCount);
  11411.   if Result = 0 then
  11412.     Destroy;
  11413. end;
  11414.  
  11415. procedure _CheckAutoResult;
  11416. asm
  11417.         TEST    EAX,EAX
  11418.         JNS     @@2
  11419.         MOV     ECX,SafeCallErrorProc
  11420.         TEST    ECX,ECX
  11421.         JE      @@1
  11422.         MOV     EDX,[ESP]
  11423.         CALL    ECX
  11424. @@1:    MOV     AL,reSafeCallError
  11425.         JMP     Error
  11426. @@2:
  11427. end;
  11428.  
  11429.  
  11430. procedure _IntfDispCall;
  11431. asm
  11432.         JMP     DispCallByIDProc
  11433. end;
  11434.  
  11435.  
  11436. procedure _IntfVarCall;
  11437. asm
  11438. end;
  11439.  
  11440. function  CompToDouble(acomp: Comp): Double; cdecl;
  11441. begin
  11442.   Result := acomp;
  11443. end;
  11444.  
  11445. procedure  DoubleToComp(adouble: Double; var result: Comp); cdecl;
  11446. begin
  11447.   result := adouble;
  11448. end;
  11449.  
  11450. function  CompToCurrency(acomp: Comp): Currency; cdecl;
  11451. begin
  11452.   Result := acomp;
  11453. end;
  11454.  
  11455. procedure  CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;
  11456. begin
  11457.   result := acurrency
  11458. end;
  11459.  
  11460. function GetMemory(Size: Integer): Pointer; cdecl;
  11461. begin
  11462.   Result := SysGetMem(Size);
  11463. end;
  11464.  
  11465. function FreeMemory(P: Pointer): Integer; cdecl;
  11466. begin
  11467.   if P = nil then
  11468.     Result := 0
  11469.   else
  11470.     Result := SysFreeMem(P);
  11471. end;
  11472.  
  11473. function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
  11474. begin
  11475.   Result := SysReallocMem(P, Size);
  11476. end;
  11477.  
  11478. function GetCurrentThreadId: DWORD; stdcall; external kernel name 'GetCurrentThreadId';
  11479.  
  11480. initialization
  11481.  
  11482.   ExitCode  := 0;
  11483.   ErrorAddr := nil;
  11484.  
  11485.   RandSeed := 0;
  11486.   FileMode := 2;
  11487.  
  11488.   Test8086 := 2;
  11489.   Test8087 := 3;
  11490.  
  11491.   TVarData(Unassigned).VType := varEmpty;
  11492.   TVarData(Null).VType := varNull;
  11493.   TVarData(EmptyParam).VType := varError;
  11494.   TVarData(EmptyParam).VError := $80020004; {DISP_E_PARAMNOTFOUND}
  11495.  
  11496.   ClearAnyProc := @VarInvalidOp;
  11497.   ChangeAnyProc := @VarCastError;
  11498.   RefAnyProc := @VarInvalidOp;
  11499.  
  11500.   if _isNECWindows then _FpuMaskInit;
  11501.   _FpuInit();
  11502.  
  11503.   _Assign( Input, '' );  { _ResetText( Input );   }
  11504.   _Assign( Output, '' );  { _RewritText( Output ); }
  11505.  
  11506.   CmdLine := GetCommandLine;
  11507.   CmdShow := GetCmdShow;
  11508.   MainThreadID := GetCurrentThreadID;
  11509.  
  11510. finalization
  11511.   Close(Input);
  11512.   Close(Output);
  11513.   UninitAllocator;
  11514. end.
  11515.