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