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