system/system.~pas

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