home *** CD-ROM | disk | FTP | other *** search
/ Delphi 5 for Professionals / DELPHI5.iso / AddOns / Components / Cell Control / DATA1.CAB / DELPHIDM / System.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-01-11  |  247.7 KB  |  9,596 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.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4290.         JE      @@DelphiException
  4291.         CLD
  4292.         CALL    _FpuInit
  4293.  
  4294. @@DelphiException:
  4295.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  4296.  
  4297.         PUSH    ESI
  4298.         PUSH    EDI
  4299.         PUSH    EBP
  4300.  
  4301.         MOV     EDX,[ESP+8+3*4]
  4302.  
  4303.         PUSH    0
  4304.         PUSH    EAX
  4305.         PUSH    offset @@returnAddress
  4306.         PUSH    EDX
  4307.         CALL    RtlUnwind
  4308.  
  4309. @@returnAddress:
  4310.         POP     EBP
  4311.         POP     EDI
  4312.         POP     ESI
  4313.         MOV     EAX,[ESP+4]
  4314.         MOV     EBX,8000FFFFH
  4315.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4316.         JNE     @@done
  4317.  
  4318.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4319.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4320.         MOV     EAX,[ESP+8]
  4321.         MOV     EAX,[EAX].TExcFrame.SelfOfMethod
  4322.         MOV     EBX,[EAX]
  4323.         CALL    [EBX].vmtSafeCallException.Pointer
  4324.         MOV     EBX,EAX
  4325. @@done:
  4326.         XOR     EAX,EAX
  4327.         MOV     ESP,[ESP+8]
  4328.         POP     ECX
  4329.         MOV     FS:[EAX],ECX
  4330.         POP     EDX
  4331.         POP     EBP
  4332.         LEA     EDX,[EDX].TExcDesc.instructions
  4333.         POP     ECX
  4334.         JMP     EDX
  4335. @@exit:
  4336.         MOV     EAX,1
  4337. end;
  4338.  
  4339.  
  4340. procedure       _RaiseExcept;
  4341. asm
  4342.         { ->    EAX     Pointer to exception object     }
  4343.         {       [ESP]   Error address           }
  4344.  
  4345.         POP     EDX
  4346.  
  4347.         PUSH    ESP
  4348.         PUSH    EBP
  4349.         PUSH    EDI
  4350.         PUSH    ESI
  4351.         PUSH    EBX
  4352.         PUSH    EAX                             { pass class argument           }
  4353.         PUSH    EDX                             { pass address argument         }
  4354.  
  4355.         PUSH    ESP                             { pass pointer to arguments             }
  4356.         PUSH    7                               { there are seven arguments               }
  4357.         PUSH    cNonContinuable                 { we can't continue execution   }
  4358.         PUSH    cDelphiException                { our magic exception code              }
  4359.         PUSH    EDX                             { pass the user's return address        }
  4360.         JMP     RaiseException
  4361. end;
  4362.  
  4363.  
  4364. procedure       _RaiseAgain;
  4365. asm
  4366.         { ->    [ESP        ] return address to user program }
  4367.         {       [ESP+ 4     ] raise list entry (4 dwords)    }
  4368.         {       [ESP+ 4+ 4*4] saved topmost frame            }
  4369.         {       [ESP+ 4+ 5*4] saved registers (4 dwords)     }
  4370.         {       [ESP+ 4+ 9*4] return address to OS           }
  4371.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4372.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4373.  
  4374.         { Point the error handler of the exception frame to something harmless }
  4375.  
  4376.         MOV     EAX,[ESP+8+10*4]
  4377.         MOV     [EAX].TExcFrame.desc,offset @@exit
  4378.  
  4379.         { Pop the RaiseList }
  4380.  
  4381.         CALL    SysInit.@GetTLS
  4382.         MOV     EDX,[EAX].RaiseList
  4383.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4384.         MOV     [EAX].RaiseList,ECX
  4385.  
  4386.         { Destroy any objects created for non-delphi exceptions }
  4387.  
  4388.         MOV     EAX,[EDX].TRaiseFrame.ExceptionRecord
  4389.         AND     [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
  4390.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4391.         JE      @@delphiException
  4392.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4393.         CALL    TObject.Free
  4394.         CALL    NotifyReRaise
  4395.  
  4396. @@delphiException:
  4397.  
  4398.         XOR     EAX,EAX
  4399.         ADD     ESP,5*4
  4400.         MOV     EDX,FS:[EAX]
  4401.         POP     ECX
  4402.         MOV     EDX,[EDX].TExcFrame.next
  4403.         MOV     [ECX].TExcFrame.next,EDX
  4404.  
  4405.         POP     EBP
  4406.         POP     EDI
  4407.         POP     ESI
  4408.         POP     EBX
  4409. @@exit:
  4410.         MOV     EAX,1
  4411. end;
  4412.  
  4413.  
  4414. procedure       _DoneExcept;
  4415. asm
  4416.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4417.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4418.  
  4419.         { Pop the RaiseList }
  4420.  
  4421.         CALL    SysInit.@GetTLS
  4422.         MOV     EDX,[EAX].RaiseList
  4423.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4424.         MOV     [EAX].RaiseList,ECX
  4425.  
  4426.         { Destroy exception object }
  4427.  
  4428.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4429.         CALL    TObject.Free
  4430.  
  4431.         POP     EDX
  4432.         MOV     ESP,[ESP+8+9*4]
  4433.         XOR     EAX,EAX
  4434.         POP     ECX
  4435.         MOV     FS:[EAX],ECX
  4436.         POP     EAX
  4437.         POP     EBP
  4438.         CALL    NotifyTerminate
  4439.         JMP     EDX
  4440. end;
  4441.  
  4442.  
  4443. procedure   _TryFinallyExit;
  4444. asm
  4445.         XOR     EDX,EDX
  4446.         MOV     ECX,[ESP+4].TExcFrame.desc
  4447.         MOV     EAX,[ESP+4].TExcFrame.next
  4448.         ADD     ECX,TExcDesc.instructions
  4449.         MOV     FS:[EDX],EAX
  4450.         CALL    ECX
  4451. @@1:    RET     12
  4452. end;
  4453.  
  4454.  
  4455. type
  4456.   PInitContext = ^TInitContext;
  4457.   TInitContext = record
  4458.     OuterContext:   PInitContext;     { saved InitContext   }
  4459.     ExcFrame:       PExcFrame;        { bottom exc handler  }
  4460.     InitTable:      PackageInfo;      { unit init info      }
  4461.     InitCount:      Integer;          { how far we got      }
  4462.     Module:         PLibModule;       { ptr to module desc  }
  4463.     DLLSaveEBP:     Pointer;          { saved regs for DLLs }
  4464.     DLLSaveEBX:     Pointer;          { saved regs for DLLs }
  4465.     DLLSaveESI:     Pointer;          { saved regs for DLLs }
  4466.     DLLSaveEDI:     Pointer;          { saved regs for DLLs }
  4467.     DLLInitState:   Byte;
  4468.     ExitProcessTLS: procedure;        { Shutdown for TLS    }
  4469.   end;
  4470.  
  4471. var
  4472.   InitContext: TInitContext;
  4473.  
  4474.  
  4475. procedure       RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
  4476. asm
  4477.         MOV     [ESP],ErrorAddr
  4478.         JMP     _RunError
  4479. end;
  4480.  
  4481. procedure       MapToRunError(P: PExceptionRecord); stdcall;
  4482. const
  4483.   STATUS_ACCESS_VIOLATION         = $C0000005;
  4484.   STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
  4485.   STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
  4486.   STATUS_FLOAT_DIVIDE_BY_ZERO     = $C000008E;
  4487.   STATUS_FLOAT_INEXACT_RESULT     = $C000008F;
  4488.   STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
  4489.   STATUS_FLOAT_OVERFLOW           = $C0000091;
  4490.   STATUS_FLOAT_STACK_CHECK        = $C0000092;
  4491.   STATUS_FLOAT_UNDERFLOW          = $C0000093;
  4492.   STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
  4493.   STATUS_INTEGER_OVERFLOW         = $C0000095;
  4494.   STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
  4495.   STATUS_STACK_OVERFLOW           = $C00000FD;
  4496.   STATUS_CONTROL_C_EXIT           = $C000013A;
  4497. var
  4498.   ErrCode: Byte;
  4499. begin
  4500.   case P.ExceptionCode of
  4501.     STATUS_INTEGER_DIVIDE_BY_ZERO:  ErrCode := 200;
  4502.     STATUS_ARRAY_BOUNDS_EXCEEDED:   ErrCode := 201;
  4503.     STATUS_FLOAT_OVERFLOW:          ErrCode := 205;
  4504.     STATUS_FLOAT_INEXACT_RESULT,
  4505.     STATUS_FLOAT_INVALID_OPERATION,
  4506.     STATUS_FLOAT_STACK_CHECK:       ErrCode := 207;
  4507.     STATUS_FLOAT_DIVIDE_BY_ZERO:    ErrCode := 200;
  4508.     STATUS_INTEGER_OVERFLOW:        ErrCode := 215;
  4509.     STATUS_FLOAT_UNDERFLOW,
  4510.     STATUS_FLOAT_DENORMAL_OPERAND:  ErrCode := 206;
  4511.     STATUS_ACCESS_VIOLATION:        ErrCode := 216;
  4512.     STATUS_PRIVILEGED_INSTRUCTION:  ErrCode := 218;
  4513.     STATUS_CONTROL_C_EXIT:          ErrCode := 217;
  4514.     STATUS_STACK_OVERFLOW:          ErrCode := 202;
  4515.   else                              ErrCode := 255;
  4516.   end;
  4517.   RunErrorAt(ErrCode, P.ExceptionAddress);
  4518. end;
  4519.  
  4520. procedure       _ExceptionHandler;
  4521. asm
  4522.         MOV     EAX,[ESP+4]
  4523.  
  4524.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4525.         JNE     @@exit
  4526.         CLD
  4527.         CALL    _FpuInit
  4528.         MOV     EDX,[ESP+8]
  4529.  
  4530.         PUSH    0
  4531.         PUSH    EAX
  4532.         PUSH    offset @@returnAddress
  4533.         PUSH    EDX
  4534.         CALL    RtlUnwind
  4535. @@returnAddress:
  4536.  
  4537.         MOV     EBX,[ESP+4]
  4538.         CMP     [EBX].TExceptionRecord.ExceptionCode,cDelphiException
  4539.         MOV     EDX,[EBX].TExceptionRecord.ExceptAddr
  4540.         MOV     EAX,[EBX].TExceptionRecord.ExceptObject
  4541.         JE      @@DelphiException2
  4542.  
  4543.         MOV     EDX,ExceptObjProc
  4544.         TEST    EDX,EDX
  4545.         JE      MapToRunError
  4546.         MOV     EAX,EBX
  4547.         CALL    EDX
  4548.         TEST    EAX,EAX
  4549.         JE      MapToRunError
  4550.         MOV     EDX,[EBX].TExceptionRecord.ExceptionAddress
  4551.  
  4552. @@DelphiException2:
  4553.  
  4554.         CALL    NotifyUnhandled
  4555.         MOV     ECX,ExceptProc
  4556.         TEST    ECX,ECX
  4557.         JE      @@noExceptProc
  4558.         CALL    ECX             { call ExceptProc(ExceptObject, ExceptAddr) }
  4559.  
  4560. @@noExceptProc:
  4561.         MOV     ECX,[ESP+4]
  4562.         MOV     EAX,217
  4563.         MOV     EDX,[ECX].TExceptionRecord.ExceptAddr
  4564.         MOV     [ESP],EDX
  4565.         JMP     _RunError
  4566.  
  4567. @@exit:
  4568.         XOR     EAX,EAX
  4569. end;
  4570.  
  4571.  
  4572. procedure       SetExceptionHandler;
  4573. asm
  4574.         XOR     EDX,EDX                 { using [EDX] saves some space over [0] }
  4575.         LEA     EAX,[EBP-12]
  4576.         MOV     ECX,FS:[EDX]            { ECX := head of chain                  }
  4577.         MOV     FS:[EDX],EAX            { head of chain := @exRegRec            }
  4578.  
  4579.         MOV     [EAX].TExcFrame.next,ECX
  4580.         MOV     [EAX].TExcFrame.desc,offset _ExceptionHandler
  4581.         MOV     [EAX].TExcFrame.hEBP,EBP
  4582.         MOV     InitContext.ExcFrame,EAX
  4583. end;
  4584.  
  4585.  
  4586. procedure       UnsetExceptionHandler;
  4587. asm
  4588.         XOR     EDX,EDX
  4589.         MOV     EAX,InitContext.ExcFrame
  4590.         MOV     ECX,FS:[EDX]    { ECX := head of chain          }
  4591.         CMP     EAX,ECX         { simple case: our record is first      }
  4592.         JNE     @@search
  4593.         MOV     EAX,[EAX]       { head of chain := exRegRec.next        }
  4594.         MOV     FS:[EDX],EAX
  4595.         JMP     @@exit
  4596.  
  4597. @@loop:
  4598.         MOV     ECX,[ECX]
  4599. @@search:
  4600.         CMP     ECX,-1          { at end of list?                       }
  4601.         JE      @@exit          { yes - didn't find it          }
  4602.         CMP     [ECX],EAX       { is it the next one on the list?       }
  4603.         JNE     @@loop          { no - look at next one on list }
  4604. @@unlink:                       { yes - unlink our record               }
  4605.         MOV     EAX,[EAX]       { get next record on list               }
  4606.         MOV     [ECX],EAX       { unlink our record                     }
  4607. @@exit:
  4608. end;
  4609.  
  4610.  
  4611. procedure FInitUnits;
  4612. var
  4613.   Count: Integer;
  4614.   Table: PUnitEntryTable;
  4615.   P: procedure;
  4616. begin
  4617.   if InitContext.InitTable = nil then
  4618.         exit;
  4619.   Count := InitContext.InitCount;
  4620.   Table := InitContext.InitTable^.UnitInfo;
  4621.   try
  4622.     while Count > 0 do
  4623.     begin
  4624.       Dec(Count);
  4625.       InitContext.InitCount := Count;
  4626.       P := Table^[Count].FInit;
  4627.       if Assigned(P) then
  4628.         P;
  4629.     end;
  4630.   except
  4631.     FInitUnits;  { try to finalize the others }
  4632.     raise;
  4633.   end;
  4634. end;
  4635.  
  4636.  
  4637. procedure InitUnits;
  4638. var
  4639.   Count, I: Integer;
  4640.   Table: PUnitEntryTable;
  4641.   P: procedure;
  4642. begin
  4643.   if InitContext.InitTable = nil then
  4644.         exit;
  4645.   Count := InitContext.InitTable^.UnitCount;
  4646.   I := 0;
  4647.   Table := InitContext.InitTable^.UnitInfo;
  4648.   try
  4649.     while I < Count do
  4650.     begin
  4651.       P := Table^[I].Init;
  4652.       Inc(I);
  4653.       InitContext.InitCount := I;
  4654.       if Assigned(P) then
  4655.         P;
  4656.     end;
  4657.   except
  4658.     FInitUnits;
  4659.     raise;
  4660.   end;
  4661. end;
  4662.  
  4663.  
  4664. procedure _PackageLoad(const Table : PackageInfo);
  4665. var
  4666.   SavedContext: TInitContext;
  4667. begin
  4668.   SavedContext := InitContext;
  4669.   InitContext.DLLInitState := 0;
  4670.   InitContext.InitTable := Table;
  4671.   InitContext.InitCount := 0;
  4672.   InitContext.OuterContext := @SavedContext;
  4673.   try
  4674.     InitUnits;
  4675.   finally
  4676.     InitContext := SavedContext;
  4677.   end;
  4678. end;
  4679.  
  4680.  
  4681. procedure _PackageUnload(const Table : PackageInfo);
  4682. var
  4683.   SavedContext: TInitContext;
  4684. begin
  4685.   SavedContext := InitContext;
  4686.   InitContext.DLLInitState := 0;
  4687.   InitContext.InitTable := Table;
  4688.   InitContext.InitCount := Table^.UnitCount;
  4689.   InitContext.OuterContext := @SavedContext;
  4690.   try
  4691.     FInitUnits;
  4692.   finally
  4693.     InitContext := SavedContext;
  4694.   end;
  4695. end;
  4696.  
  4697.  
  4698. procedure       _StartExe;
  4699. asm
  4700.         { ->    EAX InitTable   }
  4701.         {       EDX Module      }
  4702.         MOV     InitContext.InitTable,EAX
  4703.         XOR     EAX,EAX
  4704.         MOV     InitContext.InitCount,EAX
  4705.         MOV     InitContext.Module,EDX
  4706.         MOV     EAX,[EDX].TLibModule.Instance
  4707.         MOV     MainInstance,EAX
  4708.  
  4709.         CALL    SetExceptionHandler
  4710.  
  4711.         MOV     IsLibrary,0
  4712.  
  4713.         CALL    InitUnits;
  4714. end;
  4715.  
  4716.  
  4717. procedure       _StartLib;
  4718. asm
  4719.         { ->    EAX InitTable   }
  4720.         {       EDX Module      }
  4721.         {       ECX InitTLS     }
  4722.         {       [ESP+4] DllProc }
  4723.         {       [EBP+8] HInst   }
  4724.         {       [EBP+12] Reason }
  4725.  
  4726.         { Push some desperately needed registers }
  4727.  
  4728.         PUSH    ECX
  4729.         PUSH    ESI
  4730.         PUSH    EDI
  4731.  
  4732.         { Save the current init context into the stackframe of our caller }
  4733.  
  4734.         MOV     ESI,offset InitContext
  4735.         LEA     EDI,[EBP- (type TExcFrame) - (type TInitContext)]
  4736.         MOV     ECX,(type TInitContext)/4
  4737.         REP     MOVSD
  4738.  
  4739.         { Setup the current InitContext }
  4740.  
  4741.         POP     InitContext.DLLSaveEDI
  4742.         POP     InitContext.DLLSaveESI
  4743.         MOV     InitContext.DLLSaveEBP,EBP
  4744.         MOV     InitContext.DLLSaveEBX,EBX
  4745.         MOV     InitContext.InitTable,EAX
  4746.         MOV     InitContext.Module,EDX
  4747.         LEA     ECX,[EBP- (type TExcFrame) - (type TInitContext)]
  4748.         MOV     InitContext.OuterContext,ECX
  4749.         XOR     ECX,ECX
  4750.         CMP     dword ptr [EBP+12],0
  4751.         JNE     @@notShutDown
  4752.         MOV     ECX,[EAX].PackageInfoTable.UnitCount
  4753. @@notShutDown:
  4754.         MOV     InitContext.InitCount,ECX
  4755.  
  4756.         CALL    SetExceptionHandler
  4757.  
  4758.         MOV     EAX,[EBP+12]
  4759.         INC     EAX
  4760.         MOV     InitContext.DLLInitState,AL
  4761.         DEC     EAX
  4762.  
  4763.         { Init any needed TLS }
  4764.  
  4765.         POP     ECX
  4766.         MOV     EDX,[ECX]
  4767.         MOV     InitContext.ExitProcessTLS,EDX
  4768.         JE      @@noTLSproc
  4769.         CALL    dword ptr [ECX+EAX*4]
  4770. @@noTLSproc:
  4771.  
  4772.         { Call any DllProc }
  4773.  
  4774.         MOV     EDX,[ESP+4]
  4775.         TEST    EDX,EDX
  4776.         JE      @@noDllProc
  4777.         MOV     EAX,[EBP+12]
  4778.         CALL    EDX
  4779. @@noDllProc:
  4780.  
  4781.         { Set IsLibrary if there was no exe yet }
  4782.  
  4783.         CMP     MainInstance,0
  4784.         JNE     @@haveExe
  4785.         MOV     IsLibrary,1
  4786. @@haveExe:
  4787.  
  4788.         MOV     EAX,[EBP+12]
  4789.         DEC     EAX
  4790.         JNE     _Halt0
  4791.         CALL    InitUnits
  4792.         RET     4
  4793. end;
  4794.  
  4795.  
  4796. procedure _InitResStrings;
  4797. asm
  4798.         { ->    EAX     Pointer to init table               }
  4799.         {                 record                            }
  4800.         {                   cnt: Integer;                   }
  4801.         {                   tab: array [1..cnt] record      }
  4802.         {                      variableAddress: Pointer;    }
  4803.         {                      resStringAddress: Pointer;   }
  4804.         {                   end;                            }
  4805.         {                 end;                              }
  4806.  
  4807.         PUSH    EBX
  4808.         PUSH    ESI
  4809.         MOV     EBX,[EAX]
  4810.         LEA     ESI,[EAX+4]
  4811. @@loop:
  4812.         MOV     EAX,[ESI+4]      { load resStringAddress   }
  4813.         MOV     EDX,[ESI]         { load variableAddress    }
  4814.         CALL    LoadResString
  4815.         ADD     ESI,8
  4816.         DEC     EBX
  4817.         JNZ     @@loop
  4818.  
  4819.         POP     ESI
  4820.         POP     EBX
  4821. end;
  4822.  
  4823. procedure _InitResStringImports;
  4824. asm
  4825.         { ->    EAX     Pointer to init table               }
  4826.         {                 record                            }
  4827.         {                   cnt: Integer;                   }
  4828.         {                   tab: array [1..cnt] record      }
  4829.         {                      variableAddress: Pointer;    }
  4830.         {                      resStringAddress: ^Pointer;  }
  4831.         {                   end;                            }
  4832.         {                 end;                              }
  4833.  
  4834.         PUSH    EBX
  4835.         PUSH    ESI
  4836.         MOV     EBX,[EAX]
  4837.         LEA     ESI,[EAX+4]
  4838. @@loop:
  4839.         MOV     EAX,[ESI+4]     { load address of import    }
  4840.         MOV     EDX,[ESI]       { load address of variable  }
  4841.         MOV     EAX,[EAX]       { load contents of import   }
  4842.         CALL    LoadResString
  4843.         ADD     ESI,8
  4844.     DEC     EBX
  4845.     JNZ     @@loop
  4846.  
  4847.     POP     ESI
  4848.     POP     EBX
  4849. end;
  4850.  
  4851. procedure _InitImports;
  4852. asm
  4853.         { ->    EAX     Pointer to init table               }
  4854.         {                 record                            }
  4855.         {                   cnt: Integer;                   }
  4856.         {                   tab: array [1..cnt] record      }
  4857.         {                      variableAddress: Pointer;    }
  4858.         {                      sourceAddress: ^Pointer;     }
  4859.         {                      sourceOffset: Longint;       }
  4860.         {                   end;                            }
  4861.         {                 end;                              }
  4862.  
  4863.         PUSH    EBX
  4864.         PUSH    ESI
  4865.         MOV     EBX,[EAX]
  4866.         LEA     ESI,[EAX+4]
  4867. @@loop:
  4868.         MOV     EAX,[ESI+4]     { load address of import    }
  4869.         MOV     EDX,[ESI]       { load address of variable  }
  4870.         MOV     ECX,[ESI+8]     { load offset               }
  4871.         MOV     EAX,[EAX]       { load contents of import   }
  4872.         ADD     EAX,ECX         { calc address of variable  }
  4873.         MOV     [EDX],EAX       { store result              }
  4874.         ADD     ESI,12
  4875.         DEC     EBX
  4876.         JNZ     @@loop
  4877.  
  4878.         POP     ESI
  4879.         POP     EBX
  4880. end;
  4881.  
  4882. var
  4883.   runErrMsg: array[0..29] of Char = 'Runtime error     at 00000000'#0;
  4884.                         // columns:  0123456789012345678901234567890
  4885.   errCaption: array[0..5] of Char = 'Error'#0;
  4886.  
  4887.  
  4888. procedure MakeErrorMessage;
  4889. const
  4890.   dig : array [0..15] of Char = '0123456789ABCDEF';
  4891. asm
  4892.         PUSH    EBX
  4893.         MOV     EAX,ExitCode
  4894.         MOV     EBX,offset runErrMsg + 16
  4895.         MOV     ECX,10
  4896.  
  4897. @@digLoop:
  4898.         XOR     EDX,EDX
  4899.         DIV     ECX
  4900.         ADD     DL,'0'
  4901.         MOV     [EBX],DL
  4902.         DEC     EBX
  4903.         TEST    EAX,EAX
  4904.         JNZ     @@digLoop
  4905.  
  4906.         MOV     EAX,ErrorAddr
  4907.  
  4908.         CALL    FindHInstance
  4909.         MOV     EDX, ErrorAddr
  4910.         XCHG    EAX, EDX
  4911.         SUB     EAX, EDX           { EAX <=> offset from start of code for HINSTANCE }
  4912.         MOV     EBX,offset runErrMsg + 28
  4913.                 
  4914. @@hdigLoop:
  4915.         MOV     EDX,EAX
  4916.         AND     EDX,0FH
  4917.         MOV     DL,byte ptr dig[EDX]
  4918.         MOV     [EBX],DL
  4919.         DEC     EBX
  4920.         SHR     EAX,4
  4921.         JNE     @@hdigLoop
  4922.         POP     EBX
  4923. end;
  4924.  
  4925.  
  4926. procedure       ExitDll;
  4927. asm
  4928.         { Restore the InitContext }
  4929.  
  4930.         MOV     EDI,offset InitContext
  4931.  
  4932.         MOV     EBX,InitContext.DLLSaveEBX
  4933.         MOV     EBP,InitContext.DLLSaveEBP
  4934.         PUSH    [EDI].TInitContext.DLLSaveESI
  4935.         PUSH    [EDI].TInitContext.DLLSaveEDI
  4936.  
  4937.         MOV     ESI,[EDI].TInitContext.OuterContext
  4938.         MOV     ECX,(type TInitContext)/4
  4939.         REP     MOVSD
  4940.         POP     EDI
  4941.         POP     ESI
  4942.  
  4943.         { Return False if ExitCode <> 0, and set ExitCode to 0 }
  4944.  
  4945.         XOR     EAX,EAX
  4946.         XCHG    EAX,ExitCode
  4947.         NEG     EAX
  4948.         SBB     EAX,EAX
  4949.         INC     EAX
  4950.         LEAVE
  4951.         RET     12
  4952. end;
  4953.  
  4954.  
  4955. procedure _Halt0;
  4956. var
  4957.   P: procedure;
  4958. begin
  4959.  
  4960.   if InitContext.DLLInitState = 0 then
  4961.     while ExitProc <> nil do
  4962.     begin
  4963.       @P := ExitProc;
  4964.       ExitProc := nil;
  4965.       P;
  4966.     end;
  4967.  
  4968.   { If there was some kind of runtime error, alert the user }
  4969.  
  4970.   if ErrorAddr <> nil then
  4971.   begin
  4972.     MakeErrorMessage;
  4973.     if IsConsole then
  4974.       WriteLn(PChar(@runErrMsg))
  4975.     else
  4976.       MessageBox(0, runErrMsg, errCaption, 0);
  4977.     ErrorAddr := nil;
  4978.   end;
  4979.  
  4980.   { This loop exists because we might be nested in PackageLoad calls when }
  4981.   { Halt got called. We need to unwind these contexts.                    }
  4982.  
  4983.   while True do
  4984.   begin
  4985.  
  4986.     { If we are a library, and we are starting up fine, there are no units to finalize }
  4987.  
  4988.     if (InitContext.DLLInitState = 2) and (ExitCode = 0) then
  4989.       InitContext.InitCount := 0;
  4990.  
  4991.     { Undo any unit initializations accomplished so far }
  4992.  
  4993.     FInitUnits;
  4994.  
  4995.     if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then
  4996.       if InitContext.Module <> nil then
  4997.         with InitContext do
  4998.         begin
  4999.           UnregisterModule(Module);
  5000.           if Module.ResInstance <> Module.Instance then
  5001.             FreeLibrary(Module.ResInstance);
  5002.         end;
  5003.  
  5004.     UnsetExceptionHandler;
  5005.  
  5006.     if InitContext.DllInitState = 1 then
  5007.       InitContext.ExitProcessTLS;
  5008.  
  5009.     if InitContext.DllInitState <> 0 then
  5010.       ExitDll;
  5011.  
  5012.     if InitContext.OuterContext = nil then
  5013.       ExitProcess(ExitCode);
  5014.  
  5015.     InitContext := InitContext.OuterContext^
  5016.   end;
  5017.  
  5018.   asm
  5019.     db 'Portions Copyright (c) 1983,97 Borland',0
  5020.   end;
  5021.  
  5022. end;
  5023.  
  5024.  
  5025. procedure _Halt;
  5026. asm
  5027.         MOV     ExitCode,EAX
  5028.         JMP     _Halt0
  5029. end;
  5030.  
  5031.  
  5032. procedure _Run0Error;
  5033. asm
  5034.         XOR     EAX,EAX
  5035.         JMP     _RunError
  5036. end;
  5037.  
  5038.  
  5039. procedure _RunError;
  5040. asm
  5041.         POP     ErrorAddr
  5042.         JMP     _Halt
  5043. end;
  5044.  
  5045.  
  5046. procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
  5047. asm
  5048.         CMP     AssertErrorProc,0
  5049.         JE      @@1
  5050.         PUSH    [ESP].Pointer
  5051.         CALL    AssertErrorProc
  5052. @@1:    MOV     AL,reAssertionFailed
  5053.         JMP     Error
  5054. end;
  5055.  
  5056.  
  5057. type
  5058.   PThreadRec = ^TThreadRec;
  5059.   TThreadRec = record
  5060.     Func: TThreadFunc;
  5061.     Parameter: Pointer;
  5062.   end;
  5063.  
  5064.  
  5065. function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
  5066. asm
  5067.         CALL    _FpuInit
  5068.         XOR     ECX,ECX
  5069.         PUSH    EBP
  5070.         PUSH    offset _ExceptionHandler
  5071.         MOV     EDX,FS:[ECX]
  5072.         PUSH    EDX
  5073.         MOV     EAX,Parameter
  5074.         MOV     FS:[ECX],ESP
  5075.  
  5076.         MOV     ECX,[EAX].TThreadRec.Parameter
  5077.         MOV     EDX,[EAX].TThreadRec.Func
  5078.         PUSH    ECX
  5079.         PUSH    EDX
  5080.         CALL    _FreeMem
  5081.         POP     EDX
  5082.         POP     EAX
  5083.         CALL    EDX
  5084.  
  5085.         XOR     EDX,EDX
  5086.         POP     ECX
  5087.         MOV     FS:[EDX],ECX
  5088.         POP     ECX
  5089.         POP     EBP
  5090. end;
  5091.  
  5092.  
  5093. function BeginThread(SecurityAttributes: Pointer; StackSize: Integer;
  5094.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  5095.                      CreationFlags: Integer; var ThreadId: Integer): Integer;
  5096. var
  5097.   P: PThreadRec;
  5098. begin
  5099.   New(P);
  5100.   P.Func := ThreadFunc;
  5101.   P.Parameter := Parameter;
  5102.   IsMultiThread := TRUE;
  5103.   result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
  5104.                          CreationFlags, ThreadID);
  5105. end;
  5106.  
  5107.  
  5108. procedure EndThread(ExitCode: Integer);
  5109. begin
  5110.   ExitThread(ExitCode);
  5111. end;
  5112.  
  5113.  
  5114. type
  5115.         StrRec = record
  5116.         allocSiz:       Longint;
  5117.         refCnt: Longint;
  5118.         length: Longint;
  5119.         end;
  5120.  
  5121. const
  5122.         skew = sizeof(StrRec);
  5123.         rOff = sizeof(StrRec) - sizeof(Longint);
  5124.         overHead = sizeof(StrRec) + 1;
  5125.  
  5126.  
  5127. procedure _LStrClr(var S: AnsiString);
  5128. asm
  5129.         { ->    EAX pointer to str      }
  5130.  
  5131.         MOV     EDX,[EAX]                       { fetch str                     }
  5132.         TEST    EDX,EDX                         { if nil, nothing to do         }
  5133.         JE      @@done
  5134.         MOV     dword ptr [EAX],0               { clear str                     }
  5135.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  5136.         DEC     ECX                             { if < 0: literal str           }
  5137.         JL      @@done
  5138.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  5139.         JNE     @@done
  5140.         PUSH    EAX
  5141.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5142.         CALL    _FreeMem
  5143.         POP     EAX
  5144. @@done:
  5145. end;
  5146.  
  5147.  
  5148. procedure       _LStrArrayClr{var str: AnsiString; cnt: longint};
  5149. asm
  5150.         { ->    EAX pointer to str      }
  5151.         {       EDX cnt         }
  5152.  
  5153.         PUSH    EBX
  5154.         PUSH    ESI
  5155.         MOV     EBX,EAX
  5156.         MOV     ESI,EDX
  5157.  
  5158. @@loop:
  5159.         MOV     EDX,[EBX]                       { fetch str                     }
  5160.         TEST    EDX,EDX                         { if nil, nothing to do         }
  5161.         JE      @@doneEntry
  5162.         MOV     dword ptr [EBX],0               { clear str                     }
  5163.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  5164.         DEC     ECX                             { if < 0: literal str           }
  5165.         JL      @@doneEntry
  5166.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  5167.         JNE     @@doneEntry
  5168.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5169.         CALL    _FreeMem
  5170. @@doneEntry:
  5171.         ADD     EBX,4
  5172.         DEC     ESI
  5173.         JNE     @@loop
  5174.  
  5175.         POP     ESI
  5176.         POP     EBX
  5177. end;
  5178.  
  5179. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  5180. asm
  5181.         TEST    EDX,EDX
  5182.         JE      @@2
  5183.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5184.         INC     ECX
  5185.         JG      @@1
  5186.         PUSH    EAX
  5187.         PUSH    EDX
  5188.         MOV     EAX,[EDX-skew].StrRec.length
  5189.         CALL    _NewAnsiString
  5190.         MOV     EDX,EAX
  5191.         POP     EAX
  5192.         PUSH    EDX
  5193.         MOV     ECX,[EAX-skew].StrRec.length
  5194.         CALL    Move
  5195.         POP     EDX
  5196.         POP     EAX
  5197.         JMP     @@2
  5198. @@1:    MOV     [EDX-skew].StrRec.refCnt,ECX
  5199. @@2:    XCHG    EDX,[EAX]
  5200.         TEST    EDX,EDX
  5201.         JE      @@3
  5202.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5203.         DEC     ECX
  5204.         JL      @@3
  5205.         MOV     [EDX-skew].StrRec.refCnt,ECX
  5206.         JNE     @@3
  5207.         LEA     EAX,[EDX-skew].StrRec.refCnt
  5208.         CALL    _FreeMem
  5209. @@3:
  5210. end;
  5211.  
  5212. procedure       _LStrLAsg{var dest: AnsiString; source: AnsiString};
  5213. asm
  5214. { ->    EAX     pointer to dest }
  5215. {       EDX     source          }
  5216.  
  5217.         TEST    EDX,EDX
  5218.         JE      @@sourceDone
  5219.  
  5220.         { bump up the ref count of the source }
  5221.  
  5222.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5223.         INC     ECX
  5224.         JLE     @@sourceDone
  5225.         MOV     [EDX-skew].StrRec.refCnt,ECX
  5226. @@sourceDone:
  5227.  
  5228.         { we need to release whatever the dest is pointing to   }
  5229.  
  5230.         XCHG    EDX,[EAX]                       { fetch str                    }
  5231.         TEST    EDX,EDX                         { if nil, nothing to do        }
  5232.         JE      @@done
  5233.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                 }
  5234.         DEC     ECX                             { if < 0: literal str          }
  5235.         JL      @@done
  5236.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back          }
  5237.         JNE     @@done
  5238.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5239.         CALL    _FreeMem
  5240. @@done:
  5241. end;
  5242.  
  5243. procedure       _NewAnsiString{length: Longint};
  5244. asm
  5245.         { ->    EAX     length                  }
  5246.         { <-    EAX pointer to new string       }
  5247.  
  5248.         TEST    EAX,EAX
  5249.         JLE     @@null
  5250.         PUSH    EAX
  5251.         ADD     EAX,rOff+1
  5252.         CALL    _GetMem
  5253.         ADD     EAX,rOff
  5254.         POP     EDX
  5255.         MOV     [EAX-skew].StrRec.length,EDX
  5256.         MOV     [EAX-skew].StrRec.refCnt,1
  5257.         MOV     byte ptr [EAX+EDX],0
  5258.         RET
  5259.  
  5260. @@null:
  5261.         XOR     EAX,EAX
  5262. end;
  5263.  
  5264.  
  5265. procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5266. asm
  5267.         { ->    EAX     pointer to dest }
  5268.         {       EDX source              }
  5269.         {       ECX length              }
  5270.  
  5271.         PUSH    EBX
  5272.         PUSH    ESI
  5273.         PUSH    EDI
  5274.  
  5275.         MOV     EBX,EAX
  5276.         MOV     ESI,EDX
  5277.         MOV     EDI,ECX
  5278.  
  5279.         { allocate new string }
  5280.  
  5281.         MOV     EAX,EDI
  5282.  
  5283.         CALL    _NewAnsiString
  5284.         MOV     ECX,EDI
  5285.         MOV     EDI,EAX
  5286.  
  5287.         TEST    ESI,ESI
  5288.         JE      @@noMove
  5289.  
  5290.         MOV     EDX,EAX
  5291.         MOV     EAX,ESI
  5292.         CALL    Move
  5293.  
  5294.         { assign the result to dest }
  5295.  
  5296. @@noMove:
  5297.         MOV     EAX,EBX
  5298.         CALL    _LStrClr
  5299.         MOV     [EBX],EDI
  5300.  
  5301.         POP     EDI
  5302.         POP     ESI
  5303.         POP     EBX
  5304. end;
  5305.  
  5306.  
  5307. procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5308. var
  5309.   DestLen: Integer;
  5310.   Buffer: array[0..2047] of Char;
  5311. begin
  5312.   if Length <= 0 then
  5313.   begin
  5314.     _LStrClr(Dest);
  5315.     Exit;
  5316.   end;
  5317.   if Length < SizeOf(Buffer) div 2 then
  5318.   begin
  5319.     DestLen := WideCharToMultiByte(0, 0, Source, Length,
  5320.       Buffer, SizeOf(Buffer), nil, nil);
  5321.     if DestLen > 0 then
  5322.     begin
  5323.       _LStrFromPCharLen(Dest, Buffer, DestLen);
  5324.       Exit;
  5325.     end;
  5326.   end;
  5327.   DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
  5328.   _LStrFromPCharLen(Dest, nil, DestLen);
  5329.   WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil);
  5330. end;
  5331.  
  5332.  
  5333. procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
  5334. asm
  5335.         PUSH    EDX
  5336.         MOV     EDX,ESP
  5337.         MOV     ECX,1
  5338.         CALL    _LStrFromPCharLen
  5339.         POP     EDX
  5340. end;
  5341.  
  5342.  
  5343. procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
  5344. asm
  5345.         PUSH    EDX
  5346.         MOV     EDX,ESP
  5347.         MOV     ECX,1
  5348.         CALL    _LStrFromPWCharLen
  5349.         POP     EDX
  5350. end;
  5351.  
  5352.  
  5353. procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
  5354. asm
  5355.         XOR     ECX,ECX
  5356.         TEST    EDX,EDX
  5357.         JE      @@5
  5358.         PUSH    EDX
  5359. @@0:    CMP     CL,[EDX+0]
  5360.         JE      @@4
  5361.         CMP     CL,[EDX+1]
  5362.         JE      @@3
  5363.         CMP     CL,[EDX+2]
  5364.         JE      @@2
  5365.         CMP     CL,[EDX+3]
  5366.         JE      @@1
  5367.         ADD     EDX,4
  5368.         JMP     @@0
  5369. @@1:    INC     EDX
  5370. @@2:    INC     EDX
  5371. @@3:    INC     EDX
  5372. @@4:    MOV     ECX,EDX
  5373.         POP     EDX
  5374.         SUB     ECX,EDX
  5375. @@5:    JMP     _LStrFromPCharLen
  5376. end;
  5377.  
  5378.  
  5379. procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
  5380. asm
  5381.         XOR     ECX,ECX
  5382.         TEST    EDX,EDX
  5383.         JE      @@5
  5384.         PUSH    EDX
  5385. @@0:    CMP     CX,[EDX+0]
  5386.         JE      @@4
  5387.         CMP     CX,[EDX+2]
  5388.         JE      @@3
  5389.         CMP     CX,[EDX+4]
  5390.         JE      @@2
  5391.         CMP     CX,[EDX+6]
  5392.         JE      @@1
  5393.         ADD     EDX,8
  5394.         JMP     @@0
  5395. @@1:    ADD     EDX,2
  5396. @@2:    ADD     EDX,2
  5397. @@3:    ADD     EDX,2
  5398. @@4:    MOV     ECX,EDX
  5399.         POP     EDX
  5400.         SUB     ECX,EDX
  5401.         SHR     ECX,1
  5402. @@5:    JMP     _LStrFromPWCharLen
  5403. end;
  5404.  
  5405.  
  5406. procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
  5407. asm
  5408.         XOR     ECX,ECX
  5409.         MOV     CL,[EDX]
  5410.         INC     EDX
  5411.         JMP     _LStrFromPCharLen
  5412. end;
  5413.  
  5414.  
  5415. procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5416. asm
  5417.         PUSH    EDI
  5418.         PUSH    EAX
  5419.         PUSH    ECX
  5420.         MOV     EDI,EDX
  5421.         XOR     EAX,EAX
  5422.         REPNE   SCASB
  5423.         JNE     @@1
  5424.         NOT     ECX
  5425. @@1:    POP     EAX
  5426.         ADD     ECX,EAX
  5427.         POP     EAX
  5428.         POP     EDI
  5429.         JMP     _LStrFromPCharLen
  5430. end;
  5431.  
  5432.  
  5433. procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5434. asm
  5435.         PUSH    EDI
  5436.         PUSH    EAX
  5437.         PUSH    ECX
  5438.         MOV     EDI,EDX
  5439.         XOR     EAX,EAX
  5440.         REPNE   SCASW
  5441.         JNE     @@1
  5442.         NOT     ECX
  5443. @@1:    POP     EAX
  5444.         ADD     ECX,EAX
  5445.         POP     EAX
  5446.         POP     EDI
  5447.         JMP     _LStrFromPWCharLen
  5448. end;
  5449.  
  5450.  
  5451. procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
  5452. asm
  5453.         XOR     ECX,ECX
  5454.         TEST    EDX,EDX
  5455.         JE      @@1
  5456.         MOV     ECX,[EDX-4]
  5457.         SHR     ECX,1
  5458. @@1:    JMP     _LStrFromPWCharLen
  5459. end;
  5460.  
  5461.  
  5462. procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
  5463. asm
  5464.         { ->    EAX pointer to result   }
  5465.         {       EDX AnsiString s        }
  5466.         {       ECX length of result    }
  5467.  
  5468.         PUSH    EBX
  5469.         TEST    EDX,EDX
  5470.         JE      @@empty
  5471.         MOV     EBX,[EDX-skew].StrRec.length
  5472.         TEST    EBX,EBX
  5473.         JE      @@empty
  5474.  
  5475.         CMP     ECX,EBX
  5476.         JL      @@truncate
  5477.         MOV     ECX,EBX
  5478. @@truncate:
  5479.         MOV     [EAX],CL
  5480.         INC     EAX
  5481.  
  5482.         XCHG    EAX,EDX
  5483.         CALL    Move
  5484.  
  5485.         JMP     @@exit
  5486.  
  5487. @@empty:
  5488.         MOV     byte ptr [EAX],0
  5489.  
  5490. @@exit:
  5491.         POP     EBX
  5492. end;
  5493.  
  5494.  
  5495. function        _LStrLen{str: AnsiString}: Longint;
  5496. asm
  5497.         { ->    EAX str }
  5498.  
  5499.         TEST    EAX,EAX
  5500.         JE      @@done
  5501.         MOV     EAX,[EAX-skew].StrRec.length;
  5502. @@done:
  5503. end;
  5504.  
  5505.  
  5506. procedure       _LStrCat{var dest: AnsiString; source: AnsiString};
  5507. asm
  5508.         { ->    EAX     pointer to dest }
  5509.         {       EDX source              }
  5510.  
  5511.         TEST    EDX,EDX
  5512.         JE      @@exit
  5513.  
  5514.         MOV     ECX,[EAX]
  5515.         TEST    ECX,ECX
  5516.         JE      _LStrAsg
  5517.  
  5518.         PUSH    EBX
  5519.         PUSH    ESI
  5520.         PUSH    EDI
  5521.         MOV     EBX,EAX
  5522.         MOV     ESI,EDX
  5523.         MOV     EDI,[ECX-skew].StrRec.length
  5524.  
  5525.         MOV     EDX,[ESI-skew].StrRec.length
  5526.         ADD     EDX,EDI
  5527.         CMP     ESI,ECX
  5528.         JE      @@appendSelf
  5529.  
  5530.         CALL    _LStrSetLength
  5531.         MOV     EAX,ESI
  5532.         MOV     ECX,[ESI-skew].StrRec.length
  5533.  
  5534. @@appendStr:
  5535.         MOV     EDX,[EBX]
  5536.         ADD     EDX,EDI
  5537.         CALL    Move
  5538.         POP     EDI
  5539.         POP     ESI
  5540.         POP     EBX
  5541.         RET
  5542.  
  5543. @@appendSelf:
  5544.         CALL    _LStrSetLength
  5545.         MOV     EAX,[EBX]
  5546.         MOV     ECX,EDI
  5547.         JMP     @@appendStr
  5548.  
  5549. @@exit:
  5550. end;
  5551.  
  5552.  
  5553. procedure       _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  5554. asm
  5555.         {     ->EAX = Pointer to dest   }
  5556.         {       EDX = source1           }
  5557.         {       ECX = source2           }
  5558.  
  5559.         TEST    EDX,EDX
  5560.         JE      @@assignSource2
  5561.  
  5562.         TEST    ECX,ECX
  5563.         JE      _LStrAsg
  5564.  
  5565.         CMP     EDX,[EAX]
  5566.         JE      @@appendToDest
  5567.  
  5568.         CMP     ECX,[EAX]
  5569.         JE      @@theHardWay
  5570.  
  5571.         PUSH    EAX
  5572.         PUSH    ECX
  5573.         CALL    _LStrAsg
  5574.  
  5575.         POP     EDX
  5576.         POP     EAX
  5577.         JMP     _LStrCat
  5578.  
  5579. @@theHardWay:
  5580.  
  5581.         PUSH    EBX
  5582.         PUSH    ESI
  5583.         PUSH    EDI
  5584.  
  5585.         MOV     EBX,EDX
  5586.         MOV     ESI,ECX
  5587.         PUSH    EAX
  5588.  
  5589.         MOV     EAX,[EBX-skew].StrRec.length
  5590.         ADD     EAX,[ESI-skew].StrRec.length
  5591.         CALL    _NewAnsiString
  5592.  
  5593.         MOV     EDI,EAX
  5594.         MOV     EDX,EAX
  5595.         MOV     EAX,EBX
  5596.         MOV     ECX,[EBX-skew].StrRec.length
  5597.         CALL    Move
  5598.  
  5599.         MOV     EDX,EDI
  5600.         MOV     EAX,ESI
  5601.         MOV     ECX,[ESI-skew].StrRec.length
  5602.         ADD     EDX,[EBX-skew].StrRec.length
  5603.         CALL    Move
  5604.  
  5605.         POP     EAX
  5606.         MOV     EDX,EDI
  5607.         TEST    EDI,EDI
  5608.         JE      @@skip
  5609.         DEC     [EDI-skew].StrRec.refCnt
  5610. @@skip:
  5611.         CALL    _LStrAsg
  5612.  
  5613.         POP     EDI
  5614.         POP     ESI
  5615.         POP     EBX
  5616.  
  5617.         JMP     @@exit
  5618.  
  5619. @@assignSource2:
  5620.         MOV     EDX,ECX
  5621.         JMP     _LStrAsg
  5622.  
  5623. @@appendToDest:
  5624.         MOV     EDX,ECX
  5625.         JMP     _LStrCat
  5626.  
  5627. @@exit:
  5628. end;
  5629.  
  5630.  
  5631. procedure       _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  5632. asm
  5633.         {     ->EAX = Pointer to dest   }
  5634.         {       EDX = number of args (>= 3)     }
  5635.         {       [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }
  5636.  
  5637.         PUSH    EBX
  5638.         PUSH    ESI
  5639.         PUSH    EDX
  5640.         PUSH    EAX
  5641.         MOV     EBX,EDX
  5642.  
  5643.         XOR     EAX,EAX
  5644. @@loop1:
  5645.         MOV     ECX,[ESP+EDX*4+4*4]
  5646.         TEST    ECX,ECX
  5647.         JE      @@1
  5648.         ADD     EAX,[ECX-skew].StrRec.length
  5649. @@1:
  5650.         DEC     EDX
  5651.         JNE     @@loop1
  5652.  
  5653.         CALL    _NewAnsiString
  5654.         PUSH    EAX
  5655.         MOV     ESI,EAX
  5656.  
  5657. @@loop2:
  5658.         MOV     EAX,[ESP+EBX*4+5*4]
  5659.         MOV     EDX,ESI
  5660.         TEST    EAX,EAX
  5661.         JE      @@2
  5662.         MOV     ECX,[EAX-skew].StrRec.length
  5663.         ADD     ESI,ECX
  5664.         CALL    Move
  5665. @@2:
  5666.         DEC     EBX
  5667.         JNE     @@loop2
  5668.  
  5669.         POP     EDX
  5670.         POP     EAX
  5671.         TEST    EDX,EDX
  5672.         JE      @@skip
  5673.         DEC     [EDX-skew].StrRec.refCnt
  5674. @@skip:
  5675.         CALL    _LStrAsg
  5676.  
  5677.         POP     EDX
  5678.         POP     ESI
  5679.         POP     EBX
  5680.         POP     EAX
  5681.         LEA     ESP,[ESP+EDX*4]
  5682.         JMP     EAX
  5683. end;
  5684.  
  5685.  
  5686. procedure       _LStrCmp{left: AnsiString; right: AnsiString};
  5687. asm
  5688. {     ->EAX = Pointer to left string    }
  5689. {       EDX = Pointer to right string   }
  5690.  
  5691.         PUSH    EBX
  5692.         PUSH    ESI
  5693.         PUSH    EDI
  5694.  
  5695.         MOV     ESI,EAX
  5696.         MOV     EDI,EDX
  5697.  
  5698.         CMP     EAX,EDX
  5699.         JE      @@exit
  5700.  
  5701.         TEST    ESI,ESI
  5702.         JE      @@str1null
  5703.  
  5704.         TEST    EDI,EDI
  5705.         JE      @@str2null
  5706.  
  5707.         MOV     EAX,[ESI-skew].StrRec.length
  5708.         MOV     EDX,[EDI-skew].StrRec.length
  5709.  
  5710.         SUB     EAX,EDX { eax = len1 - len2 }
  5711.         JA      @@skip1
  5712.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  5713.  
  5714. @@skip1:
  5715.         PUSH    EDX
  5716.         SHR     EDX,2
  5717.         JE      @@cmpRest
  5718. @@longLoop:
  5719.         MOV     ECX,[ESI]
  5720.         MOV     EBX,[EDI]
  5721.         CMP     ECX,EBX
  5722.         JNE     @@misMatch
  5723.         DEC     EDX
  5724.         JE      @@cmpRestP4
  5725.         MOV     ECX,[ESI+4]
  5726.         MOV     EBX,[EDI+4]
  5727.         CMP     ECX,EBX
  5728.         JNE     @@misMatch
  5729.         ADD     ESI,8
  5730.         ADD     EDI,8
  5731.         DEC     EDX
  5732.         JNE     @@longLoop
  5733.         JMP     @@cmpRest
  5734. @@cmpRestP4:
  5735.         ADD     ESI,4
  5736.         ADD     EDI,4
  5737. @@cmpRest:
  5738.         POP     EDX
  5739.         AND     EDX,3
  5740.         JE      @@equal
  5741.  
  5742.         MOV     ECX,[ESI]
  5743.         MOV     EBX,[EDI]
  5744.         CMP     CL,BL
  5745.         JNE     @@exit
  5746.         DEC     EDX
  5747.         JE      @@equal
  5748.         CMP     CH,BH
  5749.         JNE     @@exit
  5750.         DEC     EDX
  5751.         JE      @@equal
  5752.         AND     EBX,$00FF0000
  5753.         AND     ECX,$00FF0000
  5754.         CMP     ECX,EBX
  5755.         JNE     @@exit
  5756.  
  5757. @@equal:
  5758.         ADD     EAX,EAX
  5759.         JMP     @@exit
  5760.  
  5761. @@str1null:
  5762.         MOV     EDX,[EDI-skew].StrRec.length
  5763.         SUB     EAX,EDX
  5764.         JMP     @@exit
  5765.  
  5766. @@str2null:
  5767.         MOV     EAX,[ESI-skew].StrRec.length
  5768.         SUB     EAX,EDX
  5769.         JMP     @@exit
  5770.  
  5771. @@misMatch:
  5772.         POP     EDX
  5773.         CMP     CL,BL
  5774.         JNE     @@exit
  5775.         CMP     CH,BH
  5776.         JNE     @@exit
  5777.         SHR     ECX,16
  5778.         SHR     EBX,16
  5779.         CMP     CL,BL
  5780.         JNE     @@exit
  5781.         CMP     CH,BH
  5782.  
  5783. @@exit:
  5784.         POP     EDI
  5785.         POP     ESI
  5786.         POP     EBX
  5787.  
  5788. end;
  5789.  
  5790.  
  5791. procedure       _LStrAddRef{str: AnsiString};
  5792. asm
  5793.         { ->    EAX     str     }
  5794.         TEST    EAX,EAX
  5795.         JE      @@exit
  5796.         MOV     EDX,[EAX-skew].StrRec.refCnt
  5797.         INC     EDX
  5798.         JLE     @@exit
  5799.         MOV     [EAX-skew].StrRec.refCnt,EDX
  5800. @@exit:
  5801. end;
  5802.  
  5803.  
  5804. procedure       _LStrToPChar{str: AnsiString): PChar};
  5805. asm
  5806.         { ->    EAX pointer to str              }
  5807.         { <-    EAX pointer to PChar    }
  5808.  
  5809.         TEST    EAX,EAX
  5810.         JE      @@handle0
  5811.         RET
  5812. @@zeroByte:
  5813.         DB      0
  5814. @@handle0:
  5815.         MOV     EAX,offset @@zeroByte
  5816. end;
  5817.  
  5818.  
  5819. procedure       UniqueString(var str: string);
  5820. asm
  5821.         { ->    EAX pointer to str              }
  5822.         { <-    EAX pointer to unique copy      }
  5823.         MOV     EDX,[EAX]
  5824.         TEST    EDX,EDX
  5825.         JE      @@exit
  5826.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5827.         DEC     ECX
  5828.         JE      @@exit
  5829.  
  5830.         PUSH    EBX
  5831.         MOV     EBX,EAX
  5832.         MOV     EAX,[EDX-skew].StrRec.length
  5833.         CALL    _NewAnsiString
  5834.         MOV     EDX,EAX
  5835.         MOV     EAX,[EBX]
  5836.         MOV     [EBX],EDX
  5837.         MOV     ECX,[EAX-skew].StrRec.refCnt
  5838.         DEC     ECX
  5839.         JL      @@skip
  5840.         MOV     [EAX-skew].StrRec.refCnt,ECX
  5841. @@skip:
  5842.         MOV     ECX,[EAX-skew].StrRec.length
  5843.         CALL    Move
  5844.         MOV     EDX,[EBX]
  5845.         POP     EBX
  5846. @@exit:
  5847.         MOV     EAX,EDX
  5848. end;
  5849.  
  5850.  
  5851. procedure       _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
  5852. asm
  5853.         {     ->EAX     Source string                   }
  5854.         {       EDX     index                           }
  5855.         {       ECX     count                           }
  5856.         {       [ESP+4] Pointer to result string        }
  5857.  
  5858.         PUSH    EBX
  5859.  
  5860.         TEST    EAX,EAX
  5861.         JE      @@srcEmpty
  5862.  
  5863.         MOV     EBX,[EAX-skew].StrRec.length
  5864.         TEST    EBX,EBX
  5865.         JE      @@srcEmpty
  5866.  
  5867. {       make index 0-based and limit to 0 <= index < Length(src) }
  5868.  
  5869.         DEC     EDX
  5870.         JL      @@smallInx
  5871.         CMP     EDX,EBX
  5872.         JGE     @@bigInx
  5873.  
  5874. @@cont1:
  5875.  
  5876. {       limit count to satisfy 0 <= count <= Length(src) - index        }
  5877.  
  5878.         SUB     EBX,EDX { calculate Length(src) - index }
  5879.         TEST    ECX,ECX
  5880.         JL      @@smallCount
  5881.         CMP     ECX,EBX
  5882.         JG      @@bigCount
  5883.  
  5884. @@cont2:
  5885.  
  5886.         ADD     EDX,EAX
  5887.         MOV     EAX,[ESP+4+4]
  5888.         CALL    _LStrFromPCharLen
  5889.         JMP     @@exit
  5890.  
  5891. @@smallInx:
  5892.         XOR     EDX,EDX
  5893.         JMP     @@cont1
  5894. @@bigCount:
  5895.         MOV     ECX,EBX
  5896.         JMP     @@cont2
  5897. @@bigInx:
  5898. @@smallCount:
  5899. @@srcEmpty:
  5900.         MOV     EAX,[ESP+4+4]
  5901.         CALL    _LStrClr
  5902. @@exit:
  5903.         POP     EBX
  5904.         RET     4
  5905. end;
  5906.  
  5907.  
  5908. procedure       _LStrDelete{ var s : AnsiString; index, count : Integer };
  5909. asm
  5910.         {     ->EAX     Pointer to s    }
  5911.         {       EDX     index           }
  5912.         {       ECX     count           }
  5913.  
  5914.         PUSH    EBX
  5915.         PUSH    ESI
  5916.         PUSH    EDI
  5917.  
  5918.         MOV     EBX,EAX
  5919.         MOV     ESI,EDX
  5920.         MOV     EDI,ECX
  5921.  
  5922.         CALL    UniqueString
  5923.  
  5924.         MOV     EDX,[EBX]
  5925.         TEST    EDX,EDX         { source already empty: nothing to do   }
  5926.         JE      @@exit
  5927.  
  5928.         MOV     ECX,[EDX-skew].StrRec.length
  5929.  
  5930. {       make index 0-based, if not in [0 .. Length(s)-1] do nothing     }
  5931.  
  5932.         DEC     ESI
  5933.         JL      @@exit
  5934.         CMP     ESI,ECX
  5935.         JGE     @@exit
  5936.  
  5937. {       limit count to [0 .. Length(s) - index] }
  5938.  
  5939.         TEST    EDI,EDI
  5940.         JLE     @@exit
  5941.         SUB     ECX,ESI         { ECX = Length(s) - index       }
  5942.         CMP     EDI,ECX
  5943.         JLE     @@1
  5944.         MOV     EDI,ECX
  5945. @@1:
  5946.  
  5947. {       move length - index - count characters from s+index+count to s+index }
  5948.  
  5949.         SUB     ECX,EDI         { ECX = Length(s) - index - count       }
  5950.         ADD     EDX,ESI         { EDX = s+index                 }
  5951.         LEA     EAX,[EDX+EDI]   { EAX = s+index+count           }
  5952.         CALL    Move
  5953.  
  5954. {       set length(s) to length(s) - count      }
  5955.  
  5956.         MOV     EDX,[EBX]
  5957.         MOV     EAX,EBX
  5958.         MOV     EDX,[EDX-skew].StrRec.length
  5959.         SUB     EDX,EDI
  5960.         CALL    _LStrSetLength
  5961.  
  5962. @@exit:
  5963.         POP     EDI
  5964.         POP     ESI
  5965.         POP     EBX
  5966. end;
  5967.  
  5968.  
  5969. procedure       _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  5970. asm
  5971.         { ->    EAX source string                       }
  5972.         {       EDX     pointer to destination string   }
  5973.         {       ECX index                               }
  5974.  
  5975.         TEST    EAX,EAX
  5976.         JE      @@nothingToDo
  5977.  
  5978.         PUSH    EBX
  5979.         PUSH    ESI
  5980.         PUSH    EDI
  5981.         PUSH    EBP
  5982.  
  5983.         MOV     EBX,EAX
  5984.         MOV     ESI,EDX
  5985.         MOV     EDI,ECX
  5986.  
  5987. {       make index 0-based and limit to 0 <= index <= Length(s) }
  5988.  
  5989.         MOV     EDX,[EDX]
  5990.         PUSH    EDX
  5991.         TEST    EDX,EDX
  5992.         JE      @@sIsNull
  5993.         MOV     EDX,[EDX-skew].StrRec.length
  5994. @@sIsNull:
  5995.         DEC     EDI
  5996.         JGE     @@indexNotLow
  5997.         XOR     EDI,EDI
  5998. @@indexNotLow:
  5999.         CMP     EDI,EDX
  6000.         JLE     @@indexNotHigh
  6001.         MOV     EDI,EDX
  6002. @@indexNotHigh:
  6003.  
  6004.         MOV     EBP,[EBX-skew].StrRec.length
  6005.  
  6006. {       set length of result to length(source) + length(s)      }
  6007.  
  6008.         MOV     EAX,ESI
  6009.         ADD     EDX,EBP
  6010.         CALL    _LStrSetLength
  6011.         POP     EAX
  6012.  
  6013.         CMP     EAX,EBX
  6014.         JNE     @@notInsertSelf
  6015.         MOV     EBX,[ESI]
  6016.  
  6017. @@notInsertSelf:
  6018.  
  6019. {       move length(s) - length(source) - index chars from s+index to s+index+length(source) }
  6020.  
  6021.         MOV     EAX,[ESI]                       { EAX = s       }
  6022.         LEA     EDX,[EDI+EBP]                   { EDX = index + length(source)  }
  6023.         MOV     ECX,[EAX-skew].StrRec.length
  6024.         SUB     ECX,EDX                         { ECX = length(s) - length(source) - index }
  6025.         ADD     EDX,EAX                         { EDX = s + index + length(source)      }
  6026.         ADD     EAX,EDI                         { EAX = s + index       }
  6027.         CALL    Move
  6028.  
  6029. {       copy length(source) chars from source to s+index        }
  6030.  
  6031.         MOV     EAX,EBX
  6032.         MOV     EDX,[ESI]
  6033.         MOV     ECX,EBP
  6034.         ADD     EDX,EDI
  6035.         CALL    Move
  6036.  
  6037. @@exit:
  6038.         POP     EBP
  6039.         POP     EDI
  6040.         POP     ESI
  6041.         POP     EBX
  6042. @@nothingToDo:
  6043. end;
  6044.  
  6045.  
  6046. procedure       _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  6047. asm
  6048. {     ->EAX     Pointer to substr               }
  6049. {       EDX     Pointer to string               }
  6050. {     <-EAX     Position of substr in s or 0    }
  6051.  
  6052.         TEST    EAX,EAX
  6053.         JE      @@noWork
  6054.  
  6055.         TEST    EDX,EDX
  6056.         JE      @@stringEmpty
  6057.  
  6058.         PUSH    EBX
  6059.         PUSH    ESI
  6060.         PUSH    EDI
  6061.  
  6062.         MOV     ESI,EAX                         { Point ESI to substr           }
  6063.         MOV     EDI,EDX                         { Point EDI to s                }
  6064.  
  6065.         MOV     ECX,[EDI-skew].StrRec.length    { ECX = Length(s)               }
  6066.  
  6067.         PUSH    EDI                             { remember s position to calculate index        }
  6068.  
  6069.         MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)          }
  6070.  
  6071.         DEC     EDX                             { EDX = Length(substr) - 1              }
  6072.         JS      @@fail                          { < 0 ? return 0                        }
  6073.         MOV     AL,[ESI]                        { AL = first char of substr             }
  6074.         INC     ESI                             { Point ESI to 2'nd char of substr      }
  6075.  
  6076.         SUB     ECX,EDX                         { #positions in s to look at    }
  6077.                                                 { = Length(s) - Length(substr) + 1      }
  6078.         JLE     @@fail
  6079. @@loop:
  6080.         REPNE   SCASB
  6081.         JNE     @@fail
  6082.         MOV     EBX,ECX                         { save outer loop counter               }
  6083.         PUSH    ESI                             { save outer loop substr pointer        }
  6084.         PUSH    EDI                             { save outer loop s pointer             }
  6085.  
  6086.         MOV     ECX,EDX
  6087.         REPE    CMPSB
  6088.         POP     EDI                             { restore outer loop s pointer  }
  6089.         POP     ESI                             { restore outer loop substr pointer     }
  6090.         JE      @@found
  6091.         MOV     ECX,EBX                         { restore outer loop counter    }
  6092.         JMP     @@loop
  6093.  
  6094. @@fail:
  6095.         POP     EDX                             { get rid of saved s pointer    }
  6096.         XOR     EAX,EAX
  6097.         JMP     @@exit
  6098.  
  6099. @@stringEmpty:
  6100.         XOR     EAX,EAX
  6101.         JMP     @@noWork
  6102.  
  6103. @@found:
  6104.         POP     EDX                             { restore pointer to first char of s    }
  6105.         MOV     EAX,EDI                         { EDI points of char after match        }
  6106.         SUB     EAX,EDX                         { the difference is the correct index   }
  6107. @@exit:
  6108.         POP     EDI
  6109.         POP     ESI
  6110.         POP     EBX
  6111. @@noWork:
  6112. end;
  6113.  
  6114.  
  6115. procedure       _LStrSetLength{ var str: AnsiString; newLength: Integer};
  6116. asm
  6117.         { ->    EAX     Pointer to str  }
  6118.         {       EDX new length  }
  6119.  
  6120.         PUSH    EBX
  6121.         PUSH    ESI
  6122.         PUSH    EDI
  6123.         MOV     EBX,EAX
  6124.         MOV     ESI,EDX
  6125.         XOR     EDI,EDI
  6126.  
  6127.         TEST    EDX,EDX
  6128.         JE      @@setString
  6129.  
  6130.         MOV     EAX,[EBX]
  6131.         TEST    EAX,EAX
  6132.         JE      @@copyString
  6133.  
  6134.         CMP     [EAX-skew].StrRec.refCnt,1
  6135.         JNE     @@copyString
  6136.  
  6137.         SUB     EAX,rOff
  6138.         ADD     EDX,rOff+1
  6139.         PUSH    EAX
  6140.         MOV     EAX,ESP
  6141.         CALL    _ReallocMem
  6142.         POP     EAX
  6143.         ADD     EAX,rOff
  6144.         MOV     [EBX],EAX
  6145.         MOV     [EAX-skew].StrRec.length,ESI
  6146.         MOV     BYTE PTR [EAX+ESI],0
  6147.         JMP     @@exit
  6148.  
  6149. @@copyString:
  6150.         MOV     EAX,EDX
  6151.         CALL    _NewAnsiString
  6152.         MOV     EDI,EAX
  6153.  
  6154.         MOV     EAX,[EBX]
  6155.         TEST    EAX,EAX
  6156.         JE      @@setString
  6157.  
  6158.         MOV     EDX,EDI
  6159.         MOV     ECX,[EAX-skew].StrRec.length
  6160.         CMP     ECX,ESI
  6161.         JL      @@moveString
  6162.         MOV     ECX,ESI
  6163.  
  6164. @@moveString:
  6165.         CALL    Move
  6166.  
  6167. @@setString:
  6168.         MOV     EAX,EBX
  6169.         CALL    _LStrClr
  6170.         MOV     [EBX],EDI
  6171.  
  6172. @@exit:
  6173.         POP     EDI
  6174.         POP     ESI
  6175.         POP     EBX
  6176. end;
  6177.  
  6178.  
  6179. procedure       _LStrOfChar{ c: Char; count: Integer): AnsiString };
  6180. asm
  6181.         { ->    AL      c               }
  6182.         {       EDX     count           }
  6183.         {       ECX     result  }
  6184.  
  6185.         PUSH    EBX
  6186.         PUSH    ESI
  6187.         PUSH    EDI
  6188.  
  6189.         MOV     EBX,EAX
  6190.         MOV     ESI,EDX
  6191.         MOV     EDI,ECX
  6192.  
  6193.         MOV     EAX,ECX
  6194.         CALL    _LStrClr
  6195.  
  6196.         TEST    ESI,ESI
  6197.     JLE @@exit
  6198.  
  6199.         MOV     EAX,ESI
  6200.         CALL    _NewAnsiString
  6201.  
  6202.         MOV     [EDI],EAX
  6203.  
  6204.         MOV     EDX,ESI
  6205.         MOV     CL,BL
  6206.  
  6207.         CALL    _FillChar
  6208.  
  6209. @@exit:
  6210.         POP     EDI
  6211.         POP     ESI
  6212.         POP     EBX
  6213.  
  6214. end;
  6215.  
  6216.  
  6217. procedure _Write0LString{ VAR t: Text; s: AnsiString };
  6218. asm
  6219.         { ->    EAX     Pointer to text record  }
  6220.         {       EDX     Pointer to AnsiString   }
  6221.  
  6222.         XOR     ECX,ECX
  6223.         JMP     _WriteLString
  6224. end;
  6225.  
  6226.  
  6227. procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
  6228. asm
  6229.         { ->    EAX     Pointer to text record  }
  6230.         {       EDX     Pointer to AnsiString   }
  6231.         {       ECX     Field width             }
  6232.  
  6233.         PUSH    EBX
  6234.  
  6235.         MOV     EBX,EDX
  6236.  
  6237.         MOV     EDX,ECX
  6238.         XOR     ECX,ECX
  6239.         TEST    EBX,EBX
  6240.         JE      @@skip
  6241.         MOV     ECX,[EBX-skew].StrRec.length
  6242.         SUB     EDX,ECX
  6243. @@skip:
  6244.         PUSH    ECX
  6245.         CALL    _WriteSpaces
  6246.         POP     ECX
  6247.  
  6248.         MOV     EDX,EBX
  6249.         POP     EBX
  6250.         JMP     _WriteBytes
  6251. end;
  6252.  
  6253.  
  6254. procedure       _ReadLString{var t: Text; var str: AnsiString};
  6255. asm
  6256.         { ->    EAX     pointer to Text         }
  6257.         {       EDX     pointer to AnsiString   }
  6258.  
  6259.         PUSH    EBX
  6260.         PUSH    ESI
  6261.         MOV     EBX,EAX
  6262.         MOV     ESI,EDX
  6263.  
  6264.         MOV     EAX,EDX
  6265.         CALL    _LStrClr
  6266.  
  6267.         SUB     ESP,256
  6268.  
  6269.         MOV     EAX,EBX
  6270.         MOV     EDX,ESP
  6271.         MOV     ECX,255
  6272.         CALL    _ReadString
  6273.  
  6274.         MOV     EAX,ESI
  6275.         MOV     EDX,ESP
  6276.         CALL    _LStrFromString
  6277.  
  6278.         CMP     byte ptr [ESP],255
  6279.         JNE     @@exit
  6280. @@loop:
  6281.  
  6282.         MOV     EAX,EBX
  6283.         MOV     EDX,ESP
  6284.         MOV     ECX,255
  6285.         CALL    _ReadString
  6286.  
  6287.         MOV     EDX,ESP
  6288.         PUSH    0
  6289.         MOV     EAX,ESP
  6290.         CALL    _LStrFromString
  6291.  
  6292.         MOV     EAX,ESI
  6293.         MOV     EDX,[ESP]
  6294.         CALL    _LStrCat
  6295.  
  6296.         MOV     EAX,ESP
  6297.         CALL    _LStrClr
  6298.         POP     EAX
  6299.  
  6300.         CMP     byte ptr [ESP],255
  6301.         JE      @@loop
  6302.  
  6303. @@exit:
  6304.         ADD     ESP,256
  6305.         POP     ESI
  6306.         POP     EBX
  6307. end;
  6308.  
  6309.  
  6310. procedure WStrError;
  6311. asm
  6312.         MOV     AL,reOutOfMemory
  6313.         JMP     Error
  6314. end;
  6315.  
  6316.  
  6317. procedure WStrSet(var S: WideString; P: PWideChar);
  6318. asm
  6319.         MOV     ECX,[EAX]
  6320.         MOV     [EAX],EDX
  6321.         TEST    ECX,ECX
  6322.         JE      @@1
  6323.         PUSH    ECX
  6324.         CALL    SysFreeString
  6325. @@1:
  6326. end;
  6327.  
  6328.  
  6329. procedure _WStrClr(var S: WideString);
  6330. asm
  6331.         MOV     EDX,[EAX]
  6332.         TEST    EDX,EDX
  6333.         JE      @@1
  6334.         MOV     DWORD PTR [EAX],0
  6335.         PUSH    EAX
  6336.         PUSH    EDX
  6337.         CALL    SysFreeString
  6338.         POP     EAX
  6339. @@1:
  6340. end;
  6341.  
  6342.  
  6343. procedure _WStrArrayClr(var StrArray; Count: Integer);
  6344. asm
  6345.         PUSH    EBX
  6346.         PUSH    ESI
  6347.         MOV     EBX,EAX
  6348.         MOV     ESI,EDX
  6349. @@1:    MOV     EAX,[EBX]
  6350.         TEST    EAX,EAX
  6351.         JE      @@2
  6352.         MOV     DWORD PTR [EBX],0
  6353.         PUSH    EAX
  6354.         CALL    SysFreeString
  6355. @@2:    ADD     EBX,4
  6356.         DEC     ESI
  6357.         JNE     @@1
  6358.         POP     ESI
  6359.         POP     EBX
  6360. end;
  6361.  
  6362.  
  6363. procedure _WStrAsg(var Dest: WideString; const Source: WideString);
  6364. asm
  6365.         TEST    EDX,EDX
  6366.         JE      _WStrClr
  6367.         MOV     ECX,[EDX-4]
  6368.         SHR     ECX,1
  6369.         JE      _WStrClr
  6370.         PUSH    ECX
  6371.         PUSH    EDX
  6372.         PUSH    EAX
  6373.         CALL    SysReAllocStringLen
  6374.         TEST    EAX,EAX
  6375.         JE      WStrError
  6376. end;
  6377.  
  6378.  
  6379. procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  6380. var
  6381.   DestLen: Integer;
  6382.   Buffer: array[0..1023] of WideChar;
  6383. begin
  6384.   if Length <= 0 then
  6385.   begin
  6386.     _WStrClr(Dest);
  6387.     Exit;
  6388.   end;
  6389.   if Length < SizeOf(Buffer) div 2 then
  6390.   begin
  6391.     DestLen := MultiByteToWideChar(0, 0, Source, Length,
  6392.       Buffer, SizeOf(Buffer) div 2);
  6393.     if DestLen > 0 then
  6394.     begin
  6395.       _WStrFromPWCharLen(Dest, Buffer, DestLen);
  6396.       Exit;
  6397.     end;
  6398.   end;
  6399.   DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0);
  6400.   _WStrFromPWCharLen(Dest, nil, DestLen);
  6401.   MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen);
  6402. end;
  6403.  
  6404.  
  6405. procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
  6406. asm
  6407.         TEST    ECX,ECX
  6408.         JE      _WStrClr
  6409.         PUSH    ECX
  6410.         PUSH    EDX
  6411.         PUSH    EAX
  6412.         CALL    SysReAllocStringLen
  6413.         TEST    EAX,EAX
  6414.         JE      WStrError
  6415. end;
  6416.  
  6417.  
  6418. procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
  6419. asm
  6420.         PUSH    EDX
  6421.         MOV     EDX,ESP
  6422.         MOV     ECX,1
  6423.         CALL    _WStrFromPCharLen
  6424.         POP     EDX
  6425. end;
  6426.  
  6427.  
  6428. procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
  6429. asm
  6430.         PUSH    EDX
  6431.         MOV     EDX,ESP
  6432.         MOV     ECX,1
  6433.         CALL    _WStrFromPWCharLen
  6434.         POP     EDX
  6435. end;
  6436.  
  6437.  
  6438. procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
  6439. asm
  6440.         XOR     ECX,ECX
  6441.         TEST    EDX,EDX
  6442.         JE      @@5
  6443.         PUSH    EDX
  6444. @@0:    CMP     CL,[EDX+0]
  6445.         JE      @@4
  6446.         CMP     CL,[EDX+1]
  6447.         JE      @@3
  6448.         CMP     CL,[EDX+2]
  6449.         JE      @@2
  6450.         CMP     CL,[EDX+3]
  6451.         JE      @@1
  6452.         ADD     EDX,4
  6453.         JMP     @@0
  6454. @@1:    INC     EDX
  6455. @@2:    INC     EDX
  6456. @@3:    INC     EDX
  6457. @@4:    MOV     ECX,EDX
  6458.         POP     EDX
  6459.         SUB     ECX,EDX
  6460. @@5:    JMP     _WStrFromPCharLen
  6461. end;
  6462.  
  6463.  
  6464. procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
  6465. asm
  6466.         XOR     ECX,ECX
  6467.         TEST    EDX,EDX
  6468.         JE      @@5
  6469.         PUSH    EDX
  6470. @@0:    CMP     CX,[EDX+0]
  6471.         JE      @@4
  6472.         CMP     CX,[EDX+2]
  6473.         JE      @@3
  6474.         CMP     CX,[EDX+4]
  6475.         JE      @@2
  6476.         CMP     CX,[EDX+6]
  6477.         JE      @@1
  6478.         ADD     EDX,8
  6479.         JMP     @@0
  6480. @@1:    ADD     EDX,2
  6481. @@2:    ADD     EDX,2
  6482. @@3:    ADD     EDX,2
  6483. @@4:    MOV     ECX,EDX
  6484.         POP     EDX
  6485.         SUB     ECX,EDX
  6486.         SHR     ECX,1
  6487. @@5:    JMP     _WStrFromPWCharLen
  6488. end;
  6489.  
  6490.  
  6491. procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
  6492. asm
  6493.         XOR     ECX,ECX
  6494.         MOV     CL,[EDX]
  6495.         INC     EDX
  6496.         JMP     _WStrFromPCharLen
  6497. end;
  6498.  
  6499.  
  6500. procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  6501. asm
  6502.         PUSH    EDI
  6503.         PUSH    EAX
  6504.         PUSH    ECX
  6505.         MOV     EDI,EDX
  6506.         XOR     EAX,EAX
  6507.         REPNE   SCASB
  6508.         JNE     @@1
  6509.         NOT     ECX
  6510. @@1:    POP     EAX
  6511.         ADD     ECX,EAX
  6512.         POP     EAX
  6513.         POP     EDI
  6514.         JMP     _WStrFromPCharLen
  6515. end;
  6516.  
  6517.  
  6518. procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
  6519. asm
  6520.         PUSH    EDI
  6521.         PUSH    EAX
  6522.         PUSH    ECX
  6523.         MOV     EDI,EDX
  6524.         XOR     EAX,EAX
  6525.         REPNE   SCASW
  6526.         JNE     @@1
  6527.         NOT     ECX
  6528. @@1:    POP     EAX
  6529.         ADD     ECX,EAX
  6530.         POP     EAX
  6531.         POP     EDI
  6532.         JMP     _WStrFromPWCharLen
  6533. end;
  6534.  
  6535.  
  6536. procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
  6537. asm
  6538.         XOR     ECX,ECX
  6539.         TEST    EDX,EDX
  6540.         JE      @@1
  6541.         MOV     ECX,[EDX-4]
  6542. @@1:    JMP     _WStrFromPCharLen
  6543. end;
  6544.  
  6545.  
  6546. procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
  6547. var
  6548.   SourceLen, DestLen: Integer;
  6549.   Buffer: array[0..511] of Char;
  6550. begin
  6551.   SourceLen := Length(Source);
  6552.   if SourceLen >= 255 then SourceLen := 255;
  6553.   if SourceLen = 0 then DestLen := 0 else
  6554.   begin
  6555.     DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen,
  6556.       Buffer, SizeOf(Buffer), nil, nil);
  6557.     if DestLen > MaxLen then DestLen := MaxLen;
  6558.   end;
  6559.   Dest^[0] := Chr(DestLen);
  6560.   if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
  6561. end;
  6562.  
  6563.  
  6564. function _WStrToPWChar(const S: WideString): PWideChar;
  6565. asm
  6566.         TEST    EAX,EAX
  6567.         JE      @@1
  6568.         RET
  6569.         NOP
  6570. @@0:    DW      0
  6571. @@1:    MOV     EAX,OFFSET @@0
  6572. end;
  6573.  
  6574.  
  6575. function _WStrLen(const S: WideString): Integer;
  6576. asm
  6577.         TEST    EAX,EAX
  6578.         JE      @@1
  6579.         MOV     EAX,[EAX-4]
  6580.         SHR     EAX,1
  6581. @@1:
  6582. end;
  6583.  
  6584.  
  6585. procedure _WStrCat(var Dest: WideString; const Source: WideString);
  6586. var
  6587.   DestLen, SourceLen: Integer;
  6588.   NewStr: PWideChar;
  6589. begin
  6590.   SourceLen := Length(Source);
  6591.   if SourceLen <> 0 then
  6592.   begin
  6593.     DestLen := Length(Dest);
  6594.     NewStr := _NewWideString(DestLen + SourceLen);
  6595.     if DestLen > 0 then
  6596.       Move(Pointer(Dest)^, NewStr^, DestLen * 2);
  6597.     Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2);
  6598.     WStrSet(Dest, NewStr);
  6599.   end;
  6600. end;
  6601.  
  6602.  
  6603. procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
  6604. var
  6605.   Source1Len, Source2Len: Integer;
  6606.   NewStr: PWideChar;
  6607. begin
  6608.   Source1Len := Length(Source1);
  6609.   Source2Len := Length(Source2);
  6610.   if (Source1Len <> 0) or (Source2Len <> 0) then
  6611.   begin
  6612.     NewStr := _NewWideString(Source1Len + Source2Len);
  6613.     Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2);
  6614.     Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2);
  6615.     WStrSet(Dest, NewStr);
  6616.   end;
  6617. end;
  6618.  
  6619.  
  6620. procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...};
  6621. asm
  6622.         {     ->EAX = Pointer to dest }
  6623.         {       EDX = number of args (>= 3) }
  6624.         {       [ESP+4], [ESP+8], ... crgCnt WideString arguments }
  6625.  
  6626.         PUSH    EBX
  6627.         PUSH    ESI
  6628.         PUSH    EDX
  6629.         PUSH    EAX
  6630.         MOV     EBX,EDX
  6631.  
  6632.         XOR     EAX,EAX
  6633. @@loop1:
  6634.         MOV     ECX,[ESP+EDX*4+4*4]
  6635.         TEST    ECX,ECX
  6636.         JE      @@1
  6637.         ADD     EAX,[ECX-4]
  6638. @@1:
  6639.         DEC     EDX
  6640.         JNE     @@loop1
  6641.  
  6642.         SHR     EAX,1
  6643.         CALL    _NewWideString
  6644.         PUSH    EAX
  6645.         MOV     ESI,EAX
  6646.  
  6647. @@loop2:
  6648.         MOV     EAX,[ESP+EBX*4+5*4]
  6649.         MOV     EDX,ESI
  6650.         TEST    EAX,EAX
  6651.         JE      @@2
  6652.         MOV     ECX,[EAX-4]
  6653.         ADD     ESI,ECX
  6654.         CALL    Move
  6655. @@2:
  6656.         DEC     EBX
  6657.         JNE     @@loop2
  6658.  
  6659.         POP     EDX
  6660.         POP     EAX
  6661.         CALL    WStrSet
  6662.  
  6663.         POP     EDX
  6664.         POP     ESI
  6665.         POP     EBX
  6666.         POP     EAX
  6667.         LEA     ESP,[ESP+EDX*4]
  6668.         JMP     EAX
  6669. end;
  6670.  
  6671.  
  6672. procedure _WStrCmp{left: WideString; right: WideString};
  6673. asm
  6674. {     ->EAX = Pointer to left string    }
  6675. {       EDX = Pointer to right string   }
  6676.  
  6677.         PUSH    EBX
  6678.         PUSH    ESI
  6679.         PUSH    EDI
  6680.  
  6681.         MOV     ESI,EAX
  6682.         MOV     EDI,EDX
  6683.  
  6684.         CMP     EAX,EDX
  6685.         JE      @@exit
  6686.  
  6687.         TEST    ESI,ESI
  6688.         JE      @@str1null
  6689.  
  6690.         TEST    EDI,EDI
  6691.         JE      @@str2null
  6692.  
  6693.         MOV     EAX,[ESI-4]
  6694.         MOV     EDX,[EDI-4]
  6695.  
  6696.         SUB     EAX,EDX { eax = len1 - len2 }
  6697.         JA      @@skip1
  6698.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  6699.  
  6700. @@skip1:
  6701.         PUSH    EDX
  6702.         SHR     EDX,2
  6703.         JE      @@cmpRest
  6704. @@longLoop:
  6705.         MOV     ECX,[ESI]
  6706.         MOV     EBX,[EDI]
  6707.         CMP     ECX,EBX
  6708.         JNE     @@misMatch
  6709.         DEC     EDX
  6710.         JE      @@cmpRestP4
  6711.         MOV     ECX,[ESI+4]
  6712.         MOV     EBX,[EDI+4]
  6713.         CMP     ECX,EBX
  6714.         JNE     @@misMatch
  6715.         ADD     ESI,8
  6716.         ADD     EDI,8
  6717.         DEC     EDX
  6718.         JNE     @@longLoop
  6719.         JMP     @@cmpRest
  6720. @@cmpRestP4:
  6721.         ADD     ESI,4
  6722.         ADD     EDI,4
  6723. @@cmpRest:
  6724.         POP     EDX
  6725.         AND     EDX,2
  6726.         JE      @@equal
  6727.  
  6728.         MOV     CX,[ESI]
  6729.         MOV     BX,[EDI]
  6730.         CMP     CX,BX
  6731.         JNE     @@exit
  6732.  
  6733. @@equal:
  6734.         ADD     EAX,EAX
  6735.         JMP     @@exit
  6736.  
  6737. @@str1null:
  6738.         MOV     EDX,[EDI-4]
  6739.         SUB     EAX,EDX
  6740.         JMP     @@exit
  6741.  
  6742. @@str2null:
  6743.         MOV     EAX,[ESI-4]
  6744.         SUB     EAX,EDX
  6745.         JMP     @@exit
  6746.  
  6747. @@misMatch:
  6748.         POP     EDX
  6749.         CMP     CX,BX
  6750.         JNE     @@exit
  6751.         SHR     ECX,16
  6752.         SHR     EBX,16
  6753.         CMP     CX,BX
  6754.  
  6755. @@exit:
  6756.         POP     EDI
  6757.         POP     ESI
  6758.         POP     EBX
  6759. end;
  6760.  
  6761.  
  6762. function _NewWideString(Length: Integer): PWideChar;
  6763. asm
  6764.         TEST    EAX,EAX
  6765.         JE      @@1
  6766.         PUSH    EAX
  6767.         PUSH    0
  6768.         CALL    SysAllocStringLen
  6769.         TEST    EAX,EAX
  6770.         JE      WStrError
  6771. @@1:
  6772. end;
  6773.  
  6774.  
  6775. function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
  6776. var
  6777.   L, N: Integer;
  6778. begin
  6779.   L := Length(S);
  6780.   if Index < 1 then Index := 0 else
  6781.   begin
  6782.     Dec(Index);
  6783.     if Index > L then Index := L;
  6784.   end;
  6785.   if Count < 0 then N := 0 else
  6786.   begin
  6787.     N := L - Index;
  6788.     if N > Count then N := Count;
  6789.   end;
  6790.   _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N);
  6791. end;
  6792.  
  6793.  
  6794. procedure _WStrDelete(var S: WideString; Index, Count: Integer);
  6795. var
  6796.   L, N: Integer;
  6797.   NewStr: PWideChar;
  6798. begin
  6799.   L := Length(S);
  6800.   if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then
  6801.   begin
  6802.     Dec(Index);
  6803.     N := L - Index - Count;
  6804.     if N < 0 then N := 0;
  6805.     if (Index = 0) and (N = 0) then NewStr := nil else
  6806.     begin
  6807.       NewStr := _NewWideString(Index + N);
  6808.       if Index > 0 then
  6809.         Move(Pointer(S)^, NewStr^, Index * 2);
  6810.       if N > 0 then
  6811.         Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2);
  6812.     end;
  6813.     WStrSet(S, NewStr);
  6814.   end;
  6815. end;
  6816.  
  6817.  
  6818. procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
  6819. var
  6820.   SourceLen, DestLen: Integer;
  6821.   NewStr: PWideChar;
  6822. begin
  6823.   SourceLen := Length(Source);
  6824.   if SourceLen > 0 then
  6825.   begin
  6826.     DestLen := Length(Dest);
  6827.     if Index < 1 then Index := 0 else
  6828.     begin
  6829.       Dec(Index);
  6830.       if Index > DestLen then Index := DestLen;
  6831.     end;
  6832.     NewStr := _NewWideString(DestLen + SourceLen);
  6833.     if Index > 0 then
  6834.       Move(Pointer(Dest)^, NewStr^, Index * 2);
  6835.     Move(Pointer(Source)^, NewStr[Index], SourceLen * 2);
  6836.     if Index < DestLen then
  6837.       Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen],
  6838.         (DestLen - Index) * 2);
  6839.     WStrSet(Dest, NewStr);
  6840.   end;
  6841. end;
  6842.  
  6843.  
  6844. procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
  6845. asm
  6846. {     ->EAX     Pointer to substr               }
  6847. {       EDX     Pointer to string               }
  6848. {     <-EAX     Position of substr in s or 0    }
  6849.  
  6850.         TEST    EAX,EAX
  6851.         JE      @@noWork
  6852.  
  6853.         TEST    EDX,EDX
  6854.         JE      @@stringEmpty
  6855.  
  6856.         PUSH    EBX
  6857.         PUSH    ESI
  6858.         PUSH    EDI
  6859.  
  6860.         MOV     ESI,EAX                         { Point ESI to substr           }
  6861.         MOV     EDI,EDX                         { Point EDI to s                }
  6862.  
  6863.         MOV     ECX,[EDI-4]                     { ECX = Length(s)               }
  6864.         SHR     ECX,1
  6865.  
  6866.         PUSH    EDI                             { remember s position to calculate index        }
  6867.  
  6868.         MOV     EDX,[ESI-4]                     { EDX = Length(substr)          }
  6869.         SHR     EDX,1
  6870.  
  6871.         DEC     EDX                             { EDX = Length(substr) - 1              }
  6872.         JS      @@fail                          { < 0 ? return 0                        }
  6873.         MOV     AX,[ESI]                        { AL = first char of substr             }
  6874.         ADD     ESI,2                           { Point ESI to 2'nd char of substr      }
  6875.  
  6876.         SUB     ECX,EDX                         { #positions in s to look at    }
  6877.                                                 { = Length(s) - Length(substr) + 1      }
  6878.         JLE     @@fail
  6879. @@loop:
  6880.         REPNE   SCASW
  6881.         JNE     @@fail
  6882.         MOV     EBX,ECX                         { save outer loop counter               }
  6883.         PUSH    ESI                             { save outer loop substr pointer        }
  6884.         PUSH    EDI                             { save outer loop s pointer             }
  6885.  
  6886.         MOV     ECX,EDX
  6887.         REPE    CMPSW
  6888.         POP     EDI                             { restore outer loop s pointer  }
  6889.         POP     ESI                             { restore outer loop substr pointer     }
  6890.         JE      @@found
  6891.         MOV     ECX,EBX                         { restore outer loop counter    }
  6892.         JMP     @@loop
  6893.  
  6894. @@fail:
  6895.         POP     EDX                             { get rid of saved s pointer    }
  6896.         XOR     EAX,EAX
  6897.         JMP     @@exit
  6898.  
  6899. @@stringEmpty:
  6900.         XOR     EAX,EAX
  6901.         JMP     @@noWork
  6902.  
  6903. @@found:
  6904.         POP     EDX                             { restore pointer to first char of s    }
  6905.         MOV     EAX,EDI                         { EDI points of char after match        }
  6906.         SUB     EAX,EDX                         { the difference is the correct index   }
  6907.         SHR     EAX,1
  6908. @@exit:
  6909.         POP     EDI
  6910.         POP     ESI
  6911.         POP     EBX
  6912. @@noWork:
  6913. end;
  6914.  
  6915.  
  6916. procedure _WStrSetLength(var S: WideString; NewLength: Integer);
  6917. var
  6918.   NewStr: PWideChar;
  6919.   Count: Integer;
  6920. begin
  6921.   NewStr := nil;
  6922.   if NewLength > 0 then
  6923.   begin
  6924.     NewStr := _NewWideString(NewLength);
  6925.     Count := Length(S);
  6926.     if Count > 0 then
  6927.     begin
  6928.       if Count > NewLength then Count := NewLength;
  6929.       Move(Pointer(S)^, NewStr^, Count * 2);
  6930.     end;
  6931.   end;
  6932.   WStrSet(S, NewStr);
  6933. end;
  6934.  
  6935.  
  6936. function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
  6937. var
  6938.   P: PWideChar;
  6939. begin
  6940.   _WStrFromPWCharLen(Result, nil, Count);
  6941.   P := Pointer(Result);
  6942.   while Count > 0 do
  6943.   begin
  6944.     Dec(Count);
  6945.     P[Count] := Ch;
  6946.   end;
  6947. end;
  6948.  
  6949.  
  6950. procedure _WStrAddRef{var str: WideString};
  6951. asm
  6952.         MOV     EDX,[EAX]
  6953.         TEST    EDX,EDX
  6954.         JE      @@1
  6955.         PUSH    EAX
  6956.         MOV     ECX,[EDX-4]
  6957.         SHR     ECX,1
  6958.         PUSH    ECX
  6959.         PUSH    EDX
  6960.         CALL    SysAllocStringLen
  6961.         POP     EDX
  6962.         TEST    EAX,EAX
  6963.         JE      WStrError
  6964.         MOV     [EDX],EAX
  6965. @@1:
  6966. end;
  6967.  
  6968.  
  6969. procedure       _InitializeRecord{ p: Pointer; typeInfo: Pointer };
  6970. asm
  6971.         { ->    EAX pointer to record to be initialized }
  6972.         {       EDX pointer to type info                }
  6973.  
  6974.         XOR     ECX,ECX
  6975.  
  6976.         PUSH    EBX
  6977.         MOV     CL,[EDX+1]
  6978.  
  6979.         PUSH    ESI
  6980.         PUSH    EDI
  6981.  
  6982.         MOV     EBX,EAX
  6983.         LEA     ESI,[EDX+ECX+2+8]
  6984.         MOV     EDI,[EDX+ECX+2+4]
  6985.  
  6986. @@loop:
  6987.  
  6988.         MOV     EDX,[ESI]
  6989.         MOV     EAX,[ESI+4]
  6990.         ADD     EAX,EBX
  6991.         MOV     EDX,[EDX]
  6992.         CALL    _Initialize
  6993.         ADD     ESI,8
  6994.         DEC     EDI
  6995.         JG      @@loop
  6996.  
  6997.         POP     EDI
  6998.         POP     ESI
  6999.         POP     EBX
  7000. end;
  7001.  
  7002.  
  7003. const
  7004.   tkLString   = 10;
  7005.   tkWString   = 11;
  7006.   tkVariant   = 12;
  7007.   tkArray     = 13;
  7008.   tkRecord    = 14;
  7009.   tkInterface = 15;
  7010.  
  7011. procedure       _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7012. asm
  7013.         { ->    EAX     pointer to data to be initialized       }
  7014.         {       EDX     pointer to type info describing data    }
  7015.         {       ECX number of elements of that type             }
  7016.  
  7017.         PUSH    EBX
  7018.         PUSH    ESI
  7019.         PUSH    EDI
  7020.         MOV     EBX,EAX
  7021.         MOV     ESI,EDX
  7022.         MOV     EDI,ECX
  7023.  
  7024.         XOR     EDX,EDX
  7025.         MOV     AL,[ESI]
  7026.         MOV     DL,[ESI+1]
  7027.         XOR     ECX,ECX
  7028.  
  7029.         CMP     AL,tkLString
  7030.         JE      @@LString
  7031.         CMP     AL,tkWString
  7032.         JE      @@WString
  7033.         CMP     AL,tkVariant
  7034.         JE      @@Variant
  7035.         CMP     AL,tkArray
  7036.         JE      @@Array
  7037.         CMP     AL,tkRecord
  7038.         JE      @@Record
  7039.         CMP     AL,tkInterface
  7040.         JE      @@Interface
  7041.         MOV     AL,reInvalidPtr
  7042.         POP     EDI
  7043.         POP     ESI
  7044.         POP     EBX
  7045.         JMP     Error
  7046.  
  7047. @@LString:
  7048. @@WString:
  7049. @@Interface:
  7050.         MOV     [EBX],ECX
  7051.         ADD     EBX,4
  7052.         DEC     EDI
  7053.         JG      @@LString
  7054.         JMP     @@exit
  7055.  
  7056. @@Variant:
  7057.         MOV     [EBX   ],ECX
  7058.         MOV     [EBX+ 4],ECX
  7059.         MOV     [EBX+ 8],ECX
  7060.         MOV     [EBX+12],ECX
  7061.         ADD     EBX,16
  7062.         DEC     EDI
  7063.         JG      @@Variant
  7064.         JMP     @@exit
  7065.  
  7066. @@Array:
  7067.         PUSH    EBP
  7068.         MOV     EBP,EDX
  7069. @@ArrayLoop:
  7070.         MOV     EDX,[ESI+EBP+2+8]
  7071.         MOV     EAX,EBX
  7072.         ADD     EBX,[ESI+EBP+2]
  7073.         MOV     ECX,[ESI+EBP+2+4]
  7074.         MOV     EDX,[EDX]
  7075.         CALL    _InitializeArray
  7076.         DEC     EDI
  7077.         JG      @@ArrayLoop
  7078.         POP     EBP
  7079.         JMP     @@exit
  7080.  
  7081. @@Record:
  7082.         PUSH    EBP
  7083.         MOV     EBP,EDX
  7084. @@RecordLoop:
  7085.         MOV     EAX,EBX
  7086.         ADD     EBX,[ESI+EBP+2]
  7087.         MOV     EDX,ESI
  7088.         CALL    _InitializeRecord
  7089.         DEC     EDI
  7090.         JG      @@RecordLoop
  7091.         POP     EBP
  7092.  
  7093. @@exit:
  7094.  
  7095.         POP     EDI
  7096.         POP     ESI
  7097.     POP EBX
  7098. end;
  7099.  
  7100.  
  7101. procedure       _Initialize{ p: Pointer; typeInfo: Pointer};
  7102. asm
  7103.         MOV     ECX,1
  7104.         JMP     _InitializeArray
  7105. end;
  7106.  
  7107. procedure       _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
  7108. asm
  7109.         { ->    EAX pointer to record to be finalized   }
  7110.         {       EDX pointer to type info                }
  7111.  
  7112.         XOR     ECX,ECX
  7113.  
  7114.         PUSH    EBX
  7115.         MOV     CL,[EDX+1]
  7116.  
  7117.         PUSH    ESI
  7118.         PUSH    EDI
  7119.  
  7120.         MOV     EBX,EAX
  7121.         LEA     ESI,[EDX+ECX+2+8]
  7122.         MOV     EDI,[EDX+ECX+2+4]
  7123.  
  7124. @@loop:
  7125.  
  7126.         MOV     EDX,[ESI]
  7127.         MOV     EAX,[ESI+4]
  7128.         ADD     EAX,EBX
  7129.         MOV     EDX,[EDX]
  7130.         CALL    _Finalize
  7131.         ADD     ESI,8
  7132.         DEC     EDI
  7133.         JG      @@loop
  7134.  
  7135.         MOV     EAX,EBX
  7136.  
  7137.         POP     EDI
  7138.         POP     ESI
  7139.         POP     EBX
  7140. end;
  7141.  
  7142.  
  7143. procedure       _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7144. asm
  7145.         { ->    EAX     pointer to data to be finalized         }
  7146.         {       EDX     pointer to type info describing data    }
  7147.         {       ECX number of elements of that type             }
  7148.  
  7149.         PUSH    EAX
  7150.         PUSH    EBX
  7151.         PUSH    ESI
  7152.         PUSH    EDI
  7153.         MOV     EBX,EAX
  7154.         MOV     ESI,EDX
  7155.         MOV     EDI,ECX
  7156.  
  7157.         XOR     EDX,EDX
  7158.         MOV     AL,[ESI]
  7159.         MOV     DL,[ESI+1]
  7160.  
  7161.         CMP     AL,tkLString
  7162.         JE      @@LString
  7163.         CMP     AL,tkWString
  7164.         JE      @@WString
  7165.         CMP     AL,tkVariant
  7166.         JE      @@Variant
  7167.         CMP     AL,tkArray
  7168.         JE      @@Array
  7169.         CMP     AL,tkRecord
  7170.         JE      @@Record
  7171.         CMP     AL,tkInterface
  7172.         JE      @@Interface
  7173.         POP     EDI
  7174.         POP     ESI
  7175.         POP     EBX
  7176.         POP      EAX
  7177.         MOV     AL,reInvalidPtr
  7178.         JMP     Error
  7179.  
  7180. @@LString:
  7181.         CMP     ECX,1
  7182.         MOV     EAX,EBX
  7183.         JG      @@LStringArray
  7184.         CALL    _LStrClr
  7185.         JMP     @@exit
  7186. @@LStringArray:
  7187.         MOV     EDX,ECX
  7188.         CALL    _LStrArrayClr
  7189.         JMP     @@exit
  7190.  
  7191. @@WString:
  7192.         CMP     ECX,1
  7193.         MOV     EAX,EBX
  7194.         JG      @@WStringArray
  7195.         CALL    _WStrClr
  7196.         JMP     @@exit
  7197. @@WStringArray:
  7198.         MOV     EDX,ECX
  7199.         CALL    _WStrArrayClr
  7200.         JMP     @@exit
  7201.  
  7202. @@Variant:
  7203.                 MOV     EAX,EBX
  7204.                 ADD     EBX,16
  7205.         CALL    _VarClr
  7206.         DEC     EDI
  7207.         JG      @@Variant
  7208.         JMP     @@exit
  7209.  
  7210. @@Array:
  7211.         PUSH    EBP
  7212.         MOV     EBP,EDX
  7213. @@ArrayLoop:
  7214.         MOV     EDX,[ESI+EBP+2+8]
  7215.         MOV     EAX,EBX
  7216.         ADD     EBX,[ESI+EBP+2]
  7217.         MOV     ECX,[ESI+EBP+2+4]
  7218.         MOV     EDX,[EDX]
  7219.         CALL    _FinalizeArray
  7220.         DEC     EDI
  7221.         JG      @@ArrayLoop
  7222.         POP     EBP
  7223.         JMP     @@exit
  7224.  
  7225. @@Record:
  7226.         PUSH    EBP
  7227.         MOV     EBP,EDX
  7228. @@RecordLoop:
  7229.         MOV     EAX,EBX
  7230.         ADD     EBX,[ESI+EBP+2]
  7231.         MOV     EDX,ESI
  7232.         CALL    _FinalizeRecord
  7233.         DEC     EDI
  7234.         JG      @@RecordLoop
  7235.         POP     EBP
  7236.         JMP     @@exit
  7237.  
  7238. @@Interface:
  7239.         MOV     EAX,EBX
  7240.         ADD     EBX,4
  7241.         CALL    _IntfClear
  7242.         DEC     EDI
  7243.         JG      @@Interface
  7244. @@exit:
  7245.  
  7246.         POP     EDI
  7247.         POP     ESI
  7248.         POP     EBX
  7249.         POP     EAX
  7250. end;
  7251.  
  7252.  
  7253. procedure       _Finalize{ p: Pointer; typeInfo: Pointer};
  7254. asm
  7255.         MOV     ECX,1
  7256.         JMP     _FinalizeArray
  7257. end;
  7258.  
  7259. procedure       _AddRefRecord{ p: Pointer; typeInfo: Pointer };
  7260. asm
  7261.         { ->    EAX pointer to record to be referenced  }
  7262.         {       EDX pointer to type info        }
  7263.  
  7264.         XOR     ECX,ECX
  7265.  
  7266.         PUSH    EBX
  7267.         MOV     CL,[EDX+1]
  7268.  
  7269.         PUSH    ESI
  7270.         PUSH    EDI
  7271.  
  7272.         MOV     EBX,EAX
  7273.         LEA     ESI,[EDX+ECX+2+8]
  7274.         MOV     EDI,[EDX+ECX+2+4]
  7275.  
  7276. @@loop:
  7277.  
  7278.         MOV     EDX,[ESI]
  7279.         MOV     EAX,[ESI+4]
  7280.         ADD     EAX,EBX
  7281.         MOV     EDX,[EDX]
  7282.         CALL    _AddRef
  7283.         ADD     ESI,8
  7284.         DEC     EDI
  7285.         JG      @@loop
  7286.  
  7287.         POP     EDI
  7288.         POP     ESI
  7289.         POP     EBX
  7290. end;
  7291.  
  7292.  
  7293. procedure       _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7294. asm
  7295.         { ->    EAX     pointer to data to be referenced        }
  7296.         {       EDX     pointer to type info describing data    }
  7297.         {       ECX number of elements of that type             }
  7298.  
  7299.         PUSH    EBX
  7300.         PUSH    ESI
  7301.         PUSH    EDI
  7302.         MOV     EBX,EAX
  7303.         MOV     ESI,EDX
  7304.         MOV     EDI,ECX
  7305.  
  7306.         XOR     EDX,EDX
  7307.         MOV     AL,[ESI]
  7308.         MOV     DL,[ESI+1]
  7309.  
  7310.         CMP     AL,tkLString
  7311.         JE      @@LString
  7312.         CMP     AL,tkWString
  7313.         JE      @@WString
  7314.         CMP     AL,tkVariant
  7315.         JE      @@Variant
  7316.         CMP     AL,tkArray
  7317.         JE      @@Array
  7318.         CMP     AL,tkRecord
  7319.         JE      @@Record
  7320.         CMP     AL,tkInterface
  7321.         JE      @@Interface
  7322.         MOV     AL,reInvalidPtr
  7323.         POP     EDI
  7324.         POP     ESI
  7325.         POP     EBX
  7326.         JMP     Error
  7327.  
  7328. @@LString:
  7329.         MOV     EAX,[EBX]
  7330.         ADD     EBX,4
  7331.         CALL    _LStrAddRef
  7332.         DEC     EDI
  7333.         JG      @@LString
  7334.         JMP     @@exit
  7335.  
  7336. @@WString:
  7337.         MOV     EAX,EBX
  7338.         ADD     EBX,4
  7339.         CALL    _WStrAddRef
  7340.         DEC     EDI
  7341.         JG      @@WString
  7342.         JMP     @@exit
  7343.  
  7344. @@Variant:
  7345.         MOV     EAX,EBX
  7346.         ADD     EBX,16
  7347.         CALL    _VarAddRef
  7348.         DEC     EDI
  7349.         JG      @@Variant
  7350.         JMP     @@exit
  7351.  
  7352. @@Array:
  7353.         PUSH    EBP
  7354.         MOV     EBP,EDX
  7355. @@ArrayLoop:
  7356.         MOV     EDX,[ESI+EBP+2+8]
  7357.         MOV     EAX,EBX
  7358.         ADD     EBX,[ESI+EBP+2]
  7359.         MOV     ECX,[ESI+EBP+2+4]
  7360.         MOV     EDX,[EDX]
  7361.         CALL    _AddRefArray
  7362.         DEC     EDI
  7363.         JG      @@ArrayLoop
  7364.         POP     EBP
  7365.         JMP     @@exit
  7366.  
  7367. @@Record:
  7368.         PUSH    EBP
  7369.         MOV     EBP,EDX
  7370. @@RecordLoop:
  7371.         MOV     EAX,EBX
  7372.         ADD     EBX,[ESI+EBP+2]
  7373.         MOV     EDX,ESI
  7374.         CALL    _AddRefRecord
  7375.         DEC     EDI
  7376.         JG      @@RecordLoop
  7377.         POP     EBP
  7378.         JMP     @@exit
  7379.  
  7380. @@Interface:
  7381.         MOV     EAX,[EBX]
  7382.         ADD     EBX,4
  7383.         CALL    _IntfAddRef
  7384.         DEC     EDI
  7385.         JG      @@Interface
  7386. @@exit:
  7387.  
  7388.         POP     EDI
  7389.         POP     ESI
  7390.         POP     EBX
  7391. end;
  7392.  
  7393.  
  7394. procedure       _AddRef{ p: Pointer; typeInfo: Pointer};
  7395. asm
  7396.         MOV     ECX,1
  7397.         JMP     _AddRefArray
  7398. end;
  7399.  
  7400.  
  7401. procedure       _CopyRecord{ dest, source, typeInfo: Pointer };
  7402. asm
  7403.         { ->    EAX pointer to dest             }
  7404.         {       EDX pointer to source           }
  7405.         {       ECX pointer to typeInfo         }
  7406.  
  7407.         PUSH    EBX
  7408.         PUSH    ESI
  7409.         PUSH    EDI
  7410.         PUSH    EBP
  7411.  
  7412.         MOV     EBX,EAX
  7413.         MOV     ESI,EDX
  7414.  
  7415.         XOR     EAX,EAX
  7416.         MOV     AL,[ECX+1]
  7417.  
  7418.         LEA     EDI,[ECX+EAX+2+8]
  7419.         MOV     EBP,[EDI-4]
  7420.         XOR     EAX,EAX
  7421.         MOV     ECX,[EDI-8]
  7422.         PUSH    ECX
  7423. @@loop:
  7424.         MOV     ECX,[EDI+4]
  7425.         SUB     ECX,EAX
  7426.         JLE     @@nomove1
  7427.         MOV     EDX,EAX
  7428.         ADD     EAX,ESI
  7429.         ADD     EDX,EBX
  7430.         CALL    Move
  7431. @@noMove1:
  7432.         MOV     EAX,[EDI+4]
  7433.  
  7434.         MOV     EDX,[EDI]
  7435.         MOV     EDX,[EDX]
  7436.         MOV     CL,[EDX]
  7437.  
  7438.         CMP     CL,tkLString
  7439.         JE      @@LString
  7440.         CMP     CL,tkWString
  7441.         JE      @@WString
  7442.         CMP     CL,tkVariant
  7443.         JE      @@Variant
  7444.         CMP     CL,tkArray
  7445.         JE      @@Array
  7446.         CMP     CL,tkRecord
  7447.         JE      @@Record
  7448.         CMP     CL,tkInterface
  7449.         JE      @@Interface
  7450.         MOV     AL,reInvalidPtr
  7451.         POP     EBP
  7452.         POP     EDI
  7453.         POP     ESI
  7454.         POP     EBX
  7455.         JMP     Error
  7456.  
  7457. @@LString:
  7458.         MOV     EDX,[ESI+EAX]
  7459.         ADD     EAX,EBX
  7460.         CALL    _LStrAsg
  7461.         MOV     EAX,4
  7462.         JMP     @@common
  7463.  
  7464. @@WString:
  7465.         MOV     EDX,[ESI+EAX]
  7466.         ADD     EAX,EBX
  7467.         CALL    _WStrAsg
  7468.         MOV     EAX,4
  7469.         JMP     @@common
  7470.  
  7471. @@Variant:
  7472.         LEA     EDX,[ESI+EAX]
  7473.         ADD     EAX,EBX
  7474.         CALL    _VarCopy
  7475.         MOV     EAX,16
  7476.         JMP     @@common
  7477.  
  7478. @@Array:
  7479.         XOR     ECX,ECX
  7480.         MOV     CL,[EDX+1]
  7481.         PUSH    dword ptr [EDX+ECX+2]
  7482.         PUSH    dword ptr [EDX+ECX+2+4]
  7483.         MOV     ECX,[EDX+ECX+2+8]
  7484.         MOV     ECX,[ECX]
  7485.         LEA     EDX,[ESI+EAX]
  7486.         ADD     EAX,EBX
  7487.         CALL    _CopyArray
  7488.         POP     EAX
  7489.         JMP     @@common
  7490.  
  7491. @@Record:
  7492.         XOR     ECX,ECX
  7493.         MOV     CL,[EDX+1]
  7494.         MOV     ECX,[EDX+ECX+2]
  7495.         PUSH    ECX
  7496.         MOV     ECX,EDX
  7497.         LEA     EDX,[ESI+EAX]
  7498.         ADD     EAX,EBX
  7499.         CALL    _CopyRecord
  7500.         POP     EAX
  7501.         JMP     @@common
  7502.  
  7503. @@Interface:
  7504.         MOV     EDX,[ESI+EAX]
  7505.         ADD     EAX,EBX
  7506.         CALL    _IntfCopy
  7507.         MOV     EAX,4
  7508. @@common:
  7509.         ADD     EAX,[EDI+4]
  7510.         ADD     EDI,8
  7511.         DEC     EBP
  7512.         JNZ     @@loop
  7513.  
  7514.         POP     ECX
  7515.         SUB     ECX,EAX
  7516.         JLE     @@noMove2
  7517.         LEA     EDX,[EBX+EAX]
  7518.         ADD     EAX,ESI
  7519.         CALL    Move
  7520. @@noMove2:
  7521.  
  7522.         POP     EBP
  7523.         POP     EDI
  7524.         POP     ESI
  7525.         POP     EBX
  7526. end;
  7527.  
  7528.  
  7529. procedure       _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer };
  7530. asm
  7531.         { ->    EAX pointer to dest             }
  7532.         {       EDX pointer to source           }
  7533.         {       ECX offset of vmt in object     }
  7534.         {       [ESP+4] pointer to typeInfo     }
  7535.  
  7536.         ADD     ECX,EAX                         { pointer to dest vmt }
  7537.         PUSH    dword ptr [ECX]                 { save dest vmt }
  7538.         PUSH    ECX
  7539.         MOV     ECX,[ESP+4+4+4]
  7540.         CALL    _CopyRecord
  7541.         POP     ECX
  7542.         POP     dword ptr [ECX]                 { restore dest vmt }
  7543.         RET     4
  7544.  
  7545. end;
  7546.  
  7547. procedure       _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer };
  7548. asm
  7549.         { ->    EAX pointer to dest             }
  7550.         {       EDX pointer to source           }
  7551.         {       ECX pointer to typeInfo         }
  7552.         {       [ESP+4] count                   }
  7553.         PUSH    EBX
  7554.         PUSH    ESI
  7555.         PUSH    EDI
  7556.         PUSH    EBP
  7557.  
  7558.         MOV     EBX,EAX
  7559.         MOV     ESI,EDX
  7560.         MOV     EDI,ECX
  7561.         MOV     EBP,[ESP+4+4*4]
  7562.  
  7563.         MOV     CL,[EDI]
  7564.  
  7565.         CMP     CL,tkLString
  7566.         JE      @@LString
  7567.         CMP     CL,tkWString
  7568.         JE      @@WString
  7569.         CMP     CL,tkVariant
  7570.         JE      @@Variant
  7571.         CMP     CL,tkArray
  7572.         JE      @@Array
  7573.         CMP     CL,tkRecord
  7574.         JE      @@Record
  7575.         CMP     CL,tkInterface
  7576.         JE      @@Interface
  7577.         MOV     AL,reInvalidPtr
  7578.         POP     EBP
  7579.         POP     EDI
  7580.         POP     ESI
  7581.         POP     EBX
  7582.         JMP     Error
  7583.  
  7584. @@LString:
  7585.         MOV     EAX,EBX
  7586.         MOV     EDX,[ESI]
  7587.         CALL    _LStrAsg
  7588.         ADD     EBX,4
  7589.         ADD     ESI,4
  7590.         DEC     EBP
  7591.         JNE     @@LString
  7592.         JMP     @@exit
  7593.  
  7594. @@WString:
  7595.         MOV     EAX,EBX
  7596.         MOV     EDX,[ESI]
  7597.         CALL    _WStrAsg
  7598.         ADD     EBX,4
  7599.         ADD     ESI,4
  7600.         DEC     EBP
  7601.         JNE     @@WString
  7602.         JMP     @@exit
  7603.  
  7604. @@Variant:
  7605.         MOV     EAX,EBX
  7606.         MOV     EDX,ESI
  7607.         CALL    _VarCopy
  7608.         ADD     EBX,16
  7609.         ADD     ESI,16
  7610.         DEC     EBP
  7611.         JNE     @@Variant
  7612.         JMP     @@exit
  7613.  
  7614. @@Array:
  7615.         XOR     ECX,ECX
  7616.         MOV     CL,[EDI+1]
  7617.         LEA     EDI,[EDI+ECX+2]
  7618. @@ArrayLoop:
  7619.         MOV     EAX,EBX
  7620.         MOV     EDX,ESI
  7621.         MOV     ECX,[EDI+8]
  7622.         PUSH    dword ptr [EDI+4]
  7623.         CALL    _CopyArray
  7624.         ADD     EBX,[EDI]
  7625.         ADD     ESI,[EDI]
  7626.         DEC     EBP
  7627.         JNE     @@ArrayLoop
  7628.         JMP     @@exit
  7629.  
  7630. @@Record:
  7631.         MOV     EAX,EBX
  7632.         MOV     EDX,ESI
  7633.         MOV     ECX,EDI
  7634.         CALL    _CopyRecord
  7635.         XOR     EAX,EAX
  7636.         MOV     AL,[EDI+1]
  7637.         ADD     EBX,[EDI+EAX+2]
  7638.         ADD     ESI,[EDI+EAX+2]
  7639.         DEC     EBP
  7640.         JNE     @@Record
  7641.         JMP     @@exit
  7642.  
  7643. @@Interface:
  7644.         MOV     EAX,EBX
  7645.         MOV     EDX,[ESI]
  7646.         CALL    _IntfCopy
  7647.         ADD     EBX,4
  7648.         ADD     ESI,4
  7649.         DEC     EBP
  7650.         JNE     @@Interface
  7651. @@exit:
  7652.         POP     EBP
  7653.         POP     EDI
  7654.         POP     ESI
  7655.         POP     EBX
  7656.         RET     4
  7657. end;
  7658.  
  7659.  
  7660. procedure       _New{ size: Longint; typeInfo: Pointer};
  7661. asm
  7662.         { ->    EAX size of object to allocate  }
  7663.         {       EDX pointer to typeInfo         }
  7664.  
  7665.         PUSH    EDX
  7666.         CALL    _GetMem
  7667.         POP     EDX
  7668.         TEST    EAX,EAX
  7669.         JE      @@exit
  7670.         PUSH    EAX
  7671.         CALL    _Initialize
  7672.         POP     EAX
  7673. @@exit:
  7674. end;
  7675.  
  7676. procedure       _Dispose{ p: Pointer; typeInfo: Pointer};
  7677. asm
  7678.         { ->    EAX     Pointer to object to be disposed        }
  7679.         {       EDX     Pointer to type info            }
  7680.  
  7681.         PUSH    EAX
  7682.         CALL    _Finalize
  7683.         POP     EAX
  7684.         CALL    _FreeMem
  7685. end;
  7686.  
  7687. { ----------------------------------------------------- }
  7688. {       Wide character support                          }
  7689. { ----------------------------------------------------- }
  7690.  
  7691. function WideCharToString(Source: PWideChar): string;
  7692. begin
  7693.   WideCharToStrVar(Source, Result);
  7694. end;
  7695.  
  7696. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  7697. begin
  7698.   WideCharLenToStrVar(Source, SourceLen, Result);
  7699. end;
  7700.  
  7701. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  7702. var
  7703.   SourceLen: Integer;
  7704. begin
  7705.   SourceLen := 0;
  7706.   while Source[SourceLen] <> #0 do Inc(SourceLen);
  7707.   WideCharLenToStrVar(Source, SourceLen, Dest);
  7708. end;
  7709.  
  7710. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  7711.   var Dest: string);
  7712. var
  7713.   DestLen: Integer;
  7714.   Buffer: array[0..2047] of Char;
  7715. begin
  7716.   if SourceLen = 0 then
  7717.     Dest := ''
  7718.   else
  7719.     if SourceLen < SizeOf(Buffer) div 2 then
  7720.       SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
  7721.         Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
  7722.     else
  7723.     begin
  7724.       DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
  7725.         nil, 0, nil, nil);
  7726.       SetString(Dest, nil, DestLen);
  7727.       WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
  7728.         DestLen, nil, nil);
  7729.     end;
  7730. end;
  7731.  
  7732. function StringToWideChar(const Source: string; Dest: PWideChar;
  7733.   DestSize: Integer): PWideChar;
  7734. begin
  7735.   Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
  7736.     Dest, DestSize - 1)] := #0;
  7737.   Result := Dest;
  7738. end;
  7739.  
  7740. { ----------------------------------------------------- }
  7741. {       OLE string support                              }
  7742. { ----------------------------------------------------- }
  7743.  
  7744. function OleStrToString(Source: PWideChar): string;
  7745. begin
  7746.   OleStrToStrVar(Source, Result);
  7747. end;
  7748.  
  7749. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  7750. begin
  7751.   WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest);
  7752. end;
  7753.  
  7754. function StringToOleStr(const Source: string): PWideChar;
  7755. var
  7756.   SourceLen, ResultLen: Integer;
  7757.   Buffer: array[0..1023] of WideChar;
  7758. begin
  7759.   SourceLen := Length(Source);
  7760.   if Length(Source) < SizeOf(Buffer) div 2 then
  7761.     Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
  7762.       PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
  7763.   else
  7764.   begin
  7765.     ResultLen := MultiByteToWideChar(0, 0,
  7766.       Pointer(Source), SourceLen, nil, 0);
  7767.     Result := SysAllocStringLen(nil, ResultLen);
  7768.     MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
  7769.       Result, ResultLen);
  7770.   end;
  7771. end;
  7772.  
  7773. { ----------------------------------------------------- }
  7774. {       Variant support                                 }
  7775. { ----------------------------------------------------- }
  7776.  
  7777. type
  7778.   TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);
  7779.  
  7780. const
  7781.   varLast = varByte;
  7782.  
  7783. const
  7784.   BaseTypeMap: array[0..varLast] of TBaseType = (
  7785.     btErr,  { varEmpty }
  7786.     btNul,  { varNull }
  7787.     btInt,  { varSmallint }
  7788.     btInt,  { varInteger }
  7789.     btFlt,  { varSingle }
  7790.     btFlt,  { varDouble }
  7791.     btCur,  { varCurrency }
  7792.     btDat,  { varDate }
  7793.     btStr,  { varOleStr }
  7794.     btErr,  { varDispatch }
  7795.     btErr,  { varError }
  7796.     btBol,  { varBoolean }
  7797.     btErr,  { varVariant }
  7798.     btErr,  { varUnknown }
  7799.     btErr,  { Undefined }
  7800.     btErr,  { Undefined }
  7801.     btErr,  { Undefined }
  7802.     btInt); { varByte }
  7803.  
  7804. const
  7805.   OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
  7806.     (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
  7807.     (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
  7808.     (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
  7809.     (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
  7810.     (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
  7811.     (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
  7812.     (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
  7813.     (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));
  7814.  
  7815. const
  7816.   C10000: Single = 10000;
  7817.  
  7818. const
  7819.   opAdd  = 0;
  7820.   opSub  = 1;
  7821.   opMul  = 2;
  7822.   opDvd  = 3;
  7823.   opDiv  = 4;
  7824.   opMod  = 5;
  7825.   opShl  = 6;
  7826.   opShr  = 7;
  7827.   opAnd  = 8;
  7828.   opOr   = 9;
  7829.   opXor  = 10;
  7830.  
  7831. procedure _DispInvoke;
  7832. asm
  7833.         { ->    [ESP+4] Pointer to result or nil }
  7834.         {       [ESP+8] Pointer to variant }
  7835.         {       [ESP+12]        Pointer to call descriptor }
  7836.         {       [ESP+16]        Additional parameters, if any }
  7837.         JMP     VarDispProc
  7838. end;
  7839.  
  7840.  
  7841. procedure _DispInvokeError;
  7842. asm
  7843.         MOV     AL,reVarDispatch
  7844.         JMP     Error
  7845. end;
  7846.  
  7847. procedure VarCastError;
  7848. asm
  7849.         MOV     AL,reVarTypeCast
  7850.         JMP     Error
  7851. end;
  7852.  
  7853. procedure VarInvalidOp;
  7854. asm
  7855.         MOV     AL,reVarInvalidOp
  7856.         JMP     Error
  7857. end;
  7858.  
  7859. procedure _VarClear(var V : Variant);
  7860. asm
  7861.         XOR     EDX,EDX
  7862.         MOV     DX,[EAX].TVarData.VType
  7863.         TEST    EDX,varByRef
  7864.         JNE     @@1
  7865.         CMP     EDX,varOleStr
  7866.         JB      @@1
  7867.         CMP     EDX,varString
  7868.         JNE     @@2
  7869.         MOV     [EAX].TVarData.VType,varEmpty
  7870.         ADD     EAX,OFFSET TVarData.VString
  7871.         JMP     _LStrClr
  7872. @@1:    MOV     [EAX].TVarData.VType,varEmpty
  7873.         RET
  7874. @@2:    PUSH    EAX
  7875.         CALL    VariantClear
  7876. end;
  7877.  
  7878. procedure _VarCopy(var Dest : Variant; const Source: Variant);
  7879. asm
  7880.         CMP     EAX,EDX
  7881.         JE      @@7
  7882.         CMP     [EAX].TVarData.VType,varOleStr
  7883.         JB      @@3
  7884.         PUSH    EAX
  7885.         PUSH    EDX
  7886.         CMP     [EAX].TVarData.VType,varString
  7887.         JE      @@1
  7888.         PUSH    EAX
  7889.         CALL    VariantClear
  7890.         JMP     @@2
  7891. @@1:    ADD     EAX,OFFSET TVarData.VString
  7892.         CALL    _LStrClr
  7893. @@2:    POP     EDX
  7894.         POP     EAX
  7895. @@3:    CMP     [EDX].TVarData.VType,varOleStr
  7896.         JAE     @@4
  7897.         MOV     ECX,[EDX]
  7898.         MOV     [EAX],ECX
  7899.         MOV     ECX,[EDX+8]
  7900.         MOV     [EAX+8],ECX
  7901.         MOV     ECX,[EDX+12]
  7902.         MOV     [EAX+12],ECX
  7903.         RET
  7904. @@4:    CMP     [EDX].TVarData.VType,varString
  7905.         JNE     @@6
  7906.         MOV     EDX,[EDX].TVarData.VString
  7907.         OR      EDX,EDX
  7908.         JE      @@5
  7909.         MOV     ECX,[EDX-skew].StrRec.refCnt
  7910.         INC     ECX
  7911.         JLE     @@5
  7912.         MOV     [EDX-skew].StrRec.refCnt,ECX
  7913. @@5:    MOV     [EAX].TVarData.VType,varString
  7914.         MOV     [EAX].TVarData.VString,EDX
  7915.         RET
  7916. @@6:    MOV     [EAX].TVarData.VType,varEmpty
  7917.         PUSH    EDX
  7918.         PUSH    EAX
  7919.         CALL    VariantCopyInd
  7920.         OR      EAX,EAX
  7921.         JNE     VarInvalidOp
  7922. @@7:
  7923. end;
  7924.  
  7925. procedure VarChangeType(var Dest: Variant; const Source: Variant;
  7926.   DestType: Word);
  7927. type
  7928.   TVarMem = array[0..3] of Integer;
  7929. var
  7930.   Temp: TVarData;
  7931. begin
  7932.   if TVarData(Dest).VType = varString then
  7933.   begin
  7934.     Temp.VType := varEmpty;
  7935.     if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
  7936.       VarCastError;
  7937.     _VarClear(Dest);
  7938.     TVarMem(Dest)[0] := TVarMem(Temp)[0];
  7939.     TVarMem(Dest)[2] := TVarMem(Temp)[2];
  7940.     TVarMem(Dest)[3] := TVarMem(Temp)[3];
  7941.   end else
  7942.     if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
  7943.       VarCastError;
  7944. end;
  7945.  
  7946. procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
  7947. var
  7948.   StringPtr: Pointer;
  7949. begin
  7950.   StringPtr := nil;
  7951.   OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
  7952.   _VarClear(Dest);
  7953.   TVarData(Dest).VType := varString;
  7954.   TVarData(Dest).VString := StringPtr;
  7955. end;
  7956.  
  7957. procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
  7958. var
  7959.   OleStrPtr: PWideChar;
  7960. begin
  7961.   OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  7962.   _VarClear(Dest);
  7963.   TVarData(Dest).VType := varOleStr;
  7964.   TVarData(Dest).VOleStr := OleStrPtr;
  7965. end;
  7966.  
  7967. procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
  7968. var
  7969.   SourceType, DestType: Word;
  7970.   Temp: TVarData;
  7971. begin
  7972.   SourceType := TVarData(Source).VType;
  7973.   DestType := Word(VarType);
  7974.   if SourceType = DestType then
  7975.     _VarCopy(Dest, Source)
  7976.   else
  7977.   if SourceType = varString then
  7978.     if DestType = varOleStr then
  7979.       VarStringToOleStr(Variant(Dest), Source)
  7980.     else
  7981.     begin
  7982.       Temp.VType := varEmpty;
  7983.       VarStringToOleStr(Variant(Temp), Source);
  7984.       try
  7985.         VarChangeType(Variant(Dest), Variant(Temp), DestType);
  7986.       finally
  7987.         _VarClear(PVariant(@Temp)^);
  7988.       end;
  7989.     end
  7990.   else
  7991.   if DestType = varString then
  7992.     if SourceType = varOleStr then
  7993.       VarOleStrToString(Variant(Dest), Source)
  7994.     else
  7995.     begin
  7996.       Temp.VType := varEmpty;
  7997.       VarChangeType(Variant(Temp), Source, varOleStr);
  7998.       try
  7999.         VarOleStrToString(Variant(Dest), Variant(Temp));
  8000.       finally
  8001.         _VarClear(Variant(Temp));
  8002.       end;
  8003.     end
  8004.   else
  8005.     VarChangeType(Variant(Dest), Source, DestType);
  8006. end;
  8007.  
  8008. (* VarCast when the destination is OleVariant *)
  8009. procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
  8010. begin
  8011.   if VarType = varString then
  8012.     VarCastError
  8013.     else
  8014.     _VarCast(Dest, Source, VarType);
  8015. end;
  8016.  
  8017. procedure _VarToInt;
  8018. asm
  8019.         XOR     EDX,EDX
  8020.         MOV     DX,[EAX].TVarData.VType
  8021.         CMP     EDX,varInteger
  8022.         JE      @@0
  8023.         CMP     EDX,varSmallint
  8024.         JE      @@1
  8025.         CMP     EDX,varByte
  8026.         JE      @@2
  8027.         CMP     EDX,varDouble
  8028.         JE      @@5
  8029.         CMP     EDX,varSingle
  8030.         JE      @@4
  8031.         CMP     EDX,varCurrency
  8032.         JE      @@3
  8033.         SUB     ESP,16
  8034.         MOV     [ESP].TVarData.VType,varEmpty
  8035.         MOV     EDX,EAX
  8036.         MOV     EAX,ESP
  8037.         MOV     ECX,varInteger
  8038.         CALL    _VarCast
  8039.         MOV     EAX,[ESP].TVarData.VInteger
  8040.         ADD     ESP,16
  8041.         RET
  8042. @@0:    MOV     EAX,[EAX].TVarData.VInteger
  8043.         RET
  8044. @@1:    MOVSX   EAX,[EAX].TVarData.VSmallint
  8045.         RET
  8046. @@2:    MOVZX   EAX,[EAX].TVarData.VByte
  8047.         RET
  8048. @@3:    FILD    [EAX].TVarData.VCurrency
  8049.         FDIV    C10000
  8050.         JMP     @@6
  8051. @@4:    FLD     [EAX].TVarData.VSingle
  8052.         JMP     @@6
  8053. @@5:    FLD     [EAX].TVarData.VDouble
  8054. @@6:    PUSH    EAX
  8055.         FISTP   DWORD PTR [ESP]
  8056.         FWAIT
  8057.         POP     EAX
  8058. end;
  8059.  
  8060. procedure _VarToBool;
  8061. asm
  8062.         CMP     [EAX].TVarData.VType,varBoolean
  8063.         JE      @@1
  8064.         SUB     ESP,16
  8065.         MOV     [ESP].TVarData.VType,varEmpty
  8066.         MOV     EDX,EAX
  8067.         MOV     EAX,ESP
  8068.         MOV     ECX,varBoolean
  8069.         CALL    _VarCast
  8070.         MOV     AX,[ESP].TVarData.VBoolean
  8071.         ADD     ESP,16
  8072.         JMP     @@2
  8073. @@1:    MOV     AX,[EAX].TVarData.VBoolean
  8074. @@2:    NEG     AX
  8075.         SBB     EAX,EAX
  8076.         NEG     EAX
  8077. end;
  8078.  
  8079. procedure _VarToReal;
  8080. asm
  8081.         XOR     EDX,EDX
  8082.         MOV     DX,[EAX].TVarData.VType
  8083.         CMP     EDX,varDouble
  8084.         JE      @@1
  8085.         CMP     EDX,varSingle
  8086.         JE      @@2
  8087.         CMP     EDX,varCurrency
  8088.         JE      @@3
  8089.         CMP     EDX,varInteger
  8090.         JE      @@4
  8091.         CMP     EDX,varSmallint
  8092.         JE      @@5
  8093.         CMP     EDX,varDate
  8094.         JE      @@1
  8095.         SUB     ESP,16
  8096.         MOV     [ESP].TVarData.VType,varEmpty
  8097.         MOV     EDX,EAX
  8098.         MOV     EAX,ESP
  8099.         MOV     ECX,varDouble
  8100.         CALL    _VarCast
  8101.         FLD     [ESP].TVarData.VDouble
  8102.         ADD     ESP,16
  8103.         RET
  8104. @@1:    FLD     [EAX].TVarData.VDouble
  8105.         RET
  8106. @@2:    FLD     [EAX].TVarData.VSingle
  8107.         RET
  8108. @@3:    FILD    [EAX].TVarData.VCurrency
  8109.         FDIV    C10000
  8110.         RET
  8111. @@4:    FILD    [EAX].TVarData.VInteger
  8112.         RET
  8113. @@5:    FILD    [EAX].TVarData.VSmallint
  8114. end;
  8115.  
  8116. procedure _VarToCurr;
  8117. asm
  8118.         XOR     EDX,EDX
  8119.         MOV     DX,[EAX].TVarData.VType
  8120.         CMP     EDX,varCurrency
  8121.         JE      @@1
  8122.         CMP     EDX,varDouble
  8123.         JE      @@2
  8124.         CMP     EDX,varSingle
  8125.         JE      @@3
  8126.         CMP     EDX,varInteger
  8127.         JE      @@4
  8128.         CMP     EDX,varSmallint
  8129.         JE      @@5
  8130.         SUB     ESP,16
  8131.         MOV     [ESP].TVarData.VType,varEmpty
  8132.         MOV     EDX,EAX
  8133.         MOV     EAX,ESP
  8134.         MOV     ECX,varCurrency
  8135.         CALL    _VarCast
  8136.         FILD    [ESP].TVarData.VCurrency
  8137.         ADD     ESP,16
  8138.         RET
  8139. @@1:    FILD    [EAX].TVarData.VCurrency
  8140.         RET
  8141. @@2:    FLD     [EAX].TVarData.VDouble
  8142.         JMP     @@6
  8143. @@3:    FLD     [EAX].TVarData.VSingle
  8144.         JMP     @@6
  8145. @@4:    FILD    [EAX].TVarData.VInteger
  8146.         JMP     @@6
  8147. @@5:    FILD    [EAX].TVarData.VSmallint
  8148. @@6:    FMUL    C10000
  8149. end;
  8150.  
  8151. procedure _VarToPStr(var S; const V: Variant);
  8152. var
  8153.   Temp: string;
  8154. begin
  8155.   _VarToLStr(Temp, V);
  8156.   ShortString(S) := Temp;
  8157. end;
  8158.  
  8159. procedure _VarToLStr(var S: string; const V: Variant);
  8160. asm
  8161.         CMP     [EDX].TVarData.VType,varString
  8162.         JNE     @@1
  8163.         MOV     EDX,[EDX].TVarData.VString
  8164.         JMP     _LStrAsg
  8165. @@1:    PUSH    EBX
  8166.         MOV     EBX,EAX
  8167.         SUB     ESP,16
  8168.         MOV     [ESP].TVarData.VType,varEmpty
  8169.         MOV     EAX,ESP
  8170.         MOV     ECX,varString
  8171.         CALL    _VarCast
  8172.         MOV     EAX,EBX
  8173.         CALL    _LStrClr
  8174.         MOV     EAX,[ESP].TVarData.VString
  8175.         MOV     [EBX],EAX
  8176.         ADD     ESP,16
  8177.         POP     EBX
  8178. end;
  8179.  
  8180. procedure _VarToWStr(var S: WideString; const V: Variant);
  8181. asm
  8182.         CMP     [EDX].TVarData.VType,varOleStr
  8183.         JNE     @@1
  8184.         MOV     EDX,[EDX].TVarData.VOleStr
  8185.         JMP     _WStrAsg
  8186. @@1:    PUSH    EBX
  8187.         MOV     EBX,EAX
  8188.         SUB     ESP,16
  8189.         MOV     [ESP].TVarData.VType,varEmpty
  8190.         MOV     EAX,ESP
  8191.         MOV     ECX,varOleStr
  8192.         CALL    _VarCast
  8193.         MOV     EAX,EBX
  8194.         MOV     EDX,[ESP].TVarData.VOleStr
  8195.         CALL    WStrSet
  8196.         ADD     ESP,16
  8197.         POP     EBX
  8198. end;
  8199.  
  8200. procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
  8201. asm
  8202.         CMP     [EDX].TVarData.VType,varEmpty
  8203.         JE      _IntfClear
  8204.         CMP     [EDX].TVarData.VType,varUnknown
  8205.         JE      @@2
  8206.         CMP     [EDX].TVarData.VType,varDispatch
  8207.         JE      @@2
  8208.         CMP     [EDX].TVarData.VType,varUnknown+varByRef
  8209.         JE      @@1
  8210.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8211.         JNE     VarCastError
  8212. @@1:    MOV     EDX,[EDX].TVarData.VPointer
  8213.         MOV     EDX,[EDX]
  8214.         JMP     _IntfCopy
  8215. @@2:    MOV     EDX,[EDX].TVarData.VUnknown
  8216.         JMP     _IntfCopy
  8217. end;
  8218.  
  8219. procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
  8220. asm
  8221.         CMP     [EDX].TVarData.VType,varEmpty
  8222.         JE      _IntfClear
  8223.         CMP     [EDX].TVarData.VType,varDispatch
  8224.         JE      @@1
  8225.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8226.         JNE     VarCastError
  8227.         MOV     EDX,[EDX].TVarData.VPointer
  8228.         MOV     EDX,[EDX]
  8229.         JMP     _IntfCopy
  8230. @@1:    MOV     EDX,[EDX].TVarData.VDispatch
  8231.         JMP     _IntfCopy
  8232. end;
  8233.  
  8234. procedure _VarFromInt;
  8235. asm
  8236.         CMP     [EAX].TVarData.VType,varOleStr
  8237.         JB      @@1
  8238.         PUSH    EAX
  8239.         PUSH    EDX
  8240.         CALL    _VarClear
  8241.         POP     EDX
  8242.         POP     EAX
  8243. @@1:    MOV     [EAX].TVarData.VType,varInteger
  8244.         MOV     [EAX].TVarData.VInteger,EDX
  8245. end;
  8246.  
  8247. procedure _VarFromBool;
  8248. asm
  8249.         CMP     [EAX].TVarData.VType,varOleStr
  8250.         JB      @@1
  8251.         PUSH    EAX
  8252.         PUSH    EDX
  8253.         CALL    _VarClear
  8254.         POP     EDX
  8255.         POP     EAX
  8256. @@1:    MOV     [EAX].TVarData.VType,varBoolean
  8257.         NEG     DL
  8258.         SBB     EDX,EDX
  8259.         MOV     [EAX].TVarData.VBoolean,DX
  8260. end;
  8261.  
  8262. procedure _VarFromReal;
  8263. asm
  8264.         CMP     [EAX].TVarData.VType,varOleStr
  8265.         JB      @@1
  8266.         PUSH    EAX
  8267.         CALL    _VarClear
  8268.         POP     EAX
  8269. @@1:    MOV     [EAX].TVarData.VType,varDouble
  8270.         FSTP    [EAX].TVarData.VDouble
  8271.         FWAIT
  8272. end;
  8273.  
  8274. procedure _VarFromTDateTime;
  8275. asm
  8276.         CMP     [EAX].TVarData.VType,varOleStr
  8277.         JB      @@1
  8278.         PUSH    EAX
  8279.         CALL    _VarClear
  8280.         POP     EAX
  8281. @@1:    MOV     [EAX].TVarData.VType,varDate
  8282.         FSTP    [EAX].TVarData.VDouble
  8283.         FWAIT
  8284. end;
  8285.  
  8286. procedure _VarFromCurr;
  8287. asm
  8288.         CMP     [EAX].TVarData.VType,varOleStr
  8289.         JB      @@1
  8290.         PUSH    EAX
  8291.         CALL    _VarClear
  8292.         POP     EAX
  8293. @@1:    MOV     [EAX].TVarData.VType,varCurrency
  8294.         FISTP   [EAX].TVarData.VCurrency
  8295.         FWAIT
  8296. end;
  8297.  
  8298. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  8299. begin
  8300.   _VarFromLStr(V, Value);
  8301. end;
  8302.  
  8303. procedure _VarFromLStr(var V: Variant; const Value: string);
  8304. asm
  8305.         CMP     [EAX].TVarData.VType,varOleStr
  8306.         JB      @@1
  8307.         PUSH    EAX
  8308.         PUSH    EDX
  8309.         CALL    _VarClear
  8310.         POP     EDX
  8311.         POP     EAX
  8312. @@1:    TEST    EDX,EDX
  8313.         JE      @@3
  8314.         MOV     ECX,[EDX-skew].StrRec.refCnt
  8315.         INC     ECX
  8316.         JLE     @@2
  8317.         MOV     [EDX-skew].StrRec.refCnt,ECX
  8318.         JMP     @@3
  8319. @@2:    PUSH    EAX
  8320.         PUSH    EDX
  8321.         MOV     EAX,[EDX-skew].StrRec.length
  8322.         CALL    _NewAnsiString
  8323.         MOV     EDX,EAX
  8324.         POP     EAX
  8325.         PUSH    EDX
  8326.         MOV     ECX,[EDX-skew].StrRec.length
  8327.         CALL    Move
  8328.         POP     EDX
  8329.         POP     EAX
  8330. @@3:    MOV     [EAX].TVarData.VType,varString
  8331.         MOV     [EAX].TVarData.VString,EDX
  8332. end;
  8333.  
  8334. procedure _VarFromWStr(var V: Variant; const Value: WideString);
  8335. asm
  8336.         PUSH    EAX
  8337.         CMP     [EAX].TVarData.VType,varOleStr
  8338.         JB      @@1
  8339.         PUSH    EDX
  8340.         CALL    _VarClear
  8341.         POP     EDX
  8342. @@1:    XOR     EAX,EAX
  8343.         TEST    EDX,EDX
  8344.         JE      @@2
  8345.         MOV     EAX,[EDX-4]
  8346.         SHR     EAX,1
  8347.         JE      @@2
  8348.         PUSH    EAX
  8349.         PUSH    EDX
  8350.         CALL    SysAllocStringLen
  8351.         TEST    EAX,EAX
  8352.         JE      WStrError
  8353. @@2:    POP     EDX
  8354.         MOV     [EDX].TVarData.VType,varOleStr
  8355.         MOV     [EDX].TVarData.VOleStr,EAX
  8356. end;
  8357.  
  8358. procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
  8359. asm
  8360.         CMP     [EAX].TVarData.VType,varOleStr
  8361.         JB      @@1
  8362.         PUSH    EAX
  8363.         PUSH    EDX
  8364.         CALL    _VarClear
  8365.         POP     EDX
  8366.         POP     EAX
  8367. @@1:    MOV     [EAX].TVarData.VType,varUnknown
  8368.         MOV     [EAX].TVarData.VUnknown,EDX
  8369.         TEST    EDX,EDX
  8370.         JE      @@2
  8371.         PUSH    EDX
  8372.         MOV     EAX,[EDX]
  8373.         CALL    [EAX].vmtAddRef.Pointer
  8374. @@2:
  8375. end;
  8376.  
  8377. procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
  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,varDispatch
  8387.         MOV     [EAX].TVarData.VDispatch,EDX
  8388.         TEST    EDX,EDX
  8389.         JE      @@2
  8390.         PUSH    EDX
  8391.         MOV     EAX,[EDX]
  8392.         CALL    [EAX].vmtAddRef.Pointer
  8393. @@2:
  8394. end;
  8395.  
  8396. procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
  8397. begin
  8398.   _OleVarFromLStr(V, Value);
  8399. end;
  8400.  
  8401.  
  8402. procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
  8403. asm
  8404.         CMP     [EAX].TVarData.VType,varOleStr
  8405.         JB      @@1
  8406.         PUSH    EAX
  8407.         PUSH    EDX
  8408.         CALL    _VarClear
  8409.         POP     EDX
  8410.         POP     EAX
  8411. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  8412.         ADD     EAX,TVarData.VOleStr
  8413.         XOR     ECX,ECX
  8414.         MOV     [EAX],ECX
  8415.         JMP     _WStrFromLStr
  8416. end;
  8417.  
  8418.  
  8419. procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
  8420. asm
  8421.         CMP     [EDX].TVarData.VType,varString
  8422.         JNE     _VarCopy
  8423.         CMP     [EAX].TVarData.VType,varOleStr
  8424.         JB      @@1
  8425.         PUSH    EAX
  8426.         PUSH    EDX
  8427.         CALL    _VarClear
  8428.         POP     EDX
  8429.         POP     EAX
  8430. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  8431.         ADD     EAX,TVarData.VOleStr
  8432.         ADD     EDX,TVarData.VString
  8433.         XOR     ECX,ECX
  8434.         MOV     EDX,[EDX]
  8435.         MOV     [EAX],ECX
  8436.         JMP     _WStrFromLStr
  8437. end;
  8438.  
  8439.  
  8440. procedure VarStrCat(var Dest: Variant; const Source: Variant);
  8441. begin
  8442.   Dest := string(Dest) + string(Source);
  8443. end;
  8444.  
  8445. procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
  8446. asm
  8447.         PUSH    EBX
  8448.         PUSH    ESI
  8449.         PUSH    EDI
  8450.         MOV     EDI,EAX
  8451.         MOV     ESI,EDX
  8452.         MOV     EBX,ECX
  8453.         MOV     EAX,[EDI].TVarData.VType.Integer
  8454.         MOV     EDX,[ESI].TVarData.VType.Integer
  8455.         AND     EAX,varTypeMask
  8456.         AND     EDX,varTypeMask
  8457.         CMP     EAX,varLast
  8458.         JBE     @@1
  8459.         CMP     EAX,varString
  8460.         JNE     @InvalidOp
  8461.         MOV     EAX,varOleStr
  8462. @@1:    CMP     EDX,varLast
  8463.         JBE     @@2
  8464.         CMP     EDX,varString
  8465.         JNE     @InvalidOp
  8466.         MOV     EDX,varOleStr
  8467. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  8468.         MOV     DL,BaseTypeMap.Byte[EDX]
  8469.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  8470.         CALL    @VarOpTable.Pointer[ECX*4]
  8471.         POP     EDI
  8472.         POP     ESI
  8473.         POP     EBX
  8474.         RET
  8475.  
  8476. @VarOpTable:
  8477.         DD      @VarOpError
  8478.         DD      @VarOpNull
  8479.         DD      @VarOpInteger
  8480.         DD      @VarOpReal
  8481.         DD      @VarOpCurr
  8482.         DD      @VarOpString
  8483.         DD      @VarOpBoolean
  8484.         DD      @VarOpDate
  8485.  
  8486. @VarOpError:
  8487.         POP     EAX
  8488.  
  8489. @InvalidOp:
  8490.         POP     EDI
  8491.         POP     ESI
  8492.         POP     EBX
  8493.         JMP     VarInvalidOp
  8494.  
  8495. @VarOpNull:
  8496.         MOV     EAX,EDI
  8497.         CALL    _VarClear
  8498.         MOV     [EDI].TVarData.VType,varNull
  8499.         RET
  8500.  
  8501. @VarOpInteger:
  8502.         CMP     BL,opDvd
  8503.         JE      @RealOp
  8504.  
  8505. @IntegerOp:
  8506.         MOV     EAX,ESI
  8507.         CALL    _VarToInt
  8508.         PUSH    EAX
  8509.         MOV     EAX,EDI
  8510.         CALL    _VarToInt
  8511.         POP     EDX
  8512.         CALL    @IntegerOpTable.Pointer[EBX*4]
  8513.         MOV     EDX,EAX
  8514.         MOV     EAX,EDI
  8515.         JMP     _VarFromInt
  8516.  
  8517. @IntegerOpTable:
  8518.         DD      @IntegerAdd
  8519.         DD      @IntegerSub
  8520.         DD      @IntegerMul
  8521.         DD      0
  8522.         DD      @IntegerDiv
  8523.         DD      @IntegerMod
  8524.         DD      @IntegerShl
  8525.         DD      @IntegerShr
  8526.         DD      @IntegerAnd
  8527.         DD      @IntegerOr
  8528.         DD      @IntegerXor
  8529.  
  8530. @IntegerAdd:
  8531.         ADD     EAX,EDX
  8532.         JO      @IntToRealOp
  8533.         RET
  8534.  
  8535. @IntegerSub:
  8536.         SUB     EAX,EDX
  8537.         JO      @IntToRealOp
  8538.         RET
  8539.  
  8540. @IntegerMul:
  8541.         IMUL    EDX
  8542.         JO      @IntToRealOp
  8543.         RET
  8544.  
  8545. @IntegerDiv:
  8546.         MOV     ECX,EDX
  8547.         CDQ
  8548.         IDIV    ECX
  8549.         RET
  8550.  
  8551. @IntegerMod:
  8552.         MOV     ECX,EDX
  8553.         CDQ
  8554.         IDIV    ECX
  8555.         MOV     EAX,EDX
  8556.         RET
  8557.  
  8558. @IntegerShl:
  8559.         MOV     ECX,EDX
  8560.         SHL     EAX,CL
  8561.         RET
  8562.  
  8563. @IntegerShr:
  8564.         MOV     ECX,EDX
  8565.         SHR     EAX,CL
  8566.         RET
  8567.  
  8568. @IntegerAnd:
  8569.         AND     EAX,EDX
  8570.         RET
  8571.  
  8572. @IntegerOr:
  8573.         OR      EAX,EDX
  8574.         RET
  8575.  
  8576. @IntegerXor:
  8577.         XOR     EAX,EDX
  8578.         RET
  8579.  
  8580. @IntToRealOp:
  8581.         POP     EAX
  8582.         JMP     @RealOp
  8583.  
  8584. @VarOpReal:
  8585.         CMP     BL,opDiv
  8586.         JAE     @IntegerOp
  8587.  
  8588. @RealOp:
  8589.         MOV     EAX,ESI
  8590.         CALL    _VarToReal
  8591.         SUB     ESP,12
  8592.         FSTP    TBYTE PTR [ESP]
  8593.         MOV     EAX,EDI
  8594.         CALL    _VarToReal
  8595.         FLD     TBYTE PTR [ESP]
  8596.         ADD     ESP,12
  8597.         CALL    @RealOpTable.Pointer[EBX*4]
  8598.  
  8599. @RealResult:
  8600.         MOV     EAX,EDI
  8601.         JMP     _VarFromReal
  8602.  
  8603. @VarOpCurr:
  8604.         CMP     BL,opDiv
  8605.         JAE     @IntegerOp
  8606.         CMP     BL,opMul
  8607.         JAE     @CurrMulDvd
  8608.         MOV     EAX,ESI
  8609.         CALL    _VarToCurr
  8610.         SUB     ESP,12
  8611.         FSTP    TBYTE PTR [ESP]
  8612.         MOV     EAX,EDI
  8613.         CALL    _VarToCurr
  8614.         FLD     TBYTE PTR [ESP]
  8615.         ADD     ESP,12
  8616.         CALL    @RealOpTable.Pointer[EBX*4]
  8617.  
  8618. @CurrResult:
  8619.         MOV     EAX,EDI
  8620.         JMP     _VarFromCurr
  8621.  
  8622. @CurrMulDvd:
  8623.         CMP     DL,btCur
  8624.         JE      @CurrOpCurr
  8625.         MOV     EAX,ESI
  8626.         CALL    _VarToReal
  8627.         FILD    [EDI].TVarData.VCurrency
  8628.         FXCH
  8629.         CALL    @RealOpTable.Pointer[EBX*4]
  8630.         JMP     @CurrResult
  8631.  
  8632. @CurrOpCurr:
  8633.         CMP     BL,opDvd
  8634.         JE      @CurrDvdCurr
  8635.         CMP     AL,btCur
  8636.         JE      @CurrMulCurr
  8637.         MOV     EAX,EDI
  8638.         CALL    _VarToReal
  8639.         FILD    [ESI].TVarData.VCurrency
  8640.         FMUL
  8641.         JMP     @CurrResult
  8642.  
  8643. @CurrMulCurr:
  8644.         FILD    [EDI].TVarData.VCurrency
  8645.         FILD    [ESI].TVarData.VCurrency
  8646.         FMUL
  8647.         FDIV    C10000
  8648.         JMP     @CurrResult
  8649.  
  8650. @CurrDvdCurr:
  8651.         MOV     EAX,EDI
  8652.         CALL    _VarToCurr
  8653.         FILD    [ESI].TVarData.VCurrency
  8654.         FDIV
  8655.         JMP     @RealResult
  8656.  
  8657. @RealOpTable:
  8658.         DD      @RealAdd
  8659.         DD      @RealSub
  8660.         DD      @RealMul
  8661.         DD      @RealDvd
  8662.  
  8663. @RealAdd:
  8664.         FADD
  8665.         RET
  8666.  
  8667. @RealSub:
  8668.         FSUB
  8669.         RET
  8670.  
  8671. @RealMul:
  8672.         FMUL
  8673.         RET
  8674.  
  8675. @RealDvd:
  8676.         FDIV
  8677.         RET
  8678.  
  8679. @VarOpString:
  8680.         CMP     BL,opAdd
  8681.         JNE     @VarOpReal
  8682.         MOV     EAX,EDI
  8683.         MOV     EDX,ESI
  8684.         JMP     VarStrCat
  8685.  
  8686. @VarOpBoolean:
  8687.         CMP     BL,opAnd
  8688.         JB      @VarOpReal
  8689.         MOV     EAX,ESI
  8690.         CALL    _VarToBool
  8691.         PUSH    EAX
  8692.         MOV     EAX,EDI
  8693.         CALL    _VarToBool
  8694.         POP     EDX
  8695.         CALL    @IntegerOpTable.Pointer[EBX*4]
  8696.         MOV     EDX,EAX
  8697.         MOV     EAX,EDI
  8698.         JMP     _VarFromBool
  8699.  
  8700. @VarOpDate:
  8701.         CMP     BL,opSub
  8702.         JA      @VarOpReal
  8703.         JB      @DateOp
  8704.         MOV     AH,DL
  8705.         CMP     AX,btDat+btDat*256
  8706.         JE      @RealOp
  8707.  
  8708. @DateOp:
  8709.         CALL    @RealOp
  8710.         MOV     [EDI].TVarData.VType,varDate
  8711.         RET
  8712. end;
  8713.  
  8714. procedure _VarAdd;
  8715. asm
  8716.         MOV     ECX,opAdd
  8717.         JMP     VarOp
  8718. end;
  8719.  
  8720. procedure _VarSub;
  8721. asm
  8722.         MOV     ECX,opSub
  8723.         JMP     VarOp
  8724. end;
  8725.  
  8726. procedure _VarMul;
  8727. asm
  8728.         MOV     ECX,opMul
  8729.         JMP     VarOp
  8730. end;
  8731.  
  8732. procedure _VarDiv;
  8733. asm
  8734.         MOV     ECX,opDiv
  8735.         JMP     VarOp
  8736. end;
  8737.  
  8738. procedure _VarMod;
  8739. asm
  8740.         MOV     ECX,opMod
  8741.         JMP     VarOp
  8742. end;
  8743.  
  8744. procedure _VarAnd;
  8745. asm
  8746.         MOV     ECX,opAnd
  8747.         JMP     VarOp
  8748. end;
  8749.  
  8750. procedure _VarOr;
  8751. asm
  8752.         MOV     ECX,opOr
  8753.         JMP     VarOp
  8754. end;
  8755.  
  8756. procedure _VarXor;
  8757. asm
  8758.         MOV     ECX,opXor
  8759.         JMP     VarOp
  8760. end;
  8761.  
  8762. procedure _VarShl;
  8763. asm
  8764.         MOV     ECX,opShl
  8765.         JMP     VarOp
  8766. end;
  8767.  
  8768. procedure _VarShr;
  8769. asm
  8770.         MOV     ECX,opShr
  8771.         JMP     VarOp
  8772. end;
  8773.  
  8774. procedure _VarRDiv;
  8775. asm
  8776.         MOV     ECX,opDvd
  8777.         JMP     VarOp
  8778. end;
  8779.  
  8780. function VarCompareString(const S1, S2: string): Integer;
  8781. asm
  8782.         PUSH    ESI
  8783.         PUSH    EDI
  8784.         MOV     ESI,EAX
  8785.         MOV     EDI,EDX
  8786.         OR      EAX,EAX
  8787.         JE      @@1
  8788.         MOV     EAX,[EAX-4]
  8789. @@1:    OR      EDX,EDX
  8790.         JE      @@2
  8791.         MOV     EDX,[EDX-4]
  8792. @@2:    MOV     ECX,EAX
  8793.         CMP     ECX,EDX
  8794.         JBE     @@3
  8795.         MOV     ECX,EDX
  8796. @@3:    CMP     ECX,ECX
  8797.         REPE    CMPSB
  8798.         JE      @@4
  8799.         MOVZX   EAX,BYTE PTR [ESI-1]
  8800.         MOVZX   EDX,BYTE PTR [EDI-1]
  8801. @@4:    SUB     EAX,EDX
  8802.         POP     EDI
  8803.         POP     ESI
  8804. end;
  8805.  
  8806. function VarCmpStr(const V1, V2: Variant): Integer;
  8807. begin
  8808.   Result := VarCompareString(V1, V2);
  8809. end;
  8810.  
  8811. procedure _VarCmp;
  8812. asm
  8813.         PUSH    ESI
  8814.         PUSH    EDI
  8815.         MOV     EDI,EAX
  8816.         MOV     ESI,EDX
  8817.         MOV     EAX,[EDI].TVarData.VType.Integer
  8818.         MOV     EDX,[ESI].TVarData.VType.Integer
  8819.         AND     EAX,varTypeMask
  8820.         AND     EDX,varTypeMask
  8821.         CMP     EAX,varLast
  8822.         JBE     @@1
  8823.         CMP     EAX,varString
  8824.         JNE     @VarCmpError
  8825.         MOV     EAX,varOleStr
  8826. @@1:    CMP     EDX,varLast
  8827.         JBE     @@2
  8828.         CMP     EDX,varString
  8829.         JNE     @VarCmpError
  8830.         MOV     EDX,varOleStr
  8831. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  8832.         MOV     DL,BaseTypeMap.Byte[EDX]
  8833.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  8834.         JMP     @VarCmpTable.Pointer[ECX*4]
  8835.  
  8836. @VarCmpTable:
  8837.         DD      @VarCmpError
  8838.         DD      @VarCmpNull
  8839.         DD      @VarCmpInteger
  8840.         DD      @VarCmpReal
  8841.         DD      @VarCmpCurr
  8842.         DD      @VarCmpString
  8843.         DD      @VarCmpBoolean
  8844.         DD      @VarCmpDate
  8845.  
  8846. @VarCmpError:
  8847.         POP     EDI
  8848.         POP     ESI
  8849.         JMP     VarInvalidOp
  8850.  
  8851. @VarCmpNull:
  8852.         CMP     AL,DL
  8853.         JMP     @Exit
  8854.  
  8855. @VarCmpInteger:
  8856.         MOV     EAX,ESI
  8857.         CALL    _VarToInt
  8858.         XCHG    EAX,EDI
  8859.         CALL    _VarToInt
  8860.         CMP     EAX,EDI
  8861.         JMP     @Exit
  8862.  
  8863. @VarCmpReal:
  8864. @VarCmpDate:
  8865.         MOV     EAX,EDI
  8866.         CALL    _VarToReal
  8867.         SUB     ESP,12
  8868.         FSTP    TBYTE PTR [ESP]
  8869.         MOV     EAX,ESI
  8870.         CALL    _VarToReal
  8871.         FLD     TBYTE PTR [ESP]
  8872.         ADD     ESP,12
  8873.  
  8874. @RealCmp:
  8875.         FCOMPP
  8876.         FNSTSW  AX
  8877.         MOV     AL,AH   { Move CF into SF }
  8878.         AND     AX,4001H
  8879.         ROR     AL,1
  8880.         OR      AH,AL
  8881.         SAHF
  8882.         JMP     @Exit
  8883.  
  8884. @VarCmpCurr:
  8885.         MOV     EAX,EDI
  8886.         CALL    _VarToCurr
  8887.         SUB     ESP,12
  8888.         FSTP    TBYTE PTR [ESP]
  8889.         MOV     EAX,ESI
  8890.         CALL    _VarToCurr
  8891.         FLD     TBYTE PTR [ESP]
  8892.         ADD     ESP,12
  8893.         JMP     @RealCmp
  8894.  
  8895. @VarCmpString:
  8896.         MOV     EAX,EDI
  8897.         MOV     EDX,ESI
  8898.         CALL    VarCmpStr
  8899.         CMP     EAX,0
  8900.         JMP     @Exit
  8901.  
  8902. @VarCmpBoolean:
  8903.         MOV     EAX,ESI
  8904.         CALL    _VarToBool
  8905.         XCHG    EAX,EDI
  8906.         CALL    _VarToBool
  8907.         MOV     EDX,EDI
  8908.         CMP     AL,DL
  8909.  
  8910. @Exit:
  8911.         POP     EDI
  8912.         POP     ESI
  8913. end;
  8914.  
  8915. procedure _VarNeg;
  8916. asm
  8917.         MOV     EDX,[EAX].TVarData.VType.Integer
  8918.         AND     EDX,varTypeMask
  8919.         CMP     EDX,varLast
  8920.         JBE     @@1
  8921.         CMP     EDX,varString
  8922.         JNE     @VarNegError
  8923.         MOV     EDX,varOleStr
  8924. @@1:    MOV     DL,BaseTypeMap.Byte[EDX]
  8925.         JMP     @VarNegTable.Pointer[EDX*4]
  8926.  
  8927. @VarNegTable:
  8928.         DD      @VarNegError
  8929.         DD      @VarNegNull
  8930.         DD      @VarNegInteger
  8931.         DD      @VarNegReal
  8932.         DD      @VarNegCurr
  8933.         DD      @VarNegReal
  8934.         DD      @VarNegInteger
  8935.         DD      @VarNegDate
  8936.  
  8937. @VarNegError:
  8938.         JMP     VarInvalidOp
  8939.  
  8940. @VarNegNull:
  8941.         RET
  8942.  
  8943. @VarNegInteger:
  8944.         PUSH    EAX
  8945.         CALL    _VarToInt
  8946.         NEG     EAX
  8947.         MOV     EDX,EAX
  8948.         POP     EAX
  8949.         JMP     _VarFromInt
  8950.  
  8951. @VarNegReal:
  8952.         PUSH    EAX
  8953.         CALL    _VarToReal
  8954.         FCHS
  8955.         POP     EAX
  8956.         JMP     _VarFromReal
  8957.  
  8958. @VarNegCurr:
  8959.         FILD    [EAX].TVarData.VCurrency
  8960.         FCHS
  8961.         FISTP   [EAX].TVarData.VCurrency
  8962.         FWAIT
  8963.         RET
  8964.  
  8965. @VarNegDate:
  8966.         FLD     [EAX].TVarData.VDate
  8967.         FCHS
  8968.         FSTP    [EAX].TVarData.VDate
  8969.         FWAIT
  8970. end;
  8971.  
  8972. procedure _VarNot;
  8973. asm
  8974.         MOV     EDX,[EAX].TVarData.VType.Integer
  8975.         AND     EDX,varTypeMask
  8976.         JE      @@2
  8977.         CMP     EDX,varBoolean
  8978.         JE      @@3
  8979.         CMP     EDX,varNull
  8980.         JE      @@4
  8981.         CMP     EDX,varLast
  8982.         JBE     @@1
  8983.         CMP     EDX,varString
  8984.         JNE     @@2
  8985. @@1:    PUSH    EAX
  8986.         CALL    _VarToInt
  8987.         NOT     EAX
  8988.         MOV     EDX,EAX
  8989.         POP     EAX
  8990.         JMP     _VarFromInt
  8991. @@2:    JMP     VarInvalidOp
  8992. @@3:    MOV     DX,[EAX].TVarData.VBoolean
  8993.         NEG     DX
  8994.         SBB     EDX,EDX
  8995.         NOT     EDX
  8996.         MOV     [EAX].TVarData.VBoolean,DX
  8997. @@4:
  8998. end;
  8999.  
  9000. procedure _VarClr;
  9001. asm
  9002.         PUSH    EAX
  9003.         CALL    _VarClear
  9004.         POP     EAX
  9005. end;
  9006.  
  9007. procedure _VarAddRef;
  9008. asm
  9009.         CMP     [EAX].TVarData.VType,varOleStr
  9010.         JB      @@1
  9011.         PUSH    [EAX].Integer[12]
  9012.         PUSH    [EAX].Integer[8]
  9013.         PUSH    [EAX].Integer[4]
  9014.         PUSH    [EAX].Integer[0]
  9015.         MOV     [EAX].TVarData.VType,varEmpty
  9016.         MOV     EDX,ESP
  9017.         CALL    _VarCopy
  9018.         ADD     ESP,16
  9019. @@1:
  9020. end;
  9021.  
  9022. function VarType(const V: Variant): Integer;
  9023. asm
  9024.         MOVZX   EAX,[EAX].TVarData.VType
  9025. end;
  9026.  
  9027. function VarAsType(const V: Variant; VarType: Integer): Variant;
  9028. begin
  9029.   _VarCast(Result, V, VarType);
  9030. end;
  9031.  
  9032. function VarIsEmpty(const V: Variant): Boolean;
  9033. begin
  9034.   with TVarData(V) do
  9035.     Result := (VType = varEmpty) or ((VType = varDispatch) or
  9036.       (VType = varUnknown)) and (VDispatch = nil);
  9037. end;
  9038.  
  9039. function VarIsNull(const V: Variant): Boolean;
  9040. begin
  9041.   Result := TVarData(V).VType = varNull;
  9042. end;
  9043.  
  9044. function VarToStr(const V: Variant): string;
  9045. begin
  9046.   if TVarData(V).VType <> varNull then Result := V else Result := '';
  9047. end;
  9048.  
  9049. function VarFromDateTime(DateTime: TDateTime): Variant;
  9050. begin
  9051.   _VarClear(Result);
  9052.   TVarData(Result).VType := varDate;
  9053.   TVarData(Result).VDate := DateTime;
  9054. end;
  9055.  
  9056. function VarToDateTime(const V: Variant): TDateTime;
  9057. var
  9058.   Temp: TVarData;
  9059. begin
  9060.   Temp.VType := varEmpty;
  9061.   _VarCast(Variant(Temp), V, varDate);
  9062.   Result := Temp.VDate;
  9063. end;
  9064.  
  9065. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  9066. var
  9067.   S: string;
  9068. begin
  9069.   if TVarData(V).VType >= varSmallint then S := V;
  9070.   Write(T, S: Width);
  9071.   Result := @T;
  9072. end;
  9073.  
  9074. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  9075. begin
  9076.   Result := _WriteVariant(T, V, 0);
  9077. end;
  9078.  
  9079. { ----------------------------------------------------- }
  9080. {       Variant array support                           }
  9081. { ----------------------------------------------------- }
  9082.  
  9083. function VarArrayCreate(const Bounds: array of Integer;
  9084.   VarType: Integer): Variant;
  9085. var
  9086.   I, DimCount: Integer;
  9087.   VarArrayRef: PVarArray;
  9088.   VarBounds: array[0..63] of TVarArrayBound;
  9089. begin
  9090.   if not Odd(High(Bounds)) or (High(Bounds) > 127) then
  9091.     Error(reVarArrayCreate);
  9092.   DimCount := (High(Bounds) + 1) div 2;
  9093.   for I := 0 to DimCount - 1 do
  9094.     with VarBounds[I] do
  9095.     begin
  9096.       LowBound := Bounds[I * 2];
  9097.       ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
  9098.     end;
  9099.   VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
  9100.   if VarArrayRef = nil then Error(reVarArrayCreate);
  9101.   _VarClear(Result);
  9102.   TVarData(Result).VType := VarType or varArray;
  9103.   TVarData(Result).VArray := VarArrayRef;
  9104. end;
  9105.  
  9106. function VarArrayOf(const Values: array of Variant): Variant;
  9107. var
  9108.   I: Integer;
  9109. begin
  9110.   Result := VarArrayCreate([0, High(Values)], varVariant);
  9111.   for I := 0 to High(Values) do Result[I] := Values[I];
  9112. end;
  9113.  
  9114. procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
  9115. var
  9116.   VarBound: TVarArrayBound;
  9117. begin
  9118.   if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
  9119.     Error(reVarNotArray);
  9120.   with TVarData(A).VArray^ do
  9121.     VarBound.LowBound := Bounds[DimCount - 1].LowBound;
  9122.   VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
  9123.   if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
  9124.     Error(reVarArrayCreate);
  9125. end;
  9126.  
  9127. function GetVarArray(const A: Variant): PVarArray;
  9128. begin
  9129.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9130.   if TVarData(A).VType and varByRef <> 0 then
  9131.     Result := PVarArray(TVarData(A).VPointer^) else
  9132.     Result := TVarData(A).VArray;
  9133. end;
  9134.  
  9135. function VarArrayDimCount(const A: Variant): Integer;
  9136. begin
  9137.   if TVarData(A).VType and varArray <> 0 then
  9138.     Result := GetVarArray(A)^.DimCount else
  9139.     Result := 0;
  9140. end;
  9141.  
  9142. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  9143. begin
  9144.   if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
  9145.     Error(reVarArrayBounds);
  9146. end;
  9147.  
  9148. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  9149. begin
  9150.   if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
  9151.     Error(reVarArrayBounds);
  9152. end;
  9153.  
  9154. function VarArrayLock(const A: Variant): Pointer;
  9155. begin
  9156.   if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
  9157.     Error(reVarNotArray);
  9158. end;
  9159.  
  9160. procedure VarArrayUnlock(const A: Variant);
  9161. begin
  9162.   if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
  9163.     Error(reVarNotArray);
  9164. end;
  9165.  
  9166. function VarArrayRef(const A: Variant): Variant;
  9167. begin
  9168.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9169.   _VarClear(Result);
  9170.   TVarData(Result).VType := TVarData(A).VType or varByRef;
  9171.   if TVarData(A).VType and varByRef <> 0 then
  9172.     TVarData(Result).VPointer := TVarData(A).VPointer else
  9173.     TVarData(Result).VPointer := @TVarData(A).VArray;
  9174. end;
  9175.  
  9176. function VarIsArray(const A: Variant): Boolean;
  9177. begin
  9178.   Result := TVarData(A).VType and varArray <> 0;
  9179. end;
  9180.  
  9181. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  9182.   Indices: Integer): Variant; cdecl;
  9183. var
  9184.   VarArrayPtr: PVarArray;
  9185.   VarType: Integer;
  9186. begin
  9187.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9188.   VarArrayPtr := GetVarArray(A);
  9189.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  9190.   VarType := TVarData(A).VType and varTypeMask;
  9191.   _VarClear(Result);
  9192.   if VarType = varVariant then
  9193.   begin
  9194.     if SafeArrayGetElement(VarArrayPtr, @Indices, @Result) <> 0 then
  9195.       Error(reVarArrayBounds);
  9196.   end else
  9197.   begin
  9198.     if SafeArrayGetElement(VarArrayPtr, @Indices,
  9199.       @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
  9200.     TVarData(Result).VType := VarType;
  9201.   end;
  9202. end;
  9203.  
  9204. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  9205.   IndexCount: Integer; Indices: Integer); cdecl;
  9206. var
  9207.   VarArrayPtr: PVarArray;
  9208.   VarType: Integer;
  9209.   P: Pointer;
  9210.   Temp: TVarData;
  9211. begin
  9212.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9213.   VarArrayPtr := GetVarArray(A);
  9214.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  9215.   VarType := TVarData(A).VType and varTypeMask;
  9216.   if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  9217.   begin
  9218.     if SafeArrayPutElement(VarArrayPtr, @Indices, @Value) <> 0 then
  9219.       Error(reVarArrayBounds);
  9220.   end else
  9221.   begin
  9222.     Temp.VType := varEmpty;
  9223.     try
  9224.       if VarType = varVariant then
  9225.       begin
  9226.         VarStringToOleStr(Variant(Temp), Value);
  9227.         P := @Temp;
  9228.       end else
  9229.       begin
  9230.         _VarCast(Variant(Temp), Value, VarType);
  9231.         case VarType of
  9232.           varOleStr, varDispatch, varUnknown:
  9233.             P := Temp.VPointer;
  9234.         else
  9235.           P := @Temp.VPointer;
  9236.         end;
  9237.       end;
  9238.       if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
  9239.         Error(reVarArrayBounds);
  9240.     finally
  9241.       _VarClear(Variant(Temp));
  9242.     end;
  9243.   end;
  9244. end;
  9245.  
  9246. { Package/Module registration/unregistration }
  9247.  
  9248. const
  9249.   LOCALE_SABBREVLANGNAME = $00000003;   { abbreviated language name }
  9250.   LOAD_LIBRARY_AS_DATAFILE = 2;
  9251.   HKEY_CURRENT_USER = $80000001;
  9252.   KEY_ALL_ACCESS = $000F003F;
  9253.  
  9254.   LocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize
  9255.  
  9256. function FindHInstance(Address: Pointer): Longint;
  9257. var
  9258.   MemInfo: TMemInfo;
  9259. begin
  9260.   VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
  9261.   if MemInfo.State = $1000{MEM_COMMIT} then
  9262.     Result := Longint(MemInfo.AllocationBase)
  9263.   else Result := 0;
  9264. end;
  9265.  
  9266. function FindClassHInstance(ClassType: TClass): Longint;
  9267. begin
  9268.   Result := FindHInstance(Pointer(ClassType));
  9269. end;
  9270.  
  9271. function FindResourceHInstance(Instance: Longint): Longint;
  9272. var
  9273.   CurModule: PLibModule;
  9274. begin
  9275.   CurModule := LibModuleList;
  9276.   while CurModule <> nil do
  9277.   begin
  9278.     if Instance = CurModule.Instance then
  9279.     begin
  9280.       Result := CurModule.ResInstance;
  9281.       Exit;
  9282.     end;
  9283.     CurModule := CurModule.Next;
  9284.   end;
  9285.   Result := Instance;
  9286. end;
  9287.  
  9288. function LoadResourceModule(ModuleName: PChar): Longint;
  9289. var
  9290.   FileName: array[0..260] of Char;
  9291.   Key: Integer;
  9292.   LocaleName, LocaleOverride: array[0..4] of Char;
  9293.   Size: Integer;
  9294.   P: PChar;
  9295. begin
  9296.   GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host appliation name
  9297.   LocaleOverride[0] := #0;
  9298.   if RegOpenKeyEx(HKEY_CURRENT_USER, LocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0 then
  9299.   try
  9300.     Size := SizeOf(LocaleOverride);
  9301.     if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then
  9302.       RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size);
  9303.   finally
  9304.     RegCloseKey(Key);
  9305.   end;
  9306.   lstrcpy(FileName, ModuleName);
  9307.   GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
  9308.   Result := 0;
  9309.   if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then
  9310.   begin
  9311.     P := PChar(@FileName) + lstrlen(FileName);
  9312.     while (P^ <> '.') and (P <> @FileName) do Dec(P);
  9313.     if P <> @FileName then
  9314.     begin
  9315.       Inc(P);
  9316.       // First look for a locale registry override
  9317.       if LocaleOverride[0] <> #0 then
  9318.       begin
  9319.         lstrcpy(P, LocaleOverride);
  9320.         Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  9321.       end;
  9322.       if (Result = 0) and (LocaleName[0] <> #0) then
  9323.       begin
  9324.         // Then look for a potential language/country translation
  9325.         lstrcpy(P, LocaleName);
  9326.         Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  9327.         if Result = 0 then
  9328.         begin
  9329.           // Finally look for a language only translation
  9330.           LocaleName[2] := #0;
  9331.           lstrcpy(P, LocaleName);
  9332.           Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
  9333.         end;
  9334.       end;
  9335.     end;
  9336.   end;
  9337. end;
  9338.  
  9339. procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer);
  9340. var
  9341.   CurModule: PLibModule;
  9342. begin
  9343.   CurModule := LibModuleList;
  9344.   while CurModule <> nil do
  9345.   begin
  9346.     if not Func(CurModule.Instance, Data) then Exit;
  9347.     CurModule := CurModule.Next;
  9348.   end;
  9349. end;
  9350.  
  9351. procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
  9352. var
  9353.   CurModule: PLibModule;
  9354. begin
  9355.   CurModule := LibModuleList;
  9356.   while CurModule <> nil do
  9357.   begin
  9358.     if not Func(CurModule.ResInstance, Data) then Exit;
  9359.     CurModule := CurModule.Next;
  9360.   end;
  9361. end;
  9362.  
  9363. procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
  9364. var
  9365.   P: PModuleUnloadRec;
  9366. begin
  9367.   New(P);
  9368.   P.Next := ModuleUnloadList;
  9369.   @P.Proc := @Proc;
  9370.   ModuleUnloadList := P;
  9371. end;
  9372.  
  9373. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
  9374. var
  9375.   P, C: PModuleUnloadRec;
  9376. begin
  9377.   P := ModuleUnloadList;
  9378.   if (P <> nil) and (@P.Proc = @Proc) then
  9379.   begin
  9380.     ModuleUnloadList := ModuleUnloadList.Next;
  9381.     Dispose(P);
  9382.   end else
  9383.   begin
  9384.     C := P;
  9385.     while C <> nil do
  9386.     begin
  9387.       if (C.Next <> nil) and (@C.Next.Proc = @Proc) then
  9388.       begin
  9389.         P := C.Next;
  9390.         C.Next := C.Next.Next;
  9391.         Dispose(P);
  9392.         Break;
  9393.       end;
  9394.       C := C.Next;
  9395.     end;
  9396.   end;
  9397. end;
  9398.  
  9399. procedure NotifyModuleUnload(HInstance: Longint);
  9400. var
  9401.   P: PModuleUnloadRec;
  9402. begin
  9403.   P := ModuleUnloadList;
  9404.   while P <> nil do
  9405.   begin
  9406.     try
  9407.       P.Proc(HInstance);
  9408.     except
  9409.       // Make sure it doesn't stop notifications
  9410.     end;
  9411.     P := P.Next;
  9412.   end;
  9413. end;
  9414.  
  9415. procedure RegisterModule(LibModule: PLibModule);
  9416. begin
  9417.   LibModule.Next := LibModuleList;
  9418.   LibModuleList := LibModule;
  9419. end;
  9420.  
  9421. procedure UnregisterModule(LibModule: PLibModule);
  9422. var
  9423.   CurModule: PLibModule;
  9424. begin
  9425.   try
  9426.     NotifyModuleUnload(LibModule.Instance);
  9427.   finally
  9428.     if LibModule = LibModuleList then
  9429.       LibModuleList := LibModule.Next
  9430.     else
  9431.     begin
  9432.       CurModule := LibModuleList;
  9433.       while CurModule <> nil do
  9434.       begin
  9435.         if CurModule.Next = LibModule then
  9436.         begin
  9437.           CurModule.Next := LibModule.Next;
  9438.           Break;
  9439.         end;
  9440.         CurModule := CurModule.Next;
  9441.       end;
  9442.     end;
  9443.   end;
  9444. end;
  9445.  
  9446. { ResString support function }
  9447.  
  9448. function LoadResString(ResStringRec: PResStringRec): string;
  9449. var
  9450.   Buffer: array[0..1023] of Char;
  9451. begin
  9452.   if ResStringRec <> nil then
  9453.     SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^),
  9454.       ResStringRec.Identifier, Buffer, SizeOf(Buffer)));
  9455. end;
  9456.  
  9457. procedure _IntfClear(var Dest: IUnknown);
  9458. asm
  9459.         MOV     EDX,[EAX]
  9460.         TEST    EDX,EDX
  9461.         JE      @@1
  9462.         MOV     DWORD PTR [EAX],0
  9463.         PUSH    EAX
  9464.         PUSH    EDX
  9465.         MOV     EAX,[EDX]
  9466.         CALL    [EAX].vmtRelease.Pointer
  9467.         POP     EAX
  9468. @@1:
  9469. end;
  9470.  
  9471. procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
  9472. asm
  9473.         MOV     ECX,[EAX]       { save dest }
  9474.         MOV     [EAX],EDX       { assign dest }
  9475.         TEST    EDX,EDX         { need to addref source before releasing dest }
  9476.         JE      @@1             { to make self assignment (I := I) work right }
  9477.         PUSH    ECX
  9478.         PUSH    EDX
  9479.         MOV     EAX,[EDX]
  9480.         CALL    [EAX].vmtAddRef.Pointer
  9481.         POP     ECX
  9482. @@1:    TEST    ECX,ECX
  9483.         JE      @@2
  9484.         PUSH    ECX
  9485.         MOV     EAX,[ECX]
  9486.         CALL    [EAX].vmtRelease.Pointer
  9487. @@2:
  9488. end;
  9489.  
  9490. procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
  9491. asm
  9492.         TEST    EDX,EDX
  9493.         JE      _IntfClear
  9494.         PUSH    EAX
  9495.         PUSH    ECX
  9496.         PUSH    EDX
  9497.         MOV     ECX,[EAX]
  9498.         TEST    ECX,ECX
  9499.         JE      @@1
  9500.         PUSH    ECX
  9501.         MOV     EAX,[ECX]
  9502.         CALL    [EAX].vmtRelease.Pointer
  9503.         MOV     EDX,[ESP]
  9504. @@1:    MOV     EAX,[EDX]
  9505.         CALL    [EAX].vmtQueryInterface.Pointer
  9506.         TEST    EAX,EAX
  9507.         JE      @@2
  9508.         MOV     AL,reIntfCastError
  9509.         JMP     Error
  9510. @@2:
  9511. end;
  9512.  
  9513. procedure _IntfAddRef(const Dest: IUnknown);
  9514. begin
  9515.   if Dest <> nil then Dest._AddRef;
  9516. end;
  9517.  
  9518. function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  9519. const
  9520.   E_NOINTERFACE = $80004002;
  9521. begin
  9522.   if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
  9523. end;
  9524.  
  9525. function TInterfacedObject._AddRef: Integer;
  9526. begin
  9527.   Inc(FRefCount);
  9528.   Result := FRefCount;
  9529. end;
  9530.  
  9531. function TInterfacedObject._Release: Integer;
  9532. begin
  9533.   Dec(FRefCount);
  9534.   if FRefCount = 0 then
  9535.   begin
  9536.     Destroy;
  9537.     Result := 0;
  9538.     Exit;
  9539.   end;
  9540.   Result := FRefCount;
  9541. end;
  9542.  
  9543. procedure _CheckAutoResult;
  9544. asm
  9545.         TEST    EAX,EAX
  9546.         JNS     @@2
  9547.         MOV     ECX,SafeCallErrorProc
  9548.         TEST    ECX,ECX
  9549.         JE      @@1
  9550.         MOV     EDX,[ESP]
  9551.         CALL    ECX
  9552. @@1:    MOV     AL,reSafeCallError
  9553.         JMP     Error
  9554. @@2:
  9555. end;
  9556.  
  9557.  
  9558. procedure _IntfDispCall;
  9559. asm
  9560.         JMP     DispCallByIDProc
  9561. end;
  9562.  
  9563.  
  9564. procedure _IntfVarCall;
  9565. asm
  9566. end;
  9567.  
  9568. initialization
  9569.  
  9570.   ExitCode  := 0;
  9571.   ErrorAddr := nil;
  9572.  
  9573.   RandSeed := 0;
  9574.   FileMode := 2;
  9575.  
  9576.   Test8086 := 2;
  9577.   Test8087 := 3;
  9578.  
  9579.   TVarData(Unassigned).VType := varEmpty;
  9580.   TVarData(Null).VType := varNull;
  9581.  
  9582.   if _isNECWindows then _FpuMaskInit;
  9583.   _FpuInit();
  9584.  
  9585.   _Assign( Input, '' );  { _ResetText( Input );   }
  9586.   _Assign( Output, '' );  { _RewritText( Output ); }
  9587.  
  9588.   CmdLine := GetCommandLine;
  9589.   CmdShow := GetCmdShow;
  9590.  
  9591. finalization
  9592.   Close(Input);
  9593.   Close(Output);
  9594.   UninitAllocator;
  9595. end.
  9596.