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