home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / SYSTEM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  188.0 KB  |  7,311 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi Runtime Library                          }
  4. {       System Unit                                     }
  5. {                                                       }
  6. {       Copyright (C) 1988,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit System;
  11.  
  12. {$H+,I-,S-}
  13.  
  14. interface
  15.  
  16. const
  17.  
  18. { Variant type codes }
  19.  
  20.   varEmpty    = $0000;
  21.   varNull     = $0001;
  22.   varSmallint = $0002;
  23.   varInteger  = $0003;
  24.   varSingle   = $0004;
  25.   varDouble   = $0005;
  26.   varCurrency = $0006;
  27.   varDate     = $0007;
  28.   varOleStr   = $0008;
  29.   varDispatch = $0009;
  30.   varError    = $000A;
  31.   varBoolean  = $000B;
  32.   varVariant  = $000C;
  33.   varUnknown  = $000D;
  34.   varByte     = $0011;
  35.   varString   = $0100;
  36.   varTypeMask = $0FFF;
  37.   varArray    = $2000;
  38.   varByRef    = $4000;
  39.  
  40. { TVarRec.VType values }
  41.  
  42.   vtInteger    = 0;
  43.   vtBoolean    = 1;
  44.   vtChar       = 2;
  45.   vtExtended   = 3;
  46.   vtString     = 4;
  47.   vtPointer    = 5;
  48.   vtPChar      = 6;
  49.   vtObject     = 7;
  50.   vtClass      = 8;
  51.   vtWideChar   = 9;
  52.   vtPWideChar  = 10;
  53.   vtAnsiString = 11;
  54.   vtCurrency   = 12;
  55.   vtVariant    = 13;
  56.  
  57. type
  58.  
  59.   TObject = class;
  60.  
  61.   TClass = class of TObject;
  62.  
  63.   TObject = class
  64.     constructor Create;
  65.     procedure Free;
  66.     class function InitInstance(Instance: Pointer): TObject;
  67.     procedure CleanupInstance;
  68.     function ClassType: TClass;
  69.     class function ClassName: ShortString;
  70.     class function ClassNameIs(const Name: string): Boolean;
  71.     class function ClassParent: TClass;
  72.     class function ClassInfo: Pointer;
  73.     class function InstanceSize: Longint;
  74.     class function InheritsFrom(AClass: TClass): Boolean;
  75.     procedure Dispatch(var Message);
  76.     class function MethodAddress(const Name: ShortString): Pointer;
  77.     class function MethodName(Address: Pointer): ShortString;
  78.     function FieldAddress(const Name: ShortString): Pointer;
  79.     procedure DefaultHandler(var Message); virtual;
  80.     class function NewInstance: TObject; virtual;
  81.     procedure FreeInstance; virtual;
  82.     destructor Destroy; virtual;
  83.   end;
  84.  
  85.   TVarArrayBound = record
  86.     ElementCount: Integer;
  87.     LowBound: Integer;
  88.   end;
  89.  
  90.   PVarArray = ^TVarArray;
  91.   TVarArray = record
  92.     DimCount: Word;
  93.     Flags: Word;
  94.     ElementSize: Integer;
  95.     LockCount: Integer;
  96.     Data: Pointer;
  97.     Bounds: array[0..255] of TVarArrayBound;
  98.   end;
  99.  
  100.   PVarData = ^TVarData;
  101.   TVarData = record
  102.     VType: Word;
  103.     Reserved1, Reserved2, Reserved3: Word;
  104.     case Integer of
  105.       varSmallint: (VSmallint: Smallint);
  106.       varInteger:  (VInteger: Integer);
  107.       varSingle:   (VSingle: Single);
  108.       varDouble:   (VDouble: Double);
  109.       varCurrency: (VCurrency: Currency);
  110.       varDate:     (VDate: Double);
  111.       varOleStr:   (VOleStr: PWideChar);
  112.       varDispatch: (VDispatch: Pointer);
  113.       varError:    (VError: Integer);
  114.       varBoolean:  (VBoolean: WordBool);
  115.       varUnknown:  (VUnknown: Pointer);
  116.       varByte:     (VByte: Byte);
  117.       varString:   (VString: Pointer);
  118.       varArray:    (VArray: PVarArray);
  119.       varByRef:    (VPointer: Pointer);
  120.   end;
  121.  
  122.   PShortString = ^ShortString;
  123.   PAnsiString = ^AnsiString;
  124.   PString = PAnsiString;
  125.  
  126.   PExtended = ^Extended;
  127.   PCurrency = ^Currency;
  128.   PVariant = ^Variant;
  129.  
  130.   TDateTime = type Double;
  131.  
  132.   PVarRec = ^TVarRec;
  133.   TVarRec = record
  134.     case Byte of
  135.       vtInteger:    (VInteger: Integer; VType: Byte);
  136.       vtBoolean:    (VBoolean: Boolean);
  137.       vtChar:       (VChar: Char);
  138.       vtExtended:   (VExtended: PExtended);
  139.       vtString:     (VString: PShortString);
  140.       vtPointer:    (VPointer: Pointer);
  141.       vtPChar:      (VPChar: PChar);
  142.       vtObject:     (VObject: TObject);
  143.       vtClass:      (VClass: TClass);
  144.       vtWideChar:   (VWideChar: WideChar);
  145.       vtPWideChar:  (VPWideChar: PWideChar);
  146.       vtAnsiString: (VAnsiString: Pointer);
  147.       vtCurrency:   (VCurrency: PCurrency);
  148.       vtVariant:    (VVariant: PVariant);
  149.   end;
  150.  
  151.   PMemoryManager = ^TMemoryManager;
  152.   TMemoryManager = record
  153.     GetMem: function(Size: Integer): Pointer;
  154.     FreeMem: function(P: Pointer): Integer;
  155.     ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  156.   end;
  157.  
  158.   THeapStatus = record
  159.     TotalAddrSpace: Cardinal;
  160.     TotalUncommitted: Cardinal;
  161.     TotalCommitted: Cardinal;
  162.     TotalAllocated: Cardinal;
  163.     TotalFree: Cardinal;
  164.     FreeSmall: Cardinal;
  165.     FreeBig: Cardinal;
  166.     Unused: Cardinal;
  167.     Overhead: Cardinal;
  168.     HeapErrorCode: Cardinal;
  169.   end;
  170.  
  171. threadvar
  172.  
  173.   RaiseList: Pointer;     { Stack of current exception objects }
  174.   InOutRes: Integer;      { Result of I/O operations }
  175.  
  176. var
  177.  
  178.   ExceptProc: Pointer;    { Unhandled exception handler }
  179.   ErrorProc: Pointer;     { Error handler procedure }
  180.   ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
  181.   ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
  182.   ExceptionClass: TClass; { Exception base class (must be Exception) }
  183.   HPrevInst: Longint;     { Handle of previous instance }
  184.   HInstance: Longint;     { Handle of this instance }
  185.   CmdShow: Integer;       { CmdShow parameter for CreateWindow }
  186.   CmdLine: PChar;         { Command line pointer }
  187.         InitProc: Pointer;                      { Last installed initialization procedure }
  188.   ExitCode: Integer;      { Program result }
  189.   ExitProc: Pointer;      { Last installed exit procedure }
  190.   ErrorAddr: Pointer;     { Address of run-time error }
  191.   DllProc: Pointer;       { Called whenever DLL entry point is called }
  192.   RandSeed: Longint;      { Base for random number generator }
  193.   IsLibrary: Boolean;     { True if module is a DLL }
  194.   IsConsole: Boolean;     { True if compiled as console app }
  195.   IsMultiThread: Boolean; { True if more than one thread }
  196.   FileMode: Byte;         { Standard mode for opening files }
  197.   Test8086: Byte;         { Will always be 2 (386 or later) }
  198.   Test8087: Byte;         { Will always be 3 (387 or later) }
  199.   TestFDIV: Shortint;     { -1: Flawed Pentium, 0: Not determined, 1: Ok }
  200.   Input: Text;            { Standard input }
  201.   Output: Text;           { Standard output }
  202.   TlsIndex: Integer;      { Thread local storage index }
  203.   TlsIndex4: Integer;     { Thread local storage index*4 }
  204.   TlsLast: Byte;          { Set by linker so its offset is last in TLS segment }
  205.  
  206. const
  207.   HeapAllocFlags: Word = 2;   { Heap allocation flags, gmem_Moveable }
  208.   DebugHook: Byte = 0;     {  1 to notify debugger of non-Delphi exceptions
  209.                              >1 to notify debugger of exception unwinding }
  210.  
  211. var
  212.   Unassigned: Variant;    { Unassigned standard constant }
  213.   Null: Variant;          { Null standard constant }
  214.  
  215.   AllocMemCount: Integer; { Number of allocated memory blocks }
  216.   AllocMemSize: Integer;  { Total size of allocated memory blocks }
  217.  
  218. { Memory manager support }
  219.  
  220. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  221. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  222.  
  223. function SysGetMem(Size: Integer): Pointer;
  224. function SysFreeMem(P: Pointer): Integer;
  225. function SysReallocMem(P: Pointer; Size: Integer): Pointer;
  226.  
  227. function GetHeapStatus: THeapStatus;
  228.  
  229. { Thread support }
  230. type
  231.   TThreadFunc = function(Parameter: Pointer): Integer;
  232.  
  233. function BeginThread(SecurityAttributes: Pointer; StackSize: Integer;
  234.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  235.                      CreationFlags: Integer; var ThreadId: Integer): Integer;
  236.  
  237. procedure EndThread(ExitCode: Integer);
  238.  
  239. { Standard procedures and functions }
  240.  
  241. procedure _ChDir(const S: string);
  242. procedure __Flush(var F: Text);
  243. procedure _LGetDir(D: Byte; var S: string);
  244. procedure _SGetDir(D: Byte; var S: ShortString);
  245. function IOResult: Integer;
  246. procedure _MkDir(const S: string);
  247. procedure Move(const Source; var Dest; Count: Integer);
  248. function ParamCount: Integer;
  249. function ParamStr(Index: Integer): string;
  250. procedure Randomize;
  251. procedure _RmDir(const S: string);
  252. function UpCase(Ch: Char): Char;
  253.  
  254. { Wide character support procedures and functions }
  255.  
  256. function WideCharToString(Source: PWideChar): string;
  257. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  258. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  259. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  260.   var Dest: string);
  261. function StringToWideChar(const Source: string; Dest: PWideChar;
  262.   DestSize: Integer): PWideChar;
  263.  
  264. { OLE string support procedures and functions }
  265.  
  266. function OleStrToString(Source: PWideChar): string;
  267. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  268. function StringToOleStr(const Source: string): PWideChar;
  269.  
  270. { Variant support procedures and functions }
  271.  
  272. procedure VarClear(var V: Variant);
  273. procedure VarCopy(var Dest: Variant; const Source: Variant);
  274. procedure VarCast(var Dest: Variant; const Source: Variant; VarType: Integer);
  275. function VarType(const V: Variant): Integer;
  276. function VarAsType(const V: Variant; VarType: Integer): Variant;
  277. function VarIsEmpty(const V: Variant): Boolean;
  278. function VarIsNull(const V: Variant): Boolean;
  279. function VarToStr(const V: Variant): string;
  280. function VarFromDateTime(DateTime: TDateTime): Variant;
  281. function VarToDateTime(const V: Variant): TDateTime;
  282.  
  283. { Variant array support procedures and functions }
  284.  
  285. function VarArrayCreate(const Bounds: array of Integer;
  286.   VarType: Integer): Variant;
  287. function VarArrayOf(const Values: array of Variant): Variant;
  288. procedure VarArrayRedim(var A: Variant; HighBound: Integer);
  289. function VarArrayDimCount(const A: Variant): Integer;
  290. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  291. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  292. function VarArrayLock(const A: Variant): Pointer;
  293. procedure VarArrayUnlock(const A: Variant);
  294. function VarArrayRef(const A: Variant): Variant;
  295. function VarIsArray(const A: Variant): Boolean;
  296.  
  297. { Variant IDispatch call support }
  298.  
  299. procedure _DispInvokeError;
  300.  
  301. const
  302.   VarDispProc: Pointer = @_DispInvokeError;
  303.  
  304. { Procedures and functions that need compiler magic }
  305.  
  306. procedure _COS;
  307. procedure _EXP;
  308. procedure _INT;
  309. procedure _SIN;
  310. procedure _FRAC;
  311. procedure _ROUND;
  312. procedure _TRUNC;
  313.  
  314. procedure _AbstractError;
  315. procedure _Append;
  316. procedure _Assign(var T: Text; S: ShortString);
  317. procedure _BlockRead;
  318. procedure _BlockWrite;
  319. procedure _Close;
  320. procedure _PStrCat;
  321. procedure _PStrNCat;
  322. procedure _PStrCpy;
  323. procedure _PStrNCpy;
  324. procedure _EofFile;
  325. procedure _EofText;
  326. procedure _Eoln;
  327. procedure _Erase;
  328. procedure _FilePos;
  329. procedure _FileSize;
  330. procedure _FillChar;
  331. procedure _FreeMem;
  332. procedure _GetMem;
  333. procedure _ReallocMem;
  334. procedure _Halt;
  335. procedure _Halt0;
  336. procedure _Mark;
  337. procedure _PStrCmp;
  338. procedure _AStrCmp;
  339. procedure _RandInt;
  340. procedure _RandExt;
  341. procedure _ReadRec;
  342. procedure _ReadChar;
  343. procedure _ReadLong;
  344. procedure _ReadString;
  345. procedure _ReadCString;
  346. procedure _ReadLString;
  347. procedure _ReadExt;
  348. procedure _ReadLn;
  349. procedure _Rename;
  350. procedure _Release;
  351. procedure _ResetText(var T: Text);
  352. procedure _ResetFile;
  353. procedure _RewritText(var T: Text);
  354. procedure _RewritFile;
  355. procedure _RunError;
  356. procedure _Run0Error;
  357. procedure _Seek;
  358. procedure _SeekEof;
  359. procedure _SeekEoln;
  360. procedure _SetTextBuf;
  361. procedure _StrLong;
  362. procedure _Str0Long;
  363. procedure _Truncate;
  364. procedure _ValLong;
  365. procedure _WriteRec;
  366. procedure _WriteChar;
  367. procedure _Write0Char;
  368. procedure _WriteBool;
  369. procedure _Write0Bool;
  370. procedure _WriteLong;
  371. procedure _Write0Long;
  372. procedure _WriteString;
  373. procedure _Write0String;
  374. procedure _WriteCString;
  375. procedure _Write0CString;
  376. procedure _WriteLString;
  377. procedure _Write0LString;
  378. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  379. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  380. procedure _Write2Ext;
  381. procedure _Write1Ext;
  382. procedure _Write0Ext;
  383. procedure _WriteLn;
  384.  
  385. procedure __CToPasStr;
  386. procedure __CLenToPasStr;
  387. procedure __PasToCStr;
  388.  
  389. procedure __IOTest;
  390. procedure _Flush(var F: Text);
  391.  
  392. procedure _SetElem;
  393. procedure _SetRange;
  394. procedure _SetEq;
  395. procedure _SetLe;
  396. procedure _SetIntersect;
  397. procedure _SetUnion;
  398. procedure _SetSub;
  399. procedure _SetExpand;
  400.  
  401. procedure _Str2Ext;
  402. procedure _Str0Ext;
  403. procedure _Str1Ext;
  404. procedure _ValExt;
  405. procedure _Pow10;
  406. procedure _Real2Ext;
  407. procedure _Ext2Real;
  408.  
  409. procedure _ObjSetup;
  410. procedure _ObjCopy;
  411. procedure _Fail;
  412. procedure _BoundErr;
  413. procedure _IntOver;
  414. procedure _InitExe;
  415. procedure _InitDll;
  416.  
  417. procedure _ClassCreate;
  418. procedure _ClassDestroy;
  419. procedure _IsClass;
  420. procedure _AsClass;
  421.  
  422. procedure _RaiseExcept;
  423. procedure _RaiseAgain;
  424. procedure _DoneExcept;
  425. procedure _TryFinallyExit;
  426.  
  427. procedure _CallDynaInst;
  428. procedure _CallDynaClass;
  429. procedure _FindDynaInst;
  430. procedure _FindDynaClass;
  431.  
  432. procedure _LStrClr{var str: AnsiString};
  433. procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
  434. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  435. procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
  436. procedure _LStrFromLenStr{var dest: AnsiString; source: Pointer; length: Longint};
  437. procedure _LStrFromChar{var dest: AnsiString; source: char};
  438. procedure _LStrFromString{var dest: AnsiString; source: ShortString};
  439. procedure _LStrFromPChar{var dest: AnsiString; source: PChar};
  440. procedure _LStrFromArray{{var dest: AnsiString; source: Pointer; length: Longint};
  441. procedure _LStrToString{ var result: ShortString; s: AnsiString; resultLen: Integer};
  442. function _LStrLen{str: AnsiString}: Longint;
  443. procedure _LStrCat{var dest: AnsiString; source: AnsiString};
  444. procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  445. procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  446. procedure _LStrCmp{left: AnsiString; right: AnsiString};
  447. procedure _LStrAddRef{str: AnsiString};
  448. procedure _LStrToPChar{str: AnsiString): PChar};
  449. procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  450. procedure _Delete{ var s : openstring; index, count : Integer };
  451. procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
  452. procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
  453. procedure _SetLength{var s: ShortString; newLength: Integer};
  454. procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};
  455.  
  456. procedure UniqueString(var str: string);
  457. procedure _NewAnsiString{length: Longint};      { for debugger purposes only }
  458.  
  459. procedure _LStrCopy  { const s : AnsiString; index, count : Integer) : AnsiString};
  460. procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
  461. procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  462. procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  463. procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
  464. procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };
  465. procedure _Initialize;
  466. procedure _InitializeArray;
  467. procedure _InitializeRecord;
  468. procedure _Finalize;
  469. procedure _FinalizeArray;
  470. procedure _FinalizeRecord;
  471. procedure _AddRef;
  472. procedure _AddRefArray;
  473. procedure _AddRefRecord;
  474.  
  475. procedure _New;
  476. procedure _Dispose;
  477.  
  478. procedure _DispInvoke; cdecl;
  479.  
  480. procedure _VarToInt;
  481. procedure _VarToBool;
  482. procedure _VarToReal;
  483. procedure _VarToCurr;
  484. procedure _VarToPStr(var S; const V: Variant);
  485. procedure _VarToLStr(var S: string; const V: Variant);
  486.  
  487. procedure _VarFromInt;
  488. procedure _VarFromBool;
  489. procedure _VarFromReal;
  490. procedure _VarFromTDateTime;
  491. procedure _VarFromCurr;
  492. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  493. procedure _VarFromLStr(var V: Variant; const Value: string);
  494.  
  495. procedure _VarAdd;
  496. procedure _VarSub;
  497. procedure _VarMul;
  498. procedure _VarDiv;
  499. procedure _VarMod;
  500. procedure _VarAnd;
  501. procedure _VarOr;
  502. procedure _VarXor;
  503. procedure _VarShl;
  504. procedure _VarShr;
  505. procedure _VarRDiv;
  506. procedure _VarCmp;
  507.  
  508. procedure _VarNeg;
  509. procedure _VarNot;
  510.  
  511. procedure _VarCopy;
  512. procedure _VarClr;
  513. procedure _VarAddRef;
  514.  
  515. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  516.   Indices: Integer): Variant; cdecl;
  517. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  518.   IndexCount: Integer; Indices: Integer); cdecl;
  519.  
  520. procedure _HandleAnyException;
  521. procedure _HandleOnException;
  522. procedure _HandleFinally;
  523.  
  524. procedure _AddExitProc(PP: Pointer);
  525.  
  526. procedure _FSafeDivide;
  527. procedure _FSafeDivideR;
  528.  
  529. procedure _SafeCall;
  530.  
  531. procedure FPower10;
  532. procedure _GetTls;
  533.  
  534. procedure TextStart;
  535.  
  536. (* =================================================================== *)
  537.  
  538. implementation
  539.  
  540. { Internal runtime error codes }
  541.  
  542. const
  543.   reOutOfMemory     = 1;
  544.   reInvalidPtr      = 2;
  545.   reDivByZero       = 3;
  546.   reRangeError      = 4;
  547.   reIntOverflow     = 5;
  548.   reInvalidOp       = 6;
  549.   reZeroDivide      = 7;
  550.   reOverflow        = 8;
  551.   reUnderflow       = 9;
  552.   reInvalidCast     = 10;
  553.   reAccessViolation = 11;
  554.   reStackOverflow   = 12;
  555.   reControlBreak    = 13;
  556.   rePrivInstruction = 14;
  557.   reVarTypeCast     = 15;
  558.   reVarInvalidOp    = 16;
  559.   reVarDispatch     = 17;
  560.   reVarArrayCreate  = 18;
  561.   reVarNotArray     = 19;
  562.   reVarArrayBounds  = 20;
  563.  
  564.   tlsArray          = $2C;      { offset of tls array from FS: }
  565.  
  566. var
  567.   DLLSaveEBP: Pointer;          { saved regs for DLLs }
  568.   DLLSaveEBX: Pointer;          { saved regs for DLLs }
  569.   DLLSaveESI: Pointer;          { saved regs for DLLs }
  570.   DLLSaveEDI: Pointer;          { saved regs for DLLs }
  571.   DLLInitState: Byte;
  572.  
  573. { this procedure should be at the very beginning of the }
  574. { text segment. it is only used by _RunError to find    }
  575. { start address of the text segment so a nice error     }
  576. { location can be shown.                                                                }
  577.  
  578. procedure TextStart;
  579. begin
  580. end;
  581.  
  582. { ----------------------------------------------------- }
  583. {       NT Calls necessary for the .asm files           }
  584. { ----------------------------------------------------- }
  585.  
  586. const
  587.   kernel = 'kernel32.dll';
  588.   user = 'user32.dll';
  589.   oleaut = 'oleaut32.dll';
  590.  
  591. procedure CloseHandle;                  external kernel name 'CloseHandle';
  592. procedure CreateFileA;                  external kernel name 'CreateFileA';
  593. procedure DeleteFileA;                  external kernel name 'DeleteFileA';
  594. procedure ExitProcess;                  external kernel name 'ExitProcess';
  595. procedure GetFileType;                  external kernel name 'GetFileType';
  596. procedure GetSystemTime;                external kernel name 'GetSystemTime';
  597. procedure GetFileSize;                  external kernel name 'GetFileSize';
  598. procedure GetStdHandle;                 external kernel name 'GetStdHandle';
  599. procedure GetStartupInfo;               external kernel name 'GetStartupInfo';
  600. procedure MessageBoxA;                  external user   name 'MessageBoxA';
  601. procedure MoveFileA;                    external kernel name 'MoveFileA';
  602. procedure RaiseException;               external kernel name 'RaiseException';
  603. procedure ReadFile;                     external kernel name 'ReadFile';
  604. procedure RtlUnwind;                    external kernel name 'RtlUnwind';
  605. procedure SetEndOfFile;                 external kernel name 'SetEndOfFile';
  606. procedure SetFilePointer;               external kernel name 'SetFilePointer';
  607. procedure WriteFile;                    external kernel name 'WriteFile';
  608.  
  609. function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall;
  610.   external kernel name 'CreateDirectoryA';
  611.  
  612. function CreateThread(SecurityAttributes: Pointer; StackSize: Integer;
  613.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  614.                      CreationFlags: Integer; var ThreadId: Integer): Integer; stdcall;
  615.   external kernel name 'CreateThread';
  616.  
  617. procedure ExitThread(ExitCode: Integer); stdcall;
  618.   external kernel name 'ExitThread';
  619.  
  620. function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall;
  621.   external kernel name 'GetCurrentDirectoryA';
  622.  
  623. function GetCommandLine: PChar; stdcall;
  624.   external kernel name 'GetCommandLineA';
  625.  
  626. function GetLastError: Integer; stdcall;
  627.   external kernel name 'GetLastError';
  628.  
  629. function GetModuleFileName(Module: Integer; Filename: PChar;
  630.   Size: Integer): Integer; stdcall;
  631.   external kernel name 'GetModuleFileNameA';
  632.  
  633. function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
  634.   external kernel name 'GetModuleHandleA';
  635.  
  636. function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar;
  637.   MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall;
  638.   external kernel name 'MultiByteToWideChar';
  639.  
  640. function RemoveDirectory(PathName: PChar): WordBool; stdcall;
  641.   external kernel name 'RemoveDirectoryA';
  642.  
  643. function SetCurrentDirectory(PathName: PChar): WordBool; stdcall;
  644.   external kernel name 'SetCurrentDirectoryA';
  645.  
  646. function TlsAlloc: Integer; stdcall;
  647.   external kernel name 'TlsAlloc';
  648.  
  649. function TlsFree(TlsIndex: Integer): Boolean; stdcall;
  650.   external kernel name 'TlsFree';
  651.  
  652. function TlsGetValue(TlsIndex: Integer): Pointer; stdcall;
  653.   external kernel name 'TlsGetValue';
  654.  
  655. function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall;
  656.   external kernel name 'TlsSetValue';
  657.  
  658. function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar;
  659.   WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar;
  660.   UsedDefaultChar: Pointer): Integer; stdcall;
  661.   external kernel name 'WideCharToMultiByte';
  662.  
  663. function SysAllocString(P: PWideChar): PWideChar; stdcall;
  664.   external oleaut name 'SysAllocString';
  665.  
  666. function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall;
  667.   external oleaut name 'SysAllocStringLen';
  668.  
  669. procedure SysFreeString(BStr: PWideChar); stdcall;
  670.   external oleaut name 'SysFreeString';
  671.  
  672. function SysStringLen(BStr: PWideChar): Integer; stdcall;
  673.   external oleaut name 'SysStringLen';
  674.  
  675. procedure VariantInit(var V: Variant); stdcall;
  676.   external oleaut name 'VariantInit';
  677.  
  678. function VariantClear(var V: Variant): Integer; stdcall;
  679.   external oleaut name 'VariantClear';
  680.  
  681. function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall;
  682.   external oleaut name 'VariantCopy';
  683.  
  684. function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall;
  685.   external oleaut name 'VariantCopyInd';
  686.  
  687. function VariantChangeType(var Dest: Variant; const Source: Variant;
  688.   Flags: Word; VarType: Word): Integer; stdcall;
  689.   external oleaut name 'VariantChangeType';
  690.  
  691. function VariantChangeTypeEx(var Dest: Variant; const Source: Variant;
  692.   LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall;
  693.   external oleaut name 'VariantChangeTypeEx';
  694.  
  695. function SafeArrayCreate(VarType, DimCount: Integer;
  696.   const Bounds): PVarArray; stdcall;
  697.   external oleaut name 'SafeArrayCreate';
  698.  
  699. function SafeArrayRedim(VarArray: PVarArray;
  700.   var NewBound: TVarArrayBound): Integer; stdcall;
  701.   external oleaut name 'SafeArrayRedim';
  702.  
  703. function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
  704.   var LBound: Integer): Integer; stdcall;
  705.   external oleaut name 'SafeArrayGetLBound';
  706.  
  707. function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
  708.   var UBound: Integer): Integer; stdcall;
  709.   external oleaut name 'SafeArrayGetUBound';
  710.  
  711. function SafeArrayAccessData(VarArray: PVarArray;
  712.   var Data: Pointer): Integer; stdcall;
  713.   external oleaut name 'SafeArrayAccessData';
  714.  
  715. function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall;
  716.   external oleaut name 'SafeArrayUnaccessData';
  717.  
  718. function SafeArrayGetElement(VarArray: PVarArray; Indices,
  719.   Data: Pointer): Integer; stdcall;
  720.   external oleaut name 'SafeArrayGetElement';
  721.  
  722. function SafeArrayPutElement(VarArray: PVarArray; Indices,
  723.   Data: Pointer): Integer; stdcall;
  724.   external oleaut name 'SafeArrayPutElement';
  725.  
  726. { ----------------------------------------------------- }
  727. {       Memory manager                                                                          }
  728. { ----------------------------------------------------- }
  729.  
  730. procedure Error(errorCode: Byte); forward;
  731.  
  732. {$I GETMEM.INC }
  733.  
  734. const
  735.   MemoryManager: TMemoryManager = (
  736.     GetMem: SysGetMem;
  737.     FreeMem: SysFreeMem;
  738.     ReallocMem: SysReallocMem);
  739.  
  740. procedure _GetMem;
  741. asm
  742.         TEST    EAX,EAX
  743.         JE      @@1
  744.         CALL    MemoryManager.GetMem
  745.         OR      EAX,EAX
  746.         JE      @@2
  747. @@1:    RET
  748. @@2:    MOV     AL,reOutOfMemory
  749.         JMP     Error
  750. end;
  751.  
  752. procedure _FreeMem;
  753. asm
  754.         TEST    EAX,EAX
  755.         JE      @@1
  756.         CALL    MemoryManager.FreeMem
  757.         OR      EAX,EAX
  758.         JNE     @@2
  759. @@1:    RET
  760. @@2:    MOV     AL,reInvalidPtr
  761.         JMP     Error
  762. end;
  763.  
  764. procedure _ReallocMem;
  765. asm
  766.         MOV     ECX,[EAX]
  767.         TEST    ECX,ECX
  768.         JE      @@alloc
  769.         TEST    EDX,EDX
  770.         JE      @@free
  771. @@resize:
  772.         PUSH    EAX
  773.         MOV     EAX,ECX
  774.         CALL    MemoryManager.ReallocMem
  775.         POP     ECX
  776.         OR      EAX,EAX
  777.         JE      @@allocError
  778.         MOV     [ECX],EAX
  779.         RET
  780. @@freeError:
  781.         MOV     AL,reInvalidPtr
  782.         JMP     Error
  783. @@free:
  784.         MOV     [EAX],EDX
  785.         MOV     EAX,ECX
  786.         CALL    MemoryManager.FreeMem
  787.         OR      EAX,EAX
  788.         JNE     @@freeError
  789.         RET
  790. @@allocError:
  791.         MOV     AL,reOutOfMemory
  792.         JMP     Error
  793. @@alloc:
  794.         TEST    EDX,EDX
  795.         JE      @@exit
  796.         PUSH    EAX
  797.         MOV     EAX,EDX
  798.         CALL    MemoryManager.GetMem
  799.         POP     ECX
  800.         OR      EAX,EAX
  801.         JE      @@allocError
  802.         MOV     [ECX],EAX
  803. @@exit:
  804. end;
  805.  
  806. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  807. begin
  808.   MemMgr := MemoryManager;
  809. end;
  810.  
  811. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  812. begin
  813.   MemoryManager := MemMgr;
  814. end;
  815.  
  816.  
  817. { ----------------------------------------------------- }
  818. {    local functions & procedures of the system unit    }
  819. { ----------------------------------------------------- }
  820.  
  821. procedure Error(errorCode: Byte);
  822. asm
  823.         AND     EAX,127
  824.         MOV     ECX,ErrorProc
  825.         TEST    ECX,ECX
  826.         JE      @@term
  827.         POP     EDX
  828.         CALL    ECX
  829. @@term:
  830.         DEC     EAX
  831.         MOV     AL,byte ptr @@errorTable[EAX]
  832.         JNS     @@skip
  833.         CALL    _GetTLS
  834.         MOV     EAX,[EAX].InOutRes
  835. @@skip:
  836.         JMP     _RunError
  837.  
  838. @@errorTable:
  839.         DB      203     { reOutOfMemory }
  840.         DB      204     { reInvalidPtr }
  841.         DB      200     { reDivByZero }
  842.         DB      201     { reRangeError }
  843.         DB      215     { reIntOverflow }
  844.         DB      207     { reInvalidOp }
  845.         DB      200     { reZeroDivide }
  846.         DB      205     { reOverflow }
  847.         DB      206     { reUnderflow }
  848.         DB      219     { reInvalidCast }
  849.         DB      216     { Access violation }
  850.         DB      202     { Stack overflow }
  851.         DB      217     { Control-C }
  852.         DB      218     { Privileged instruction }
  853.         DB      220     { Invalid variant type cast }
  854.         DB      221     { Invalid variant operation }
  855.         DB      222     { No variant method call dispatcher }
  856.         DB      223     { Cannot create variant array }
  857.         DB      224     { Variant does not contain an array }
  858.         DB      225     { Variant array bounds error }
  859. end;
  860.  
  861. procedure       __IOTest;
  862. asm
  863.         PUSH    EAX
  864.         PUSH    EDX
  865.         PUSH    ECX
  866.         CALL    _GetTLS
  867.         CMP     [EAX].InOutRes,0
  868.         POP     ECX
  869.         POP     EDX
  870.         POP     EAX
  871.         JNE     @error
  872.         RET
  873. @error:
  874.         XOR     EAX,EAX
  875.         JMP     Error
  876. end;
  877.  
  878. procedure SetInOutRes;
  879. asm
  880.         PUSH    EAX
  881.         CALL    _GetTLS
  882.         POP     [EAX].InOutRes
  883. end;
  884.  
  885.  
  886. procedure InOutError;
  887. asm
  888.         CALL    GetLastError
  889.         JMP     SetInOutRes
  890. end;
  891.  
  892. procedure _ChDir(const S: string);
  893. begin
  894.   if not SetCurrentDirectory(PChar(S)) then InOutError;
  895. end;
  896.  
  897. procedure       _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  898. asm
  899. {     ->EAX     Source string                   }
  900. {       EDX     index                           }
  901. {       ECX     count                           }
  902. {       [ESP+4] Pointer to result string        }
  903.  
  904.         PUSH    ESI
  905.         PUSH    EDI
  906.  
  907.         MOV     ESI,EAX
  908.         MOV     EDI,[ESP+8+4]
  909.  
  910.         XOR     EAX,EAX
  911.         OR      AL,[ESI]
  912.         JZ      @@srcEmpty
  913.  
  914. {       limit index to satisfy 1 <= index <= Length(src) }
  915.  
  916.         TEST    EDX,EDX
  917.         JLE     @@smallInx
  918.         CMP     EDX,EAX
  919.         JG      @@bigInx
  920. @@cont1:
  921.  
  922. {       limit count to satisfy 0 <= count <= Length(src) - index + 1    }
  923.  
  924.         SUB     EAX,EDX { calculate Length(src) - index + 1     }
  925.         INC     EAX
  926.         TEST    ECX,ECX
  927.         JL      @@smallCount
  928.         CMP     ECX,EAX
  929.         JG      @@bigCount
  930. @@cont2:
  931.  
  932.         ADD     ESI,EDX
  933.  
  934.         MOV     [EDI],CL
  935.         INC     EDI
  936.         REP     MOVSB
  937.         JMP     @@exit
  938.  
  939. @@smallInx:
  940.         MOV     EDX,1
  941.         JMP     @@cont1
  942. @@bigInx:
  943. {       MOV     EDX,EAX
  944.         JMP     @@cont1 }
  945. @@smallCount:
  946.         XOR     ECX,ECX
  947.         JMP     @@cont2
  948. @@bigCount:
  949.         MOV     ECX,EAX
  950.         JMP     @@cont2
  951. @@srcEmpty:
  952.         MOV     [EDI],AL
  953. @@exit:
  954.         POP     EDI
  955.         POP     ESI
  956.     RET 4
  957. end;
  958.  
  959. procedure       _Delete{ var s : openstring; index, count : Integer };
  960. asm
  961. {     ->EAX     Pointer to s    }
  962. {       EDX     index           }
  963. {       ECX     count           }
  964.  
  965.         PUSH    ESI
  966.         PUSH    EDI
  967.  
  968.         MOV     EDI,EAX
  969.  
  970.         XOR     EAX,EAX
  971.         MOV     AL,[EDI]
  972.  
  973. {       if index not in [1 .. Length(s)] do nothing     }
  974.  
  975.         TEST    EDX,EDX
  976.         JLE     @@exit
  977.         CMP     EDX,EAX
  978.         JG      @@exit
  979.  
  980. {       limit count to [0 .. Length(s) - index + 1]     }
  981.  
  982.         TEST    ECX,ECX
  983.         JLE     @@exit
  984.         SUB     EAX,EDX         { calculate Length(s) - index + 1       }
  985.         INC     EAX
  986.         CMP     ECX,EAX
  987.         JLE     @@1
  988.         MOV     ECX,EAX
  989. @@1:
  990.         SUB     [EDI],CL        { reduce Length(s) by count                     }
  991.         ADD     EDI,EDX         { point EDI to first char to be deleted }
  992.         LEA     ESI,[EDI+ECX]   { point ESI to first char to be preserved       }
  993.         SUB     EAX,ECX         { #chars = Length(s) - index + 1 - count        }
  994.         MOV     ECX,EAX
  995.  
  996.         REP     MOVSB
  997.  
  998. @@exit:
  999.         POP     EDI
  1000.         POP     ESI
  1001. end;
  1002.  
  1003. procedure       __Flush( var f : Text );
  1004. external;       {   Assign  }
  1005.  
  1006. procedure       _Flush( var f : Text );
  1007. external;       {   Assign  }
  1008.  
  1009. procedure _LGetDir(D: Byte; var S: string);
  1010. var
  1011.   Drive: array[0..3] of Char;
  1012.   DirBuf, SaveBuf: array[0..259] of Char;
  1013. begin
  1014.   if D <> 0 then
  1015.   begin
  1016.         Drive[0] := Chr(D + Ord('A') - 1);
  1017.         Drive[1] := ':';
  1018.         Drive[2] := #0;
  1019.         GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf);
  1020.         SetCurrentDirectory(Drive);
  1021.   end;
  1022.   GetCurrentDirectory(SizeOf(DirBuf), DirBuf);
  1023.   if D <> 0 then SetCurrentDirectory(SaveBuf);
  1024.   S := DirBuf;
  1025. end;
  1026.  
  1027. procedure _SGetDir(D: Byte; var S: ShortString);
  1028. var
  1029.   L: string;
  1030. begin
  1031.   GetDir(D, L);
  1032.   S := L;
  1033. end;
  1034.  
  1035. procedure       _Insert{ source : ShortString; var s : openstring; index : Integer };
  1036. asm
  1037. {     ->EAX     Pointer to source string        }
  1038. {       EDX     Pointer to destination string   }
  1039. {       ECX     Length of destination string    }
  1040. {       [ESP+4] Index                   }
  1041.  
  1042.         PUSH    EBX
  1043.         PUSH    ESI
  1044.         PUSH    EDI
  1045.         PUSH    ECX
  1046.         MOV     ECX,[ESP+16+4]
  1047.         SUB     ESP,512         { VAR buf: ARRAY [0..511] of Char       }
  1048.  
  1049.         MOV     EBX,EDX         { save pointer to s for later   }
  1050.         MOV     ESI,EDX
  1051.  
  1052.         XOR     EDX,EDX
  1053.         MOV     DL,[ESI]
  1054.         INC     ESI
  1055.  
  1056. {       limit index to [1 .. Length(s)+1]       }
  1057.  
  1058.         INC     EDX
  1059.         TEST    ECX,ECX
  1060.         JLE     @@smallInx
  1061.         CMP     ECX,EDX
  1062.         JG      @@bigInx
  1063. @@cont1:
  1064.         DEC     EDX     { EDX = Length(s)               }
  1065.                         { EAX = Pointer to src  }
  1066.                         { ESI = EBX = Pointer to s      }
  1067.                         { ECX = Index           }
  1068.  
  1069. {       copy index-1 chars from s to buf        }
  1070.  
  1071.         MOV     EDI,ESP
  1072.         DEC     ECX
  1073.         SUB     EDX,ECX { EDX = remaining length of s   }
  1074.         REP     MOVSB
  1075.  
  1076. {       copy Length(src) chars from src to buf  }
  1077.  
  1078.         XCHG    EAX,ESI { save pointer into s, point ESI to src         }
  1079.         MOV     CL,[ESI]        { ECX = Length(src) (ECX was zero after rep)    }
  1080.         INC     ESI
  1081.         REP     MOVSB
  1082.  
  1083. {       copy remaining chars of s to buf        }
  1084.  
  1085.         MOV     ESI,EAX { restore pointer into s                }
  1086.         MOV     ECX,EDX { copy remaining bytes of s             }
  1087.         REP     MOVSB
  1088.  
  1089. {       calculate total chars in buf    }
  1090.  
  1091.         SUB     EDI,ESP         { length = bufPtr - buf         }
  1092.         MOV     ECX,[ESP+512]   { ECX = Min(length, destLength) }
  1093. {       MOV     ECX,[EBP-16]    { ECX = Min(length, destLength) }
  1094.         CMP     ECX,EDI
  1095.         JB      @@1
  1096.         MOV     ECX,EDI
  1097. @@1:
  1098.         MOV     EDI,EBX         { Point EDI to s                }
  1099.         MOV     ESI,ESP         { Point ESI to buf              }
  1100.         MOV     [EDI],CL        { Store length in s             }
  1101.         INC     EDI
  1102.         REP     MOVSB           { Copy length chars to s        }
  1103.         JMP     @@exit
  1104.  
  1105. @@smallInx:
  1106.         MOV     ECX,1
  1107.         JMP     @@cont1
  1108. @@bigInx:
  1109.         MOV     ECX,EDX
  1110.         JMP     @@cont1
  1111.  
  1112. @@exit:
  1113.         ADD     ESP,512+4
  1114.         POP     EDI
  1115.         POP     ESI
  1116.         POP     EBX
  1117.     RET 4
  1118. end;
  1119.  
  1120. function IOResult: Integer;
  1121. asm
  1122.         CALL    _GetTLS
  1123.         XOR     EDX,EDX
  1124.         MOV     ECX,[EAX].InOutRes
  1125.         MOV     [EAX].InOutRes,EDX
  1126.         MOV     EAX,ECX
  1127. end;
  1128.  
  1129. procedure _MkDir(const S: string);
  1130. begin
  1131.   if not CreateDirectory(PChar(S), 0) then InOutError;
  1132. end;
  1133.  
  1134. procedure       Move( const Source; var Dest; count : Integer );
  1135. asm
  1136. {     ->EAX     Pointer to source       }
  1137. {       EDX     Pointer to destination  }
  1138. {       ECX     Count                   }
  1139.  
  1140.         PUSH    ESI
  1141.         PUSH    EDI
  1142.  
  1143.         MOV     ESI,EAX
  1144.         MOV     EDI,EDX
  1145.  
  1146.         MOV     EAX,ECX
  1147.  
  1148.         CMP     EDI,ESI
  1149.         JG      @@down
  1150.         JE      @@exit
  1151.  
  1152.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1153.         JS      @@exit
  1154.  
  1155.         REP     MOVSD
  1156.  
  1157.         MOV     ECX,EAX
  1158.         AND     ECX,03H
  1159.         REP     MOVSB           { copy count MOD 4 bytes        }
  1160.         JMP     @@exit
  1161.  
  1162. @@down:
  1163.         LEA     ESI,[ESI+ECX-4] { point ESI to last dword of source     }
  1164.         LEA     EDI,[EDI+ECX-4] { point EDI to last dword of dest       }
  1165.  
  1166.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1167.         JS      @@exit
  1168.         STD
  1169.         REP     MOVSD
  1170.  
  1171.         MOV     ECX,EAX
  1172.         AND     ECX,03H         { copy count MOD 4 bytes        }
  1173.         ADD     ESI,4-1         { point to last byte of rest    }
  1174.         ADD     EDI,4-1
  1175.         REP     MOVSB
  1176.         CLD
  1177. @@exit:
  1178.         POP     EDI
  1179.         POP     ESI
  1180. end;
  1181.  
  1182. function GetParamStr(P: PChar; var Param: string): PChar;
  1183. var
  1184.   Len: Integer;
  1185.   Buffer: array[Byte] of Char;
  1186. begin
  1187.   while True do
  1188.   begin
  1189.     while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
  1190.     if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  1191.   end;
  1192.   Len := 0;
  1193.   while P[0] > ' ' do
  1194.     if P[0] = '"' then
  1195.     begin
  1196.       Inc(P);
  1197.       while (P[0] <> #0) and (P[0] <> '"') do
  1198.       begin
  1199.         Buffer[Len] := P[0];
  1200.         Inc(Len);
  1201.         Inc(P);
  1202.       end;
  1203.       if P[0] <> #0 then Inc(P);
  1204.     end else
  1205.     begin
  1206.       Buffer[Len] := P[0];
  1207.       Inc(Len);
  1208.       Inc(P);
  1209.     end;
  1210.   SetString(Param, Buffer, Len);
  1211.   Result := P;
  1212. end;
  1213.  
  1214. function ParamCount: Integer;
  1215. var
  1216.   P: PChar;
  1217.   S: string;
  1218. begin
  1219.   P := GetParamStr(GetCommandLine, S);
  1220.   Result := 0;
  1221.   while True do
  1222.   begin
  1223.     P := GetParamStr(P, S);
  1224.     if S = '' then Break;
  1225.     Inc(Result);
  1226.   end;
  1227. end;
  1228.  
  1229. function ParamStr(Index: Integer): string;
  1230. var
  1231.   P: PChar;
  1232.   Buffer: array[0..260] of Char;
  1233. begin
  1234.   if Index = 0 then
  1235.     SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer)))
  1236.   else
  1237.   begin
  1238.     P := GetCommandLine;
  1239.     while True do
  1240.     begin
  1241.       P := GetParamStr(P, Result);
  1242.       if (Index = 0) or (Result = '') then Break;
  1243.       Dec(Index);
  1244.     end;
  1245.   end;
  1246. end;
  1247.  
  1248. procedure       _Pos{ substr : ShortString; s : ShortString ) : Integer};
  1249. asm
  1250. {     ->EAX     Pointer to substr               }
  1251. {       EDX     Pointer to string               }
  1252. {     <-EAX     Position of substr in s or 0    }
  1253.  
  1254.         PUSH    EBX
  1255.         PUSH    ESI
  1256.         PUSH    EDI
  1257.  
  1258.         MOV     ESI,EAX { Point ESI to substr           }
  1259.         MOV     EDI,EDX { Point EDI to s                }
  1260.  
  1261.         XOR     ECX,ECX { ECX = Length(s)               }
  1262.         MOV     CL,[EDI]
  1263.         INC     EDI             { Point EDI to first char of s  }
  1264.  
  1265.         PUSH    EDI             { remember s position to calculate index        }
  1266.  
  1267.         XOR     EDX,EDX { EDX = Length(substr)          }
  1268.         MOV     DL,[ESI]
  1269.         INC     ESI             { Point ESI to first char of substr     }
  1270.  
  1271.         DEC     EDX             { EDX = Length(substr) - 1              }
  1272.         JS      @@fail  { < 0 ? return 0                        }
  1273.         MOV     AL,[ESI]        { AL = first char of substr             }
  1274.         INC     ESI             { Point ESI to 2'nd char of substr      }
  1275.  
  1276.         SUB     ECX,EDX { #positions in s to look at    }
  1277.                         { = Length(s) - Length(substr) + 1      }
  1278.         JLE     @@fail
  1279. @@loop:
  1280.         REPNE   SCASB
  1281.         JNE     @@fail
  1282.         MOV     EBX,ECX { save outer loop counter               }
  1283.         PUSH    ESI             { save outer loop substr pointer        }
  1284.         PUSH    EDI             { save outer loop s pointer             }
  1285.  
  1286.         MOV     ECX,EDX
  1287.         REPE    CMPSB
  1288.         POP     EDI             { restore outer loop s pointer  }
  1289.         POP     ESI             { restore outer loop substr pointer     }
  1290.         JE      @@found
  1291.         MOV     ECX,EBX { restore outer loop counter    }
  1292.         JMP     @@loop
  1293.  
  1294. @@fail:
  1295.         POP     EDX             { get rid of saved s pointer    }
  1296.         XOR     EAX,EAX
  1297.         JMP     @@exit
  1298.  
  1299. @@found:
  1300.         POP     EDX             { restore pointer to first char of s    }
  1301.         MOV     EAX,EDI { EDI points of char after match        }
  1302.         SUB     EAX,EDX { the difference is the correct index   }
  1303. @@exit:
  1304.         POP     EDI
  1305.         POP     ESI
  1306.         POP     EBX
  1307. end;
  1308.  
  1309. procedure       _SetLength{var s: ShortString; newLength: Integer};
  1310. asm
  1311.         { ->    EAX pointer to string   }
  1312.         {       EDX new length          }
  1313.  
  1314.         MOV     [EAX],DL        { should also fill new space, parameter should be openstring }
  1315.  
  1316. end;
  1317.  
  1318. procedure       _SetString{var s: ShortString: buffer: PChar; len: Integer};
  1319. asm
  1320.         { ->    EAX pointer to string           }
  1321.         {       EDX pointer to buffer   }
  1322.         {       ECX len                         }
  1323.  
  1324.         MOV     [EAX],CL
  1325.         XCHG    EAX,EDX
  1326.         INC     EDX
  1327.         CALL    Move
  1328. end;
  1329.  
  1330. procedure       Randomize;
  1331. var
  1332.         systemTime :
  1333.         record
  1334.                 wYear   : Word;
  1335.                 wMonth  : Word;
  1336.                 wDayOfWeek      : Word;
  1337.                 wDay    : Word;
  1338.                 wHour   : Word;
  1339.                 wMinute : Word;
  1340.                 wSecond : Word;
  1341.                 wMilliSeconds: Word;
  1342.                 reserved        : array [0..7] of char;
  1343.         end;
  1344. asm
  1345.         LEA     EAX,systemTime
  1346.         PUSH    EAX
  1347.         CALL    GetSystemTime
  1348.         MOVZX   EAX,systemTime.wHour
  1349.         IMUL    EAX,60
  1350.         ADD     AX,systemTime.wMinute   { sum = hours * 60 + minutes    }
  1351.         IMUL    EAX,60
  1352.         XOR     EDX,EDX
  1353.         MOV     DX,systemTime.wSecond
  1354.         ADD     EAX,EDX                 { sum = sum * 60 + seconds              }
  1355.         IMUL    EAX,1000
  1356.         MOV     DX,systemTime.wMilliSeconds
  1357.         ADD     EAX,EDX                 { sum = sum * 1000 + milliseconds       }
  1358.         MOV     RandSeed,EAX
  1359. end;
  1360.  
  1361. procedure _RmDir(const S: string);
  1362. begin
  1363.   if not RemoveDirectory(PChar(S)) then InOutError;
  1364. end;
  1365.  
  1366. function        UpCase( ch : Char ) : Char;
  1367. asm
  1368. { ->    AL      Character       }
  1369. { <-    AL      Result          }
  1370.  
  1371.         CMP     AL,'a'
  1372.         JB      @@exit
  1373.         CMP     AL,'z'
  1374.         JA      @@exit
  1375.         SUB     AL,'a' - 'A'
  1376. @@exit:
  1377. end;
  1378.  
  1379. { ----------------------------------------------------- }
  1380. {       functions & procedures that need compiler magic }
  1381. { ----------------------------------------------------- }
  1382.  
  1383. const cwChop : Word = $1F32;
  1384.  
  1385. procedure       _COS;
  1386. asm
  1387.         FCOS
  1388.         FNSTSW  AX
  1389.         SAHF
  1390.         JP      @@outOfRange
  1391.         RET
  1392. @@outOfRange:
  1393.         FSTP    st(0)   { for now, return 0. result would }
  1394.         FLDZ            { have little significance anyway }
  1395. end;
  1396.  
  1397. procedure       _EXP;
  1398. asm
  1399.         {       e**x = 2**(x*log2(e))   }
  1400.  
  1401.         FLDL2E          { y := x*log2e; }
  1402.         FMUL
  1403.         FLD     ST(0)   { i := round(y);        }
  1404.         FRNDINT
  1405.         FSUB    ST(1), ST       { f := y - i;   }
  1406.         FLD1            { power := 2**i;        }
  1407.         FSCALE
  1408.         FSTP    ST(1)
  1409.         FXCH    ST(1)   { z := 2**f             }
  1410.         F2XM1
  1411.         FLD1
  1412.         FADD
  1413.         FMUL            { result := z*power     }
  1414. end;
  1415.  
  1416. procedure       _INT;
  1417. asm
  1418.         SUB     ESP,4
  1419.         FSTCW   [ESP]
  1420.         FWAIT
  1421.         FLDCW   cwChop
  1422.         FRNDINT
  1423.         FWAIT
  1424.         FLDCW   [ESP]
  1425.         ADD     ESP,4
  1426. end;
  1427.  
  1428. procedure       _SIN;
  1429. asm
  1430.         FSIN
  1431.         FNSTSW  AX
  1432.         SAHF
  1433.         JP      @@outOfRange
  1434.         RET
  1435. @@outOfRange:
  1436.         FSTP    st(0)   { for now, return 0. result would       }
  1437.         FLDZ            { have little significance anyway       }
  1438. end;
  1439.  
  1440. procedure       _FRAC;
  1441. asm
  1442.         FLD     ST(0)
  1443.         SUB     ESP,4
  1444.         FSTCW   [ESP]
  1445.         FWAIT
  1446.         FLDCW   cwChop
  1447.         FRNDINT
  1448.         FWAIT
  1449.         FLDCW   [ESP]
  1450.         ADD     ESP,4
  1451.         FSUB
  1452. end;
  1453.  
  1454. procedure       _ROUND;
  1455. asm
  1456. { ->    FST(0)  Extended argument       }
  1457. { <-    EAX     Result                  }
  1458.  
  1459.         PUSH    EAX
  1460.         FISTP   dword ptr [ESP]
  1461.         FWAIT
  1462.         POP     EAX
  1463. end;
  1464.  
  1465. procedure       _TRUNC;
  1466. asm
  1467.         { ->    FST(0)  Extended argument       }
  1468.         { <-    EAX     Result                  }
  1469.  
  1470.         SUB     ESP,8
  1471.         FSTCW   [ESP]
  1472.         FWAIT
  1473.         FLDCW   cwChop
  1474.         FISTP   dword ptr [ESP+4]
  1475.         FWAIT
  1476.         FLDCW   [ESP]
  1477.         ADD     ESP,4
  1478.         POP     EAX
  1479. end;
  1480.  
  1481. procedure       _AbstractError;
  1482. asm
  1483.         MOV     EAX,210
  1484.         JMP     _RunError
  1485. end;
  1486.  
  1487. procedure       _Append;                                external;       {   OpenText}
  1488. procedure       _Assign(var t: text; s: ShortString);   external;       {$L Assign  }
  1489. procedure       _BlockRead;                             external;       {$L BlockRea}
  1490. procedure       _BlockWrite;                            external;       {$L BlockWri}
  1491. procedure       _Close;                                 external;       {$L Close   }
  1492.  
  1493. procedure       _PStrCat;
  1494. asm
  1495. {     ->EAX = Pointer to destination string     }
  1496. {       EDX = Pointer to source string  }
  1497.  
  1498.         PUSH    ESI
  1499.         PUSH    EDI
  1500.  
  1501. {       load dest len into EAX  }
  1502.  
  1503.         MOV     EDI,EAX
  1504.         XOR     EAX,EAX
  1505.         MOV     AL,[EDI]
  1506.  
  1507. {       load source address in ESI, source len in ECX   }
  1508.  
  1509.         MOV     ESI,EDX
  1510.         XOR     ECX,ECX
  1511.         MOV     CL,[ESI]
  1512.         INC     ESI
  1513.  
  1514. {       calculate final length in DL and store it in the destination    }
  1515.  
  1516.         MOV     DL,AL
  1517.         ADD     DL,CL
  1518.         JC      @@trunc
  1519.  
  1520. @@cont:
  1521.         MOV     [EDI],DL
  1522.  
  1523. {       calculate final dest address    }
  1524.  
  1525.         INC     EDI
  1526.         ADD     EDI,EAX
  1527.  
  1528. {       do the copy     }
  1529.  
  1530.         REP     MOVSB
  1531.  
  1532. {       done    }
  1533.  
  1534.         POP     EDI
  1535.         POP     ESI
  1536.         RET
  1537.  
  1538. @@trunc:
  1539.         INC     DL      {       DL = #chars to truncate                 }
  1540.         SUB     CL,DL   {       CL = source len - #chars to truncate    }
  1541.         MOV     DL,255  {       DL = maximum length                     }
  1542.         JMP     @@cont
  1543. end;
  1544.  
  1545. procedure       _PStrNCat;
  1546. asm
  1547. {     ->EAX = Pointer to destination string                     }
  1548. {       EDX = Pointer to source string                          }
  1549. {       CL  = max length of result (allocated size of dest - 1) }
  1550.  
  1551.         PUSH    ESI
  1552.         PUSH    EDI
  1553.  
  1554. {       load dest len into EAX  }
  1555.  
  1556.         MOV     EDI,EAX
  1557.         XOR     EAX,EAX
  1558.         MOV     AL,[EDI]
  1559.  
  1560. {       load source address in ESI, source len in EDX   }
  1561.  
  1562.         MOV     ESI,EDX
  1563.         XOR     EDX,EDX
  1564.         MOV     DL,[ESI]
  1565.         INC     ESI
  1566.  
  1567. {       calculate final length in AL and store it in the destination    }
  1568.  
  1569.         ADD     AL,DL
  1570.         JC      @@trunc
  1571.         CMP     AL,CL
  1572.         JA      @@trunc
  1573.  
  1574. @@cont:
  1575.         MOV     ECX,EDX
  1576.         MOV     DL,[EDI]
  1577.         MOV     [EDI],AL
  1578.  
  1579. {       calculate final dest address    }
  1580.  
  1581.         INC     EDI
  1582.         ADD     EDI,EDX
  1583.  
  1584. {       do the copy     }
  1585.  
  1586.         REP     MOVSB
  1587.  
  1588. @@done:
  1589.         POP     EDI
  1590.         POP     ESI
  1591.         RET
  1592.  
  1593. @@trunc:
  1594. {       CL = maxlen     }
  1595.  
  1596.         MOV     AL,CL   { AL = final length = maxlen            }
  1597.         SUB     CL,[EDI]        { CL = length to copy = maxlen - destlen        }
  1598.         JBE     @@done
  1599.         MOV     DL,CL
  1600.         JMP     @@cont
  1601. end;
  1602.  
  1603. procedure       _PStrCpy;
  1604. asm
  1605. {     ->EAX = Pointer to dest string    }
  1606. {       EDX = Pointer to source string  }
  1607.  
  1608.         XOR     ECX,ECX
  1609.  
  1610.         PUSH    ESI
  1611.         PUSH    EDI
  1612.  
  1613.         MOV     CL,[EDX]
  1614.  
  1615.         MOV     EDI,EAX
  1616.  
  1617.         INC     ECX             { we must copy len+1 bytes      }
  1618.  
  1619.         MOV     ESI,EDX
  1620.  
  1621.         MOV     EAX,ECX
  1622.         SHR     ECX,2
  1623.         AND     EAX,3
  1624.         REP     MOVSD
  1625.  
  1626.         MOV     ECX,EAX
  1627.         REP     MOVSB
  1628.  
  1629.         POP     EDI
  1630.         POP     ESI
  1631. end;
  1632.  
  1633. procedure       _PStrNCpy;
  1634. asm
  1635. {     ->EAX = Pointer to dest string                            }
  1636. {       EDX = Pointer to source string                          }
  1637. {       CL  = Maximum length to copy (allocated size of dest - 1)       }
  1638.  
  1639.         PUSH    ESI
  1640.         PUSH    EDI
  1641.  
  1642.         MOV     EDI,EAX
  1643.         XOR     EAX,EAX
  1644.         MOV     ESI,EDX
  1645.  
  1646.         MOV     AL,[EDX]
  1647.         CMP     AL,CL
  1648.         JA      @@trunc
  1649.  
  1650.         INC     EAX
  1651.  
  1652.         MOV     ECX,EAX
  1653.         AND     EAX,3
  1654.         SHR     ECX,2
  1655.         REP     MOVSD
  1656.  
  1657.         MOV     ECX,EAX
  1658.         REP     MOVSB
  1659.  
  1660.         POP     EDI
  1661.         POP     ESI
  1662.         RET
  1663.  
  1664. @@trunc:
  1665.         MOV     [EDI],CL        { result length is maxLen       }
  1666.         INC     ESI             { advance pointers              }
  1667.         INC     EDI
  1668.         AND     ECX,0FFH        { should be cheaper than MOVZX  }
  1669.         REP     MOVSB   { copy maxLen bytes             }
  1670.  
  1671.         POP     EDI
  1672.         POP     ESI
  1673. end;
  1674.  
  1675. procedure       _PStrCmp;
  1676. asm
  1677. {     ->EAX = Pointer to left string    }
  1678. {       EDX = Pointer to right string   }
  1679.  
  1680.         PUSH    EBX
  1681.         PUSH    ESI
  1682.         PUSH    EDI
  1683.  
  1684.         MOV     ESI,EAX
  1685.         MOV     EDI,EDX
  1686.  
  1687.         XOR     EAX,EAX
  1688.         XOR     EDX,EDX
  1689.         MOV     AL,[ESI]
  1690.         MOV     DL,[EDI]
  1691.         INC     ESI
  1692.         INC     EDI
  1693.  
  1694.         SUB     EAX,EDX { eax = len1 - len2 }
  1695.         JA      @@skip1
  1696.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  1697.  
  1698. @@skip1:
  1699.         PUSH    EDX
  1700.         SHR     EDX,2
  1701.         JE      @@cmpRest
  1702. @@longLoop:
  1703.         MOV     ECX,[ESI]
  1704.         MOV     EBX,[EDI]
  1705.         CMP     ECX,EBX
  1706.         JNE     @@misMatch
  1707.         DEC     EDX
  1708.         JE      @@cmpRestP4
  1709.         MOV     ECX,[ESI+4]
  1710.         MOV     EBX,[EDI+4]
  1711.         CMP     ECX,EBX
  1712.         JNE     @@misMatch
  1713.         ADD     ESI,8
  1714.         ADD     EDI,8
  1715.         DEC     EDX
  1716.         JNE     @@longLoop
  1717.         JMP     @@cmpRest
  1718. @@cmpRestP4:
  1719.         ADD     ESI,4
  1720.         ADD     EDI,4
  1721. @@cmpRest:
  1722.         POP     EDX
  1723.         AND     EDX,3
  1724.         JE      @@equal
  1725.  
  1726.         MOV     CL,[ESI]
  1727.         CMP     CL,[EDI]
  1728.         JNE     @@exit
  1729.         DEC     EDX
  1730.         JE      @@equal
  1731.         MOV     CL,[ESI+1]
  1732.         CMP     CL,[EDI+1]
  1733.         JNE     @@exit
  1734.         DEC     EDX
  1735.         JE      @@equal
  1736.         MOV     CL,[ESI+2]
  1737.         CMP     CL,[EDI+2]
  1738.         JNE     @@exit
  1739.  
  1740. @@equal:
  1741.         ADD     EAX,EAX
  1742.         JMP     @@exit
  1743.  
  1744. @@misMatch:
  1745.         POP     EDX
  1746.         CMP     CL,BL
  1747.         JNE     @@exit
  1748.         CMP     CH,BH
  1749.         JNE     @@exit
  1750.         SHR     ECX,16
  1751.         SHR     EBX,16
  1752.         CMP     CL,BL
  1753.         JNE     @@exit
  1754.         CMP     CH,BH
  1755.  
  1756. @@exit:
  1757.         POP     EDI
  1758.         POP     ESI
  1759.         POP     EBX
  1760. end;
  1761.  
  1762. procedure       _AStrCmp;
  1763. asm
  1764. {     ->EAX = Pointer to left string    }
  1765. {       EDX = Pointer to right string   }
  1766. {       ECX = Number of chars to compare}
  1767.  
  1768.         PUSH    EBX
  1769.         PUSH    ESI
  1770.         PUSH    ECX
  1771.         MOV     ESI,ECX
  1772.         SHR     ESI,2
  1773.         JE      @@cmpRest
  1774.  
  1775. @@longLoop:
  1776.         MOV     ECX,[EAX]
  1777.         MOV     EBX,[EDX]
  1778.         CMP     ECX,EBX
  1779.         JNE     @@misMatch
  1780.         DEC     ESI
  1781.         JE      @@cmpRestP4
  1782.         MOV     ECX,[EAX+4]
  1783.         MOV     EBX,[EDX+4]
  1784.         CMP     ECX,EBX
  1785.         JNE     @@misMatch
  1786.         ADD     EAX,8
  1787.         ADD     EDX,8
  1788.         DEC     ESI
  1789.         JNE     @@longLoop
  1790.         JMP     @@cmpRest
  1791. @@cmpRestp4:
  1792.         ADD     EAX,4
  1793.         ADD     EDX,4
  1794. @@cmpRest:
  1795.         POP     ESI
  1796.         AND     ESI,3
  1797.         JE      @@exit
  1798.  
  1799.         MOV     CL,[EAX]
  1800.         CMP     CL,[EDX]
  1801.         JNE     @@exit
  1802.         DEC     ESI
  1803.         JE      @@equal
  1804.         MOV     CL,[EAX+1]
  1805.         CMP     CL,[EDX+1]
  1806.         JNE     @@exit
  1807.         DEC     ESI
  1808.         JE      @@equal
  1809.         MOV     CL,[EAX+2]
  1810.         CMP     CL,[EDX+2]
  1811.         JNE     @@exit
  1812.  
  1813. @@equal:
  1814.         XOR     EAX,EAX
  1815.         JMP     @@exit
  1816.  
  1817. @@misMatch:
  1818.         POP     ESI
  1819.         CMP     CL,BL
  1820.         JNE     @@exit
  1821.         CMP     CH,BH
  1822.         JNE     @@exit
  1823.         SHR     ECX,16
  1824.         SHR     EBX,16
  1825.         CMP     CL,BL
  1826.         JNE     @@exit
  1827.         CMP     CH,BH
  1828.  
  1829. @@exit:
  1830.         POP     ESI
  1831.         POP     EBX
  1832. end;
  1833.  
  1834. procedure       _EofFile;                               external;       {$L EofFile }
  1835. procedure       _EofText;                               external;       {$L EofText }
  1836. procedure       _Eoln;                          external;       {$L Eoln    }
  1837. procedure       _Erase;                         external;       {$L Erase   }
  1838.  
  1839. procedure       _FSafeDivide;                           external;       {$L FDIV    }
  1840. procedure       _FSafeDivideR;                          external;       {   FDIV    }
  1841.  
  1842. procedure       _FilePos;                               external;       {$L FilePos }
  1843. procedure       _FileSize;                              external;       {$L FileSize}
  1844.  
  1845. procedure       _FillChar;
  1846. asm
  1847. {     ->EAX     Pointer to destination  }
  1848. {       EDX     count   }
  1849. {       CL      value   }
  1850.  
  1851.         PUSH    EDI
  1852.  
  1853.         MOV     EDI,EAX { Point EDI to destination              }
  1854.  
  1855.         MOV     CH,CL   { Fill EAX with value repeated 4 times  }
  1856.         MOV     EAX,ECX
  1857.         SHL     EAX,16
  1858.         MOV     AX,CX
  1859.  
  1860.         MOV     ECX,EDX
  1861.         SAR     ECX,2
  1862.         JS      @@exit
  1863.  
  1864.         REP     STOSD   { Fill count DIV 4 dwords       }
  1865.  
  1866.         MOV     ECX,EDX
  1867.         AND     ECX,3
  1868.         REP     STOSB   { Fill count MOD 4 bytes        }
  1869.  
  1870. @@exit:
  1871.         POP     EDI
  1872. end;
  1873.  
  1874. procedure       _Halt;                          external;       {$L Halt    }
  1875. procedure       _Halt0;                         external;       {   Halt    }
  1876.  
  1877. procedure       _Mark;
  1878. begin
  1879.   Error(reInvalidPtr);
  1880. end;
  1881.  
  1882. procedure       _RandInt;
  1883. asm
  1884. {     ->EAX     Range   }
  1885. {     <-EAX     Result  }
  1886.         IMUL    EDX,RandSeed,08088405H
  1887.         INC     EDX
  1888.         MOV     RandSeed,EDX
  1889.         MUL     EDX
  1890.         MOV     EAX,EDX
  1891. end;
  1892.  
  1893. procedure       _RandExt;
  1894. const   Minus32: double = -32.0;
  1895. asm
  1896. {       FUNCTION _RandExt: Extended;    }
  1897. {     ->EAX     Range   }
  1898.  
  1899.         IMUL    EDX,RandSeed,08088405H
  1900.         INC     EDX
  1901.         MOV     RandSeed,EDX
  1902.  
  1903.         FLD     Minus32
  1904.         PUSH    0
  1905.         PUSH    EDX
  1906.         FILD    qword ptr [ESP]
  1907.         ADD     ESP,8
  1908.         FSCALE
  1909.         FSTP    ST(1)
  1910. end;
  1911.  
  1912. procedure       _ReadRec;                               external;       {$L ReadRec }
  1913.  
  1914. procedure       _ReadChar;                              external;       {$L ReadChar}
  1915. procedure       _ReadLong;                              external;       {$L ReadLong}
  1916. procedure       _ReadString;                    external;       {$L ReadStri}
  1917. procedure       _ReadCString;                   external;       {   ReadStri}
  1918.  
  1919. procedure       _ReadExt;                               external;       {$L ReadExt }
  1920. procedure       _ReadLn;                                external;       {$L ReadLn  }
  1921.  
  1922. procedure       _Rename;                                external;       {$L Rename  }
  1923.  
  1924. procedure       _Release;
  1925. begin
  1926.   Error(reInvalidPtr);
  1927. end;
  1928.  
  1929. procedure       _ResetText(var t: text);                external;       {$L OpenText}
  1930. procedure       _ResetFile;                             external;       {$L OpenFile}
  1931. procedure       _RewritText(var t: text);               external;       {   OpenText}
  1932. procedure       _RewritFile;                    external;       {   OpenFile}
  1933.  
  1934. procedure       _RunError;                              external;       {   Halt    }
  1935. procedure       _Run0Error;                             external;       {   Halt    }
  1936.  
  1937. procedure       _Seek;                          external;       {$L Seek    }
  1938. procedure       _SeekEof;                               external;       {$L SeekEof }
  1939. procedure       _SeekEoln;                              external;       {$L SeekEoln}
  1940.  
  1941. procedure       _SetTextBuf;                    external;       {$L SetTextB}
  1942.  
  1943. procedure       _StrLong;
  1944. asm
  1945. {       PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString );
  1946.       ->EAX     Value
  1947.         EDX     Width
  1948.         ECX     Pointer to string       }
  1949.  
  1950.         PUSH    EBX             { VAR i: Longint;               }
  1951.         PUSH    ESI             { VAR sign : Longint;           }
  1952.         PUSH    EDI
  1953.         PUSH    EDX             { store width on the stack      }
  1954.         SUB     ESP,20          { VAR a: array [0..19] of Char; }
  1955.  
  1956.         MOV     EDI,ECX
  1957.  
  1958.         MOV     ESI,EAX         { sign := val                   }
  1959.  
  1960.         CDQ                     { val := Abs(val);  canned sequence }
  1961.         XOR     EAX,EDX
  1962.         SUB     EAX,EDX
  1963.  
  1964.         MOV     ECX,10
  1965.         XOR     EBX,EBX         { i := 0;                       }
  1966.  
  1967. @@repeat1:                      { repeat                        }
  1968.         XOR     EDX,EDX         {   a[i] := Chr( val MOD 10 + Ord('0') );}
  1969.  
  1970.         DIV     ECX             {   val := val DIV 10;          }
  1971.  
  1972.         ADD     EDX,'0'
  1973.         MOV     [ESP+EBX],DL
  1974.         INC     EBX             {   i := i + 1;                 }
  1975.         TEST    EAX,EAX         { until val = 0;                }
  1976.         JNZ     @@repeat1
  1977.  
  1978.         TEST    ESI,ESI
  1979.         JGE     @@2
  1980.         MOV     byte ptr [ESP+EBX],'-'
  1981.         INC     EBX
  1982. @@2:
  1983.         MOV     [EDI],BL        { s^++ := Chr(i);               }
  1984.         INC     EDI
  1985.  
  1986.         MOV     ECX,[ESP+20]    { spaceCnt := width - i;        }
  1987.         CMP     ECX,255
  1988.         JLE     @@3
  1989.         MOV     ECX,255
  1990. @@3:
  1991.         SUB     ECX,EBX
  1992.         JLE     @@repeat2       { for k := 1 to spaceCnt do s^++ := ' ';        }
  1993.         ADD     [EDI-1],CL
  1994.         MOV     AL,' '
  1995.         REP     STOSB
  1996.  
  1997. @@repeat2:                      { repeat                        }
  1998.         MOV     AL,[ESP+EBX-1]  {   s^ := a[i-1];               }
  1999.         MOV     [EDI],AL
  2000.         INC     EDI             {   s := s + 1                  }
  2001.         DEC     EBX             {   i := i - 1;                 }
  2002.         JNZ     @@repeat2       { until i = 0;                  }
  2003.  
  2004.         ADD     ESP,20+4
  2005.         POP     EDI
  2006.         POP     ESI
  2007.         POP     EBX
  2008. end;
  2009.  
  2010. procedure       _Str0Long;
  2011. asm
  2012. {     ->EAX     Value           }
  2013. {       EDX     Pointer to string       }
  2014.  
  2015.         MOV     ECX,EDX
  2016.         XOR     EDX,EDX
  2017.         JMP     _StrLong
  2018. end;
  2019.  
  2020. procedure       _Truncate;                              external;       {$L Truncate}
  2021.  
  2022. procedure       _ValLong;
  2023. asm
  2024. {       FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint;        }
  2025. {     ->EAX     Pointer to string       }
  2026. {       EDX     Pointer to code result  }
  2027. {     <-EAX     Result                  }
  2028.  
  2029.         PUSH    EBX
  2030.         PUSH    ESI
  2031.         PUSH    EDI
  2032.  
  2033.         MOV     ESI,EAX
  2034.         PUSH    EAX             { save for the error case       }
  2035.  
  2036.         TEST    EAX,EAX
  2037.         JE      @@empty
  2038.  
  2039.         XOR     EAX,EAX
  2040.         XOR     EBX,EBX
  2041.         MOV     EDI,07FFFFFFFH / 10     { limit }
  2042.  
  2043. @@blankLoop:
  2044.         MOV     BL,[ESI]
  2045.         INC     ESI
  2046.         CMP     BL,' '
  2047.         JE      @@blankLoop
  2048.  
  2049. @@endBlanks:
  2050.         MOV     CH,0
  2051.         CMP     BL,'-'
  2052.         JE      @@minus
  2053.         CMP     BL,'+'
  2054.         JE      @@plus
  2055.         CMP     BL,'$'
  2056.         JE      @@dollar
  2057.  
  2058. @@firstDigit:
  2059.         TEST    BL,BL
  2060.         JE      @@error
  2061.  
  2062. @@digLoop:
  2063.         SUB     BL,'0'
  2064.         CMP     BL,9
  2065.         JA      @@error
  2066.         CMP     EAX,EDI         { value > limit ?       }
  2067.         JA      @@overFlow
  2068.         LEA     EAX,[EAX+EAX*4]
  2069.         ADD     EAX,EAX
  2070.         ADD     EAX,EBX         { fortunately, we can't have a carry    }
  2071.  
  2072.         MOV     BL,[ESI]
  2073.         INC     ESI
  2074.  
  2075.         TEST    BL,BL
  2076.         JNE     @@digLoop
  2077.  
  2078. @@endDigits:
  2079.         DEC     CH
  2080.         JE      @@negate
  2081.         TEST    EAX,EAX
  2082.         JL      @@overFlow
  2083.  
  2084. @@successExit:
  2085.  
  2086.         POP     ECX                     { saved copy of string pointer  }
  2087.  
  2088.         XOR     ESI,ESI         { signal no error to caller     }
  2089.  
  2090. @@exit:
  2091.         MOV     [EDX],ESI
  2092.  
  2093.         POP     EDI
  2094.         POP     ESI
  2095.         POP     EBX
  2096.         RET
  2097.  
  2098. @@empty:
  2099.         INC     ESI
  2100.         JMP     @@error
  2101.  
  2102. @@negate:
  2103.         NEG     EAX
  2104.         JLE     @@successExit
  2105.  
  2106. @@error:
  2107. @@overFlow:
  2108.         POP     EBX
  2109.         SUB     ESI,EBX
  2110.         JMP     @@exit
  2111.  
  2112. @@minus:
  2113.         INC     CH
  2114. @@plus:
  2115.         MOV     BL,[ESI]
  2116.         INC     ESI
  2117.         JMP     @@firstDigit
  2118.  
  2119. @@dollar:
  2120.         MOV     EDI,0FFFFFFFH
  2121.  
  2122.         MOV     BL,[ESI]
  2123.         INC     ESI
  2124.         TEST    BL,BL
  2125.         JZ      @@empty
  2126.  
  2127. @@hDigLoop:
  2128.         CMP     BL,'a'
  2129.         JB      @@upper
  2130.         SUB     BL,'a' - 'A'
  2131. @@upper:
  2132.         SUB     BL,'0'
  2133.         CMP     BL,9
  2134.         JBE     @@digOk
  2135.         SUB     BL,'A' - '0'
  2136.         CMP     BL,5
  2137.         JA      @@error
  2138.         ADD     BL,10
  2139. @@digOk:
  2140.         CMP     EAX,EDI
  2141.         JA      @@overFlow
  2142.         SHL     EAX,4
  2143.         ADD     EAX,EBX
  2144.  
  2145.         MOV     BL,[ESI]
  2146.         INC     ESI
  2147.  
  2148.         TEST    BL,BL
  2149.         JNE     @@hDigLoop
  2150.  
  2151.         JMP     @@successExit
  2152. end;
  2153.  
  2154. procedure       _WriteRec;                              external;       {$L WriteRec}
  2155.  
  2156. procedure       _WriteChar;                             external;       {   WriteStr}
  2157. procedure       _Write0Char;                    external;       {   WriteStr}
  2158.  
  2159. procedure       _WriteBool;
  2160. asm
  2161. {       PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint);       }
  2162. {     ->EAX     Pointer to file record  }
  2163. {       DL      Boolean value           }
  2164. {       ECX     Field width             }
  2165.  
  2166.         TEST    DL,DL
  2167.         JE      @@false
  2168.         MOV     EDX,offset @trueString
  2169.         JMP     _WriteString
  2170. @@false:
  2171.         MOV     EDX,offset @falseString
  2172.         JMP     _WriteString
  2173. @trueString:  db        4,'TRUE'
  2174. @falseString: db        5,'FALSE'
  2175. end;
  2176.  
  2177. procedure       _Write0Bool;
  2178. asm
  2179. {       PROCEDURE _Write0Bool( VAR t: Text; val: Boolean);      }
  2180. {     ->EAX     Pointer to file record  }
  2181. {       DL      Boolean value           }
  2182.  
  2183.         XOR     ECX,ECX
  2184.         JMP     _WriteBool
  2185. end;
  2186.  
  2187. procedure       _WriteLong;
  2188. asm
  2189. {       PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint);        }
  2190. {     ->EAX     Pointer to file record  }
  2191. {       EDX     Value                   }
  2192. {       ECX     Field width             }
  2193.  
  2194.         SUB     ESP,32          { VAR s: String[31];    }
  2195.  
  2196.         PUSH    EAX
  2197.         PUSH    ECX
  2198.  
  2199.         MOV     EAX,EDX         { Str( val : 0, s );    }
  2200.         XOR     EDX,EDX
  2201.         CMP     ECX,31
  2202.         JG      @@1
  2203.         MOV     EDX,ECX
  2204. @@1:
  2205.         LEA     ECX,[ESP+8]
  2206.         CALL    _StrLong
  2207.  
  2208.         POP     ECX
  2209.         POP     EAX
  2210.  
  2211.         MOV     EDX,ESP         { Write( t, s : width );}
  2212.         CALL    _WriteString
  2213.  
  2214.         ADD     ESP,32
  2215. end;
  2216.  
  2217. procedure       _Write0Long;
  2218. asm
  2219. {       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
  2220. {     ->EAX     Pointer to file record  }
  2221. {       EDX     Value                   }
  2222.         XOR     ECX,ECX
  2223.         JMP     _WriteLong
  2224. end;
  2225.  
  2226. procedure       _WriteString;                   external;       {$L WriteStr}
  2227. procedure       _Write0String;                  external;       {   WriteStr}
  2228.  
  2229. procedure       _WriteCString;                  external;       {   WriteStr}
  2230. procedure       _Write0CString;                 external;       {   WriteStr}
  2231.  
  2232. procedure       _WriteBytes;                    external;       {   WriteStr}
  2233. procedure       _WriteSpaces;                   external;       {   WriteStr}
  2234.  
  2235. procedure       _Write2Ext;
  2236. asm
  2237. {       PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint);
  2238.       ->EAX     Pointer to file record
  2239.         [ESP+4] Extended value
  2240.         EDX     Field width
  2241.         ECX     precision (<0: scientific, >= 0: fixed point)   }
  2242.  
  2243.         FLD     tbyte ptr [ESP+4]       { load value    }
  2244.         SUB     ESP,256         { VAR s: String;        }
  2245.  
  2246.         PUSH    EAX
  2247.         PUSH    EDX
  2248.  
  2249. {       Str( val, width, prec, s );     }
  2250.  
  2251.         SUB     ESP,12
  2252.         FSTP    tbyte ptr [ESP] { pass value            }
  2253.         MOV     EAX,EDX         { pass field width              }
  2254.         MOV     EDX,ECX         { pass precision                }
  2255.         LEA     ECX,[ESP+8+12]  { pass destination string       }
  2256.         CALL    _Str2Ext
  2257.  
  2258. {       Write( t, s, width );   }
  2259.  
  2260.         POP     ECX                     { pass width    }
  2261.         POP     EAX                     { pass text     }
  2262.         MOV     EDX,ESP         { pass string   }
  2263.         CALL    _WriteString
  2264.  
  2265.         ADD     ESP,256
  2266.         RET     12
  2267. end;
  2268.  
  2269. procedure       _Write1Ext;
  2270. asm
  2271. {       PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint);
  2272.   ->    EAX     Pointer to file record
  2273.         [ESP+4] Extended value
  2274.         EDX     Field width             }
  2275.  
  2276.         OR      ECX,-1
  2277.         JMP     _Write2Ext
  2278. end;
  2279.  
  2280. procedure       _Write0Ext;
  2281. asm
  2282. {       PROCEDURE _Write0Ext( VAR t: Text; val: Extended);
  2283.       ->EAX     Pointer to file record
  2284.         [ESP+4] Extended value  }
  2285.  
  2286.         MOV     EDX,23  { field width   }
  2287.         OR      ECX,-1
  2288.         JMP     _Write2Ext
  2289. end;
  2290.  
  2291. procedure       _WriteLn;                       external;       {   WriteStr}
  2292.  
  2293. procedure       __CToPasStr;
  2294. asm
  2295. {     ->EAX     Pointer to destination  }
  2296. {       EDX     Pointer to source       }
  2297.  
  2298.         PUSH    EAX             { save destination      }
  2299.  
  2300.         MOV     CL,255
  2301. @@loop:
  2302.         MOV     CH,[EDX]        { ch = *src++;          }
  2303.         INC     EDX
  2304.         TEST    CH,CH   { if (ch == 0) break    }
  2305.         JE      @@endLoop
  2306.         INC     EAX             { *++dest = ch;         }
  2307.         MOV     [EAX],CH
  2308.         DEC     CL
  2309.         JNE     @@loop
  2310.  
  2311. @@endLoop:
  2312.         POP     EDX
  2313.         SUB     EAX,EDX
  2314.         MOV     [EDX],AL
  2315. end;
  2316.  
  2317. procedure       __CLenToPasStr;
  2318. asm
  2319. {     ->EAX     Pointer to destination  }
  2320. {       EDX     Pointer to source       }
  2321. {       ECX     cnt                     }
  2322.  
  2323.         PUSH    EBX
  2324.         PUSH    EAX             { save destination      }
  2325.  
  2326.         CMP     ECX,255
  2327.         JBE     @@loop
  2328.     MOV ECX,255
  2329. @@loop:
  2330.         MOV     BL,[EDX]        { ch = *src++;          }
  2331.         INC     EDX
  2332.         TEST    BL,BL   { if (ch == 0) break    }
  2333.         JE      @@endLoop
  2334.         INC     EAX             { *++dest = ch;         }
  2335.         MOV     [EAX],BL
  2336.         DEC     ECX             { while (--cnt != 0)    }
  2337.         JNZ     @@loop
  2338.  
  2339. @@endLoop:
  2340.         POP     EDX
  2341.         SUB     EAX,EDX
  2342.         MOV     [EDX],AL
  2343.         POP     EBX
  2344. end;
  2345.  
  2346. procedure       __PasToCStr;
  2347. asm
  2348. {     ->EAX     Pointer to source       }
  2349. {       EDX     Pointer to destination  }
  2350.  
  2351.         PUSH    ESI
  2352.         PUSH    EDI
  2353.  
  2354.         MOV     ESI,EAX
  2355.         MOV     EDI,EDX
  2356.  
  2357.         XOR     ECX,ECX
  2358.         MOV     CL,[ESI]
  2359.         INC     ESI
  2360.  
  2361.         REP     MOVSB
  2362.         MOV     byte ptr [EDI],CL       { Append terminator: CL is zero here }
  2363.  
  2364.         POP     EDI
  2365.         POP     ESI
  2366. end;
  2367.  
  2368. procedure       _SetElem;
  2369. asm
  2370.         {       PROCEDURE _SetElem( VAR d: SET; elem, size: Byte);      }
  2371.         {       EAX     =       dest address                            }
  2372.         {       DL      =       element number                          }
  2373.         {       CL      =       size of set                                     }
  2374.  
  2375.         PUSH    EBX
  2376.         PUSH    EDI
  2377.  
  2378.         MOV     EDI,EAX
  2379.  
  2380.         XOR     EBX,EBX { zero extend set size into ebx }
  2381.         MOV     BL,CL
  2382.         MOV     ECX,EBX { and use it for the fill       }
  2383.  
  2384.         XOR     EAX,EAX { for zero fill                 }
  2385.         REP     STOSB
  2386.  
  2387.         SUB     EDI,EBX { point edi at beginning of set again   }
  2388.  
  2389.         INC     EAX             { eax is still zero - make it 1 }
  2390.         MOV     CL,DL
  2391.         ROL     AL,CL   { generate a mask               }
  2392.         SHR     ECX,3   { generate the index            }
  2393.         CMP     ECX,EBX { if index >= siz then exit     }
  2394.         JAE     @@exit
  2395.         OR      [EDI+ECX],AL{ set bit                   }
  2396.  
  2397. @@exit:
  2398.         POP     EDI
  2399.         POP     EBX
  2400. end;
  2401.  
  2402. procedure       _SetRange;
  2403. asm
  2404. {       PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET );  }
  2405. { ->AL  low limit of range      }
  2406. {       DL      high limit of range     }
  2407. {       ECX     Pointer to set          }
  2408. {       AH      size of set             }
  2409.  
  2410.         PUSH    EBX
  2411.         PUSH    ESI
  2412.         PUSH    EDI
  2413.  
  2414.         XOR     EBX,EBX { EBX = set size                }
  2415.         MOV     BL,AH
  2416.         MOVZX   ESI,AL  { ESI = low zero extended       }
  2417.         MOVZX   EDX,DL  { EDX = high zero extended      }
  2418.         MOV     EDI,ECX
  2419.  
  2420. {       clear the set                                   }
  2421.  
  2422.         MOV     ECX,EBX
  2423.         XOR     EAX,EAX
  2424.         REP     STOSB
  2425.  
  2426. {       prepare for setting the bits                    }
  2427.  
  2428.         SUB     EDI,EBX { point EDI at start of set     }
  2429.         SHL     EBX,3   { EBX = highest bit in set + 1  }
  2430.         CMP     EDX,EBX
  2431.         JB      @@inrange
  2432.         LEA     EDX,[EBX-1]     { ECX = highest bit in set      }
  2433.  
  2434. @@inrange:
  2435.         CMP     ESI,EDX { if lo > hi then exit;         }
  2436.         JA      @@exit
  2437.  
  2438.         DEC     EAX     { loMask = 0xff << (lo & 7)             }
  2439.         MOV     ECX,ESI
  2440.         AND     CL,07H
  2441.         SHL     AL,CL
  2442.  
  2443.         SHR     ESI,3   { loIndex = lo >> 3;            }
  2444.  
  2445.         MOV     CL,DL   { hiMask = 0xff >> (7 - (hi & 7));      }
  2446.         NOT     CL
  2447.         AND     CL,07
  2448.         SHR     AH,CL
  2449.  
  2450.         SHR     EDX,3   { hiIndex = hi >> 3;            }
  2451.  
  2452.         ADD     EDI,ESI { point EDI to set[loIndex]     }
  2453.         MOV     ECX,EDX
  2454.         SUB     ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0)     }
  2455.         JNE     @@else
  2456.  
  2457.         AND     AL,AH   { set[loIndex] = hiMask & loMask;       }
  2458.         MOV     [EDI],AL
  2459.         JMP     @@exit
  2460.  
  2461. @@else:
  2462.         STOSB           { set[loIndex++] = loMask;      }
  2463.         DEC     ECX
  2464.         MOV     AL,0FFH { while (loIndex < hiIndex)     }
  2465.         REP     STOSB   {   set[loIndex++] = 0xff;      }
  2466.         MOV     [EDI],AH        { set[hiIndex] = hiMask;        }
  2467.  
  2468. @@exit:
  2469.         POP     EDI
  2470.         POP     ESI
  2471.         POP     EBX
  2472. end;
  2473.  
  2474. procedure       _SetEq;
  2475. asm
  2476. {       FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode;   }
  2477. {       EAX     =       left operand    }
  2478. {       EDX     =       right operand   }
  2479. {       CL      =       size of set     }
  2480.  
  2481.         PUSH    ESI
  2482.         PUSH    EDI
  2483.  
  2484.         MOV     ESI,EAX
  2485.         MOV     EDI,EDX
  2486.  
  2487.         AND     ECX,0FFH
  2488.         REP     CMPSB
  2489.  
  2490.         POP     EDI
  2491.         POP     ESI
  2492. end;
  2493.  
  2494. procedure       _SetLe;
  2495. asm
  2496. {       FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode;   }
  2497. {       EAX     =       left operand            }
  2498. {       EDX     =       right operand           }
  2499. {       CL      =       size of set (>0 && <= 32)       }
  2500.  
  2501. @@loop:
  2502.         MOV     CH,[EDX]
  2503.         NOT     CH
  2504.         AND     CH,[EAX]
  2505.         JNE     @@exit
  2506.         INC     EDX
  2507.         INC     EAX
  2508.         DEC     CL
  2509.         JNZ     @@loop
  2510. @@exit:
  2511. end;
  2512.  
  2513. procedure       _SetIntersect;
  2514. asm
  2515. {       PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);}
  2516. {       EAX     =       destination operand             }
  2517. {       EDX     =       source operand                  }
  2518. {       CL      =       size of set (0 < size <= 32)    }
  2519.  
  2520. @@loop:
  2521.         MOV     CH,[EDX]
  2522.         INC     EDX
  2523.         AND     [EAX],CH
  2524.         INC     EAX
  2525.         DEC     CL
  2526.         JNZ     @@loop
  2527. end;
  2528.  
  2529. procedure       _SetUnion;
  2530. asm
  2531. {       PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte);        }
  2532. {       EAX     =       destination operand             }
  2533. {       EDX     =       source operand                  }
  2534. {       CL      =       size of set (0 < size <= 32)    }
  2535.  
  2536. @@loop:
  2537.         MOV     CH,[EDX]
  2538.         INC     EDX
  2539.         OR      [EAX],CH
  2540.         INC     EAX
  2541.         DEC     CL
  2542.         JNZ     @@loop
  2543. end;
  2544.  
  2545. procedure       _SetSub;
  2546. asm
  2547. {       PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte);  }
  2548. {       EAX     =       destination operand             }
  2549. {       EDX     =       source operand                  }
  2550. {       CL      =       size of set (0 < size <= 32)    }
  2551.  
  2552. @@loop:
  2553.         MOV     CH,[EDX]
  2554.         NOT     CH
  2555.         INC     EDX
  2556.         AND     [EAX],CH
  2557.         INC     EAX
  2558.         DEC     CL
  2559.         JNZ     @@loop
  2560. end;
  2561.  
  2562. procedure       _SetExpand;
  2563. asm
  2564. {       PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte);     }
  2565. {     ->EAX     Pointer to source (packed set)          }
  2566. {       EDX     Pointer to destination (expanded set)   }
  2567. {       CH      high byte of source                     }
  2568. {       CL      low byte of source                      }
  2569.  
  2570. {       algorithm:              }
  2571. {       clear low bytes         }
  2572. {       copy high-low+1 bytes   }
  2573. {       clear 31-high bytes     }
  2574.  
  2575.         PUSH    ESI
  2576.         PUSH    EDI
  2577.  
  2578.         MOV     ESI,EAX
  2579.         MOV     EDI,EDX
  2580.  
  2581.         MOV     EDX,ECX { save low, high in dl, dh      }
  2582.         XOR     ECX,ECX
  2583.         XOR     EAX,EAX
  2584.  
  2585.         MOV     CL,DL   { clear low bytes               }
  2586.         REP     STOSB
  2587.  
  2588.         MOV     CL,DH   { copy high - low bytes }
  2589.         SUB     CL,DL
  2590.         REP     MOVSB
  2591.  
  2592.         MOV     CL,32   { copy 32 - high bytes  }
  2593.         SUB     CL,DH
  2594.         REP     STOSB
  2595.  
  2596.         POP     EDI
  2597.         POP     ESI
  2598. end;
  2599.  
  2600. procedure       _Str2Ext;                       external;       {$L StrExt  }
  2601. procedure       _Str0Ext;                       external;       {   StrExt  }
  2602. procedure       _Str1Ext;                       external;       {   StrExt  }
  2603.  
  2604. procedure       _ValExt;                        external;       {$L ValExt  }
  2605.  
  2606. procedure       _Pow10;                         external;       {$L Pow10   }
  2607. procedure       FPower10;                       external;       {   Pow10   }
  2608. procedure       _Real2Ext;                      external;       {$L Real2Ext}
  2609. procedure       _Ext2Real;                      external;       {$L Ext2Real}
  2610.  
  2611. const
  2612.         ovtInstanceSize = -8;   { Offset of instance size in OBJECTs    }
  2613.         ovtVmtPtrOffs   = -4;
  2614.  
  2615. procedure       _ObjSetup;
  2616. asm
  2617. {       FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
  2618. {     ->EAX     Pointer to self (possibly nil)  }
  2619. {       EDX     Pointer to vmt  (possibly nil)  }
  2620. {     <-EAX     Pointer to self                 }
  2621. {       EDX     <> 0: an object was allocated   }
  2622. {       Z-Flag  Set: failure, Cleared: Success  }
  2623.  
  2624.         CMP     EDX,1   { is vmt = 0, indicating a call         }
  2625.         JAE     @@skip1 { from a constructor?                   }
  2626.         RET                     { return immediately with Z-flag cleared        }
  2627.  
  2628. @@skip1:
  2629.         PUSH    ECX
  2630.         TEST    EAX,EAX { is self already allocated?            }
  2631.         JNE     @@noAlloc
  2632.         MOV     EAX,[EDX].ovtInstanceSize
  2633.         TEST    EAX,EAX
  2634.         JE      @@zeroSize
  2635.         PUSH    EDX
  2636.         CALL    MemoryManager.GetMem
  2637.         POP     EDX
  2638.         TEST    EAX,EAX
  2639.         JZ      @@fail
  2640.         MOV     ECX,[EDX].ovtVmtPtrOffs
  2641.         TEST    ECX,ECX
  2642.         JL      @@skip
  2643.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  2644. @@skip:
  2645.         TEST    EAX,EAX { clear zero flag                               }
  2646.         POP     ECX
  2647.         RET
  2648.  
  2649. @@fail:
  2650.         XOR     EDX,EDX
  2651.         POP     ECX
  2652.         RET
  2653.  
  2654. @@zeroSize:
  2655.         XOR     EDX,EDX
  2656.         CMP     EAX,1   { clear zero flag - we were successful (kind of) }
  2657.         POP     ECX
  2658.         RET
  2659.  
  2660. @@noAlloc:
  2661.         MOV     ECX,[EDX].ovtVmtPtrOffs
  2662.         TEST    ECX,ECX
  2663.         JL      @@exit
  2664.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  2665. @@exit:
  2666.         XOR     EDX,EDX { clear allocated flag                  }
  2667.         TEST    EAX,EAX { clear zero flag                               }
  2668.         POP     ECX
  2669. end;
  2670.  
  2671. procedure       _ObjCopy;
  2672. asm
  2673. {       PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint);    }
  2674. {     ->EAX     Pointer to destination          }
  2675. {       EDX     Pointer to source               }
  2676. {       ECX     Offset of vmt in those objects. }
  2677.  
  2678.         PUSH    EBX
  2679.         PUSH    ESI
  2680.         PUSH    EDI
  2681.  
  2682.         MOV     ESI,EDX
  2683.         MOV     EDI,EAX
  2684.  
  2685.         LEA     EAX,[EDI+ECX]   { remember pointer to dest vmt pointer  }
  2686.         MOV     EDX,[EAX]       { fetch dest vmt pointer        }
  2687.  
  2688.         MOV     EBX,[EDX].ovtInstanceSize
  2689.  
  2690.         MOV     ECX,EBX { copy size DIV 4 dwords        }
  2691.         SHR     ECX,2
  2692.         REP     MOVSD
  2693.  
  2694.         MOV     ECX,EBX { copy size MOD 4 bytes }
  2695.         AND     ECX,3
  2696.         REP     MOVSB
  2697.  
  2698.         MOV     [EAX],EDX       { restore dest vmt              }
  2699.  
  2700.         POP     EDI
  2701.         POP     ESI
  2702.         POP     EBX
  2703. end;
  2704.  
  2705. procedure       _Fail;
  2706. asm
  2707. {       FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT;     }
  2708. {     ->EAX     Pointer to self (possibly nil)  }
  2709. {       EDX     <> 0: Object must be deallocated        }
  2710. {     <-EAX     Nil                                     }
  2711.  
  2712.         TEST    EDX,EDX
  2713.         JE      @@exit  { if no object was allocated, return    }
  2714.         CALL    _FreeMem
  2715. @@exit:
  2716.         XOR     EAX,EAX
  2717. end;
  2718.  
  2719. procedure       _FpuInit;
  2720. const cwDefault: Word = $1332 { $133F};
  2721. asm
  2722.         FNINIT
  2723.         FWAIT
  2724.         FLDCW   cwDefault
  2725. end;
  2726.  
  2727. procedure       _BoundErr;
  2728. asm
  2729.         MOV     AL,reRangeError
  2730.         JMP     Error
  2731. end;
  2732.  
  2733. procedure       _IntOver;
  2734. asm
  2735.         MOV     AL,reIntOverflow
  2736.         JMP     Error
  2737. end;
  2738.  
  2739.  
  2740. const
  2741.         vtInitTable      = -48;
  2742.         vtTypeInfo       = -44;
  2743.         vtFieldTable     = -40;
  2744.         vtMethodTable    = -36;
  2745.         vtDynamicTable   = -32;
  2746.         vtClassName      = -28;
  2747.         vtInstanceSize   = -24;
  2748.         vtParent         = -20;
  2749.         vtDefaultHandler = -16;
  2750.         vtNewInstance    = -12;
  2751.         vtFreeInstance   = -8;
  2752.         vtDestroy        = -4;
  2753.  
  2754.         clVTable         = 0;
  2755.  
  2756. function TObject.ClassType:TClass;
  2757. asm
  2758.         mov     eax,[eax].clVTable
  2759. end;
  2760.  
  2761. class function TObject.ClassName: ShortString;
  2762. asm
  2763.         { ->    EAX VMT                         }
  2764.         {       EDX Pointer to result string    }
  2765.         PUSH    ESI
  2766.         PUSH    EDI
  2767.         MOV     EDI,EDX
  2768.         MOV     ESI,[EAX].vtClassName
  2769.         XOR     ECX,ECX
  2770.         MOV     CL,[ESI]
  2771.         INC     ECX
  2772.         REP     MOVSB
  2773.         POP     EDI
  2774.         POP     ESI
  2775. end;
  2776.  
  2777. class function TObject.ClassNameIs(const Name: string): Boolean;
  2778. asm
  2779.         PUSH    EBX
  2780.         XOR     EBX,EBX
  2781.         OR      EDX,EDX
  2782.         JE      @@exit
  2783.         MOV     EAX,[EAX].vtClassName
  2784.         XOR     ECX,ECX
  2785.         MOV     CL,[EAX]
  2786.         CMP     ECX,[EDX-4]
  2787.         JNE     @@exit
  2788.         DEC     EDX
  2789. @@loop:
  2790.         MOV     BH,[EAX+ECX]
  2791.         XOR     BH,[EDX+ECX]
  2792.         AND     BH,0DFH
  2793.         JNE     @@exit
  2794.         DEC     ECX
  2795.         JNE     @@loop
  2796.         INC     EBX
  2797. @@exit:
  2798.         MOV     AL,BL
  2799.         POP     EBX
  2800. end;
  2801.  
  2802. class function TObject.ClassParent:TClass;
  2803. asm
  2804.         MOV     EAX,[EAX].vtParent
  2805. end;
  2806.  
  2807. class function TObject.NewInstance:TObject;
  2808. asm
  2809.         PUSH    EDI
  2810.         PUSH    EAX
  2811.         MOV     EAX,[EAX].vtInstanceSize
  2812.         CALL    _GetMem
  2813.         MOV     EDI,EAX
  2814.         MOV     EDX,EAX
  2815.         POP     EAX
  2816.         STOSD                                   { Set VMT pointer }
  2817.         MOV     ECX,[EAX].vtInstanceSize        { Clear object }
  2818.         XOR     EAX,EAX
  2819.         PUSH    ECX
  2820.         SHR     ECX,2
  2821.         DEC     ECX
  2822.         REP     STOSD
  2823.         POP     ECX
  2824.         AND     ECX,3
  2825.         REP     STOSB
  2826.         MOV     EAX,EDX
  2827.         POP     EDI
  2828. end;
  2829.  
  2830. procedure TObject.FreeInstance;
  2831. asm
  2832.         PUSH    EBX
  2833.         PUSH    ESI
  2834.         MOV     EBX,EAX
  2835.         MOV     ESI,[EAX]
  2836. @@loop:
  2837.         MOV     EDX,[ESI].vtInitTable
  2838.         MOV     ESI,[ESI].vtParent
  2839.         TEST    EDX,EDX
  2840.         JE      @@skip
  2841.         CALL    _FinalizeRecord
  2842.         MOV     EAX,EBX
  2843. @@skip:
  2844.         TEST    ESI,ESI
  2845.         JNE     @@loop
  2846.  
  2847.         CALL    _FreeMem
  2848.         POP     ESI
  2849.         POP     EBX
  2850. end;
  2851.  
  2852. class function TObject.InstanceSize:Longint;
  2853. asm
  2854.         MOV     EAX,[EAX].vtInstanceSize
  2855. end;
  2856.  
  2857.  
  2858. constructor TObject.Create;
  2859. begin
  2860. end;
  2861.  
  2862.  
  2863. destructor TObject.Destroy;
  2864. begin
  2865. end;
  2866.  
  2867.  
  2868. procedure TObject.Free;
  2869. asm
  2870.         TEST    EAX,EAX
  2871.         JE      @@exit
  2872.         MOV     ECX,[EAX]
  2873.         MOV     DL,1
  2874.         CALL    dword ptr [ECX].vtDestroy
  2875. @@exit:
  2876. end;
  2877.  
  2878. class function TObject.InitInstance(Instance: Pointer): TObject;
  2879. asm
  2880.         PUSH    EDI
  2881.         MOV     EDI,EDX
  2882.         STOSD                           {       Set VMT pointer }
  2883.         MOV     ECX,[EAX].vtInstanceSize        {       Clear object    }
  2884.         XOR     EAX,EAX
  2885.         PUSH    ECX
  2886.         SHR     ECX,2
  2887.         DEC     ECX
  2888.         REP     STOSD
  2889.         POP     ECX
  2890.         AND     ECX,3
  2891.         REP     STOSB
  2892.         MOV     EAX,EDX
  2893.         POP     EDI
  2894. end;
  2895.  
  2896. procedure TObject.CleanupInstance;
  2897. asm
  2898.         PUSH    EBX
  2899.         PUSH    ESI
  2900.         MOV     EBX,EAX
  2901.         MOV     ESI,[EAX]
  2902. @@loop:
  2903.         MOV     EDX,[ESI].vtInitTable
  2904.         MOV     ESI,[ESI].vtParent
  2905.         TEST    EDX,EDX
  2906.         JE      @@skip
  2907.         CALL    _FinalizeRecord
  2908.         MOV     EAX,EBX
  2909. @@skip:
  2910.         TEST    ESI,ESI
  2911.         JNE     @@loop
  2912.  
  2913.         POP     ESI
  2914.     POP EBX
  2915. end;
  2916.  
  2917.  
  2918. procedure       _IsClass;
  2919. asm
  2920.         { ->    EAX     left operand (class)    }
  2921.         {       EDX VMT of right operand        }
  2922.         { <-    AL      left is derived from right      }
  2923.         TEST    EAX,EAX
  2924.         JE      @@exit
  2925.         MOV     EAX,[EAX]
  2926. @@loop:
  2927.         CMP     EAX,EDX
  2928.         JE      @@success
  2929.         MOV     EAX,[EAX].vtParent
  2930.         TEST    EAX,EAX
  2931.         JNE     @@loop
  2932.         JMP     @@exit
  2933. @@success:
  2934.         MOV     AL,1
  2935. @@exit:
  2936. end;
  2937.  
  2938.  
  2939. procedure       _AsClass;
  2940. asm
  2941.         { ->    EAX     left operand (class)    }
  2942.         {       EDX VMT of right operand        }
  2943.         { <-    EAX      if left is derived from right, else runtime error      }
  2944.         TEST    EAX,EAX
  2945.         JE      @@exit
  2946.         MOV     ECX,[EAX]
  2947. @@loop:
  2948.         CMP     ECX,EDX
  2949.         JE      @@exit
  2950.         MOV     ECX,[ECX].vtParent
  2951.         TEST    ECX,ECX
  2952.         JNE     @@loop
  2953.  
  2954.         {       do runtime error        }
  2955.         MOV     AL,reInvalidCast
  2956.         JMP     Error
  2957.  
  2958. @@exit:
  2959. end;
  2960.  
  2961.  
  2962. procedure       GetDynaMethod;
  2963. {       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
  2964. asm
  2965.         { ->    EAX     vmt of class            }
  2966.         {       BX      dynamic method index    }
  2967.         { <-    EBX pointer to routine  }
  2968.         {       ZF = 0 if found         }
  2969.         {       trashes: EAX, ECX               }
  2970.  
  2971.         PUSH    EDI
  2972.         XCHG    EAX,EBX
  2973. @@outerLoop:
  2974.         MOV     EDI,[EBX].vtDynamicTable
  2975.         TEST    EDI,EDI
  2976.         JE      @@parent
  2977.         MOVZX   ECX,word ptr [EDI]
  2978.         PUSH    ECX
  2979.         ADD     EDI,2
  2980.         REPNE   SCASW
  2981.         JE      @@found
  2982.         POP     ECX
  2983. @@parent:
  2984.         MOV     EBX,[EBX].vtParent
  2985.         TEST    EBX,EBX
  2986.         JNE     @@outerLoop
  2987.         JMP     @@exit
  2988.  
  2989. @@found:
  2990.         POP     EAX
  2991.         ADD     EAX,EAX
  2992.         SUB     EAX,ECX         { this will always clear the Z-flag ! }
  2993.         MOV     EBX,[EDI+EAX*2-4]
  2994.  
  2995. @@exit:
  2996.         POP     EDI
  2997. end;
  2998.  
  2999. procedure       _CallDynaInst;
  3000. asm
  3001.         PUSH    EAX
  3002.         PUSH    ECX
  3003.         MOV     EAX,[EAX]
  3004.         CALL    GetDynaMethod
  3005.         POP     ECX
  3006.         POP     EAX
  3007.         JE      @@Abstract
  3008.         JMP     EBX
  3009. @@Abstract:
  3010.         POP     ECX
  3011.         JMP     _AbstractError
  3012. end;
  3013.  
  3014.  
  3015. procedure       _CallDynaClass;
  3016. asm
  3017.         PUSH    EAX
  3018.         PUSH    ECX
  3019.         CALL    GetDynaMethod
  3020.         POP     ECX
  3021.         POP     EAX
  3022.         JE      @@Abstract
  3023.         JMP     EBX
  3024. @@Abstract:
  3025.         POP     ECX
  3026.         JMP     _AbstractError
  3027. end;
  3028.  
  3029.  
  3030. procedure       _FindDynaInst;
  3031. asm
  3032.         PUSH    EBX
  3033.         MOV     EBX,EDX
  3034.         MOV     EAX,[EAX]
  3035.         CALL    GetDynaMethod
  3036.         MOV     EAX,EBX
  3037.         POP     EBX
  3038.         JNE     @@exit
  3039.         POP     ECX
  3040.         JMP     _AbstractError
  3041. @@exit:
  3042. end;
  3043.  
  3044.  
  3045. procedure       _FindDynaClass;
  3046. asm
  3047.         PUSH    EBX
  3048.         MOV     EBX,EDX
  3049.         CALL    GetDynaMethod
  3050.         MOV     EAX,EBX
  3051.         POP     EBX
  3052.         JNE     @@exit
  3053.         POP     ECX
  3054.         JMP     _AbstractError
  3055. @@exit:
  3056. end;
  3057.  
  3058.  
  3059. class function TObject.InheritsFrom(AClass: TClass): Boolean;
  3060. asm
  3061.         { ->    EAX     Pointer to our class    }
  3062.         {       EDX     Pointer to AClass               }
  3063.         { <-    AL      Boolean result          }
  3064. @@loop:
  3065.         CMP     EAX,EDX
  3066.         JE      @@success
  3067.         MOV     EAX,[EAX].vtParent
  3068.         TEST    EAX,EAX
  3069.         JNE     @@loop
  3070.         JMP     @@exit
  3071. @@success:
  3072.         MOV     AL,1
  3073. @@exit:
  3074. end;
  3075.  
  3076.  
  3077. class function TObject.ClassInfo: Pointer;
  3078. asm
  3079.         MOV     EAX,[EAX].vtTypeInfo
  3080. end;
  3081.  
  3082.  
  3083. procedure TObject.DefaultHandler(var Message);
  3084. begin
  3085. end;
  3086.  
  3087.  
  3088. procedure TObject.Dispatch(var Message);
  3089. asm
  3090.         PUSH    EBX
  3091.         MOV     BX,[EDX]
  3092.         OR      BX,BX
  3093.         JE      @@default
  3094.         CMP     BX,0C000H
  3095.         JAE     @@default
  3096.         PUSH    EAX
  3097.         MOV     EAX,[EAX]
  3098.         CALL    GetDynaMethod
  3099.         POP     EAX
  3100.         JE      @@default
  3101.         MOV     ECX,EBX
  3102.         POP     EBX
  3103.         JMP     ECX
  3104.  
  3105. @@default:
  3106.         POP     EBX
  3107.         MOV     ECX,[EAX]
  3108.         JMP     dword ptr [ECX].vtDefaultHandler
  3109. end;
  3110.  
  3111.  
  3112. class function TObject.MethodAddress(const Name: ShortString): Pointer;
  3113. asm
  3114.         { ->    EAX     Pointer to class        }
  3115.         {       EDX     Pointer to name }
  3116.         PUSH    EBX
  3117.         PUSH    ESI
  3118.         PUSH    EDI
  3119.     XOR ECX,ECX
  3120.         XOR     EDI,EDI
  3121.         MOV     BL,[EDX]
  3122. @@outer:                        { upper 16 bits of ECX are 0 !  }
  3123.         MOV     ESI,[EAX].vtMethodTable
  3124.         TEST    ESI,ESI
  3125.         JE      @@parent
  3126.         MOV     DI,[ESI]                { EDI := method count           }
  3127.         ADD     ESI,2
  3128. @@inner:                        { upper 16 bits of ECX are 0 !  }
  3129.         MOV     CL,[ESI+6]              { compare length of strings     }
  3130.         CMP     CL,BL
  3131.         JE      @@cmpChar
  3132. @@cont:                         { upper 16 bits of ECX are 0 !  }
  3133.         MOV     CX,[ESI]                { fetch length of method desc   }
  3134.         ADD     ESI,ECX         { point ESI to next method      }
  3135.         DEC     EDI
  3136.         JNZ     @@inner
  3137. @@parent:
  3138.         MOV     EAX,[EAX].vtParent      { fetch parent vmt              }
  3139.         TEST    EAX,EAX
  3140.         JNE     @@outer
  3141.         JMP     @@exit          { return NIL                    }
  3142.  
  3143. @@notEqual:
  3144.         MOV     BL,[EDX]                { restore BL to length of name  }
  3145.         JMP     @@cont
  3146.  
  3147. @@cmpChar:                      { upper 16 bits of ECX are 0 !  }
  3148.         MOV     CH,0                { upper 24 bits of ECX are 0 !      }
  3149. @@cmpCharLoop:
  3150.         MOV     BL,[ESI+ECX+6]  { case insensitive string cmp   }
  3151.         XOR     BL,[EDX+ECX+0]  { last char is compared first   }
  3152.         AND     BL,$DF
  3153.         JNE     @@notEqual
  3154.         DEC     ECX                     { ECX serves as counter         }
  3155.         JNZ     @@cmpCharLoop
  3156.  
  3157.         { found it }
  3158.         MOV     EAX,[ESI+2]
  3159.  
  3160. @@exit:
  3161.         POP     EDI
  3162.         POP     ESI
  3163.         POP     EBX
  3164. end;
  3165.  
  3166.  
  3167. class function TObject.MethodName(Address: Pointer): ShortString;
  3168. asm
  3169.         { ->    EAX     Pointer to class        }
  3170.         {       EDX     Address         }
  3171.         {       ECX Pointer to result   }
  3172.         PUSH    EBX
  3173.         PUSH    ESI
  3174.         PUSH    EDI
  3175.         MOV     EDI,ECX
  3176.         XOR     EBX,EBX
  3177.         XOR     ECX,ECX
  3178. @@outer:
  3179.         MOV     ESI,[EAX].vtMethodTable { fetch pointer to method table }
  3180.         TEST    ESI,ESI
  3181.         JE      @@parent
  3182.         MOV     CX,[ESI]
  3183.         ADD     ESI,2
  3184. @@inner:
  3185.         CMP     EDX,[ESI+2]
  3186.         JE      @@found
  3187.         MOV     BX,[ESI]
  3188.         ADD     ESI,EBX
  3189.         DEC     ECX
  3190.         JNZ     @@inner
  3191. @@parent:
  3192.         MOV     EAX,[EAX].vtParent
  3193.         TEST    EAX,EAX
  3194.         JNE     @@outer
  3195.         MOV     [EDI],AL
  3196.         JMP     @@exit
  3197.  
  3198. @@found:
  3199.         ADD     ESI,6
  3200.         XOR     ECX,ECX
  3201.         MOV     CL,[ESI]
  3202.         INC     ECX
  3203.         REP     MOVSB
  3204.  
  3205. @@exit:
  3206.         POP     EDI
  3207.         POP     ESI
  3208.         POP     EBX
  3209. end;
  3210.  
  3211.  
  3212. function TObject.FieldAddress(const Name: ShortString): Pointer;
  3213. asm
  3214.         { ->    EAX     Pointer to instance     }
  3215.         {       EDX     Pointer to name }
  3216.         PUSH    EBX
  3217.         PUSH    ESI
  3218.         PUSH    EDI
  3219.         XOR     ECX,ECX
  3220.         XOR     EDI,EDI
  3221.         MOV     BL,[EDX]
  3222.  
  3223.         PUSH    EAX                     { save instance pointer         }
  3224.         MOV     EAX,[EAX]               { fetch class pointer           }
  3225.  
  3226. @@outer:
  3227.         MOV     ESI,[EAX].vtFieldTable
  3228.         TEST    ESI,ESI
  3229.         JE      @@parent
  3230.         MOV     DI,[ESI]                { fetch count of fields         }
  3231.         ADD     ESI,6
  3232. @@inner:
  3233.         MOV     CL,[ESI+6]              { compare string lengths        }
  3234.         CMP     CL,BL
  3235.         JE      @@cmpChar
  3236. @@cont:
  3237.         LEA     ESI,[ESI+ECX+7] { point ESI to next field       }
  3238.         DEC     EDI
  3239.         JNZ     @@inner
  3240. @@parent:
  3241.         MOV     EAX,[EAX].vtParent      { fetch parent VMT              }
  3242.         TEST    EAX,EAX
  3243.         JNE     @@outer
  3244.         POP     EDX                     { forget instance, return Nil   }
  3245.         JMP     @@exit
  3246.  
  3247. @@notEqual:
  3248.         MOV     BL,[EDX]                { restore BL to length of name  }
  3249.         MOV     CL,[ESI+6]              { ECX := length of field name   }
  3250.         JMP     @@cont
  3251.  
  3252. @@cmpChar:
  3253.         MOV     BL,[ESI+ECX+6]  { case insensitive string cmp   }
  3254.         XOR     BL,[EDX+ECX+0]  { starting with last char       }
  3255.         AND     BL,$DF
  3256.         JNE     @@notEqual
  3257.         DEC     ECX                     { ECX serves as counter         }
  3258.         JNZ     @@cmpChar
  3259.  
  3260.         { found it }
  3261.         MOV     EAX,[ESI]           { result is field offset plus ...   }
  3262.         POP     EDX
  3263.         ADD     EAX,EDX         { instance pointer              }
  3264.  
  3265. @@exit:
  3266.         POP     EDI
  3267.         POP     ESI
  3268.         POP     EBX
  3269. end;
  3270.  
  3271.  
  3272. const { copied from xx.h }
  3273.         cContinuable        = 0;
  3274.         cNonContinuable     = 1;
  3275.         cUnwinding          = 2;
  3276.         cUnwindingForExit   = 4;
  3277.         cUnwindInProgress   = cUnwinding or cUnwindingForExit;
  3278.         cDelphiException    = $0EEDFACE;
  3279.         cDelphiReRaise      = $0EEDFACF;
  3280.         cDelphiExcept       = $0EEDFAD0;
  3281.         cDelphiFinally      = $0EEDFAD1;
  3282.         cDelphiTerminate    = $0EEDFAD2;
  3283.         cDelphiUnhandled    = $0EEDFAD3;
  3284.         cNonDelphiException = $0EEDFAD4;
  3285.         cDelphiExitFinally  = $0EEDFAD5;
  3286.  
  3287. type
  3288.         JmpInstruction =
  3289.         packed record
  3290.                 opCode:   Byte;
  3291.                 distance: Longint;
  3292.         end;
  3293.         TExcDescEntry =
  3294.         record
  3295.                 vTable:  Pointer;
  3296.                 handler: Pointer;
  3297.         end;
  3298.         PExcDesc = ^TExcDesc;
  3299.         TExcDesc =
  3300.         packed record
  3301.                 jmp: JmpInstruction;
  3302.                 case Integer of
  3303.                 0:      (instructions: array [0..0] of Byte);
  3304.                 1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry);
  3305.         end;
  3306.  
  3307.         PExcFrame = ^TExcFrame;
  3308.         TExcFrame =
  3309.         record
  3310.                 next: PExcFrame;
  3311.                 desc: PExcDesc;
  3312.                 hEBP: Pointer;
  3313.                 case { InConstructor: } Boolean of
  3314.                 True:  ( ConstructedObject: Pointer );
  3315.             False: ( );
  3316.         end;
  3317.  
  3318.         PExceptionRecord = ^TExceptionRecord;
  3319.         TExceptionRecord =
  3320.         record
  3321.                 ExceptionCode        : Longint;
  3322.                 ExceptionFlags       : Longint;
  3323.                 OuterException       : PExceptionRecord;
  3324.                 ExceptionAddress     : Pointer;
  3325.                 NumberParameters     : Longint;
  3326.                 case {IsOsException:} Boolean of
  3327.                 True:  (ExceptionInformation : array [0..14] of Longint);
  3328.                 False: (ExceptAddr: Pointer; ExceptObject: Pointer);
  3329.         end;
  3330.  
  3331.         PRaiseFrame = ^TRaiseFrame;
  3332.         TRaiseFrame = record
  3333.                 NextRaise: PRaiseFrame;
  3334.                 ExceptAddr: Pointer;
  3335.                 ExceptObject: TObject;
  3336.                 ExceptionRecord: PExceptionRecord;
  3337.         end;
  3338.  
  3339.  
  3340. procedure       _ClassCreate;
  3341. asm
  3342.         { ->    EAX = pointer to VMT      }
  3343.         { <-    EAX = pointer to instance }
  3344.         PUSH    EDX
  3345.         PUSH    ECX
  3346.         PUSH    EBX
  3347.         CALL    dword ptr [EAX].vtNewInstance
  3348.         XOR     EDX,EDX
  3349.         LEA     ECX,[ESP+16]
  3350.         MOV     EBX,FS:[EDX]
  3351.         MOV     [ECX].TExcFrame.next,EBX
  3352.         MOV     [ECX].TExcFrame.hEBP,EBP
  3353.         MOV     [ECX].TExcFrame.desc,offset @desc
  3354.         MOV     [ECX].TexcFrame.ConstructedObject,EAX   { trick: remember copy to instance }
  3355.         MOV     FS:[EDX],ECX
  3356.         POP     EBX
  3357.         POP     ECX
  3358.         POP     EDX
  3359.         RET
  3360.  
  3361. @desc:
  3362.         JMP     _HandleAnyException
  3363.  
  3364.         {       destroy the object                                                      }
  3365.  
  3366.         MOV     EAX,[ESP+8+9*4]
  3367.         MOV     EAX,[EAX].TExcFrame.ConstructedObject
  3368.         CALL    TObject.Free
  3369.  
  3370.         {       reraise the exception   }
  3371.         CALL    _RaiseAgain
  3372. end;
  3373.  
  3374.  
  3375. procedure       _ClassDestroy;
  3376. asm
  3377.         MOV     EDX,[EAX]
  3378.         CALL    dword ptr [EDX].vtFreeInstance
  3379. end;
  3380.  
  3381.  
  3382. {
  3383.   The following NotifyXXXX routines are used to "raise" special exceptions
  3384.   as a signaling mechanism to an interested debugger.  If the debugger sets
  3385.   the DebugHook flag to 1 or 2, then all exception processing is tracked by
  3386.   raising these special exceptions.  The debugger *MUST* respond to the
  3387.   debug event with DBG_CONTINE so that normal processing will occur.
  3388. }
  3389.  
  3390. { tell the debugger that the next raise is a re-raise of the current non-Delphi
  3391.   exception }
  3392. procedure       NotifyReRaise;
  3393. asm
  3394.         CMP     BYTE PTR DebugHook,1
  3395.         JBE     @@1
  3396.         PUSH    0
  3397.         PUSH    0
  3398.         PUSH    cContinuable
  3399.         PUSH    cDelphiReRaise
  3400.         CALL    RaiseException
  3401. @@1:
  3402. end;
  3403.  
  3404. { tell the debugger about the raise of a non-Delphi exception }
  3405. procedure       NotifyNonDelphiException;
  3406. asm
  3407.         CMP     BYTE PTR DebugHook,0
  3408.         JE      @@1
  3409.         PUSH    EAX
  3410.         PUSH    EAX
  3411.         PUSH    EDX
  3412.         PUSH    ESP
  3413.         PUSH    2
  3414.         PUSH    cContinuable
  3415.         PUSH    cNonDelphiException
  3416.         CALL    RaiseException
  3417.         ADD     ESP,8
  3418.         POP     EAX
  3419. @@1:
  3420. end;
  3421.  
  3422. { Tell the debugger where the handler for the current exception is located }
  3423. procedure       NotifyExcept;
  3424. asm
  3425.         PUSH    ESP
  3426.         PUSH    1
  3427.         PUSH    cContinuable
  3428.         PUSH    cDelphiExcept           { our magic exception code }
  3429.         CALL    RaiseException
  3430.         ADD     ESP,4
  3431.         POP     EAX
  3432. end;
  3433.  
  3434. procedure       NotifyOnExcept;
  3435. asm
  3436.         CMP     BYTE PTR DebugHook,1
  3437.         JBE     @@1
  3438.         PUSH    EAX
  3439.         PUSH    [EBX].TExcDescEntry.handler
  3440.         JMP     NotifyExcept
  3441. @@1:
  3442. end;
  3443.  
  3444. procedure       NotifyAnyExcept;
  3445. asm
  3446.         CMP     BYTE PTR DebugHook,1
  3447.         JBE     @@1
  3448.         PUSH    EAX
  3449.         PUSH    EBX
  3450.         JMP     NotifyExcept
  3451. @@1:
  3452. end;
  3453.  
  3454. procedure       CheckJmp;
  3455. asm
  3456.         TEST    ECX,ECX
  3457.         JE      @@3
  3458.         MOV     EAX,[ECX + 1]
  3459.         CMP     BYTE PTR [ECX],0E9H { near jmp }
  3460.         JE      @@1
  3461.         CMP     BYTE PTR [ECX],0EBH { short jmp }
  3462.         JNE     @@3
  3463.         MOVSX   EAX,AL
  3464.         INC     ECX
  3465.         INC     ECX
  3466.         JMP     @@2
  3467. @@1:
  3468.         ADD     ECX,5
  3469. @@2:
  3470.         ADD     ECX,EAX
  3471. @@3:
  3472. end;
  3473.  
  3474. { Notify debugger of a finally during an exception unwind }
  3475. procedure       NotifyExceptFinally;
  3476. asm
  3477.         CMP     BYTE PTR DebugHook,1
  3478.         JBE     @@1
  3479.         PUSH    EAX
  3480.         PUSH    EDX
  3481.         PUSH    ECX
  3482.         CALL    CheckJmp
  3483.         PUSH    ECX
  3484.         PUSH    ESP                     { pass pointer to arguments }
  3485.         PUSH    1                       { there is 1 argument }
  3486.         PUSH    cContinuable            { continuable execution }
  3487.         PUSH    cDelphiFinally          { our magic exception code }
  3488.         CALL    RaiseException
  3489.         POP     ECX
  3490.         POP     ECX
  3491.         POP     EDX
  3492.         POP     EAX
  3493. @@1:
  3494. end;
  3495.  
  3496.  
  3497. { Tell the debugger that the current exception is handled and cleaned up.
  3498.   Also indicate where execution is about to resume. }
  3499. procedure       NotifyTerminate;
  3500. asm
  3501.         CMP     BYTE PTR DebugHook,1
  3502.         JBE     @@1
  3503.         PUSH    EDX
  3504.         PUSH    ESP
  3505.         PUSH    1
  3506.         PUSH    cContinuable
  3507.         PUSH    cDelphiTerminate        { our magic exception code }
  3508.         CALL    RaiseException
  3509.         POP     EDX
  3510. @@1:
  3511. end;
  3512.  
  3513. { Tell the debugger that there was no handler found for the current execption
  3514.   and we are about to go to the default handler }
  3515. procedure       NotifyUnhandled;
  3516. asm
  3517.         CMP     BYTE PTR DebugHook,1
  3518.         JBE     @@1
  3519.         PUSH    EAX
  3520.         PUSH    EDX
  3521.         PUSH    ESP
  3522.         PUSH    2
  3523.         PUSH    cContinuable
  3524.         PUSH    cDelphiUnhandled
  3525.         CALL    RaiseException
  3526.         POP     EDX
  3527.         POP     EAX
  3528. @@1:
  3529. end;
  3530.  
  3531. procedure       _HandleAnyException;
  3532. asm
  3533.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3534.         {       [ESP+ 8] errPtr: PExcFrame              }
  3535.         {       [ESP+12] ctxPtr: Pointer                }
  3536.         {       [ESP+16] dspPtr: Pointer                }
  3537.         { <-    EAX return value - always one   }
  3538.  
  3539.         MOV     EAX,[ESP+4]
  3540.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  3541.         JNE     @@exit
  3542.  
  3543.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  3544.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  3545.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  3546.         JE      @@DelphiException
  3547.         CALL    _FpuInit
  3548.         MOV     EDX,ExceptObjProc
  3549.         TEST    EDX,EDX
  3550.         JE      @@exit
  3551.         CALL    EDX
  3552.         TEST    EAX,EAX
  3553.         JE      @@exit
  3554.         MOV     EDX,[ESP+12]
  3555.         CALL    NotifyNonDelphiException
  3556.         MOV     EDX,EAX
  3557.         MOV     EAX,[ESP+4]
  3558.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  3559.  
  3560. @@DelphiException:
  3561.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  3562.  
  3563.         PUSH    EBX
  3564.         XOR     EBX,EBX
  3565.         PUSH    ESI
  3566.         PUSH    EDI
  3567.         PUSH    EBP
  3568.  
  3569.         MOV     EBX,FS:[EBX]
  3570.         PUSH    EBX                     { Save pointer to topmost frame }
  3571.         PUSH    EAX                     { Save OS exception pointer     }
  3572.         PUSH    EDX                     { Save exception object         }
  3573.         PUSH    ECX                     { Save exception address        }
  3574.  
  3575.         MOV     EDX,[ESP+8+8*4]
  3576.  
  3577.         PUSH    0
  3578.         PUSH    EAX
  3579.         PUSH    offset @@returnAddress
  3580.         PUSH    EDX
  3581.         CALL    RtlUnwind
  3582. @@returnAddress:
  3583.  
  3584.         MOV     EDI,[ESP+8+8*4]
  3585.  
  3586.         {       Make the RaiseList entry on the stack }
  3587.  
  3588.         CALL    _GetTLS
  3589.         PUSH    [EAX].RaiseList
  3590.         MOV     [EAX].RaiseList,ESP
  3591.  
  3592.         MOV     EBP,[EDI].TExcFrame.hEBP
  3593.         MOV     EBX,[EDI].TExcFrame.desc
  3594.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  3595.  
  3596.         ADD     EBX,TExcDesc.instructions
  3597.         CALL    NotifyAnyExcept
  3598.         JMP     EBX
  3599.  
  3600. @@exceptFinally:
  3601.         JMP     _HandleFinally
  3602.  
  3603. @@destroyExcept:
  3604.         {       we come here if an exception handler has thrown yet another exception }
  3605.         {       we need to destroy the exception object and pop the raise list. }
  3606.  
  3607.         CALL    _GetTLS
  3608.         MOV     ECX,[EAX].RaiseList
  3609.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  3610.         MOV     [EAX].RaiseList,EDX
  3611.  
  3612.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  3613.         JMP     TObject.Free
  3614.  
  3615. @@exit:
  3616.         MOV     EAX,1
  3617. end;
  3618.  
  3619.  
  3620. procedure       _HandleOnException;
  3621. asm
  3622.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3623.         {       [ESP+ 8] errPtr: PExcFrame              }
  3624.         {       [ESP+12] ctxPtr: Pointer                }
  3625.         {       [ESP+16] dspPtr: Pointer                }
  3626.         { <-    EAX return value - always one   }
  3627.  
  3628.         MOV     EAX,[ESP+4]
  3629.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  3630.         JNE     @@exit
  3631.  
  3632.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  3633.         JE      @@DelphiException
  3634.         CALL    _FpuInit
  3635.         MOV     EDX,ExceptClsProc
  3636.         TEST    EDX,EDX
  3637.         JE      @@exit
  3638.         CALL    EDX
  3639.         TEST    EAX,EAX
  3640.         JNE     @@common
  3641.         JMP     @@exit
  3642.  
  3643. @@DelphiException:
  3644.         MOV     EAX,[EAX].TExceptionRecord.ExceptObject
  3645.         MOV     EAX,[EAX].clVTable              { load vtable of exception object       }
  3646.  
  3647. @@common:
  3648.  
  3649.         MOV     EDX,[ESP+8]
  3650.  
  3651.         PUSH    EBX
  3652.         PUSH    ESI
  3653.         PUSH    EDI
  3654.         PUSH    EBP
  3655.  
  3656.         MOV     ECX,[EDX].TExcFrame.desc
  3657.         MOV     EBX,[ECX].TExcDesc.cnt
  3658.         LEA     ESI,[ECX].TExcDesc.excTab       { point ECX to exc descriptor table }
  3659.         MOV     EBP,EAX                         { load vtable of exception object }
  3660.  
  3661. @@innerLoop:
  3662.         MOV     EAX,[ESI].TExcDescEntry.vTable
  3663.         TEST    EAX,EAX                         { catch all clause?                     }
  3664.         JE      @@doHandler                     { yes: go execute handler               }
  3665.         MOV     EDI,EBP                         { load vtable of exception object       }
  3666.  
  3667. @@vtLoop:
  3668.         CMP     EAX,EDI
  3669.         JE      @@doHandler
  3670.  
  3671.         MOV     ECX,[EAX].vtInstanceSize
  3672.         CMP     ECX,[EDI].vtInstanceSize
  3673.         JNE     @@parent
  3674.  
  3675.         MOV     EAX,[EAX].vtClassName
  3676.         MOV     EDX,[EDI].vtClassName
  3677.  
  3678.         XOR     ECX,ECX
  3679.         MOV     CL,[EAX]
  3680.         CMP     CL,[EDX]
  3681.         JNE     @@parent
  3682.  
  3683.         INC     EAX
  3684.         INC     EDX
  3685.         CALL    _AStrCmp
  3686.         JE      @@doHandler
  3687.  
  3688. @@parent:
  3689.         MOV     EDI,[EDI].vtParent              { load vtable of parent         }
  3690.         MOV     EAX,[ESI].TExcDescEntry.vTable
  3691.         TEST    EDI,EDI
  3692.         JNE     @@vtLoop
  3693.  
  3694.         ADD     ESI,8
  3695.         DEC     EBX
  3696.         JNZ     @@innerLoop
  3697.  
  3698.         POP     EBP
  3699.         POP     EDI
  3700.         POP     ESI
  3701.         POP     EBX
  3702.         JMP     @@exit
  3703.  
  3704. @@doHandler:
  3705.         MOV     EAX,[ESP+4+4*4]
  3706.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  3707.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  3708.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  3709.         JE      @@haveObject
  3710.         CALL    ExceptObjProc
  3711.         MOV     EDX,[ESP+12+4*4]
  3712.         CALL    NotifyNonDelphiException
  3713.         MOV     EDX,EAX
  3714.         MOV     EAX,[ESP+4+4*4]
  3715.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  3716.  
  3717. @@haveObject:
  3718.         XOR     EBX,EBX
  3719.         MOV     EBX,FS:[EBX]
  3720.         PUSH    EBX                     { Save topmost frame     }
  3721.         PUSH    EAX                     { Save exception record  }
  3722.         PUSH    EDX                     { Save exception object  }
  3723.         PUSH    ECX                     { Save exception address }
  3724.  
  3725.         MOV     EDX,[ESP+8+8*4]
  3726.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  3727.  
  3728.         PUSH    ESI                     { Save handler entry     }
  3729.  
  3730.         PUSH    0
  3731.         PUSH    EAX
  3732.         PUSH    offset @@returnAddress
  3733.         PUSH    EDX
  3734.         CALL    RtlUnwind
  3735. @@returnAddress:
  3736.  
  3737.         POP     EBX                     { Restore handler entry  }
  3738.  
  3739.         MOV     EDI,[ESP+8+8*4]
  3740.  
  3741.         {       Make the RaiseList entry on the stack }
  3742.  
  3743.         CALL    _GetTLS
  3744.         PUSH    [EAX].RaiseList
  3745.         MOV     [EAX].RaiseList,ESP
  3746.  
  3747.         MOV     EBP,[EDI].TExcFrame.hEBP
  3748.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  3749.         MOV     EAX,[ESP].TRaiseFrame.ExceptObject
  3750.         CALL    NotifyOnExcept
  3751.         JMP     [EBX].TExcDescEntry.handler
  3752.  
  3753. @@exceptFinally:
  3754.         JMP     _HandleFinally
  3755. @@destroyExcept:
  3756.         {       we come here if an exception handler has thrown yet another exception }
  3757.         {       we need to destroy the exception object and pop the raise list. }
  3758.  
  3759.         CALL    _GetTLS
  3760.         MOV     ECX,[EAX].RaiseList
  3761.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  3762.         MOV     [EAX].RaiseList,EDX
  3763.  
  3764.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  3765.         JMP     TObject.Free
  3766. @@exit:
  3767.         MOV     EAX,1
  3768. end;
  3769.  
  3770.  
  3771. procedure       _HandleFinally;
  3772. asm
  3773.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3774.         {       [ESP+ 8] errPtr: PExcFrame              }
  3775.         {       [ESP+12] ctxPtr: Pointer                }
  3776.         {       [ESP+16] dspPtr: Pointer                }
  3777.         { <-    EAX return value - always one   }
  3778.  
  3779.         MOV     EAX,[ESP+4]
  3780.         MOV     EDX,[ESP+8]
  3781.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  3782.         JE      @@exit
  3783.         MOV     ECX,[EDX].TExcFrame.desc
  3784.         MOV     [EDX].TExcFrame.desc,offset @@exit
  3785.  
  3786.         PUSH    EBX
  3787.         PUSH    ESI
  3788.         PUSH    EDI
  3789.         PUSH    EBP
  3790.  
  3791.         MOV     EBP,[EDX].TExcFrame.hEBP
  3792.         ADD     ECX,TExcDesc.instructions
  3793.         CALL    NotifyExceptFinally
  3794.         CALL    ECX
  3795.  
  3796.         POP     EBP
  3797.         POP     EDI
  3798.         POP     ESI
  3799.         POP     EBX
  3800.  
  3801. @@exit:
  3802.         MOV     EAX,1
  3803. end;
  3804.  
  3805.  
  3806. procedure       _SafeCall;
  3807. asm
  3808. { ->    EAX:    EAX argument            }
  3809. {       EDX:    EDX argument            }
  3810. {       ECX:    ECX argument            }
  3811. {       EBX:    Routine to call         }
  3812. {       ESI:    #stack argument dwords  }
  3813. {       EDI:    stack argument block    }
  3814. {       EBP:    Return address          }
  3815.  
  3816.         PUSH    EBP                     { push return address }
  3817.  
  3818.         XOR     EBP,EBP
  3819.         PUSH    offset @@exceptionHandler
  3820.         PUSH    dword ptr FS:[EBP]
  3821.         MOV     FS:[EBP],ESP
  3822.  
  3823.         TEST    ESI,ESI
  3824.         JE      @@noStackArgs
  3825.         JS      @@floatArg
  3826.  
  3827.         DEC     ESI
  3828. @@stackArgLoop:
  3829.         MOV     EBP,dword ptr [EDI+ESI*4]
  3830.         DEC     ESI
  3831.         PUSH    EBP
  3832.         JNS     @@stackArgLoop
  3833.         JMP     @@noStackArgs
  3834.  
  3835. @@floatArg:
  3836.         FLD     tbyte ptr [EDI]
  3837.  
  3838. @@noStackArgs:
  3839.  
  3840.         CALL    EBX
  3841.  
  3842.         XOR     EDX,EDX
  3843.         XOR     ECX,ECX
  3844.         JMP     @@exit
  3845.  
  3846. @@exceptionHandlerexit:
  3847.         MOV     EAX,1
  3848.         RET
  3849.  
  3850. @@exceptionHandler:
  3851.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3852.         {       [ESP+ 8] errPtr: PExcFrame              }
  3853.         { <-    EAX return value - always one   }
  3854.  
  3855.         CALL    _FpuInit
  3856.  
  3857.         MOV     EAX,[ESP+4]
  3858.         MOV     EDX,[ESP+8]
  3859.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  3860.         JNE     @@exceptionHandlerexit
  3861.  
  3862.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  3863.  
  3864.         PUSH    0
  3865.         PUSH    EAX
  3866.         PUSH    offset @@returnAddress
  3867.         PUSH    EDX
  3868.         CALL    RtlUnwind
  3869. @@returnAddress:
  3870.         MOV     EAX,[ESP+4]
  3871.         MOV     ECX,[EAX].TExceptionRecord.ExceptionCode
  3872.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  3873.         CMP     ECX,cDelphiException
  3874.         JNE     @@nonDelphiException
  3875.         MOV     EAX,[EAX].TExceptionRecord.ExceptAddr
  3876.         JMP     @@exit
  3877. @@nonDelphiException:
  3878.         MOV     EAX,[EAX].TExceptionRecord.ExceptionAddress
  3879. @@exit:
  3880.         XOR     EBP,EBP
  3881.         MOV     ESP,FS:[EBP]
  3882.         POP     dword ptr FS:[EBP]
  3883.         POP     EBP
  3884. end;
  3885.  
  3886.  
  3887. procedure       _RaiseExcept;
  3888. asm
  3889.         { ->    EAX     Pointer to exception object     }
  3890.         {       [ESP]   Error address           }
  3891.  
  3892.         POP     EDX
  3893.  
  3894.         PUSH    ESP
  3895.         PUSH    EBP
  3896.         PUSH    EDI
  3897.         PUSH    ESI
  3898.         PUSH    EBX
  3899.         PUSH    EAX                             { pass class argument           }
  3900.         PUSH    EDX                             { pass address argument         }
  3901.  
  3902.         PUSH    ESP                             { pass pointer to arguments             }
  3903.         PUSH    7                               { there are seven arguments               }
  3904.         PUSH    cNonContinuable                 { we can't continue execution   }
  3905.         PUSH    cDelphiException                { our magic exception code              }
  3906.         PUSH    EDX                             { pass the user's return address        }
  3907.         JMP     RaiseException
  3908. end;
  3909.  
  3910.  
  3911. procedure       _RaiseAgain;
  3912. asm
  3913.         { ->    [ESP        ] return address to user program }
  3914.         {       [ESP+ 4     ] raise list entry (4 dwords)    }
  3915.         {       [ESP+ 4+ 4*4] saved topmost frame            }
  3916.         {       [ESP+ 4+ 5*4] saved registers (4 dwords)     }
  3917.         {       [ESP+ 4+ 9*4] return address to OS           }
  3918.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  3919.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  3920.  
  3921.         { Point the error handler of the exception frame to something harmless }
  3922.  
  3923.         MOV     EAX,[ESP+8+10*4]
  3924.         MOV     [EAX].TExcFrame.desc,offset @@exit
  3925.  
  3926.         { Pop the RaiseList }
  3927.  
  3928.         CALL    _GetTLS
  3929.         MOV     EDX,[EAX].RaiseList
  3930.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  3931.         MOV     [EAX].RaiseList,ECX
  3932.  
  3933.         { Destroy any objects created for non-delphi exceptions }
  3934.  
  3935.         MOV     EAX,[EDX].TRaiseFrame.ExceptionRecord
  3936.         AND     [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
  3937.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  3938.         JE      @@delphiException
  3939.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  3940.         CALL    TObject.Free
  3941.         CALL    NotifyReRaise
  3942.  
  3943. @@delphiException:
  3944.  
  3945.         XOR     EAX,EAX
  3946.         ADD     ESP,5*4
  3947.         MOV     EDX,FS:[EAX]
  3948.         POP     ECX
  3949.         MOV     EDX,[EDX].TExcFrame.next
  3950.         MOV     [ECX].TExcFrame.next,EDX
  3951.  
  3952.         POP     EBP
  3953.         POP     EDI
  3954.         POP     ESI
  3955.         POP     EBX
  3956. @@exit:
  3957.         MOV     EAX,1
  3958. end;
  3959.  
  3960.  
  3961. procedure       _DoneExcept;
  3962. asm
  3963.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  3964.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  3965.  
  3966.         { Pop the RaiseList }
  3967.  
  3968.         CALL    _GetTLS
  3969.         MOV     EDX,[EAX].RaiseList
  3970.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  3971.         MOV     [EAX].RaiseList,ECX
  3972.  
  3973.         { Destroy exception object }
  3974.  
  3975.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  3976.         CALL    TObject.Free
  3977.  
  3978.         POP     EDX
  3979.         MOV     ESP,[ESP+8+9*4]
  3980.         XOR     EAX,EAX
  3981.         POP     ECX
  3982.         MOV     FS:[EAX],ECX
  3983.         POP     EAX
  3984.         POP     EBP
  3985.         CALL    NotifyTerminate
  3986.         JMP     EDX
  3987. end;
  3988.  
  3989.  
  3990. procedure   _TryFinallyExit;
  3991. asm
  3992.         XOR     EDX,EDX
  3993.         MOV     ECX,[ESP+4].TExcFrame.desc
  3994.         MOV     EAX,[ESP+4].TExcFrame.next
  3995.         ADD     ECX,TExcDesc.instructions
  3996.         MOV     FS:[EDX],EAX
  3997.         CALL    ECX
  3998. @@1:    RET     12
  3999. end;
  4000.  
  4001. VAR
  4002.         excFrame: PExcFrame;
  4003.  
  4004.  
  4005. procedure       RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
  4006. asm
  4007.         MOV     [ESP],ErrorAddr
  4008.         JMP     _RunError
  4009. end;
  4010.  
  4011. procedure       MapToRunError(P: PExceptionRecord); stdcall;
  4012. const
  4013.   STATUS_ACCESS_VIOLATION         = $C0000005;
  4014.   STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
  4015.   STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
  4016.   STATUS_FLOAT_DIVIDE_BY_ZERO     = $C000008E;
  4017.   STATUS_FLOAT_INEXACT_RESULT     = $C000008F;
  4018.   STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
  4019.   STATUS_FLOAT_OVERFLOW           = $C0000091;
  4020.   STATUS_FLOAT_STACK_CHECK        = $C0000092;
  4021.   STATUS_FLOAT_UNDERFLOW          = $C0000093;
  4022.   STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
  4023.   STATUS_INTEGER_OVERFLOW         = $C0000095;
  4024.   STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
  4025.   STATUS_STACK_OVERFLOW           = $C00000FD;
  4026.   STATUS_CONTROL_C_EXIT           = $C000013A;
  4027. var
  4028.   ErrCode: Byte;
  4029. begin
  4030.   case P.ExceptionCode of
  4031.     STATUS_INTEGER_DIVIDE_BY_ZERO:  ErrCode := 200;
  4032.     STATUS_ARRAY_BOUNDS_EXCEEDED:   ErrCode := 201;
  4033.     STATUS_FLOAT_OVERFLOW:          ErrCode := 205;
  4034.     STATUS_FLOAT_INEXACT_RESULT,
  4035.     STATUS_FLOAT_INVALID_OPERATION,
  4036.     STATUS_FLOAT_STACK_CHECK:       ErrCode := 207;
  4037.     STATUS_FLOAT_DIVIDE_BY_ZERO:    ErrCode := 200;
  4038.     STATUS_INTEGER_OVERFLOW:        ErrCode := 215;
  4039.     STATUS_FLOAT_UNDERFLOW,
  4040.     STATUS_FLOAT_DENORMAL_OPERAND:  ErrCode := 206;
  4041.     STATUS_ACCESS_VIOLATION:        ErrCode := 216;
  4042.     STATUS_PRIVILEGED_INSTRUCTION:  ErrCode := 218;
  4043.     STATUS_CONTROL_C_EXIT:          ErrCode := 217;
  4044.     STATUS_STACK_OVERFLOW:          ErrCode := 202;
  4045.   else                              ErrCode := 217;
  4046.   end;
  4047.   RunErrorAt(ErrCode, P.ExceptionAddress);
  4048. end;
  4049.  
  4050. procedure       _ExceptionHandler;
  4051. asm
  4052.         MOV     EAX,[ESP+4]
  4053.  
  4054.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4055.         JNE     @@exit
  4056.         CALL    _FpuInit
  4057.         MOV     EDX,[ESP+8]
  4058.  
  4059.         PUSH    0
  4060.         PUSH    EAX
  4061.         PUSH    offset @@returnAddress
  4062.         PUSH    EDX
  4063.         CALL    RtlUnwind
  4064. @@returnAddress:
  4065.  
  4066.         MOV     EBX,[ESP+4]
  4067.         CMP     [EBX].TExceptionRecord.ExceptionCode,cDelphiException
  4068.         MOV     EDX,[EBX].TExceptionRecord.ExceptAddr
  4069.         MOV     EAX,[EBX].TExceptionRecord.ExceptObject
  4070.         JE      @@DelphiException2
  4071.  
  4072.         MOV     EDX,ExceptObjProc
  4073.         TEST    EDX,EDX
  4074.         JE      MapToRunError
  4075.         MOV     EAX,EBX
  4076.         CALL    EDX
  4077.         TEST    EAX,EAX
  4078.         JE      MapToRunError
  4079.         MOV     EDX,[EBX].TExceptionRecord.ExceptionAddress
  4080.  
  4081. @@DelphiException2:
  4082.  
  4083.         CALL    NotifyUnhandled
  4084.         MOV     ECX,ExceptProc
  4085.         TEST    ECX,ECX
  4086.         JE      @@noExceptProc
  4087.         CALL    ECX             { call ExceptProc(ExceptObject, ExceptAddr) }
  4088.  
  4089. @@noExceptProc:
  4090.         MOV     ECX,[ESP+4]
  4091.         MOV     EAX,217
  4092.         MOV     EDX,[ECX].TExceptionRecord.ExceptAddr
  4093.         MOV     [ESP],EDX
  4094.         JMP     _RunError
  4095.  
  4096. @@exit:
  4097.         XOR     EAX,EAX
  4098. end;
  4099.  
  4100.  
  4101. procedure       SetExceptionHandler;
  4102. asm
  4103.         XOR     EDX,EDX                 { using [EDX] saves some space over [0] }
  4104.         LEA     EAX,[EBP-12]
  4105.         MOV     ECX,FS:[EDX]            { ECX := head of chain                  }
  4106.         MOV     FS:[EDX],EAX            { head of chain := @exRegRec            }
  4107.  
  4108.         MOV     [EAX].TExcFrame.next,ECX
  4109.         MOV     [EAX].TExcFrame.desc,offset _ExceptionHandler
  4110.         MOV     [EAX].TExcFrame.hEBP,EBP
  4111.         MOV     excFrame,EAX
  4112. end;
  4113.  
  4114.  
  4115. procedure       UnsetExceptionHandler;
  4116. asm
  4117.         XOR     EDX,EDX
  4118.         MOV     EAX,excFrame
  4119.         MOV     ECX,FS:[EDX]    { ECX := head of chain          }
  4120.         CMP     EAX,ECX         { simple case: our record is first      }
  4121.         JNE     @@search
  4122.         MOV     EAX,[EAX]       { head of chain := exRegRec.next        }
  4123.         MOV     FS:[EDX],EAX
  4124.         JMP     @@exit
  4125.  
  4126. @@loop:
  4127.         MOV     ECX,[ECX]
  4128. @@search:
  4129.         CMP     ECX,-1          { at end of list?                       }
  4130.         JE      @@exit          { yes - didn't find it          }
  4131.         CMP     [ECX],EAX       { is it the next one on the list?       }
  4132.         JNE     @@loop          { no - look at next one on list }
  4133. @@unlink:                       { yes - unlink our record               }
  4134.         MOV     EAX,[EAX]       { get next record on list               }
  4135.         MOV     [ECX],EAX       { unlink our record                     }
  4136. @@exit:
  4137. end;
  4138.  
  4139.  
  4140. procedure       _InitExe;
  4141. asm
  4142.         CALL    SetExceptionHandler
  4143.  
  4144.         PUSH    0
  4145.         CALL    GetModuleHandle
  4146.         MOV     HInstance,EAX
  4147.  
  4148.         CALL    GetCommandLine
  4149.         MOV     CmdLine,EAX
  4150.  
  4151.         MOV     CmdShow,10      { SW_SHOWDEFAULT }
  4152.  
  4153.         MOV     EAX,offset _SafeCall    { make sure an .exe will contain _SafeCall }
  4154. end;
  4155.  
  4156.  
  4157. var
  4158.   tlsBuffer: Pointer;
  4159.  
  4160. procedure       InitThreadTLS;
  4161. var
  4162.   p: Pointer;
  4163. begin
  4164.   if TlsIndex < 0 then
  4165.     RunError(226);
  4166.   p := LocalAlloc(LMEM_ZEROINIT, Longint(@TlsLast));
  4167.   if p = nil then
  4168.     RunError(226)
  4169.   else
  4170.     TlsSetValue(TlsIndex, p);
  4171.   tlsBuffer := p;
  4172. end;
  4173.  
  4174.  
  4175. procedure _GetTls;
  4176. asm
  4177.         MOV     CL,IsLibrary
  4178.         MOV     EAX,TlsIndex
  4179.         TEST    CL,CL
  4180.         JNE     @@isDll
  4181.         MOV     EDX,FS:tlsArray
  4182.         MOV     EAX,[EDX+EAX*4]
  4183.         RET
  4184.  
  4185. @@initTls:
  4186.         CALL    InitThreadTLS
  4187.         MOV     EAX,TlsIndex
  4188.         PUSH    EAX
  4189.         CALL    TlsGetValue
  4190.         TEST    EAX,EAX
  4191.         JE      @@RTM32
  4192.         RET
  4193.  
  4194. @@RTM32:
  4195.         MOV     EAX, tlsBuffer
  4196.         RET
  4197.  
  4198. @@isDll:
  4199.         PUSH    EAX
  4200.         CALL    TlsGetValue
  4201.         TEST    EAX,EAX
  4202.         JE      @@initTls
  4203. end;
  4204.  
  4205.  
  4206. procedure       InitProcessTLS;
  4207. var
  4208.   i: Integer;
  4209. begin
  4210.   i := TlsAlloc;
  4211.   TlsIndex := i;
  4212.   if i < 0 then
  4213.     RunError(226);
  4214.   InitThreadTLS;
  4215. end;
  4216.  
  4217.  
  4218. procedure       ExitThreadTLS;
  4219. var
  4220.   p: Pointer;
  4221. begin
  4222.   if TlsIndex >= 0 then begin
  4223.     p := TlsGetValue(TlsIndex);
  4224.     if p <> nil then
  4225.       LocalFree(p);
  4226.   end;
  4227. end;
  4228.  
  4229.  
  4230. procedure       ExitProcessTLS;
  4231. begin
  4232.   ExitThreadTLS;
  4233.   if TlsIndex >= 0 then
  4234.     TlsFree(TlsIndex);
  4235. end;
  4236.  
  4237.  
  4238. procedure       _InitDll;
  4239. const
  4240.   tlsProc: array [0..3] of procedure =
  4241.     (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS);
  4242. asm
  4243.         CALL    SetExceptionHandler
  4244.  
  4245.         MOV     DLLSaveEBP,EBP
  4246.         MOV     DLLSaveEBX,EBX
  4247.         MOV     DLLSaveESI,ESI
  4248.         MOV     DLLSaveEDI,EDI
  4249.  
  4250.         MOV     IsLibrary,1
  4251.         MOV     EAX,[EBP+8]
  4252.         MOV     HInstance,EAX
  4253.         MOV     EAX,[EBP+12]
  4254.         INC     EAX
  4255.         MOV     DLLInitState,AL
  4256.         DEC     EAX
  4257.         MOV     EDX,offset TlsLast
  4258.         TEST    EDX,EDX
  4259.         JE      @@noTls
  4260.         PUSH    EAX
  4261.         CALL    dword ptr tlsProc[EAX*4]
  4262.         POP     EAX
  4263. @@noTls:
  4264.         MOV     EDX,DllProc
  4265.         TEST    EDX,EDX
  4266.         JE      @@noDllProc
  4267.         CALL    EDX
  4268. @@noDllProc:
  4269.         MOV     AL,DLLInitState
  4270.         CMP     AL,2                    { if AL != 2, initialization of DLL will }
  4271.                                 { immediately call _Halt0                }
  4272. end;
  4273.  
  4274.  
  4275. type
  4276.   PThreadRec = ^TThreadRec;
  4277.   TThreadRec = record
  4278.     Func: TThreadFunc;
  4279.     Parameter: Pointer;
  4280.   end;
  4281.  
  4282.  
  4283. function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
  4284. asm
  4285.         CALL    _FpuInit
  4286.         XOR     ECX,ECX
  4287.         PUSH    EBP
  4288.         PUSH    offset _ExceptionHandler
  4289.         MOV     EDX,FS:[ECX]
  4290.         PUSH    EDX
  4291.         MOV     EAX,Parameter
  4292.         MOV     FS:[ECX],ESP
  4293.  
  4294.         MOV     ECX,[EAX].TThreadRec.Parameter
  4295.         MOV     EDX,[EAX].TThreadRec.Func
  4296.         PUSH    ECX
  4297.         PUSH    EDX
  4298.         CALL    _FreeMem
  4299.         POP     EDX
  4300.         POP     EAX
  4301.         CALL    EDX
  4302.  
  4303.         XOR     EDX,EDX
  4304.         POP     ECX
  4305.         MOV     FS:[EDX],ECX
  4306.         POP     ECX
  4307.         POP     EBP
  4308. end;
  4309.  
  4310.  
  4311. function BeginThread(SecurityAttributes: Pointer; StackSize: Integer;
  4312.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  4313.                      CreationFlags: Integer; var ThreadId: Integer): Integer;
  4314. var
  4315.   P: PThreadRec;
  4316. begin
  4317.   New(P);
  4318.   P.Func := ThreadFunc;
  4319.   P.Parameter := Parameter;
  4320.   IsMultiThread := TRUE;
  4321.   result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
  4322.                          CreationFlags, ThreadID);
  4323. end;
  4324.  
  4325.  
  4326. procedure EndThread(ExitCode: Integer);
  4327. begin
  4328.   ExitThread(ExitCode);
  4329. end;
  4330.  
  4331.  
  4332. type
  4333.         StrRec = record
  4334.         allocSiz:       Longint;
  4335.         refCnt: Longint;
  4336.         length: Longint;
  4337.         end;
  4338.  
  4339. const
  4340.         skew = sizeof(StrRec);
  4341.         rOff = sizeof(StrRec) - sizeof(Longint);
  4342.         overHead = sizeof(StrRec) + 1;
  4343.  
  4344. procedure       _LStrClr{var str: AnsiString};
  4345. asm
  4346.         { ->    EAX pointer to str      }
  4347.  
  4348.         MOV     EDX,[EAX]                       { fetch str                     }
  4349.         TEST    EDX,EDX                         { if nil, nothing to do         }
  4350.         JE      @@done
  4351.         MOV     dword ptr [EAX],0               { clear str                     }
  4352.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  4353.         DEC     ECX                             { if < 0: literal str           }
  4354.         JL      @@done
  4355.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  4356.         JNE     @@done
  4357.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  4358.         CALL    _FreeMem
  4359. @@done:
  4360. end;
  4361.  
  4362.  
  4363. procedure       _LStrArrayClr{var str: AnsiString; cnt: longint};
  4364. asm
  4365.         { ->    EAX pointer to str      }
  4366.         {       EDX cnt         }
  4367.  
  4368.         PUSH    EBX
  4369.         PUSH    ESI
  4370.         MOV     EBX,EAX
  4371.         MOV     ESI,EDX
  4372.  
  4373. @@loop:
  4374.         MOV     EDX,[EBX]                       { fetch str                     }
  4375.         TEST    EDX,EDX                         { if nil, nothing to do         }
  4376.         JE      @@doneEntry
  4377.         MOV     dword ptr [EBX],0               { clear str                     }
  4378.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  4379.         DEC     ECX                             { if < 0: literal str           }
  4380.         JL      @@doneEntry
  4381.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  4382.         JNE     @@doneEntry
  4383.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  4384.         CALL    _FreeMem
  4385. @@doneEntry:
  4386.         ADD     EBX,4
  4387.         DEC     ESI
  4388.         JNE     @@loop
  4389.  
  4390.         POP     ESI
  4391.         POP     EBX
  4392. end;
  4393.  
  4394. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  4395. asm
  4396.         TEST    EDX,EDX
  4397.         JE      @@2
  4398.         MOV     ECX,[EDX-skew].StrRec.refCnt
  4399.         INC     ECX
  4400.         JG      @@1
  4401.         PUSH    EAX
  4402.         PUSH    EDX
  4403.         MOV     EAX,[EDX-skew].StrRec.length
  4404.         CALL    _NewAnsiString
  4405.         MOV     EDX,EAX
  4406.         POP     EAX
  4407.         PUSH    EDX
  4408.         MOV     ECX,[EAX-skew].StrRec.length
  4409.         CALL    Move
  4410.         POP     EDX
  4411.         POP     EAX
  4412.         JMP     @@2
  4413. @@1:    MOV     [EDX-skew].StrRec.refCnt,ECX
  4414. @@2:    XCHG    EDX,[EAX]
  4415.         TEST    EDX,EDX
  4416.         JE      @@3
  4417.         MOV     ECX,[EDX-skew].StrRec.refCnt
  4418.         DEC     ECX
  4419.         JL      @@3
  4420.         MOV     [EDX-skew].StrRec.refCnt,ECX
  4421.         JNE     @@3
  4422.         LEA     EAX,[EDX-skew].StrRec.refCnt
  4423.         CALL    _FreeMem
  4424. @@3:
  4425. end;
  4426.  
  4427. procedure       _LStrLAsg{var dest: AnsiString; source: AnsiString};
  4428. asm
  4429. { ->    EAX     pointer to dest }
  4430. {       EDX     source          }
  4431.  
  4432.         TEST    EDX,EDX
  4433.         JE      @@sourceDone
  4434.  
  4435.         { bump up the ref count of the source }
  4436.  
  4437.         MOV     ECX,[EDX-skew].StrRec.refCnt
  4438.         INC     ECX
  4439.         JLE     @@sourceDone
  4440.         MOV     [EDX-skew].StrRec.refCnt,ECX
  4441. @@sourceDone:
  4442.  
  4443.         { we need to release whatever the dest is pointing to   }
  4444.  
  4445.         XCHG    EDX,[EAX]                       { fetch str                    }
  4446.         TEST    EDX,EDX                         { if nil, nothing to do        }
  4447.         JE      @@done
  4448.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                 }
  4449.         DEC     ECX                             { if < 0: literal str          }
  4450.         JL      @@done
  4451.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back          }
  4452.         JNE     @@done
  4453.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  4454.         CALL    _FreeMem
  4455. @@done:
  4456. end;
  4457.  
  4458. procedure       _NewAnsiString{length: Longint};
  4459. asm
  4460.         { ->    EAX     length                  }
  4461.         { <-    EAX pointer to new string       }
  4462.  
  4463.         TEST    EAX,EAX
  4464.         JLE     @@null
  4465.         PUSH    EAX
  4466.         ADD     EAX,rOff+1
  4467.         CALL    _GetMem
  4468.         ADD     EAX,rOff
  4469.         POP     EDX
  4470.         MOV     [EAX-skew].StrRec.length,EDX
  4471.         MOV     [EAX-skew].StrRec.refCnt,1
  4472.         MOV     byte ptr [EAX+EDX],0
  4473.         RET
  4474.  
  4475. @@null:
  4476.         XOR     EAX,EAX
  4477. end;
  4478.  
  4479.  
  4480. procedure       _LStrFromLenStr{var dest: AnsiString; source: Pointer; length: Longint};
  4481. asm
  4482.         { ->    EAX     pointer to dest }
  4483.         {       EDX source              }
  4484.         {       ECX length              }
  4485.  
  4486.         PUSH    EBX
  4487.         PUSH    ESI
  4488.         PUSH    EDI
  4489.  
  4490.         MOV     EBX,EAX
  4491.         MOV     ESI,EDX
  4492.         MOV     EDI,ECX
  4493.  
  4494.         { allocate new string }
  4495.  
  4496.         MOV     EAX,EDI
  4497.  
  4498.         CALL    _NewAnsiString
  4499.         MOV     ECX,EDI
  4500.         MOV     EDI,EAX
  4501.  
  4502.         TEST    ESI,ESI
  4503.         JE      @@noMove
  4504.  
  4505.         MOV     EDX,EAX
  4506.         MOV     EAX,ESI
  4507.         CALL    Move
  4508.  
  4509.         { assign the result to dest }
  4510.  
  4511. @@noMove:
  4512.         MOV     EAX,EBX
  4513.         CALL    _LStrClr
  4514.         MOV     [EBX],EDI
  4515.  
  4516.         POP     EDI
  4517.         POP     ESI
  4518.         POP     EBX
  4519. end;
  4520.  
  4521.  
  4522. procedure       _LStrFromChar{var dest: AnsiString; source: char};
  4523. asm
  4524.         { ->    EAX     pointer to dest }
  4525.         {       EDX source              }
  4526.         PUSH    EDX
  4527.         MOV     EDX,ESP
  4528.         MOV     ECX,1
  4529.         CALL    _LStrFromLenStr
  4530.         POP     EDX
  4531. end;
  4532.  
  4533.  
  4534. procedure       _LStrFromString{var dest: AnsiString; source: ShortString};
  4535. asm
  4536.         { ->    EAX     pointer to dest }
  4537.         {       EDX source              }
  4538.  
  4539.         XOR     ECX,ECX
  4540.         MOV     CL,[EDX]
  4541.         INC     EDX
  4542.         CALL    _LStrFromLenStr
  4543. end;
  4544.  
  4545.  
  4546. procedure       _LStrFromPChar{var dest: AnsiString; source: PChar};
  4547. asm
  4548.         { ->    EAX     pointer to dest }
  4549.         {       EDX     source          }
  4550.  
  4551.         XOR     ECX,ECX
  4552.         TEST    EDX,EDX
  4553.         JE      @@foundLength
  4554.         PUSH    EDX
  4555. @@loop:
  4556.         CMP     CL,[EDX+0]
  4557.         JE      @@end0
  4558.         CMP     CL,[EDX+1]
  4559.         JE      @@end1
  4560.         CMP     CL,[EDX+2]
  4561.         JE      @@end2
  4562.         CMP     CL,[EDX+3]
  4563.         JE      @@end3
  4564.         ADD     EDX,4
  4565.         JMP     @@loop
  4566. @@end3:
  4567.         INC     EDX
  4568. @@end2:
  4569.         INC     EDX
  4570. @@end1:
  4571.         INC     EDX
  4572. @@end0:
  4573.         MOV     ECX,EDX
  4574.         POP     EDX
  4575.         SUB     ECX,EDX
  4576.  
  4577. @@foundLength:
  4578.         JMP     _LStrFromLenStr
  4579. end;
  4580.  
  4581. procedure       _LStrFromArray{{var dest: AnsiString; source: Pointer; length: Longint};
  4582. asm
  4583.         { ->    EAX     pointer to dest }
  4584.         {       EDX     source          }
  4585.         {       ECX length              }
  4586.  
  4587.         PUSH    EDI
  4588.  
  4589.         PUSH    EAX
  4590.         PUSH    ECX
  4591.  
  4592.         MOV     EDI,EDX
  4593.         XOR     EAX,EAX
  4594.         REPNE   SCASB
  4595.         JNE     @@noTerminator
  4596.         NOT     ECX
  4597. @@noTerminator:
  4598.         POP     EAX
  4599.         ADD     ECX,EAX
  4600.         POP     EAX
  4601.  
  4602.         POP     EDI
  4603.  
  4604.         JMP     _LStrFromLenStr
  4605. end;
  4606.  
  4607. function        _LStrLen{str: AnsiString}: Longint;
  4608. asm
  4609.         { ->    EAX str }
  4610.  
  4611.         TEST    EAX,EAX
  4612.         JE      @@done
  4613.         MOV     EAX,[EAX-skew].StrRec.length;
  4614. @@done:
  4615. end;
  4616.  
  4617. procedure       _LStrCat{var dest: AnsiString; source: AnsiString};
  4618. asm
  4619.         { ->    EAX     pointer to dest }
  4620.         {       EDX source              }
  4621.  
  4622.         TEST    EDX,EDX
  4623.         JE      @@exit
  4624.  
  4625.         MOV     ECX,[EAX]
  4626.         TEST    ECX,ECX
  4627.         JE      _LStrAsg
  4628.  
  4629.         PUSH    EBX
  4630.         PUSH    ESI
  4631.         PUSH    EDI
  4632.         MOV     EBX,EAX
  4633.         MOV     ESI,EDX
  4634.         MOV     EDI,[ECX-skew].StrRec.length
  4635.  
  4636.         MOV     EDX,[ESI-skew].StrRec.length
  4637.         ADD     EDX,EDI
  4638.         CMP     ESI,ECX
  4639.         JE      @@appendSelf
  4640.  
  4641.         CALL    _LStrSetLength
  4642.         MOV     EAX,ESI
  4643.         MOV     ECX,[ESI-skew].StrRec.length
  4644.  
  4645. @@appendStr:
  4646.         MOV     EDX,[EBX]
  4647.         ADD     EDX,EDI
  4648.         CALL    Move
  4649.         POP     EDI
  4650.         POP     ESI
  4651.         POP     EBX
  4652.         RET
  4653.  
  4654. @@appendSelf:
  4655.         CALL    _LStrSetLength
  4656.         MOV     EAX,[EBX]
  4657.         MOV     ECX,EDI
  4658.         JMP     @@appendStr
  4659.  
  4660. @@exit:
  4661. end;
  4662.  
  4663.  
  4664. procedure       _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  4665. asm
  4666.         {     ->EAX = Pointer to dest   }
  4667.         {       EDX = source1           }
  4668.         {       ECX = source2           }
  4669.  
  4670.         TEST    EDX,EDX
  4671.         JE      @@assignSource2
  4672.  
  4673.         TEST    ECX,ECX
  4674.         JE      _LStrAsg
  4675.  
  4676.         CMP     EDX,[EAX]
  4677.         JE      @@appendToDest
  4678.  
  4679.         CMP     ECX,[EAX]
  4680.         JE      @@theHardWay
  4681.  
  4682.         PUSH    EAX
  4683.         PUSH    ECX
  4684.         CALL    _LStrAsg
  4685.  
  4686.         POP     EDX
  4687.         POP     EAX
  4688.         JMP     _LStrCat
  4689.  
  4690. @@theHardWay:
  4691.  
  4692.         PUSH    EBX
  4693.         PUSH    ESI
  4694.         PUSH    EDI
  4695.  
  4696.         MOV     EBX,EDX
  4697.         MOV     ESI,ECX
  4698.         PUSH    EAX
  4699.  
  4700.         MOV     EAX,[EBX-skew].StrRec.length
  4701.         ADD     EAX,[ESI-skew].StrRec.length
  4702.         CALL    _NewAnsiString
  4703.  
  4704.         MOV     EDI,EAX
  4705.         MOV     EDX,EAX
  4706.         MOV     EAX,EBX
  4707.         MOV     ECX,[EBX-skew].StrRec.length
  4708.         CALL    Move
  4709.  
  4710.         MOV     EDX,EDI
  4711.         MOV     EAX,ESI
  4712.         MOV     ECX,[ESI-skew].StrRec.length
  4713.         ADD     EDX,[EBX-skew].StrRec.length
  4714.         CALL    Move
  4715.  
  4716.         POP     EAX
  4717.         MOV     EDX,EDI
  4718.         TEST    EDI,EDI
  4719.         JE      @@skip
  4720.         DEC     [EDI-skew].StrRec.refCnt
  4721. @@skip:
  4722.         CALL    _LStrAsg
  4723.  
  4724.         POP     EDI
  4725.         POP     ESI
  4726.         POP     EBX
  4727.  
  4728.         JMP     @@exit
  4729.  
  4730. @@assignSource2:
  4731.         MOV     EDX,ECX
  4732.         JMP     _LStrAsg
  4733.  
  4734. @@appendToDest:
  4735.         MOV     EDX,ECX
  4736.         JMP     _LStrCat
  4737.  
  4738. @@exit:
  4739. end;
  4740.  
  4741.  
  4742. procedure       _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  4743. asm
  4744.         {     ->EAX = Pointer to dest   }
  4745.         {       EDX = number of args (>= 3)     }
  4746.         {       [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }
  4747.  
  4748.         PUSH    EBX
  4749.         PUSH    ESI
  4750.         PUSH    EDX
  4751.         PUSH    EAX
  4752.         MOV     EBX,EDX
  4753.  
  4754.         XOR     EAX,EAX
  4755. @@loop1:
  4756.         MOV     ECX,[ESP+EDX*4+4*4]
  4757.         TEST    ECX,ECX
  4758.         JE      @@1
  4759.         ADD     EAX,[ECX-skew].StrRec.length
  4760. @@1:
  4761.         DEC     EDX
  4762.         JNE     @@loop1
  4763.  
  4764.         CALL    _NewAnsiString
  4765.         PUSH    EAX
  4766.         MOV     ESI,EAX
  4767.  
  4768. @@loop2:
  4769.         MOV     EAX,[ESP+EBX*4+5*4]
  4770.         MOV     EDX,ESI
  4771.         TEST    EAX,EAX
  4772.         JE      @@2
  4773.         MOV     ECX,[EAX-skew].StrRec.length
  4774.         ADD     ESI,ECX
  4775.         CALL    Move
  4776. @@2:
  4777.         DEC     EBX
  4778.         JNE     @@loop2
  4779.  
  4780.         POP     EDX
  4781.         POP     EAX
  4782.         TEST    EDX,EDX
  4783.         JE      @@skip
  4784.         DEC     [EDX-skew].StrRec.refCnt
  4785. @@skip:
  4786.         CALL    _LStrAsg
  4787.  
  4788.         POP     EDX
  4789.         POP     ESI
  4790.         POP     EBX
  4791.         POP     EAX
  4792.         LEA     ESP,[ESP+EDX*4]
  4793.         JMP     EAX
  4794. end;
  4795.  
  4796.  
  4797. procedure       _LStrCmp{left: AnsiString; right: AnsiString};
  4798. asm
  4799. {     ->EAX = Pointer to left string    }
  4800. {       EDX = Pointer to right string   }
  4801.  
  4802.         PUSH    EBX
  4803.         PUSH    ESI
  4804.         PUSH    EDI
  4805.  
  4806.         MOV     ESI,EAX
  4807.         MOV     EDI,EDX
  4808.  
  4809.         CMP     EAX,EDX
  4810.         JE      @@exit
  4811.  
  4812.         TEST    ESI,ESI
  4813.         JE      @@str1null
  4814.  
  4815.         TEST    EDI,EDI
  4816.         JE      @@str2null
  4817.  
  4818.         MOV     EAX,[ESI-skew].StrRec.length
  4819.         MOV     EDX,[EDI-skew].StrRec.length
  4820.  
  4821.         SUB     EAX,EDX { eax = len1 - len2 }
  4822.         JA      @@skip1
  4823.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  4824.  
  4825. @@skip1:
  4826.         PUSH    EDX
  4827.         SHR     EDX,2
  4828.         JE      @@cmpRest
  4829. @@longLoop:
  4830.         MOV     ECX,[ESI]
  4831.         MOV     EBX,[EDI]
  4832.         CMP     ECX,EBX
  4833.         JNE     @@misMatch
  4834.         DEC     EDX
  4835.         JE      @@cmpRestP4
  4836.         MOV     ECX,[ESI+4]
  4837.         MOV     EBX,[EDI+4]
  4838.         CMP     ECX,EBX
  4839.         JNE     @@misMatch
  4840.         ADD     ESI,8
  4841.         ADD     EDI,8
  4842.         DEC     EDX
  4843.         JNE     @@longLoop
  4844.         JMP     @@cmpRest
  4845. @@cmpRestP4:
  4846.         ADD     ESI,4
  4847.         ADD     EDI,4
  4848. @@cmpRest:
  4849.         POP     EDX
  4850.         AND     EDX,3
  4851.         JE      @@equal
  4852.  
  4853.         MOV     ECX,[ESI]
  4854.         MOV     EBX,[EDI]
  4855.         CMP     CL,BL
  4856.         JNE     @@exit
  4857.         DEC     EDX
  4858.         JE      @@equal
  4859.         CMP     CH,BH
  4860.         JNE     @@exit
  4861.         DEC     EDX
  4862.         JE      @@equal
  4863.         AND     EBX,$00FF0000
  4864.         AND     ECX,$00FF0000
  4865.         CMP     ECX,EBX
  4866.         JNE     @@exit
  4867.  
  4868. @@equal:
  4869.         ADD     EAX,EAX
  4870.         JMP     @@exit
  4871.  
  4872. @@str1null:
  4873.         MOV     EDX,[EDI-skew].StrRec.length
  4874.         SUB     EAX,EDX
  4875.         JMP     @@exit
  4876.  
  4877. @@str2null:
  4878.         MOV     EAX,[ESI-skew].StrRec.length
  4879.         SUB     EAX,EDX
  4880.         JMP     @@exit
  4881.  
  4882. @@misMatch:
  4883.         POP     EDX
  4884.         CMP     CL,BL
  4885.         JNE     @@exit
  4886.         CMP     CH,BH
  4887.         JNE     @@exit
  4888.         SHR     ECX,16
  4889.         SHR     EBX,16
  4890.         CMP     CL,BL
  4891.         JNE     @@exit
  4892.         CMP     CH,BH
  4893.  
  4894. @@exit:
  4895.         POP     EDI
  4896.         POP     ESI
  4897.         POP     EBX
  4898.  
  4899. end;
  4900.  
  4901.  
  4902. procedure       _LStrAddRef{str: AnsiString};
  4903. asm
  4904.         { ->    EAX     str     }
  4905.         TEST    EAX,EAX
  4906.         JE      @@exit
  4907.         MOV     EDX,[EAX-skew].StrRec.refCnt
  4908.         INC     EDX
  4909.         JLE     @@exit
  4910.         MOV     [EAX-skew].StrRec.refCnt,EDX
  4911. @@exit:
  4912. end;
  4913.  
  4914.  
  4915. procedure       _LStrToPChar{str: AnsiString): PChar};
  4916. asm
  4917.         { ->    EAX pointer to str              }
  4918.         { <-    EAX pointer to PChar    }
  4919.  
  4920.         TEST    EAX,EAX
  4921.         JE      @@handle0
  4922.         RET
  4923. @@zeroByte:
  4924.         DB      0
  4925. @@handle0:
  4926.         MOV     EAX,offset @@zeroByte
  4927. end;
  4928.  
  4929.  
  4930. procedure       UniqueString(var str: string);
  4931. asm
  4932.         { ->    EAX pointer to str              }
  4933.         { <-    EAX pointer to unique copy      }
  4934.         MOV     EDX,[EAX]
  4935.         TEST    EDX,EDX
  4936.         JE      @@exit
  4937.         MOV     ECX,[EDX-skew].StrRec.refCnt
  4938.         DEC     ECX
  4939.         JE      @@exit
  4940.  
  4941.         PUSH    EBX
  4942.         MOV     EBX,EAX
  4943.         MOV     EAX,[EDX-skew].StrRec.length
  4944.         CALL    _NewAnsiString
  4945.         MOV     EDX,EAX
  4946.         MOV     EAX,[EBX]
  4947.         MOV     [EBX],EDX
  4948.         MOV     ECX,[EAX-skew].StrRec.refCnt
  4949.         DEC     ECX
  4950.         JL      @@skip
  4951.         MOV     [EAX-skew].StrRec.refCnt,ECX
  4952. @@skip:
  4953.         MOV     ECX,[EAX-skew].StrRec.length
  4954.         CALL    Move
  4955.         MOV     EDX,[EBX]
  4956.         POP     EBX
  4957. @@exit:
  4958.         MOV     EAX,EDX
  4959. end;
  4960.  
  4961.  
  4962. procedure       _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
  4963. asm
  4964.         {     ->EAX     Source string                   }
  4965.         {       EDX     index                           }
  4966.         {       ECX     count                           }
  4967.         {       [ESP+4] Pointer to result string        }
  4968.  
  4969.         PUSH    EBX
  4970.  
  4971.         TEST    EAX,EAX
  4972.         JE      @@srcEmpty
  4973.  
  4974.         MOV     EBX,[EAX-skew].StrRec.length
  4975.         TEST    EBX,EBX
  4976.         JE      @@srcEmpty
  4977.  
  4978. {       make index 0-based and limit to 0 <= index < Length(src) }
  4979.  
  4980.         DEC     EDX
  4981.         JL      @@smallInx
  4982.         CMP     EDX,EBX
  4983.         JGE     @@bigInx
  4984.  
  4985. @@cont1:
  4986.  
  4987. {       limit count to satisfy 0 <= count <= Length(src) - index        }
  4988.  
  4989.         SUB     EBX,EDX { calculate Length(src) - index }
  4990.         TEST    ECX,ECX
  4991.         JL      @@smallCount
  4992.         CMP     ECX,EBX
  4993.         JG      @@bigCount
  4994.  
  4995. @@cont2:
  4996.  
  4997.         ADD     EDX,EAX
  4998.         MOV     EAX,[ESP+4+4]
  4999.         CALL    _LStrFromLenStr
  5000.         JMP     @@exit
  5001.  
  5002. @@smallInx:
  5003.         XOR     EDX,EDX
  5004.         JMP     @@cont1
  5005. @@bigCount:
  5006.         MOV     ECX,EBX
  5007.         JMP     @@cont2
  5008. @@bigInx:
  5009. @@smallCount:
  5010. @@srcEmpty:
  5011.         MOV     EAX,[ESP+4+4]
  5012.         CALL    _LStrClr
  5013. @@exit:
  5014.         POP     EBX
  5015.         RET     4
  5016. end;
  5017.  
  5018.  
  5019. procedure       _LStrDelete{ var s : AnsiString; index, count : Integer };
  5020. asm
  5021.         {     ->EAX     Pointer to s    }
  5022.         {       EDX     index           }
  5023.         {       ECX     count           }
  5024.  
  5025.         PUSH    EBX
  5026.         PUSH    ESI
  5027.         PUSH    EDI
  5028.  
  5029.         MOV     EBX,EAX
  5030.         MOV     ESI,EDX
  5031.         MOV     EDI,ECX
  5032.  
  5033.         CALL    UniqueString
  5034.  
  5035.         MOV     EDX,[EBX]
  5036.         TEST    EDX,EDX         { source already empty: nothing to do   }
  5037.         JE      @@exit
  5038.  
  5039.         MOV     ECX,[EDX-skew].StrRec.length
  5040.  
  5041. {       make index 0-based, if not in [0 .. Length(s)-1] do nothing     }
  5042.  
  5043.         DEC     ESI
  5044.         JL      @@exit
  5045.         CMP     ESI,ECX
  5046.         JGE     @@exit
  5047.  
  5048. {       limit count to [0 .. Length(s) - index] }
  5049.  
  5050.         TEST    EDI,EDI
  5051.         JLE     @@exit
  5052.         SUB     ECX,ESI         { ECX = Length(s) - index       }
  5053.         CMP     EDI,ECX
  5054.         JLE     @@1
  5055.         MOV     EDI,ECX
  5056. @@1:
  5057.  
  5058. {       move length - index - count characters from s+index+count to s+index }
  5059.  
  5060.         SUB     ECX,EDI         { ECX = Length(s) - index - count       }
  5061.         ADD     EDX,ESI         { EDX = s+index                 }
  5062.         LEA     EAX,[EDX+EDI]   { EAX = s+index+count           }
  5063.         CALL    Move
  5064.  
  5065. {       set length(s) to length(s) - count      }
  5066.  
  5067.         MOV     EDX,[EBX]
  5068.         MOV     EAX,EBX
  5069.         MOV     EDX,[EDX-skew].StrRec.length
  5070.         SUB     EDX,EDI
  5071.         CALL    _LStrSetLength
  5072.  
  5073. @@exit:
  5074.         POP     EDI
  5075.         POP     ESI
  5076.         POP     EBX
  5077. end;
  5078.  
  5079.  
  5080. procedure       _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  5081. asm
  5082.         { ->    EAX source string                       }
  5083.         {       EDX     pointer to destination string   }
  5084.         {       ECX index                               }
  5085.  
  5086.         TEST    EAX,EAX
  5087.         JE      @@nothingToDo
  5088.  
  5089.         PUSH    EBX
  5090.         PUSH    ESI
  5091.         PUSH    EDI
  5092.         PUSH    EBP
  5093.  
  5094.         MOV     EBX,EAX
  5095.         MOV     ESI,EDX
  5096.         MOV     EDI,ECX
  5097.  
  5098. {       make index 0-based and limit to 0 <= index <= Length(s) }
  5099.  
  5100.         MOV     EDX,[EDX]
  5101.         PUSH    EDX
  5102.         TEST    EDX,EDX
  5103.         JE      @@sIsNull
  5104.         MOV     EDX,[EDX-skew].StrRec.length
  5105. @@sIsNull:
  5106.         DEC     EDI
  5107.         JGE     @@indexNotLow
  5108.         XOR     EDI,EDI
  5109. @@indexNotLow:
  5110.         CMP     EDI,EDX
  5111.         JLE     @@indexNotHigh
  5112.         MOV     EDI,EDX
  5113. @@indexNotHigh:
  5114.  
  5115.         MOV     EBP,[EBX-skew].StrRec.length
  5116.  
  5117. {       set length of result to length(source) + length(s)      }
  5118.  
  5119.         MOV     EAX,ESI
  5120.         ADD     EDX,EBP
  5121.         CALL    _LStrSetLength
  5122.         POP     EAX
  5123.  
  5124.         CMP     EAX,EBX
  5125.         JNE     @@notInsertSelf
  5126.         MOV     EBX,[ESI]
  5127.  
  5128. @@notInsertSelf:
  5129.  
  5130. {       move length(s) - length(source) - index chars from s+index to s+index+length(source) }
  5131.  
  5132.         MOV     EAX,[ESI]                       { EAX = s       }
  5133.         LEA     EDX,[EDI+EBP]                   { EDX = index + length(source)  }
  5134.         MOV     ECX,[EAX-skew].StrRec.length
  5135.         SUB     ECX,EDX                         { ECX = length(s) - length(source) - index }
  5136.         ADD     EDX,EAX                         { EDX = s + index + length(source)      }
  5137.         ADD     EAX,EDI                         { EAX = s + index       }
  5138.         CALL    Move
  5139.  
  5140. {       copy length(source) chars from source to s+index        }
  5141.  
  5142.         MOV     EAX,EBX
  5143.         MOV     EDX,[ESI]
  5144.         MOV     ECX,EBP
  5145.         ADD     EDX,EDI
  5146.         CALL    Move
  5147.  
  5148. @@exit:
  5149.         POP     EBP
  5150.         POP     EDI
  5151.         POP     ESI
  5152.         POP     EBX
  5153. @@nothingToDo:
  5154. end;
  5155.  
  5156.  
  5157. procedure       _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  5158. asm
  5159. {     ->EAX     Pointer to substr               }
  5160. {       EDX     Pointer to string               }
  5161. {     <-EAX     Position of substr in s or 0    }
  5162.  
  5163.         TEST    EAX,EAX
  5164.         JE      @@noWork
  5165.  
  5166.         TEST    EDX,EDX
  5167.         JE      @@stringEmpty
  5168.  
  5169.         PUSH    EBX
  5170.         PUSH    ESI
  5171.         PUSH    EDI
  5172.  
  5173.         MOV     ESI,EAX                         { Point ESI to substr           }
  5174.         MOV     EDI,EDX                         { Point EDI to s                }
  5175.  
  5176.         MOV     ECX,[EDI-skew].StrRec.length    { ECX = Length(s)               }
  5177.  
  5178.         PUSH    EDI                             { remember s position to calculate index        }
  5179.  
  5180.         MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)          }
  5181.  
  5182.         DEC     EDX                             { EDX = Length(substr) - 1              }
  5183.         JS      @@fail                          { < 0 ? return 0                        }
  5184.         MOV     AL,[ESI]                        { AL = first char of substr             }
  5185.         INC     ESI                             { Point ESI to 2'nd char of substr      }
  5186.  
  5187.         SUB     ECX,EDX                         { #positions in s to look at    }
  5188.                                                 { = Length(s) - Length(substr) + 1      }
  5189.         JLE     @@fail
  5190. @@loop:
  5191.         REPNE   SCASB
  5192.         JNE     @@fail
  5193.         MOV     EBX,ECX                         { save outer loop counter               }
  5194.         PUSH    ESI                             { save outer loop substr pointer        }
  5195.         PUSH    EDI                             { save outer loop s pointer             }
  5196.  
  5197.         MOV     ECX,EDX
  5198.         REPE    CMPSB
  5199.         POP     EDI                             { restore outer loop s pointer  }
  5200.         POP     ESI                             { restore outer loop substr pointer     }
  5201.         JE      @@found
  5202.         MOV     ECX,EBX                         { restore outer loop counter    }
  5203.         JMP     @@loop
  5204.  
  5205. @@fail:
  5206.         POP     EDX                             { get rid of saved s pointer    }
  5207.         XOR     EAX,EAX
  5208.         JMP     @@exit
  5209.  
  5210. @@stringEmpty:
  5211.         XOR     EAX,EAX
  5212.         JMP     @@noWork
  5213.  
  5214. @@found:
  5215.         POP     EDX                             { restore pointer to first char of s    }
  5216.         MOV     EAX,EDI                         { EDI points of char after match        }
  5217.         SUB     EAX,EDX                         { the difference is the correct index   }
  5218. @@exit:
  5219.         POP     EDI
  5220.         POP     ESI
  5221.         POP     EBX
  5222. @@noWork:
  5223. end;
  5224.  
  5225.  
  5226. procedure       _LStrSetLength{ var str: AnsiString; newLength: Integer};
  5227. asm
  5228.         { ->    EAX     Pointer to str  }
  5229.         {       EDX new length  }
  5230.  
  5231.         PUSH    EBX
  5232.         PUSH    ESI
  5233.         PUSH    EDI
  5234.         MOV     EBX,EAX
  5235.         MOV     ESI,EDX
  5236.         XOR     EDI,EDI
  5237.  
  5238.         TEST    EDX,EDX
  5239.         JE      @@setString
  5240.  
  5241.         MOV     EAX,[EBX]
  5242.         TEST    EAX,EAX
  5243.         JE      @@copyString
  5244.  
  5245.         CMP     [EAX-skew].StrRec.refCnt,1
  5246.         JNE     @@copyString
  5247.  
  5248.         SUB     EAX,rOff
  5249.         ADD     EDX,rOff+1
  5250.         PUSH    EAX
  5251.         MOV     EAX,ESP
  5252.         CALL    _ReallocMem
  5253.         POP     EAX
  5254.         ADD     EAX,rOff
  5255.         MOV     [EBX],EAX
  5256.         MOV     [EAX-skew].StrRec.length,ESI
  5257.         MOV     BYTE PTR [EAX+ESI],0
  5258.         JMP     @@exit
  5259.  
  5260. @@copyString:
  5261.         MOV     EAX,EDX
  5262.         CALL    _NewAnsiString
  5263.         MOV     EDI,EAX
  5264.  
  5265.         MOV     EAX,[EBX]
  5266.         TEST    EAX,EAX
  5267.         JE      @@setString
  5268.  
  5269.         MOV     EDX,EDI
  5270.         MOV     ECX,[EAX-skew].StrRec.length
  5271.         CMP     ECX,ESI
  5272.         JL      @@moveString
  5273.         MOV     ECX,ESI
  5274.  
  5275. @@moveString:
  5276.         CALL    Move
  5277.  
  5278. @@setString:
  5279.         MOV     EAX,EBX
  5280.         CALL    _LStrClr
  5281.         MOV     [EBX],EDI
  5282.  
  5283. @@exit:
  5284.         POP     EDI
  5285.         POP     ESI
  5286.         POP     EBX
  5287. end;
  5288.  
  5289.  
  5290. procedure       _LStrToString{ var result: ShortString; s: AnsiString; resultLen: Integer};
  5291. asm
  5292.         { ->    EAX pointer to result   }
  5293.         {       EDX AnsiString s        }
  5294.         {       ECX length of result    }
  5295.  
  5296.         PUSH    EBX
  5297.         TEST    EDX,EDX
  5298.         JE      @@empty
  5299.         MOV     EBX,[EDX-skew].StrRec.length
  5300.         TEST    EBX,EBX
  5301.         JE      @@empty
  5302.  
  5303.         CMP     ECX,EBX
  5304.         JL      @@truncate
  5305.         MOV     ECX,EBX
  5306. @@truncate:
  5307.         MOV     [EAX],CL
  5308.         INC     EAX
  5309.  
  5310.         XCHG    EAX,EDX
  5311.         CALL    Move
  5312.  
  5313.         JMP     @@exit
  5314.  
  5315. @@empty:
  5316.         MOV     byte ptr [EAX],0
  5317.  
  5318. @@exit:
  5319.         POP     EBX
  5320. end;
  5321.  
  5322.  
  5323. procedure       _LStrOfChar{ c: Char; count: Integer): AnsiString };
  5324. asm
  5325.         { ->    AL      c               }
  5326.         {       EDX     count           }
  5327.         {       ECX     result  }
  5328.  
  5329.         PUSH    EBX
  5330.         PUSH    ESI
  5331.         PUSH    EDI
  5332.  
  5333.         MOV     EBX,EAX
  5334.         MOV     ESI,EDX
  5335.         MOV     EDI,ECX
  5336.  
  5337.         MOV     EAX,ECX
  5338.         CALL    _LStrClr
  5339.  
  5340.         TEST    ESI,ESI
  5341.     JLE @@exit
  5342.  
  5343.         MOV     EAX,ESI
  5344.         CALL    _NewAnsiString
  5345.  
  5346.         MOV     [EDI],EAX
  5347.  
  5348.         MOV     EDX,ESI
  5349.         MOV     CL,BL
  5350.  
  5351.         CALL    _FillChar
  5352.  
  5353. @@exit:
  5354.         POP     EDI
  5355.         POP     ESI
  5356.         POP     EBX
  5357.  
  5358. end;
  5359.  
  5360.  
  5361. procedure _Write0LString{ VAR t: Text; s: AnsiString };
  5362. asm
  5363.         { ->    EAX     Pointer to text record  }
  5364.         {       EDX     Pointer to AnsiString   }
  5365.  
  5366.         XOR     ECX,ECX
  5367.         JMP     _WriteLString
  5368. end;
  5369.  
  5370.  
  5371. procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
  5372. asm
  5373.         { ->    EAX     Pointer to text record  }
  5374.         {       EDX     Pointer to AnsiString   }
  5375.         {       ECX     Field width             }
  5376.  
  5377.         PUSH    EBX
  5378.  
  5379.         MOV     EBX,EDX
  5380.  
  5381.         MOV     EDX,ECX
  5382.         XOR     ECX,ECX
  5383.         TEST    EBX,EBX
  5384.         JE      @@skip
  5385.         MOV     ECX,[EBX-skew].StrRec.length
  5386.         SUB     EDX,ECX
  5387. @@skip:
  5388.         PUSH    ECX
  5389.         CALL    _WriteSpaces
  5390.         POP     ECX
  5391.  
  5392.         MOV     EDX,EBX
  5393.         POP     EBX
  5394.         JMP     _WriteBytes
  5395. end;
  5396.  
  5397.  
  5398. procedure       _ReadLString{var t: Text; var str: AnsiString};
  5399. asm
  5400.         { ->    EAX     pointer to Text         }
  5401.         {       EDX     pointer to AnsiString   }
  5402.  
  5403.         PUSH    EBX
  5404.         PUSH    ESI
  5405.         MOV     EBX,EAX
  5406.         MOV     ESI,EDX
  5407.  
  5408.         MOV     EAX,EDX
  5409.         CALL    _LStrClr
  5410.  
  5411.         SUB     ESP,256
  5412.  
  5413.         MOV     EAX,EBX
  5414.         MOV     EDX,ESP
  5415.         MOV     ECX,255
  5416.         CALL    _ReadString
  5417.  
  5418.         MOV     EAX,ESI
  5419.         MOV     EDX,ESP
  5420.         CALL    _LStrFromString
  5421.  
  5422.         CMP     byte ptr [ESP],255
  5423.         JNE     @@exit
  5424. @@loop:
  5425.  
  5426.         MOV     EAX,EBX
  5427.         MOV     EDX,ESP
  5428.         MOV     ECX,255
  5429.         CALL    _ReadString
  5430.  
  5431.         MOV     EDX,ESP
  5432.         PUSH    0
  5433.         MOV     EAX,ESP
  5434.         CALL    _LStrFromString
  5435.  
  5436.         MOV     EAX,ESI
  5437.         POP     EDX
  5438.         CALL    _LStrCat
  5439.  
  5440.         CMP     byte ptr [ESP],255
  5441.         JE      @@loop
  5442.  
  5443. @@exit:
  5444.         ADD     ESP,256
  5445.         POP     ESI
  5446.         POP     EBX
  5447. end;
  5448.  
  5449.  
  5450. procedure       _InitializeRecord{ p: Pointer; typeInfo: Pointer };
  5451. asm
  5452.         { ->    EAX pointer to record to be finalized   }
  5453.         {       EDX pointer to type info                }
  5454.  
  5455.         XOR     ECX,ECX
  5456.  
  5457.         PUSH    EBX
  5458.         MOV     CL,[EDX+1]
  5459.  
  5460.         PUSH    ESI
  5461.         PUSH    EDI
  5462.  
  5463.         MOV     EBX,EAX
  5464.         LEA     ESI,[EDX+ECX+2+8]
  5465.         MOV     EDI,[EDX+ECX+2+4]
  5466.  
  5467. @@loop:
  5468.  
  5469.         MOV     EAX,[ESI+4]
  5470.         MOV     EDX,[ESI]
  5471.         ADD     EAX,EBX
  5472.         CALL    _Initialize
  5473.         ADD     ESI,8
  5474.         DEC     EDI
  5475.         JG      @@loop
  5476.  
  5477.         POP     EDI
  5478.         POP     ESI
  5479.         POP     EBX
  5480. end;
  5481.  
  5482.  
  5483. procedure       _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  5484. const
  5485.   tkLString = 10;
  5486.   tkVariant = 12;
  5487.   tkArray   = 13;
  5488.   tkRecord  = 14;
  5489. asm
  5490.         { ->    EAX     pointer to data to be finalized         }
  5491.         {       EDX     pointer to type info describing data    }
  5492.         {       ECX number of elements of that type             }
  5493.  
  5494.         PUSH    EBX
  5495.         PUSH    ESI
  5496.         PUSH    EDI
  5497.         MOV     EBX,EAX
  5498.         MOV     ESI,EDX
  5499.         MOV     EDI,ECX
  5500.  
  5501.         XOR     EDX,EDX
  5502.         MOV     AL,[ESI]
  5503.         MOV     DL,[ESI+1]
  5504.         XOR     ECX,ECX
  5505.  
  5506.         CMP     AL,tkLString
  5507.         JE      @@LString
  5508.         CMP     AL,tkVariant
  5509.         JE      @@Variant
  5510.         CMP     AL,tkArray
  5511.         JE      @@Array
  5512.         CMP     AL,tkRecord
  5513.         JE      @@Record
  5514.         MOV     AL,reInvalidPtr
  5515.         POP     EDI
  5516.         POP     ESI
  5517.         POP     EBX
  5518.         JMP     Error
  5519.  
  5520. @@LString:
  5521.         MOV     [EBX],ECX
  5522.         ADD     EBX,4
  5523.         DEC     EDI
  5524.         JG      @@LString
  5525.         JMP     @@exit
  5526.  
  5527. @@Variant:
  5528.         MOV     [EBX   ],ECX
  5529.         MOV     [EBX+ 4],ECX
  5530.         MOV     [EBX+ 8],ECX
  5531.         MOV     [EBX+12],ECX
  5532.         ADD     EBX,16
  5533.         DEC     EDI
  5534.         JG      @@Variant
  5535.         JMP     @@exit
  5536.  
  5537. @@Array:
  5538.         PUSH    EBP
  5539.         MOV     EBP,EDX
  5540. @@ArrayLoop:
  5541.         MOV     EAX,EBX
  5542.         ADD     EBX,[ESI+EBP+2]
  5543.         MOV     ECX,[ESI+EBP+2+4]
  5544.         MOV     EDX,[ESI+EBP+2+8]
  5545.         CALL    _InitializeArray
  5546.         DEC     EDI
  5547.         JG      @@ArrayLoop
  5548.         POP     EBP
  5549.         JMP     @@exit
  5550.  
  5551. @@Record:
  5552.         PUSH    EBP
  5553.         MOV     EBP,EDX
  5554. @@RecordLoop:
  5555.         MOV     EAX,EBX
  5556.         ADD     EBX,[ESI+EBP+2]
  5557.         MOV     EDX,ESI
  5558.         CALL    _InitializeRecord
  5559.         DEC     EDI
  5560.         JG      @@RecordLoop
  5561.         POP     EBP
  5562.  
  5563. @@exit:
  5564.  
  5565.         POP     EDI
  5566.         POP     ESI
  5567.     POP EBX
  5568. end;
  5569.  
  5570.  
  5571. procedure       _Initialize{ p: Pointer; typeInfo: Pointer};
  5572. asm
  5573.         MOV     ECX,1
  5574.         JMP     _InitializeArray
  5575. end;
  5576.  
  5577. procedure       _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
  5578. asm
  5579.         { ->    EAX pointer to record to be finalized   }
  5580.         {       EDX pointer to type info                }
  5581.  
  5582.         XOR     ECX,ECX
  5583.  
  5584.         PUSH    EBX
  5585.         MOV     CL,[EDX+1]
  5586.  
  5587.         PUSH    ESI
  5588.         PUSH    EDI
  5589.  
  5590.         MOV     EBX,EAX
  5591.         LEA     ESI,[EDX+ECX+2+8]
  5592.         MOV     EDI,[EDX+ECX+2+4]
  5593.  
  5594. @@loop:
  5595.  
  5596.         MOV     EAX,[ESI+4]
  5597.         MOV     EDX,[ESI]
  5598.         ADD     EAX,EBX
  5599.         CALL    _Finalize
  5600.         ADD     ESI,8
  5601.         DEC     EDI
  5602.         JG      @@loop
  5603.  
  5604.         POP     EDI
  5605.         POP     ESI
  5606.         POP     EBX
  5607. end;
  5608.  
  5609.  
  5610. procedure       _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  5611. const
  5612.         tkLString = 10;
  5613.         tkVariant = 12;
  5614.         tkArray   = 13;
  5615.         tkRecord  = 14;
  5616. asm
  5617.         { ->    EAX     pointer to data to be finalized         }
  5618.         {       EDX     pointer to type info describing data    }
  5619.         {       ECX number of elements of that type             }
  5620.  
  5621.         PUSH    EBX
  5622.         PUSH    ESI
  5623.         PUSH    EDI
  5624.         MOV     EBX,EAX
  5625.         MOV     ESI,EDX
  5626.         MOV     EDI,ECX
  5627.  
  5628.         XOR     EDX,EDX
  5629.         MOV     AL,[ESI]
  5630.         MOV     DL,[ESI+1]
  5631.  
  5632.         CMP     AL,tkLString
  5633.         JE      @@LString
  5634.         CMP     AL,tkVariant
  5635.         JE      @@Variant
  5636.         CMP     AL,tkArray
  5637.         JE      @@Array
  5638.         CMP     AL,tkRecord
  5639.         JE      @@Record
  5640.         MOV     AL,reInvalidPtr
  5641.         POP     EDI
  5642.         POP     ESI
  5643.         POP     EBX
  5644.         JMP     Error
  5645.  
  5646. @@LString:
  5647.         CMP     ECX,1
  5648.         MOV     EAX,EBX
  5649.         JG      @@LStringArray
  5650.         CALL    _LStrClr
  5651.         JMP     @@exit
  5652. @@LStringArray:
  5653.         MOV     EDX,ECX
  5654.         CALL    _LStrArrayClr
  5655.         JMP     @@exit
  5656.  
  5657. @@Variant:
  5658.         MOV     EAX,EBX
  5659.         ADD     EBX,16
  5660.         CALL    _VarClr
  5661.         DEC     EDI
  5662.         JG      @@Variant
  5663.         JMP     @@exit
  5664.  
  5665. @@Array:
  5666.         PUSH    EBP
  5667.         MOV     EBP,EDX
  5668. @@ArrayLoop:
  5669.         MOV     EAX,EBX
  5670.         ADD     EBX,[ESI+EBP+2]
  5671.         MOV     ECX,[ESI+EBP+2+4]
  5672.         MOV     EDX,[ESI+EBP+2+8]
  5673.         CALL    _FinalizeArray
  5674.         DEC     EDI
  5675.         JG      @@ArrayLoop
  5676.         POP     EBP
  5677.         JMP     @@exit
  5678.  
  5679. @@Record:
  5680.         PUSH    EBP
  5681.         MOV     EBP,EDX
  5682. @@RecordLoop:
  5683.         MOV     EAX,EBX
  5684.         ADD     EBX,[ESI+EBP+2]
  5685.         MOV     EDX,ESI
  5686.         CALL    _FinalizeRecord
  5687.         DEC     EDI
  5688.         JG      @@RecordLoop
  5689.         POP     EBP
  5690.  
  5691. @@exit:
  5692.  
  5693.         POP     EDI
  5694.         POP     ESI
  5695.         POP     EBX
  5696. end;
  5697.  
  5698.  
  5699. procedure       _Finalize{ p: Pointer; typeInfo: Pointer};
  5700. asm
  5701.         MOV     ECX,1
  5702.         JMP     _FinalizeArray
  5703. end;
  5704.  
  5705. procedure       _AddRefRecord{ p: Pointer; typeInfo: Pointer };
  5706. asm
  5707.         { ->    EAX pointer to record to be finalized           }
  5708.         {       EDX pointer to type info        }
  5709.  
  5710.         XOR     ECX,ECX
  5711.  
  5712.         PUSH    EBX
  5713.         MOV     CL,[EDX+1]
  5714.  
  5715.         PUSH    ESI
  5716.         PUSH    EDI
  5717.  
  5718.         MOV     EBX,EAX
  5719.         LEA     ESI,[EDX+ECX+2+8]
  5720.         MOV     EDI,[EDX+ECX+2+4]
  5721.  
  5722. @@loop:
  5723.  
  5724.         MOV     EAX,[ESI+4]
  5725.         MOV     EDX,[ESI]
  5726.         ADD     EAX,EBX
  5727.         CALL    _AddRef
  5728.         ADD     ESI,8
  5729.         DEC     EDI
  5730.         JG      @@loop
  5731.  
  5732.         POP     EDI
  5733.         POP     ESI
  5734.         POP     EBX
  5735. end;
  5736.  
  5737.  
  5738. procedure       _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  5739. const
  5740.         tkLString = 10;
  5741.         tkVariant = 12;
  5742.         tkArray   = 13;
  5743.         tkRecord  = 14;
  5744. asm
  5745.         { ->    EAX     pointer to data to be finalized         }
  5746.         {       EDX     pointer to type info describing data    }
  5747.         {       ECX number of elements of that type             }
  5748.  
  5749.         PUSH    EBX
  5750.         PUSH    ESI
  5751.         PUSH    EDI
  5752.         MOV     EBX,EAX
  5753.         MOV     ESI,EDX
  5754.         MOV     EDI,ECX
  5755.  
  5756.         XOR     EDX,EDX
  5757.         MOV     AL,[ESI]
  5758.         MOV     DL,[ESI+1]
  5759.  
  5760.         CMP     AL,tkLString
  5761.         JE      @@LString
  5762.         CMP     AL,tkVariant
  5763.         JE      @@Variant
  5764.         CMP     AL,tkArray
  5765.         JE      @@Array
  5766.         CMP     AL,tkRecord
  5767.         JE      @@Record
  5768.         MOV     AL,reInvalidPtr
  5769.         POP     EDI
  5770.         POP     ESI
  5771.         POP     EBX
  5772.         JMP     Error
  5773.  
  5774. @@LString:
  5775.         MOV     EAX,[EBX]
  5776.         ADD     EBX,4
  5777.         CALL    _LStrAddRef
  5778.         DEC     EDI
  5779.         JG      @@LString
  5780.         JMP     @@exit
  5781.  
  5782. @@Variant:
  5783.         MOV     EAX,EBX
  5784.         ADD     EBX,16
  5785.         CALL    _VarAddRef
  5786.         DEC     EDI
  5787.         JG      @@Variant
  5788.         JMP     @@exit
  5789.  
  5790. @@Array:
  5791.         PUSH    EBP
  5792.         MOV     EBP,EDX
  5793. @@ArrayLoop:
  5794.         MOV     EAX,EBX
  5795.         ADD     EBX,[ESI+EBP+2]
  5796.         MOV     ECX,[ESI+EBP+2+4]
  5797.         MOV     EDX,[ESI+EBP+2+8]
  5798.         CALL    _AddRefArray
  5799.         DEC     EDI
  5800.         JG      @@ArrayLoop
  5801.         POP     EBP
  5802.         JMP     @@exit
  5803.  
  5804. @@Record:
  5805.         PUSH    EBP
  5806.         MOV     EBP,EDX
  5807. @@RecordLoop:
  5808.         MOV     EAX,EBX
  5809.         ADD     EBX,[ESI+EBP+2]
  5810.         MOV     EDX,ESI
  5811.         CALL    _AddRefRecord
  5812.         DEC     EDI
  5813.         JG      @@RecordLoop
  5814.         POP     EBP
  5815.  
  5816. @@exit:
  5817.  
  5818.         POP     EDI
  5819.         POP     ESI
  5820.         POP     EBX
  5821. end;
  5822.  
  5823.  
  5824. procedure       _AddRef{ p: Pointer; typeInfo: Pointer};
  5825. asm
  5826.         MOV     ECX,1
  5827.         JMP     _AddRefArray
  5828. end;
  5829.  
  5830.  
  5831. procedure       _New{ size: Longint; typeInfo: Pointer};
  5832. asm
  5833.         { ->    EAX size of object to allocate  }
  5834.         {       EDX pointer to typeInfo         }
  5835.  
  5836.         PUSH    EDX
  5837.         CALL    _GetMem
  5838.         POP     EDX
  5839.         TEST    EAX,EAX
  5840.         JE      @@exit
  5841.         PUSH    EAX
  5842.         CALL    _Initialize
  5843.         POP     EAX
  5844. @@exit:
  5845. end;
  5846.  
  5847. procedure       _Dispose{ p: Pointer; typeInfo: Pointer};
  5848. asm
  5849.         { ->    EAX     Pointer to object to be disposed        }
  5850.         {       EDX     Pointer to type info            }
  5851.  
  5852.         PUSH    EAX
  5853.         CALL    _Finalize
  5854.         POP     EAX
  5855.         CALL    _FreeMem
  5856. end;
  5857.  
  5858. { ----------------------------------------------------- }
  5859. {       Wide character support                          }
  5860. { ----------------------------------------------------- }
  5861.  
  5862. function WideCharToString(Source: PWideChar): string;
  5863. begin
  5864.   WideCharToStrVar(Source, Result);
  5865. end;
  5866.  
  5867. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  5868. begin
  5869.   WideCharLenToStrVar(Source, SourceLen, Result);
  5870. end;
  5871.  
  5872. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  5873. var
  5874.   SourceLen: Integer;
  5875. begin
  5876.   SourceLen := 0;
  5877.   while Source[SourceLen] <> #0 do Inc(SourceLen);
  5878.   WideCharLenToStrVar(Source, SourceLen, Dest);
  5879. end;
  5880.  
  5881. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  5882.   var Dest: string);
  5883. var
  5884.   DestLen: Integer;
  5885.   Buffer: array[0..2047] of Char;
  5886. begin
  5887.   if SourceLen = 0 then
  5888.     Dest := ''
  5889.   else
  5890.     if SourceLen < SizeOf(Buffer) div 2 then
  5891.       SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
  5892.         Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
  5893.     else
  5894.     begin
  5895.       DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
  5896.         nil, 0, nil, nil);
  5897.       SetString(Dest, nil, DestLen);
  5898.       WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
  5899.         DestLen, nil, nil);
  5900.     end;
  5901. end;
  5902.  
  5903. function StringToWideChar(const Source: string; Dest: PWideChar;
  5904.   DestSize: Integer): PWideChar;
  5905. begin
  5906.   Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
  5907.     Dest, DestSize - 1)] := #0;
  5908.   Result := Dest;
  5909. end;
  5910.  
  5911. { ----------------------------------------------------- }
  5912. {       OLE string support                              }
  5913. { ----------------------------------------------------- }
  5914.  
  5915. function OleStrToString(Source: PWideChar): string;
  5916. begin
  5917.   OleStrToStrVar(Source, Result);
  5918. end;
  5919.  
  5920. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  5921. begin
  5922.   WideCharLenToStrVar(Source, SysStringLen(Source), Dest);
  5923. end;
  5924.  
  5925. function StringToOleStr(const Source: string): PWideChar;
  5926. var
  5927.   SourceLen, ResultLen: Integer;
  5928.   Buffer: array[0..1023] of WideChar;
  5929. begin
  5930.   SourceLen := Length(Source);
  5931.   if Length(Source) < SizeOf(Buffer) div 2 then
  5932.     Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
  5933.       PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
  5934.   else
  5935.   begin
  5936.     ResultLen := MultiByteToWideChar(0, 0,
  5937.       Pointer(Source), SourceLen, nil, 0);
  5938.     Result := SysAllocStringLen(nil, ResultLen);
  5939.     MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
  5940.       Result, ResultLen);
  5941.   end;
  5942. end;
  5943.  
  5944. { ----------------------------------------------------- }
  5945. {       Variant support                                 }
  5946. { ----------------------------------------------------- }
  5947.  
  5948. type
  5949.   TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);
  5950.  
  5951. const
  5952.   varLast = varByte;
  5953.  
  5954. const
  5955.   BaseTypeMap: array[0..varLast] of TBaseType = (
  5956.     btErr,  { varEmpty }
  5957.     btNul,  { varNull }
  5958.     btInt,  { varSmallint }
  5959.     btInt,  { varInteger }
  5960.     btFlt,  { varSingle }
  5961.     btFlt,  { varDouble }
  5962.     btCur,  { varCurrency }
  5963.     btDat,  { varDate }
  5964.     btStr,  { varOleStr }
  5965.     btErr,  { varDispatch }
  5966.     btErr,  { varError }
  5967.     btBol,  { varBoolean }
  5968.     btErr,  { varVariant }
  5969.     btErr,  { varUnknown }
  5970.     btErr,  { Undefined }
  5971.     btErr,  { Undefined }
  5972.     btErr,  { Undefined }
  5973.     btInt); { varByte }
  5974.  
  5975. const
  5976.   OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
  5977.     (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
  5978.     (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
  5979.     (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
  5980.     (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
  5981.     (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
  5982.     (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
  5983.     (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
  5984.     (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));
  5985.  
  5986. const
  5987.   C10000: Single = 10000;
  5988.  
  5989. const
  5990.   opAdd  = 0;
  5991.   opSub  = 1;
  5992.   opMul  = 2;
  5993.   opDvd  = 3;
  5994.   opDiv  = 4;
  5995.   opMod  = 5;
  5996.   opShl  = 6;
  5997.   opShr  = 7;
  5998.   opAnd  = 8;
  5999.   opOr   = 9;
  6000.   opXor  = 10;
  6001.  
  6002. procedure _DispInvoke;
  6003. asm
  6004.         { ->    [ESP+4] Pointer to result or nil }
  6005.         {       [ESP+8] Pointer to variant }
  6006.         {       [ESP+12]        Pointer to call descriptor }
  6007.         {       [ESP+16]        Additional parameters, if any }
  6008.         JMP     VarDispProc
  6009. end;
  6010.  
  6011. procedure _DispInvokeError;
  6012. asm
  6013.         MOV     AL,reVarDispatch
  6014.         JMP     Error
  6015. end;
  6016.  
  6017. procedure VarCastError;
  6018. asm
  6019.         MOV     AL,reVarTypeCast
  6020.         JMP     Error
  6021. end;
  6022.  
  6023. procedure VarInvalidOp;
  6024. asm
  6025.         MOV     AL,reVarInvalidOp
  6026.         JMP     Error
  6027. end;
  6028.  
  6029. procedure VarClear(var V: Variant);
  6030. asm
  6031.         XOR     EDX,EDX
  6032.         MOV     DX,[EAX].TVarData.VType
  6033.         TEST    EDX,varByRef
  6034.         JNE     @@1
  6035.         CMP     EDX,varOleStr
  6036.         JB      @@1
  6037.         CMP     EDX,varString
  6038.         JNE     @@2
  6039.         MOV     [EAX].TVarData.VType,varEmpty
  6040.         ADD     EAX,OFFSET TVarData.VString
  6041.         JMP     _LStrClr
  6042. @@1:    MOV     [EAX].TVarData.VType,varEmpty
  6043.         RET
  6044. @@2:    PUSH    EAX
  6045.         CALL    VariantClear
  6046. end;
  6047.  
  6048. procedure VarCopy(var Dest: Variant; const Source: Variant);
  6049. asm
  6050.         CMP     EAX,EDX
  6051.         JE      @@7
  6052.         CMP     [EAX].TVarData.VType,varOleStr
  6053.         JB      @@3
  6054.         PUSH    EAX
  6055.         PUSH    EDX
  6056.         CMP     [EAX].TVarData.VType,varString
  6057.         JE      @@1
  6058.         PUSH    EAX
  6059.         CALL    VariantClear
  6060.         JMP     @@2
  6061. @@1:    ADD     EAX,OFFSET TVarData.VString
  6062.         CALL    _LStrClr
  6063. @@2:    POP     EDX
  6064.         POP     EAX
  6065. @@3:    CMP     [EDX].TVarData.VType,varOleStr
  6066.         JAE     @@4
  6067.         MOV     ECX,[EDX]
  6068.         MOV     [EAX],ECX
  6069.         MOV     ECX,[EDX+8]
  6070.         MOV     [EAX+8],ECX
  6071.         MOV     ECX,[EDX+12]
  6072.         MOV     [EAX+12],ECX
  6073.         RET
  6074. @@4:    CMP     [EDX].TVarData.VType,varString
  6075.         JNE     @@6
  6076.         MOV     EDX,[EDX].TVarData.VString
  6077.         OR      EDX,EDX
  6078.         JE      @@5
  6079.         MOV     ECX,[EDX-skew].StrRec.refCnt
  6080.         INC     ECX
  6081.         JLE     @@5
  6082.         MOV     [EDX-skew].StrRec.refCnt,ECX
  6083. @@5:    MOV     [EAX].TVarData.VType,varString
  6084.         MOV     [EAX].TVarData.VString,EDX
  6085.         RET
  6086. @@6:    MOV     [EAX].TVarData.VType,varEmpty
  6087.         PUSH    EDX
  6088.         PUSH    EAX
  6089.         CALL    VariantCopyInd
  6090.         OR      EAX,EAX
  6091.         JNE     VarInvalidOp
  6092. @@7:
  6093. end;
  6094.  
  6095. procedure VarChangeType(var Dest: Variant; const Source: Variant;
  6096.   DestType: Word);
  6097. type
  6098.   TVarMem = array[0..3] of Integer;
  6099. var
  6100.   Temp: TVarData;
  6101. begin
  6102.   if TVarData(Dest).VType = varString then
  6103.   begin
  6104.     Temp.VType := varEmpty;
  6105.     if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
  6106.       VarCastError;
  6107.     VarClear(Dest);
  6108.     TVarMem(Dest)[0] := TVarMem(Temp)[0];
  6109.     TVarMem(Dest)[2] := TVarMem(Temp)[2];
  6110.     TVarMem(Dest)[3] := TVarMem(Temp)[3];
  6111.   end else
  6112.     if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
  6113.       VarCastError;
  6114. end;
  6115.  
  6116. procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
  6117. var
  6118.   StringPtr: Pointer;
  6119. begin
  6120.   StringPtr := nil;
  6121.   OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
  6122.   VarClear(Dest);
  6123.   TVarData(Dest).VType := varString;
  6124.   TVarData(Dest).VString := StringPtr;
  6125. end;
  6126.  
  6127. procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
  6128. var
  6129.   OleStrPtr: PWideChar;
  6130. begin
  6131.   OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  6132.   VarClear(Dest);
  6133.   TVarData(Dest).VType := varOleStr;
  6134.   TVarData(Dest).VOleStr := OleStrPtr;
  6135. end;
  6136.  
  6137. procedure VarCast(var Dest: Variant; const Source: Variant; VarType: Integer);
  6138. var
  6139.   SourceType, DestType: Word;
  6140.   Temp: TVarData;
  6141. begin
  6142.   SourceType := TVarData(Source).VType;
  6143.   DestType := Word(VarType);
  6144.   if SourceType = DestType then
  6145.     VarCopy(Dest, Source)
  6146.   else
  6147.   if SourceType = varString then
  6148.     if DestType = varOleStr then
  6149.       VarStringToOleStr(Dest, Source)
  6150.     else
  6151.     begin
  6152.       Temp.VType := varEmpty;
  6153.       VarStringToOleStr(Variant(Temp), Source);
  6154.       try
  6155.         VarChangeType(Dest, Variant(Temp), DestType);
  6156.       finally
  6157.         VarClear(Variant(Temp));
  6158.       end;
  6159.     end
  6160.   else
  6161.   if DestType = varString then
  6162.     if SourceType = varOleStr then
  6163.       VarOleStrToString(Dest, Source)
  6164.     else
  6165.     begin
  6166.       Temp.VType := varEmpty;
  6167.       VarChangeType(Variant(Temp), Source, varOleStr);
  6168.       try
  6169.         VarOleStrToString(Dest, Variant(Temp));
  6170.       finally
  6171.         VarClear(Variant(Temp));
  6172.       end;
  6173.     end
  6174.   else
  6175.     VarChangeType(Dest, Source, DestType);
  6176. end;
  6177.  
  6178. procedure _VarToInt;
  6179. asm
  6180.         XOR     EDX,EDX
  6181.         MOV     DX,[EAX].TVarData.VType
  6182.         CMP     EDX,varInteger
  6183.         JE      @@0
  6184.         CMP     EDX,varSmallint
  6185.         JE      @@1
  6186.         CMP     EDX,varByte
  6187.         JE      @@2
  6188.         CMP     EDX,varDouble
  6189.         JE      @@5
  6190.         CMP     EDX,varSingle
  6191.         JE      @@4
  6192.         CMP     EDX,varCurrency
  6193.         JE      @@3
  6194.         SUB     ESP,16
  6195.         MOV     [ESP].TVarData.VType,varEmpty
  6196.         MOV     EDX,EAX
  6197.         MOV     EAX,ESP
  6198.         MOV     ECX,varInteger
  6199.         CALL    VarCast
  6200.         MOV     EAX,[ESP].TVarData.VInteger
  6201.         ADD     ESP,16
  6202.         RET
  6203. @@0:    MOV     EAX,[EAX].TVarData.VInteger
  6204.         RET
  6205. @@1:    MOVSX   EAX,[EAX].TVarData.VSmallint
  6206.         RET
  6207. @@2:    MOVZX   EAX,[EAX].TVarData.VByte
  6208.         RET
  6209. @@3:    FILD    [EAX].TVarData.VCurrency
  6210.         FDIV    C10000
  6211.         JMP     @@6
  6212. @@4:    FLD     [EAX].TVarData.VSingle
  6213.         JMP     @@6
  6214. @@5:    FLD     [EAX].TVarData.VDouble
  6215. @@6:    PUSH    EAX
  6216.         FISTP   DWORD PTR [ESP]
  6217.         FWAIT
  6218.         POP     EAX
  6219. end;
  6220.  
  6221. procedure _VarToBool;
  6222. asm
  6223.         CMP     [EAX].TVarData.VType,varBoolean
  6224.         JE      @@1
  6225.         SUB     ESP,16
  6226.         MOV     [ESP].TVarData.VType,varEmpty
  6227.         MOV     EDX,EAX
  6228.         MOV     EAX,ESP
  6229.         MOV     ECX,varBoolean
  6230.         CALL    VarCast
  6231.         MOV     AX,[ESP].TVarData.VBoolean
  6232.         ADD     ESP,16
  6233.         JMP     @@2
  6234. @@1:    MOV     AX,[EAX].TVarData.VBoolean
  6235. @@2:    NEG     AX
  6236.         SBB     EAX,EAX
  6237.         NEG     EAX
  6238. end;
  6239.  
  6240. procedure _VarToReal;
  6241. asm
  6242.         XOR     EDX,EDX
  6243.         MOV     DX,[EAX].TVarData.VType
  6244.         CMP     EDX,varDouble
  6245.         JE      @@1
  6246.         CMP     EDX,varSingle
  6247.         JE      @@2
  6248.         CMP     EDX,varCurrency
  6249.         JE      @@3
  6250.         CMP     EDX,varInteger
  6251.         JE      @@4
  6252.         CMP     EDX,varSmallint
  6253.         JE      @@5
  6254.         CMP     EDX,varDate
  6255.         JE      @@1
  6256.         SUB     ESP,16
  6257.         MOV     [ESP].TVarData.VType,varEmpty
  6258.         MOV     EDX,EAX
  6259.         MOV     EAX,ESP
  6260.         MOV     ECX,varDouble
  6261.         CALL    VarCast
  6262.         FLD     [ESP].TVarData.VDouble
  6263.         ADD     ESP,16
  6264.         RET
  6265. @@1:    FLD     [EAX].TVarData.VDouble
  6266.         RET
  6267. @@2:    FLD     [EAX].TVarData.VSingle
  6268.         RET
  6269. @@3:    FILD    [EAX].TVarData.VCurrency
  6270.         FDIV    C10000
  6271.         RET
  6272. @@4:    FILD    [EAX].TVarData.VInteger
  6273.         RET
  6274. @@5:    FILD    [EAX].TVarData.VSmallint
  6275. end;
  6276.  
  6277. procedure _VarToCurr;
  6278. asm
  6279.         XOR     EDX,EDX
  6280.         MOV     DX,[EAX].TVarData.VType
  6281.         CMP     EDX,varCurrency
  6282.         JE      @@1
  6283.         CMP     EDX,varDouble
  6284.         JE      @@2
  6285.         CMP     EDX,varSingle
  6286.         JE      @@3
  6287.         CMP     EDX,varInteger
  6288.         JE      @@4
  6289.         CMP     EDX,varSmallint
  6290.         JE      @@5
  6291.         SUB     ESP,16
  6292.         MOV     [ESP].TVarData.VType,varEmpty
  6293.         MOV     EDX,EAX
  6294.         MOV     EAX,ESP
  6295.         MOV     ECX,varCurrency
  6296.         CALL    VarCast
  6297.         FILD    [ESP].TVarData.VCurrency
  6298.         ADD     ESP,16
  6299.         RET
  6300. @@1:    FILD    [EAX].TVarData.VCurrency
  6301.         RET
  6302. @@2:    FLD     [EAX].TVarData.VDouble
  6303.         JMP     @@6
  6304. @@3:    FLD     [EAX].TVarData.VSingle
  6305.         JMP     @@6
  6306. @@4:    FILD    [EAX].TVarData.VInteger
  6307.         JMP     @@6
  6308. @@5:    FILD    [EAX].TVarData.VSmallint
  6309. @@6:    FMUL    C10000
  6310. end;
  6311.  
  6312. procedure _VarToPStr(var S; const V: Variant);
  6313. var
  6314.   Temp: string;
  6315. begin
  6316.   _VarToLStr(Temp, V);
  6317.   ShortString(S) := Temp;
  6318. end;
  6319.  
  6320. procedure _VarToLStr(var S: string; const V: Variant);
  6321. asm
  6322.         CMP     [EDX].TVarData.VType,varString
  6323.         JNE     @@1
  6324.         MOV     EDX,[EDX].TVarData.VString
  6325.         JMP     _LStrAsg
  6326. @@1:    PUSH    EBX
  6327.         MOV     EBX,EAX
  6328.         SUB     ESP,16
  6329.         MOV     [ESP].TVarData.VType,varEmpty
  6330.         MOV     EAX,ESP
  6331.         MOV     ECX,varString
  6332.         CALL    VarCast
  6333.         MOV     EAX,EBX
  6334.         CALL    _LStrClr
  6335.         MOV     EAX,[ESP].TVarData.VString
  6336.         MOV     [EBX],EAX
  6337.         ADD     ESP,16
  6338.         POP     EBX
  6339. end;
  6340.  
  6341. procedure _VarFromInt;
  6342. asm
  6343.         CMP     [EAX].TVarData.VType,varOleStr
  6344.         JB      @@1
  6345.         PUSH    EAX
  6346.         PUSH    EDX
  6347.         CALL    VarClear
  6348.         POP     EDX
  6349.         POP     EAX
  6350. @@1:    MOV     [EAX].TVarData.VType,varInteger
  6351.         MOV     [EAX].TVarData.VInteger,EDX
  6352. end;
  6353.  
  6354. procedure _VarFromBool;
  6355. asm
  6356.         CMP     [EAX].TVarData.VType,varOleStr
  6357.         JB      @@1
  6358.         PUSH    EAX
  6359.         PUSH    EDX
  6360.         CALL    VarClear
  6361.         POP     EDX
  6362.         POP     EAX
  6363. @@1:    MOV     [EAX].TVarData.VType,varBoolean
  6364.         NEG     DL
  6365.         SBB     EDX,EDX
  6366.         MOV     [EAX].TVarData.VBoolean,DX
  6367. end;
  6368.  
  6369. procedure _VarFromReal;
  6370. asm
  6371.         CMP     [EAX].TVarData.VType,varOleStr
  6372.         JB      @@1
  6373.         PUSH    EAX
  6374.         CALL    VarClear
  6375.         POP     EAX
  6376. @@1:    MOV     [EAX].TVarData.VType,varDouble
  6377.         FSTP    [EAX].TVarData.VDouble
  6378.         FWAIT
  6379. end;
  6380.  
  6381. procedure _VarFromTDateTime;
  6382. asm
  6383.         CMP     [EAX].TVarData.VType,varOleStr
  6384.         JB      @@1
  6385.         PUSH    EAX
  6386.         CALL    VarClear
  6387.         POP     EAX
  6388. @@1:    MOV     [EAX].TVarData.VType,varDate
  6389.         FSTP    [EAX].TVarData.VDouble
  6390.         FWAIT
  6391. end;
  6392.  
  6393. procedure _VarFromCurr;
  6394. asm
  6395.         CMP     [EAX].TVarData.VType,varOleStr
  6396.         JB      @@1
  6397.         PUSH    EAX
  6398.         CALL    VarClear
  6399.         POP     EAX
  6400. @@1:    MOV     [EAX].TVarData.VType,varCurrency
  6401.         FISTP   [EAX].TVarData.VCurrency
  6402.         FWAIT
  6403. end;
  6404.  
  6405. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  6406. begin
  6407.   _VarFromLStr(V, Value);
  6408. end;
  6409.  
  6410. procedure _VarFromLStr(var V: Variant; const Value: string);
  6411. asm
  6412.         CMP     [EAX].TVarData.VType,varOleStr
  6413.         JB      @@1
  6414.         PUSH    EAX
  6415.         PUSH    EDX
  6416.         CALL    VarClear
  6417.         POP     EDX
  6418.         POP     EAX
  6419. @@1:    TEST    EDX,EDX
  6420.         JE      @@3
  6421.         MOV     ECX,[EDX-skew].StrRec.refCnt
  6422.         INC     ECX
  6423.         JLE     @@2
  6424.         MOV     [EDX-skew].StrRec.refCnt,ECX
  6425.         JMP     @@3
  6426. @@2:    PUSH    EAX
  6427.         PUSH    EDX
  6428.         MOV     EAX,[EDX-skew].StrRec.length
  6429.         CALL    _NewAnsiString
  6430.         MOV     EDX,EAX
  6431.         POP     EAX
  6432.         PUSH    EDX
  6433.         MOV     ECX,[EDX-skew].StrRec.length
  6434.         CALL    Move
  6435.         POP     EDX
  6436.         POP     EAX
  6437. @@3:    MOV     [EAX].TVarData.VType,varString
  6438.         MOV     [EAX].TVarData.VString,EDX
  6439. end;
  6440.  
  6441. procedure VarStrCat(var Dest: Variant; const Source: Variant);
  6442. begin
  6443.   Dest := string(Dest) + string(Source);
  6444. end;
  6445.  
  6446. procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
  6447. asm
  6448.         PUSH    EBX
  6449.         PUSH    ESI
  6450.         PUSH    EDI
  6451.         MOV     EDI,EAX
  6452.         MOV     ESI,EDX
  6453.         MOV     EBX,ECX
  6454.         MOV     EAX,[EDI].TVarData.VType.Integer
  6455.         MOV     EDX,[ESI].TVarData.VType.Integer
  6456.         AND     EAX,varTypeMask
  6457.         AND     EDX,varTypeMask
  6458.         CMP     EAX,varLast
  6459.         JBE     @@1
  6460.         CMP     EAX,varString
  6461.         JNE     @InvalidOp
  6462.         MOV     EAX,varOleStr
  6463. @@1:    CMP     EDX,varLast
  6464.         JBE     @@2
  6465.         CMP     EDX,varString
  6466.         JNE     @InvalidOp
  6467.         MOV     EDX,varOleStr
  6468. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  6469.         MOV     DL,BaseTypeMap.Byte[EDX]
  6470.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  6471.         CALL    @VarOpTable.Pointer[ECX*4]
  6472.         POP     EDI
  6473.         POP     ESI
  6474.         POP     EBX
  6475.         RET
  6476.  
  6477. @VarOpTable:
  6478.         DD      @VarOpError
  6479.         DD      @VarOpNull
  6480.         DD      @VarOpInteger
  6481.         DD      @VarOpReal
  6482.         DD      @VarOpCurr
  6483.         DD      @VarOpString
  6484.         DD      @VarOpBoolean
  6485.         DD      @VarOpDate
  6486.  
  6487. @VarOpError:
  6488.         POP     EAX
  6489.  
  6490. @InvalidOp:
  6491.         POP     EDI
  6492.         POP     ESI
  6493.         POP     EBX
  6494.         JMP     VarInvalidOp
  6495.  
  6496. @VarOpNull:
  6497.         MOV     EAX,EDI
  6498.         CALL    VarClear
  6499.         MOV     [EDI].TVarData.VType,varNull
  6500.         RET
  6501.  
  6502. @VarOpInteger:
  6503.         CMP     BL,opDvd
  6504.         JE      @RealOp
  6505.  
  6506. @IntegerOp:
  6507.         MOV     EAX,ESI
  6508.         CALL    _VarToInt
  6509.         PUSH    EAX
  6510.         MOV     EAX,EDI
  6511.         CALL    _VarToInt
  6512.         POP     EDX
  6513.         CALL    @IntegerOpTable.Pointer[EBX*4]
  6514.         MOV     EDX,EAX
  6515.         MOV     EAX,EDI
  6516.         JMP     _VarFromInt
  6517.  
  6518. @IntegerOpTable:
  6519.         DD      @IntegerAdd
  6520.         DD      @IntegerSub
  6521.         DD      @IntegerMul
  6522.         DD      0
  6523.         DD      @IntegerDiv
  6524.         DD      @IntegerMod
  6525.         DD      @IntegerShl
  6526.         DD      @IntegerShr
  6527.         DD      @IntegerAnd
  6528.         DD      @IntegerOr
  6529.         DD      @IntegerXor
  6530.  
  6531. @IntegerAdd:
  6532.         ADD     EAX,EDX
  6533.         JO      @IntToRealOp
  6534.         RET
  6535.  
  6536. @IntegerSub:
  6537.         SUB     EAX,EDX
  6538.         JO      @IntToRealOp
  6539.         RET
  6540.  
  6541. @IntegerMul:
  6542.         IMUL    EDX
  6543.         JO      @IntToRealOp
  6544.         RET
  6545.  
  6546. @IntegerDiv:
  6547.         MOV     ECX,EDX
  6548.         CDQ
  6549.         IDIV    ECX
  6550.         RET
  6551.  
  6552. @IntegerMod:
  6553.         MOV     ECX,EDX
  6554.         CDQ
  6555.         IDIV    ECX
  6556.         MOV     EAX,EDX
  6557.         RET
  6558.  
  6559. @IntegerShl:
  6560.         MOV     ECX,EDX
  6561.         SHL     EAX,CL
  6562.         RET
  6563.  
  6564. @IntegerShr:
  6565.         MOV     ECX,EDX
  6566.         SHR     EAX,CL
  6567.         RET
  6568.  
  6569. @IntegerAnd:
  6570.         AND     EAX,EDX
  6571.         RET
  6572.  
  6573. @IntegerOr:
  6574.         OR      EAX,EDX
  6575.         RET
  6576.  
  6577. @IntegerXor:
  6578.         XOR     EAX,EDX
  6579.         RET
  6580.  
  6581. @IntToRealOp:
  6582.         POP     EAX
  6583.         JMP     @RealOp
  6584.  
  6585. @VarOpReal:
  6586.         CMP     BL,opDiv
  6587.         JAE     @IntegerOp
  6588.  
  6589. @RealOp:
  6590.         MOV     EAX,ESI
  6591.         CALL    _VarToReal
  6592.         SUB     ESP,12
  6593.         FSTP    TBYTE PTR [ESP]
  6594.         MOV     EAX,EDI
  6595.         CALL    _VarToReal
  6596.         FLD     TBYTE PTR [ESP]
  6597.         ADD     ESP,12
  6598.         CALL    @RealOpTable.Pointer[EBX*4]
  6599.  
  6600. @RealResult:
  6601.         MOV     EAX,EDI
  6602.         JMP     _VarFromReal
  6603.  
  6604. @VarOpCurr:
  6605.         CMP     BL,opDiv
  6606.         JAE     @IntegerOp
  6607.         CMP     BL,opMul
  6608.         JAE     @CurrMulDvd
  6609.         MOV     EAX,ESI
  6610.         CALL    _VarToCurr
  6611.         SUB     ESP,12
  6612.         FSTP    TBYTE PTR [ESP]
  6613.         MOV     EAX,EDI
  6614.         CALL    _VarToCurr
  6615.         FLD     TBYTE PTR [ESP]
  6616.         ADD     ESP,12
  6617.         CALL    @RealOpTable.Pointer[EBX*4]
  6618.  
  6619. @CurrResult:
  6620.         MOV     EAX,EDI
  6621.         JMP     _VarFromCurr
  6622.  
  6623. @CurrMulDvd:
  6624.         CMP     DL,btCur
  6625.         JE      @CurrOpCurr
  6626.         MOV     EAX,ESI
  6627.         CALL    _VarToReal
  6628.         FILD    [EDI].TVarData.VCurrency
  6629.         FXCH
  6630.         CALL    @RealOpTable.Pointer[EBX*4]
  6631.         JMP     @CurrResult
  6632.  
  6633. @CurrOpCurr:
  6634.         CMP     BL,opDvd
  6635.         JE      @CurrDvdCurr
  6636.         CMP     AL,btCur
  6637.         JE      @CurrMulCurr
  6638.         MOV     EAX,EDI
  6639.         CALL    _VarToReal
  6640.         FILD    [ESI].TVarData.VCurrency
  6641.         FMUL
  6642.         JMP     @CurrResult
  6643.  
  6644. @CurrMulCurr:
  6645.         FILD    [EDI].TVarData.VCurrency
  6646.         FILD    [ESI].TVarData.VCurrency
  6647.         FMUL
  6648.         FDIV    C10000
  6649.         JMP     @CurrResult
  6650.  
  6651. @CurrDvdCurr:
  6652.         MOV     EAX,EDI
  6653.         CALL    _VarToCurr
  6654.         FILD    [ESI].TVarData.VCurrency
  6655.         FDIV
  6656.         JMP     @RealResult
  6657.  
  6658. @RealOpTable:
  6659.         DD      @RealAdd
  6660.         DD      @RealSub
  6661.         DD      @RealMul
  6662.         DD      @RealDvd
  6663.  
  6664. @RealAdd:
  6665.         FADD
  6666.         RET
  6667.  
  6668. @RealSub:
  6669.         FSUB
  6670.         RET
  6671.  
  6672. @RealMul:
  6673.         FMUL
  6674.         RET
  6675.  
  6676. @RealDvd:
  6677.         FDIV
  6678.         RET
  6679.  
  6680. @VarOpString:
  6681.         CMP     BL,opAdd
  6682.         JNE     @VarOpReal
  6683.         MOV     EAX,EDI
  6684.         MOV     EDX,ESI
  6685.         JMP     VarStrCat
  6686.  
  6687. @VarOpBoolean:
  6688.         CMP     BL,opAnd
  6689.         JB      @VarOpReal
  6690.         MOV     EAX,ESI
  6691.         CALL    _VarToBool
  6692.         PUSH    EAX
  6693.         MOV     EAX,EDI
  6694.         CALL    _VarToBool
  6695.         POP     EDX
  6696.         CALL    @IntegerOpTable.Pointer[EBX*4]
  6697.         MOV     EDX,EAX
  6698.         MOV     EAX,EDI
  6699.         JMP     _VarFromBool
  6700.  
  6701. @VarOpDate:
  6702.         CMP     BL,opSub
  6703.         JA      @VarOpReal
  6704.         JB      @DateOp
  6705.         MOV     AH,DL
  6706.         CMP     AX,btDat+btDat*256
  6707.         JE      @RealOp
  6708.  
  6709. @DateOp:
  6710.         CALL    @RealOp
  6711.         MOV     [EDI].TVarData.VType,varDate
  6712.         RET
  6713. end;
  6714.  
  6715. procedure _VarAdd;
  6716. asm
  6717.         MOV     ECX,opAdd
  6718.         JMP     VarOp
  6719. end;
  6720.  
  6721. procedure _VarSub;
  6722. asm
  6723.         MOV     ECX,opSub
  6724.         JMP     VarOp
  6725. end;
  6726.  
  6727. procedure _VarMul;
  6728. asm
  6729.         MOV     ECX,opMul
  6730.         JMP     VarOp
  6731. end;
  6732.  
  6733. procedure _VarDiv;
  6734. asm
  6735.         MOV     ECX,opDiv
  6736.         JMP     VarOp
  6737. end;
  6738.  
  6739. procedure _VarMod;
  6740. asm
  6741.         MOV     ECX,opMod
  6742.         JMP     VarOp
  6743. end;
  6744.  
  6745. procedure _VarAnd;
  6746. asm
  6747.         MOV     ECX,opAnd
  6748.         JMP     VarOp
  6749. end;
  6750.  
  6751. procedure _VarOr;
  6752. asm
  6753.         MOV     ECX,opOr
  6754.         JMP     VarOp
  6755. end;
  6756.  
  6757. procedure _VarXor;
  6758. asm
  6759.         MOV     ECX,opXor
  6760.         JMP     VarOp
  6761. end;
  6762.  
  6763. procedure _VarShl;
  6764. asm
  6765.         MOV     ECX,opShl
  6766.         JMP     VarOp
  6767. end;
  6768.  
  6769. procedure _VarShr;
  6770. asm
  6771.         MOV     ECX,opShr
  6772.         JMP     VarOp
  6773. end;
  6774.  
  6775. procedure _VarRDiv;
  6776. asm
  6777.         MOV     ECX,opDvd
  6778.         JMP     VarOp
  6779. end;
  6780.  
  6781. function VarCompareString(const S1, S2: string): Integer;
  6782. asm
  6783.         PUSH    ESI
  6784.         PUSH    EDI
  6785.         MOV     ESI,EAX
  6786.         MOV     EDI,EDX
  6787.         OR      EAX,EAX
  6788.         JE      @@1
  6789.         MOV     EAX,[EAX-4]
  6790. @@1:    OR      EDX,EDX
  6791.         JE      @@2
  6792.         MOV     EDX,[EDX-4]
  6793. @@2:    MOV     ECX,EAX
  6794.         CMP     ECX,EDX
  6795.         JBE     @@3
  6796.         MOV     ECX,EDX
  6797. @@3:    CMP     ECX,ECX
  6798.         REPE    CMPSB
  6799.         JE      @@4
  6800.         MOVZX   EAX,BYTE PTR [ESI-1]
  6801.         MOVZX   EDX,BYTE PTR [EDI-1]
  6802. @@4:    SUB     EAX,EDX
  6803.         POP     EDI
  6804.         POP     ESI
  6805. end;
  6806.  
  6807. function VarCmpStr(const V1, V2: Variant): Integer;
  6808. begin
  6809.   Result := VarCompareString(V1, V2);
  6810. end;
  6811.  
  6812. procedure _VarCmp;
  6813. asm
  6814.         PUSH    ESI
  6815.         PUSH    EDI
  6816.         MOV     EDI,EAX
  6817.         MOV     ESI,EDX
  6818.         MOV     EAX,[EDI].TVarData.VType.Integer
  6819.         MOV     EDX,[ESI].TVarData.VType.Integer
  6820.         AND     EAX,varTypeMask
  6821.         AND     EDX,varTypeMask
  6822.         CMP     EAX,varLast
  6823.         JBE     @@1
  6824.         CMP     EAX,varString
  6825.         JNE     @VarCmpError
  6826.         MOV     EAX,varOleStr
  6827. @@1:    CMP     EDX,varLast
  6828.         JBE     @@2
  6829.         CMP     EDX,varString
  6830.         JNE     @VarCmpError
  6831.         MOV     EDX,varOleStr
  6832. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  6833.         MOV     DL,BaseTypeMap.Byte[EDX]
  6834.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  6835.         JMP     @VarCmpTable.Pointer[ECX*4]
  6836.  
  6837. @VarCmpTable:
  6838.         DD      @VarCmpError
  6839.         DD      @VarCmpNull
  6840.         DD      @VarCmpInteger
  6841.         DD      @VarCmpReal
  6842.         DD      @VarCmpCurr
  6843.         DD      @VarCmpString
  6844.         DD      @VarCmpBoolean
  6845.         DD      @VarCmpDate
  6846.  
  6847. @VarCmpError:
  6848.         POP     EDI
  6849.         POP     ESI
  6850.         JMP     VarInvalidOp
  6851.  
  6852. @VarCmpNull:
  6853.         CMP     AL,DL
  6854.         JMP     @Exit
  6855.  
  6856. @VarCmpInteger:
  6857.         MOV     EAX,ESI
  6858.         CALL    _VarToInt
  6859.         XCHG    EAX,EDI
  6860.         CALL    _VarToInt
  6861.         CMP     EAX,EDI
  6862.         JMP     @Exit
  6863.  
  6864. @VarCmpReal:
  6865. @VarCmpDate:
  6866.         MOV     EAX,EDI
  6867.         CALL    _VarToReal
  6868.         SUB     ESP,12
  6869.         FSTP    TBYTE PTR [ESP]
  6870.         MOV     EAX,ESI
  6871.         CALL    _VarToReal
  6872.         FLD     TBYTE PTR [ESP]
  6873.         ADD     ESP,12
  6874.  
  6875. @RealCmp:
  6876.         FCOMPP
  6877.         FNSTSW  AX
  6878.         MOV     AL,AH   { Move CF into SF }
  6879.         AND     AX,4001H
  6880.         ROR     AL,1
  6881.         OR      AH,AL
  6882.         SAHF
  6883.         JMP     @Exit
  6884.  
  6885. @VarCmpCurr:
  6886.         MOV     EAX,EDI
  6887.         CALL    _VarToCurr
  6888.         SUB     ESP,12
  6889.         FSTP    TBYTE PTR [ESP]
  6890.         MOV     EAX,ESI
  6891.         CALL    _VarToCurr
  6892.         FLD     TBYTE PTR [ESP]
  6893.         ADD     ESP,12
  6894.         JMP     @RealCmp
  6895.  
  6896. @VarCmpString:
  6897.         MOV     EAX,EDI
  6898.         MOV     EDX,ESI
  6899.         CALL    VarCmpStr
  6900.         CMP     EAX,0
  6901.         JMP     @Exit
  6902.  
  6903. @VarCmpBoolean:
  6904.         MOV     EAX,ESI
  6905.         CALL    _VarToBool
  6906.         XCHG    EAX,EDI
  6907.         CALL    _VarToBool
  6908.         MOV     EDX,EDI
  6909.         CMP     AL,DL
  6910.  
  6911. @Exit:
  6912.         POP     EDI
  6913.         POP     ESI
  6914. end;
  6915.  
  6916. procedure _VarNeg;
  6917. asm
  6918.         MOV     EDX,[EAX].TVarData.VType.Integer
  6919.         AND     EDX,varTypeMask
  6920.         CMP     EDX,varLast
  6921.         JBE     @@1
  6922.         CMP     EDX,varString
  6923.         JNE     @VarNegError
  6924.         MOV     EDX,varOleStr
  6925. @@1:    MOV     DL,BaseTypeMap.Byte[EDX]
  6926.         JMP     @VarNegTable.Pointer[EDX*4]
  6927.  
  6928. @VarNegTable:
  6929.         DD      @VarNegError
  6930.         DD      @VarNegNull
  6931.         DD      @VarNegInteger
  6932.         DD      @VarNegReal
  6933.         DD      @VarNegCurr
  6934.         DD      @VarNegReal
  6935.         DD      @VarNegInteger
  6936.         DD      @VarNegDate
  6937.  
  6938. @VarNegError:
  6939.         JMP     VarInvalidOp
  6940.  
  6941. @VarNegNull:
  6942.         RET
  6943.  
  6944. @VarNegInteger:
  6945.         PUSH    EAX
  6946.         CALL    _VarToInt
  6947.         NEG     EAX
  6948.         MOV     EDX,EAX
  6949.         POP     EAX
  6950.         JMP     _VarFromInt
  6951.  
  6952. @VarNegReal:
  6953.         PUSH    EAX
  6954.         CALL    _VarToReal
  6955.         FCHS
  6956.         POP     EAX
  6957.         JMP     _VarFromReal
  6958.  
  6959. @VarNegCurr:
  6960.         FILD    [EAX].TVarData.VCurrency
  6961.         FCHS
  6962.         FISTP   [EAX].TVarData.VCurrency
  6963.         FWAIT
  6964.         RET
  6965.  
  6966. @VarNegDate:
  6967.         FLD     [EAX].TVarData.VDate
  6968.         FCHS
  6969.         FSTP    [EAX].TVarData.VDate
  6970.         FWAIT
  6971. end;
  6972.  
  6973. procedure _VarNot;
  6974. asm
  6975.         MOV     EDX,[EAX].TVarData.VType.Integer
  6976.         AND     EDX,varTypeMask
  6977.         JE      @@2
  6978.         CMP     EDX,varBoolean
  6979.         JE      @@3
  6980.         CMP     EDX,varNull
  6981.         JE      @@4
  6982.         CMP     EDX,varLast
  6983.         JBE     @@1
  6984.         CMP     EDX,varString
  6985.         JNE     @@2
  6986. @@1:    PUSH    EAX
  6987.         CALL    _VarToInt
  6988.         NOT     EAX
  6989.         MOV     EDX,EAX
  6990.         POP     EAX
  6991.         JMP     _VarFromInt
  6992. @@2:    JMP     VarInvalidOp
  6993. @@3:    MOV     DX,[EAX].TVarData.VBoolean
  6994.         NEG     DX
  6995.         SBB     EDX,EDX
  6996.         NOT     EDX
  6997.         MOV     [EAX].TVarData.VBoolean,DX
  6998. @@4:
  6999. end;
  7000.  
  7001. procedure _VarCopy;
  7002. asm
  7003.         JMP     VarCopy
  7004. end;
  7005.  
  7006. procedure _VarClr;
  7007. asm
  7008.         JMP     VarClear
  7009. end;
  7010.  
  7011. procedure _VarAddRef;
  7012. asm
  7013.         CMP     [EAX].TVarData.VType,varOleStr
  7014.         JB      @@1
  7015.         PUSH    [EAX].Integer[12]
  7016.         PUSH    [EAX].Integer[8]
  7017.         PUSH    [EAX].Integer[4]
  7018.         PUSH    [EAX].Integer[0]
  7019.         MOV     [EAX].TVarData.VType,varEmpty
  7020.         MOV     EDX,ESP
  7021.         CALL    VarCopy
  7022.         ADD     ESP,16
  7023. @@1:
  7024. end;
  7025.  
  7026. function VarType(const V: Variant): Integer;
  7027. asm
  7028.         MOVZX   EAX,[EAX].TVarData.VType
  7029. end;
  7030.  
  7031. function VarAsType(const V: Variant; VarType: Integer): Variant;
  7032. begin
  7033.   VarCast(Result, V, VarType);
  7034. end;
  7035.  
  7036. function VarIsEmpty(const V: Variant): Boolean;
  7037. begin
  7038.   with TVarData(V) do
  7039.     Result := (VType = varEmpty) or ((VType = varDispatch) or
  7040.       (VType = varUnknown)) and (VDispatch = nil);
  7041. end;
  7042.  
  7043. function VarIsNull(const V: Variant): Boolean;
  7044. begin
  7045.   Result := TVarData(V).VType = varNull;
  7046. end;
  7047.  
  7048. function VarToStr(const V: Variant): string;
  7049. begin
  7050.   if TVarData(V).VType <> varNull then Result := V else Result := '';
  7051. end;
  7052.  
  7053. function VarFromDateTime(DateTime: TDateTime): Variant;
  7054. begin
  7055.   VarClear(Result);
  7056.   TVarData(Result).VType := varDate;
  7057.   TVarData(Result).VDate := DateTime;
  7058. end;
  7059.  
  7060. function VarToDateTime(const V: Variant): TDateTime;
  7061. var
  7062.   Temp: TVarData;
  7063. begin
  7064.   Temp.VType := varEmpty;
  7065.   VarCast(Variant(Temp), V, varDate);
  7066.   Result := Temp.VDate;
  7067. end;
  7068.  
  7069. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  7070. var
  7071.   S: string;
  7072. begin
  7073.   if TVarData(V).VType >= varSmallint then S := V;
  7074.   Write(T, S: Width);
  7075.   Result := @T;
  7076. end;
  7077.  
  7078. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  7079. begin
  7080.   Result := _WriteVariant(T, V, 0);
  7081. end;
  7082.  
  7083. { ----------------------------------------------------- }
  7084. {       Variant array support                           }
  7085. { ----------------------------------------------------- }
  7086.  
  7087. function VarArrayCreate(const Bounds: array of Integer;
  7088.   VarType: Integer): Variant;
  7089. var
  7090.   I, DimCount: Integer;
  7091.   VarArrayRef: PVarArray;
  7092.   VarBounds: array[0..63] of TVarArrayBound;
  7093. begin
  7094.   if not Odd(High(Bounds)) or (High(Bounds) > 127) then
  7095.     Error(reVarArrayCreate);
  7096.   DimCount := (High(Bounds) + 1) div 2;
  7097.   for I := 0 to DimCount - 1 do
  7098.     with VarBounds[I] do
  7099.     begin
  7100.       LowBound := Bounds[I * 2];
  7101.       ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
  7102.     end;
  7103.   VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
  7104.   if VarArrayRef = nil then Error(reVarArrayCreate);
  7105.   VarClear(Result);
  7106.   TVarData(Result).VType := VarType or varArray;
  7107.   TVarData(Result).VArray := VarArrayRef;
  7108. end;
  7109.  
  7110. function VarArrayOf(const Values: array of Variant): Variant;
  7111. var
  7112.   I: Integer;
  7113. begin
  7114.   Result := VarArrayCreate([0, High(Values)], varVariant);
  7115.   for I := 0 to High(Values) do Result[I] := Values[I];
  7116. end;
  7117.  
  7118. procedure VarArrayRedim(var A: Variant; HighBound: Integer);
  7119. var
  7120.   VarBound: TVarArrayBound;
  7121. begin
  7122.   if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
  7123.     Error(reVarNotArray);
  7124.   with TVarData(A).VArray^ do
  7125.     VarBound.LowBound := Bounds[DimCount - 1].LowBound;
  7126.   VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
  7127.   if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
  7128.     Error(reVarArrayCreate);
  7129. end;
  7130.  
  7131. function GetVarArray(const A: Variant): PVarArray;
  7132. begin
  7133.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  7134.   if TVarData(A).VType and varByRef <> 0 then
  7135.     Result := PVarArray(TVarData(A).VPointer^) else
  7136.     Result := TVarData(A).VArray;
  7137. end;
  7138.  
  7139. function VarArrayDimCount(const A: Variant): Integer;
  7140. begin
  7141.   if TVarData(A).VType and varArray <> 0 then
  7142.     Result := GetVarArray(A)^.DimCount else
  7143.     Result := 0;
  7144. end;
  7145.  
  7146. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  7147. begin
  7148.   if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
  7149.     Error(reVarArrayBounds);
  7150. end;
  7151.  
  7152. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  7153. begin
  7154.   if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
  7155.     Error(reVarArrayBounds);
  7156. end;
  7157.  
  7158. function VarArrayLock(const A: Variant): Pointer;
  7159. begin
  7160.   if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
  7161.     Error(reVarNotArray);
  7162. end;
  7163.  
  7164. procedure VarArrayUnlock(const A: Variant);
  7165. begin
  7166.   if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
  7167.     Error(reVarNotArray);
  7168. end;
  7169.  
  7170. function VarArrayRef(const A: Variant): Variant;
  7171. begin
  7172.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  7173.   VarClear(Result);
  7174.   TVarData(Result).VType := TVarData(A).VType or varByRef;
  7175.   if TVarData(A).VType and varByRef <> 0 then
  7176.     TVarData(Result).VPointer := TVarData(A).VPointer else
  7177.     TVarData(Result).VPointer := @TVarData(A).VArray;
  7178. end;
  7179.  
  7180. function VarIsArray(const A: Variant): Boolean;
  7181. begin
  7182.   Result := TVarData(A).VType and varArray <> 0;
  7183. end;
  7184.  
  7185. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  7186.   Indices: Integer): Variant; cdecl;
  7187. var
  7188.   VarArrayPtr: PVarArray;
  7189.   VarType: Integer;
  7190. begin
  7191.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  7192.   VarArrayPtr := GetVarArray(A);
  7193.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  7194.   VarType := TVarData(A).VType and varTypeMask;
  7195.   if VarType = varVariant then
  7196.   begin
  7197.     if SafeArrayGetElement(VarArrayPtr, @Indices, @Result) <> 0 then
  7198.       Error(reVarArrayBounds);
  7199.   end else
  7200.   begin
  7201.     VarClear(Result);
  7202.     if SafeArrayGetElement(VarArrayPtr, @Indices,
  7203.       @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
  7204.     TVarData(Result).VType := VarType;
  7205.   end;
  7206. end;
  7207.  
  7208. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  7209.   IndexCount: Integer; Indices: Integer); cdecl;
  7210. var
  7211.   VarArrayPtr: PVarArray;
  7212.   VarType: Integer;
  7213.   P: Pointer;
  7214.   Temp: TVarData;
  7215. begin
  7216.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  7217.   VarArrayPtr := GetVarArray(A);
  7218.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  7219.   VarType := TVarData(A).VType and varTypeMask;
  7220.   if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  7221.   begin
  7222.     if SafeArrayPutElement(VarArrayPtr, @Indices, @Value) <> 0 then
  7223.       Error(reVarArrayBounds);
  7224.   end else
  7225.   begin
  7226.     Temp.VType := varEmpty;
  7227.     try
  7228.       if VarType = varVariant then
  7229.       begin
  7230.         VarStringToOleStr(Variant(Temp), Value);
  7231.         P := @Temp;
  7232.       end else
  7233.       begin
  7234.         VarCast(Variant(Temp), Value, VarType);
  7235.         case VarType of
  7236.           varOleStr, varDispatch, varUnknown:
  7237.             P := Temp.VPointer;
  7238.         else
  7239.           P := @Temp.VPointer;
  7240.         end;
  7241.       end;
  7242.       if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
  7243.         Error(reVarArrayBounds);
  7244.     finally
  7245.       VarClear(Variant(Temp));
  7246.     end;
  7247.   end;
  7248. end;
  7249.  
  7250. { Exit procedure handling, copied from SYSUTILS.PAS }
  7251.  
  7252. type
  7253.   PExitProcInfo = ^TExitProcInfo;
  7254.   TExitProcInfo = record
  7255.     Next: PExitProcInfo;
  7256.     SaveExit: Pointer;
  7257.     Proc: Procedure;
  7258.   end;
  7259.  
  7260. var
  7261.   ExitProcList: PExitProcInfo;
  7262.  
  7263. procedure DoExitProc;
  7264. var
  7265.   P: PExitProcInfo;
  7266.   Proc: Procedure;
  7267. begin
  7268.   P := ExitProcList;
  7269.   ExitProcList := P^.Next;
  7270.   ExitProc := P^.SaveExit;
  7271.   Proc := P^.Proc;
  7272.   Proc;
  7273. end;
  7274.  
  7275. procedure _AddExitProc(PP: Pointer);
  7276. var
  7277.   P: PExitProcInfo;
  7278. begin
  7279.   P := PP;
  7280.   P.Next := ExitProcList;
  7281.   P.SaveExit := ExitProc;
  7282.   ExitProcList := P;
  7283.   ExitProc := @DoExitProc;
  7284. end;
  7285.  
  7286.  
  7287. begin
  7288.  
  7289.   TlsIndex4 := TlsIndex*4;
  7290.  
  7291.   ExitCode  := 0;
  7292.   ExitProc  := nil;
  7293.   ErrorAddr := nil;
  7294.  
  7295.   InOutRes := 0;
  7296.   RandSeed := 0;
  7297.   FileMode := 2;
  7298.  
  7299.   Test8086 := 2;
  7300.   Test8087 := 3;
  7301.  
  7302.   TVarData(Unassigned).VType := varEmpty;
  7303.   TVarData(Null).VType := varNull;
  7304.  
  7305.   _FpuInit();
  7306.  
  7307.   _Assign( Input, '' );  { _ResetText( Input );   }
  7308.   _Assign( Output, '' );  { _RewritText( Output ); }
  7309.  
  7310. end.
  7311.