home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / vp21beta.zip / ARTLSRC.RAR / SYS / SYSTEM.PAS < prev    next >
Pascal/Delphi Source File  |  2000-08-15  |  360KB  |  9,406 lines
  1. //█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
  2. //█                                                       █
  3. //█      Virtual Pascal Runtime Library.  Version 2.1.    █
  4. //█      System unit                                      █
  5. //█      ─────────────────────────────────────────────────█
  6. //█      Copyright (C) 1995-2000 vpascal.com              █
  7. //█                                                       █
  8. //▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
  9.  
  10. {$S-,D-,M+,H+,X+,Speed+,Delphi+,Cdecl-,OrgName-,AlignRec-,SmartLink+,Optimise+,W-}
  11.  
  12. {$IFDEF LINUX}  {$DEFINE LNX_DPMI} {$ENDIF}
  13. {$IFDEF DPMI32} {$DEFINE LNX_DPMI} {$ENDIF}
  14.  
  15. unit System;
  16.  
  17. interface
  18.  
  19. type
  20.   Integer = SmallInt;
  21.   Word = SmallWord;
  22.   TDateTime = Double;
  23.   TProcedure = procedure;
  24.   PExtended = ^Extended;
  25.   PCurrency = ^Currency;
  26.   PShortString = ^ShortString;
  27.   PAnsiString = ^AnsiString;
  28.   PString = PAnsiString;
  29.  
  30. procedure AddExitProc(Proc: TProcedure);                        // Unit finalisation support
  31. procedure UniqueString(var LStr: String);
  32. procedure _Abstract;                                            // Entry point for any abstract virtual method
  33. procedure _Atan;                                                // 'ArcTan' standard function
  34. procedure _BlockRead (FileVar,Buffer:Pointer;Count:Longint;Result:Pointer); // 'BlockRead' standard procedure
  35. procedure _BlockWrite(FileVar,Buffer:Pointer;Count:Longint;Result:Pointer); // 'BlockWrite' standard procedure
  36. procedure _ClsAs(AClass,VMT: Pointer);                          // 'AS' class operator
  37. procedure _ClsCallDynCls(Self,Index: Longint);                  // Calls a dynamic class method using class reference
  38. procedure _ClsCallDynInst(Self,Index: Longint);                 // Calls a dynamic method using class instance
  39. procedure _ClsCtr;                                              // Class constructor support
  40. procedure _ClsDtr;                                              // Class destructor support
  41. procedure _ClsFindDynCls(Self,Index: Longint);                  // Finds a dynamic class method using class reference
  42. procedure _ClsFindDynInst(Self,Index: Longint);                 // Finds a dynamic method using class instance
  43. procedure _ClsIs(AClass,VMT: Pointer);                          // 'IS' class operator
  44. procedure _CopyOpArr   (ElementSize,Src: Longint);              // Open array copying support
  45. procedure _CopyOpArrChk(ElementSize,Src: Longint);              // The same, but with stack checking
  46. procedure _CopyParms(Data: Pointer);                            // Structured parameter copying support
  47. procedure _Cos;                                                 // 'Cos' standard function
  48. procedure _DirCh;                                               // 'ChDir' standard procedure (ShortString)
  49. procedure _DirChPCh;                                            // 'ChDir' standard procedure (PChar/AnsiString)
  50. procedure _DirGet(Drive: Byte; S: Pointer; SLen: Longint);      // 'GetDir' standard procedure (ShortString)
  51. procedure _DirGetL(Drive: Byte; var LStr: Pointer);             // 'GetDir' standard procedure (AnsiString)
  52. procedure _DirMk;                                               // 'MkDir' standard procedure (ShortString)
  53. procedure _DirMkPCh;                                            // 'MkDir' standard procedure (PChar/AnsiString)
  54. procedure _DirRm;                                               // 'RmDir' standard procedure (ShortString)
  55. procedure _DirRmPCh;                                            // 'RmDir' standard procedure (PChar/AnsiString)
  56. procedure _DmtCall(DynIndex: Longint);                          // Dynamic method call routine (objects)
  57. procedure _Eof(FileVar: Pointer);                               // 'Eof' standard function
  58. procedure _Erase(FileVar: Pointer);                             // 'Erase' standard procedure
  59. procedure _ErrOverflow;                                         // Arithmetic overflow error
  60. procedure _ErrRange;                                            // Range check error
  61. procedure _Exp;                                                 // 'Exp' standard function
  62. procedure _Ext2Real(Dest: Pointer);                             // Converts Extended to Real
  63. procedure _Far16Pas;                                            // Thunk support for calling Far16 routines
  64. procedure _FileAssign(FileVar,S: Pointer);                      // 'Assign' standard procedure (String)
  65. procedure _FileAssignPCh(FileVar,S: Pointer);                   // 'Assign' standard procedure (PChar)
  66. procedure _FileClose(FileVar: Pointer);                         // 'Close' standard procedure
  67. procedure _FilePos (FileVar: Pointer);                          // 'FilePos' standard function
  68. procedure _FileRead(FileVar,Buffer: Pointer);                   // 'Read' standard procedure
  69. procedure _FileReset(FileVar: Pointer; RecSize: Longint);       // 'Reset' standard procedure
  70. procedure _FileRewrite(FileVar: Pointer; RecSize: Longint);     // 'Rewrite' standard procedure
  71. procedure _FileSeek(FileVar: Pointer; FilePos: Longint);        // 'Seek' standard procedure
  72. procedure _FileSize(FileVar: Pointer);                          // 'FileSize' standard function
  73. procedure _FileTrunc(FileVar: Pointer);                         // 'Truncate' standard procedure
  74. procedure _FileWrite(FileVar,Buffer: Pointer);                  // 'Write' standard procedure
  75. procedure _Frac;                                                // 'Frac' standard function
  76. procedure _GetIORes;                                            // 'IOResult' standard function
  77. function  _GetTlsVar(var TlsVar): Pointer;                      // Returns an address of the THREADVAR variable
  78. procedure _Halt(ExitCode: Longint);                             // 'Halt' standard procedure
  79. procedure _IOChk;                                               // I/O result check
  80. procedure _In16(PortNo: Longint);                               // Inputs Word from I/O Port
  81. procedure _In32(PortNo: Longint);                               // Inputs DWord from I/O Port
  82. procedure _In8(PortNo: Longint);                                // Inputs Byte from I/O Port
  83. procedure _InitDll;                                             // DLL initialisation/termination start
  84. procedure _InitDllEnd(ExitCode: Longint);                       // DLL initialisation/termination end
  85. procedure _InitExe(Params,EnvPtr: Pointer; Reserved,ModHandle,RetAddr:Longint); // Program initialisation
  86. procedure _Int;                                                 // 'Int' standard function
  87. procedure _Ln;                                                  // 'Ln' standard function
  88. procedure _LStr2Str(SStr,LStr: Pointer; MaxLen: Longint);
  89. procedure _LStrAddRef(LStr: Pointer);
  90. procedure _LStrArray(Dest,Src: Pointer; Size: Longint);
  91. procedure _LStrAsn(var Dest: Pointer; Src: Pointer);
  92. procedure _LStrChar(LStr: Pointer; C: Char);
  93. procedure _LStrClr(LStr: Pointer);
  94. procedure _LStrCmp(LStr1,LStr2: Pointer);
  95. procedure _LStrConcat(var Dest: Pointer; Src: Pointer);
  96. procedure _LStrCopy(var Dest: Pointer; Src: Pointer; Index,Count: Longint);
  97. procedure _LStrDel(LStr: Pointer; Index,Count: Longint);
  98. procedure _LStrIns(Src: Pointer; var Dest: Pointer; Index: Longint);
  99. procedure _LStrLoad(var Dest: Pointer; Src: Pointer);
  100. procedure _LStrNew(Len: Longint);
  101. procedure _LStrOfChar(LStr: Pointer; C: Char; Count: Longint);
  102. procedure _LStrPChar(LStr: Pointer; Str: PChar);
  103. procedure _LStrPacked(Dest,Src: Pointer; Len: Longint);
  104. procedure _LStrPos(SubStr,LStr: Pointer);
  105. procedure _LStrSetLen(var LStr: Pointer; Len: Longint);
  106. procedure _LStrStr(var LStr: Pointer; SStr: Pointer);
  107. procedure _LStrToPChar(LStr: Pointer);
  108. procedure _MemAddRef(P,TypeInfo: Pointer);                      // Adds reference to all long string fields
  109. procedure _MemFill(Dest: Pointer; Count: Longint; Value: Byte); // 'FillChar' standard procedure
  110. procedure _MemFin(P,TypeInfo: Pointer);                         // 'Finalize' standard procedure
  111. procedure _MemFinCnt(P,TypeInfo: Pointer; Count: Longint);      // 'Finalize' standard procedure with Count optional parameter
  112. procedure _MemFree(P: Pointer);                                 // 'Dispose','FreeMem' standard procedures
  113. procedure _MemFreeFin(P,TypeInfo: Pointer);                     // 'Dispose' standard procedure (finalization is needed)
  114. procedure _MemInit(P,TypeInfo: Pointer);                        // 'Initialize' standard procedure
  115. procedure _MemInitCnt(P,TypeInfo: Pointer; Count: Longint);     // 'Initialize' standard procedure with Count optional parameter
  116. procedure _MemLocFin(Data: Pointer);                            // Finalization of the local memory
  117. procedure _MemLocInit(Data,Handler: Pointer);                   // Initialization of the local memory
  118. procedure _MemMove(Src,Dest: Pointer; Count: Longint);          // 'Move' standard procedure
  119. procedure _MemNew(Size: Longint);                               // 'New','GetMem' standard procedures
  120. procedure _MemNewInit(Size: Longint; TypeInfo: Pointer);        // 'New' standard procedure(initialization is needed)
  121. procedure _MemRealloc(var P: Pointer; Size: Longint);           // 'ReallocMem' standard procedure
  122. procedure _ObjChk(VmtPtr: Longint);                             // Object initialisation check
  123. procedure _ObjCopy(Src,Dest: Pointer; VmtPtr: Longint);         // Object assignment support routine
  124. procedure _ObjCopyInit(Src,Dest: Pointer; VmtPtr: Longint; RTTI: Pointer); // Object assignment support routine for types that need initialization
  125. procedure _ObjCtr(VmtPtr: Longint);                             // Constructor support routine
  126. procedure _ObjDtr;                                              // Destructor support routine
  127. procedure _Out16(Value,PortNo: Longint);                        // Outputs Word to I/O Port
  128. procedure _Out32(Value,PortNo: Longint);                        // Outputs DWord to I/O Port
  129. procedure _Out8(Value,PortNo: Longint);                         // Outputs Byte to I/O Port
  130. procedure _RandFlt;                                             // 'Random' standard function (Float)
  131. procedure _RandInt(Range: Longint);                             // 'Random' standard function (Integer)
  132. procedure _Real2Ext(Src: Pointer);                              // Converts Real to Extended
  133. procedure _Rename(FileVar,NewName: Pointer);                    // 'Rename' standard procedure (String)
  134. procedure _RenamePCh(FileVar,NewName: Pointer);                 // 'Rename' standard procedure (PChar)
  135. procedure _Round;                                               // 'Round' standard function
  136. procedure _RunError(ErrorCode: Longint);                        // 'RunError' standard procedure
  137. procedure _SetAddRange(Dest: Pointer; Lower,Upper: Byte);       // Loads dword sized set
  138. procedure _SetDWordLoad(Dest: Pointer; Value: Longint);         // Loads dword sized set
  139. procedure _SetDif(Dest,Src : Pointer);                          // '-' operator for unpacked sets
  140. procedure _SetEqual(Dest,Src : Pointer);                        // '=','<>' operators for unpacked sets
  141. procedure _SetInter(Dest,Src : Pointer);                        // '*' operator for unpacked sets
  142. procedure _SetLoad(Dest,Src: Pointer; SetData: Longint);        // Loads packed set
  143. procedure _SetRel(Dest,Src : Pointer);                          // '<','>' operators for unpacked sets
  144. procedure _SetStore(Src,Dest: Pointer; SetData: Longint);       // Stores unpacked set
  145. procedure _SetUnion(Dest,Src : Pointer);                        // '+' operator for unpacked sets
  146. procedure _Sin;                                                 // 'Sin' standard function
  147. procedure _Sqrt;                                                // 'Sqrt' standard function
  148. procedure _StkChk(LocalSize: Longint);                          // Stack check routine
  149. procedure _StkPrb(LocalSize: Longint);                          // Stack probing for routines with more than 4K local variables
  150. procedure _StrChar(Dest: Pointer; Char: Byte);                  // Converts char to string
  151. procedure _StrCmp(S1,S2: Pointer);                              // String relation operators
  152. procedure _StrConcat(Dest,Src: Pointer);                        // 'Concat' standard function
  153. procedure _StrCopy(Dest,Src: Pointer; Index,Count: Longint);    // Copy standard function
  154. procedure _StrDel(S: Pointer; Index,Count: Longint);            // 'Delete' standard procedure
  155. procedure _StrFlt(Width,Dec:Longint; S: Pointer; SLen: Longint);// 'Str' standard procedure (Float,ShortString)
  156. procedure _StrFltLStr(Width,Dec: Longint; var S: Pointer);      // 'Str' standard procedure (Float,AnsiString)
  157. procedure _StrFltPCh(Width,Dec:Longint;S:Pointer;SLen: Longint);// 'Str' standard procedure (Float, PChar)
  158. procedure _StrIns(Src,Dest: Pointer; DestLen,Index: Longint);   // 'Insert' standard procedure
  159. procedure _StrInt(Value,Width:Longint; S:Pointer; SLen:Longint);// 'Str' standard procedure (Integer,ShortString)
  160. procedure _StrIntLStr(Value,Width: Longint; var S: Pointer);    // 'Str' standard procedure (Integer,AnsiString)
  161. procedure _StrIntPCh(Value,Width:Longint;S:Pointer;SLen:Longint);//'Str' standard procedure (Integer,PChar)
  162. procedure _StrLoad(Dest,Src: Pointer);                          // Loads string
  163. procedure _StrPacked(Dest,Src: Pointer; Len: Longint);          // Converts packed string to string
  164. procedure _StrPos(SubStr,S: Pointer);                           // 'Pos' standard function
  165. procedure _StrSet(S: Pointer; Buffer: PChar; Len: Longint);     // 'SetString' standard procedure (ShortString)
  166. procedure _StrStore(Src,Dest: Pointer; MaxLen: Longint);        // Stores string
  167. procedure _Terminate;                                           // Terminates program with exit code = 0
  168. procedure _Trunc;                                               // 'Trunc' standard function
  169. procedure _TxtAppend(FileVar: Pointer);                         // 'Append' standard procedure
  170. procedure _TxtAssign(FileVar,S: Pointer);                       // 'Assign' standard procedure (String)
  171. procedure _TxtAssignPCh(FileVar,S: Pointer);                    // 'Assign' standard procedure (PChar)
  172. procedure _TxtClose(FileVar: Pointer);                          // 'Close' standard procedure
  173. procedure _TxtEof(FileVar: Pointer);                            // 'Eof' standard function
  174. procedure _TxtEoln(FileVar: Pointer);                           // 'Eoln' standard function
  175. procedure _TxtFlush(FileVar: Pointer);                          // 'Flush' standard procedure
  176. procedure _TxtRChar(FileVar: Pointer);                          // 'Read' standard procedure (Char)
  177. procedure _TxtREnd(FileVar: Pointer);                           // End of read
  178. procedure _TxtRFlt(FileVar: Pointer);                           // 'Read' standard procedure (Float)
  179. procedure _TxtRInt(FileVar: Pointer);                           // 'Read' standard procedure (Integer)
  180. procedure _TxtRLn(FileVar: Pointer);                            // 'ReadLn' standard procedure
  181. procedure _TxtRLStr(FileVar,LStr: Pointer);                     // 'Read' standard procedure for long string type
  182. procedure _TxtRPChar(FileVar,S: Pointer; SLen: Longint);        // 'Read' standard procedure (PChar)
  183. procedure _TxtRStr  (FileVar,S: Pointer; SLen: Longint);        // 'Read' standard procedure (String)
  184. procedure _TxtReset(FileVar: Pointer);                          // 'Reset' standard procedure
  185. procedure _TxtRewrite(FileVar: Pointer);                        // 'Rewrite' standard procedure
  186. procedure _TxtSEof(FileVar: Pointer);                           // 'SeekEof' standard function
  187. procedure _TxtSEoln(FileVar: Pointer);                          // 'SeekEoln' standard function
  188. procedure _TxtSetBuf(FileVar,Buffer: Pointer; BufSize: Longint);// 'SetTextBuf' standard procedure
  189. procedure _TxtWBool(FileVar:Pointer; Value:Byte; Width:Longint);// 'Write' standard procedure (Boolean)
  190. procedure _TxtWChar(FileVar:Pointer; Value:Byte; Width:Longint);// 'Write' standard procedure (Char)
  191. procedure _TxtWEnd(FileVar: Pointer);                           // End of write
  192. procedure _TxtWFlt(FileVar: Pointer; Width,Dec: Longint);       // 'Write' standard procedure (Float)
  193. procedure _TxtWInt(FileVar: Pointer; Value,Width: Longint);     // 'Write' standard procedure (Integer)
  194. procedure _TxtWLn(FileVar: Pointer);                            // 'WriteLn' standard procedure
  195. procedure _TxtWPChar(FileVar,S: Pointer; Width: Longint);       // 'Write' standard procedure (PChar)
  196. procedure _TxtWStr  (FileVar,S: Pointer; Width: Longint);       // 'Write' standard procedure (String)
  197. procedure _TxtWLStr (FileVar,S: Pointer; Width: Longint);       // 'Write' standard procedure (Long String)
  198. procedure _UpCase(Char: Byte);                                  // 'UpCase' standard function
  199. procedure _ValFlt(S,Code: Pointer);                             // 'Val' standard procedure (Float)
  200. procedure _ValFltPCh(S,Code: Pointer);                          // 'Val' standard procedure (Float,PChar)
  201. procedure _ValInt(S,Code: Pointer);                             // 'Val' standard procedure (Integer)
  202. procedure _ValIntPCh(S,Code: Pointer);                          // 'Val' standard procedure (Integer,PChar)
  203. procedure _VarMove(Src,Dest: Pointer; Count: Longint);          // Variable assignment support routine
  204. procedure _VarMoveInit(Src,Dest: Pointer; Count: Longint; RTTI: Pointer); // Variable assignment support routine for types that need initialization
  205. {&Cdecl+}
  206. procedure _XcptAny    (Report,Registration,Context,Void: Pointer); // Handler for any exception
  207. procedure _XcptDone   (Report,Registration,Context,Void: Pointer); // Exit exception block routine
  208. procedure _XcptFinally(Report,Registration,Context,Void: Pointer); // Finally block handler
  209. procedure _XcptOn     (Report,Registration,Context,Void: Pointer); // Handler for ON exception handlers
  210. procedure _XcptRaise  (Exception: Pointer); pascal;                // 'raise' statement support routine
  211. procedure _XcptRaiseAg(Report,Registration,Context,Void: Pointer); // Re-raise form of the 'raise' statement
  212. procedure _XcptTryExit; pascal;                                    // Exception block exit support routine
  213. {&Cdecl-}
  214.  
  215. { TVarRec.VType values }
  216.  
  217. const
  218.   vtInteger    = 0;
  219.   vtBoolean    = 1;
  220.   vtChar       = 2;
  221.   vtExtended   = 3;
  222.   vtString     = 4;
  223.   vtPointer    = 5;
  224.   vtPChar      = 6;
  225.   vtObject     = 7;
  226.   vtClass      = 8;
  227.   vtCurrency   = 9;
  228.   vtAnsiString = 10;
  229.  
  230. { The ultimate ancestor for all class types }
  231.  
  232. type
  233.   TObject = class;
  234.   TClass = class of TObject;
  235.   TObject = class
  236.   public
  237.     constructor Create;
  238.     class function ClassInfo: Pointer;
  239.     class function ClassName: ShortString;
  240.     class function ClassNameIs(const Name: String): Boolean;
  241.     class function ClassParent: TClass;
  242.     function ClassType: TClass;
  243.     procedure CleanupInstance;
  244.     procedure Dispatch(var Message);
  245.     function FieldAddress(const Name: ShortString): Pointer;
  246.     procedure Free;
  247.     class function InheritsFrom(AClass: TClass): Boolean;
  248.     class function InitInstance(Instance: Pointer): TObject;
  249.     class function InstanceSize: Longint;
  250.     class function MethodAddress(const Name: ShortString): Pointer;
  251.     class function MethodName(Address: Pointer): ShortString;
  252.     { virtual methods: the order is significant }
  253.     procedure DefaultHandler(var Message); virtual;
  254.     class function NewInstance: TObject; virtual;
  255.     procedure FreeInstance; virtual;
  256.     destructor Destroy; virtual;
  257.   end;
  258.  
  259. { The record used for passing type variant open array parameters }
  260.  
  261.   PVarRec = ^TVarRec;
  262.   TVarRec = record
  263.     case Byte of
  264.       vtInteger:   (VInteger: Longint; VType: Byte; VFiller: array[0..2] of Byte);
  265.       vtBoolean:   (VBoolean: Boolean);
  266.       vtChar:      (VChar: Char);
  267.       vtExtended:  (VExtended: PExtended);
  268.       vtString:    (VString: PShortString);
  269.       vtPointer:   (VPointer: Pointer);
  270.       vtPChar:     (VPChar: PChar);
  271.       vtObject:    (VObject: TObject);
  272.       vtClass:     (VClass: TClass);
  273.       vtCurrency:  (VCurrency: PCurrency);
  274.       vtAnsiString:(VAnsiString: Pointer);
  275.   end;
  276.  
  277. { Thread local storage variables }
  278.  
  279. threadvar
  280.   InOutRes: Longint;            // Result of the last I/O operation
  281.   RaiseList: Pointer;           // Head of the list of current exception class instances
  282.   FileMode: Longint;            // Mode for Reset: Default=Read/Write, Deny None
  283.   FileModeReadWrite: Longint;   // File mode for Rewrite (typed/untyped files), Default: Read/Write, Deny None
  284.   TextModeRead: Longint;        // File mode for Reset on text files: Default=Read, Deny None
  285.   TextModeReadWrite: Longint;   // File mode for Rewrite/Append on text files: Default=Read/Write, Deny None
  286.  
  287. var
  288.   Input:            Text;               // Standard input file
  289.   Output:           Text;               // Standard output file
  290.  
  291. const
  292.   CurrScale1:       Single   = 1.0e+4;  // Scale factors for Currency values
  293.   CurrScale2:       Extended = 1.0e-4;
  294.  
  295. const
  296.   ExitCode:         Longint = 0;        // Exit/Error code
  297.   ErrorAddr:        Pointer = nil;      // Flat address of a Runtime error
  298.   ExceptionNo:      Longint = 0;        // OS/2 exception number
  299.   TlsSharedMem:     Pointer = nil;      //  / Used internally
  300.   TlsSharedMemSize: Longint = 0;        // <  by
  301.   DebugHook:        Boolean = False;    //  \ the debugger
  302.   IsConsole:        Boolean = False;    // True if NOVIO/VIO, False if PM application
  303.   IsMultiThread:    Boolean = False;    // True if more than one thread exists
  304.   ExitProc:         Pointer = nil;      // Exit procedure
  305.   XcptProc:         Pointer = nil;      // Exception Handler for BP7 compatible programs
  306.   ExceptProc:       Pointer = nil;      // Handler for unhandled exceptions
  307.   ErrorProc:        Pointer = nil;      // Handler for RTL errors
  308. //HeapList:         Pointer = nil;      // Head of the list of memory blocks
  309.   SmHeapList:       Pointer = nil;      // Head of list of small memory blocks
  310.   LgHeapList:       Pointer = nil;      // Head of list of large blocks
  311.   HeapError:        Pointer = nil;      // Handler for heap errors
  312.   Environment:      Pointer = nil;      // Pointer to the environment
  313.   ExceptClsProc:    Pointer = nil;      // Map an OS/2 Exception to a language class reference
  314.   ExceptObjProc:    Pointer = nil;      // Map an OS/2 Exception to a language class instance
  315.   ExceptionClass:   TClass  = nil;      // Exception base class (must be SysUtils.Exception)
  316.   CmdLine:          PChar   = nil;      // Points to the command line
  317.   ModuleHandle:     Longint = 0;        // Module Handle
  318.   RandSeed:         Longint = 0;        // Random Number Generator Seed
  319.   AllocMemCount:    Longint = 0;        // Number of allocated memory blocks
  320.   AllocMemSize:     Longint = 0;        // Total size of allocated memory blocks
  321. //HeapBlock:        Longint = 8*1024;   // 8K
  322.   SmHeapBlock:      Longint = 16*1024;  // Size of block to allocate from OS
  323.   LgHeapBlock:      Longint = 64*1024;  // Size of block to allocate from OS
  324.   HeapLimit:        Longint = 8*1024;   // Blocks up to this size are "small"
  325.   HeapAllocFlags:   Longint = {$IFDEF OS2} $53 {$ELSE} {$IFDEF LINUX} $06 {$ELSE} $1000 {$ENDIF} {$ENDIF}; // obj_Tile+pag_Commit+pag_Read+pag_Write / mem_Commit
  326.   Test8086:         Byte    = 2;        // 386 or better
  327.   Test8087:         Byte    = 3;        // 387 or better
  328.  
  329. {-------[ Standard routines that do not need compiler magic ]-----------}
  330.  
  331. procedure FlatToSel(var P: Pointer);    // Converts FLAT (0:32) pointer to Selector:Offset (16:16) form
  332. procedure SelToFlat(var P: Pointer);    // Converts Selector:Offset (16:16) pointer to FLAT (0:32) form
  333. procedure FPower10;                     // Used internally by System & SysUtils units
  334.  
  335. { Thread support }
  336.  
  337. type
  338.   TThreadFunc = function(Parameter: Pointer): Longint;
  339.  
  340. function BeginThread(SecurityAttributes: Pointer; StackSize: Longint; ThreadFunc: TThreadFunc;
  341.   Parameter: Pointer; CreationFlags: Longint; var ThreadId: Longint): Longint;
  342. procedure EndThread(ExitCode: Longint);
  343. function KillThread(Handle: Longint): Longint;
  344. function SuspendThread(Handle: Longint): Longint;
  345. function ResumeThread(Handle: Longint): Longint;
  346. function GetThreadId: Longint;
  347. function GetLocationInfo(Addr: Pointer; var AFileName: ShortString; var ALineNo: Longint): Pointer;
  348. procedure _RunErrorStr(var ErrStr: ShortString);
  349.  
  350. { Memory manager }
  351.  
  352. type
  353.   PMemoryManager = ^TMemoryManager;
  354.   TMemoryManager = record
  355.     GetMem: function(Size: Longint): Pointer;
  356.     FreeMem: function(P: Pointer): Longint;
  357.     ReallocMem: function(P: Pointer; Size: Longint): Pointer;
  358.   end;
  359.   THeapStatus = record
  360.     TotalAddrSpace: Cardinal;
  361.     TotalUncommitted: Cardinal;
  362.     TotalCommitted: Cardinal;
  363.     TotalAllocated: Cardinal;
  364.     TotalFree: Cardinal;
  365.     FreeSmall: Cardinal;
  366.     FreeBig: Cardinal;
  367.     Unused: Cardinal;
  368.     Overhead: Cardinal;
  369.     HeapErrorCode: Cardinal;
  370.   end;
  371.  
  372. function SysGetMem(Size: Longint): Pointer;
  373. function SysFreeMem(P: Pointer): Longint;
  374. function SysReallocMem(P: Pointer; Size: Longint): Pointer;
  375.  
  376. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  377. function GetPMemoryManager: PMemoryManager;
  378. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  379. function GetHeapStatus: THeapStatus;
  380.  
  381. function MaxAvail: Longint;
  382. function MemAvail: Longint;
  383. procedure Randomize;
  384. function ParamCount: Longint;
  385. function ParamStr(Index: Longint): ShortString;
  386.  
  387. { Operating System interface }
  388.  
  389. {&OrgName+}
  390. function SysFileStdIn: Longint;
  391. function SysFileStdOut: Longint;
  392. function SysFileStdErr: Longint;
  393. function SysFileOpen(FileName: PChar; Mode: Longint; var Handle: Longint): Longint;
  394. function SysFileCreate(FileName: PChar; Mode,Attr: Longint; var Handle: Longint): Longint;
  395. function SysFileSeek(Handle,Distance,Method: Longint; var Actual: Longint): Longint;
  396. function SysFileRead(Handle: Longint; var Buffer; Count: Longint; var Actual: Longint): Longint;
  397. function SysFileWrite(Handle: Longint; const Buffer; Count: Longint; var Actual: Longint): Longint;
  398. function SysFileSetSize(Handle,NewSize: Longint): Longint;
  399. function SysFileClose(Handle: Longint): Longint;
  400. function SysFileDelete(FileName: PChar): Longint;
  401. function SysFileMove(OldName,NewName: PChar): Longint;
  402. function SysFileIsDevice(Handle: Longint): Longint;
  403. function SysDirGetCurrent(Drive: Longint; Path: PChar): Longint;
  404. function SysDirSetCurrent(Path: PChar): Longint;
  405. function SysDirCreate(Path: PChar): Longint;
  406. function SysDirDelete(Path: PChar): Longint;
  407. function SysMemAvail: Longint;
  408. function SysMemAlloc(Size,Flags: Longint; var MemPtr: Pointer): Longint;
  409. function SysMemFree(MemPtr: Pointer): Longint;
  410. function SysSysMsCount: Longint;
  411. procedure SysSysWaitSem(var Sem: Longint);
  412. procedure SysSysSelToFlat(var P: Pointer);
  413. procedure SysSysFlatToSel(var P: Pointer);
  414. function SysCtrlSelfAppType: Longint;
  415. function SysCtrlCreateThread(Attrs: Pointer; StackSize: Longint; Func,Param: Pointer; Flags: Longint; var Tid: Longint): Longint;
  416. function SysCtrlKillThread(Handle: Longint): Longint;
  417. function SysCtrlSuspendThread(Handle: Longint): Longint;
  418. function SysCtrlResumeThread(Handle: Longint): Longint;
  419. procedure SysCtrlExitThread(ExitCode: Longint);
  420. procedure SysCtrlExitProcess(ExitCode: Longint);
  421. function SysCtrlGetModuleName(Handle: Longint; Buffer: PChar): Longint;
  422. procedure SysCtrlEnterCritSec;
  423. procedure SysCtrlLeaveCritSec;
  424. function SysCtrlGetTlsMapMem: Pointer;
  425. function SysCmdln: PChar;
  426. function SysCmdlnCount: Longint;
  427. procedure SysCmdlnParam(Index: Longint; var Param: ShortString);
  428. {$IFDEF LNX_DPMI}
  429. procedure SysLowInit;
  430. procedure RaiseNotification(ArgCount,Arg1,Arg2,Code: Longint);
  431. {$ENDIF}
  432.  
  433. {&OrgName-}
  434.  
  435. const
  436. {$IFDEF OS2}
  437.   xcpt_Access_Violation         = $C0000005;
  438.   xcpt_Guard_Page_Violation     = $80000001;
  439.   xcpt_In_Page_Error            = $C0000006;
  440.   xcpt_Array_Bounds_Exceeded    = $C0000093;
  441.   xcpt_Float_Denormal_Operand   = $C0000094;
  442.   xcpt_Float_Divide_By_Zero     = $C0000095;
  443.   xcpt_Float_Inexact_Result     = $C0000096;
  444.   xcpt_Float_Invalid_Operation  = $C0000097;
  445.   xcpt_Float_Overflow           = $C0000098;
  446.   xcpt_Float_Stack_Check        = $C0000099;
  447.   xcpt_Float_Underflow          = $C000009A;
  448.   xcpt_Integer_Divide_By_Zero   = $C000009B;
  449.   xcpt_Integer_Overflow         = $C000009C;
  450.   xcpt_Privileged_Instruction   = $C000009D;
  451.   xcpt_Unable_To_Grow_Stack     = $80010001;
  452.   xcpt_Illegal_Instruction      = $C000001C;
  453.   xcpt_DataType_Misalignment    = $C000009E;
  454.   xcpt_NonContinuable_Exception = $C0000024;
  455.   xcpt_Invalid_Disposition      = $C0000025;
  456.   // OS/2 specific
  457.   xcpt_Process_Terminate        = $C0010001;
  458.   xcpt_Async_Process_Terminate  = $C0010002;
  459.   xcpt_Invalid_Lock_Sequence    = $C000001D;
  460.   xcpt_B1npx_Errata_02          = $C0010004;
  461.   xcpt_Bad_Stack                = $C0000027;
  462.   xcpt_Invalid_Unwind_Target    = $C0000028;
  463.   xcpt_Unwind                   = $C0000026;
  464.   xcpt_Signal                   = $C0010003;
  465. {$ENDIF}
  466. {$IFDEF WIN32}
  467.   xcpt_Access_Violation         = $C0000005;
  468.   xcpt_Guard_Page_Violation     = $80000001;
  469.   xcpt_In_Page_Error            = $C0000006;
  470.   xcpt_Array_Bounds_Exceeded    = $C000008C;
  471.   xcpt_Float_Denormal_Operand   = $C000008D;
  472.   xcpt_Float_Divide_By_Zero     = $C000008E;
  473.   xcpt_Float_Inexact_Result     = $C000008F;
  474.   xcpt_Float_Invalid_Operation  = $C0000090;
  475.   xcpt_Float_Overflow           = $C0000091;
  476.   xcpt_Float_Stack_Check        = $C0000092;
  477.   xcpt_Float_Underflow          = $C0000093;
  478.   xcpt_Integer_Divide_By_Zero   = $C0000094;
  479.   xcpt_Integer_Overflow         = $C0000095;
  480.   xcpt_Privileged_Instruction   = $C0000096;
  481.   xcpt_Unable_To_Grow_Stack     = $C00000FD; // STATUS_STACK_OVERFLOW
  482.   xcpt_Illegal_Instruction      = $C000001D;
  483.   xcpt_DataType_Misalignment    = $80000002;
  484.   xcpt_NonContinuable_Exception = $C0000025;
  485.   xcpt_Invalid_Disposition      = $C0000026;
  486.   // Win32 specific
  487.   xcpt_Control_C_Exit           = $C000013A;
  488. {$ENDIF}
  489. {$IFDEF DPMI32}
  490.   xcpt_Integer_Divide_By_Zero   = $c0000000;
  491.   xcpt_Integer_Overflow         = $c0000004;
  492.   xcpt_Array_Bounds_Exceeded    = $c0000005;
  493.   xcpt_Illegal_Instruction      = $c0000006;
  494.   xcpt_Privileged_Instruction   = $c0000006;
  495.   xcpt_Unable_To_Grow_Stack     = $c000000c;
  496.   xcpt_Access_Violation         = $c000000d;
  497.   xcpt_In_Page_Error            = $c000000e;
  498.   xcpt_Float_generic            = $c0000010;
  499.   xcpt_Float_Denormal_Operand   = $c0000110;
  500.   xcpt_Float_Divide_By_Zero     = $c0000210;
  501.   xcpt_Float_Inexact_Result     = $c0000310;
  502.   xcpt_Float_Invalid_Operation  = $c0000410;
  503.   xcpt_Float_Overflow           = $c0000510;
  504.   xcpt_Float_Stack_Check        = $c0000610;
  505.   xcpt_Float_Underflow          = $c0000710;
  506.   xcpt_DataType_Misalignment    = $c0000011;
  507.   xcpt_Ctrl_Break               = $c00000cc;
  508.   //----xcpt_Guard_Page_Violation     = $c000000;
  509.   //----xcpt_NonContinuable_Exception = $C0000024;
  510.   //----xcpt_Invalid_Disposition      = $C0000025;
  511. {$ENDIF}
  512. {$IFDEF LINUX}
  513.   xcpt_Integer_Divide_By_Zero   = $C0080000;
  514.   xcpt_Integer_Overflow         = $C0080400;
  515.   xcpt_Array_Bounds_Exceeded    = $C0080500; // ?
  516.   xcpt_Illegal_Instruction      = $C0040600;
  517.   xcpt_Privileged_Instruction   = $C0040600; // ?
  518.   xcpt_Unable_To_Grow_Stack     = $C0040C00; // ?
  519.   xcpt_Access_Violation         = $C00B0D00;
  520.   xcpt_In_Page_Error            = $C00B0E00;
  521.  
  522.   xcpt_Float_Generic            = $C0081000;
  523.   xcpt_Float_Denormal_Operand   = $C0081002;
  524.   xcpt_Float_Divide_By_Zero     = $C0081004;
  525.   xcpt_Float_Inexact_Result     = $C0081020;
  526.   xcpt_Float_Invalid_Operation  = $C0081001;
  527.   xcpt_Float_Overflow           = $C0081008;
  528.   xcpt_Float_Stack_Check        = $C0081040; // ?
  529.   xcpt_Float_Underflow          = $C0081010;
  530.   xcpt_DataType_Misalignment    = $C0071100;
  531.   xcpt_Ctrl_Break               = $C0020000;
  532. {$ENDIF}
  533.  
  534. type
  535.   PXcptReportRecord = ^TXcptReportRecord;
  536.   TXcptReportRecord = record
  537.     ExceptionNum: Longint;
  538.     fHandlerFlags: Longint;
  539.     NestedXcptReportRecord: PXcptReportRecord;
  540.     ExceptionAddress: Pointer;
  541.     cParameters: Longint;
  542.     case Integer of
  543.       0: (ExceptionInfo: array [0..3] of Longint);
  544.       1: (ExceptAddr: Pointer;
  545.           ExceptObject: Pointer);
  546.   end;
  547.  
  548. { BP7/Delphi Windows compatibility variables }
  549.  
  550. const
  551.   HInstance: Longint = -1;      // Handle of this instance: -1 in Open32
  552.   HPrevInst: Longint = 0;       // Handle of previous instance: 0 in Open32
  553.   CmdShow:   Longint = 10;      // CmdShow parameter for CreateWindow: sw_ShowDefault
  554.  
  555. {$IFDEF DPMI32}
  556. var
  557.   code_base  : Longint;         // First byte of code object
  558.   seldata    : SmallWord;       // Default DS selector
  559.   sel_psp    : SmallWord;       // Process Segment Prefix selector
  560.   sel_fs     : SmallWord;       // Selector for TIB emulation
  561.   stacksize  : Longint;         // Needed for TIB emulation
  562.   seg_psp    : Longint;         // Ofs( Mem[psp:0000] )
  563.  
  564. const
  565.   seg0000    = $0000 shl 4;     // Ofs( Mem[$0000:0000] )
  566.   seg0040    = $0040 shl 4;     // Ofs( Mem[$0040:0000] )
  567.   sega000    = $a000 shl 4;     // Ofs( Mem[$a000:0000] )
  568.   segb000    = $b000 shl 4;     // Ofs( Mem[$b000:0000] )
  569.   segb800    = $b800 shl 4;     // Ofs( Mem[$b800:0000] )
  570. {$ENDIF}
  571.  
  572. {$IFDEF LINUX}
  573.  
  574. { File system settings for Linux. The TFileSystem type together with
  575.   the FileSystem variable allows to select the kind of file system
  576.   that the application sees. The selection affects the way in which
  577.   the VpSysLow unit (and possibly other units, too) handle file names.
  578.  
  579.   The following values are possible:
  580.  
  581.   fsUnix ....... The application sees the real Unix file system. File
  582.                  names are expected to use foreslashes as separators.
  583.                  Backslashes and drive letters are not allowed. This
  584.                  file system selection should be used when writing
  585.                  pure Linux applications. No automatic conversion is
  586.                  needed in this case.
  587.  
  588.   fsDos ........ The application sees a Dos-like, but case-sensitive
  589.                  file system. File names are expected to contain
  590.                  backslashes as separators. Foreslashes are not
  591.                  allowed. The drive letter 'c:' (or 'C:') is allowed,
  592.                  that is, the application sees a single drive. No
  593.                  floppy drives do exist. The application can be sure
  594.                  that all file names returned from system calls
  595.                  (VpSysLow and other units) will conform to these
  596.                  rules. This mode should be used when porting old
  597.                  Dos, Windows or OS/2 applications to Linux. It
  598.                  should allow a simple recompile of the programs
  599.                  without having to change file handling.
  600.  
  601.   fsDosUpper ... The application sees a Dos-like, case-insensitive
  602.                  file system. This file system selection is similar
  603.                  to fsDos, with these two exceptions:
  604.  
  605.                  - All file names are converted to upper case before
  606.                    passing them to the operating system. As an effect,
  607.                    the application can only create or modify files
  608.                    with upper case names.
  609.  
  610.                  - File search functions (FindFirst et. al.) filter
  611.                    all file names that are not completely upper case.
  612.                    As an effect, the application sees only upper case
  613.                    names.
  614.  
  615.                  Use this mode to port existing Dos application to
  616.                  Linux whose source code refers to the same disk file
  617.                  with different spelling ('MyFile.Txt', 'myfile.txt).
  618.  
  619.   fsDosLower ... Same as fsDosUpper, but all file names are lower
  620.                  case.                                                 }
  621.  
  622. type
  623.   TFileSystem = (fsUnix, fsDos, fsDosUpper, fsDosLower);
  624.  
  625. const
  626.   FileSystem: TFileSystem = fsUnix;
  627. {$ENDIF}
  628.  
  629. implementation
  630.  
  631. { OS interface }
  632.  
  633. function SysFileStdIn;          external;
  634. function SysFileStdOut;         external;
  635. function SysFileStdErr;         external;
  636. function SysFileOpen;           external;
  637. function SysFileCreate;         external;
  638. function SysFileSeek;           external;
  639. function SysFileRead;           external;
  640. function SysFileWrite;          external;
  641. function SysFileSetSize;        external;
  642. function SysFileClose;          external;
  643. function SysFileDelete;         external;
  644. function SysFileMove;           external;
  645. function SysFileIsDevice;       external;
  646. function SysDirGetCurrent;      external;
  647. function SysDirSetCurrent;      external;
  648. function SysDirCreate;          external;
  649. function SysDirDelete;          external;
  650. function SysMemAvail;           external;
  651. function SysMemAlloc;           external;
  652. function SysMemFree;            external;
  653. function SysSysMsCount;         external;
  654. procedure SysSysWaitSem;        external;
  655. procedure SysSysSelToFlat;      external;
  656. procedure SysSysFlatToSel;      external;
  657. function SysCtrlSelfAppType;    external;
  658. function SysCtrlCreateThread;   external;
  659. function SysCtrlKillThread;     external;
  660. function SysCtrlSuspendThread;  external;
  661. function SysCtrlResumeThread;   external;
  662. procedure SysCtrlExitThread;    external;
  663. procedure SysCtrlExitProcess;   external;
  664. function SysCtrlGetModuleName;  external;
  665. procedure SysCtrlEnterCritSec;  external;
  666. procedure SysCtrlLeaveCritSec;  external;
  667. function SysCtrlGetTlsMapMem;   external;
  668. function SysCmdln;              external;
  669. function SysCmdlnCount;         external;
  670. procedure SysCmdlnParam;        external;
  671. {$IFDEF LNX_DPMI}
  672. procedure SysLowInit;           external;
  673. {$ENDIF}
  674.  
  675. // Known problems:
  676. // 1. The TLS memory allocated for a DLL loaded dynamically must be freed
  677. //    after the DLL is unloaded. Otherwise the RTL will run out TLS shared
  678. //    memory.
  679.  
  680. // Forward declaration
  681.  
  682. procedure RtlError; forward;
  683. function ThreadStartup(P: Longint): Longint; {$IFDEF OS2} cdecl {$ELSE} stdcall {$ENDIF}; forward;
  684. procedure _ExceptionHandler(Report,Registration,Context,Void: Pointer); cdecl; forward;
  685.  
  686. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ RECORDS AND CONSTANTS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  687.  
  688. type
  689.   PByte         = ^Byte;
  690.   PSmallWord    = ^SmallWord;
  691.   PLongint      = ^Longint;
  692.  
  693. // VMT header
  694.  
  695. type
  696.   VMT = record
  697.     InstanceSize:  Longint;     // Size of the object instance
  698.     InstanceCheck: Longint;     // Negative size of the object instance
  699.     DMTPointer:    Pointer;     // Pointer to the Dynamic Method Table
  700.     EntryTable: record end;     // Pointers to the virtual methods start here
  701.   end;
  702.  
  703. // DMT Header
  704.  
  705.   DMT = record
  706.     Parent:         Pointer;    // Offset of the parent's DMT
  707.     Cache_Entry:    Longint;    // Last used dynamic method entry
  708.     Cache_Index:    Longint;    // Last used dynamic index
  709.     Entry_Count:    Longint;    // Number of entries in the DMT
  710.     Entry_Table: record end;    // Dynamic indices start here, pointers
  711.   end;                          // to the method entries follow them
  712.  
  713. // Text file variable record
  714.  
  715.   TextBuf = array[0..127] of Char;
  716.   TextRec = record
  717.     Handle:    Longint;         // +00 File Handle
  718.     Mode:      Longint;         // +04 Current file mode
  719.     BufSize:   Longint;         // +08 Text File buffer size
  720.     BufPos:    Longint;         // +0C Buffer current position
  721.     BufEnd:    Longint;         // +10 Buffer ending position
  722.     BufPtr:    PChar;           // +14 Pointer to the buffer
  723.     OpenFunc:  Pointer;         // +18 Open Text File function @
  724.     InOutFunc: Pointer;         // +1C In/Out ...
  725.     FlushFunc: Pointer;         // +20 Flush ...
  726.     CloseFunc: Pointer;         // +24 Close ...
  727.     UserData:  array [1..32] of Byte;   // +28 User data area
  728.     Name:      array [0..259] of Char;  // +48 File name (ASCIIZ)
  729.     Buffer:    TextBuf;         // +14C Default I/O buffer
  730.   end;                          // +1CC SizeOf(TextRec)
  731.  
  732. // Control Characters
  733.  
  734. const
  735.   ccLF  = #$0A;                 // Line Feed
  736.   ccCR  = #$0D;                 // Carriage Return
  737.   ccEOF = #$1A;                 // EOF character
  738.  
  739. // File mode constants
  740.  
  741.   fmClosed =  $A55AD7B0;
  742.   fmInput  =  $A55AD7B1;
  743.   fmOutput =  $A55AD7B2;
  744.   fmInOut  =  $A55AD7B3;
  745.  
  746. // Size of the buffer for direcory path
  747.  
  748.   PATH_BUFFER_SIZE = 260;
  749.  
  750. // Run-time error codes
  751.  
  752.   RTE_Disk_Read_Error           = 100;
  753.   RTE_Disk_Write_Error          = 101;
  754.   RTE_File_Not_Assigned         = 102;
  755.   RTE_File_Not_Open             = 103;
  756.   RTE_File_Not_Open_For_Input   = 104;
  757.   RTE_File_Not_Open_For_Output  = 105;
  758.   RTE_Invalid_Numeric_Format    = 106;
  759.   RTE_Zero_Divide               = 200;
  760.   RTE_Range_Check               = 201;
  761.   RTE_Stack_Overflow            = 202;
  762.   RTE_Heap_Overflow             = 203;
  763.   RTE_Invalid_Pointer           = 204;
  764.   RTE_FP_Overflow               = 205;
  765.   RTE_FP_Underflow              = 206;
  766.   RTE_Invalid_FP_Operation      = 207;
  767.   RTE_FP_Inexact_Result         = 208;
  768.   RTE_FP_Denormal_Operand       = 209;
  769.   RTE_Object_Not_Initialized    = 210;
  770.   RTE_Abstruct_Method_Call      = 211;
  771.   RTE_Stream_Registration_Error = 212;
  772.   RTE_Invalid_Collection_Index  = 213;
  773.   RTE_Collection_Overflow       = 214;
  774.   RTE_Integer_Overflow          = 215;
  775.   RTE_Access_Violation          = 216;
  776.   RTE_Signal                    = 217;
  777.   RTE_Exception                 = 217;
  778.   RTE_Privileged_Instruction    = 218;
  779.   RTE_Invalid_Cast              = 219;
  780.  
  781. // 80x87 Status Word
  782. const
  783.   mSW_IE        = $0001;        // Invalid Operation exception
  784.   wSW_IE        = 1;
  785.   mSW_DE        = $0002;        // Denormalized Operand exception
  786.   wSW_DE        = 1;
  787.   mSW_ZE        = $0004;        // Zero-Divide exception
  788.   wSW_ZE        = 1;
  789.   mSW_OE        = $0008;        // Overflow exception
  790.   wSW_OE        = 1;
  791.   mSW_UE        = $0010;        // Underflow exception
  792.   wSW_UE        = 1;
  793.   mSW_PE        = $0020;        // Precision exception
  794.   wSW_PE        = 1;
  795.   mSW_SF        = $0040;        // Stack flag (387+ only)
  796.   wSW_SF        = 1;
  797.   mSW_ES        = $0080;        // Error summary
  798.   wSW_ES        = 1;
  799.   mSW_C0        = $0100;        // Condition bit 0
  800.   wSW_C0        = 1;
  801.   sSW_C0        = 8;
  802.   mSW_C1        = $0200;        // Condition bit 1
  803.   wSW_C1        = 1;
  804.   mSW_C2        = $0400;        // Condition bit 2
  805.   wSW_C2        = 1;
  806.   mSW_ST        = $3800;        // Stack top
  807.   wSW_ST        = 3;
  808.   sSW_ST        = 11;
  809.   mSW_C3        = $4000;        // Condition bit 3
  810.   wSW_C3        = 1;
  811.   mSW_B         = $8000;        // Busy bit
  812.   wSW_B         = 1;
  813.  
  814. // 80x87 Control Word
  815.  
  816.   mCW_IM        = $0001;        // Invalid Operation mask
  817.   wCW_IM        = 1;            // Bit = 1 if Exception is masked
  818.   mCW_DM        = $0002;        // Denormalized Operand mask
  819.   wCW_DM        = 1;
  820.   mCW_ZM        = $0004;        // Zero-Divide mask
  821.   wCW_ZM        = 1;
  822.   mCW_OM        = $0008;        // Overflow mask
  823.   wCW_OM        = 1;
  824.   mCW_UM        = $0010;        // Underflow mask
  825.   wCW_UM        = 1;
  826.   mCW_PM        = $0020;        // Precision mask
  827.   wCW_PM        = 1;
  828.   mCW_PC        = $0300;        // Precision control
  829.   wCW_PC        = 2;
  830.   sCW_PC        = 8;
  831.   mCW_RC        = $0C00;        // Rounding control
  832.   wCW_RC        = 2;
  833.   sCW_RC        = 10;
  834.   mCW_IC        = $1000;        // Infinity control
  835.   sCW_IC        = 12;
  836.   wCW_IC        = 1;
  837.  
  838.   IC_Projective = 0;            // Projective closure (387 doesn't support it)
  839.   IC_Affine     = 1;            // Affine mode
  840.  
  841.   RC_Nearest    = 0;            // Rounding to nearest (the default)
  842.   RC_Down       = 1;            // Rounding down (towards "-" infinity)
  843.   RC_Up         = 2;            // Rounding up (towards "+" infinity)
  844.   RC_To_Zero    = 3;            // Rounding toward zero.
  845.  
  846.   PC_Single     = 0;            // Round to single precision
  847.   PC_Reserved   = 1;            // Reserved ( should not be specified)
  848.   PC_Double     = 2;            // Round to double precision
  849.   PC_Extended   = 3;            // Round to extended precision (the default)
  850.  
  851.   TAG_Valid     = 0;            // Tag values
  852.   TAG_Zero      = 1;
  853.   TAG_Spec      = 2;
  854.   TAG_Empty     = 3;
  855.  
  856. // x86 flags definition
  857.  
  858.   mCF           = $0001;
  859.   mPF           = $0004;
  860.   mAF           = $0010;
  861.   mZF           = $0040;
  862.   mSF           = $0080;
  863.   mIF           = $0200;
  864.   mDF           = $0400;
  865.   mOF           = $0800;
  866.  
  867. // Descriptor definition
  868.  
  869.   desAttrBig      = $40;        // Attribute byte
  870.   desAttrGran     = $80;
  871.  
  872.   mEXP_Sign       = $8000;      // Exponent field sign
  873.   mEXP_Exponent   = $7FFF;      // Exponent field exponent
  874.   EXP_Spec_Value  = $7FFF;      // Exponent value for NANs and INF
  875.   SIGN_Inf_Value  = $8000;      // Value of the ER_Signifcand3 for infinity
  876.  
  877. type
  878.   ExtRec = record               // Extended coprocessor value
  879.     ER_Significand0: Word;      // low word of the significand field
  880.     ER_Significand1: Word;      // second word of the significand field
  881.     ER_Significand2: Word;      // third word of the significand field
  882.     ER_Significand3: Word;      // high word of the significand field
  883.     ER_Exponent    : Word;      // Exponent & Sign
  884.   end;
  885.  
  886. // Class Virtual Method Table
  887.  
  888. const
  889.   vtInitTable      = -48;
  890.   vtTypeInfo       = -44;
  891.   vtFieldTable     = -40;
  892.   vtMethodTable    = -36;
  893.   vtDynamicTable   = -32;
  894.   vtClassName      = -28;
  895.   vtInstanceSize   = -24;
  896.   vtParent         = -20;
  897.   vtDefaultHandler = -16;
  898.   vtNewInstance    = -12;
  899.   vtFreeInstance   = -8;
  900.   vtDestroy        = -4;
  901.   clVTable         = 0;
  902.  
  903. // Language Exception codes
  904.  
  905.   cContinuable          = 0;
  906.   cNonContinuable       = 1;        // eh_NonContinuable
  907.   cUnwinding            = 2;        // eh_Unwinding
  908.   cUnwindingForExit     = 4;        // eh_Exit_Unwind
  909.   cUnwindInProgress     = cUnwinding or cUnwindingForExit;
  910.   cLanguageException    = $0EEDFACE;
  911.   cLanguageReRaise      = $0EEDFACF;
  912.   cLanguageExcept       = $0EEDFAD0;
  913.   cLanguageFinally      = $0EEDFAD1;
  914.   cLanguageTerminate    = $0EEDFAD2;
  915.   cLanguageUnhandled    = $0EEDFAD3;
  916.   cNonLanguageException = $0EEDFAD4;
  917.  
  918. // Run-time error codes
  919.  
  920.   reInOutError      = 0;
  921.   reOutOfMemory     = 1;
  922.   reInvalidPtr      = 2;
  923.   reDivByZero       = 3;
  924.   reRangeError      = 4;
  925.   reIntOverflow     = 5;
  926.   reInvalidOp       = 6;
  927.   reZeroDivide      = 7;
  928.   reOverflow        = 8;
  929.   reUnderflow       = 9;
  930.   reInvalidCast     = 10;
  931.   reAccessViolation = 11;
  932.   reStackOverflow   = 12;
  933.   reSignal          = 13;
  934.   rePrivilegedInstr = 14;
  935.  
  936. // Some RTTI type kinds
  937.  
  938.   tkLString = 10;
  939.   tkArray   = 13;
  940.   tkRecord  = 14;
  941.  
  942. // Subtables of the Virtual Method table
  943.  
  944. type
  945.   TMethodTable = record
  946.     Count:      SmallWord;
  947.     Entries:    record end;
  948.   end;
  949.  
  950.   TMethodEntry = record
  951.     Address:    Longint;
  952.     Name:       ShortString;
  953.   end;
  954.  
  955.   TFieldTable = record
  956.     Count:      SmallWord;
  957.     ClassTable: Pointer;
  958.     Entries:    record end;
  959.   end;
  960.  
  961.   TFieldEntry = record
  962.     Ofs:        Longint;
  963.     ClassIndex: SmallWord;
  964.     Name:       Byte;
  965.   end;
  966.  
  967.   TDynamicTable = record
  968.     Count:      Longint;
  969.     Indices:    array[0..0] of Longint;
  970.   end;
  971.  
  972. // Run-time type information header record
  973.  
  974.   PTypeInfo = ^TTypeInfo;
  975.   TTypeInfo = record
  976.     Kind: Byte;
  977.     Name: ShortString;
  978.   end;
  979.  
  980. // Class Run-time type information
  981.  
  982.   TClassRTTI = record
  983.     ClassType:  TClass;
  984.     ParentInfo: PTypeInfo;
  985.     PropCount:  SmallWord;
  986.     UnitName:   ShortString;
  987.   end;
  988.  
  989.   TFieldRec = record
  990.     TypeInfo: Pointer;
  991.     Offset:   Longint;
  992.   end;
  993.  
  994.   TRecType = record
  995.     FieldCount: Longint;
  996.     FieldTable: array[0..10] of TFieldRec;
  997.   end;
  998.  
  999.   PTypeData = ^TTypeData;
  1000.   TTypeData = record
  1001.     case Byte of
  1002.       tkLString: ();
  1003.       tkArray: (
  1004.         ArrSize:   Longint;
  1005.         ElemCount: Longint;
  1006.         ElemRTTI:  Longint);
  1007.       tkRecord: (
  1008.         RecSize:   Longint;
  1009.         RecData:   TRecType);
  1010.   end;
  1011.  
  1012.   JmpInstruction = record
  1013.     OpCode:   Byte;
  1014.     Distance: Longint;
  1015.   end;
  1016.  
  1017.   TExcDescEntry = record
  1018.     vTable:  Pointer;
  1019.     Handler: Pointer;
  1020.   end;
  1021.  
  1022.   PExcDesc = ^TExcDesc;
  1023.   TExcDesc = record
  1024.     Jmp: JmpInstruction;
  1025.     case Integer of
  1026.       0: (Instructions: array [0..0] of Byte);
  1027.       1: (Cnt: Longint; ExcTab: array [0..0] of TExcDescEntry);
  1028.   end;
  1029.  
  1030.   PExcFrame = ^TExcFrame;
  1031.   TExcFrame = record
  1032.     Next: PExcFrame;
  1033.     Desc: PExcDesc;
  1034.     hEBP: Pointer;
  1035.     ConstructedObject: Pointer;
  1036.   end;
  1037.  
  1038.   PRaiseFrame = ^TRaiseFrame;
  1039.   TRaiseFrame = record
  1040.     NextRaise: PRaiseFrame;
  1041.     ExceptAddr: Pointer;
  1042.     ExceptObject: TObject;
  1043.     ExceptionRecord: PXcptReportRecord;
  1044.   end;
  1045.  
  1046. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ LOW LEVEL ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  1047.  
  1048. // Compiler should only use procedures that are implemented in this
  1049. // unit because dynamic version of the System unit exports all interface
  1050. // procedures and functions. For this reason all procedures that have macro
  1051. // assembler implementation should be called from System unit code.
  1052.  
  1053. // Compiler itself is unable to generate 16-bit code, so low level
  1054. // routines that have 16-bit code are implemented in macro assembler and
  1055. // placed in the SYSTEM.LIB
  1056.  
  1057. // 32 to 16 bit far pascal calling thunk support: OS/2 only
  1058. procedure __Far16Pas; external;
  1059. // Direct I/O Port access: OS/2, Win95 & DOS
  1060. {$IFDEF OS2}
  1061. procedure __IOPort;   external;
  1062. {$ENDIF}
  1063. {$IFDEF WIN32}
  1064. procedure __IOPort;   external;
  1065. {$ENDIF}
  1066. {$IFDEF DPMI32}
  1067. procedure __IOPort;{$FRAME-}{$USES NONE}
  1068.   asm
  1069.     jmp [offset @funktionstabelle+ecx]
  1070.  
  1071.   {****************}
  1072.  
  1073.   @funktionstabelle:
  1074.     dd      @InputByte
  1075.     dd      @InputWord
  1076.     dd      @InputDWord
  1077.     dd      @OutputByte
  1078.     dd      @OutputWord
  1079.     dd      @OutputDWord
  1080.  
  1081.   {****************}
  1082.  
  1083.   @InputByte:
  1084.     in al,dx
  1085.     ret
  1086.  
  1087.   {****************}
  1088.  
  1089.   @InputWord:
  1090.     in ax,dx
  1091.     ret
  1092.  
  1093.   {****************}
  1094.  
  1095.   @InputDWord:
  1096.     in eax,dx
  1097.     ret
  1098.  
  1099.   {****************}
  1100.  
  1101.   @OutputByte:
  1102.     out dx,al
  1103.     ret
  1104.  
  1105.   {****************}
  1106.  
  1107.   @OutputWord:
  1108.     out dx,ax
  1109.     ret
  1110.  
  1111.   {****************}
  1112.  
  1113.   @OutputDWord:
  1114.     out dx,eax
  1115.  
  1116.   {****************}
  1117.  
  1118.   end;
  1119. {$ENDIF}
  1120.  
  1121. {$IFDEF LINUX}
  1122. procedure __IOPort;{$FRAME-}{$USES NONE}
  1123. asm
  1124. end;
  1125. {$ENDIF}
  1126.  
  1127. // Performs a call of the far16 Pascal routine
  1128. // Two extra DWORD parameter are the last arguments passed
  1129. // ProcAddr: Longint;  FLAT address of the 16-bit routine entry point
  1130. // Parms:    Longint;  DWORD describing up to 16 parameters
  1131.  
  1132. procedure _Far16Pas; {&USES None} {&FRAME-}
  1133. asm
  1134.                 jmp     __Far16Pas;
  1135. end;
  1136.  
  1137. // __IOPort: Direct I/O Port access
  1138. // EXPECTS:      [1]:DWord   = Value to write (output only)
  1139. //               [1/2]:DWord = Port number
  1140. // RETURNS:      eax         = Value that have been read (input only)
  1141.  
  1142. procedure _In8(PortNo: Longint); {&USES ecx,edx} {&FRAME-}
  1143. asm
  1144.                 xor     ecx,ecx
  1145.                 mov     edx,PortNo
  1146.                 Call    __IOPort
  1147. end;
  1148.  
  1149. procedure _In16(PortNo: Longint); {&USES ecx,edx} {&FRAME-}
  1150. asm
  1151.                 mov     ecx,1*4
  1152.                 mov     edx,PortNo
  1153.                 Call    __IOPort
  1154. end;
  1155.  
  1156. procedure _In32(PortNo: Longint); {&USES ecx,edx} {&FRAME-}
  1157. asm
  1158.                 mov     ecx,2*4
  1159.                 mov     edx,PortNo
  1160.                 Call    __IOPort
  1161. end;
  1162.  
  1163. procedure _Out8(Value,PortNo: Longint); {&USES eax,ecx,edx} {&FRAME-}
  1164. asm
  1165.                 mov     ecx,3*4
  1166.                 mov     eax,Value
  1167.                 mov     edx,PortNo
  1168.                 Call    __IOPort
  1169. end;
  1170.  
  1171. procedure _Out16(Value,PortNo: Longint); {&USES eax,ecx,edx} {&FRAME-}
  1172. asm
  1173.                 mov     ecx,4*4
  1174.                 mov     eax,Value
  1175.                 mov     edx,PortNo
  1176.                 Call    __IOPort
  1177. end;
  1178.  
  1179. procedure _Out32(Value,PortNo: Longint); {&USES eax,ecx,edx} {&FRAME-}
  1180. asm
  1181.                 mov     ecx,5*4
  1182.                 mov     eax,Value
  1183.                 mov     edx,PortNo
  1184.                 Call    __IOPort
  1185. end;
  1186.  
  1187. procedure _FpuInit; assembler; {&USES None} {&FRAME-}
  1188. const
  1189.   Default: Word = $1332;                // Enabled: IM,ZM,OM
  1190. asm
  1191.                 fninit
  1192.                 fwait
  1193.                 fldcw   Default
  1194. end;
  1195.  
  1196. // Compares the value of InOutRes with 0
  1197. // RETURNS:     ZF      = 1 if InOtRes = 0
  1198.  
  1199. procedure TestInOutRes; {&USES eax} {&FRAME-}
  1200. asm
  1201.                 push    OFFSET InOutRes
  1202.                 Call    _GetTlsVar
  1203.                 cmp     [eax].Longint,0
  1204. end;
  1205.  
  1206. // Performs the following assignment: InOutRes := EAX
  1207.  
  1208. procedure SetInOutRes; {&USES EFL} {&FRAME-}
  1209. asm
  1210.                 push    eax
  1211.                 push    OFFSET InOutRes
  1212.                 Call    _GetTlsVar
  1213.                 pop     [eax].Longint
  1214. end;
  1215.  
  1216. // IOResult standard function
  1217. // function IOResult: Longint;
  1218. // RETURNS:     eax     = I/O result
  1219.  
  1220. procedure _GetIORes; {&USES ecx} {&FRAME-}
  1221. asm
  1222.                 push    OFFSET InOutRes
  1223.                 Call    _GetTlsVar
  1224.                 mov     ecx,eax
  1225.                 xor     eax,eax
  1226.                 xchg    eax,[ecx]
  1227. end;
  1228.  
  1229. // Pointer conversion routines
  1230.  
  1231. procedure SelToFlat; {&USES None} {&FRAME-}
  1232. asm
  1233.                 jmp     SysSysSelToFlat
  1234. end;
  1235.  
  1236. procedure FlatToSel; {&USES None} {&FRAME-}
  1237. asm
  1238.                 jmp     SysSysFlatToSel
  1239. end;
  1240.  
  1241. // Checks I/O result. Called after any I/O standard routine
  1242. // when compiled in the {$I+} state.
  1243.  
  1244. procedure _IOChk; {&USES eax} {&FRAME-}
  1245. asm
  1246.                 push    OFFSET InOutRes
  1247.                 Call    _GetTlsVar
  1248.                 mov     eax,[eax]
  1249.                 test    eax,eax
  1250.                 jz      @@RET
  1251.                 add     esp,@Uses
  1252.                 mov     al,reInOutError
  1253.                 jmp     RtlError
  1254.               @@RET:
  1255. end;
  1256.  
  1257. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ UTILITY ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  1258.  
  1259. // Calculates the length of the null-terminated string
  1260. // EXPECTS:     edi     = source string
  1261. // RETURNS:     eax     = Length
  1262.  
  1263. procedure PCharLength; {&USES edi} {&FRAME-}
  1264. asm
  1265.                 cld
  1266.                 or      ecx,-1                  // ecx := -1
  1267.                 xor     eax,eax                 // Determine string length
  1268.                 repne   scasb
  1269.                 sub     eax,ecx                 // eax := Length of the string
  1270.                 dec     eax
  1271.                 dec     eax
  1272. end;
  1273.  
  1274. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ HEAP MEMORY MANAGER ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  1275.  
  1276. type
  1277.   PBlockRec = ^TBlockRec;
  1278.   TBlockRec = record            // Heap free sub-block record
  1279.     Next:      PBlockRec;       // Pointer to the next free sub-block
  1280.     Size:      Longint;         // Size of the sub-block
  1281.   end;
  1282.  
  1283.   PHeapRec = ^THeapRec;
  1284.   THeapRec = record             // Heap Block record
  1285.     Signature: Longint;         // Signature = 'VPSM' or 'VPLG'
  1286.     FreeList:  TBlockRec;       // Free sub-block list head
  1287.     MemFree:   Longint;         // Number of free bytes in the Heap Block
  1288.     TotalSize: Longint;         // Total size of the Heap Block
  1289.     NextHeap:  Pointer;         // Pointer to the next Heap Block
  1290.     HeapOrg:   TBlockRec;       // Heap memory starts here, marks header end
  1291.   end;
  1292.  
  1293.   PHeapBlockList = ^THeapBlockList;
  1294.   THeapBlockList = Array[0..MaxLongInt div 4] of Longint;
  1295.  
  1296. const
  1297.   HeapSemaphore : Longint = 0;          // "Semaphore", synchronising access
  1298.   HeapBlockList : PHeapBlockList = nil; // Sorted list of heap blocks
  1299.   hblNext       : Longint = 0;          // Next entry to use
  1300.   hblAlloc      : Longint = 0;          // Number of entries allocated
  1301.  
  1302. const
  1303.   MemoryManager: TMemoryManager = (
  1304.     GetMem: SysGetMem;
  1305.     FreeMem: SysFreeMem;
  1306.     ReallocMem: SysReallocMem);
  1307.  
  1308. // Return the state of the heap, in a Delphi compatible THeapStatus
  1309. // record.
  1310.  
  1311. const
  1312.   OSCommitkB  = 4*1024-1;  // The OS commits memory in 4kB chunks
  1313.   OSAddresskB = 64*1024-1; // Each OS allocation uses 64kB Address space
  1314.  
  1315. function GetHeapStatus: THeapStatus;
  1316.  
  1317.   procedure ParseHeapList(P: PHeapRec);
  1318.   var
  1319.     Starting: PHeapRec;
  1320.   begin
  1321.     Starting := P;
  1322.     if P <> nil then
  1323.       repeat
  1324.         Inc(Result.TotalAddrSpace, (P^.TotalSize + OSAddresskB) and not OSAddresskB);
  1325.         Inc(Result.TotalCommitted, (P^.TotalSize + OSCommitkB) and not OSCommitkB);
  1326.         Inc(Result.FreeSmall, P^.MemFree);
  1327.         Inc(Result.Overhead, SizeOf(THeapRec) - SizeOf(TBlockRec));
  1328.         P := P^.NextHeap;
  1329.       until P = Starting;
  1330.   end;
  1331.  
  1332. begin
  1333.   FillChar(Result, SizeOf(Result), 0);
  1334.   Result.TotalAllocated := AllocMemSize;
  1335.   ParseHeapList(SmHeapList);
  1336.   ParseHeapList(LgHeapList);
  1337.  
  1338.   Result.TotalFree := Result.FreeSmall + Result.FreeBig;
  1339.   Result.TotalUnCommitted := Result.TotalAddrSpace - Result.TotalCommitted;
  1340.   Inc(Result.Overhead, AllocMemCount * 4);
  1341.   Dec(Result.TotalAllocated, AllocMemCount * 4);
  1342. end;
  1343.  
  1344. // New and GetMem standard procedures
  1345. // procedure New(var P: Pointer);
  1346. // procedure GetMem(var P: Pointer; Size: Longint);
  1347. // RETURNS:     eax     = Pointer to allocated memory block
  1348.  
  1349. procedure _MemNew(Size: Longint); {&USES ecx,edx} {&Frame-}
  1350. asm
  1351.                 mov     eax,Size
  1352.                 test    eax,eax
  1353.                 jz      @@RET
  1354.                 push    eax
  1355.                 Call    MemoryManager.GetMem
  1356.                 test    eax,eax
  1357.                 jnz     @@RET                   // Success?
  1358.                 add     esp,@Uses               // No, report a run-time error
  1359.                 mov     al,reOutOfMemory
  1360.                 jmp     RtlError
  1361.               @@RET:
  1362. end;
  1363.  
  1364. // Dispose and FreeMem standard procedures
  1365. // procedure Dispose(var P: Pointer);
  1366. // procedure FreeMem(var P: Pointer[; Size: Longint]);
  1367.  
  1368. procedure _MemFree(P: Pointer); {&USES eax,ecx,edx} {&FRAME-}
  1369. asm
  1370.                 mov     eax,P
  1371.                 test    eax,eax
  1372.                 jz      @@RET
  1373.                 push    eax
  1374.                 Call    MemoryManager.FreeMem
  1375.                 test    eax,eax
  1376.                 jz      @@RET
  1377.                 add     esp,@Uses
  1378.                 mov     al,reInvalidPtr
  1379.                 jmp     RtlError
  1380.               @@RET:
  1381. end;
  1382.  
  1383. // procedure ReallocMem(var P: Pointer; Size: Longint);
  1384. // The algorithm is the following:
  1385. //   ■ if (P = nil) and (Size = 0), reallocMem does nothing
  1386. //   ■ if (P = nil) and (Size <> 0), ReallocMem allocates new block of the given
  1387. //     size and sets P to point to the block. This corresponds to call to GetMem.
  1388. //   ■ if (P <> nil) and (Size = 0), ReallocMem disposes the block referenced by
  1389. //      P and sets P to nil. This corresponds to a call to FreeMem, except that
  1390. //      FreeMem does not clear the pointer.
  1391.  
  1392. procedure _MemRealloc(var P: Pointer; Size: Longint); {&USES eax,ecx,edx} {&FRAME-}
  1393. asm
  1394.                 mov     eax,P
  1395.                 mov     edx,Size
  1396.                 mov     ecx,[eax]
  1397.                 jecxz   @@Alloc
  1398.                 test    edx,edx
  1399.                 jz      @@Free
  1400.               @@Resize:
  1401.                 push    ecx                     // [1]:Pointer = OldMem
  1402.                 push    edx                     // [2]:Longint = NewSize
  1403.                 Call    MemoryManager.ReallocMem
  1404.                 test    eax,eax
  1405.                 jnz     @@Set
  1406.               @@AllocError:
  1407.                 add     esp,@Uses
  1408.                 mov     al,reOutOfMemory
  1409.                 jmp     RtlError
  1410.               @@Free:
  1411.                 push    ecx
  1412.                 Call    MemoryManager.FreeMem
  1413.                 test    eax,eax
  1414.                 jz      @@Set                   // Zero pointer
  1415.                 add     esp,@Uses
  1416.                 mov     al,reInvalidPtr
  1417.                 jmp     RtlError
  1418.               @@Alloc:
  1419.                 test    edx,edx
  1420.                 jz      @@RET
  1421.                 push    edx
  1422.                 Call    MemoryManager.GetMem
  1423.                 test    eax,eax
  1424.                 jz      @@AllocError
  1425.               @@Set:
  1426.                 mov     ecx,P
  1427.                 mov     [ecx],eax
  1428.               @@RET:
  1429. end;
  1430.  
  1431. function GetPMemoryManager: PMemoryManager;
  1432. begin
  1433.   Result := @MemoryManager;
  1434. end;
  1435.  
  1436. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  1437. begin
  1438.   MemMgr := MemoryManager;
  1439. end;
  1440.  
  1441. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  1442. begin
  1443.   MemoryManager := MemMgr;
  1444. end;
  1445.  
  1446. function MemAvail: Longint; {&USES None} {&FRAME-}
  1447. asm
  1448.                 push    OFFSET HeapSemaphore
  1449.                 Call    SysSysWaitSem
  1450.                 Call    SysMemAvail
  1451.                 mov     ecx,LgHeapList          // eax := Total Size
  1452.                 jecxz   @@Small
  1453.               @@2:
  1454.                 add     eax,[ecx].THeapRec.MemFree
  1455.                 mov     ecx,[ecx].THeapRec.NextHeap
  1456.                 cmp     ecx,LgHeapList
  1457.                 jne     @@2
  1458.               @@Small:
  1459.                 mov     ecx,SmHeapList
  1460.                 jecxz   @@RET
  1461.               @@3:
  1462.                 add     eax,[ecx].THeapRec.MemFree
  1463.                 mov     ecx,[ecx].THeapRec.NextHeap
  1464.                 cmp     ecx,SmHeapList
  1465.                 jne     @@3
  1466.               @@RET:                            // Unlock heap manager
  1467.                 test    eax,$80000000
  1468.                 jz      @@ok
  1469.                 mov     eax,$7fffffff            // Make sure result is 31 bits only
  1470.               @@ok:
  1471.            lock btr     HeapSemaphore,0
  1472. end;
  1473.  
  1474. function MaxAvail: Longint; {&USES None} {&FRAME-}
  1475. asm
  1476.                 push    OFFSET HeapSemaphore
  1477.                 Call    SysSysWaitSem
  1478.                 Call    SysMemAvail             // eax := Total size
  1479.                 mov     ecx,LgHeapList
  1480.                 call    @@Adjust                // Adjust with Large blocks
  1481.                 mov     ecx,SmHeapList
  1482.                 call    @@Adjust                // Adjust with small blocks
  1483.                 jmp     @@RET
  1484.  
  1485.               @@Adjust:
  1486.                 jecxz   @@Exit
  1487.                 mov     edx,ecx
  1488.               @@2:
  1489.                 cmp     eax,[ecx].THeapRec.MemFree
  1490.                 jae     @@3
  1491.                 mov     eax,[ecx].THeapRec.MemFree
  1492.               @@3:
  1493.                 mov     ecx,[ecx].THeapRec.NextHeap
  1494.                 cmp     ecx,edx
  1495.                 jne     @@2
  1496.               @@Exit:
  1497.                 ret
  1498.  
  1499.               @@RET:
  1500.                 test    eax,$80000000
  1501.                 jz      @@ok
  1502.                 mov     eax,$7fffffff            // Make sure result is 31 bits only
  1503.               @@ok:
  1504.            lock btr     HeapSemaphore,0
  1505. end;
  1506. procedure NewHeapBlock; forward;
  1507. procedure NewSubBlock;  forward;
  1508.  
  1509. // Allocates memory
  1510. // EXPECTS:     eax     = Size of the memory block to allocate
  1511. // RETURNS:     eax     = Pointer to allocated memory block (nil if failed)
  1512.  
  1513. function SysGetMem(Size: Longint): Pointer; assembler; {&USES ebx,esi,edi} {&FRAME-}
  1514. var
  1515.   BlockSize: Longint;
  1516. asm
  1517.            lock bts     HeapSemaphore,0
  1518.                 jnc     @@Clear                 // Lock heap manager
  1519.                 push    OFFSET HeapSemaphore
  1520.                 Call    SysSysWaitSem
  1521.               @@Clear:
  1522.                 mov     eax,Size
  1523.                 add     eax,(TYPE TBlockRec-1+4)  // Align size to a qword boundary
  1524.                 and     al,NOT (TYPE TBlockRec-1) // +4 = Store BlockSize
  1525.                 mov     BlockSize,eax
  1526.               @@0:
  1527.  
  1528. // Small allocations <= HeapLimit must be allocated from a small
  1529. // memory block to avoid putting a small allocation in a large
  1530. // block, which then can become almost empty and cause overcommitment
  1531.                 cmp     eax,HeapLimit
  1532.                 jge     @@ScanLarge             // Large block
  1533.  
  1534.                 mov     ecx,SmHeapList
  1535.                 jecxz   @@AllocSmall
  1536.  
  1537.               @@NextSmall:
  1538.                 Call    NewSubBlock             // Successfully allocated ?
  1539.                 jnc     @@SmallOK               // Yes, exit
  1540.                 mov     ecx,[ecx].THeapRec.NextHeap
  1541.                 cmp     ecx,SmHeapList          // No, goto next heap block
  1542.                 jne     @@NextSmall             // Are all blocks searched?
  1543.               @@AllocSmall:
  1544.                 xor     ecx,ecx
  1545.                 Call    NewHeapBlock            // Fail ?
  1546.                 jc      @@ERROR                 // Yes, error
  1547.  
  1548.                 Call    NewSubBlock             // No, success, allocate new
  1549.               @@SmallOK:                        // memory block
  1550.                 mov     SmHeapList,ecx          // eax = Pointer to
  1551.                 jmp     @@Done                  // allocated memory block
  1552.  
  1553. // Allocate a large block > HeapLimit
  1554.               @@ScanLarge:                      // Scan available Heap Blocks
  1555.                 mov     ecx,LgHeapList
  1556.                 jecxz   @@AllocLarge
  1557.  
  1558.               @@NextLarge:                      // Scan available Heap Blocks
  1559.                 Call    NewSubBlock             // Successfully allocated ?
  1560.                 jnc     @@LargeOK
  1561.                 mov     ecx,[ecx].THeapRec.NextHeap
  1562.                 cmp     ecx,LgHeapList          // No, goto next heap block
  1563.                 jne     @@NextLarge             // Are all blocks searched?
  1564.               @@AllocLarge:
  1565.                 mov     ecx,1
  1566.                 Call    NewHeapBlock            // Fail ?
  1567.                 jc      @@ERROR                 // Yes, error
  1568.  
  1569.                 Call    NewSubBlock             // No, success, allocate new
  1570.               @@largeOK:                        // memory block
  1571.                 mov     LgHeapList,ecx          // eax = Pointer to
  1572.                 jmp     @@Done                  // allocated memory block
  1573.  
  1574.               @@ERROR:
  1575.                 mov     ecx,HeapError           // If HeapError = nil then
  1576.                 jecxz   @@Fail                  // exit
  1577.                 push    eax                     // [1]:Longint = Failed size
  1578.                 Call    ecx                     // Call HeapError
  1579.                 cmp     eax,1
  1580.                 mov     eax,BlockSize           // Restore requested size
  1581. // 0 = Failure with run-time error \  Now merged, always
  1582. // 1 = Failure: return NIL pointer /  causes RTE to occur
  1583. // 2 = Success: retry operation
  1584.                 ja      @@0                     // Retry
  1585.               @@Fail:
  1586.                 xor     eax,eax                 // Fail, return NIL pointer
  1587.                 jmp     @@RET
  1588.  
  1589.               @@Done:
  1590.                 mov     ecx,BlockSize
  1591.                 mov     [eax],ecx
  1592.                 inc     AllocMemCount
  1593.                 add     AllocMemSize,ecx
  1594.                 add     eax,4
  1595.               @@RET:                            // Unlock heap manager
  1596.            lock btr     HeapSemaphore,0
  1597. end;
  1598.  
  1599. // Re-allocate a memory block allocated directly from the operating system
  1600.  
  1601. function OSReallocMem(_P: Pointer; _Old, _New: Longint): Pointer;
  1602.   assembler; {&uses esi,edi} {&frame+}
  1603. asm
  1604.                 mov     ecx,_New
  1605.                 push    0                   // MemPtr
  1606.                 mov     eax,esp
  1607.                 push    ecx                 // [1]:DWord = Size
  1608.                 push    HeapAllocFlags      // [2]:DWord = Flags
  1609.                 push    eax                 // [3]:Pointer = @MemPtr
  1610.                 Call    SysMemAlloc
  1611.                 pop     eax                 // MemPtr
  1612.                 test    eax,eax             // nil?
  1613.                 stc                         // Set carry to indicate error
  1614.                 jz      @@RET               // Error: Return
  1615.  
  1616.                 push    eax
  1617.                 mov     esi,_P              // Previous block
  1618.                 mov     edi,eax             // New block
  1619.                 mov     eax,_Old
  1620.                 mov     ecx,_New
  1621.                 cmp     eax,ecx             // Compate _Old and _New
  1622.                 jg      @@1                 // _Old > _New
  1623.                 mov     ecx,eax             // _New > _Old
  1624.               @@1:
  1625.                 cld
  1626.                 rep     movsb               // Copy data
  1627.  
  1628.                 mov     eax,_P
  1629.                 push    eax
  1630.                 call    SysMemFree          // Free old block
  1631.                 pop     eax                 // Return new mem block
  1632.               @@RET:
  1633. end;
  1634.  
  1635. // Insert the new heap block, in sorted order.  This dramatically
  1636. // speeds up freeing memory, as a binary search on a large number
  1637. // of heap blocks can be performed, instead of a linear one.
  1638.  
  1639. procedure InsertNewheapBlock( _P: Longint); {&uses ebx,esi} {&Frame+}
  1640. asm
  1641.                 mov     eax,hblAlloc
  1642.                 or      eax,eax             // Is HeapBlockList nil?
  1643.                 jg      @@Not0
  1644.  
  1645. // Allocate initial memory for HeapBlockList
  1646.                 mov     ecx,512             // Yes, initial allocation in DWords
  1647.                 mov     hblAlloc,ecx        // Save this value
  1648.                 shl     ecx,2
  1649.                 push    0                   // MemPtr
  1650.                 mov     eax,esp
  1651.                 push    ecx                 // [1]:DWord = Size
  1652.                 push    HeapAllocFlags      // [2]:DWord = Flags
  1653.                 push    eax                 // [3]:Pointer = @MemPtr
  1654.                 Call    SysMemAlloc
  1655.                 pop     eax                 // MemPtr
  1656.                 test    eax,eax             // nil?
  1657.                 stc                         // Set carry to indicate error
  1658.                 jz      @@RET               // Error: Return
  1659.  
  1660.                 mov     HeapBlockList,eax
  1661.                 jmp     @@Insert
  1662.  
  1663.               @@Not0:
  1664.                 cmp     eax,hblNext         // Room for another entry?
  1665.                 jg      @@Insert
  1666.                 shl     eax,1               // No, allocate more memory
  1667.                 mov     hblAlloc,eax
  1668.                 push    HeapBlockList       // [1]:DWord = MemPtr
  1669.                 shl     eax,1
  1670.                 push    eax                 // [2]:DWord = Old size
  1671.                 shl     eax,1
  1672.                 push    eax                 // [3]:DWord = New size
  1673.                 call    OSReAllocMem
  1674.                 jc      @@RET               // Error
  1675.                 mov     HeapBlockList,eax
  1676.  
  1677. // Binary search for the insert location
  1678.               @@Insert:
  1679.                 mov     edx,HeapBlockList
  1680.                 mov     ebx,_P              // N
  1681.                 mov     eax,0               // Lo := 0
  1682.                 mov     ecx,hblNext         // Hi := Max
  1683.                 mov     esi,eax
  1684.               @@1:
  1685.                 cmp     eax,ecx             // Lo >= Hi?
  1686.                 jge     @@Found
  1687.                 mov     esi,eax             // j := (Lo+Hi) div 2
  1688.                 add     esi,ecx
  1689.                 shr     esi,1
  1690.                 cmp     ebx,[edx+esi*4]     // N < x[j]?
  1691.                 jl      @@2
  1692.                 mov     eax,esi             // No; Lo := j+1
  1693.                 inc     eax
  1694.                 jmp     @@1
  1695.               @@2:
  1696.                 mov     ecx,esi             // Yes: Hi := j
  1697.                 jmp     @@1
  1698.  
  1699. // Perform the insert
  1700.               @@Found:
  1701.                 mov     ecx,hblNext         // MoveCount := (Hi-j) div 4
  1702.                 mov     esi,eax
  1703.                 sub     ecx,esi
  1704.                 shl     esi,2
  1705.                 add     esi,edx
  1706.                 mov     edx,esi
  1707.                 jecxz   @@NoMove            // Insert at end of list: No move
  1708.                 mov     eax,ecx
  1709.                 shl     eax,2
  1710.                 add     esi,eax
  1711.                 mov     edi,esi
  1712.                 sub     esi,4
  1713.                 std
  1714.                 rep     movsd               // Make room
  1715.                 cld
  1716.               @@NoMove:
  1717.                 mov     [edx],ebx           // Copy new entry
  1718.                 inc     hblNext             // Increase heap block count
  1719.               @@RET:
  1720. end;
  1721.  
  1722. // Allocates system memory for a Heap Block
  1723. // EXPECTS:     eax     = Minimum Size ofblock to allocate
  1724. //              ecx     = 0: Allocate small block
  1725. //              ecx     = 1: Allocate large block
  1726. // RETURNS:     ecx     = Heap block address
  1727. //              CF      = 1 if error
  1728.  
  1729. procedure NewHeapBlock; {&USES eax,ebx} {&FRAME-}
  1730. asm
  1731.                 mov     ebx,eax
  1732.                 or      ecx,ecx
  1733.                 jne     @@AllocLarge
  1734.                 // Allocate block for small allocations
  1735.                 mov     ecx,SmHeapBlock
  1736.                 add     eax,THeapRec.HeapOrg.Longint
  1737.                 cmp     eax,ecx
  1738.                 jbe     @@1
  1739.                 dec     ecx                     // Round up to boundary
  1740.                 add     eax,ecx                 // Inc(Size, BlockSize-1)
  1741.                 not     ecx
  1742.                 and     eax,ecx                 // And not (Blocksize-1)
  1743.                 mov     ecx,eax
  1744.                 jmp     @@1
  1745.  
  1746.               @@AllocLarge:
  1747.                 mov     ecx,LgHeapBlock
  1748.                 add     eax,THeapRec.HeapOrg.Longint
  1749.                 cmp     eax,ecx
  1750.                 jbe     @@1
  1751.                 dec     ecx
  1752.                 add     eax,ecx                   // Round up to 64K boundary
  1753.                 not     ecx
  1754.                 and     eax,ecx
  1755.                 mov     ecx,eax
  1756.  
  1757.               @@1:
  1758.                 push    ecx                     // Size
  1759.                 push    0                       // MemPtr
  1760.                 mov     eax,esp
  1761.                 push    ecx                     // [1]:DWord = Size
  1762.                 push    HeapAllocFlags          // [2]:DWord = Flags
  1763.                 push    eax                     // [3]:Pointer = @MemPtr
  1764.                 Call    SysMemAlloc
  1765.                 pop     eax                     // MemPtr
  1766.                 pop     ecx                     // Size
  1767.                 test    eax,eax
  1768.                 stc
  1769.                 jz      @@RET                   // Error
  1770.                 push    eax
  1771.                 push    ecx
  1772.                 push    edx
  1773.                 push    eax
  1774.                 call    InsertNewheapBlock      // Insert in list
  1775.                 pop     edx
  1776.                 pop     ecx
  1777.                 pop     eax
  1778.                 jc      @@RET                   // Return if error
  1779.                 mov     [eax].THeapRec.TotalSize,ecx
  1780.                 sub     ecx,THeapRec.HeapOrg.Longint
  1781.                 mov     [eax].THeapRec.MemFree,ecx
  1782.                 mov     [eax].THeapRec.Signature,'GLPV' // For large blocks
  1783.                 mov     edx,LgHeapList
  1784.                 cmp     ebx,HeapLimit
  1785.                 jge     @@Large
  1786.                 mov     edx,SmHeapList
  1787.                 mov     [eax].THeapRec.Signature,'MSPV' // For small blocks
  1788.               @@Large:
  1789.                 clc
  1790.                 mov     [eax].THeapRec.HeapOrg.Size,ecx
  1791.                 and     [eax].THeapRec.HeapOrg.Next,0
  1792.                 lea     ecx,[eax].THeapRec.HeapOrg
  1793.                 and     [eax].THeapRec.FreeList.Size,0
  1794.                 mov     [eax].THeapRec.FreeList.Next,ecx
  1795.                 mov     ecx,eax                 // ring-linked list of blocks
  1796.                 test    edx,edx
  1797.                 jz      @@2                     // Empty? Yes, NextHeap := Self@
  1798.                 xchg    eax,[edx].THeapRec.NextHeap
  1799.               @@2:                              // CF=0! (after TEST)
  1800.                 mov     [ecx].THeapRec.NextHeap,eax
  1801.               @@RET:
  1802. end;
  1803.  
  1804. // Allocates new sub-block within Heap Block
  1805. // EXPECTS:     ecx     = Heap block base address
  1806. //              eax     = Size of the sub-block to allocate
  1807. // RETURNS:     eax     = Allocated sub-block base address (CF=0)
  1808. //              CF      = 1 if requested sub-block cannot be allocated
  1809.  
  1810. procedure NewSubBlock; {&USES None} {&FRAME-}
  1811. asm
  1812.                 cmp     [ecx].THeapRec.MemFree,eax // Is there enough memory in
  1813.                 jb      @@RET                   // this block ?, No, exit CF=1
  1814.                 lea     edi,[ecx].THeapRec.FreeList
  1815.               @@1:
  1816.                 mov     esi,edi                 // esi = Previous block
  1817.                 mov     edi,[edi].TBlockRec.Next// Get next block
  1818.                 cmp     edi,1                   // Next = nil ?
  1819.                 jb      @@RET                   // Yes, exit CF=1
  1820.                 mov     edx,[edi].TBlockRec.Size// Is block big enough ?
  1821.                 sub     edx,eax                 // No, continue scanning free
  1822.                 jb      @@1                     // blocks (@@1)
  1823.                 mov     ebx,[edi].TBlockRec.Next// Yes, Size = Requested ?
  1824.                 je      @@2                     // Yes, perfect match
  1825. // No, block is bigger, split it into 2 pieces: one of the requested size,
  1826. // and the other of the Old-Requested size (Since each memory request is
  1827. // aligned on (TYPE TBlockRec) boundary there is always enough space for
  1828. // TBlockRec.) Then insert second block into free block list.
  1829.                 mov     [edi+eax].TBlockRec.Next,ebx
  1830.                 mov     [edi+eax].TBlockRec.Size,edx
  1831.                 lea     ebx,[edi+eax]
  1832.               @@2:
  1833.                 mov     [esi].TBlockRec.Next,ebx   // Remove allocated block from
  1834.                 sub     [ecx].THeapRec.MemFree,eax // free block list
  1835.                 mov     eax,edi
  1836.                 clc
  1837.               @@RET:
  1838. end;
  1839.  
  1840. // Merges current sub-block with the next adjacent
  1841. // EXPECTS:     ebx     = Current Sub-Block address
  1842.  
  1843. procedure MergeSubBlock; {&USES None} {&FRAME-}
  1844. asm
  1845.                 mov     esi,ebx
  1846.                 add     esi,[ebx].TBlockRec.Size
  1847.                 cmp     esi,[ebx].TBlockRec.Next
  1848.                 jne     @@RET
  1849.                 mov     eax,[esi].TBlockRec.Next
  1850.                 mov     [ebx].TBlockRec.Next,eax
  1851.                 mov     eax,[esi].TBlockRec.Size
  1852.                 add     [ebx].TBlockRec.Size,eax
  1853.               @@RET:
  1854. end;
  1855.  
  1856. // Disposes the memory block
  1857. // RETURNS:      eax    = <> 0 if error
  1858.  
  1859. function SysFreeMem(P: Pointer): Longint; {&USES ebx,esi,edi} {&FRAME-}
  1860. asm
  1861.                 mov     ebx,P
  1862.            lock bts     HeapSemaphore,0
  1863.                 jnc     @@Clear                 // Lock heap manager
  1864.                 push    OFFSET HeapSemaphore
  1865.                 Call    SysSysWaitSem
  1866.               @@Clear:
  1867.                 sub     ebx,4
  1868.                 mov     eax,[ebx]
  1869.                 test    bl,TYPE TBlockRec-1     // Is block base qword-aligned?
  1870.                 jnz     @@ERROR                 // No, error
  1871. // Find Heap Block that contains this base address
  1872.                 push    eax
  1873.                 push    esi
  1874.                 mov     ecx,HeapBlockList
  1875.                 xor     eax,eax
  1876.                 mov     edx,hblNext
  1877.  
  1878.               @@Next:
  1879.                 mov     esi,eax
  1880.                 add     esi,edx
  1881.                 shr     esi,1
  1882.                 cmp     ebx,[ecx+esi*4]
  1883.                 jb      @@2                     // Nope, address is less
  1884.                 mov     eax,[ecx+esi*4]
  1885.                 add     eax,[eax].THeapRec.TotalSize
  1886.                 cmp     ebx,eax
  1887.                 jb      @@Found                 // Found insert point
  1888.                 mov     eax,esi                 // More
  1889.                 inc     eax
  1890.                 jmp     @@Next
  1891.  
  1892.               @@2:
  1893.                 mov     edx,esi
  1894.                 dec     edx
  1895.                 jmp     @@Next
  1896.  
  1897.               @@Found:
  1898.                 mov     ecx,[ecx+esi*4]
  1899.                 cmp     [ecx].THeapRec.Signature,'GLPV'
  1900.                 je      @@SigOK
  1901.                 cmp     [ecx].THeapRec.Signature,'MSPV'
  1902.                 jne     @@ERROR
  1903.               @@SigOK:
  1904.                 mov     edx,esi // Save index in edx
  1905.                 pop     esi
  1906.                 pop     eax
  1907.                 jmp     @@BlockFound
  1908.               @@ERROR:
  1909.                 mov     al,1
  1910.                 jmp     @@Done
  1911.  
  1912. // Heap Block is found: ecx = base address
  1913. // ■ Check for signature
  1914. // ■ Scan free list and find out the right place to insert new free block
  1915.               @@BlockFound:
  1916.                 lea     esi,[ecx].THeapRec.FreeList
  1917.               @@3:
  1918.                 mov     edi,esi         // edi = Previous Block
  1919.                 mov     esi,[esi].TBlockRec.Next
  1920.                 test    esi,esi
  1921.                 jz      @@4
  1922.                 cmp     ebx,esi         // Request base > Current Free Block ?
  1923.                 ja      @@3             // No, found
  1924.                 je      @@ERROR         // Exactly equal ? Yes, probably double
  1925.               @@4:                      // dispose request, error
  1926.  
  1927.                 dec     AllocMemCount
  1928.                 sub     AllocMemSize,eax
  1929.                 mov     [ebx].TBlockRec.Next,esi
  1930.                 mov     [ebx].TBlockRec.Size,eax
  1931.                 add     eax,[ecx].THeapRec.MemFree
  1932.                 mov     [ecx].THeapRec.MemFree,eax
  1933.                 add     eax,THeapRec.HeapOrg.Longint
  1934.                 cmp     eax,[ecx].THeapRec.TotalSize
  1935.                 jne     @@MergeBlock
  1936. // All heap block is empty, remove it from the list
  1937.                 push    edx             // Save index
  1938.  
  1939.                 lea     esi,SmHeapList
  1940.                 cmp     [ecx].THeapRec.Signature,'MSPV'
  1941.                 je      @@Small
  1942.                 lea     esi,LgHeapList
  1943.               @@Small:
  1944.  
  1945.                 xor     eax,eax
  1946.                 mov     edx,[ecx].THeapRec.NextHeap
  1947.                 cmp     ecx,edx
  1948.                 je      @@6             // Only one list in chain: Set to nil
  1949.  
  1950.                 mov     ebx,[esi]
  1951.               @@5:
  1952.                 mov     eax,ebx
  1953.                 mov     ebx,[ebx].THeapRec.NextHeap
  1954.                 cmp     ebx,ecx
  1955.                 jne     @@5
  1956.                 mov     [eax].THeapRec.NextHeap,edx
  1957.               @@6:
  1958.                 mov     [esi],eax
  1959.  
  1960.                 pop     edx             // Restore index
  1961. // Free HeapListBlock reference
  1962.                 push    edi
  1963.                 push    ecx
  1964.                 mov     esi,HeapBlockList
  1965.                 dec     hblNext
  1966.                 mov     ecx,hblNext
  1967.                 sub     ecx,edx
  1968.                 jle     @@FreeSystemMem
  1969.                 shl     edx,2
  1970.                 add     esi,edx
  1971.                 mov     edi,esi
  1972.                 add     esi,4
  1973.                 cld
  1974.                 rep     movsd
  1975.  
  1976.               @@FreeSystemMem:
  1977.                 pop     ecx
  1978.                 pop     edi
  1979. // Release system memory
  1980.                 push    ecx                     // eax := Base address
  1981.                 Call    SysMemFree
  1982.                 jmp     @@OK
  1983. // There are allocated memory in the block, try to merge current sub-block
  1984. // with two adjacent ones.
  1985.               @@MergeBlock:
  1986.                 Call    MergeSubBlock           // Merge with next sub-block
  1987.                 mov     [edi].TBlockRec.Next,ebx
  1988.                 mov     ebx,edi                 // Merge with previous sub-block
  1989.                 Call    MergeSubBlock
  1990.               @@OK:
  1991.                 xor     eax,eax
  1992.               @@Done:                           // Unlock heap manager
  1993.            lock btr     HeapSemaphore,0
  1994. end;
  1995.  
  1996. // Reallocates the memory block
  1997.  
  1998. function SysReallocMem(P: Pointer; Size: Longint): Pointer; {&USES ebx} {&FRAME-}
  1999. asm
  2000.                 push    Size                    // [1]:Longint = Size
  2001.                 Call    SysGetMem
  2002.                 mov     ebx,eax
  2003.                 mov     ecx,P
  2004.                 mov     eax,[ecx-4]
  2005.                 sub     eax,4                   // OldSize
  2006.                 cmp     eax,Size
  2007.                 jb      @@1
  2008.                 mov     eax,Size
  2009.               @@1:                              // Min(Size, OldSize)
  2010.                 push    ecx                     // [1]:Pointer = Src
  2011.                 push    ebx                     // [2]:Pointer = Dest
  2012.                 push    eax                     // [3]:Pointer = Count
  2013.                 Call    _MemMove
  2014.                 push    ecx                     // [1]:Pointer = Mem
  2015.                 Call    SysFreeMem
  2016.                 test    eax,eax
  2017.                 jz      @@2
  2018.                 push    ebx
  2019.                 Call    SysFreeMem
  2020.                 xor     ebx,ebx
  2021.               @@2:
  2022.                 mov     eax,ebx
  2023. end;
  2024.  
  2025. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ RANDOM NUMBER GENERATOR ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  2026.  
  2027. // RETURNS:      eax =  Next Random Number
  2028.  
  2029. procedure NextRandom; {&USES edx} {&FRAME-}
  2030. asm
  2031.                 mov     eax,8088405h            // New := 8088405h * Old + 1
  2032.                 mul     RandSeed
  2033.                 inc     eax
  2034.                 mov     RandSeed,eax
  2035. end;
  2036.  
  2037. // Random standard function (Integer)
  2038. // function Random [ ( Range: Longint) ]: < Same type as parameter >;
  2039. // EXPECTS:       [1]:Longint = Upper Bound of the Range
  2040. // RETURNS:       eax = Random number X: 0 <= X < Range
  2041.  
  2042. procedure _RandInt(Range: Longint); {&USES edx} {&FRAME-}
  2043. asm
  2044.                 Call    NextRandom
  2045.                 mul     Range           // Random * Range / 1 0000 0000h
  2046.                 mov     eax,edx         // 0 <= eax < Range
  2047. end;
  2048.  
  2049. // Random standard function (Float)
  2050. // function Random [ ( Range: Word) ]: < Same type as parameter >;
  2051. // RETURNS:     ST(0)   = Random Number X: 0 <= X < 1
  2052.  
  2053. procedure _RandFlt; assembler; {&USES eax} {&FRAME-}
  2054. const
  2055.   ConstDelta: Single   = 2147483648.0;          // 80000000h
  2056.   ConstScale: SmallInt = -32;                   // -32
  2057. asm
  2058.                 Call    NextRandom              // Compute next random number
  2059.                 fild    ConstScale              // Load -32
  2060.                 fild    RandSeed                // Load 32-bit random integer
  2061.                 fadd    ConstDelta              // Scale to 32-bit positive integer
  2062.                 fscale                          // Scale so 0 <= ST < 1
  2063.                 fstp    st(1)                   // Remove scaling factor
  2064. end;
  2065.  
  2066. procedure Randomize; {&USES eax,ecx,edx} {&FRAME-}
  2067. asm
  2068.                 Call    SysSysMsCount
  2069.                 mov     RandSeed,eax            // Init Random Seed
  2070. end;
  2071.  
  2072. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ STRING HANDLING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  2073.  
  2074. // Loads a string
  2075. // Important!:  Doesn't pop destination pointer
  2076.  
  2077. procedure _StrLoad(Dest,Src: Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  2078. asm
  2079.                 cld
  2080.                 mov     esi,Src
  2081.                 mov     edi,Dest
  2082.                 xor     eax,eax
  2083.                 lodsb
  2084.                 stosb
  2085.                 mov     ecx,eax
  2086.                 shr     ecx,2
  2087.                 and     al,11b
  2088.                 rep     movsd
  2089.                 mov     cl,al
  2090.                 rep     movsb
  2091.                 PopArgs @Params - Type Dest
  2092. end;
  2093.  
  2094. // Stores a string
  2095.  
  2096. procedure _StrStore(Src,Dest: Pointer; MaxLen: Longint); {&USES eax,ecx,esi,edi} {&FRAME-}
  2097. asm
  2098.                 cld
  2099.                 mov     esi,Src
  2100.                 mov     edi,Dest
  2101.                 mov     ecx,MaxLen
  2102.                 xor     eax,eax
  2103.                 lodsb
  2104.                 cmp     al,cl
  2105.                 jbe     @@1
  2106.                 mov     al,cl
  2107.               @@1:
  2108.                 stosb
  2109.                 mov     ecx,eax
  2110.                 shr     ecx,2
  2111.                 and     al,11b
  2112.                 rep     movsd
  2113.                 mov     cl,al
  2114.                 rep     movsb
  2115. end;
  2116.  
  2117. // Converts Char to String
  2118. // Important!:  Doesn't pop destination pointer
  2119.  
  2120. procedure _StrChar(Dest: Pointer; Char: Byte); {&USES eax,edx} {&FRAME-}
  2121. asm
  2122.                 mov     ah,Char
  2123.                 mov     al,1
  2124.                 mov     edx,Dest
  2125.                 mov     [edx],ax
  2126.                 PopArgs @Params - Type Dest
  2127. end;
  2128.  
  2129. // Converts packed string to string
  2130. // Important!:  Doesn't pop destination pointer
  2131.  
  2132. procedure _StrPacked(Dest,Src: Pointer; Len: Longint); {&USES eax,ecx,esi,edi} {&FRAME-}
  2133. asm
  2134.                 cld
  2135.                 mov     esi,Src
  2136.                 mov     edi,Dest
  2137.                 mov     eax,Len
  2138.                 stosb
  2139.                 mov     ecx,eax
  2140.                 shr     ecx,2
  2141.                 and     al,11b
  2142.                 rep     movsd
  2143.                 mov     cl,al
  2144.                 rep     movsb
  2145.                 PopArgs @Params - Type Dest
  2146. end;
  2147.  
  2148. // Copy standard function
  2149. // function Copy(S: String; Index: Integer; Count: Integer): String;
  2150. // Important!:  Doesn't pop destination pointer
  2151.  
  2152.  
  2153. procedure _StrCopy(Dest,Src: Pointer; Index,Count: Longint); {&USES eax,ecx,esi,edi} {&FRAME-}
  2154. asm
  2155.                 cld
  2156.                 mov     esi,Src
  2157.                 mov     edi,Dest
  2158.                 movzx   eax,Byte Ptr [esi]      // eax := Length(S)
  2159.                 mov     ecx,Index               // ecx := Index
  2160.                 test    ecx,ecx                 // If Index < 0 then Index := 1
  2161.                 jg      @@1
  2162.                 mov     ecx,1
  2163.               @@1:
  2164.                 add     esi,ecx                 // esi := @S[Index]
  2165.                 sub     eax,ecx                 // eax := Number of bytes from
  2166.                 jb      @@Empty                 // Index to the end of string-1
  2167.                 inc     eax
  2168.                 mov     ecx,Count               // If Count < 0 then Count := 0
  2169.                 test    ecx,ecx
  2170.                 jge     @@2
  2171.                 xor     ecx,ecx
  2172.               @@2:
  2173.                 cmp     eax,ecx
  2174.                 jbe     @@3                     // if eax > Count then eax := Count
  2175.                 mov     eax,ecx
  2176.                 jmp     @@3
  2177.               @@Empty:
  2178.                 xor     eax,eax
  2179.               @@3:
  2180.                 stosb                           // Store string length
  2181.                 mov     ecx,eax
  2182.                 shr     ecx,2
  2183.                 and     al,11b
  2184.                 rep     movsd
  2185.                 mov     cl,al
  2186.                 rep     movsb
  2187.                 PopArgs @Params - Type Dest
  2188. end;
  2189.  
  2190. // Concat standard function
  2191. // function Concat(s1 [,s2,..,sn] : String): String;
  2192. // Important!:  Doesn't pop destination pointer
  2193.  
  2194. procedure _StrConcat(Dest,Src: Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  2195. asm
  2196.                 cld
  2197.                 mov     esi,Src
  2198.                 mov     edi,Dest
  2199.                 movzx   ecx,Byte Ptr [edi]      // ecx := Length(Dest)
  2200.                 lodsb                           // al := Length(Src)
  2201.                 add     [edi],al                // Dest[0] := Length(Dest)+Length(Src)
  2202.                 jnc     @@1                     // If Total Length > 255 then
  2203.                 mov     Byte Ptr [edi],255      // Dest[0] := 255;
  2204.                 mov     al,cl                   // Truncate source string
  2205.                 not     al                      // al := truncated src length
  2206.               @@1:
  2207.                 add     edi,ecx                 // edi := @Dest[Length(Dest)+1
  2208.                 inc     edi
  2209.                 mov     cl,al                   // Append source string
  2210.                 shr     ecx,2
  2211.                 and     al,11b
  2212.                 rep     movsd
  2213.                 mov     cl,al
  2214.                 rep     movsb
  2215.                 PopArgs @Params - Type Dest
  2216. end;
  2217.  
  2218. // Pos standard function
  2219. // function Pos(SubStr: String; S: String): Byte;
  2220. // RETURNS:     eax     = Index of the first char of SubStr within S or 0 if SubStr is not found
  2221.  
  2222. procedure _StrPos(SubStr,S: Pointer); {&USES ebx,ecx,edx,esi,edi} {&FRAME-}
  2223. asm
  2224.                 cld
  2225.                 mov     esi,SubStr
  2226.                 lodsb
  2227.                 test    al,al                   // If SubStr = '' then Pos := 0
  2228.                 jz      @@Not_Found             // (Not found)
  2229.                 movzx   edx,al                  // edx := Length(SubStr)
  2230.                 mov     edi,S                   // If Length(SubStr) > Length(S)
  2231.                 movzx   ecx,Byte Ptr [edi]      // then Pos := 0 (Not found)
  2232.                 sub     ecx,edx                 // ■■■■■■■■■■■■■■■■■■■■ <=S
  2233.                 jb      @@Not_Found             // ■■■■■■■■■            <=SubStr
  2234.                 inc     ecx                     // ecx := <─┴─────────┘
  2235.                 inc     edi                     // edi := @S[1]
  2236.               @@1:
  2237.                 lodsb                           // Search SubStr[1] in S
  2238.                 repne   scasb
  2239.                 jne     @@Not_Found
  2240.                 mov     eax,edi                 // Compare other characters
  2241.                 mov     ebx,ecx
  2242.                 lea     ecx,[edx-1]
  2243.                 shr     ecx,2                   // FAST String compare
  2244.                 repe    cmpsd                   // if ecx = 0 then ZF = 1
  2245.                 jne     @@2
  2246.                 lea     ecx,[edx-1]
  2247.                 and     ecx,11b
  2248.                 repe    cmpsb
  2249.                 je      @@Found
  2250.               @@2:
  2251.                 mov     edi,eax                 // Restore edi, ecx
  2252.                 mov     ecx,ebx
  2253.                 mov     esi,SubStr
  2254.                 inc     esi                     // esi := @SubStr[1]
  2255.                 jmp     @@1
  2256.  
  2257.               @@Not_Found:
  2258.                 xor     eax,eax                 // Pos := 0
  2259.                 jmp     @@RET
  2260.  
  2261.               @@Found:
  2262.                 dec     eax
  2263.                 sub     eax,S
  2264.               @@RET:
  2265. end;
  2266.  
  2267. // String Compare
  2268. // RETURNS:     ZF = 1 if S1 = S2
  2269. //              CF = 1 if S1 < S2
  2270.  
  2271. procedure _StrCmp(S1,S2: Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  2272. asm
  2273.                 cld
  2274.                 xor     ecx,ecx
  2275.                 mov     esi,S1
  2276.                 mov     edi,S2
  2277.                 lodsb                           // al := Length(S1)
  2278.                 mov     ah,[edi]                // ah := Length(S2)
  2279.                 inc     edi
  2280.                 mov     cl,al
  2281.                 cmp     cl,ah
  2282.                 jbe     @@1
  2283.                 mov     cl,ah                   // ecx := Min(al,ah)
  2284.               @@1:
  2285.                 jecxz   @@CmpLen
  2286.                 repe    cmpsb
  2287.                 jne     @@RET
  2288.               @@CmpLen:
  2289.                 cmp     al,ah
  2290.               @@RET:
  2291. end;
  2292.  
  2293. // Insert standard procedure
  2294. // procedure Insert(Src: String; var S: String; Index: Integer);
  2295. // Insert(Src,Dest,Index) = Copy(Dest,1,Index-1) + Src + Copy(Dest,Index,255)
  2296.  
  2297. procedure _StrIns(Src,Dest: Pointer; DestLen,Index: Longint); assembler; {&USES eax} {&FRAME+}
  2298. var
  2299.   Buffer1,Buffer2: ShortString;
  2300. asm
  2301.                 cmp     Index,1         // If Index < 1 then Index := 1
  2302.                 jge     @@1
  2303.                 mov     Index,1
  2304.               @@1:
  2305.                 lea     eax,Buffer1
  2306.                 push    eax             // Dest
  2307.                 push    Dest            // Src
  2308.                 push    1               // Index
  2309.                 mov     eax,Index
  2310.                 dec     eax
  2311.                 push    eax             // Count
  2312.                 Call    _StrCopy        // Buffer1 := Copy(Dest,1,Index-1)
  2313.                 push    Src             // Dest is already on stack
  2314.                 Call    _StrConcat      // + Src
  2315.                 lea     eax,Buffer2
  2316.                 push    eax             // Dest
  2317.                 push    Dest            // Src
  2318.                 push    Index           // Index
  2319.                 push    255             // Count
  2320.                 Call    _StrCopy        // Buffer2 := Copy(Dest,Index,255)
  2321.                 Call    _StrConcat      // Buffer1 :=  Buffer1 + Buffer2
  2322.                 push    Dest            // Dest
  2323.                 push    DestLen         // MaxLen
  2324.                 Call    _StrStore
  2325. end;
  2326.  
  2327. // Delete standard procedure
  2328. // procedure Delete(var S: String; Index: Integer; Count: Integer);
  2329. // Delete(S,Index,Count) = Copy(S,1,Index-1) + Copy(S,Index+Count,255)
  2330.  
  2331. procedure _StrDel(S: Pointer; Index,Count: Longint); assembler; {&USES eax} {&FRAME+}
  2332. var
  2333.   Buffer1,Buffer2: ShortString;
  2334. asm
  2335.                 cmp     Count,0
  2336.                 jle     @@RET
  2337.                 cmp     Index,0
  2338.                 jle     @@RET           // Do nothing if Index <- 0
  2339.                 lea     eax,Buffer1
  2340.                 push    eax             // Dest
  2341.                 push    S               // Src
  2342.                 push    1               // Index
  2343.                 mov     eax,Index
  2344.                 dec     eax
  2345.                 push    eax             // Count
  2346.                 Call    _StrCopy        // Buffer1 := Copy(S,1,Index-1)
  2347.                 lea     eax,Buffer2
  2348.                 push    eax             // Dest
  2349.                 push    S
  2350.                 mov     eax,Index
  2351.                 add     eax,Count
  2352.                 push    eax
  2353.                 push    255
  2354.                 Call    _StrCopy        // Buffer1 := Copy(S,Index+Count,255)
  2355.                 Call    _StrConcat      // Buffer1 := Buffer1 + Buffer2
  2356.                 push    S               // Dest
  2357.                 push    255             // MaxLen
  2358.                 Call    _StrStore
  2359.               @@RET:
  2360. end;
  2361.  
  2362. // 'SetString' standard procedure
  2363.  
  2364. procedure _StrSet(S: Pointer; Buffer: PChar; Len: Longint); {&USES eax,ecx} {&FRAME-}
  2365. asm
  2366.                 movzx   ecx,Len.Byte
  2367.                 mov     eax,S
  2368.                 mov     [eax],cl
  2369.                 cmp     Buffer,0
  2370.                 jz      @@RET
  2371.                 inc     eax
  2372.                 push    Buffer          // [1]: Source
  2373.                 push    eax             // [2]: Dest
  2374.                 push    ecx             // [3]: Length
  2375.                 Call    _VarMove
  2376.               @@RET:
  2377. end;
  2378.  
  2379. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ Long string support ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  2380.  
  2381. type
  2382.   TStrRec = record
  2383.     RefCnt:    Longint;         // String reference count
  2384.     Length:    Longint;         // Current dynamic string size
  2385.   end;
  2386.  
  2387. const
  2388.   SHS = SizeOf(TStrRec);        // String header size
  2389.  
  2390. // Cleans up the long string variable. If the reference count is zero, the
  2391. // dynamic variable is freed
  2392.  
  2393. procedure _LStrClr(LStr: Pointer); {&USES eax,ecx} {&FRAME-}
  2394. asm
  2395.                 mov     eax,LStr
  2396.                 mov     ecx,[eax]                       // eax = @LStr
  2397.                 jecxz   @@RET                           // Already cleared
  2398.                 and     [eax].Longint,0
  2399.                 mov     eax,[ecx-SHS].TStrRec.RefCnt
  2400.                 dec     eax                             // < 0: literal string
  2401.                 js      @@RET
  2402.                 mov     [ecx-SHS].TStrRec.RefCnt,eax
  2403.                 jne     @@RET
  2404.                 sub     ecx,SHS                         // Free
  2405.                 push    ecx
  2406.                 Call    _MemFree
  2407.               @@RET:
  2408. end;
  2409.  
  2410. // Creates a new long string. Returns a pointer to the allocated buffer.
  2411.  
  2412. procedure _LStrNew(Len: Longint); {&USES edx} {&Frame-}
  2413. asm
  2414.                 xor     eax,eax
  2415.                 mov     edx,Len
  2416.                 test    edx,edx
  2417.                 jle     @@RET
  2418.                 lea     eax,[edx+SHS+1]
  2419.                 push    eax                     // [1]:Longint = Size
  2420.                 Call    _MemNew
  2421.                 mov     [eax].TStrRec.Length,edx
  2422.                 mov     [eax].TStrRec.RefCnt,1
  2423.                 add     eax,SHS
  2424.                 mov     [eax+edx].Byte,0
  2425.               @@RET:
  2426. end;
  2427.  
  2428. // Converts a packed string to the long string.
  2429.  
  2430. procedure _LStrPacked(Dest,Src: Pointer; Len: Longint); {&USES eax,ecx,edx} {&FRAME-}
  2431. asm
  2432.                 mov     ecx,Dest
  2433.                 mov     edx,Len
  2434.                 push    ecx                     // Free previous Dest value
  2435.                 Call    _LStrClr
  2436.                 push    edx                     // [1]:Longint = Length
  2437.                 Call    _LStrNew
  2438.                 mov     [ecx],eax
  2439.                 mov     ecx,Src
  2440.                 jecxz   @@RET
  2441.                 push    ecx                     // [1]:Pointer = Src
  2442.                 push    eax                     // [2]:Pointer = Dest
  2443.                 push    edx                     // [3]:Longint = Count
  2444.                 Call    _MemMove
  2445.               @@RET:
  2446. end;
  2447.  
  2448. // Converts a character to the long string
  2449.  
  2450. procedure _LStrChar(LStr: Pointer; C: Char); {&USES eax} {&FRAME-}
  2451. asm
  2452.                 lea     eax,C
  2453.                 push    LStr                    // [1]:Pointer = Dest
  2454.                 push    eax                     // [2]:Pointer = Src
  2455.                 push    1                       // [3]:Longint = Length
  2456.                 Call    _LStrPacked
  2457.                 PopArgs @Params - TYPE LStr
  2458. end;
  2459.  
  2460. // Converts a short string to the long string
  2461.  
  2462. procedure _LStrStr(var LStr: Pointer; SStr: Pointer); {&USES eax,ecx} {&FRAME-}
  2463. asm
  2464.                 mov     eax,SStr
  2465.                 movzx   ecx,[eax].Byte
  2466.                 inc     eax
  2467.                 push    LStr                    // [1]:Pointer = Dest
  2468.                 push    eax                     // [2]:Pointer = Src
  2469.                 push    ecx                     // [3]:Longint = Len
  2470.                 Call    _LStrPacked
  2471.                 PopArgs @Params - TYPE LStr
  2472. end;
  2473.  
  2474. // Converts a null-terminated string to the long string
  2475.  
  2476. procedure _LStrPChar(LStr: Pointer; Str: PChar); {&USES eax,ecx,edi} {&FRAME-}
  2477. asm
  2478.                 xor     eax,eax
  2479.                 mov     edi,Str
  2480.                 test    edi,edi
  2481.                 jz      @@1
  2482.                 Call    PCharLength
  2483.               @@1:
  2484.                 push    LStr                    // [1]:Pointer = Dest
  2485.                 push    edi                     // [2]:Pointer = Src
  2486.                 push    eax                     // [3]:Longint = Length
  2487.                 Call    _LStrPacked
  2488.                 PopArgs @Params - TYPE LStr
  2489. end;
  2490.  
  2491. procedure _LStrArray(Dest,Src: Pointer; Size: Longint); {&USES eax,ecx,edi} {&FRAME-}
  2492. asm
  2493.                 mov     edi,Src
  2494.                 mov     ecx,Size
  2495.                 push    Dest                    // [1]:Pointer = Dest
  2496.                 push    edi                     // [2]:Pointer = Src
  2497.                 push    ecx
  2498.                 xor     eax,eax
  2499.                 cld
  2500.                 repne   scasb
  2501.                 jne     @@1
  2502.                 not     ecx
  2503.               @@1:
  2504.                 pop     eax
  2505.                 add     ecx,eax
  2506.                 push    ecx                     // [3]:Longint = Length
  2507.                 Call    _LStrPacked
  2508.                 PopArgs @Params - TYPE Dest
  2509. end;
  2510.  
  2511. // Sets a new length of the long string
  2512.  
  2513. procedure _LStrSetLen(var LStr: Pointer; Len: Longint); {&USES eax,ebx,ecx,edx} {&FRAME-}
  2514. asm
  2515.                 mov     ecx,Len
  2516.                 mov     ebx,LStr
  2517.                 xor     eax,eax
  2518.                 jecxz   @@3
  2519.                 mov     eax,[ebx]
  2520.                 test    eax,eax
  2521.                 jz      @@1
  2522.                 cmp     [eax-SHS].TStrRec.RefCnt,1
  2523.                 jne     @@1
  2524.                 sub     eax,SHS
  2525.                 lea     edx,[ecx+SHS+1]         // +1 for null terminate
  2526.                 push    eax
  2527.                 push    esp                     // [1]:Pointer = @Ptr
  2528.                 push    edx                     // [2]:Longint = Counter
  2529.                 Call    _MemRealloc
  2530.                 pop     eax                     // New reallocated pointer
  2531.                 add     eax,SHS
  2532.                 mov     [ebx],eax
  2533.                 mov     [eax-SHS].TStrRec.Length,ecx
  2534.                 mov     [eax+ecx].Byte,0
  2535.                 jmp     @@RET
  2536.               @@1:
  2537.                 push    ecx                     // [1]:Longint = Length
  2538.                 Call    _LStrNew
  2539.                 mov     edx,[ebx]
  2540.                 test    edx,edx
  2541.                 jz      @@3
  2542.                 push    edx                     // [1]:Pointer = Src
  2543.                 push    eax                     // [2]:Pointer = Dest
  2544.                 mov     edx,[edx-SHS].TStrRec.Length
  2545.                 cmp     edx,ecx
  2546.                 jl      @@2
  2547.                 mov     edx,ecx
  2548.               @@2:
  2549.                 push    edx                     // [3]:Longint = Count
  2550.                 Call    _MemMove
  2551.               @@3:                              // Free old string contents
  2552.                 push    ebx                     // [1]:Pointer = Old string
  2553.                 Call    _LStrClr
  2554.                 mov     [ebx],eax
  2555.               @@RET:
  2556. end;
  2557.  
  2558. // Converts a long string to the short string
  2559.  
  2560. procedure _LStr2Str(SStr,LStr: Pointer; MaxLen: Longint); {&USES eax,ecx,edx} {&FRAME-}
  2561. asm
  2562.                 mov     ecx,LStr
  2563.                 mov     eax,SStr
  2564.                 jecxz   @@RET
  2565.                 mov     edx,ecx
  2566.                 mov     ecx,[edx-SHS].TStrRec.Length
  2567.                 jecxz   @@RET
  2568.                 cmp     ecx,MaxLen
  2569.                 jl      @@1
  2570.                 mov     ecx,MaxLen
  2571.               @@1:
  2572.                 inc     eax
  2573.                 push    edx                     // [1]:Pointer = Src
  2574.                 push    eax                     // [2]:Pointer = Dest
  2575.                 push    ecx                     // [3]:Longint = Length
  2576.                 Call    _MemMove
  2577.                 dec     eax
  2578.               @@RET:
  2579.                 mov     [eax],cl
  2580.                 PopArgs @Params - TYPE SStr
  2581. end;
  2582.  
  2583. // Creates a long string containing Count characters Ch.
  2584. // function StringOfChar(Ch: Char; Count: Longint): String;
  2585.  
  2586. procedure _LStrOfChar(LStr: Pointer; C: Char; Count: Longint); {&USES eax,ecx,edx} {&FRAME-}
  2587. asm
  2588.                 mov     edx,Count
  2589.                 mov     ecx,LStr
  2590.                 push    ecx
  2591.                 Call    _LStrClr
  2592.                 test    edx,edx
  2593.                 jle     @@RET
  2594.                 push    edx
  2595.                 Call    _LStrNew
  2596.                 mov     [ecx],eax
  2597.                 push    eax                     // [1]:Pointer = Dest
  2598.                 push    edx                     // [2]:Longint = Count
  2599.                 push    C[8].Longint            // [3]:Longint = Char
  2600.                 Call    _MemFill
  2601.               @@RET:
  2602.                 PopArgs @Params - TYPE LStr
  2603. end;
  2604.  
  2605. // Reads a long string from the text file
  2606. // ! Does not pop out the file variable address
  2607.  
  2608. procedure _TxtRLStr(FileVar,LStr: Pointer); assembler; {&USES eax,ecx} {&FRAME+}
  2609. var
  2610.   TempLStr: Pointer;
  2611.   SStr: ShortString;
  2612. asm
  2613.                 mov     ecx,LStr
  2614.                 push    ecx
  2615.                 Call    _LStrClr                // Free dest string
  2616.                 lea     eax,SStr
  2617.                 push    FileVar                 // [1]:Pointer = File
  2618.                 push    eax                     // [2]:Pointer = String
  2619.                 push    255                     // [3]:Longint = MaxLen
  2620.                 Call    _TxtRStr
  2621.                 pop     eax                     // Pop file@
  2622.                 lea     eax,SStr
  2623.                 push    ecx                     // [1]:Pointer = LStr
  2624.                 push    eax                     // [2]:Pointer = SStr
  2625.                 Call    _LStrStr
  2626.                 pop     eax                     // Pop out String@
  2627.                 cmp     SStr.Byte,255
  2628.                 jne     @@RET
  2629.               @@1:
  2630.                 lea     eax,SStr
  2631.                 push    FileVar                 // [1]:Pointer = FileVar
  2632.                 push    eax                     // [2]:Pointer = String
  2633.                 push    255                     // [3]:Longint = MaxLen
  2634.                 Call    _TxtRStr
  2635.                 pop     eax                     // Pop file@
  2636.                 lea     eax,TempLStr
  2637.                 and     [eax].Longint,0
  2638.                 push    eax                     // [1]:Pointer = LStr
  2639.                 lea     eax,SStr
  2640.                 push    eax                     // [2]:Pointer = SStr
  2641.                 Call    _LStrStr
  2642.                 pop     eax                     // Pop out String@
  2643.                 push    ecx                     // [1]:Pointer = Dest LStr
  2644.                 push    TempLStr                // [2]:Pointer = Src LStr
  2645.                 Call    _LStrConcat             // Pop out Dest@
  2646.                 pop     ecx                     // Clear the Src string
  2647.                 push    eax                     // [1]:Pointer = LStr
  2648.                 Call    _LStrClr
  2649.                 cmp     SStr.Byte,255
  2650.                 je      @@1
  2651.               @@RET:
  2652.                 PopArgs @Params - TYPE FileVar
  2653. end;
  2654.  
  2655. // Assignement operator for long strings
  2656.  
  2657. procedure _LStrAsn(var Dest: Pointer; Src: Pointer); {&USES eax,ecx,edx} {&FRAME-}
  2658. asm
  2659.                 mov     ecx,Src
  2660.                 mov     eax,Dest
  2661.                 jecxz   @@1
  2662.                 mov     edx,[ecx-SHS].TStrRec.RefCnt
  2663.                 inc     edx
  2664.                 jle     @@1
  2665.                 mov     [ecx-SHS].TStrRec.RefCnt,edx
  2666.               @@1:
  2667.                 xchg    ecx,[eax]               // Do assign
  2668.                 jecxz   @@RET                   // Free the old contents of Dest
  2669.                 mov     edx,[ecx-SHS].TStrRec.RefCnt
  2670.                 dec     edx
  2671.                 jl      @@RET
  2672.                 mov     [ecx-SHS].TStrRec.RefCnt,edx
  2673.                 jne     @@RET
  2674.                 sub     ecx,SHS
  2675.                 push    ecx
  2676.                 Call    _MemFree
  2677.               @@RET:
  2678. end;
  2679.  
  2680. procedure _LStrLoad(var Dest: Pointer; Src: Pointer); {&USES None} {&FRAME-}
  2681. asm
  2682.                 push    Dest
  2683.                 push    Src[4]
  2684.                 Call    _LStrAsn
  2685.                 PopArgs @Params - TYPE Dest
  2686. end;
  2687.  
  2688. procedure _LStrAsg(Dest,Src: Pointer); {&USES eax,ecx,edx} {&FRAME-}
  2689. asm
  2690.                 mov     edx,Src
  2691.                 mov     eax,Dest
  2692.                 test    edx,edx
  2693.                 jz      @@2
  2694.                 mov     ecx,[edx-SHS].TStrRec.RefCnt
  2695.                 inc     ecx
  2696.                 jg      @@1
  2697.                 push    eax
  2698.                 push    [edx-SHS].TStrRec.Length        // Copy a literal string
  2699.                 Call    _LStrNew
  2700.                 push    edx                             // [1]:Pointer = Src
  2701.                 push    eax                             // [2]:Pointer = Dest
  2702.                 push    [edx-SHS].TStrRec.Length        // [3]:Longint = Size
  2703.                 Call    _MemMove
  2704.                 mov     edx,eax
  2705.                 pop     eax
  2706.                 jmp     @@2
  2707.               @@1:
  2708.                 mov     [edx-SHS].TStrRec.RefCnt,ecx
  2709.               @@2:
  2710.                 xchg    edx,[eax]
  2711.                 test    edx,edx
  2712.                 jz      @@3
  2713.                 mov     ecx,[edx-SHS].TStrRec.RefCnt
  2714.                 dec     ecx
  2715.                 jl      @@3
  2716.                 mov     [edx-SHS].TStrRec.RefCnt,ecx
  2717.                 jne     @@3
  2718.                 sub     edx,SHS
  2719.                 push    edx                             // [1]:Pointer = Free memory
  2720.                 Call    _MemFree
  2721.               @@3:
  2722. end;
  2723.  
  2724. // Concatenates two long strings
  2725.  
  2726. procedure _LStrConcat(var Dest: Pointer; Src: Pointer); {&USES ALL} {&FRAME-}
  2727. asm
  2728.                 mov     esi,Src
  2729.                 mov     ebx,Dest
  2730.                 test    esi,esi
  2731.                 jz      @@RET
  2732.                 mov     ecx,[ebx]
  2733.                 jecxz   @@2
  2734.                 mov     edi,[ecx-SHS].TStrRec.Length
  2735.                 mov     edx,[esi-SHS].TStrRec.Length
  2736.                 add     edx,edi
  2737.                 push    ebx                     // [1]:Pointer = Dest
  2738.                 push    edx                     // [2]:Pointer = New length
  2739.                 Call    _LStrSetLen
  2740.                 cmp     esi,ecx
  2741.                 je      @@0
  2742.                 mov     eax,esi
  2743.                 mov     ecx,[esi-SHS].TStrRec.Length
  2744.                 jmp     @@1
  2745.               @@0:
  2746.                 mov     eax,[ebx]               // Append to itself
  2747.                 mov     ecx,edi
  2748.               @@1:
  2749.                 mov     edx,[ebx]               // Dest[Length(Dest)]
  2750.                 add     edx,edi
  2751.                 push    eax                     // [1]:Pointer = Src
  2752.                 push    edx                     // [2]:Pointer = Dest
  2753.                 push    ecx                     // [3]:Longint = Size
  2754.                 Call    _MemMove
  2755.                 jmp     @@RET
  2756.               @@2:                              // Assign: Dest := Src (Dest = nil)
  2757.                 push    ebx                     // [1]:Pointer = Dest
  2758.                 push    esi                     // [2]:Pointer = Src
  2759.                 Call    _LStrAsg
  2760.               @@RET:
  2761.                 PopArgs @Params - TYPE Dest
  2762. end;
  2763.  
  2764. // Compares two long strings. Returns the result in the CPU flags.
  2765.  
  2766. procedure _LStrCmp(LStr1,LStr2: Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  2767. asm
  2768.                 mov     esi,LStr1
  2769.                 mov     edi,LStr2
  2770.                 cmp     esi,edi
  2771.                 je      @@RET
  2772.                 test    esi,esi
  2773.                 jz      @@2
  2774.                 test    edi,edi
  2775.                 jz      @@3
  2776.                 mov     eax,[esi-SHS].TStrRec.Length
  2777.                 mov     ecx,[edi-SHS].TStrRec.Length
  2778.                 sub     eax,ecx         // ecx = Len1
  2779.                 ja      @@1
  2780.                 add     ecx,eax         // ecx = Len2 + (Len1 - Len2) = Len1
  2781.               @@1:                      // ecx := Min(Len1, Len2)
  2782.                 cld
  2783.                 repe    cmpsb           // Compare string
  2784.                 jne     @@RET           // if equal, compare lengths
  2785.                 add     eax,eax         // if eax < 0 then CF:=1 (JB=JC),
  2786.                 jmp     @@RET           // if eax > 0 then CF := 0, eax = 0 ZF=1
  2787.               @@2:
  2788.                 cmp     esi,[edi-SHS].TStrRec.Length
  2789.                 jmp     @@RET
  2790.               @@3:
  2791.                 cmp     [esi-SHS].TStrRec.Length,edi
  2792.               @@RET:
  2793. end;
  2794.  
  2795. // Increments the usage count of the long string
  2796.  
  2797. procedure _LStrAddRef(LStr: Pointer); {&USES eax,ecx} {&FRAME-}
  2798. asm
  2799.                 mov     ecx,LStr
  2800.                 jecxz   @@RET
  2801.                 mov     eax,[ecx-SHS].TStrRec.RefCnt
  2802.                 inc     eax
  2803.                 jle     @@RET
  2804.                 mov     [ecx-SHS].TStrRec.RefCnt,eax
  2805.               @@RET:
  2806. end;
  2807.  
  2808. // Type cast routine from long string to PChar
  2809.  
  2810. procedure _LStrToPChar(LStr: Pointer); {&USES None} {&FRAME-}
  2811. asm
  2812.                 mov     eax,LStr
  2813.                 test    eax,eax
  2814.                 jz      @@1
  2815.                 ret     @Params
  2816.               @@Zero:
  2817.                 db      0
  2818.               @@1:
  2819.                 mov     eax,OFFSET @@Zero
  2820.               @@RET:
  2821. end;
  2822.  
  2823. // Creates a unique copy of a long string
  2824.  
  2825. procedure UniqueString(var LStr: String); {&USES ecx,edx} {&FRAME-}
  2826. asm
  2827.                 mov     edx,LStr
  2828.                 mov     ecx,[edx]
  2829.                 jecxz   @@RET
  2830.                 mov     eax,[ecx-SHS].TStrRec.RefCnt
  2831.                 dec     eax
  2832.                 jz      @@RET                           // Already unique
  2833.                 jl      @@1                             // Literal: Skip
  2834.                 mov     [ecx-SHS].TStrRec.RefCnt,eax
  2835.               @@1:
  2836.                 push    [ecx-SHS].TStrRec.Length        // [1]:Longint = Length
  2837.                 Call    _LStrNew
  2838.                 mov     [edx],eax
  2839.                 push    ecx                             // [1]:Pointer = Src
  2840.                 push    eax                             // [2]:Pointer = Dest
  2841.                 push    [ecx-SHS].TStrRec.Length        // [3]:Longint = Size
  2842.                 Call    _MemMove
  2843.               @@RET:
  2844.                 mov     eax,[edx]
  2845. end;
  2846.  
  2847. // function Copy(S: AnsiString; Index,Count: Longint): AnsiString;
  2848.  
  2849. procedure _LStrCopy(var Dest: Pointer; Src: Pointer; Index,Count: Longint); {&USES eax,ebx,ecx,edx} {&FRAME-}
  2850. asm
  2851.                 mov     eax,Src
  2852.                 mov     edx,Index
  2853.                 mov     ecx,Count
  2854.                 test    eax,eax
  2855.                 jz      @@Empty
  2856.                 mov     ebx,[eax-SHS].TStrRec.Length
  2857.                 test    ebx,ebx
  2858.                 jz      @@Empty
  2859.                 dec     edx                     // edx = 0-based index
  2860.                 jge     @@1                     // Make sure it is within the
  2861.                 xor     edx,edx                 // range: 0..Length(Src)-1
  2862.               @@1:
  2863.                 cmp     edx,ebx
  2864.                 jge     @@Empty
  2865.                 sub     ebx,edx                 // Length(Src) - Index
  2866.                 test    ecx,ecx                 // Make sure count is within the
  2867.                 jl      @@Empty                 // range: 0..Length(Src)-Index
  2868.                 cmp     ecx,ebx
  2869.                 jl      @@2
  2870.                 mov     ecx,ebx
  2871.               @@2:
  2872.                 add     eax,edx
  2873.                 push    Dest                    // [1]:Pointer = Dest
  2874.                 push    eax                     // [2]:Pointer = Src
  2875.                 push    ecx                     // [3]:Longint = Length
  2876.                 Call    _LStrPacked
  2877.                 jmp     @@RET
  2878.               @@Empty:
  2879.                 push    Dest
  2880.                 Call    _LStrClr
  2881.               @@RET:
  2882.                 PopArgs @Params - Type Dest
  2883. end;
  2884.  
  2885. // procedure Delete(var LStr: AnsiString; Index,Count: Longint);
  2886.  
  2887. procedure _LStrDel(LStr: Pointer; Index,Count: Longint); {&USES ALL} {&FRAME-}
  2888. asm
  2889.                 mov     ebx,LStr
  2890.                 mov     esi,Index
  2891.                 or      esi,esi
  2892.                 je      @@RET                   // Do nothing if index = 0
  2893.                 mov     edi,Count
  2894.                 push    ebx                     // [1]:Pointer = LStr
  2895.                 Call    UniqueString
  2896.                 mov     edx,[ebx]               // Source is already empty
  2897.                 test    edx,edx
  2898.                 jz      @@RET
  2899.                 mov     ecx,[edx-SHS].TStrRec.Length
  2900.                 dec     esi                     // Make 0-based index
  2901.                 jl      @@RET                   // Make sure index is within the
  2902.                 cmp     esi,ecx                 // range: 0..Length(LStr)-1
  2903.                 jge     @@RET
  2904.                 test    edi,edi                 // Make sure Index is within the
  2905.                 jle     @@RET                   // range: 0..Length(LStr)-Index
  2906.                 sub     ecx,esi
  2907.                 cmp     edi,ecx
  2908.                 jle     @@1
  2909.                 mov     edi,ecx
  2910.               @@1:
  2911.                 sub     ecx,edi                 // Length(LStr)-Index-Count
  2912.                 add     edx,esi                 // LStr[Index]
  2913.                 lea     eax,[edx+edi]           // LStr[Index+Count]
  2914.                 push    eax                     // [1]:Pointer = Src
  2915.                 push    edx                     // [2]:Pointer = Dest
  2916.                 push    ecx                     // [3]:Longint = Count
  2917.                 Call    _MemMove
  2918.                 mov     eax,[ebx]
  2919.                 mov     eax,[eax-SHS].TStrRec.Length
  2920.                 sub     eax,edi
  2921.                 push    ebx                     // [1]:Pointer = LStr
  2922.                 push    eax                     // [2]:Longint = NewLength
  2923.                 Call    _LStrSetLen
  2924.               @@RET:
  2925. end;
  2926.  
  2927. // procedure Insert(Src: String; var S: String; Index: Integer);
  2928.  
  2929. procedure _LStrIns(Src: Pointer; var Dest: Pointer; Index: Longint); {&USES ALL} {&FRAME-}
  2930. asm
  2931.                 mov     ebx,Src
  2932.                 mov     esi,Dest
  2933.                 mov     edi,Index
  2934.                 test    ebx,ebx
  2935.                 jz      @@RET
  2936.                 mov     edx,[esi]
  2937.                 push    edx
  2938.                 test    edx,edx
  2939.                 jz      @@1
  2940.                 mov     edx,[edx-SHS].TStrRec.Length
  2941.               @@1:
  2942.                 dec     edi                     // Make index 0-based
  2943.                 jge     @@2                     // Make sure index is within the
  2944.                 xor     edi,edi                 // range: 0..Length(S)
  2945.               @@2:
  2946.                 cmp     edi,edx
  2947.                 jle     @@3
  2948.                 mov     edi,edx
  2949.               @@3:
  2950.                 mov     ecx,[ebx-SHS].TStrRec.Length
  2951.                 add     edx,ecx
  2952.                 push    esi                     // [1]:Pointer = LStr
  2953.                 push    edx                     // [2]:Longint = New length
  2954.                 Call    _LStrSetLen
  2955.                 pop     eax
  2956.                 cmp     eax,ebx
  2957.                 jne     @@4
  2958.                 mov     ebx,[esi]               // Insert Self
  2959.               @@4:
  2960. // Move(Dest[Index], Dest[Index+Length(Src)], Length(Dest)-Length(Src)-Index);
  2961.                 mov     eax,[esi]
  2962.                 lea     edx,[eax+edi]
  2963.                 push    edx             // [1]:Pointer = Src : Dest[Index]
  2964.                 add     edx,ecx
  2965.                 push    edx             // [2]:Pointer = Dest: Dest[Index+Length(Src)]
  2966.                 mov     edx,[eax-SHS].TStrRec.Length
  2967.                 sub     edx,ecx
  2968.                 sub     edx,edi
  2969.                 push    edx             // [3]:Longint = Size: Length(Dest)-Length(Src)-Index
  2970.                 Call    _MemMove
  2971.                 mov     eax,[esi]
  2972.                 add     eax,edi
  2973.                 push    ebx             // [1]:Pointer = Src : Src
  2974.                 push    eax             // [2]:Pointer = Dest: Dest[Index]
  2975.                 push    ecx             // [3]:Longint = Size: Length(Src)
  2976.                 Call    _MemMove
  2977.               @@RET:
  2978. end;
  2979.  
  2980. // function Pos(SubStr,S: AnsiString): Byte;
  2981.  
  2982. procedure _LStrPos(SubStr,LStr: Pointer); {&USES ecx,edx,esi,edi} {&FRAME-}
  2983. asm
  2984.                 mov     esi,SubStr
  2985.                 mov     edi,LStr
  2986.                 test    esi,esi
  2987.                 jz      @@Zero
  2988.                 test    edi,edi
  2989.                 jz      @@Zero
  2990.                 mov     ecx,[edi-SHS].TStrRec.Length
  2991.                 mov     edx,[esi-SHS].TStrRec.Length
  2992.                 dec     edx
  2993.                 js      @@Zero
  2994.                 cld
  2995.                 lodsb
  2996.                 sub     ecx,edx
  2997.                 jle     @@Zero
  2998.               @@1:
  2999.                 repne   scasb
  3000.                 jne     @@Zero
  3001.                 push    ecx
  3002.                 push    esi
  3003.                 push    edi
  3004.                 mov     ecx,edx
  3005.                 repe    cmpsb
  3006.                 pop     edi
  3007.                 pop     esi
  3008.                 pop     ecx
  3009.                 jne     @@1
  3010.                 mov     eax,edi
  3011.                 sub     eax,LStr
  3012.                 jmp     @@RET
  3013.               @@Zero:
  3014.                 xor     eax,eax
  3015.               @@RET:
  3016. end;
  3017.  
  3018. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ CHAR HANDLING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3019.  
  3020. // UpCase standard function
  3021.  
  3022. procedure _UpCase(Char: Byte); {&USES None} {&FRAME-}
  3023. asm
  3024.                 mov     al,Char
  3025.                 cmp     al,'a'
  3026.                 jb      @@RET
  3027.                 cmp     al,'z'
  3028.                 ja      @@RET
  3029.                 sub     al,'a'-'A'
  3030.               @@RET:
  3031. end;
  3032.  
  3033. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ SET HANDLING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3034.  
  3035. // Loads packed set
  3036. // Important!:  Doesn't pop destination pointer
  3037.  
  3038. procedure _SetLoad(Dest,Src: Pointer; SetData: Longint); {&USES eax,ebx,ecx,esi,edi} {&FRAME-}
  3039. asm
  3040.                 cld
  3041.                 mov     esi,Src
  3042.                 mov     edi,Dest
  3043.                 mov     ebx,SetData
  3044.                 movzx   ecx,bh          // High Byte = Set Offset
  3045.                 xor     eax,eax         // Zero fill to the set start
  3046.                 shr     ecx,2
  3047.                 rep     stosd           // FAST STOS
  3048.                 mov     cl,bh
  3049.                 and     cl,11b
  3050.                 rep     stosb
  3051.                 mov     cl,bl           // Low Byte = Set Size
  3052.                 shr     ecx,2           // Copy Set value itself
  3053.                 rep     movsd
  3054.                 mov     cl,bl           // FAST MOVS
  3055.                 and     cl,11b
  3056.                 rep     movsb
  3057.                 mov     cl,32           // Zero fill to the end of
  3058.                 sub     cl,bl           // set variable
  3059.                 sub     cl,bh
  3060.                 mov     bl,cl           // FAST STOS
  3061.                 shr     ecx,2
  3062.                 rep     stosd
  3063.                 mov     cl,bl
  3064.                 and     cl,11b
  3065.                 rep     stosb
  3066.                 PopArgs @Params - Type Dest
  3067. end;
  3068.  
  3069. // Loads dword sized set
  3070. // Important!:  Doesn't pop destination pointer
  3071.  
  3072. procedure _SetDWordLoad(Dest: Pointer; Value: Longint); {&USES eax,ecx,edi} {&FRAME-}
  3073. asm
  3074.                 cld
  3075.                 mov     edi,Dest
  3076.                 mov     eax,Value
  3077.                 stosd
  3078.                 mov     ecx,(32-4)/4
  3079.                 xor     eax,eax
  3080.                 rep     stosd
  3081.                 PopArgs @Params - Type Dest
  3082. end;
  3083.  
  3084. // Adds specified range to the set
  3085. // Important!:  Doesn't pop destination pointer
  3086.  
  3087. procedure _SetAddRange(Dest: Pointer; Lower,Upper: Byte); {&USES eax,ebx,ecx,edx,edi} {&FRAME-}
  3088. asm
  3089.                 mov     edi,Dest
  3090.                 xor     ecx,ecx
  3091.                 xor     edx,edx
  3092.                 mov     cl,Lower
  3093.                 mov     dl,Upper
  3094.                 sub     edx,ecx         // Upper bound < Lower bound, do nothing
  3095.                 jb      @@RET
  3096.                 mov     eax,ecx
  3097.                 shr     eax,3
  3098.                 add     edi,eax         // edi = first byte of the range to set
  3099.                 inc     edx             // edx = # of bits to set to 1's
  3100. //         │0 1 2 3 4 5 6 7│
  3101. //     ────┴─┴─┴─┴─┴─┴─┴─┴─┴────....
  3102. //[1]:         ├─────┤
  3103. //[2]:       ├───────────────....───┤
  3104. //
  3105. //■ Handle first byte
  3106.                 mov     eax,ecx
  3107.                 and     eax,00000111b   // eax: Bit Position in byte (0..7)
  3108.                 mov     ebx,edx
  3109.                 lea     ecx,[eax+edx]   // Bit Pos + Length < 8 ?
  3110.                 cmp     ecx,8
  3111.                 jbe     @@1             // Case [1]
  3112.                 mov     ebx,8           // Case [2]
  3113.                 sub     ebx,eax
  3114.               @@1:                      // ebx: Bit length           (1..8)
  3115.                 mov     al,Byte Ptr @@AddRangeTable[eax*8+ebx-1]
  3116.                 or      [edi],al
  3117.                 inc     edi
  3118. // ■ Handle full bytes
  3119.                 sub     edx,ebx         // # of bit remains
  3120.                 jz      @@RET
  3121.                 mov     ebx,edx
  3122.                 shr     ebx,3           // Number of bytes
  3123.                 mov     ecx,ebx
  3124.                 shr     ecx,2           // # of full DWords
  3125.                 or      eax,-1          // eax := all 1's
  3126.                 cld
  3127.                 rep     stosd
  3128.                 mov     cl,bl
  3129.                 and     cl,11b          // # of full bytes
  3130.                 rep     stosb
  3131. // ■ Handle last byte
  3132.                 and     edx,00000111b   // # of bit remains = Length (1..7)
  3133.                 jz      @@RET           // Position in byte = 0
  3134.                 mov     al,Byte Ptr @@AddRangeTable[edx-1]
  3135.                 or      [edi],al
  3136.                 jmp     @@RET
  3137.  
  3138. // TYPE  BitLength = 1..8;
  3139. //       BitPos    = 0..7;
  3140. // AddRangeTable : ARRAY [BitPos, BitLength] OF BYTE; 64 elements
  3141. //  Length:                  1         2          3          4          5          6          7          8    Position
  3142. @@AddRangeTable:
  3143.                 db      00000001b, 00000011b, 00000111b, 00001111b, 00011111b, 00111111b, 01111111b, 11111111b // 0
  3144.                 db      00000010b, 00000110b, 00001110b, 00011110b, 00111110b, 01111110b, 11111110b, 11111110b // 1
  3145.                 db      00000100b, 00001100b, 00011100b, 00111100b, 01111100b, 11111100b, 11111100b, 11111100b // 2
  3146.                 db      00001000b, 00011000b, 00111000b, 01111000b, 11111000b, 11111000b, 11111000b, 11111000b // 3
  3147.                 db      00010000b, 00110000b, 01110000b, 11110000b, 11110000b, 11110000b, 11110000b, 11110000b // 4
  3148.                 db      00100000b, 01100000b, 11100000b, 11100000b, 11100000b, 11100000b, 11100000b, 11100000b // 5
  3149.                 db      01000000b, 11000000b, 11000000b, 11000000b, 11000000b, 11000000b, 11000000b, 11000000b // 6
  3150.                 db      10000000b, 10000000b, 10000000b, 10000000b, 10000000b, 10000000b, 10000000b, 10000000b // 7
  3151.  
  3152.               @@RET:
  3153.                 PopArgs @Params - Type Dest
  3154. end;
  3155.  
  3156. // Stores unpacked set
  3157.  
  3158. procedure _SetStore(Src,Dest: Pointer; SetData: Longint); {&USES eax,ecx,esi,edi} {&FRAME-}
  3159. asm
  3160.                 cld
  3161.                 xor     ecx,ecx
  3162.                 mov     esi,Src
  3163.                 mov     edi,Dest
  3164.                 mov     eax,SetData
  3165.                 mov     cl,ah           // High Byte = Set Offset
  3166.                 add     esi,ecx
  3167.                 mov     cl,al           // Low Byte = Set Size
  3168.                 shr     ecx,2
  3169.                 and     al,11b
  3170.                 rep     movsd           // FAST MOVS
  3171.                 mov     cl,al
  3172.                 rep     movsb
  3173. end;
  3174.  
  3175. // Operators on two unpacked sets
  3176. // _SetUnion     '+' operator
  3177. // _SetDif       '-' operator
  3178. // _SetInter     '*' operator
  3179. // _SetRel       ? ( '>','<' ) set operators
  3180. // _SetEqual     ? ( '=','<>') set operators
  3181. // Important!:  Doesn't pop destination pointer
  3182.  
  3183. procedure _SetUnion(Dest,Src : Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  3184. asm
  3185.                 cld
  3186.                 mov     esi,Src
  3187.                 mov     edi,Dest
  3188.                 mov     ecx,32/4
  3189.               @@1:
  3190.                 lodsd
  3191.                 or      eax,[edi]
  3192.                 stosd
  3193.                 loop    @@1
  3194.                 PopArgs @Params - Type Dest
  3195. end;
  3196.  
  3197. procedure _SetDif(Dest,Src : Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  3198. asm
  3199.                 cld
  3200.                 mov     esi,Src
  3201.                 mov     edi,Dest
  3202.                 mov     ecx,32/4
  3203.               @@1:
  3204.                 lodsd
  3205.                 not     eax
  3206.                 and     eax,[edi]
  3207.                 stosd
  3208.                 loop    @@1
  3209.                 PopArgs @Params - Type Dest
  3210. end;
  3211.  
  3212. procedure _SetInter(Dest,Src : Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  3213. asm
  3214.                 cld
  3215.                 mov     esi,Src
  3216.                 mov     edi,Dest
  3217.                 mov     ecx,32/4
  3218.               @@1:
  3219.                 lodsd
  3220.                 and     eax,[edi]
  3221.                 stosd
  3222.                 loop    @@1
  3223.                 PopArgs @Params - Type Dest
  3224. end;
  3225.  
  3226. // RETURNS:     ZF = 1 if Destination >= Source
  3227.  
  3228. procedure _SetRel(Dest,Src : Pointer); {&USES eax,ecx,esi,edi} {&FRAME-}
  3229. asm
  3230.                 cld
  3231.                 mov     esi,Src
  3232.                 mov     edi,Dest
  3233.                 mov     ecx,32/4
  3234.               @@1:
  3235.                 lodsd
  3236.                 or      eax,[edi]
  3237.                 scasd
  3238.                 jne     @@RET
  3239.                 loop    @@1
  3240.               @@RET:
  3241. end;
  3242.  
  3243. // RETURNS:     ZF = 1 if Destination = Source
  3244.  
  3245. procedure _SetEqual(Dest,Src : Pointer); {&USES ecx,esi,edi} {&FRAME-}
  3246. asm
  3247.                 cld
  3248.                 mov     esi,Src
  3249.                 mov     edi,Dest
  3250.                 mov     ecx,32/4
  3251.                 repe    cmpsd
  3252. end;
  3253.  
  3254. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ INTEGER STRING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3255.  
  3256. // Converts integer to string
  3257. // EXPECTS:     eax    = Value to convert
  3258. //              edi    = @ of the buffer to hold output string
  3259. // RETURNS:     ecx    = Output string length
  3260. //              edi    = @ of the buffer just after the string written
  3261.  
  3262. procedure Int2Str; {&USES eax,ebx,edx} {&FRAME-}
  3263. asm
  3264.                 cld
  3265.                 push    edi
  3266.                 test    eax,eax
  3267.                 jge     @@1
  3268.                 neg     eax
  3269.                 mov     [edi].Byte,'-'
  3270.                 inc     edi
  3271.               @@1:
  3272.                 mov     ebx,10
  3273.                 xor     ecx,ecx
  3274.               @@2:
  3275.                 xor     edx,edx
  3276.                 div     ebx
  3277.                 add     dl,'0'
  3278.                 push    edx
  3279.                 inc     ecx
  3280.                 test    eax,eax
  3281.                 jnz     @@2
  3282.               @@3:
  3283.                 dec     ecx
  3284.                 pop     eax
  3285.                 stosb
  3286.                 jnz     @@3
  3287.                 mov     ecx,edi
  3288.                 pop     eax
  3289.                 sub     ecx,eax
  3290. end;
  3291.  
  3292. // Converts string to integer
  3293. // EXPECTS:     ecx     = Length of the source string
  3294. //              edi     = @ of the buffer with source string
  3295. // RETURNS:     ecx     = Number of remaining characters
  3296. //              edi     = @ of the buffer just after parsed str
  3297. //              eax     = Converted value
  3298. //              CF      = 0 if success
  3299.  
  3300. procedure Str2Int; {&USES ebx,edx,esi} {&FRAME-}
  3301. asm
  3302.                 jecxz   @@Failed
  3303.                 xor     eax,eax                 // Result
  3304.                 xor     ebx,ebx                 // Current digit
  3305.                 xor     esi,esi                 // Sign: 0 = '+', 1 = '-'
  3306.                 cmp     [edi].Byte,'+'
  3307.                 je      @@Positive
  3308.                 cmp     [edi].Byte,'-'
  3309.                 jne     @@No_Sign
  3310.                 inc     esi
  3311.               @@Positive:
  3312.                 inc     edi
  3313.                 dec     ecx
  3314.                 jecxz   @@Failed
  3315.               @@No_Sign:
  3316.                 cmp     [edi].Byte,'$'          // Hexadecimal ?
  3317.                 jne     @@Decimal
  3318. // Integer is in Hexadecimal form
  3319.                 inc     edi                     // Skip '$'
  3320.                 dec     ecx
  3321.                 jecxz   @@Failed
  3322.               @@1:
  3323.                 mov     bl,[edi]
  3324.                 cmp     bl,'a'                  // Letter ?
  3325.                 jb      @@2
  3326.                 sub     bl,'a'-'A'              // Yes, Convert to upper case
  3327.               @@2:
  3328.                 sub     bl,'0'+10               // Decimal digit 0..9 ?
  3329.                 add     bl,10                   // 10 digits
  3330.                 jc      @@3                     // Yes
  3331.                 sub     bl,'A'-'9' + 15         // Is it hex letter A..F ?
  3332.                 add     bl,6                    // 6 letters
  3333.                 jnc     @@OK
  3334.                 add     bl,10
  3335.               @@3:
  3336.                 test    eax,0F0000000h          // bl = Current Hex Digit 0..15
  3337.                 jnz     @@Failed
  3338.                 shl     eax,4                   // eax * 16
  3339.                 or      al,bl                   // + Current Digit
  3340.                 inc     edi
  3341.                 loop    @@1
  3342.                 jmp     @@OK
  3343.  
  3344.               @@Failed:
  3345.                 stc
  3346.                 jmp     @@RET
  3347. // Integer is in Decimal form
  3348.               @@Decimal:
  3349.                 mov     bl,[edi]
  3350.                 sub     bl,'0'+10
  3351.                 add     bl,10
  3352.                 jnc     @@OK
  3353.                 shl     eax,1                   // FAST MUL: eax*10
  3354.                 lea     eax,[eax+eax*4]
  3355.                 add     eax,ebx                 // + Current digit
  3356.                 js      @@Failed
  3357.                 inc     edi
  3358.                 loop    @@Decimal
  3359.  
  3360.               @@OK:
  3361.                 dec     esi
  3362.                 jnz     @@Done
  3363.                 neg     eax                     // eax := - eax
  3364.               @@Done:
  3365.                 clc
  3366.               @@RET:
  3367. end;
  3368.  
  3369. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ 80X87 BINARY/DECIMAL ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3370.  
  3371. const
  3372.   CWNear: Word = (IC_Affine   shl sCW_IC) or    // Affine mode
  3373.                  (RC_Nearest  shl sCW_RC) or    // Round to nearest
  3374.                  (PC_Extended shl sCW_PC) or    // Round to extended
  3375.                                   mCW_PM  or    // Masked
  3376.                                   mCW_UM  or    // Masked
  3377.                                   mCW_OM  or    // Masked
  3378.                                   mCW_ZM  or    // Masked
  3379.                                   mCW_DM  or    // Masked
  3380.                                   mCW_IM ;      // Masked
  3381.  
  3382. const
  3383.   LongP10Table: array [0..7] of Longint =
  3384.     (1,                 // 0
  3385.      10,                // 1
  3386.      100,               // 2
  3387.      1000,              // 3
  3388.      10000,             // 4
  3389.      100000,            // 5
  3390.      1000000,           // 6
  3391.      10000000);         // 7
  3392.  
  3393. // Multiplies ST(0) by 10^EAX
  3394. // EXPECTS:     eax     = Power of 10
  3395. // RETURNS:     ST(0)   = Result
  3396.  
  3397. procedure FPower10; assembler; {&USES eax,ebx,edx} {&FRAME-}
  3398. const
  3399.   ExtendedP10Table: array [0..9] of Extended =
  3400.     (1e8,               // 0
  3401.      1e16,              // 1
  3402.      1e32,              // 2
  3403.      1e64,              // 3
  3404.      1e128,             // 4
  3405.      1e256,             // 5
  3406.      1e512,             // 6
  3407.      1e1024,            // 7
  3408.      1e2048,            // 8
  3409.      1e4096);           // 9
  3410. asm
  3411.                 cmp     eax,4096
  3412.                 jle     @@1
  3413.                 fld     ExtendedP10Table[9*TYPE Extended].Extended // 1.0e4096
  3414.                 fmul
  3415.                 sub     eax,4096
  3416.               @@1:
  3417.                 cmp     eax,-4096
  3418.                 jge     @@2
  3419.                 fld     ExtendedP10Table[9*TYPE Extended].Extended // 1.0e4096
  3420.                 fdiv
  3421.                 add     eax,4096
  3422.               @@2:
  3423.                 mov     ebx,eax
  3424.                 test    eax,eax                         // 10^0 = 1, @@Done
  3425.                 jz      @@Done
  3426.                 jns     @@3
  3427.                 neg     eax                             // Make eax positive
  3428.               @@3:
  3429.                 mov     edx,eax
  3430.                 and     edx,111b
  3431.                 fild    LongP10Table.Longint[edx*4]
  3432.                 shr     eax,3
  3433.                 mov     edx,OFFSET ExtendedP10Table // 1.0e8....
  3434.                 jmp     @@6
  3435.               @@4:
  3436.                 shr     eax,1
  3437.                 jnc     @@5
  3438.                 fld     [edx].Extended
  3439.                 fmul
  3440.               @@5:
  3441.                 add     edx,TYPE Extended
  3442.               @@6:
  3443.                 test    eax,eax
  3444.                 jne     @@4
  3445.                 test    ebx,ebx
  3446.                 jns     @@7
  3447.                 fdiv                            // Power < 0 =>ST(0)/Power10
  3448.                 jmp     @@Done
  3449.               @@7:
  3450.                 fmul                            // Power >= 0 =>ST(0)*Power10
  3451.               @@Done:
  3452. end;
  3453.  
  3454. // Converts float to string
  3455. // EXPECTS:     edi     = Offset of the buffer to hold output string
  3456. //              ST(0)   = Extended floating point value to convert
  3457. //              ecx     = Digit count (Float<0, Fixed>=0
  3458. // RETURNS:     ecx     = Output string length
  3459. //              edi     = Offset of the buffer (not changed)
  3460.  
  3461. procedure Float2Str; assembler; {&USES eax,ebx,edx,esi} {&FRAME+}
  3462. var
  3463.   Digits,Exponent: Longint;
  3464.   Value: Extended;
  3465.   CtrlWord: Word;
  3466.   Sign: Byte;
  3467.   DigitBuf: array[0..19] of Byte;
  3468. const
  3469.   C1e18: Extended = 1e18;
  3470.  
  3471. // Get digit from digit buffer
  3472.  
  3473. procedure GetDigit; {&USES None} {&FRAME-}
  3474. asm
  3475.                 mov     al,DigitBuf.Byte[esi]
  3476.                 inc     esi
  3477.                 test    al,al
  3478.                 jnz     @@RET
  3479.                 mov     al,'0'
  3480.                 dec     esi
  3481.               @@RET:
  3482. end;
  3483.  
  3484. asm
  3485.                 fstcw   CtrlWord        // Save x87 control word to the temp var
  3486.                 fldcw   CWNear          // Load new control word
  3487.                 fstp    Value           // Save value to the temp variable
  3488.                 push    edi             // Save buffer pointer to determine later string length
  3489.                 cmp     ecx,18          // Maximum number of digits = 18
  3490.                 jle     @@1             // convert digit count to the range of
  3491.                 mov     ecx,18          // -18 .. +18
  3492.               @@1:
  3493.                 cmp     ecx,-18
  3494.                 jge     @@2
  3495.                 mov     ecx,-18
  3496.               @@2:
  3497.                 mov     Digits,ecx      // Number of digits (Float<0, Fixed>=0)
  3498.                 cld
  3499.                 fwait                   // Wait for coprocessor
  3500.                 movzx   eax,Value.ExtRec.ER_Exponent // ax := Exponent & Sign
  3501.                 mov     Sign,ah
  3502.                 and     eax,mEXP_Exponent
  3503.                 jz      @@Zero_Exponent
  3504.                 cmp     eax,EXP_Spec_Value // Is value special (NAN or infinity) ?
  3505.                 jne     @@Not_Spec         // if not then normal value
  3506.                 cmp     Value.ExtRec.ER_Significand3,SIGN_Inf_Value // Is it infinity or NAN ?
  3507.                 je      @@Infinity
  3508.                 mov     ax,'AN'         // Output 'NAN'
  3509.                 stosw
  3510.                 stosb                   // AL already = 'N'
  3511.                 jmp     @@Done
  3512.  
  3513.               @@Infinity:
  3514.                 cmp     Sign,0          // Output 'INF' for +infinity
  3515.                 jns     @@Plus_Inf      // and   '-INF' for -infinity
  3516.                 mov     al,'-'
  3517.                 stosb
  3518.               @@Plus_Inf:
  3519.                 mov     ax,'NI'
  3520.                 stosw
  3521.                 mov     al,'F'
  3522.                 stosb
  3523.                 jmp     @@Done
  3524.  
  3525.               @@Zero_Exponent:
  3526.                 mov     Exponent,eax    // eax = 0
  3527.                 mov     DigitBuf.Byte,al
  3528.                 jmp     @@Make_String
  3529.  
  3530.               @@Not_Spec:
  3531.                 mov     Value.ExtRec.ER_Exponent,ax // Clear sign bit
  3532.                 fld     Value           // Load positive value
  3533.                 sub     ax,3FFFh        // Obtain signed binary exponent
  3534.                 mov     dx,19728
  3535.                 imul    dx              // 2^X = 10^Y => Y=LN(2)*X/LN(10)
  3536.                 movsx   edx,dx
  3537.                 mov     Exponent,edx    // 19728,301 =LN(2)*65536/LN(10)
  3538.                 sub     edx,17
  3539.                 neg     edx
  3540.                 mov     eax,edx
  3541.                 Call    FPower10
  3542.                 frndint
  3543.                 fld     C1e18           // ST(0) ? 1.0e18
  3544.                 fcomp
  3545.                 fnstsw  ax
  3546.                 test    ah,(mSW_C0+mSW_C3) shr 8
  3547.                 jz      @@Below_1e18    // If Significand >= 1.0e18 then
  3548.                 fidiv   LongP10Table[1*4].Longint // significand := significand /10
  3549.                 inc     Exponent        // Inc(Exponent)
  3550.               @@Below_1e18:
  3551.                 fbstp   Value           //  Store in BCD form
  3552.                 lea     ebx,DigitBuf
  3553.                 mov     esi,9           // Packed decimal: 9 bytes(72 bits)
  3554.                 fwait
  3555.               @@3:
  3556.                 mov     al,Value[esi-1].Byte // Get two nibbles
  3557.                 mov     ah,al
  3558.                 shr     al,4            // Put them: one to AL and the other
  3559.                 and     ah,0Fh          // to AH
  3560.                 add     ax,'00'         // Convert them to ASCII form
  3561.                 mov     [ebx],ax
  3562.                 add     ebx,2
  3563.                 dec     esi
  3564.                 jnz     @@3
  3565.                 mov     [ebx].Byte,0    // Terminate with '\0'
  3566.  
  3567.                 cmp     Digits,0        // If Fixed point and
  3568.                 jl      @@4
  3569.                 cmp     Exponent,36     // exponent => 36 then display
  3570.                 jl      @@4
  3571.                 mov     Digits,-18      // as floating point with 18 digits
  3572.               @@4:
  3573.                 mov     esi,Digits
  3574.                 test    esi,esi
  3575.                 js      @@Float
  3576.                 add     esi,Exponent
  3577.                 inc     esi
  3578.                 jns     @@5
  3579.                 mov     DigitBuf.Byte,0
  3580.                 jmp     @@Make_String
  3581.  
  3582.               @@Float:
  3583.                 neg     esi
  3584.               @@5:
  3585.                 cmp     esi,18                  // if > 18 then no rounding is needed
  3586.                 jae     @@Make_String           // else
  3587.                 cmp     DigitBuf.Byte[esi],'5'  // Round significand to the           }
  3588.                 mov     DigitBuf.Byte[esi],0    // specified number of digits         }
  3589.                 jb      @@Make_String           // if last digit < '5' then truncate it
  3590.               @@6:
  3591.                 dec     esi                     // else
  3592.                 js      @@Rounding_Done
  3593.                 inc     DigitBuf.Byte[esi]      // Inc(LastDigit)
  3594.                 cmp     DigitBuf.Byte[esi],'9'  // if digit < 9 then done
  3595.                 jbe     @@Make_String           // else truncate string
  3596.                 mov     DigitBuf.Byte[esi],0    // E.g: 0.596 => 0.6
  3597.                 jmp     @@6
  3598.  
  3599.               @@Rounding_Done:
  3600.                 mov     DigitBuf.Word,'1'
  3601.                 inc     Exponent
  3602.  
  3603.               @@Make_String:
  3604.                 xor     esi,esi
  3605.                 mov     edx,Digits
  3606.                 test    edx,edx
  3607.                 js      @@As_Float
  3608. // ....... Output as fixed point number ............
  3609.                 cmp     Sign,0
  3610.                 jns     @@Positive
  3611.                 mov     al,'-'                  // Output '-'
  3612.                 stosb
  3613.               @@Positive:
  3614.                 mov     ecx,Exponent
  3615.                 test    ecx,ecx
  3616.                 jns     @@7
  3617.                 mov     al,'0'
  3618.                 stosb
  3619.                 jmp     @@Fract_Part
  3620.  
  3621.               @@7:
  3622.                 Call    GetDigit
  3623.                 stosb
  3624.                 dec     ecx
  3625.                 jns     @@7
  3626.  
  3627.               @@Fract_Part:
  3628.                 test    edx,edx
  3629.                 jz      @@Done
  3630.                 mov     al,'.'
  3631.                 stosb
  3632.               @@8:
  3633.                 inc     ecx
  3634.                 jz      @@9
  3635.                 mov     al,'0'
  3636.                 stosb
  3637.                 dec     edx
  3638.                 jnz     @@8
  3639.               @@9:
  3640.                 dec     edx
  3641.                 js      @@Done
  3642.                 Call    GetDigit
  3643.                 stosb
  3644.                 jmp     @@9
  3645. // ........ Output as floating point number .........
  3646.               @@As_Float:
  3647.                 mov     al,' '
  3648.                 cmp     Sign,0
  3649.                 jns     @@Pos
  3650.                 mov     al,'-'
  3651.               @@Pos:
  3652.                 stosb
  3653.                 Call    GetDigit
  3654.                 stosb
  3655.                 inc     edx
  3656.                 jz      @@Exponent
  3657.                 mov     al,'.'
  3658.                 stosb
  3659.               @@10:
  3660.                 Call    GetDigit
  3661.                 stosb
  3662.                 inc     edx
  3663.                 jne     @@10
  3664.  
  3665.               @@Exponent:
  3666.                 mov     al,'E'
  3667.                 stosb
  3668.                 mov     al,'+'
  3669.                 mov     edx,Exponent
  3670.                 test    edx,edx
  3671.                 jns     @@Positive_Exp
  3672.                 mov     al,'-'
  3673.                 neg     edx
  3674.               @@Positive_Exp:
  3675.                 stosb
  3676.                 mov     ah,100
  3677.                 mov     al,10
  3678.                 xchg    eax,edx         // Convert Number in eax to the ASCII form
  3679.                 div     dh              // dh = 100
  3680.                 mov     dh,ah
  3681.                 cbw
  3682.                 div     dl              // dl = 10
  3683.                 add     ax,'00'
  3684.                 stosw
  3685.                 mov     al,dh
  3686.                 cbw
  3687.                 div     dl
  3688.                 add     ax,'00'
  3689.                 stosw
  3690.  
  3691.               @@Done:
  3692.                 mov     ecx,edi
  3693.                 pop     edi             // Pop previous buffer pointer
  3694.                 sub     ecx,edi         // ecx := Output string length
  3695.                 fclex                   // clear exceptions (if any)
  3696.                 fldcw   CtrlWord        // Restore old value of the control word
  3697.                 fwait
  3698. end;
  3699.  
  3700. // Converts sequence of digits to float
  3701. // EXPECTS:     edi     = @ of the buffer with packed string
  3702. //              ecx     = Packed string length
  3703. // RETURNS:     ebx     = Digit count
  3704.  
  3705. procedure DigitStr; {&USES None} {&FRAME-}
  3706. asm
  3707.                 xor     ebx,ebx                 // Digit Count
  3708.                 jecxz   @@Done
  3709.               @@1:
  3710.                 mov     al,[edi]                // Get char
  3711.                 sub     al,'0'+10
  3712.                 add     al,10                   // Is char in ['0'..'9'] ?
  3713.                 jnc     @@Done                  // No, @@Done
  3714.                 fimul   LongP10Table[1*4].Longint // *10
  3715.                 and     eax,7Fh
  3716.                 push    eax
  3717.                 fiadd   Word Ptr [esp]
  3718.                 pop     eax
  3719.                 inc     ebx
  3720.                 inc     edi
  3721.                 dec     ecx
  3722.                 jnz     @@1
  3723.               @@Done:
  3724. end;
  3725.  
  3726. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ Str2Float ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3727.  
  3728. // Converts string to float
  3729. // EXPECTS:     edi     = @ of the buffer with packed string
  3730. //              ecx     = Packed string length
  3731. // RETURNS:     ecx     = Number of the remaining characters
  3732. //              edi     = @ just after the parsed string
  3733. //              ST(0)   = Converted value
  3734. //              CF      = 1 if error occurred ( 0  otherwise)
  3735.  
  3736. procedure Str2Float; assembler; {&USES eax,ebx,edx} {&FRAME+}
  3737. var
  3738.   CtrlWord: Word;
  3739.   SignChar,ExpoChar: Byte;
  3740. asm
  3741.                 fstcw   CtrlWord        // Save x87 control word
  3742.                 fclex                   // Clear exceptions
  3743.                 fldcw   CWNear          // Load new control word
  3744.                 fldz                    // ST(0) := 0
  3745.                 test    ecx,ecx         // jecxz cannot access target
  3746.                 jz      @@Failed
  3747.                 mov     al,[edi]
  3748.                 mov     SignChar,al     // Record the sign
  3749.                 cmp     al,' '
  3750.                 je      @@1
  3751.                 cmp     al,'+'
  3752.                 je      @@1
  3753.                 cmp     al,'-'
  3754.                 jne     @@2
  3755.               @@1:
  3756.                 inc     edi
  3757.                 dec     ecx
  3758.               @@2:
  3759.                 mov     edx,ecx
  3760.                 Call    DigitStr        // Read significand before
  3761.                 xor     ebx,ebx         // decimal point
  3762.                 jecxz   @@3
  3763.                 mov     al,[edi]
  3764.                 cmp     al,'.'
  3765.                 jne     @@3
  3766.                 inc     edi
  3767.                 dec     ecx
  3768.                 Call    DigitStr        // after decimal point
  3769.                 neg     ebx             // ebx = Exponent
  3770.               @@3:
  3771.                 cmp     edx,ecx         // Is anything parsed ?
  3772.                 je      @@Failed        // No, @@Failed
  3773.                 jecxz   @@5
  3774.                 mov     al,[edi]
  3775.                 cmp     al,'E'          // Parse exponent(if any)
  3776.                 je      @@4
  3777.                 cmp     al,'e'
  3778.                 jne     @@5
  3779.               @@4:
  3780.                 inc     edi
  3781.                 dec     ecx
  3782.                 Call    Str2Int         // RETURNS: eax = Exponent
  3783.                 jc      @@Failed
  3784.                 cmp     eax,4999
  3785.                 jge     @@Failed
  3786.                 cmp     eax,-4999
  3787.                 jle     @@Failed
  3788.                 add     ebx,eax
  3789.               @@5:
  3790.                 mov     eax,ebx
  3791.                 Call    FPower10        // Significand * 10^Exponent
  3792.                 cmp     SignChar,'-'
  3793.                 jne     @@6
  3794.                 fchs
  3795.               @@6:
  3796.                 fnstsw  ax
  3797.                 test    al,mSW_IE or mSW_OE
  3798.                 jz      @@OK            // CF = 0
  3799.               @@Failed:
  3800.                 stc
  3801.               @@OK:
  3802.                 fclex                   // Clear exceptions
  3803.                 fldcw   CtrlWord        // Restore old control word
  3804.                 fwait
  3805. end;
  3806.  
  3807. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ STR/VAL INTEGER ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3808.  
  3809. // procedure Str(X:[:Width ]; var S: ShortString);
  3810.  
  3811. procedure _StrInt(Value,Width: Longint; S: Pointer; SLen: Longint); assembler; {&USES ALL} {&FRAME-}
  3812. var
  3813.   Buffer: array[0..31] of Byte;
  3814. asm
  3815.                 mov     eax,Value
  3816.                 lea     edi,Buffer
  3817.                 mov     esi,edi
  3818.                 Call    Int2Str
  3819.                 mov     edi,S
  3820.                 mov     edx,SLen
  3821.                 mov     eax,Width
  3822.                 cmp     eax,edx
  3823.                 jle     @@1
  3824.                 mov     eax,edx
  3825.               @@1:
  3826.                 cmp     ecx,edx
  3827.                 jle     @@2
  3828.                 mov     ecx,edx
  3829.               @@2:
  3830.                 cmp     eax,ecx
  3831.                 jge     @@3
  3832.                 mov     eax,ecx                 // ecx = String Length
  3833.               @@3:                              // eax = Field width
  3834.                 cld
  3835.                 stosb                           // String Length
  3836.                 sub     eax,ecx
  3837.                 jz      @@4
  3838.                 push    ecx
  3839.                 mov     ecx,eax
  3840.                 mov     al,' '
  3841.                 rep     stosb
  3842.                 pop     ecx
  3843.               @@4:
  3844.                 rep     movsb
  3845. end;
  3846.  
  3847. // procedure Str(X:[:Width ]; var S: AnsiString);
  3848.  
  3849. procedure _StrIntLStr(Value,Width: Longint; var S: Pointer); assembler; {&USES eax} {&FRAME-}
  3850. var
  3851.   Buffer: ShortString;
  3852. asm
  3853.                 lea     eax,Buffer
  3854.                 push    Value                   // [1]:Longint = Value
  3855.                 push    Width[4]                // [2]:Longint = Width
  3856.                 push    eax                     // [3]:Pointer = @String
  3857.                 push    255                     // [4]:Longint = MaxLen
  3858.                 Call    _StrInt
  3859.                 push    S                       // [1]:Pointer = @Dest LStr
  3860.                 push    eax                     // [2]:Pointer = Src SStr
  3861.                 Call    _LStrStr
  3862.                 pop     eax
  3863. end;
  3864.  
  3865. // procedure Str(X:[:Width ]; var S: PChar);
  3866.  
  3867. procedure _StrIntPCh(Value,Width: Longint; S: Pointer; SLen: Longint); assembler; {&USES ALL} {&FRAME-}
  3868. var
  3869.   Buffer: array[0..31] of Byte;
  3870. asm
  3871.                 mov     eax,Value
  3872.                 lea     edi,Buffer
  3873.                 mov     esi,edi
  3874.                 Call    Int2Str                 // Convert Integer to String
  3875.                 mov     edi,S
  3876.                 mov     edx,SLen
  3877.                 mov     eax,Width
  3878.                 cmp     eax,edx
  3879.                 jle     @@1
  3880.                 mov     eax,edx
  3881.               @@1:
  3882.                 cmp     ecx,edx
  3883.                 jle     @@2
  3884.                 mov     ecx,edx
  3885.               @@2:
  3886.                 cmp     eax,ecx
  3887.                 jge     @@3
  3888.                 mov     eax,ecx                 // ecx = String Length
  3889.               @@3:                              // eax = Field width
  3890.                 cld
  3891.                 sub     eax,ecx
  3892.                 jz      @@4
  3893.                 push    ecx
  3894.                 mov     ecx,eax
  3895.                 mov     al,' '
  3896.                 rep     stosb
  3897.                 pop     ecx
  3898.               @@4:
  3899.                 rep     movsb
  3900.                 mov     al,cl                   // Terminate it with #0
  3901.                 stosb
  3902. end;
  3903.  
  3904. // procedure Val(const S: ShortString; var V; var Code: IntegerType);
  3905. // RETURNS:      eax   = Integer value
  3906.  
  3907. procedure _ValInt(S, Code: Pointer); {&USES ecx,edi} {&FRAME-}
  3908. asm
  3909.                 mov     edi,S
  3910.                 movzx   ecx,Byte Ptr [edi]      // ecx := String Length
  3911.                 inc     edi                     // edi := @S[1]
  3912.                 jecxz   @@2
  3913.               @@1:
  3914.                 cmp     [edi].Byte,' '          // Skip blanks
  3915.                 jne     @@2
  3916.                 inc     edi
  3917.                 loop    @@1
  3918.               @@2:
  3919.                 Call    Str2Int                 // Convert String to Integer
  3920.                 jc      @@ERROR
  3921.                 jecxz   @@OK                    // OK, Error position = 0
  3922.               @@ERROR:
  3923.                 mov     ecx,edi
  3924.                 sub     ecx,S                   // ecx := Error position
  3925.                 xor     eax,eax                 // Return 0
  3926.               @@OK:
  3927.                 mov     edi,Code
  3928.                 mov     [edi],ecx
  3929. end;
  3930.  
  3931. // procedure Val(const S: [PChar | AnsiString]; var V; var Code: IntegerType);
  3932. // RETURNS:     eax     = Integer value
  3933. //              edx     = Error position
  3934.  
  3935. procedure _ValIntPCh(S, Code: Pointer); {&USES ecx,edi} {&FRAME-}
  3936. asm
  3937.                 mov     edi,S
  3938.                 test    edi,edi
  3939.                 jz      @@ERROR
  3940.                 or      ecx,-1                  // ecx := -1
  3941.                 mov     al,' '
  3942.                 cld
  3943.                 repe    scasb                   // Skip blanks
  3944.                 dec     edi
  3945.                 or      ecx,-1                  // Calculate string length
  3946.                 mov     al,0
  3947.                 repne   scasb
  3948.                 not     ecx
  3949.                 sub     edi,ecx                 // edi := String offset
  3950.                 dec     ecx                     // ecx := Length of the string
  3951.                 Call    Str2Int                 // Convert string to float
  3952.                 jc      @@ERROR                 // Result in ST(0)
  3953.                 jecxz   @@OK                    // OK, Error position = 0
  3954.               @@ERROR:
  3955.                 mov     ecx,edi                 // Pop out invalid value
  3956.                 sub     ecx,S                   // and return 0
  3957.                 inc     ecx                     // ecx := Error position
  3958.                 xor     eax,eax
  3959.               @@OK:
  3960.                 mov     edi,Code
  3961.                 mov     [edi],ecx
  3962. end;
  3963.  
  3964. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ STR/VAL FLOATING POINT ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  3965.  
  3966. // procedure Str(X:[:Width [:Decimals ]]; var S: ShortString);
  3967. // EXPECTS:     ST(0)   = Floating point value
  3968.  
  3969. procedure _StrFlt(Width,Dec: Longint; S: Pointer; SLen: Longint); assembler; {&USES ALL} {&FRAME-}
  3970. var
  3971.   Buffer: array[0..63] of Byte;
  3972. asm
  3973.                 mov     ecx,Dec
  3974.                 test    ecx,ecx                 // Setup parameters
  3975.                 jns     @@0
  3976.                 mov     ecx,8
  3977.                 sub     ecx,Width
  3978.                 cmp     ecx,-2
  3979.                 jle     @@0
  3980.                 mov     ecx,-2
  3981.               @@0:
  3982.                 lea     edi,Buffer
  3983.                 Call    Float2Str               // Convert float to string
  3984.                 mov     esi,edi
  3985.                 mov     edi,S
  3986.                 mov     edx,SLen
  3987.                 mov     eax,Width
  3988.                 cmp     eax,edx
  3989.                 jle     @@1
  3990.                 mov     eax,edx
  3991.               @@1:
  3992.                 cmp     ecx,edx
  3993.                 jle     @@2
  3994.                 mov     ecx,edx
  3995.               @@2:
  3996.                 cmp     eax,ecx
  3997.                 jge     @@3
  3998.                 mov     eax,ecx                 // ecx = String Length
  3999.               @@3:                              // eax = Field width
  4000.                 cld
  4001.                 stosb                           // String Length
  4002.                 sub     eax,ecx
  4003.                 jz      @@4
  4004.                 push    ecx
  4005.                 mov     ecx,eax
  4006.                 mov     edx,eax
  4007.                 shr     ecx,2
  4008.                 and     dl,11b
  4009.                 mov     eax,'    '              // FAST STOS
  4010.                 rep     stosd                   // Right-justify output string
  4011.                 mov     cl,dl
  4012.                 rep     stosb
  4013.                 pop     ecx
  4014.               @@4:
  4015.                 mov     eax,ecx                 // Copy string itself
  4016.                 shr     ecx,2
  4017.                 and     al,11b
  4018.                 rep     movsd                   // FAST MOVS
  4019.                 mov     cl,al
  4020.                 rep     movsb
  4021. end;
  4022.  
  4023. // procedure Str(X:[:Width [:Decimals ]]; var S: AnsiString);
  4024.  
  4025. procedure _StrFltLStr(Width,Dec: Longint; var S: Pointer); assembler; {&USES eax} {&FRAME-}
  4026. var
  4027.   Buffer: ShortString;
  4028. asm
  4029.                 lea     eax,Buffer
  4030.                 push    Width                   // [1]:Longint = Width
  4031.                 push    Dec[4]                  // [2]:Longint = Dec
  4032.                 push    eax                     // [3]:Pointer = @String
  4033.                 push    255                     // [4]:Longint = MaxLen
  4034.                 Call    _StrFlt
  4035.                 push    S                       // [1]:Pointer = @Dest LStr
  4036.                 push    eax                     // [2]:Pointer = Src SStr
  4037.                 Call    _LStrStr
  4038.                 pop     eax
  4039. end;
  4040.  
  4041. // procedure Str(X:[:Width [:Decimals ]]; var S: PChar);
  4042. // EXPECTS:      ST(0) = Floating point value
  4043.  
  4044. procedure _StrFltPCh(Width,Dec: Longint; S: Pointer; SLen: Longint); assembler; {&USES ALL} {&FRAME-}
  4045. var
  4046.   Buffer: array[0..63] of Byte;
  4047. asm
  4048.                 mov     ecx,Dec
  4049.                 test    ecx,ecx                 // Setup parameters
  4050.                 jns     @@0
  4051.                 mov     ecx,8
  4052.                 sub     ecx,Width
  4053.                 cmp     ecx,-2
  4054.                 jle     @@0
  4055.                 mov     ecx,-2
  4056.               @@0:
  4057.                 lea     edi,Buffer
  4058.                 Call    Float2Str               // Convert float to string
  4059.                 mov     esi,edi
  4060.                 mov     edi,S
  4061.                 mov     edx,SLen
  4062.                 mov     eax,Width
  4063.                 cmp     eax,edx
  4064.                 jle     @@1
  4065.                 mov     eax,edx
  4066.               @@1:
  4067.                 cmp     ecx,edx
  4068.                 jle     @@2
  4069.                 mov     ecx,edx
  4070.               @@2:
  4071.                 cmp     eax,ecx
  4072.                 jge     @@3
  4073.                 mov     eax,ecx                 // ecx = String Length
  4074.               @@3:                              // eax = Field width
  4075.                 cld
  4076.                 sub     eax,ecx
  4077.                 jz      @@4
  4078.                 push    ecx
  4079.                 mov     ecx,eax
  4080.                 mov     edx,eax
  4081.                 shr     ecx,2
  4082.                 and     dl,11b
  4083.                 mov     eax,'    '              // FAST STOS
  4084.                 rep     stosd                   // Right-justify output string
  4085.                 mov     cl,dl
  4086.                 rep     stosb
  4087.                 pop     ecx
  4088.               @@4:
  4089.                 mov     eax,ecx                 // Copy string itself
  4090.                 shr     ecx,2
  4091.                 and     al,11b
  4092.                 rep     movsd                   // FAST MOVS
  4093.                 mov     cl,al
  4094.                 rep     movsb
  4095.                 mov     al,cl                   // Terminate it with #0
  4096.                 stosb
  4097. end;
  4098.  
  4099. // procedure Val(const S: ShortString; var V; var Code: IntegerType);
  4100. // RETURNS:     ST(0) = Floating point value
  4101.  
  4102. procedure _ValFlt(S, Code: Pointer); {&USES ecx,edi} {&FRAME-}
  4103. asm
  4104.                 mov     edi,S
  4105.                 movzx   ecx,Byte Ptr [edi]      // ecx := String Length
  4106.                 inc     edi                     // edi := @S[1]
  4107.                 jecxz   @@2
  4108.               @@1:
  4109.                 cmp     [edi].Byte,' '          // Skip blanks
  4110.                 jne     @@2
  4111.                 inc     edi
  4112.                 loop    @@1
  4113.               @@2:
  4114.                 Call    Str2Float               // Convert string to float
  4115.                 jc      @@ERROR                 // Result in ST(0)
  4116.                 jecxz   @@OK                    // OK, Error position = 0
  4117.               @@ERROR:
  4118.                 fstp    st(0)                   // Pop out invalid value
  4119.                 fldz                            // and return 0
  4120.                 mov     ecx,edi                 // ecx := Error position
  4121.                 sub     ecx,S
  4122.                 fwait                           // Wait for result
  4123.               @@OK:
  4124.                 mov     edi,Code
  4125.                 mov     [edi],ecx
  4126. end;
  4127.  
  4128. // procedure Val(const S:[PChar | AnsiString]; var V; var Code: IntegerType);
  4129. // RETURNS:     ST(0)   = Floating point value
  4130.  
  4131. procedure _ValFltPCh(S,Code: Pointer); {&USES eax,ecx,edi} {&FRAME-}
  4132. asm
  4133.                 mov     edi,S
  4134.                 test    edi,edi
  4135.                 jz      @@Fail
  4136.                 or      ecx,-1                  // ecx := -1
  4137.                 mov     al,' '
  4138.                 cld                             // Skip Blanks
  4139.                 repe    scasb
  4140.                 dec     edi
  4141.                 or      ecx,-1                  // Calculate string length
  4142.                 mov     al,0
  4143.                 repne   scasb
  4144.                 not     ecx
  4145.                 sub     edi,ecx                 // edi := String offset
  4146.                 dec     ecx                     // ecx := Length of the string
  4147.                 Call    Str2Float               // Convert string to float
  4148.                 jc      @@ERROR                 // Result in ST(0)
  4149.                 jecxz   @@OK                    // OK, Error position = 0
  4150.               @@ERROR:
  4151.                 fstp    st(0)                   // Pop out invalid value
  4152.               @@Fail:
  4153.                 fldz                            // and return 0
  4154.                 mov     ecx,edi                 // ecx := Error position
  4155.                 sub     ecx,S
  4156.                 inc     ecx
  4157.                 fwait                           // Wait for result
  4158.               @@OK:
  4159.                 mov     edi,Code
  4160.                 mov     [edi],ecx
  4161. end;
  4162.  
  4163. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ MEMORY BLOCK OPERATIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  4164.  
  4165. // procedure Move(var Source, Dest, Count: LongInt);
  4166. // Important! Memory regions may overlap
  4167.  
  4168. procedure _MemMove(Src,Dest: Pointer; Count: Longint); {&USES eax,ecx,esi,edi} {&FRAME-}
  4169. asm
  4170.                 mov     esi,Src
  4171.                 mov     edi,Dest
  4172.                 mov     ecx,Count
  4173.                 test    ecx,ecx
  4174.                 jz      @@RET
  4175.                 cmp     esi,edi
  4176.                 jae     @@Forward
  4177.  
  4178.                 // Move backwards
  4179.                 std
  4180.                 add     esi,ecx
  4181.                 add     edi,ecx
  4182.                 mov     eax,ecx
  4183.                 and     ecx,11b
  4184.                 dec     esi
  4185.                 dec     edi
  4186.                 rep     movsb
  4187.                 mov     ecx,eax
  4188.                 shr     ecx,2
  4189.                 jz      @@RET
  4190.                 sub     esi,3
  4191.                 sub     edi,3
  4192.                 rep     movsd
  4193.                 jmp     @@RET
  4194.  
  4195.                 // Move forward
  4196.               @@Forward:
  4197.                 cld
  4198.                 // Make sure data is well aligned
  4199.               @@Align:
  4200.                 test    edi,3
  4201.                 jz      @@Aligned
  4202.                 movsb
  4203.                 dec     ecx
  4204.                 jz      @@RET
  4205.                 jmp     @@Align
  4206.  
  4207.               @@Aligned:
  4208.                 mov     eax,ecx
  4209.                 shr     ecx,2
  4210.                 and     al,11b
  4211.                 rep     movsd
  4212.                 mov     cl,al
  4213.                 rep     movsb
  4214.               @@RET:
  4215.                 cld
  4216. end;
  4217.  
  4218. // FillChar standard procedure
  4219. // procedure FillChar(var Dest; Count: LongInt, Value);
  4220.  
  4221. procedure _MemFill(Dest: Pointer; Count: Longint; Value: Byte); {&USES eax,ecx,edi} {&FRAME-}
  4222. asm
  4223.                 cld
  4224.                 mov     al,Value                // Fill all bytes of the eax
  4225.                 mov     ah,al                   // with Value byte
  4226.                 mov     ecx,eax
  4227.                 shl     eax,16
  4228.                 mov     ax,cx
  4229.                 mov     edi,Dest
  4230.                 mov     ecx,Count
  4231.                 push    ecx
  4232.                 shr     ecx,2
  4233.                 rep     stosd
  4234.                 pop     ecx
  4235.                 and     ecx,11b
  4236.                 rep     stosb
  4237. end;
  4238.  
  4239. // Support routine for structured variable assignments
  4240. // procedure _VarMove(var Dest; Count: LongInt, Value);
  4241. // Important! Memory regions must NOT overlap
  4242.  
  4243. procedure _VarMove(Src,Dest: Pointer; Count: Longint); {&USES ecx,esi,edi} {&FRAME-}
  4244. asm
  4245.                 cld
  4246.                 mov     esi,Src
  4247.                 mov     edi,Dest
  4248.                 mov     ecx,Count
  4249.                 push    ecx
  4250.                 shr     ecx,2
  4251.                 rep     movsd
  4252.                 pop     ecx
  4253.                 and     ecx,11b
  4254.                 rep     movsb
  4255. end;
  4256.  
  4257. procedure _VarMoveInit(Src,Dest: Pointer; Count: Longint; RTTI: Pointer); {&USES None} {&FRAME-}
  4258. asm
  4259.                 push    Src  [0]
  4260.                 push    Dest [4]
  4261.                 push    Count[8]
  4262.                 Call    _VarMove
  4263.                 push    Dest [0]
  4264.                 push    RTTI [4]
  4265.                 Call    _MemAddRef
  4266. end;
  4267.  
  4268. //--------------[ INITIALIZATION/FINALIZATION ]-------------------------------
  4269.  
  4270. // Initialize standard procedure without Count
  4271. // procedure Initialize(var V);
  4272.  
  4273. procedure _MemInit(P,TypeInfo: Pointer); {&USES None} {&FRAME-}
  4274. asm
  4275.                 pop     eax             // Return address
  4276.                 push    1               // [3]:Longint = Count
  4277.                 push    eax
  4278.                 jmp     _MemInitCnt
  4279.                 PopArgs 0
  4280. end;
  4281.  
  4282. // Initialize standard procedure with Count optional parameter
  4283. // procedure Initialize(var V; Count: Longint);
  4284.  
  4285. procedure _MemInitCnt(P,TypeInfo: Pointer; Count: Longint); {&USES ebx,ecx,edx,esi} {&FRAME-}
  4286. asm
  4287.                 mov     ebx,P
  4288.                 mov     esi,TypeInfo
  4289.                 mov      al,[esi].TTypeInfo.Kind
  4290.                 movzx   ecx,[esi].TTypeInfo.Name.Byte
  4291.                 lea     esi,[esi+ecx].TTypeInfo.Name[1]
  4292.                 cmp     al,tkLString
  4293.                 je      @@LString
  4294.                 cmp     al,tkArray
  4295.                 je      @@Array
  4296.                 cmp     al,tkRecord
  4297.                 je      @@Record
  4298.                 mov     al,reInvalidPtr
  4299.                 add     esp,@Uses
  4300.                 jmp     RtlError
  4301. // Long String
  4302.               @@LString:
  4303.                 xor     eax,eax
  4304.                 mov     ecx,Count
  4305.               @@1:
  4306.                 mov     [ebx],eax
  4307.                 add     ebx,4
  4308.                 dec     ecx
  4309.                 jg      @@1
  4310.                 jmp     @@RET
  4311. // Array
  4312.               @@Array:
  4313.                 push    ebx                         // [1]:Pointer = @Variable
  4314.                 add     ebx,[esi].TTypeData.ArrSize
  4315.                 push    [esi].TTypeData.ElemRTTI    // [2]:Pointer = RTTI
  4316.                 push    [esi].TTypeData.ElemCount   // [3]:Longint = Count
  4317.                 Call    _MemInitCnt
  4318.                 dec     Count
  4319.                 jg      @@Array
  4320.                 jmp     @@RET
  4321. // Record
  4322.               @@Record:
  4323.                 mov     eax,ebx
  4324.                 add     eax,[esi].TTypeData.RecSize
  4325.                 push    eax
  4326.                 mov     ecx,[esi].TTypeData.RecData.FieldCount
  4327.                 lea     edx,[esi].TTypeData.RecData.FieldTable
  4328.               @@2:
  4329.                 mov     eax,ebx
  4330.                 add     eax,[edx].TFieldRec.&Offset
  4331.                 push    eax                     // [1]:Pointer = @Variable
  4332.                 push    [edx].TFieldRec.TypeInfo// [2]:Pointer = RTTI
  4333.                 Call    _MemInit
  4334.                 add     edx,TYPE TFieldRec
  4335.                 dec     ecx
  4336.                 jg      @@2
  4337.                 pop     ebx
  4338.                 dec     Count
  4339.                 jg      @@Record
  4340.               @@RET:
  4341. end;
  4342.  
  4343. // Finalize standard procedure without Count
  4344. // procedure Initialize(var V);
  4345.  
  4346. procedure _MemFin(P,TypeInfo: Pointer); {&USES None} {&FRAME-}
  4347. asm
  4348.                 pop     eax             // Return address
  4349.                 push    1               // [3]:Longint = Count
  4350.                 push    eax
  4351.                 jmp     _MemFinCnt
  4352.                 PopArgs 0
  4353. end;
  4354.  
  4355. // Finalizes the fields of a record, object or class
  4356. // EXPECTS:     ebx     = @Memory
  4357. //              edx     = Record type data
  4358.  
  4359. procedure _MemFinRec; {&USES ecx} {&FRAME-}
  4360. asm
  4361.                 mov     ecx,[edx].TRecType.FieldCount
  4362.                 add     edx,TRecType.FieldTable
  4363.               @@1:
  4364.                 mov     eax,ebx
  4365.                 add     eax,[edx].TFieldRec.&Offset
  4366.                 push    eax                     // [1]:Pointer = @Variable
  4367.                 push    [edx].TFieldRec.TypeInfo// [2]:Pointer = RTTI
  4368.                 Call    _MemFin
  4369.                 add     edx,TYPE TFieldRec
  4370.                 dec     ecx
  4371.                 jg      @@1
  4372. end;
  4373.  
  4374. // Initialize standard procedure with Count optional parameter
  4375. // procedure Initialize(var V; Count: Longint);
  4376.  
  4377. procedure _MemFinCnt(P,TypeInfo: Pointer; Count: Longint); {&USES ebx,ecx,edx,esi} {&FRAME-}
  4378. asm
  4379.                 mov     ebx,P
  4380.                 mov     esi,TypeInfo
  4381.                 mov      al,[esi].TTypeInfo.Kind
  4382.                 movzx   ecx,[esi].TTypeInfo.Name.Byte
  4383.                 lea     esi,[esi+ecx].TTypeInfo.Name[1]
  4384.                 cmp     al,tkLString
  4385.                 je      @@LString
  4386.                 cmp     al,tkArray
  4387.                 je      @@Array
  4388.                 cmp     al,tkRecord
  4389.                 je      @@Record
  4390.                 mov     al,reInvalidPtr
  4391.                 add     esp,@Uses
  4392.                 jmp     RtlError
  4393. // Long String
  4394.               @@LString:
  4395.                 push    ebx                     // [1]:Pointer = @LStr
  4396.                 Call    _LStrClr
  4397.                 add     ebx,4
  4398.                 dec     Count
  4399.                 jg      @@LString
  4400.                 jmp     @@RET
  4401. // Array
  4402.               @@Array:
  4403.                 push    ebx                         // [1]:Pointer = @Variable
  4404.                 add     ebx,[esi].TTypeData.ArrSize
  4405.                 push    [esi].TTypeData.ElemRTTI    // [2]:Pointer = RTTI
  4406.                 push    [esi].TTypeData.ElemCount   // [3]:Longint = Count
  4407.                 Call    _MemFinCnt
  4408.                 dec     Count
  4409.                 jg      @@Array
  4410.                 jmp     @@RET
  4411. // Record
  4412.               @@Record:
  4413.                 mov     eax,ebx
  4414.                 add     eax,[esi].TTypeData.RecSize
  4415.                 push    eax
  4416.                 lea     edx,[esi].TTypeData.RecData
  4417.                 Call    _MemFinRec
  4418.                 pop     ebx
  4419.                 dec     Count
  4420.                 jg      @@Record
  4421.               @@RET:
  4422. end;
  4423.  
  4424. procedure _MemAddRefCnt(P,TypeInfo: Pointer; Count: Longint); {&USES ebx,ecx,edx,esi} {&FRAME-}
  4425. asm
  4426.                 mov     ebx,P
  4427.                 mov     esi,TypeInfo
  4428.                 mov      al,[esi].TTypeInfo.Kind
  4429.                 movzx   ecx,[esi].TTypeInfo.Name.Byte
  4430.                 lea     esi,[esi+ecx].TTypeInfo.Name[1]
  4431.                 cmp     al,tkLString
  4432.                 je      @@LString
  4433.                 cmp     al,tkArray
  4434.                 je      @@Array
  4435.                 cmp     al,tkRecord
  4436.                 je      @@Record
  4437.                 mov     al,reInvalidPtr
  4438.                 add     esp,@Uses
  4439.                 jmp     RtlError
  4440. // Long String
  4441.               @@LString:
  4442.                 push    [ebx].Longint               // [1]:Pointer = @LStr
  4443.                 Call    _LStrAddRef
  4444.                 add     ebx,4
  4445.                 dec     Count
  4446.                 jg      @@LString
  4447.                 jmp     @@RET
  4448. // Array
  4449.               @@Array:
  4450.                 push    ebx                         // [1]:Pointer = @Variable
  4451.                 add     ebx,[esi].TTypeData.ArrSize
  4452.                 push    [esi].TTypeData.ElemRTTI    // [2]:Pointer = RTTI
  4453.                 push    [esi].TTypeData.ElemCount   // [3]:Longint = Count
  4454.                 Call    _MemAddRefCnt
  4455.                 dec     Count
  4456.                 jg      @@Array
  4457.                 jmp     @@RET
  4458. // Record
  4459.               @@Record:
  4460.                 mov     eax,ebx
  4461.                 add     eax,[esi].TTypeData.RecSize
  4462.                 push    eax
  4463.                 mov     ecx,[esi].TTypeData.RecData.FieldCount
  4464.                 lea     edx,[esi].TTypeData.RecData.FieldTable
  4465.               @@2:
  4466.                 mov     eax,ebx
  4467.                 add     eax,[edx].TFieldRec.&Offset
  4468.                 push    eax                     // [1]:Pointer = @Variable
  4469.                 push    [edx].TFieldRec.TypeInfo// [2]:Pointer = RTTI
  4470.                 Call    _MemAddRef
  4471.                 add     edx,TYPE TFieldRec
  4472.                 dec     ecx
  4473.                 jg      @@2
  4474.                 pop     ebx
  4475.                 dec     Count
  4476.                 jg      @@Record
  4477.               @@RET:
  4478. end;
  4479.  
  4480. // Adds references to all long string fields of the specified variable.
  4481.  
  4482. procedure _MemAddRef(P,TypeInfo: Pointer); {&USES None} {&FRAME-}
  4483. asm
  4484.                 pop     eax             // Return address
  4485.                 push    1               // [3]:Longint = Count
  4486.                 push    eax
  4487.                 jmp     _MemAddRefCnt
  4488.                 PopArgs 0
  4489. end;
  4490.  
  4491. // New standard procedure. Pointer to the type that needs initialization is used
  4492.  
  4493. procedure _MemNewInit(Size: Longint; TypeInfo: Pointer); {&USES None} {&Frame-}
  4494. asm
  4495.                 push    Size
  4496.                 Call    _MemNew
  4497.                 test    eax,eax
  4498.                 jz      @@RET
  4499.                 push    eax
  4500.                 push    eax             // [1]:Pointer = @Memory
  4501.                 push    TypeInfo[8]     // [2]:Pointer = RTTI
  4502.                 Call    _MemInit
  4503.                 pop     eax
  4504.               @@RET:
  4505. end;
  4506.  
  4507. // Dispose standard procedure. Pointer to the type that needs finalization is used
  4508.  
  4509. procedure _MemFreeFin(P,TypeInfo: Pointer); {&USES None} {&FRAME-}
  4510. asm
  4511.                 push    P               // [1]:Pointer = @Memory
  4512.                 push    TypeInfo[4]     // [2]:Pointer = RTTI
  4513.                 Call    _MemFin
  4514.                 push    P               // [1]:Pointer = Memory
  4515.                 Call    _MemFree
  4516. end;
  4517.  
  4518. type
  4519.   TParamInit = record
  4520.     itFlag: Byte;
  4521.     itOfs:  Longint;
  4522.     itRTTI: Longint;
  4523.   end;
  4524.  
  4525. // Initializes the subprogram memory: both parameters and local variables
  4526. // The values of the flag field are as follows:
  4527. //      0: END
  4528. //      1: value parameter that must be copied
  4529. //      2: value parameter
  4530. //    $80: function result (no finalization is needed)
  4531.  
  4532. procedure _MemLocInit(Data,Handler: Pointer); {&USES None} {&FRAME-}
  4533. asm
  4534.                 push    ecx
  4535.                 push    edx
  4536.                 mov     edx,ebp
  4537.                 xchg    edx,Data[8]             // XCPT[1] = EBP
  4538.               @@1:
  4539.                 mov     al,[edx].TParamInit.itFlag
  4540.                 and     al,7Fh
  4541.                 cmp     al,1
  4542.                 jb      @@RET                   // 0: END
  4543.                 mov     ecx,OFFSET _MemAddRef
  4544.                 mov     eax,[edx].TParamInit.itOfs
  4545.                 ja      @@2
  4546.                 mov     eax,[eax+ebp]           // 1: Value parameter that is copied
  4547.                 test    [edx].TParamInit.itFlag,80h
  4548.                 jz      @@4
  4549.                 mov     ecx,OFFSET _MemFin
  4550.                 jmp     @@4
  4551.               @@2:
  4552.                 test    eax,eax
  4553.                 lea     eax,[eax+ebp]
  4554.                 jg      @@4
  4555.                 mov     ecx,OFFSET _MemInit
  4556.               @@4:
  4557.                 push    eax                     // [1]:Pointer = @Memory
  4558.                 push    [edx].TParamInit.itRTTI // [2]:Pointer = RTTI
  4559.                 Call    ecx
  4560.                 add     edx,TYPE TParamInit
  4561.                 jmp     @@1
  4562.               @@RET:
  4563.                 pop     edx
  4564.                 pop     ecx
  4565.                 pop     eax                     // RET@
  4566.                 push    fs:[0].Longint          // XCPT[3] = NextRec
  4567.                 mov     fs:[0].Longint,esp
  4568.                 jmp     eax
  4569.                 PopArgs 0
  4570. end;
  4571.  
  4572. procedure _MemLocFin(Data: Pointer); {&USES eax,edx} {&FRAME-}
  4573. asm
  4574.                 mov     edx,Data
  4575.               @@1:
  4576.                 mov     al,[edx].TParamInit.itFlag
  4577.                 test    al,80h                  // Do not finalize function result
  4578.                 jnz     @@3
  4579.                 and     al,7Fh
  4580.                 cmp     al,1
  4581.                 jb      @@RET
  4582.                 mov     eax,[edx].TParamInit.itOfs
  4583.                 lea     eax,[eax+ebp]
  4584.                 ja      @@2
  4585.                 mov     eax,[eax]               // 1: Address is on stack
  4586.               @@2:
  4587.                 push    eax                     // [1]:Pointer = @Memory
  4588.                 push    [edx].TParamInit.itRTTI // [2]:Pointer = RTTI
  4589.                 Call    _MemFin
  4590.               @@3:
  4591.                 add     edx,TYPE TParamInit
  4592.                 jmp     @@1
  4593.               @@RET:
  4594. end;
  4595.  
  4596. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ OBJECT HANDLING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  4597.  
  4598. // _DmtCall: Calls dynamic method
  4599. // EXPECTS:  eax         = Object's VMT address
  4600. //           [1]:Longint = Dynamic Index of the method
  4601. // Important!: Changes only value of eax
  4602.  
  4603. // Stack Layout:
  4604. //   ┌───────────────┐    ┌───────────┐    ┌───────────┐
  4605. //   │   Arguments   │    │ Arguments │    │ Arguments │
  4606. //   ├───────────────┤    ├───────────┤    ├───────────┤
  4607. //   │   DynIndex    │ -> │ Return @  │ -> │ Return @  │
  4608. //   ├───────────────┤    ├───────────┤    └───────────┘
  4609. //   │   Return @    │    │ Return @  │
  4610. //   └───────────────┘    └───────────┘
  4611.  
  4612. procedure _DmtCall(DynIndex: Longint); {&USES None} {&FRAME-}
  4613. asm
  4614.                 push    edi
  4615.                 push    edx                        // eax = VMT@
  4616.                 mov     edx,[eax].VMT.DMTPointer   // edx := DMT@
  4617.                 mov     eax,[esp+8]                // Swap Return@
  4618.                 xchg    eax,DynIndex[8]            // & DynIndex
  4619.                 mov     edi,[edx].DMT.Cache_Entry  // Cache method offset
  4620.                 cmp     eax,[edx].DMT.Cache_Index  // Is it last method used?
  4621.                 je      @@Done                     // Yes, Done
  4622.                 push    ebx
  4623.                 push    ecx
  4624.                 push    edx                        // Original DMT@
  4625.                 cld
  4626.               @@1:
  4627.                 mov     ecx,[edx].DMT.Entry_Count
  4628.                 mov     ebx,ecx                    // ebx := Dynamic Method#
  4629.                 lea     edi,[edx].DMT.Entry_Table  // eax = Dynamic Index
  4630.                 repne   scasd                      // Is such index found ?
  4631.                 je      @@Found                    // Yes, OK
  4632.                 mov     edx,[edx].DMT.Parent       // No, search in parent DMT
  4633.                 test    edx,edx
  4634.                 jne     @@1                        // Not found, error
  4635.                 add     esp,4*(5+1)                // 5 regs, former RET@
  4636.                 pop     eax
  4637.                 push    RTE_Object_Not_Initialized // [1]: Error Code
  4638.                 push    eax                        // Return address
  4639.                 jmp     _RunError
  4640.               @@Found:
  4641.                 mov     edi,[edi+ebx*4-4]
  4642.                 pop     edx                        // Original DMT@
  4643.                 mov     [edx].DMT.Cache_Index,eax
  4644.                 mov     [edx].DMT.Cache_Entry,edi
  4645.                 pop     ecx
  4646.                 pop     ebx
  4647.               @@Done:
  4648.                 mov     eax,edi
  4649.                 pop     edx
  4650.                 pop     edi
  4651.                 add     esp,4*1                    // Pop out former Ret@
  4652.                 jmp     eax
  4653. end;
  4654.  
  4655. const
  4656.   SelfOfs = $08;
  4657.   VmtOfs  = $0C;
  4658.  
  4659. // _ObjCtr: Constructor support routine
  4660. // _ObjDtr: Destructor support routine
  4661. // EXPECTS:     ebp     = Constructor/Destructor EBP
  4662. // RETURNS:     ZF      = 1 if failed (constructor only)
  4663.  
  4664. procedure _ObjCtr(VmtPtr: Longint); {&USES eax,ecx} {&FRAME-}
  4665. asm
  4666.                 mov     ecx,[ebp].VmtOfs        // VMT=0 while qualified or
  4667.                 cmp     ecx,1                   // inherited constructor call
  4668.                 jb      @@RET                   // Don't init object (ZF = 0)
  4669.                 mov     eax,[ebp].SelfOfs       // else VMT = VMT offset
  4670.                 test    eax,eax                 // Self = nil?
  4671.                 jz      @@GetMemory             // Yes, allocate
  4672.                 mov     [ebp].VmtOfs.Longint,0  // No deallocation on Fail
  4673.                 jmp     @@StoreLink             // (VMT := 0)
  4674.  
  4675.               @@GetMemory:
  4676.                 push    [ecx].VMT.InstanceSize  // Memory Size to allocate
  4677.                 Call    _MemNew                 // Allocate dynamic object
  4678.               @@OK:
  4679.                 test    eax,eax                 // Out of memory?
  4680.                 jz      @@RET                   // Yes, exit with ZF = 1
  4681.                 mov     [ebp].SelfOfs,eax       // Store in Self pointer
  4682.  
  4683.               @@StoreLink:
  4684.                 add     eax,VmtPtr              // VMT Ptr offset within object
  4685.                 mov     [eax],ecx               // Store VMT link in object
  4686.                 test    esp,esp                 // Exit with ZF=0
  4687.               @@RET:
  4688. end;
  4689.  
  4690. procedure _ObjDtr; {&USES None} {&FRAME-}
  4691. asm
  4692.                 cmp     [ebp].VmtOfs.Longint,0  // Inherited call?
  4693.                 je      @@OK                    // Yes, skip
  4694.                 push    [ebp].SelfOfs.Longint   // Extended syntax of Dispose
  4695.                 Call    _MemFree                // Dispose dynamic object(Self)
  4696.               @@OK:
  4697.                 and     [ebp].SelfOfs.Longint,0 // Self := nil
  4698. end;
  4699.  
  4700. // Object assignment support routine
  4701.  
  4702. procedure _ObjCopy(Src,Dest: Pointer; VmtPtr: Longint); {&USES ebx,ecx,esi,edi} {&FRAME-}
  4703. asm
  4704.                 cld
  4705.                 mov     esi,Src
  4706.                 mov     edi,Dest
  4707.                 mov     ebx,VmtPtr
  4708.                 add     ebx,edi
  4709.                 mov     ecx,[ebx]                       // ecx := VMT offset from Dest
  4710.                 push    ecx                             // Save it
  4711.                 mov     ecx,[ecx].VMT.InstanceSize      // Get Dest Size
  4712.                 push    ecx                             // Copy object
  4713.                 shr     ecx,2
  4714.                 rep     movsd                           // FAST MOVS
  4715.                 pop     ecx
  4716.                 and     ecx,11b
  4717.                 rep     movsb
  4718.                 pop     [ebx].Longint                   // Restore Dest VMT offset
  4719. end;
  4720.  
  4721. procedure _ObjCopyInit(Src,Dest: Pointer; VmtPtr: Longint; RTTI: Pointer); {&USES None} {&FRAME-}
  4722. asm
  4723.                 push    Src   [0]
  4724.                 push    Dest  [4]
  4725.                 push    VmtPtr[8]
  4726.                 Call    _ObjCopy
  4727.                 push    Dest  [0]
  4728.                 push    RTTI  [4]
  4729.                 Call    _MemAddRef
  4730. end;
  4731.  
  4732. // Checks VMT ptr offset within object instance
  4733.  
  4734. procedure _ObjChk(VmtPtr: Longint); {&USES eax,ecx} {&FRAME-}
  4735. asm
  4736.                 mov     eax,VmtPtr
  4737.                 test    eax,eax
  4738.                 jz      @@Error
  4739.                 mov     ecx,[eax].VMT.InstanceSize      // if Size = 0
  4740.                 jecxz   @@ERROR                         // or
  4741.                 add     ecx,[eax].VMT.InstanceCheck     // Size + Negative Size
  4742.                 jz      @@OK                            // <> 0 then Error
  4743.               @@Error:
  4744.                 add     esp,@Uses                       // Remove used registers
  4745.                 pop     eax
  4746.                 push    RTE_Object_Not_Initialized
  4747.                 push    eax                             // [1]: Error Code
  4748.                 jmp     _RunError                       // Return address
  4749.               @@OK:
  4750. end;
  4751.  
  4752. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ CLASS SUPPORT ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  4753.  
  4754. // EXPECTS:     eax     = Dynamic method index
  4755. //              ecx     = @VMT
  4756. // RETURNS:     ZF      = 1 if found
  4757. //              eax     = Method entry point address
  4758.  
  4759. procedure GetDynaMethod(Index,Self: Longint); {&USES ebx,ecx,edx,edi} {&FRAME-}
  4760. asm
  4761.                 cld
  4762.                 mov     eax,Index
  4763.                 mov     ecx,Self
  4764.               @@1:
  4765.                 mov     edi,[ecx].vtDynamicTable
  4766.                 mov     edx,ecx
  4767.                 test    edi,edi
  4768.                 je      @@2
  4769.                 mov     ecx,[edi].TDynamicTable.Count
  4770.                 mov     ebx,ecx
  4771.                 add     edi,TDynamicTable.Indices
  4772.                 repne   scasd
  4773.                 je      @@3
  4774.               @@2:
  4775.                 mov     ecx,[edx].vtParent
  4776.                 cmp     ecx,1
  4777.                 jb      @@RET                   { ZF = 0 }
  4778.                 jmp     @@1
  4779.               @@3:
  4780.                 mov     eax,[edi+ebx*4-4]       { ZF = 1 }
  4781.               @@RET:
  4782. end;
  4783.  
  4784. procedure _ClsCtr; {&USES None} {&FRAME-}
  4785. asm
  4786.                 cmp     [ebp+VmtOfs].Longint,0          // Inherited call ?
  4787.                 jz      @@RET
  4788.                 sub     esp,TYPE TExcFrame
  4789.                 push    eax
  4790.                 push    ecx
  4791.                 push    edx
  4792.                 mov     eax,[esp+4*3][TYPE TExcFrame]   // Move return@
  4793.                 mov     [esp+4*3],eax
  4794.                 mov     eax,[ebp+SelfOfs]               // VMT Ptr
  4795.                 push    eax                             // [1]:Self = VMT@
  4796.                 Call    DWord Ptr [eax].vtNewInstance
  4797.                 mov     [ebp+SelfOfs],eax               // Self
  4798.                 lea     edx,[esp+4*4]
  4799.                 mov     ecx,fs:[0]
  4800.                 mov     [edx].TExcFrame.Next,ecx
  4801.                 mov     [edx].TExcFrame.hEBP,ebp
  4802.                 mov     [edx].TExcFrame.Desc,OFFSET @@Desc
  4803.                 mov     [edx].TExcFrame.ConstructedObject,eax
  4804.                 mov     fs:[0],edx
  4805.                 pop     edx
  4806.                 pop     ecx
  4807.                 pop     eax
  4808.               @@RET:
  4809.                 ret
  4810.               @@Desc:
  4811.                 jmp     _XcptAny
  4812. //              Destroy the object
  4813.                 mov     eax,[esp+8+9*4]         // Registration[9*4]
  4814.                 push    [eax].TExcFrame.ConstructedObject
  4815.                 Call    TObject.Free
  4816. // Re-raise the exception
  4817.                 Call    _XcptRaiseAg
  4818. end;
  4819.  
  4820. procedure _ClsDtr; {&USES None} {&FRAME-}
  4821. asm
  4822.                 cmp     [ebp+VmtOfs].Longint,0  // Inherited call ?
  4823.                 je      @@RET
  4824.                 push    eax
  4825.                 push    ecx
  4826.                 push    edx
  4827.                 mov     eax,[ebp+SelfOfs]
  4828.                 push    eax
  4829.                 mov     eax,[eax].clVTable
  4830.                 Call    DWord Ptr [eax].vtFreeInstance
  4831.                 pop     edx
  4832.                 pop     ecx
  4833.                 pop     eax
  4834.                 and     [ebp].SelfOfs.Longint,0 // Self := nil
  4835.               @@RET:
  4836. end;
  4837.  
  4838. // Abstruct method handler
  4839.  
  4840. procedure _Abstract; {&USES None} {&FRAME-}
  4841. asm
  4842.                 pop     eax
  4843.                 push    RTE_Object_Not_Initialized
  4844.                 push    eax
  4845.                 jmp     _RunError
  4846. end;
  4847.  
  4848. // EXPECTS:     eax     = Instance pointer
  4849.  
  4850. procedure _ClsCallDynInst(Self,Index: Longint); {&USES None} {&FRAME-}
  4851. asm
  4852.                 pop     eax                     // Return@
  4853.                 xchg    eax,[esp]
  4854.                 push    eax                     // Index
  4855.                 mov     eax,Self
  4856.                 push    [eax].clVTable.Longint  // VMT@
  4857.                 Call    GetDynaMethod
  4858.                 jne     _Abstract
  4859.                 jmp     eax
  4860. end;
  4861.  
  4862. procedure _ClsCallDynCls(Self,Index: Longint); {&USES None} {&FRAME-}
  4863. asm
  4864.                 pop     eax                     // Return@
  4865.                 xchg    eax,[esp]
  4866.                 push    eax                     // Index
  4867.                 push    Self                    // VMT@
  4868.                 Call    GetDynaMethod
  4869.                 jne     _Abstract
  4870.                 jmp     eax
  4871. end;
  4872.  
  4873. procedure _ClsFindDynInst(Self,Index: Longint); {&USES None} {&FRAME-}
  4874. asm
  4875.                 mov     eax,Self
  4876.                 push    Index                   // Index
  4877.                 push    [eax].clVTable.Longint  // Vmt@
  4878.                 Call    GetDynaMethod
  4879.                 jne     _Abstract
  4880. end;
  4881.  
  4882. procedure _ClsFindDynCls(Self,Index: Longint); {&USES None} {&FRAME-}
  4883. asm
  4884.                 push    Index                   // Index
  4885.                 push    Self[4]                 // Vmt@
  4886.                 Call    GetDynaMethod
  4887.                 jne     _Abstract
  4888. end;
  4889.  
  4890. // 'IS' class operator
  4891. // EXPECTS:     [1]:DWord = Left operand (class)
  4892. //              [2]:DWord = Right operand (class reference)
  4893. // RETURNS:     al        = Boolean result
  4894.  
  4895. procedure _ClsIs(AClass,VMT: Pointer); {&USES ecx} {&FRAME-}
  4896. asm
  4897.                 mov     eax,AClass
  4898.                 test    eax,eax
  4899.                 jz      @@RET
  4900.                 mov     ecx,VMT
  4901.                 mov     eax,[eax].clVTable
  4902.               @@1:
  4903.                 cmp     eax,ecx
  4904.                 je      @@2
  4905.                 mov     eax,[eax].vtParent
  4906.                 test    eax,eax
  4907.                 jnz     @@1
  4908.                 jmp     @@RET
  4909.               @@2:
  4910.                 mov     al,1
  4911.               @@RET:
  4912. end;
  4913.  
  4914. // 'AS' class operator
  4915. // EXPECTS:     [1]:DWord = Left operand (class)
  4916. //              [2]:DWord = Right operand (class reference)
  4917. // RETURNS:     eax       = Left operand if left is derived from right, else error
  4918.  
  4919. procedure _ClsAs(AClass,VMT: Pointer); {&USES ecx,edx} {&FRAME-}
  4920. asm
  4921.                 mov     eax,AClass
  4922.                 test    eax,eax
  4923.                 jz      @@RET
  4924.                 mov     edx,VMT
  4925.                 mov     ecx,[eax].clVTable
  4926.               @@1:
  4927.                 cmp     ecx,edx
  4928.                 je      @@RET
  4929.                 mov     ecx,[ecx].vtParent
  4930.                 test    ecx,ecx
  4931.                 jnz     @@1
  4932.                 add     esp,@Uses
  4933.                 mov     al,reInvalidCast
  4934.                 jmp     RtlError
  4935.               @@RET:
  4936. end;
  4937.  
  4938. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ TOBJECT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  4939.  
  4940. constructor TObject.Create;
  4941. begin
  4942. end;
  4943.  
  4944. destructor TObject.Destroy;
  4945. begin
  4946. end;
  4947.  
  4948. procedure TObject.CleanupInstance; {&USES ebx} {&FRAME-}
  4949. asm
  4950.                 mov     ebx,Self                // ebx = @Memory
  4951.                 mov     ecx,[ebx]
  4952.               @@1:
  4953.                 mov     edx,[ecx].vtInitTable   // edx = RTTI
  4954.                 mov     ecx,[ecx].vtParent
  4955.                 test    edx,edx
  4956.                 jz      @@2
  4957.                 Call    _MemFinRec
  4958.               @@2:
  4959.                 test    ecx,ecx
  4960.                 jnz     @@1
  4961. end;
  4962.  
  4963. procedure TObject.DefaultHandler(var Message);
  4964. begin
  4965. end;
  4966.  
  4967. procedure TObject.Free; {&USES None} {&FRAME-}
  4968. asm
  4969.                 mov     ecx,Self
  4970.                 jecxz   @@RET
  4971.                 push    1
  4972.                 push    ecx
  4973.                 mov     eax,[ecx]
  4974.                 Call    DWord Ptr [eax].vtDestroy
  4975.               @@RET:
  4976. end;
  4977.  
  4978. class function TObject.NewInstance: TObject; {&USES edi} {&Frame-}
  4979. asm
  4980.                 mov     ecx,Self
  4981.                 mov     edx,[ecx].vtInstanceSize
  4982.                 push    edx
  4983.                 Call    _MemNew
  4984.                 push    eax
  4985.                 cld
  4986.                 mov     edi,eax
  4987.                 mov     eax,ecx
  4988.                 stosd                                   { VMT pointer  }
  4989.                 mov     ecx,edx
  4990.                 xor     eax,eax                         { Clear object }
  4991.                 shr     ecx,2
  4992.                 and     dl,11b
  4993.                 dec     ecx
  4994.                 rep     stosd
  4995.                 mov     cl,dl
  4996.                 rep     stosb
  4997.                 pop     eax
  4998. end;
  4999.  
  5000. procedure TObject.FreeInstance; {&USES None} {&FRAME-}
  5001. asm
  5002.                 push    Self                    // [1]:Pointer = @Self
  5003.                 Call    CleanupInstance
  5004.                 push    Self                    // [1]:Pointer = @Memory
  5005.                 Call    _MemFree
  5006. end;
  5007.  
  5008. class function TObject.InitInstance(Instance: Pointer): TObject; {&USES edi} {&FRAME-}
  5009. asm
  5010.                 cld
  5011.                 mov     eax,Self                { VMT address }
  5012.                 mov     edi,Instance
  5013.                 stosd                           { VMT pointer (offset = 0)  }
  5014.                 mov     ecx,[eax].vtInstanceSize
  5015.                 xor     eax,eax
  5016.                 push    ecx
  5017.                 shr     ecx,2
  5018.                 dec     ecx
  5019.                 rep     stosd
  5020.                 pop     ecx
  5021.                 and     ecx,3
  5022.                 rep     stosb
  5023.                 mov     edi,Instance
  5024. end;
  5025.  
  5026. function TObject.ClassType: TClass; {&USES None} {&FRAME-}
  5027. asm
  5028.                 mov     eax,Self
  5029.                 mov     eax,[eax].clVTable
  5030. end;
  5031.  
  5032. class function TObject.ClassName: ShortString; {&USES esi,edi} {&FRAME-}
  5033. asm
  5034.                 cld
  5035.                 mov     edx,Self
  5036.                 mov     edi,@Result
  5037.                 mov     esi,[edx].vtClassName
  5038.                 movzx   ecx,[esi].Byte
  5039.                 inc     ecx
  5040.                 rep     movsb
  5041. end;
  5042.  
  5043. class function TObject.ClassNameIs(const Name: String): Boolean; {&USES esi} {&FRAME-}
  5044. asm
  5045.                 mov     esi,Name
  5046.                 mov     edx,Self
  5047.                 test    esi,esi
  5048.                 mov     al,0
  5049.                 jz      @@RET
  5050.                 mov     edx,[edx].vtClassName
  5051.                 movzx   ecx,[edx].Byte
  5052.                 cmp     ecx,[esi-4]
  5053.                 jne     @@RET
  5054.                 dec     esi
  5055.               @@1:
  5056.                 mov     ah,[edx+ecx]
  5057.                 xor     ah,[esi+ecx]
  5058.                 and     ah,0DFh
  5059.                 jne     @@RET
  5060.                 dec     ecx
  5061.                 jnz     @@1
  5062.                 inc     eax
  5063.               @@RET:
  5064. end;
  5065.  
  5066. class function TObject.ClassParent: TClass; {&USES None} {&FRAME-}
  5067. asm
  5068.                 mov     eax,Self
  5069.                 mov     eax,[eax].vtParent
  5070. end;
  5071.  
  5072. class function TObject.InstanceSize: Longint; {&USES None} {&FRAME-}
  5073. asm
  5074.                 mov     eax,Self
  5075.                 mov     eax,[eax].vtInstanceSize
  5076. end;
  5077.  
  5078. class function TObject.ClassInfo: Pointer; {&USES None} {&FRAME-}
  5079. asm
  5080.                 mov     eax,Self
  5081.                 mov     eax,[eax].vtTypeInfo
  5082. end;
  5083.  
  5084. class function TObject.MethodAddress(const Name: ShortString): Pointer; {&USES ebx,esi,edi} {&FRAME-}
  5085. asm
  5086.                 mov     eax,Self
  5087.                 mov     edi,Name
  5088.               @@1:
  5089.                 mov     esi,[eax].vtMethodTable
  5090.                 test    esi,esi
  5091.                 jz      @@Parent
  5092.                 movzx   ecx,[esi].TMethodTable.Count
  5093.                 add     esi,TMethodTable.Entries
  5094.               @@2:
  5095.                 movzx   edx,[esi].TMethodEntry.Name.Byte
  5096.                 cmp     dl,[edi]
  5097.                 je      @@CmpName
  5098.               @@3:
  5099.                 mov     dl,[esi].TMethodEntry.Name.Byte
  5100.                 lea     esi,[esi+edx].TMethodEntry.Name[1]
  5101.                 loop    @@2
  5102.               @@Parent:
  5103.                 mov     eax,[eax].vtParent
  5104.                 test    eax,eax
  5105.                 jne     @@1
  5106.                 jmp     @@RET           // Not found, return nil
  5107. // Lengths are equal, compare names themselves ignoring letter case
  5108.               @@CmpName:
  5109.                 mov     bl,[esi+edx].TMethodEntry.Name.Byte
  5110.                 xor     bl,[edi+edx]
  5111.                 and     bl,$DF
  5112.                 jne     @@3
  5113.                 dec     edx
  5114.                 jnz     @@CmpName
  5115.                 mov     eax,[esi].TMethodEntry.Address
  5116.               @@RET:
  5117. end;
  5118.  
  5119. class function TObject.MethodName(Address: Pointer): ShortString; {&USES ebx,esi,edi} {&FRAME-}
  5120. asm
  5121.                 cld
  5122.                 mov     eax,Self
  5123.                 mov     edx,Address
  5124.                 mov     edi,@Result
  5125.               @@1:
  5126.                 mov     esi,[eax].vtMethodTable
  5127.                 test    esi,esi
  5128.                 jz      @@Parent
  5129.                 movzx   ecx,[esi].TMethodTable.Count
  5130.                 add     esi,TMethodTable.Entries
  5131.               @@2:
  5132.                 cmp     edx,[esi].TMethodEntry.Address
  5133.                 je      @@Found
  5134.               @@3:
  5135.                 movzx   ebx,[esi].TMethodEntry.Name.Byte
  5136.                 lea     esi,[esi+ebx].TMethodEntry.Name[1]
  5137.                 loop    @@2
  5138.               @@Parent:
  5139.                 mov     eax,[eax].vtParent
  5140.                 test    eax,eax
  5141.                 jne     @@1
  5142.                 mov     [edi],al        // Not found, return ''
  5143.                 jmp     @@RET
  5144.               @@Found:
  5145.                 add     esi,TMethodEntry.Name
  5146.                 movzx   ecx,[esi].Byte
  5147.                 inc     ecx
  5148.                 rep     movsb
  5149.               @@RET:
  5150. end;
  5151.  
  5152. function TObject.FieldAddress(const Name: ShortString): Pointer; {&USES ebx,esi,edi} {&FRAME-}
  5153. asm
  5154.                 mov     eax,Self
  5155.                 mov     edi,Name
  5156.                 mov     eax,[eax].clVTable
  5157.                 xor     edx,edx
  5158.               @@1:
  5159.                 mov     esi,[eax].vtFieldTable
  5160.                 test    esi,esi
  5161.                 jz      @@Parent
  5162.                 movzx   ecx,[esi].TFieldTable.Count
  5163.                 add     esi,TFieldTable.Entries
  5164.               @@2:
  5165.                 mov     dl,[esi].TFieldEntry.Name.Byte
  5166.                 cmp     dl,[edi]
  5167.                 je      @@CmpName
  5168.               @@3:
  5169.                 lea     esi,[esi+edx].TFieldEntry.Name[1]
  5170.                 loop    @@2
  5171.               @@Parent:
  5172.                 mov     eax,[eax].vtParent
  5173.                 test    eax,eax
  5174.                 jne     @@1
  5175.                 jmp     @@RET           // Not found, return nil
  5176.               @@4:
  5177.                 mov     dl,[esi].TFieldEntry.Name.Byte
  5178.                 jmp     @@3
  5179. // Lengths are equal, compare names themselves ignoring letter case
  5180.               @@CmpName:
  5181.                 mov     bl,[esi+edx].TFieldEntry.Name.Byte
  5182.                 xor     bl,[edi+edx]
  5183.                 and     bl,$DF
  5184.                 jne     @@4
  5185.                 dec     edx
  5186.                 jnz     @@CmpName
  5187.                 mov     eax,Self
  5188.                 add     eax,[esi].TFieldEntry.Ofs
  5189.               @@RET:
  5190. end;
  5191.  
  5192. class function TObject.InheritsFrom(AClass: TClass): Boolean; {&USES None} {&FRAME-}
  5193. asm
  5194.                 mov     eax,Self
  5195.                 mov     ecx,AClass
  5196.               @@1:
  5197.                 cmp     eax,ecx
  5198.                 je      @@2
  5199.                 mov     eax,[eax].vtParent
  5200.                 test    eax,eax
  5201.                 jnz     @@1
  5202.                 jmp     @@RET           // Not found, return False
  5203.               @@2:
  5204.                 mov     al,1
  5205.               @@RET:
  5206. end;
  5207.  
  5208. procedure TObject.Dispatch(var Message); {&USES None} {&FRAME-}
  5209. asm
  5210.                 mov     eax,Message
  5211.                 mov     ecx,Self
  5212.                 mov     eax,[eax]
  5213.                 test    eax,eax
  5214.                 jl      @@Default
  5215.                 push    eax                     // Index
  5216.                 push    [ecx].clVTable.Longint  // VMT@
  5217.                 Call    GetDynaMethod
  5218.                 je      @@1
  5219.               @@Default:
  5220.                 mov     eax,[ecx]
  5221.                 mov     eax,[eax].vtDefaultHandler
  5222.               @@1:
  5223.                 push    Message                 // [1]:Message
  5224.                 push    ecx                     // Self
  5225.                 Call    eax
  5226. end;
  5227.  
  5228. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ 80X87 NUMERIC FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  5229.  
  5230. const
  5231.   CWChop: Word = (IC_Affine   shl sCW_IC) or    // Affine mode
  5232.                  (RC_To_Zero  shl sCW_RC) or    // Round towards 0
  5233.                  (PC_Extended shl sCW_PC) or    // Round to extended
  5234.                                   mCW_PM  or    // Masked
  5235.                                   mCW_UM  or    // Masked
  5236.                                   mCW_OM  or    // Masked
  5237.                                   mCW_ZM  or    // Masked
  5238.                                   mCW_DM  or    // Masked
  5239.                                   mCW_IM ;      // Masked
  5240.   C0_5: Single = 0.5;
  5241.   C1:   Single = 1.0;
  5242.   PI_Mul_2: Extended = 6.28318530717958648;     // 2*PI (SIN,COS period)
  5243.  
  5244. // Trunc standard function
  5245. // EXPECTS:     ST(0)   = Argument
  5246. // RETURNS:     eax     = Result
  5247.  
  5248. procedure _Trunc; assembler; {&USES None} {&FRAME-}
  5249. var
  5250.   TempLong: Longint;
  5251.   CtrlWord: Word;
  5252. asm
  5253.                 fstcw   CtrlWord        // Save control word
  5254.                 fldcw   CWChop          // Set Rounding towards zero
  5255.                 fistp   TempLong        // Save ST(0) as 32-bit integer
  5256.                 fldcw   CtrlWord        // Restore previous control word
  5257.                 fwait                   // Wait for result
  5258.                 mov     eax,TempLong    // Return Longint result in eax
  5259. end;
  5260.  
  5261. // Round standard function
  5262. // COMMENTS: Coprocessor has a special rounding mode:
  5263. // rounding to nearest. However, it rounds numbers ending
  5264. // with .5 in a very strange way: towards even, so
  5265. // Round(4.5) = 4 (not 5 as one expects to be). That is
  5266. // why this routine does not use this mode.
  5267. // EXPECTS:     ST(0)   = Argument
  5268. // RETURNS:     eax     = Result
  5269.  
  5270. procedure _Round; assembler; {&USES None} {&FRAME-}
  5271. var
  5272.   TempLong: Longint;
  5273.   TempWord: Word;
  5274. asm
  5275.         ftst                            // X ? 0
  5276.         fnstsw   ax                     // SW -> AX
  5277.         sahf                            // AH -> FLAGS
  5278.         ja      @@1
  5279.         fsub    C0_5                    // X <= 0  -> X := X - 0.5
  5280.         jmp     @@Trunc
  5281.       @@1:
  5282.         fadd    C0_5                    // X > 0   -> X := X + 0.5
  5283.       @@Trunc:
  5284.         fstcw   TempWord                // Save control word
  5285.         fldcw   CWChop                  // Set Rounding towards zero
  5286.         fistp   TempLong                // Save ST(0) as 32-bit integer
  5287.         fldcw   TempWord                // Restore previous control word
  5288.         fwait                           // Wait for result
  5289.         mov     eax,TempLong            // Return Longint result in eax
  5290. end;
  5291.  
  5292. // Int standard function
  5293. // EXPECTS:     ST(0) = Argument
  5294. // RETURNS:     ST(0) = Result
  5295.  
  5296. procedure _Int; assembler; {&USES None} {&FRAME-}
  5297. var
  5298.   CtrlWord: Word;
  5299. asm
  5300.                 fstcw   CtrlWord        // Save control word
  5301.                 fldcw   CWChop          // Set Rounding toward zero
  5302.                 frndint                 // Round st to integer
  5303.                 fldcw   CtrlWord        // Restore previous control word
  5304. end;
  5305.  
  5306. // Frac standard function
  5307. // EXPECTS:      ST(0) = Argument
  5308. // RETURNS:      ST(0) = Result
  5309.  
  5310. procedure _Frac; assembler; {&USES None} {&FRAME-}
  5311. var
  5312.   CtrlWord: Word;
  5313. asm
  5314.                 fstcw   CtrlWord        // Save control word
  5315.                 fldcw   CWChop          // Set Rounding toward zero
  5316.                 fld     st              // st = st(1) = argument
  5317.                 frndint                 // Round st to integer
  5318.                 fsubp   st(1),st        // st := st(1)-st ; pop
  5319.                 fldcw   CtrlWord        // Restore previous control word
  5320. end;
  5321.  
  5322. // Sqrt standard function
  5323. // EXPECTS:     ST(0) = Argument
  5324. // RETURNS:     ST(0) = Result
  5325.  
  5326. procedure _Sqrt; {&USES None} {&FRAME-}
  5327. asm
  5328.                 fsqrt                   // st := Sqrt(st)
  5329. end;
  5330.  
  5331. // _Sin:  Sin standard function
  5332. // Cos:  Cos standard function
  5333. // _ATan: ArcTan standard function
  5334. // _Ln:   Ln standard function
  5335. // _Exp:  Exp standard function
  5336. // EXPECTS:     ST(0) = Argument
  5337. // RETURNS:     ST(0) = Result
  5338.  
  5339. // COMMENTS: The range of allowable inputs for FSIN and FCOS cannot
  5340. // exceed 2^63. If input is out of range, FSIN will leave NCP stack
  5341. // unchanged, and set C2 bit in the status word
  5342. // RETURNS:     CF = 1 if FSIN/FCOS operation is successful
  5343.  
  5344. procedure ChkResult; {&USES eax} {&FRAME-}
  5345. asm
  5346.                 fstsw   ax                      // SW -> AX
  5347.                 or      ah,mCF                  // Return CF=1
  5348.                 sahf                            // C2 -> PF
  5349.                 jnp     @@RET
  5350.                 fld     PI_Mul_2                // Load period
  5351.                 fxch    st(1)                   // ST(0) = X, ST(1) = 2*PI
  5352.               @@1:
  5353.                 fprem1                          // Reduce the input modulo 2*PI
  5354.                 fstsw   ax                      // SW -> AX
  5355.                 sahf                            // C2 -> PF
  5356.                 jp      @@1
  5357.                 fstp    st(1)                   // Discard 2*PI from stack
  5358.                 fdiv    st(1),st                // Obtain result
  5359.                 clc
  5360.               @@RET:
  5361. end;
  5362.  
  5363. procedure _Sin; {&USES None} {&FRAME-}
  5364. asm
  5365.               @@1:
  5366.                 fsin                            // Partial Sine
  5367.                 Call    ChkResult
  5368.                 jnc     @@1
  5369. end;
  5370.  
  5371. procedure _Cos; {&USES None} {&FRAME-}
  5372. asm
  5373.               @@1:
  5374.                 fcos                            // Partial Cosine
  5375.                 Call    ChkResult
  5376.                 jnc     @@1
  5377. end;
  5378.  
  5379. procedure _ATan; {&USES None} {&FRAME-}
  5380. asm                                             // FLD Mem4r is faster than FLD1
  5381.                 fld     C1                      // ST(0) := 1
  5382.                 fpatan                          // ArcTan(ST(1)/ST(0))
  5383. end;
  5384.  
  5385. // Ln(X) = Ln(2) * Log2(X)
  5386.  
  5387. procedure _Ln; {&USES None} {&FRAME-}
  5388. asm
  5389.                 fldln2
  5390.                 fxch    st(1)
  5391.                 fyl2x
  5392. end;
  5393.  
  5394. // Exp(X) = 2^(X * Log2(E))
  5395.  
  5396. // COMMENTS: The basic limitation of FX2M1 is that it accepts parameters
  5397. // only in the range -0.5 <= X <= 0.5. So we must reduce the parameter
  5398. // to that range.
  5399.  
  5400. procedure _Exp; assembler; {&USES None } {&FRAME-}
  5401. var
  5402.   TempWord: Word;
  5403. asm
  5404.                 fstcw   TempWord                // Save old control word
  5405.                 fldcw   CWNear                  // Set rounding mode to nearest
  5406.                 fldl2e                          // ST(0) := Log2(E)
  5407.                 fmul    st,st(1)                // ST(0) := X * Log2(E)
  5408.                 fst     st(1)                   // ST(1) := ST(0)
  5409.                 frndint                         // Round towards nearest
  5410.                 fsub    st(1),st                // Now -0.5 <= X <= 0.5
  5411.                 fxch
  5412.                                                 // ST(0) := X, ST(1)=Int part
  5413.                 f2xm1                           // ST(0) := 2^ST(0) - 1
  5414.                 fadd    C1                      // add bias
  5415.                 fscale                          // ST(0) := ST(0) * 2^ST(1)
  5416.                 fstp    st(1)
  5417.                 fldcw   TempWord                // Restore previous control word
  5418. end;
  5419.  
  5420. // Converts Real to Extended
  5421.  
  5422. procedure _Real2Ext(Src: Pointer); assembler; {&USES eax,ebx} {&FRAME-}
  5423. var
  5424.   Ext: ExtRec;
  5425. asm
  5426.                 mov     ebx,Src
  5427.                 mov     al,[ebx]
  5428.                 test    al,al
  5429.                 je      @@Zero
  5430.                 mov     ah,[ebx+5]              // Sign
  5431.                 and     ah,80h
  5432.                 add     ax,3F7Eh
  5433.                 mov     Ext.ER_Exponent,ax
  5434.                 mov     al,[ebx+1]
  5435.                 shl     eax,24
  5436.                 mov     Ext.ER_Significand0.Longint,eax
  5437.                 mov     eax,[ebx+2]
  5438.                 or      eax,80000000h
  5439.                 mov     Ext.ER_Significand2.Longint,eax
  5440.                 fld     Ext
  5441.                 jmp     @@RET
  5442.               @@Zero:
  5443.                 fldz
  5444.               @@RET:
  5445. end;
  5446.  
  5447. // Converts Extended to Real
  5448.  
  5449. procedure _Ext2Real(Dest: Pointer); {&USES eax,ebx,ecx} {&FRAME-}
  5450. asm
  5451.                 sub     esp,4*3
  5452.                 fstp    TByte Ptr [esp]
  5453.                 pop     eax
  5454.                 pop     ebx
  5455.                 pop     ecx
  5456.                 shr     eax,24
  5457.                 adc     al,0
  5458.                 adc     ebx,0
  5459.                 adc     cx,0
  5460.                 jo      @@ERROR
  5461.                 add     ebx,ebx
  5462.                 add     cx,cx
  5463.                 rcr     ebx,1
  5464.                 shr     cx,1
  5465.                 sub     cx,3F7Eh
  5466.                 jg      @@1
  5467.                 xor     eax,eax         // Zero
  5468.                 xor     ebx,ebx
  5469.                 xor     ecx,ecx
  5470.               @@1:
  5471.                 test    ch,ch
  5472.                 jg      @@ERROR
  5473.                 mov     ch,al
  5474.                 mov     eax,Dest
  5475.                 mov     [eax],cx
  5476.                 mov     [eax+2],ebx
  5477.                 jmp     @@RET
  5478.               @@ERROR:
  5479.                 add     esp,@Uses
  5480.                 mov     al,reOverflow
  5481.                 jmp     RtlError
  5482.               @@RET:
  5483. end;
  5484.  
  5485. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ DIRECTORY HANDLING ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  5486.  
  5487. // Converts either Pascal string or PChar path to PChar path name
  5488. // EXPECTS:     esi     = Source buffer
  5489. //              edi     = Output buffer
  5490. //              bl      = Bit 6 = 0: Pascal string / 1: PChar
  5491.  
  5492. const
  5493.   cpShortString = 0;
  5494.   cpPChar       = $40;
  5495.  
  5496. procedure ConvertPath; {&USES None} {&FRAME-}
  5497. asm
  5498.                 cld
  5499.                 test    esi,esi
  5500.                 jz      @@2
  5501.                 mov     ecx,PATH_BUFFER_SIZE-1
  5502.                 test    bl,cpPChar              // Is it PASCAL style string ?
  5503.                 jnz     @@1                     // No, ASCIIZ
  5504.                 lodsb                           // Yes, get string length
  5505.                 movzx   ecx,al
  5506.                 jecxz   @@2
  5507.               @@1:
  5508.                 lodsb                           // Copy name
  5509.                 test    al,al
  5510.                 jz      @@2
  5511.                 stosb
  5512.                 loop    @@1
  5513.               @@2:
  5514.                 mov     al,0                    // Terminate name with #0
  5515.                 stosb
  5516. end;
  5517.  
  5518. // procedure ChDir(S: String);
  5519. // procedure MkDir(S: String);
  5520. // procedure RmDir(S: String);
  5521. // Sets InOutRes <> 0 if error occurred
  5522. // EXPECTS:      S      = function # (ChDir = 0, MkDir = 2, RmDir = 3)
  5523. //               AL     = Source string
  5524.  
  5525. procedure DoDirFunction(S: Pointer); assembler; {&USES ALL} {&FRAME-}
  5526. var
  5527.   Path: array [1..PATH_BUFFER_SIZE] of Byte;
  5528. const
  5529.   ProcTable: array[0..2] of Pointer = (@SysDirSetCurrent, @SysDirCreate, @SysDirDelete);
  5530. asm
  5531.                 mov     ebx,eax
  5532.                 mov     esi,S
  5533.                 lea     edi,Path        // Convert String -> PChar
  5534.                 push    edi             // [1]:PChar = Current Dir
  5535.                 Call    ConvertPath
  5536.                 and     ebx,3Fh
  5537.                 Call    ProcTable[ebx*4].Pointer
  5538.                 test    eax,eax
  5539.                 jz      @@RET
  5540.                 Call    SetInOutRes
  5541.               @@RET:
  5542. end;
  5543.  
  5544. procedure _DirCh; {&USES None} {&FRAME-}
  5545. asm
  5546.                 mov     al,0+cpShortString
  5547.                 jmp     DoDirFunction
  5548. end;
  5549.  
  5550. procedure _DirChPCh; {&USES None} {&FRAME-}
  5551. asm
  5552.                 mov     al,0+cpPChar
  5553.                 jmp     DoDirFunction
  5554. end;
  5555.  
  5556. procedure _DirMk; {&USES None} {&FRAME-}
  5557. asm
  5558.                 mov     al,1+cpShortString
  5559.                 jmp     DoDirFunction
  5560. end;
  5561.  
  5562. procedure _DirMkPCh; {&USES None} {&FRAME-}
  5563. asm
  5564.                 mov     al,1+cpPChar
  5565.                 jmp     DoDirFunction
  5566. end;
  5567.  
  5568. procedure _DirRm; {&USES None} {&FRAME-}
  5569. asm
  5570.                 mov     al,2+cpShortString
  5571.                 jmp     DoDirFunction
  5572. end;
  5573.  
  5574. procedure _DirRmPCh; {&USES None} {&FRAME-}
  5575. asm
  5576.                 mov     al,2+cpPChar
  5577.                 jmp     DoDirFunction
  5578. end;
  5579.  
  5580. // GetDir standard procedure
  5581. // procedure GetDir(D: Byte, var S: String);
  5582. // Drive number (0=default, 1=A, 2=B ...)
  5583.  
  5584. procedure _DirGet(Drive: Byte; S: Pointer; SLen: Longint); assembler; {&USES ALL} {&FRAME-}
  5585. var
  5586.   Path: array [1..PATH_BUFFER_SIZE] of Byte;
  5587. asm
  5588.                 movzx   eax,Drive
  5589.                 lea     edi,Path
  5590.                 push    eax                     // [1]:DWord = Drive
  5591.                 push    edi                     // [2]:PChar = Path
  5592.                 Call    SysDirGetCurrent
  5593.                 mov     esi,edi
  5594.                 mov     edi,S
  5595.                 mov     ecx,SLen                // Copy PChar =>  String
  5596.                 xor     ebx,ebx
  5597.                 cld
  5598.               @@1:
  5599.                 lodsb
  5600.                 test    al,al
  5601.                 je      @@2
  5602.                 inc     ebx
  5603.                 mov     [edi+ebx],al
  5604.                 loop    @@1
  5605.               @@2:
  5606.                 mov     [edi],bl                // Write String length byte
  5607. end;
  5608.  
  5609. procedure _DirGetL(Drive: Byte; var LStr: Pointer); assembler; {&USES ALL} {&FRAME-}
  5610. var
  5611.   Path: array [1..PATH_BUFFER_SIZE] of Byte;
  5612. asm
  5613.                 movzx   eax,Drive
  5614.                 lea     edi,Path
  5615.                 push    eax                     // [1]:DWord = Drive
  5616.                 push    edi                     // [2]:PChar = Path
  5617.                 Call    SysDirGetCurrent
  5618.                 Call    PCharLength             // edi = PChar dir
  5619.                 push    LStr                    // [1]:Pointer = LStr
  5620.                 push    edi                     // [2]:Pointer = Src
  5621.                 push    eax                     // [3]:Longint = Length
  5622.                 Call    _LStrPacked
  5623. end;
  5624.  
  5625. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ ERROR CHECK ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  5626.  
  5627. // Checks for stack overflow. This procedure is called on
  5628. // entry to any procedure or function compiled in the $S+ state
  5629.  
  5630. procedure _StkChk(LocalSize: Longint); {&USES None} {&FRAME-}
  5631. asm
  5632. {$IFNDEF WIN32}
  5633.                 cmp     ExitCode,RTE_Stack_Overflow
  5634.                 je      @@RET                   // Prevent re-raising error
  5635.                 xchg    eax,LocalSize           // Size of the subprogram's
  5636.                 add     eax,4*1024              // local data allocated on
  5637.                 sub     eax,esp                 // stack; add extra "SAFE" 4K
  5638.                 jae     @@ERROR
  5639.                 neg     eax
  5640.                 cmp     esp,fs:[8]              // Tib_PStackLimit
  5641.                 jae     @@ERROR
  5642.                 cmp     eax,fs:[4]              // Tib_PStack
  5643.                 jae     @@OK
  5644.               @@ERROR:
  5645.                 pop     eax
  5646.                 push    RTE_Stack_Overflow      // [1]:Error code
  5647.                 push    eax                     // Return address
  5648.                 jmp     _RunError
  5649.               @@OK:
  5650.                 mov     eax,LocalSize           // Restore EAX
  5651.               @@RET:
  5652. {$ENDIF}
  5653. end;
  5654.  
  5655. // Probes each stack page allocated for the caller routine
  5656. // Equivalent to
  5657. //      SUB  ESP,LocalSize
  5658. // but makes sure that stack does not fall out of the guard page
  5659.  
  5660. procedure _StkPrb(LocalSize: Longint); {&USES None} {&FRAME-}
  5661. asm
  5662.                 push    ecx
  5663.                 push    edx
  5664.                 push    eax
  5665.                 mov     ecx,esp
  5666.                 mov     eax,LocalSize[4*3]
  5667.                 sub     eax,5*4         // 3 used registers, Ret@, local size
  5668.                 mov     edx,4*1024      // Page size
  5669.               @@1:
  5670.                 cmp     eax,edx
  5671.                 jae     @@2
  5672.                 mov     edx,eax
  5673.               @@2:
  5674.                 sub     esp,edx
  5675.                 mov     [esp],eax       // Probe this page
  5676.                 sub     eax,edx
  5677.                 jnz     @@1
  5678.               @@RET:
  5679.                 push    [ecx+12].Longint// Return address
  5680.                 mov     eax,[ecx+0]     // Restore all registers
  5681.                 mov     edx,[ecx+4]
  5682.                 mov     ecx,[ecx+8]
  5683.                 PopArgs 0
  5684. end;
  5685.  
  5686. // Arithmetic overflow error. This procedure is called by statement code
  5687. // compiled in $Q+ state when an integer arithmetic operation overflow occured.
  5688. // Terminates program with Arithmetic Overflow run-time error.
  5689.  
  5690. procedure _ErrOverflow; {&USES None} {&FRAME-}
  5691. asm
  5692.                 mov     al,reIntOverflow
  5693.                 jmp     RtlError
  5694. end;
  5695.  
  5696. // Range check error. This procedure is called by statement code compiled
  5697. // in $R+ state when one of the following conditions are met:
  5698. //   ■ The index of the array is out of range.
  5699. //   ■ Assignment out-of-ranges value to variable.
  5700. //   ■ Pass out-of-range value as a parameter.
  5701.  
  5702. procedure _ErrRange; {&USES None} {&FRAME-}
  5703. asm
  5704.                 mov     al,reRangeError
  5705.                 jmp     RtlError
  5706. end;
  5707.  
  5708. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ PARAMETER COPYING SUPPORT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  5709.  
  5710. const
  5711.   ptEnd         = 0;            // End of parameter list
  5712.   ptString      = 1;            // String
  5713.   ptSet         = 2;            // Set
  5714.   ptObject      = 3;            // Object with VMT
  5715.   ptOther       = 4;            // All other parameters
  5716.  
  5717. // The data structure for one parameter is as follows:
  5718.  
  5719. type
  5720.   ParmRec = record
  5721.     ParmType:  Byte;            // ParameterType (see values above)
  5722.     Filler:    Byte;            // Filler to the word boundary
  5723.     Src:       Word;            // Parameter EBP relative offset
  5724.     Dest:      Longint;         // Destination EBP relative offset
  5725.     Size:      Longint;         // Size of the parameter in bytes
  5726.   end;
  5727.  
  5728.   ParmObj = record              // This fields are present for Object with VMT
  5729.     VmtPtrOfs: Longint;         // Virtual Pointer Offset
  5730.     VmtOfs:    Longint;         // VMT address
  5731.   end;
  5732.  
  5733. procedure _CopyParms(Data: Pointer); {&USES eax,ecx,edx,esi,edi} {&FRAME-}
  5734. asm
  5735.                 cld
  5736.                 mov     edx,Data
  5737.               @@1:
  5738.                 xor     eax,eax
  5739.                 add     al,[edx].ParmRec.ParmType
  5740.                 jz      @@Done
  5741.                 movzx   esi,[edx].ParmRec.Src
  5742.                 mov     edi,[edx].ParmRec.Dest
  5743.                 mov     ecx,[edx].ParmRec.Size
  5744.                 mov     esi,[ebp+esi]
  5745.                 add     edi,ebp
  5746.                 jmp     DWord Ptr @@Jmp_Table[eax*4-4]
  5747. @@Jmp_Table:    dd      OFFSET @@String
  5748.                 dd      OFFSET @@Set
  5749.                 dd      OFFSET @@Object
  5750.                 dd      OFFSET @@Other
  5751.  
  5752.               @@String:
  5753.                 dec     ecx             // Size-1 = Max Length
  5754.                 lodsb
  5755.                 cmp     al,cl
  5756.                 jb      @@2
  5757.                 mov     al,cl
  5758.               @@2:
  5759.                 stosb                   // String Length
  5760.                 mov     ecx,eax         // ah = 0
  5761.                 jmp     @@3
  5762.  
  5763.               @@Object:
  5764.                 mov     ah,1            // Object with virtual methods
  5765.                 jmp     @@Other
  5766.  
  5767.               @@Set:
  5768.                 mov     al,ch           // Starting set offset
  5769.                 and     ecx,0FFh        // Set Size
  5770.                 add     esi,eax         // ah = 0
  5771.  
  5772.               @@Other:
  5773.                 mov     al,cl
  5774.               @@3:
  5775.                 shr     ecx,2
  5776.                 and     al,11b
  5777.                 rep     movsd
  5778.                 mov     cl,al
  5779.                 rep     movsb
  5780.                 add     edx,TYPE ParmRec
  5781.                 test    ah,ah           // Object with virtual methods ?
  5782.                 jz      @@1             // No, copy next parameter
  5783.                                         // Yes, setup VmtPtr within object
  5784.                 mov     edi,[edx-TYPE ParmRec].ParmRec.Dest
  5785.                 add     edi,[edx].ParmObj.VmtPtrOfs
  5786.                 mov     eax,[edx].ParmObj.VmtOfs
  5787.                 mov     [edi+ebp],eax
  5788.                 add     edx,TYPE ParmObj
  5789.                 jmp     @@1
  5790.               @@Done:
  5791. end;
  5792.  
  5793. // Allocates space for open array parameter. It's actual size is known
  5794. // only at run time.
  5795.  
  5796. // ┌────────────────┐     ┌────────────────┐     ┌────────────────┐     }
  5797. // │     Params     │     │    Params      │     │                │     }
  5798. // ├────────────────┤     ├────────────────┤     │                │     }
  5799. // │    Return@     │     │    Return@     │     │                │     }
  5800. // ├────────────────┤     ├────────────────┤     │     Array      │     }
  5801. // │ Used Registers │     │ Used Registers │     │                │     }
  5802. // └────────────────┘<ESP ├────────────────┤     │                │     }
  5803. //                        │                │     │                │     }
  5804. //                        │                │     ├────────────────┤<ESP }
  5805. //                        │    Reserved    │     │    Return@     │     }
  5806. //                        │                │     ├────────────────┤     }
  5807. //                        │                │     │ Used Registers │     }
  5808. //                        └────────────────┘<ESP>└────────────────┘     }
  5809.  
  5810.  
  5811.  
  5812. procedure _CopyOpArr(ElementSize,Src: Longint); {&USES ecx,edx,esi,edi} {&FRAME-}
  5813. asm
  5814.                 mov     esi,Src         // Calculate array size in bytes
  5815.                 mov     eax,[esi+ebp]   // Array Size - 1
  5816.                 inc     eax             // Array Size
  5817.                 imul    ElementSize     // Array Size * Element Size
  5818.                 mov     edx,esi
  5819.                 mov     esi,esp
  5820.                 lea     ecx,[eax+3]
  5821.                 and     cl,NOT 11b      // Align to the DWord boundary
  5822.                 sub     ecx,@Params
  5823.                 jnc     @@1
  5824.                 xor     ecx,ecx
  5825.               @@1:
  5826.                 cmp     ecx,4*1024-64
  5827.                 jae     @@2
  5828.                 sub     esp,ecx
  5829.                 jmp     @@3
  5830.               @@2:
  5831.                 push    ecx             // Probe the stack if the allocation is greater than 4K
  5832.                 Call    _StkPrb
  5833.               @@3:
  5834.                 mov     edi,esp         // Copy used registers and return address
  5835.                 mov     ecx,(@Uses+4) / 4
  5836.                 cld
  5837.                 rep     movsd
  5838.                 mov     esi,edi         // Copy Array itself
  5839.                 xchg    esi,[edx+ebp+4] // Set new array address
  5840.                 mov     ecx,eax         // edi = Copied array address
  5841.                 and     al,11b
  5842.                 shr     ecx,2
  5843.                 rep     movsd
  5844.                 mov     cl,al
  5845.                 rep     movsb
  5846.                 PopArgs 0
  5847. end;
  5848.  
  5849. procedure _CopyOpArrChk(ElementSize,Src: Longint); {&USES ecx,edx,esi,edi} {&FRAME-}
  5850. asm
  5851.                 mov     esi,Src         // Calculate array size in
  5852.                 mov     eax,[esi+ebp]   // Array Size - 1
  5853.                 inc     eax             // Array Size
  5854.                 imul    ElementSize     // Array Size * Element Size
  5855.                 mov     edx,esi
  5856.                 mov     esi,esp
  5857.                 lea     ecx,[eax+3]
  5858.                 and     cl,NOT 11b      // Align to the DWord boundary
  5859.                 sub     ecx,@Params
  5860.                 jnc     @@1
  5861.                 xor     ecx,ecx
  5862.               @@1:
  5863.                 push    ecx             // [1]:Longint = LocalSize
  5864.                 Call    _StkChk
  5865.                 cmp     ecx,4*1024-64
  5866.                 jae     @@2
  5867.                 sub     esp,ecx
  5868.                 jmp     @@3
  5869.               @@2:
  5870.                 push    ecx             // Probe the stack if the allocation is greater than 4K
  5871.                 Call    _StkPrb
  5872.               @@3:
  5873.                 mov     edi,esp         // Copy used registers and return address
  5874.                 mov     ecx,(@Uses+4) / 4
  5875.                 cld
  5876.                 rep     movsd
  5877.                 mov     esi,edi         // Copy Array itself
  5878.                 xchg    esi,[edx+ebp+4] // Set new array address
  5879.                 mov     ecx,eax         // edi = Copied array address
  5880.                 and     al,11b
  5881.                 shr     ecx,2
  5882.                 rep     movsd
  5883.                 mov     cl,al
  5884.                 rep     movsb
  5885.                 PopArgs 0
  5886. end;
  5887.  
  5888. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ TEXT FILE I/O ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  5889.  
  5890. // InOutProc: Performs Text file InOutFunc
  5891. // FlushProc: Performs Text file FlushFunc
  5892. // EXPECTS:     ebx     = @ of the file variable
  5893. // Important!
  5894. // If Operation failed then InOutRes will hold error code
  5895.  
  5896. procedure InOutProc; {&USES ALL} {&FRAME-}
  5897. asm
  5898.                 push    ebx             // [1]:Pointer = Text File variable
  5899.                 Call    [ebx].TextRec.InOutFunc
  5900.                 test    eax,eax
  5901.                 jz      @@RET
  5902.                 Call    SetInOutRes
  5903.               @@RET:
  5904. end;
  5905.  
  5906. procedure FlushProc; {&USES eax,ebx,ecx,edx,esi,edi} {&FRAME-}
  5907. asm
  5908.                 cmp     [ebx].TextRec.FlushFunc,0  // Is FlushFunc installed ?
  5909.                 jz      @@RET                      // No, skip
  5910.                 push    ebx                        // [1]:Pointer = Text File variable
  5911.                 Call    [ebx].TextRec.FlushFunc
  5912.                 test    eax,eax
  5913.                 jz      @@RET
  5914.                 Call    SetInOutRes
  5915.               @@RET:
  5916. end;
  5917.  
  5918. // Read from Text file
  5919. // EXPECTS:     ebx     = @ of the file variable
  5920. //              eax     = @ of the Callback procedure
  5921. // Upon CallBack procedure entry:
  5922. //          ecx,edi     = ecx,edi of the _TxtRead Caller
  5923. //              ebx     = Ending buffer pointer
  5924. //              esi     = Current buffer pointer
  5925. // RETURNS:     ZF      = 1 if no error
  5926. // CallBack:    eax     = @ of the restart entry point or 0 if
  5927. //                        the operation is completed.
  5928. //              esi     = @ of the char just after last processed
  5929.  
  5930. procedure _TxtRead; {&USES edx,esi} {&FRAME-}
  5931. asm
  5932.                 Call    TestInOutRes              // If InOutRes <> 0 then
  5933.                 jnz     @@RET                     // do nothing (ZF=0: error)
  5934.                 cmp     [ebx].TextRec.Mode,fmInput// File must be opened for
  5935.                 je      @@OK                      // input
  5936.                 mov     eax,RTE_File_Not_Open_For_Input
  5937.                 Call    SetInOutRes
  5938.                 jmp     @@RET                     // It's no so,report an error
  5939.                                                   // ZF=0: error
  5940.               @@OK:
  5941.                 mov     esi,[ebx].TextRec.BufPos  // Is I/O Buffer exhausted ?
  5942.                 cmp     esi,[ebx].TextRec.BufEnd
  5943.                 jne     @@1
  5944.  
  5945.               @@Read_File:                        // Yes, Read from text file
  5946.                 Call    InOutProc
  5947.                 mov     esi,[ebx].TextRec.BufPos
  5948.                 cmp     esi,[ebx].TextRec.BufEnd  // EOF ?
  5949.                 je      @@RET                     // Yes, exit (ZF=1: success)
  5950.  
  5951.               @@1:
  5952.                 push    ebx
  5953.                 mov     edx,[ebx].TextRec.BufPtr  // ebx := Ending pointer
  5954.                 mov     ebx,[ebx].TextRec.BufEnd  // esi := Current pointer
  5955.                 add     esi,edx
  5956.                 add     ebx,edx
  5957.                 cld
  5958.                 Call    eax                       // Call CallBack procedure
  5959.                 pop     ebx
  5960.                 sub     esi,edx
  5961.                 mov     [ebx].TextRec.BufPos,esi
  5962.                 test    eax,eax                   // Has CallBack read all the
  5963.                 jne     @@Read_File               // buffer? Yes, @@Read_File
  5964.               @@RET:                              // ZF=1: success
  5965. end;
  5966.  
  5967. // Write blanks to the text file
  5968. // EXPECTS:     ebx     = @ of the file variable
  5969. //              edx     = Number of blanks to write
  5970. // RETURNS:     ZF      = 1 if no error
  5971.  
  5972. procedure _TxtWBlanks; {&USES eax,ecx,edx,esi,edi} {&FRAME-}
  5973. asm
  5974.                 Call    TestInOutRes               // If InOutRes <> 0 then
  5975.                 jnz     @@RET                      // do nothing (ZF=0: error)
  5976.                 cmp     [ebx].TextRec.Mode,fmOutput// file must be opened for
  5977.                 je      @@1                        // output
  5978.                 mov     eax,RTE_File_Not_Open_For_Output
  5979.                 Call    SetInOutRes
  5980.                 jmp     @@RET                      // It's no so,report an error
  5981.                                                    // ZF=0: error
  5982.               @@1:
  5983.                 mov     ecx,[ebx].TextRec.BufSize
  5984.                 mov     edi,[ebx].TextRec.BufPos
  5985.                 sub     ecx,edi
  5986.                 sub     edx,ecx                    // edx = Remaining blanks to
  5987.                 jae     @@2                        // write
  5988.                 add     ecx,edx                    // ecx = Blanks# to write
  5989.                 xor     edx,edx
  5990.  
  5991.               @@2:
  5992.                 mov     esi,[ebx].TextRec.BufPtr   // Position in the buffer to
  5993.                 add     edi,esi                    // write to
  5994.                 mov     eax,'    '
  5995.                 cld
  5996.                 push    ecx
  5997.                 shr     ecx,2                      // FAST STOS
  5998.                 rep     stosd
  5999.                 pop     ecx
  6000.                 and     ecx,11b
  6001.                 rep     stosb
  6002.                 sub     edi,esi
  6003.                 mov     [ebx].TextRec.BufPos,edi
  6004.                 cmp     edi,[ebx].TextRec.BufSize  // Is buffer full ?
  6005.                 jne     @@3                        // No, @@3
  6006.                 Call    InOutProc                  // Yes,
  6007.                                                    // Flush Buffer to the file
  6008.               @@3:
  6009.                 test    edx,edx                    // Have all blanks written ?
  6010.                 jne     @@1                        // No, @@1
  6011.                                                    // Yes, ZF=1: success
  6012.               @@RET:
  6013. end;
  6014.  
  6015. // Write Data to Text file
  6016. // EXPECTS:     ebx     = @ of the file variable
  6017. //              esi     = Offset of the data to write
  6018. //              eax     = Number of bytes to write
  6019. // RETURNS:     ZF      = 1 if no error
  6020.  
  6021. procedure _TxtWBuf; {&USES eax,ecx,edx,esi,edi} {&FRAME-}
  6022. asm
  6023.                 Call    TestInOutRes               // If InOutRes <> 0 then
  6024.                 jnz     @@RET                      // do nothing (ZF=0: error)
  6025.                 cmp     [ebx].TextRec.Mode,fmOutput// file must be opened for
  6026.                 je      @@1                        // output
  6027.                 mov     eax,RTE_File_Not_Open_For_Output
  6028.                 Call    SetInOutRes
  6029.                 jmp     @@RET                      // It's no so,report an error
  6030.                                                    // ZF=0: error
  6031.               @@1:
  6032.                 mov     ecx,[ebx].TextRec.BufSize
  6033.                 mov     edi,[ebx].TextRec.BufPos
  6034.                 sub     ecx,edi                    // eax = Remaining bytes to
  6035.                 sub     eax,ecx                    // write
  6036.                 jae     @@2                        // ecx = # of bytes to copy
  6037.                 add     ecx,eax
  6038.                 xor     eax,eax
  6039.  
  6040.               @@2:
  6041.                 mov     edx,[ebx].TextRec.BufPtr
  6042.                 add     edi,edx                    // Position in the buffer to
  6043.                 cld                                // write to
  6044.                 push    ecx
  6045.                 shr     ecx,2
  6046.                 rep     movsd                      // FAST MOVS
  6047.                 pop     ecx
  6048.                 and     ecx,11b
  6049.                 rep     movsb
  6050.                 sub     edi,edx
  6051.                 mov     [ebx].TextRec.BufPos,edi
  6052.                 cmp     edi,[ebx].TextRec.BufSize  // Is buffer full ?
  6053.                 jne     @@3                        // No, @@3
  6054.                 Call    InOutProc                  // Yes,
  6055.                                                    // Flush Buffer to the file
  6056.               @@3:
  6057.                 test    eax,eax                    // Have all data written ?
  6058.                 jnz     @@1                        // No, @@1
  6059.                                                    // Yes, ZF=1: success
  6060.               @@RET:
  6061. end;
  6062.  
  6063. // _TxtRLn: ReadLn standard procedure
  6064. // _TxtWLn: WriteLn standard procedure
  6065. // _TxtREnd: End of read
  6066. // _TxtWEnd: End of write
  6067.  
  6068.  
  6069. procedure _TxtRLn(FileVar: Pointer); assembler; {&USES eax,ebx,ecx,edi} {&FRAME-}
  6070.  
  6071. // EXPECTS:     esi     = Current Buffer Pointer
  6072. //              ebx     = Ending Buffer Offset
  6073.  
  6074. procedure Read_Callback; {&USES None } {&FRAME-}
  6075. asm
  6076.               @@1:
  6077.                 lodsb                           // Get Character
  6078.                 cmp     al,ccLF                 // Is it LF ?
  6079.                 je      @@Done                  // Yes, @@Done
  6080.                 cmp     al,ccCR                 // Is it CR ?
  6081.                 je      @@Done                  // Yes, @@CR
  6082.                 cmp     al,ccEOF                // Is it EOF
  6083.                 je      @@EOF                   // Yes, @@EOF
  6084.                 cmp     esi,ebx                 // Is buffer exhausted ?
  6085.                 jne     @@1                     // No, get next character
  6086.                 mov     eax,OFFSET @@1          // Yes, exit with restart point
  6087.                 jmp     @@RET                   // in @@1
  6088.  
  6089.               @@CR:
  6090.                 mov     eax,OFFSET @@2
  6091.                 cmp     esi,ebx                 // Is buffer exhausted ?
  6092.                 je      @@RET                   // Yes, exit with restart
  6093.               @@2:                              // point in @@2
  6094.                 lodsb                           // Get next char
  6095.                 cmp     al,ccLF                 // Is it LF (CR/LF encounted) ?
  6096.                 je      @@Done                  // Yes, @@Done
  6097.               @@EOF:
  6098.                 dec     esi                     // Return character back
  6099.               @@Done:
  6100.                 xor     eax,eax
  6101.               @@RET:
  6102. end;
  6103. asm // _TxtRLn body
  6104.                 mov     ebx,FileVar
  6105.                 mov     eax,OFFSET Read_Callback
  6106.                 Call    _TxtRead
  6107.                 jnz     @@RET
  6108.                 Call    FlushProc
  6109.               @@RET:
  6110. end;
  6111.  
  6112. procedure _TxtWLn(FileVar: Pointer); assembler; {&USES eax,ebx,esi} {&FRAME-}
  6113. const
  6114.   {$IFDEF LINUX}
  6115.   NewLineStr: Char = ccLF;
  6116.   {$ELSE}
  6117.   NewLineStr: array[0..1] of Char = ccCR + ccLF;
  6118.   {$ENDIF}
  6119. asm
  6120.                 mov     ebx,FileVar
  6121.                 mov     esi,OFFSET NewLineStr   // Write CF/LF to the buffer
  6122.                 mov     eax,TYPE NewLineStr
  6123.                 Call    _TxtWBuf                // Has error occured?
  6124.                 jnz     @@RET                   // Yes, skip flush
  6125.                 Call    FlushProc               // Do flush
  6126.               @@RET:
  6127. end;
  6128.  
  6129. procedure _TxtREnd(FileVar: Pointer); {&USES ebx} {&FRAME-}
  6130. asm
  6131.                 Call    TestInOutRes            // Is previous I/O operation
  6132.                 jnz     @@RET                   // terminated successfully ?
  6133.                 mov     ebx,FileVar             // Yes,
  6134.                 Call    FlushProc               // Do flush
  6135.               @@RET:
  6136. end;
  6137.  
  6138. procedure _TxtWEnd(FileVar: Pointer); {&USES ebx} {&FRAME-}
  6139. asm
  6140.                 Call    TestInOutRes            // Is previous operation
  6141.                 jnz     @@RET                   // terminated successfully ?
  6142.                 mov     ebx,FileVar             // Yes,
  6143.                 Call    FlushProc               // Do flush
  6144.               @@RET:
  6145. end;
  6146.  
  6147. // Read standard procedure (String)
  6148. // Important!:  Doesn't pop file variable address
  6149.  
  6150. procedure _TxtRStr(FileVar,S: Pointer; SLen: Longint); assembler; {&USES eax,ebx,ecx,edi} {&FRAME-}
  6151.  
  6152. // EXPECTS:     esi     = Current Buffer Pointer
  6153. //              ebx     = Ending Buffer Offset
  6154.  
  6155. procedure Read_Callback; {&USES None} {&FRAME-}
  6156. asm
  6157.               @@1:
  6158.                 lodsb
  6159.                 cmp     al,ccLF                 // Is it LF ?
  6160.                 je      @@2                     // Yes, @@2
  6161.                 cmp     al,ccCR         // CR
  6162.                 je      @@skip
  6163.                 cmp     al,ccEOF        // EOF
  6164.                 je      @@2
  6165.                 stosb
  6166.               @@skip:
  6167.                 cmp     esi,ebx
  6168.                 loopne  @@1
  6169.                 jecxz   @@Done
  6170.                 mov     eax,OFFSET @@1  // Restart entry = @@1
  6171.                 jmp     @@RET
  6172.               @@2:
  6173.                 dec     esi
  6174.               @@Done:
  6175.                 xor     eax,eax
  6176.               @@RET:
  6177. end;
  6178. asm // _TxtRStr body
  6179.                 mov     ebx,FileVar
  6180.                 mov     edi,S
  6181.                 mov     ecx,SLen
  6182.                 push    edi                     // Save string start@
  6183.                 inc     edi                     // Reserve 1 byte for length
  6184.                 mov     eax,OFFSET Read_Callback
  6185.                 Call    _TxtRead
  6186.                 mov     eax,edi
  6187.                 pop     edi
  6188.                 sub     eax,edi                 // eax := Length+1
  6189.                 dec     eax
  6190.                 stosb                           // Write string length
  6191.                 PopArgs @Params -  TYPE FileVar
  6192. end;
  6193.  
  6194. // Write standard procedure (String)
  6195. // Important!:  Doesn't pop file variable address
  6196.  
  6197. procedure _TxtWStr(FileVar,S: Pointer; Width: Longint); {&USES eax,ebx,edx,esi} {&FRAME-}
  6198. asm
  6199.                 mov     ebx,FileVar
  6200.                 mov     esi,S
  6201.                 movzx   eax,Byte Ptr [esi]      // eax := Length(S)
  6202.                 mov     edx,Width               // If Length(S) < Width then
  6203.                 sub     edx,eax                 // S will be right-justified
  6204.                 jle     @@1
  6205.                 Call    _TxtWBlanks             // Write blanks before string
  6206.               @@1:
  6207.                 test    eax,eax
  6208.                 jz      @@RET
  6209.                 inc     esi                     // Skip Length byte
  6210.                 Call    _TxtWBuf
  6211.               @@RET:
  6212.                 PopArgs @Params -  TYPE FileVar
  6213. end;
  6214.  
  6215. // Write standard procedure (Long String)
  6216. // Important!:  Doesn't pop file variable address
  6217.  
  6218. procedure _TxtWLStr (FileVar,S: Pointer; Width: Longint); {&USES eax,ebx,edx,esi} {&FRAME-}
  6219. asm
  6220.                 mov     ebx,FileVar
  6221.                 mov     eax,S
  6222.                 mov     esi,eax
  6223.                 test    eax,eax
  6224.                 jz      @@0
  6225.                 mov     eax,[esi-SHS].TStrRec.Length
  6226.               @@0:
  6227.                 mov     edx,Width               // If Length(S) < Width then
  6228.                 sub     edx,eax                 // S will be right-justified
  6229.                 jle     @@1
  6230.                 Call    _TxtWBlanks             // Write blanks before string
  6231.               @@1:
  6232.                 test    eax,eax
  6233.                 jz      @@RET
  6234.                 Call    _TxtWBuf
  6235.               @@RET:
  6236.                 PopArgs @Params -  TYPE FileVar
  6237. end;
  6238.  
  6239. // Write standard procedure (Boolean)
  6240. // Important!:  Doesn't pop file variable address
  6241.  
  6242. procedure _TxtWBool(FileVar: Pointer; Value: Byte; Width: Longint); assembler; {&USES None} {&FRAME+}
  6243. const
  6244.   TrueStr:  String[4] = 'TRUE' ;
  6245.   FalseStr: String[5] = 'FALSE';
  6246. asm
  6247.                 push    FileVar                 // [1]:Pointer = File Variable
  6248.                 cmp     Value,0
  6249.                 jnz     @@True
  6250.                 push    OFFSET FalseStr         // [2]:Pointer = String Offset
  6251.                 jmp     @@1
  6252.               @@True:
  6253.                 push    OFFSET TrueStr
  6254.               @@1:
  6255.                 push    Width                   // [3]:Longint = Width
  6256.                 Call    _TxtWStr
  6257.                 add     esp,4                   // _TxtWStr doesn't pop FileVar
  6258.                 PopArgs @Params - TYPE FileVar
  6259. end;
  6260.  
  6261. // Read standard procedure (PChar)
  6262. // Important!:  Doesn't pop file variable address
  6263.  
  6264. procedure _TxtRPChar(FileVar,S: Pointer; SLen: Longint); assembler; {&USES eax,ebx,ecx,edi} {&FRAME-}
  6265.  
  6266. // EXPECTS:     esi     = Current Buffer Pointer
  6267. //              ebx     = Ending Buffer Offset
  6268.  
  6269. procedure Read_Callback; {&USES None} {&FRAME-}
  6270. asm
  6271.                 jecxz   @@3
  6272.               @@1:
  6273.                 lodsb
  6274.                 cmp     al,ccLF                 // Is it LF ?
  6275.                 je      @@2                     // Yes, @@2
  6276.                 cmp     al,ccCR
  6277.                 je      @@skip
  6278.                 cmp     al,ccEOF
  6279.                 je      @@2
  6280.                 stosb
  6281.               @@skip:
  6282.                 cmp     esi,ebx
  6283.                 loopne  @@1
  6284.                 jecxz   @@3
  6285.                 mov     eax,OFFSET @@1          // Restart entry = @@1
  6286.                 jmp     @@RET
  6287.               @@2:
  6288.                 dec     esi
  6289.               @@3:
  6290.                 xor     eax,eax
  6291.               @@RET:
  6292. end;
  6293. asm //_TxtRPChar body
  6294.                 mov     ebx,FileVar
  6295.                 mov     edi,S
  6296.                 mov     ecx,SLen
  6297.                 mov     eax,OFFSET Read_Callback
  6298.                 Call    _TxtRead
  6299.                 xor     eax,eax
  6300.                 stosb
  6301.                 PopArgs @Params - TYPE FileVar
  6302. end;
  6303.  
  6304. // Write standard procedure (PChar)
  6305. // Important!:  Doesn't pop file variable address
  6306.  
  6307. procedure _TxtWPChar(FileVar,S: Pointer; Width: Longint); {&USES ALL} {&FRAME-}
  6308. asm
  6309.                 mov     eax,S
  6310.                 test    eax,eax
  6311.                 jz      @@1
  6312.                 mov     edi,eax
  6313.                 Call    PCharLength
  6314.               @@1:
  6315.                 mov     ebx,FileVar
  6316.                 test    eax,eax
  6317.                 js      @@2
  6318.                 mov     edx,Width
  6319.                 sub     edx,eax
  6320.                 jle     @@2
  6321.                 Call    _TxtWBlanks
  6322.               @@2:
  6323.                 test    eax,eax
  6324.                 jz      @@RET
  6325.                 mov     esi,S
  6326.                 Call    _TxtWBuf
  6327.               @@RET:
  6328.                 PopArgs @Params - TYPE FileVar
  6329. end;
  6330.  
  6331. // Read standard procedure (integer)
  6332. // RETURNS:     eax = Integer value
  6333. // Important!:  Doesn't pop file variable address
  6334.  
  6335. procedure _TxtRInt(FileVar: Pointer); assembler; {&USES ebx,ecx,edi} {&FRAME-}
  6336.  
  6337. // EXPECTS:     esi     = Current Buffer Pointer
  6338. //              ebx     = Ending Buffer Offset
  6339.  
  6340. procedure Read_Callback; {&USES None} {&FRAME-}
  6341. asm
  6342.               @@1:
  6343.                 lodsb                           // Skip blanks and
  6344.                 cmp     al,' '                  // control characters
  6345.                 ja      @@Copy
  6346.                 cmp     al,ccEOF                // EOF ?
  6347.                 je      @@3                     // Put it back and exit
  6348.                 cmp     esi,ebx                 // Is buffer exhausted ?
  6349.                 jne     @@1                     // No, get next char
  6350.                 mov     eax,OFFSET @@1          // Yes, Restart entry = @@1
  6351.                 jmp     @@RET
  6352.  
  6353.               @@2:                              // Read string with number
  6354.                 lodsb                           // and copy it to the buffer
  6355.                 cmp     al,' '
  6356.                 jbe     @@3
  6357.  
  6358.               @@Copy:
  6359.                 stosb
  6360.                 cmp     esi,ebx
  6361.                 loopne  @@2
  6362.                 jecxz   @@Done
  6363.                 mov     eax,OFFSET @@2          // Restart entry = @@2
  6364.                 jmp     @@RET
  6365.  
  6366.               @@3:
  6367.                 dec     esi                     // Return back control char
  6368.               @@Done:
  6369.                 xor     eax,eax
  6370.               @@RET:
  6371. end;
  6372. var
  6373.   Buffer: array[0..31] of Byte;
  6374. asm // _TxtRInt body
  6375.                 mov     ebx,FileVar
  6376.                 mov     eax,OFFSET Read_Callback
  6377.                 mov     ecx,TYPE Buffer
  6378.                 lea     edi,Buffer
  6379.                 push    edi
  6380.                 Call    _TxtRead
  6381.                 mov     ecx,edi
  6382.                 pop     edi                     // ecx := String Length
  6383.                 sub     ecx,edi                 // Is anything being read ?
  6384.                 jz      @@Zero                  // No, return zero
  6385.                 Call    Str2Int                 // Yes, Convert String to
  6386.                 jc      @@ERROR                 // Integer (Result in EAX)
  6387.                 jecxz   @@RET
  6388.               @@ERROR:
  6389.                 mov     eax,RTE_Invalid_Numeric_Format
  6390.                 Call    SetInOutRes
  6391.               @@Zero:
  6392.                 xor     eax,eax
  6393.               @@RET:
  6394.                 PopArgs @Params - Type FileVar
  6395. end;
  6396.  
  6397. // Write standard procedure (integer)
  6398. // Important!:  Doesn't pop file variable address
  6399.  
  6400. procedure _TxtWInt(FileVar: Pointer; Value,Width: Longint); assembler; {&USES ALL} {&FRAME-}
  6401. var
  6402.   Buffer: array[0..31] of Byte;
  6403. asm
  6404.                 mov     eax,Value
  6405.                 mov     ebx,FileVar
  6406.                 mov     edx,Width
  6407.                 lea     edi,Buffer              // Allocate buffer
  6408.                 Call    Int2Str
  6409.                 mov     eax,ecx                 // Write blanks (if necessary)
  6410.                 sub     edx,ecx                 // Output is right-justified
  6411.                 jle     @@1                     // edx = Number of blanks
  6412.                 Call    _TxtWBlanks             // to write
  6413.               @@1:
  6414.                 lea     esi,Buffer              // esi <= buffer@
  6415.                 Call    _TxtWBuf
  6416.                 PopArgs @Params - Type FileVar
  6417. end;
  6418.  
  6419. // Read standard procedure (float)
  6420. // Important!:  Doesn't pop file variable adderss
  6421.  
  6422. procedure _TxtRFlt(FileVar: Pointer); assembler; {&USES ALL} {&FRAME-}
  6423.  
  6424. // EXPECTS:     esi     = Current Buffer Pointer
  6425. //              ebx     = Ending Buffer Offset
  6426.  
  6427. procedure Read_Callback; {&USES None} {&FRAME-}
  6428. asm
  6429.               @@1:
  6430.                 lodsb                           // Skip blanks and
  6431.                 cmp     al,' '                  // control characters
  6432.                 ja      @@Copy
  6433.                 cmp     al,ccEOF                // EOF ?
  6434.                 je      @@3                     // Put it back and exit
  6435.                 cmp     esi,ebx                 // Is buffer exhausted ?
  6436.                 jne     @@1                     // No, get next char
  6437.                 mov     eax,OFFSET @@1          // Yes, Restart entry = @@1
  6438.                 jmp     @@RET
  6439.  
  6440.               @@2:                              // Read string with number
  6441.                 lodsb                           // and copy it to the buffer
  6442.                 cmp     al,' '
  6443.                 jbe     @@3
  6444.  
  6445.               @@Copy:
  6446.                 stosb
  6447.                 cmp     esi,ebx
  6448.                 loopne  @@2
  6449.                 jecxz   @@Done
  6450.                 mov     eax,OFFSET @@2          // Restart entry = @@2
  6451.                 jmp     @@RET
  6452.  
  6453.               @@3:
  6454.                 dec     esi                     // Return back control char
  6455.               @@Done:
  6456.                 xor     eax,eax
  6457.               @@RET:
  6458. end;
  6459. var
  6460.   Buffer: array[0..79] of Byte;
  6461. asm
  6462.                 mov     ebx,FileVar
  6463.                 mov     eax,OFFSET Read_Callback
  6464.                 mov     ecx,TYPE Buffer
  6465.                 lea     edi,Buffer
  6466.                 push    edi
  6467.                 Call    _TxtRead
  6468.                 mov     ecx,edi
  6469.                 pop     edi                     // ecx := String Length
  6470.                 sub     ecx,edi                 // Is anything being read ?
  6471.                 jz      @@Zero                  // No, Return zero
  6472.                 Call    Str2Float               // Yes, Convert String to Float
  6473.                 jc      @@ERROR                 // Returns result in ST(0)
  6474.                 jecxz   @@RET
  6475.               @@ERROR:
  6476.                 mov     eax,RTE_Invalid_Numeric_Format
  6477.                 Call    SetInOutRes
  6478.                 fstp    st                      // Pop out ST(0)
  6479.               @@Zero:
  6480.                 fldz
  6481.                 wait                            // Wait for result
  6482.               @@RET:
  6483.                 PopArgs @Params - Type FileVar
  6484. end;
  6485.  
  6486. // Write standard procedure (float)
  6487. // EXPECTS:      ST(0) = Floating point value
  6488. // Important!:  Doesn't pop file variable adderss
  6489.  
  6490. procedure _TxtWFlt(FileVar: Pointer; Width,Dec: Longint); assembler; {&USES ALL} {&FRAME+}
  6491. var
  6492.   Buffer: array[0..63] of Byte;
  6493. asm
  6494.                 mov     ecx,Dec
  6495.                 test    ecx,ecx
  6496.                 jns     @@1
  6497.                 mov     ecx,8
  6498.                 sub     ecx,Width
  6499.                 cmp     ecx,-2
  6500.                 jle     @@1
  6501.                 mov     ecx,-2
  6502.               @@1:
  6503.                 lea     edi,Buffer              // Convert float in ST(0) to
  6504.                 Call    Float2Str               // string
  6505.                 mov     eax,ecx
  6506.                 mov     ebx,FileVar
  6507.                 mov     edx,Width               // Write blanks (if necessary)
  6508.                 sub     edx,ecx                 // Output is right-justified
  6509.                 jle     @@2                     // edx = Number of blanks
  6510.                 Call    _TxtWBlanks             // to write
  6511.               @@2:
  6512.                 lea     esi,Buffer              // esi := buffer@
  6513.                 Call    _TxtWBuf
  6514.                 PopArgs @Params - Type FileVar
  6515. end;
  6516.  
  6517. // Read standard procedure (Char)
  6518. // Important!:  Doesn't pop file variable address
  6519. // RETURNS:     al = Char
  6520.  
  6521. procedure _TxtRChar(FileVar: Pointer); {&USES ebx,edi} {&FRAME-}
  6522. asm
  6523.                 Call    TestInOutRes            // If InOutRes <> 0 then
  6524.                 jnz     @@EOF                   // return EOF
  6525.                 mov     ebx,FileVar
  6526.                 cmp     [ebx].TextRec.Mode,fmInput // Is file opened for Input?
  6527.                 jne     @@ERROR                 // No, error
  6528.                 mov     edi,[ebx].TextRec.BufPos
  6529.                 cmp     edi,[ebx].TextRec.BufEnd// Is buffer exhausted ?
  6530.                 jne     @@1                     // No, get from buffer
  6531.                 Call    InOutProc               // Yes, read from the file
  6532.                 mov     edi,[ebx].TextRec.BufPos// EOF ?
  6533.                 cmp     edi,[ebx].TextRec.BufEnd// Yes, return EOF character
  6534.                 je      @@EOF
  6535.  
  6536.               @@1:
  6537.                 inc     [ebx].TextRec.BufPos
  6538.                 add     edi,[ebx].TextRec.BufPtr// Get char from the buffer
  6539.                 mov     al,[edi]
  6540.                 jmp     @@RET
  6541.  
  6542.               @@ERROR:
  6543.                 mov     eax,RTE_File_Not_Open_For_Input
  6544.                 Call    SetInOutRes
  6545.  
  6546.               @@EOF:
  6547.                 mov     al,ccEOF
  6548.  
  6549.               @@RET:
  6550.                 PopArgs @Params - TYPE FileVar
  6551. end;
  6552.  
  6553. // Write standard procedure (Char)
  6554. // Important!:  Doesn't pop file variable address
  6555.  
  6556. procedure _TxtWChar(FileVar: Pointer; Value: Byte; Width: Longint); {&USES ALL} {&FRAME-}
  6557. asm
  6558.                 mov     ebx,FileVar
  6559.                 mov     edx,Width
  6560.                 dec     edx                     // Right-justify output
  6561.                 jle     @@1                     // edx := Number of blanks
  6562.                 Call    _TxtWBlanks             // to write
  6563.               @@1:                              // Is previous I/O operation
  6564.                 Call    TestInOutRes            // terminated successfully ?
  6565.                 jnz     @@RET                   // No, do nothing
  6566.                 cmp     [ebx].TextRec.Mode,fmOutput//Is file opened for Output?
  6567.                 jne     @@ERROR                 // No, report an error
  6568.                 inc     [ebx].TextRec.BufPos
  6569.                 mov     edi,[ebx].TextRec.BufPos
  6570.                 add     edi,[ebx].TextRec.BufPtr// Write char to the buffer
  6571.                 mov     dl,Value
  6572.                 mov     [edi-1],dl
  6573.                 mov     edx,[ebx].TextRec.BufSize
  6574.                 add     edx,[ebx].TextRec.BufPtr
  6575.                 cmp     edi,edx                 // Is buffer full ?
  6576.                 jne     @@RET
  6577.                 Call    InOutProc               // Yes, flush it to file
  6578.                 jmp     @@RET
  6579.               @@ERROR:
  6580.                 mov     eax,RTE_File_Not_Open_For_Output
  6581.                 Call    SetInOutRes
  6582.               @@RET:
  6583.                 PopArgs @Params - TYPE FileVar
  6584. end;
  6585.  
  6586. // _TxtSEoln    SeekEoln standard function
  6587. // _TxtSEof     SeekEof  standard function
  6588. // _TxtEoln     Eoln     standard function
  6589. // _TxtEof      Eof      standard function
  6590.  
  6591. const
  6592.   tsEof      = $0;
  6593.   tsEoln     = $1;
  6594.   tsSeekEof  = $2;
  6595.   tsSeekEoln = $3;
  6596.  
  6597. // EXPECTS:      ebx = File Variable address
  6598.  
  6599. procedure TextFile_Status; assembler; {&USES ecx,esi,edi} {&FRAME-}
  6600.  
  6601. // EXPECTS:      esi    = Current Buffer Pointer
  6602. //               ebx    = Ending Buffer Offset
  6603.  
  6604. procedure Read_Callback; {&USES None} {&FRAME-}
  6605. asm
  6606.               @@1:
  6607.                 lodsb
  6608.                 cmp     al,ccEOF
  6609.                 je      @@True
  6610.                 test    cl,01b          // EOL bit
  6611.                 jz      @@2
  6612.                 cmp     al,ccCR
  6613.                 je      @@1
  6614.                 cmp     al,ccLF                 // Is it LF ?
  6615.                 je      @@True                  // Yes, @@True
  6616.  
  6617.               @@2:
  6618.                 test    cl,10b          // SEEK bit
  6619.                 jz      @@False
  6620.                 cmp     al,' '
  6621.                 ja      @@False
  6622.                 cmp     esi,ebx
  6623.                 jne     @@1
  6624.                 mov     eax,OFFSET @@1  // Restart entry = @@1
  6625.                 jmp     @@RET
  6626.  
  6627.               @@False:
  6628.                 mov     ch,0            // Return false
  6629.               @@True:
  6630.                 dec     esi             // Return back control character
  6631.                 xor     eax,eax
  6632.               @@RET:
  6633. end;
  6634. asm // TextFile_Status body
  6635.                 mov     ch,1            // True
  6636.                 mov     eax,OFFSET Read_Callback
  6637.                 Call    _TxtRead
  6638.                 mov     al,ch
  6639. end;
  6640.  
  6641. procedure _TxtSEoln(FileVar: Pointer); {&USES ebx,ecx} {&FRAME-}
  6642. asm
  6643.                 mov     ebx,FileVar
  6644.                 mov     cl,tsSeekEoln
  6645.                 Call    TextFile_Status
  6646. end;
  6647.  
  6648. procedure _TxtSEof(FileVar: Pointer); {&USES ebx,ecx} {&FRAME-}
  6649. asm
  6650.                 mov     ebx,FileVar
  6651.                 mov     cl,tsSeekEof
  6652.                 Call    TextFile_Status
  6653. end;
  6654.  
  6655. procedure _TxtEoln(FileVar: Pointer); {&USES ebx,ecx} {&FRAME-}
  6656. asm
  6657.                 mov     ebx,FileVar
  6658.                 mov     cl,tsEoln
  6659.                 Call    TextFile_Status
  6660. end;
  6661.  
  6662. procedure _TxtEof(FileVar: Pointer); {&USES ebx,ecx} {&FRAME-}
  6663. asm
  6664.                 mov     ebx,FileVar
  6665.                 mov     cl,tsEof
  6666.                 Call    TextFile_Status
  6667. end;
  6668.  
  6669. // Forward declarations
  6670.  
  6671. procedure AppendFile; forward;
  6672. procedure _TxtFOpen(FileVar: Pointer); forward;
  6673.  
  6674. // Do Text File function call
  6675. // EXPECTS:     ebx     = Function offset within TextRec
  6676. //              edi     = Text file variable address
  6677. // RETURNS:     ZF      = 0 if error occurred
  6678.  
  6679. procedure Do_Function; {&USES ALL} {&FRAME-}
  6680. asm
  6681.                 and     ebx,7Fh
  6682.                 push    edi                     // [1]:Pointer = FileVar
  6683.                 Call    DWord Ptr [edi+ebx]
  6684.                 test    eax,eax
  6685.                 jz      @@RET
  6686.                 Call    SetInOutRes
  6687.               @@RET:
  6688. end;
  6689.  
  6690. // _TxtAssign: Assign standard procedure (String)
  6691. // _TxtAssignPCh: Assign standard procedure (PChar)
  6692. // procedure Assign( var F; String);
  6693. // String can be either ShortString, AnsiString or PChar
  6694.  
  6695. procedure Assign_Text; {&USES eax,ecx,edx} {&FRAME-}
  6696. asm
  6697.                 cld
  6698.                 xor     eax,eax                 // Fill in TextRec fields
  6699.                 mov     [edi].TextRec.Handle,eax
  6700.                 mov     [edi].TextRec.Mode,fmClosed
  6701.                 mov     [edi].TextRec.BufSize,TYPE TextRec.Buffer
  6702.                 mov     [edi].TextRec.BufPos,eax
  6703.                 mov     [edi].TextRec.BufEnd,eax
  6704.                 lea     edx,[edi].TextRec.Buffer
  6705.                 mov     [edi].TextRec.BufPtr,edx
  6706.                 mov     [edi].TextRec.OpenFunc,OFFSET _TxtFOpen
  6707.                 add     edi,TextRec.InOutFunc   // Wipe out user data
  6708.                 mov     ecx,(TextRec.Name-TextRec.InOutFunc) / 4
  6709.                 rep     stosd
  6710.                 Call    ConvertPath
  6711. end;
  6712.  
  6713. procedure _TxtAssignPCh(FileVar,S: Pointer); {&USES ebx,esi,edi} {&FRAME-}
  6714. asm
  6715.                 mov     bl,cpPChar              // bl: Flag
  6716.                 mov     esi,S
  6717.                 mov     edi,FileVar
  6718.                 Call    Assign_Text
  6719. end;
  6720.  
  6721. procedure _TxtAssign(FileVar,S: Pointer); {&USES ebx,esi,edi} {&FRAME-}
  6722. asm
  6723.                 mov     bl,cpShortString        // bl: Flag
  6724.                 mov     esi,S
  6725.                 mov     edi,FileVar
  6726.                 Call    Assign_Text
  6727. end;
  6728.  
  6729. // SetTextBuf standard procedure
  6730. // procedure SetTextBuf(var F:Text; var Buf [; Size: Longint]);
  6731.  
  6732. procedure _TxtSetBuf(FileVar,Buffer: Pointer; BufSize: Longint); {&USES eax,edi} {&FRAME-}
  6733. asm
  6734.                 mov     edi,FileVar             // Fill in Buffer@ and Length
  6735.                 mov     eax,BufSize             // fields
  6736.                 mov     [edi].TextRec.BufSize,eax
  6737.                 mov     eax,Buffer
  6738.                 mov     [edi].TextRec.BufPtr,eax
  6739.                 xor     eax,eax                 // Initialize BufPos, BufEnd
  6740.                 mov     [edi].TextRec.BufPos,eax
  6741.                 mov     [edi].TextRec.BufEnd,eax
  6742. end;
  6743.  
  6744. // _TxtReset:   Reset standard procedure
  6745. // _TxtRewrite: Rewrite standard procedure
  6746. // _TxtAppend:  Append standard procedure
  6747. // procedure Reset  (var F[:File; RecSize: Longint] );
  6748. // procedure Rewrite(var F[:File; RecSize: Longint] );
  6749. // procedure Append (var F: Text);
  6750.  
  6751. // EXPECTS:     edi     = File Variable address
  6752. //              eax     = Open Mode
  6753.  
  6754. procedure Text_Open; {&USES ebx} {&FRAME-}
  6755. asm
  6756.                 mov     ebx,[edi].TextRec.Mode
  6757.                 cmp     ebx,fmInput
  6758.                 je      @@Close
  6759.                 cmp     ebx,fmOutput
  6760.                 je      @@Close
  6761.                 cmp     ebx,fmClosed
  6762.                 je      @@SkipClose
  6763.                 mov     eax,RTE_File_Not_Assigned
  6764.                 Call    SetInOutRes
  6765.                 jmp     @@RET
  6766.  
  6767.               @@Close:
  6768.                 push    edi                     // [1]:Pointer = FileVar
  6769.                 Call    _TxtClose
  6770.  
  6771.               @@SkipClose:
  6772.                 xor     ebx,ebx
  6773.                 mov     [edi].TextRec.Mode,eax
  6774.                 mov     [edi].TextRec.BufPos,ebx
  6775.                 mov     [edi].TextRec.BufEnd,ebx
  6776.                 mov     bl,TextRec.OpenFunc
  6777.                 Call    Do_Function
  6778.                 jz      @@RET
  6779.                 mov     [edi].TextRec.Mode,fmClosed
  6780.               @@RET:
  6781. end;
  6782.  
  6783. procedure _TxtReset(FileVar: Pointer); {&USES eax,edi} {&FRAME-}
  6784. asm
  6785.                 mov     eax,fmInput
  6786.                 mov     edi,FileVar
  6787.                 Call    Text_Open
  6788. end;
  6789.  
  6790. procedure _TxtRewrite(FileVar: Pointer); {&USES eax,edi} {&FRAME-}
  6791. asm
  6792.                 mov     eax,fmOutput
  6793.                 mov     edi,FileVar
  6794.                 Call    Text_Open
  6795. end;
  6796.  
  6797. procedure _TxtAppend(FileVar: Pointer); {&USES eax,edi} {&FRAME-}
  6798. asm
  6799.                 mov     eax,fmInOut
  6800.                 mov     edi,FileVar
  6801.                 Call    Text_Open
  6802. end;
  6803.  
  6804. // _TxtFlush:   Flush standard procedure
  6805. // _TxtClose:   Close standard procedure
  6806. // procedure Close(var F );
  6807. // procedure Flush(var F: Text);
  6808.  
  6809. procedure Text_FlushClose; {&USES ebx} {&FRAME-}
  6810. asm
  6811.                 cmp     [edi].TextRec.Mode,fmInput
  6812.                 je      @@2
  6813.                 cmp     [edi].TextRec.Mode,fmOutput
  6814.                 je      @@1
  6815.                 mov     eax,RTE_File_Not_Open
  6816.                 Call    SetInOutRes
  6817.                 jmp     @@RET
  6818.               @@1:
  6819.                 mov     bl,TextRec.InOutFunc
  6820.                 Call    Do_Function
  6821.               @@2:
  6822.                 test    al,al                   // Flush ?
  6823.                 jz      @@RET                   // Yes, skip close
  6824.                 mov     bl,TextRec.CloseFunc    // No, it's Close, close file
  6825.                 Call    Do_Function
  6826.                 mov     [edi].TextRec.Mode,fmClosed
  6827.               @@RET:
  6828. end;
  6829.  
  6830. procedure _TxtFlush(FileVar: Pointer); {&USES eax,edi} {&FRAME-}
  6831. asm
  6832.                 mov     al,0                    // Flag: 0 = Flush
  6833.                 mov     edi,FileVar
  6834.                 Call    Text_FlushClose
  6835. end;
  6836.  
  6837. procedure _TxtClose(FileVar: Pointer); {&USES eax,edi} {&FRAME-}
  6838. asm
  6839.                 mov     al,1                    // Flag: 1 = Close
  6840.                 mov     edi,FileVar
  6841.                 Call    Text_FlushClose
  6842. end;
  6843.  
  6844. // Standart text file driver I/O procedures
  6845. // _TxtFOpen    Open file
  6846. // _TxtFRead    Read file
  6847. // _TxtFWrite   Write to disk file
  6848. // _TxtFClose   Close file
  6849. // RETURNS:     eax = Error code
  6850.  
  6851. procedure _TxtFRead(FileVar: Pointer); {&USES edi} {&FRAME-}
  6852. asm
  6853.                 mov     edi,FileVar
  6854.                 push    0                       // Bytes Read
  6855.                 mov     ecx,esp
  6856.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  6857.                 push    [edi].TextRec.BufPtr    // [2]:PChar = Buffer
  6858.                 push    [edi].TextRec.BufSize   // [3]:DWord = Count
  6859.                 push    ecx                     // [4]:DWord = @ByteRead
  6860.                 Call    SysFileRead
  6861.                 pop     ecx                     // Ignore actual
  6862.                 mov     [edi].TextRec.BufEnd,ecx
  6863.                 and     [edi].TextRec.BufPos,0  // eax = Error Code
  6864.  
  6865.                 cmp     eax,109                 // msg_Broken_Pipe
  6866.                 jne     @@RET
  6867.                 xor     eax,eax
  6868.               @@RET:
  6869. end;
  6870.  
  6871. procedure _TxtFWrite(FileVar: Pointer); {&USES None} {&FRAME-}
  6872. asm
  6873.                 mov     edx,FileVar
  6874.                 xor     eax,eax
  6875.                 xchg    eax,[edx].TextRec.BufPos
  6876.                 push    0                       // Actual
  6877.                 mov     ecx,esp
  6878.                 push    [edx].TextRec.Handle    // [1]:DWord = File Handle
  6879.                 push    [edx].TextRec.BufPtr    // [2]:PChar = Buffer
  6880.                 push    eax                     // [3]:DWord = Count
  6881.                 push    ecx                     // [4]:DWord = @ByteWrite
  6882.                 Call    SysFileWrite
  6883.                 pop     ecx                     // Ignore actual
  6884.               @@RET:
  6885. end;
  6886.  
  6887. procedure _TxtFClose(FileVar: Pointer); {&USES None} {&FRAME-}
  6888. asm
  6889.                 mov     eax,FileVar
  6890.                 push    [eax].TextRec.Handle    // [1]:DWord = File Handle
  6891.                 Call    SysFileClose
  6892. end;
  6893.  
  6894. procedure _TxtFOpen(FileVar: Pointer); {&USES ebx,esi,edi} {&FRAME-}
  6895. asm
  6896.                 mov     edi,FileVar
  6897.                 cmp     [edi].TextRec.Mode,fmInput // Output: StdOut Handle
  6898.                 je      @@Input
  6899.                 Call    SysFileStdOut
  6900.                 jmp     @@1
  6901.               @@Input:
  6902.                 Call    SysFileStdIn
  6903.               @@1:
  6904.                 mov     ecx,eax
  6905.                 lea     edx,[edi].TextRec.Name     // If name is empty then
  6906.                 cmp     [edx].Byte,0               // file will refer to StdIn
  6907.                 je      @@SkipOpen                 // or StdOut
  6908.                 push    OFFSET TextModeRead
  6909.                 Call    _GetTlsVar
  6910.                 mov     ecx,[eax]                  // TextModeRead
  6911.                 test    ecx,ecx
  6912.                 jnz     @@2
  6913.                 mov     cl,40h
  6914.               @@2:
  6915.                 mov     eax,[eax+4]                // TextModeReadWrite
  6916.                 test    eax,eax
  6917.                 jnz     @@3
  6918.                 mov     al,42h
  6919.               @@3:
  6920.                 cmp     [edi].TextRec.Mode,fmInOut
  6921.                 je      @@Open                     // Append
  6922.                 cmp     [edi].TextRec.Mode,fmInput
  6923.                 jne     @@Output                   // Rewrite
  6924.                 xchg    eax,ecx
  6925. // Reset -> Open existing file
  6926.               @@Open:
  6927.                 movzx   eax,al
  6928.                 push    0                       // Handle
  6929.                 mov     ecx,esp
  6930.                 push    edx                     // [1]:PChar = FileName
  6931.                 push    eax                     // [2]:DWord = Mode
  6932.                 push    ecx                     // [3]:DWord = @Handle
  6933.                 Call    SysFileOpen
  6934.                 pop     ecx                     // Handle
  6935.                 jmp     @@OpenDone
  6936. // Rewrite -> Create a file
  6937.               @@Output:
  6938.                 movzx   eax,al
  6939.                 push    0
  6940.                 mov     ecx,esp
  6941.                 push    edx                     // [1]:PChar = FileName
  6942.                 push    eax                     // [2]:DWord = Mode
  6943.                 push    0                       // [3]:DWord = Attr = Normal file
  6944.                 push    ecx                     // [4]:DWord = @Handle
  6945.                 Call    SysFileCreate
  6946.                 pop     ecx
  6947.               @@OpenDone:
  6948.                 test    eax,eax
  6949.                 jnz     @@RET                   // Error occurred
  6950. // EXPECTS: eax = File Handle
  6951.               @@SkipOpen:
  6952.                 mov     [edi].TextRec.Handle,ecx
  6953.                 mov     ebx,ecx
  6954.                 mov     eax,OFFSET _TxtFRead            // InOutFunc
  6955.                 xor     ecx,ecx                         // FlushFunc = None
  6956.                 cmp     [edi].TextRec.Mode,fmInput
  6957.                 je      @@Done
  6958.                 push    [edi].TextRec.Handle            // [1]:DWord = Handle
  6959.                 Call    SysFileIsDevice                 // Device ?
  6960.                 mov     dl,al
  6961.                 mov     eax,OFFSET _TxtFWrite           // InOutFunc
  6962.                 mov     ecx,eax                         // FlushFunc
  6963.                 test    dl,dl
  6964.                 jnz     @@Device
  6965.                 cmp     [edi].TextRec.Mode,fmInOut
  6966.                 je      @@Append
  6967.                 cmp     [edi].TextRec.Name.Byte,0       // For redirected StdOut
  6968.                 jz      @@Device
  6969.                 jmp     @@4
  6970.               @@Append:
  6971.                 Call    AppendFile
  6972.               @@4:
  6973.                 xor     ecx,ecx                         // FlushFunc = None
  6974.               @@Device:
  6975.                 mov     [edi].TextRec.Mode,fmOutput
  6976.               @@Done:
  6977.                 mov     [edi].TextRec.InOutFunc,eax
  6978.                 mov     [edi].TextRec.FlushFunc,ecx
  6979.                 mov     [edi].TextRec.CloseFunc,OFFSET _TxtFClose
  6980.                 xor     eax,eax                         // Error Code := 0
  6981.               @@RET:
  6982. end;
  6983.  
  6984. // Truncates the file at the current file position
  6985.  
  6986. function TruncateFile(FileHandle: Longint): Longint;
  6987. var
  6988.   FilePos: Longint;
  6989. begin
  6990.   Result := SysFileSeek(FileHandle, 0, 1, FilePos);
  6991.   if Result = 0 then
  6992.     Result := SysFileSetSize(FileHandle, FilePos);
  6993. end;
  6994.  
  6995. // Prepares Text File for appending.
  6996. // EXPECTS:     edi     = Offset of the file variable
  6997.  
  6998. procedure AppendFile; {&USES ALL} {&FRAME-}
  6999. asm
  7000. // Get File Size
  7001.                 push    0                       // Actual
  7002.                 mov     ecx,esp
  7003.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7004.                 push    0                       // [2]:DWord = Distance
  7005.                 push    2                       // [3]:DWord = Method (EOF)
  7006.                 push    ecx                     // [4]:DWord = @Actual
  7007.                 Call    SysFileSeek
  7008.                 pop     eax                     // File size
  7009. // Set File Pointer 128 bytes ahead of EOF (If possible)
  7010.                 sub     eax,TYPE TextRec.Buffer
  7011.                 jge     @@1
  7012.                 xor     eax,eax
  7013.               @@1:
  7014.                 push    0                       // Actual
  7015.                 mov     ecx,esp
  7016.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7017.                 push    eax                     // [2]:DWord = Distance
  7018.                 push    0                       // [3]:DWord = Method (Start file)
  7019.                 push    ecx                     // [4]:DWord = @Actual
  7020.                 Call    SysFileSeek
  7021.                 pop     eax
  7022. // Fill in the text file buffer
  7023.                 lea     edx,[edi].TextRec.Buffer// Fill buffer
  7024.                 push    0                       // Bytes Read
  7025.                 mov     ecx,esp
  7026.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7027.                 push    edx                     // [2]:PChar = Buffer
  7028.                 push    TYPE TextRec.Buffer     // [3]:DWord = Count
  7029.                 push    ecx                     // [4]:DWord = @ByteRead
  7030.                 Call    SysFileRead
  7031.                 pop     eax                     // Bytes Read
  7032.                 xor     edx,edx                 // Buffer pointer := 0
  7033.               @@2:
  7034.                 cmp     edx,eax                 // Is all buffer done ?
  7035.                 je      @@RET                   // Yes, exit
  7036.                 cmp     [edi].TextRec.Buffer[edx].Byte,ccEOF
  7037.                 je      @@EOF
  7038.                 inc     edx
  7039.                 jmp     @@2
  7040. // EOF is encountered
  7041.               @@EOF:
  7042.                 sub     edx,eax
  7043. // Set File Pointer again to EOF
  7044.                 push    0                       // Actual
  7045.                 mov     ecx,esp
  7046.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7047.                 push    edx                     // [2]:DWord = Distance
  7048.                 push    2                       // [3]:DWord = Method (EOF)
  7049.                 push    ecx                     // [4]:DWord = @Actual
  7050.                 Call    SysFileSeek
  7051.                 pop     eax                     // File size
  7052.                 push    [edi].TextRec.Handle
  7053.                 Call    TruncateFile
  7054.               @@RET:
  7055. end;
  7056.  
  7057. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ BINARY FILE ROUTINES ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  7058.  
  7059. // Erase standard procedure
  7060. // procedure Erase (Var F);
  7061.  
  7062. procedure _Erase(FileVar: Pointer); {&USES eax,ecx,edx} {&FRAME-}
  7063. asm
  7064.                 mov     edx,FileVar
  7065.                 add     edx,TextRec.Name.Longint
  7066.                 push    edx                     // [1]:PChar = FileName
  7067.                 Call    SysFileDelete
  7068.                 test    eax,eax
  7069.                 jz      @@RET
  7070.                 Call    SetInOutRes
  7071.               @@RET:
  7072. end;
  7073.  
  7074. // Rename standard procedure
  7075. // procedure Rename (var F; NewName: String);
  7076.  
  7077. procedure RenameFile; assembler; {&USES eax,ecx,edi} {&FRAME+}
  7078. var
  7079.   Buffer: array[1..PATH_BUFFER_SIZE] of Byte;
  7080. asm
  7081.                 cld
  7082.                 lea     edi,Buffer
  7083.                 mov     ecx,TYPE TextRec.Name - 1
  7084.                 test    bl,bl                   // PChar ?
  7085.                 jnz     @@1                     // Yes
  7086.                 lodsb                           // No, String: Get length
  7087.                 movzx   ecx,al
  7088.                 jecxz   @@2
  7089.               @@1:                              // Copy new name
  7090.                 lodsb
  7091.                 test    al,al
  7092.                 jz      @@2
  7093.                 stosb
  7094.                 loop    @@1
  7095.               @@2:
  7096.                 mov     al,0                    // Terminate int with #0
  7097.                 stosb
  7098.                 lea     esi,[edx].TextRec.Name
  7099.                 lea     edi,Buffer
  7100.                 push    esi                     // [1]:PChar = Old Name
  7101.                 push    edi                     // [2]:PChar = New Name
  7102.                 Call    SysFileMove
  7103.                 test    eax,eax
  7104.                 jz      @@OK
  7105.                 Call    SetInOutRes
  7106.                 jmp     @@RET
  7107.               @@OK:
  7108.                 xchg    esi,edi
  7109.               @@3:
  7110.                 lodsb                           // Copy new name to the text
  7111.                 test    al,al                   // file variable
  7112.                 stosb
  7113.                 jne     @@3
  7114.               @@RET:
  7115. end;
  7116.  
  7117. procedure _Rename(FileVar,NewName: Pointer); {&USES ebx,edx,esi} {&FRAME-}
  7118. asm
  7119.                 mov     edx,FileVar
  7120.                 mov     esi,NewName
  7121.                 mov     bl,0                    // Flag: 0 = String
  7122.                 Call    RenameFile
  7123. end;
  7124.  
  7125. procedure _RenamePCh(FileVar,NewName: Pointer); assembler; {&USES ebx,edx,esi} {&FRAME-}
  7126. const
  7127.   Zero: Byte = 0;
  7128. asm
  7129.                 mov     edx,FileVar
  7130.                 mov     esi,NewName
  7131.                 test    esi,esi
  7132.                 jnz     @@1
  7133.                 lea     esi,Zero
  7134.               @@1:
  7135.                 mov     bl,1                    // Flag: 1 = PChar
  7136.                 Call    RenameFile
  7137. end;
  7138.  
  7139. // _FilePos:  FilePos standard function
  7140. // _FileSize: FileSize standard function
  7141. // _Eof:      Eof standard function
  7142. // function FilePos(var F): Longint;
  7143. // function FileSize(var F): Longint;
  7144. // function Eof(var F): Boolean;
  7145. //      where   F = File Variable other than TEXT
  7146. //
  7147. // Sets InOutRes <> 0 if error
  7148.  
  7149. // Returns current file position and size
  7150. // EXPECTS:      edi     = @ of the File Variable
  7151. // RETURNS:      ebx     = File position
  7152. //               esi     = File size
  7153. //               CF      = 1 if file is not open
  7154.  
  7155. procedure GetFileInfo; {&USES eax,ecx,edx} {&FRAME-}
  7156. asm
  7157.                 mov     eax,RTE_File_Not_Open
  7158.                 cmp     [edi].TextRec.Mode,fmInOut
  7159.                 jne     @@ERROR
  7160. // Get Current Position
  7161.                 push    0                       // Actual
  7162.                 mov     ecx,esp
  7163.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7164.                 push    0                       // [2]:DWord = Distance
  7165.                 push    1                       // [3]:DWord = Method (Current)
  7166.                 push    ecx                     // [4]:DWord = @Actual
  7167.                 Call    SysFileSeek
  7168.                 pop     ebx                     // Current file position
  7169.                 test    eax,eax
  7170.                 jnz     @@ERROR
  7171. // Get File Size
  7172.                 push    0                       // Actual
  7173.                 mov     ecx,esp
  7174.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7175.                 push    0                       // [2]:DWord = Distance
  7176.                 push    2                       // [3]:DWord = Method (EOF)
  7177.                 push    ecx                     // [4]:DWord = @Actual
  7178.                 Call    SysFileSeek
  7179.                 pop     esi                     // File Size
  7180. // Restore current position
  7181.                 push    0                       // Actual
  7182.                 mov     ecx,esp
  7183.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7184.                 push    ebx                     // [2]:DWord = Distance
  7185.                 push    0                       // [3]:DWord = Method (Start file)
  7186.                 push    ecx                     // [4]:DWord = @Actual
  7187.                 Call    SysFileSeek
  7188.                 pop     ebx                     // Current file position
  7189.                 test    eax,eax
  7190.                 jz      @@RET                   // CF = 0
  7191.               @@ERROR:
  7192.                 Call    SetInOutRes
  7193.                 xor     ebx,ebx
  7194.                 xor     esi,esi
  7195.                 stc                             // CF := 1
  7196.               @@RET:
  7197. end;
  7198.  
  7199. procedure _FilePos(FileVar: Pointer); {&USES ebx,edx,esi,edi} {&FRAME-}
  7200. asm
  7201.                 mov     edi,FileVar
  7202.                 Call    GetFileInfo             // Returns: ebx = File Position
  7203.                 mov     eax,ebx
  7204.                 jc      @@RET
  7205.                 mov     esi,[edi].TextRec.BufSize
  7206.                 cmp     esi,1
  7207.                 jbe     @@RET                   // if RecSize > 1 then
  7208.                 xor     edx,edx                 //   Result := FilePos / RecSize
  7209.                 div     esi
  7210.               @@RET:
  7211. end;
  7212.  
  7213. procedure _FileSize(FileVar: Pointer); {&USES ebx,edx,esi,edi} {&FRAME-}
  7214. asm
  7215.                 mov     edi,FileVar
  7216.                 Call    GetFileInfo             // Returns: ecx = File Size
  7217.                 mov     eax,esi
  7218.                 jc      @@RET
  7219.                 mov     esi,[edi].TextRec.BufSize
  7220.                 cmp     esi,1
  7221.                 jbe     @@RET                   // if RecSize > 1 then
  7222.                 xor     edx,edx                 //   Result := FileSize / RecSize
  7223.                 div     esi
  7224.               @@RET:
  7225. end;
  7226.  
  7227. procedure _Eof(FileVar: Pointer); {&USES ebx,esi,edi} {&FRAME-}
  7228. asm
  7229.                 mov     edi,FileVar
  7230.                 Call    GetFileInfo
  7231.                 mov     al,0
  7232.                 jc      @@RET
  7233.                 cmp     ebx,esi
  7234.                 jne     @@RET                   // EOF := FilePos = FileSize;
  7235.                 inc     eax
  7236.               @@RET:
  7237. end;
  7238.  
  7239. // Checks that file is open
  7240. // EXPECTS:     edi     = File Variable @
  7241. // RETURNS:     ZF      = 1 if file is opened
  7242.  
  7243. procedure OpenCheck; {&USES eax} {&FRAME-}
  7244. asm
  7245.                 cmp     [edi].TextRec.Mode,fmInOut
  7246.                 je      @@RET
  7247.                 mov     eax,RTE_File_Not_Open
  7248.                 Call    SetInOutRes
  7249.               @@RET:
  7250. end;
  7251.  
  7252. // Assign standard procedure (typed and untyped files)
  7253. // procedure Assign(var F; String);
  7254.  
  7255. // EXPECTS:      dl     = String/PChar flag
  7256. //              esi     = File Name String/PChar
  7257. //              edi     = File Variable @
  7258.  
  7259. procedure Assign_File; {&USES eax,ecx} {&FRAME-}
  7260. asm
  7261.                 cld
  7262.                 xor     eax,eax                      // Initialize file
  7263.                 mov     [edi].TextRec.Handle,eax     // variable
  7264.                 mov     [edi].TextRec.Mode,fmClosed
  7265.                 add     edi,TextRec.BufSize
  7266.                 mov     ecx,(TextRec.Name - TextRec.BufSize)/4
  7267.                 rep     stosd
  7268.                 mov     ecx,TYPE TextRec.Name - 1
  7269.                 test    dl,dl                        // PChar ?
  7270.                 jnz     @@1                          // Yes, @@1
  7271.                 lodsb                                // No, Get string length
  7272.                 movzx   ecx,al
  7273.                 jecxz   @@Done
  7274.               @@1:
  7275.                 lodsb
  7276.                 test    al,al
  7277.                 jz      @@Done
  7278.                 stosb
  7279.                 loop    @@1
  7280.               @@Done:
  7281.                 mov     al,0                         // Terminate it with #0
  7282.                 stosb
  7283. end;
  7284.  
  7285. procedure _FileAssign(FileVar,S: Pointer); {&USES edx,esi,edi} {&FRAME-}
  7286. asm
  7287.                 mov     edi,FileVar
  7288.                 mov     esi,S
  7289.                 mov     dl,0            // Flag: 0 = String
  7290.                 Call    Assign_File
  7291. end;
  7292.  
  7293. procedure _FileAssignPCh(FileVar,S: Pointer); {&USES edx,esi,edi} {&FRAME-}
  7294. asm
  7295.                 mov     edi,FileVar
  7296.                 mov     esi,S
  7297.                 mov     dl,1            // Flag: 1 = PChar
  7298.                 Call    Assign_File
  7299. end;
  7300.  
  7301. // Reset:   Reset standard procedure
  7302. // Rewrite: Rewrite standard procedure
  7303. // procedure Reset(var F [:File; RecSize:Longint]);
  7304. // procedure Rewrite(var F [:File; RecSize:Longint]);
  7305. //      where F is file variable other than TEXT.
  7306. //
  7307. // Sets InOutRes <> 0 if error occurred
  7308.  
  7309. procedure OpenFile; {&USES None} {&FRAME-}
  7310. asm
  7311.                 mov     esi,eax
  7312.                 cmp     [edi].TextRec.Mode,fmClosed
  7313.                 je      @@OK
  7314.                 mov     eax,RTE_File_Not_Assigned
  7315.                 cmp     [edi].TextRec.Mode,fmInOut
  7316.                 jne     @@Error
  7317.                 push    edi                             // [1]:Pointer=FileVar
  7318.                 Call    _FileClose
  7319.               @@OK:
  7320.                 lea     edx,[edi].TextRec.Name
  7321.                 cmp     [edx].Byte,0                    // Is file name empty ?
  7322.                 je      @@Done                          // Yes, StdIn or StdOut
  7323.                 push    OFFSET FileMode
  7324.                 Call    _GetTlsVar
  7325.                 test    cl,cl                           // Open or Create ?
  7326.                 push    0                               // Handle
  7327.                 mov     ecx,esp
  7328.                 jnz     @@Create
  7329. // Reset -> Open an existing file
  7330.                 mov     eax,[eax]               // Open mode for Reset
  7331.                 push    edx                     // [1]:PChar = FileName
  7332.                 push    eax                     // [2]:DWord = Mode
  7333.                 push    ecx                     // [3]:DWord = @Handle
  7334.                 Call    SysFileOpen
  7335.                 pop     esi                     // Handle
  7336.                 jmp     @@2
  7337. // Rewrite -> Create a file
  7338.               @@Create:
  7339.                 mov     eax,[eax+4]             // FileModeReadWrite
  7340.                 test    eax,eax
  7341.                 jnz     @@1
  7342.                 mov     al,42h
  7343.               @@1:
  7344.                 push    edx                     // [1]:PChar = FileName
  7345.                 push    eax                     // [2]:DWord = Mode
  7346.                 push    0                       // [3]:DWord = Attr = Normal file
  7347.                 push    ecx                     // [4]:DWord = @Handle
  7348.                 Call    SysFileCreate
  7349.                 pop     esi                     // Handle
  7350.               @@2:
  7351.                 test    eax,eax
  7352.                 jz      @@Done
  7353.               @@Error:
  7354.                 Call    SetInOutRes
  7355.                 jmp     @@RET
  7356.               @@Done:
  7357.                 mov     [edi].TextRec.Mode,fmInOut
  7358.                 mov     [edi].TextRec.Handle,esi
  7359.                 mov     [edi].TextRec.BufSize,ebx       // Record Size
  7360.               @@RET:
  7361. end;
  7362.  
  7363. procedure _FileReset(FileVar: Pointer; RecSize: Longint); {&USES ALL} {&FRAME-}
  7364. asm
  7365.                 Call    SysFileStdIn
  7366.                 mov     edi,FileVar
  7367.                 mov     ebx,RecSize
  7368.                 mov     cl,0
  7369.                 Call    OpenFile
  7370. end;
  7371.  
  7372. procedure _FileRewrite(FileVar: Pointer; RecSize: Longint); {&USES ALL} {&FRAME-}
  7373. asm
  7374.                 Call    SysFileStdOut
  7375.                 mov     edi,FileVar
  7376.                 mov     ebx,RecSize
  7377.                 mov     cl,1
  7378.                 Call    OpenFile
  7379. end;
  7380.  
  7381. // Truncate standard procedure (typed and untyped files)
  7382. // procedure Truncate(var F);
  7383. // Sets InOutRes <> 0 if error occurred
  7384.  
  7385. procedure _FileTrunc(FileVar: Pointer); {&USES ALL} {&FRAME-}
  7386. asm
  7387.                 mov     edi,FileVar
  7388.                 Call    OpenCheck               // Is file Opened ?
  7389.                 jne     @@RET                   // No, exit with error
  7390.                 push    [edi].TextRec.Handle
  7391.                 Call    TruncateFile
  7392.                 test    eax,eax
  7393.                 jz      @@RET
  7394.                 Call    SetInOutRes
  7395.               @@RET:
  7396. end;
  7397.  
  7398. // Seek standard procedure (typed and untyped files)
  7399. // procedure Seek(var F; N: Longint);
  7400. // Sets InOutRes <> 0 if error occurred
  7401.  
  7402. procedure _FileSeek(FileVar: Pointer; FilePos: Longint); {&USES ALL} {&FRAME-}
  7403. asm
  7404.                 mov     edi,FileVar
  7405.                 Call    OpenCheck
  7406.                 jne     @@RET
  7407.                 mov     eax,FilePos             // FilePtr := FilePos * BufSize
  7408.                 mul     [edi].TextRec.BufSize
  7409.                 push    0                       // Actual
  7410.                 mov     ecx,esp
  7411.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7412.                 push    eax                     // [2]:DWord = Distance
  7413.                 push    0                       // [3]:DWord = Method(Start file)
  7414.                 push    ecx                     // [4]:DWord = @Actual
  7415.                 Call    SysFileSeek
  7416.                 pop     ecx
  7417.                 test    eax,eax
  7418.                 jz      @@RET
  7419.                 Call    SetInOutRes
  7420.               @@RET:
  7421. end;
  7422.  
  7423. // Close standard procedure (typed and untyped files)
  7424. // procedure Close(var F);
  7425. // Sets InOutRes <> 0 if error occurred
  7426.  
  7427. procedure _FileClose(FileVar: Pointer); {&USES eax,ecx,edx,edi} {&FRAME-}
  7428. asm
  7429.                 mov     edi,FileVar
  7430.                 Call    OpenCheck               // Is file Opened ?
  7431.                 jne     @@RET                   // No, exit with error
  7432.                 push    [edi].TextRec.Handle
  7433.                 Call    SysFileClose
  7434.                 test    eax,eax
  7435.                 jz      @@OK
  7436.                 Call    SetInOutRes
  7437.               @@OK:
  7438.                 mov     [edi].TextRec.Mode,fmClosed
  7439.               @@RET:
  7440. end;
  7441.  
  7442. // _FileRead:  Read  standard procedure (typed files)
  7443. // _FileWrite: Write standard procedure (typed files)
  7444. // Sets InOutRes <> 0 if error occurred
  7445.  
  7446. // Performs typed file I/O
  7447. // EXPECTS:      eax     = Error Code
  7448. //               edx     = Buffer @
  7449. //               edi     = File Variable @
  7450.  
  7451. procedure InOutFile; {&USES ecx} {&FRAME-}
  7452. asm
  7453.                 Call    OpenCheck               // Is file Opened ?
  7454.                 jne     @@RET                   // No, exit with error
  7455.                 push    eax                     // Save Error code
  7456.                 push    0                       // Bytes Read
  7457.                 mov     ecx,esp
  7458.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7459.                 push    edx                     // [2]:PChar = Buffer
  7460.                 push    [edi].TextRec.BufSize   // [3]:DWord = Count
  7461.                 push    ecx                     // [4]:DWord = @ByteRead
  7462.                 cmp     eax,RTE_Disk_Write_Error
  7463.                 je      @@Write
  7464.                 Call    SysFileRead
  7465.                 jmp     @@Done
  7466.               @@Write:
  7467.                 Call    SysFileWrite
  7468.               @@Done:
  7469.                 pop     ecx                     // Actual bytes done
  7470.                 pop     edx                     // Error code
  7471.                 test    eax,eax
  7472.                 jnz     @@ERROR
  7473.                 cmp     ecx,[edi].TextRec.BufSize // All data processed?
  7474.                 je      @@RET
  7475.                 mov     eax,edx                 // No, set I/O Error
  7476.               @@ERROR:
  7477.                 Call    SetInOutRes
  7478.               @@RET:
  7479. end;
  7480.  
  7481. procedure _FileRead(FileVar,Buffer: Pointer); {&USES eax,edx,edi} {&FRAME-}
  7482. asm
  7483.                 mov     eax,RTE_Disk_Read_Error
  7484.                 mov     edi,FileVar
  7485.                 mov     edx,Buffer
  7486.                 Call    InOutFile
  7487.                 PopArgs @Params - TYPE FileVar
  7488. end;
  7489.  
  7490. procedure _FileWrite(FileVar,Buffer: Pointer); {&USES eax,edx,edi} {&FRAME-}
  7491. asm
  7492.                 mov     eax,RTE_Disk_Write_Error
  7493.                 mov     edi,FileVar
  7494.                 mov     edx,Buffer
  7495.                 Call    InOutFile
  7496.                 PopArgs @Params - TYPE FileVar
  7497. end;
  7498.  
  7499. // BlockRead:  BlockRead  standard procedure (untyped files)
  7500. // BlockWrite: BlockWrite standard procedure (untyped files)
  7501. // procedure BlockRead (var F: file; var Buf; Cnt: Longint; Res:Longint);
  7502. // procedure BlockWrite(var F: file; var Buf; Cnt: Longint; Res:Longint);
  7503. // Sets InOutRes <> 0 if error occurred
  7504. // If result address is <> 0 then number of bytes that have been
  7505. // actually processed is stored in Result
  7506.  
  7507. // Performs untyped file I/O }
  7508.  
  7509. // EXPECTS:     esi     = Error code
  7510. //              edi     = File Variable @
  7511. //              ecx     = Count
  7512. //              edx     = Buffer @
  7513. //              ebx     = Result @
  7514.  
  7515. procedure InOutBlock; {&USES None} {&FRAME-}
  7516. asm
  7517.                 test    ebx,ebx
  7518.                 jz      @@1
  7519.                 and     DWord Ptr [ebx],0       // Result := 0
  7520.               @@1:
  7521.                 Call    OpenCheck               // Is file Opened ?
  7522.                 jne     @@RET                   // No, exit with error(Res=0)
  7523.                 mov     eax,ecx
  7524.                 jecxz   @@2
  7525.                 push    edx
  7526.                 mul     [edi].TextRec.BufSize
  7527.                 pop     edx
  7528.                 mov     ecx,eax                 // ecx := Number of bytes
  7529.                 push    ebx                     // @Result
  7530.                 push    ecx                     // Count
  7531.                 push    0                       // Bytes Read
  7532.                 mov     eax,esp
  7533.                 push    [edi].TextRec.Handle    // [1]:DWord = File Handle
  7534.                 push    edx                     // [2]:PChar = Buffer
  7535.                 push    ecx                     // [3]:DWord = Count
  7536.                 push    eax                     // [4]:DWord = @ByteRead
  7537.                 cmp     esi,RTE_Disk_Write_Error
  7538.                 je      @@Write
  7539.                 Call    SysFileRead
  7540.                 jmp     @@Done
  7541.               @@Write:
  7542.                 Call    SysFileWrite
  7543.               @@Done:
  7544.                 pop     ecx                     // Bytes processed
  7545.                 pop     edx                     // Count
  7546.                 pop     ebx                     // @Result
  7547.                 test    eax,eax
  7548.                 jnz     @@ERROR
  7549.                 mov     eax,edx
  7550.               @@2:
  7551.                 test    ebx,ebx                 // @Result = nil ?
  7552.                 jz      @@3
  7553.                 mov     eax,ecx                 // Bytes processed
  7554.                 xor     edx,edx
  7555.                 div     [edi].TextRec.BufSize
  7556.                 mov     [ebx],eax               // Return result
  7557.                 jmp     @@RET
  7558.               @@3:
  7559.                 cmp     ecx,eax                 // if Actual <> Count then
  7560.                 je      @@RET                   //   Return error
  7561.                 xchg    eax,esi
  7562.               @@ERROR:
  7563.                 Call    SetInOutRes
  7564.               @@RET:
  7565. end;
  7566.  
  7567. procedure _BlockRead(FileVar,Buffer: Pointer; Count: Longint; Result: Pointer); {&USES ALL} {&FRAME-}
  7568. asm
  7569.                 mov     esi,RTE_Disk_Read_Error
  7570.                 mov     edi,FileVar
  7571.                 mov     ecx,Count
  7572.                 mov     edx,Buffer
  7573.                 mov     ebx,Result
  7574.                 Call    InOutBlock
  7575. end;
  7576.  
  7577. procedure _BlockWrite(FileVar,Buffer: Pointer; Count: Longint; Result: Pointer); {&USES ALL} {&FRAME-}
  7578. asm
  7579.                 mov     esi,RTE_Disk_Write_Error
  7580.                 mov     edi,FileVar
  7581.                 mov     ecx,Count
  7582.                 mov     edx,Buffer
  7583.                 mov     ebx,Result
  7584.                 Call    InOutBlock
  7585. end;
  7586.  
  7587. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ COMMAND LINE PARAMETERS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  7588.  
  7589. function ParamCount: Longint;
  7590. begin
  7591.   Result := SysCmdlnCount;
  7592. end;
  7593.  
  7594. function ParamStr(Index: Longint): ShortString;
  7595. begin
  7596.   SysCmdlnParam(Index, Result);
  7597. end;
  7598.  
  7599. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ SYSTEM INDEPENDENT INTERFACE ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  7600.  
  7601. // Exit procedure handling
  7602.  
  7603. type
  7604.   PExitProcInfo = ^TExitProcInfo;
  7605.   TExitProcInfo = record
  7606.     Next: PExitProcInfo;
  7607.     SaveExit: Pointer;
  7608.     Proc: TProcedure;
  7609.   end;
  7610.  
  7611. const
  7612.   ExitProcList: PExitProcInfo = nil;
  7613.  
  7614. procedure DoExitProc;
  7615. var
  7616.   P: PExitProcInfo;
  7617.   Proc: TProcedure;
  7618. begin
  7619.   P := ExitProcList;
  7620.   ExitProcList := P^.Next;
  7621.   ExitProc := P^.SaveExit;
  7622.   Proc := P^.Proc;
  7623.   Dispose(P);
  7624.   Proc;
  7625. end;
  7626.  
  7627. procedure AddExitProc(Proc: TProcedure);
  7628. var
  7629.   P: PExitProcInfo;
  7630. begin
  7631.   New(P);
  7632.   P^.Next := ExitProcList;
  7633.   P^.SaveExit := ExitProc;
  7634.   P^.Proc := Proc;
  7635.   ExitProcList := P;
  7636.   ExitProc := @DoExitProc;
  7637. end;
  7638.  
  7639. procedure DoExitProcs; {&USES ALL} {&FRAME-}
  7640. asm
  7641.               @@1:
  7642.                 mov     ecx,ExitProc
  7643.                 jecxz   @@RET
  7644.                 xor     eax,eax
  7645.                 mov     ExitProc,eax            // Clear ExitProc
  7646.                 Call    SetInOutRes             // Clear InOutRes
  7647.                 Call    ecx
  7648.                 jmp     @@1
  7649.               @@RET:
  7650. end;
  7651.  
  7652. // Standard exit procedure
  7653.  
  7654. procedure _ExitProc;
  7655. begin
  7656.   _TxtClose(@Input);
  7657.   _TxtClose(@Output);
  7658. end;
  7659.  
  7660. // Standard initialization
  7661.  
  7662. procedure DoInit; assembler; {&USES NONE} {&FRAME-}
  7663. const
  7664.   EmptyStr: Byte = 0;
  7665. asm
  7666. // Assign(Input, ''); Reset(Input);
  7667.                 mov     eax,OFFSET Input
  7668.                 push    eax                     // [1]:Pointer = FileVar(Reset)
  7669.                 push    eax                     // [1]:Pointer = FileVar
  7670.                 push    OFFSET EmptyStr         // [2]:Pointer = Name
  7671.                 Call    _TxtAssign
  7672.                 Call    _TxtReset
  7673. // Assign(Output, ''); Rewrite(Output);
  7674.                 mov     eax,OFFSET Output
  7675.                 push    eax                     // [1]:Pointer = FileVar(Rewrite)
  7676.                 push    eax                     // [1]:Pointer = FileVar
  7677.                 push    OFFSET EmptyStr         // [2]:Pointer = Name
  7678.                 Call    _TxtAssign
  7679.                 Call    _TxtRewrite
  7680.                 mov     ExitProc,OFFSET _ExitProc // Default ExitProc
  7681.                 Call    _FpuInit
  7682.                 Call    SysCmdln
  7683.                 mov     CmdLine,eax
  7684. end;
  7685.  
  7686. // Converts hexadecimal number to string
  7687. // EXPECTS:     eax     = Number
  7688. //              edi     = Buffer pointer
  7689.  
  7690. procedure Hex2Str; {&USES None} {&FRAME-}
  7691. asm
  7692.                 mov     cl,8
  7693.               @@1:
  7694.                 rol     eax,4
  7695.                 push    eax
  7696.                 and     al,0Fh
  7697.                 add     al,'0'
  7698.                 cmp     al,'9'
  7699.                 jbe     @@2
  7700.                 add     al,'A'-'0'-10
  7701.               @@2:
  7702.                 stosb
  7703.                 pop     eax
  7704.                 dec     cl
  7705.                 jnz     @@1
  7706. end;
  7707.  
  7708. // RunError standard procedure
  7709. // procedure RunError[(ErrorCode: Longint)];
  7710. // EXPECTS:     eax     = Error Code
  7711. //              Error address on stack
  7712.  
  7713. procedure _RunError(ErrorCode: Longint); {&USES None} {&FRAME-}
  7714. asm
  7715.                 mov     eax,ErrorCode
  7716.                 pop     ecx             // ecx = Return address
  7717.                 jmp     _Terminate
  7718. end;
  7719.  
  7720. // Halt standard procedure
  7721. // procedure Halt[(ExitCode: Longint)];
  7722. // EXPECTS:     eax     = Error Code
  7723. //              Error address on stack
  7724.  
  7725. procedure _Halt(ExitCode: Longint); {&USES None} {&FRAME-}
  7726. asm
  7727.                 mov     eax,ExitCode    // eax = Exit Code
  7728.                 xor     ecx,ecx         // ecx = Return address
  7729.                 jmp     _Terminate
  7730. end;
  7731.  
  7732. // Converts error number to run-time error
  7733. // EXPECTS:     al      = reXXX style error code
  7734. //              [ESP]   = Error address on stack
  7735.  
  7736. procedure RtlError; {&USES None} {&FRAME-}
  7737. asm
  7738.                 and     eax,7Fh
  7739.                 mov     ecx,ErrorProc
  7740.                 jecxz   @@1
  7741.                 mov     edx,[esp]
  7742.                 push    eax             // [1]:Byte    = Error number
  7743.                 push    edx             // [2]:Pointer = Error address
  7744.                 Call    ecx
  7745.               @@1:
  7746.                 dec     eax
  7747.                 mov     al,Byte Ptr @@ErrorTable[eax]
  7748.                 jns     @@2
  7749.                 push    OFFSET InOutRes // reInOutError
  7750.                 Call    _GetTlsVar
  7751.                 mov     eax,[eax]
  7752.               @@2:
  7753.                 pop     edx
  7754.                 push    eax             // [1]:Error number
  7755.                 push    edx             // Return address
  7756.                 jmp     _RunError
  7757. @@ErrorTable:   db      RTE_Heap_Overflow          // reOutOfMemory
  7758.                 db      RTE_Invalid_Pointer        // reInvalidPtr
  7759.                 db      RTE_Zero_Divide            // reDivByZero
  7760.                 db      RTE_Range_Check            // reRangeError
  7761.                 db      RTE_Integer_Overflow       // reIntOverflow
  7762.                 db      RTE_Invalid_FP_Operation   // reInvalidOp
  7763.                 db      RTE_Zero_Divide            // reZeroDivide
  7764.                 db      RTE_FP_Overflow            // reOverflow
  7765.                 db      RTE_FP_Underflow           // reUnderflow
  7766.                 db      RTE_Invalid_Cast           // reInvalidCast
  7767.                 db      RTE_Access_Violation       // reAccessViolation
  7768.                 db      RTE_Stack_Overflow         // reStackOverflow
  7769.                 db      RTE_Signal                 // reSignal
  7770.                 db      RTE_Privileged_Instruction // rePrivilegedInstr
  7771. end;
  7772.  
  7773. procedure _RunErrorStr(var ErrStr: ShortString); assembler; {&USES esi,edi} {&FRAME-}
  7774. const
  7775.    RuntimeStr: array [1..14] of Char = 'Runtime error ';
  7776.    Copyright:  array [1..54] of Char = 'Virtual Pascal - Copyright (C) 1996-2000 vpascal.com';
  7777. asm
  7778.                 cld
  7779.                 mov     edi,ErrStr
  7780.                 push    edi
  7781.                 inc     edi
  7782.                 mov     esi,OFFSET RuntimeStr   // 'Runtime error '
  7783.                 mov     ecx,TYPE RuntimeStr
  7784.                 rep     movsb
  7785.                 mov     eax,ExitCode
  7786.                 Call    Int2Str
  7787.                 mov     eax,' ta '              // ' at '
  7788.                 stosd
  7789.                 mov     eax,ErrorAddr
  7790.                 Call    Hex2Str
  7791.                 {$IFDEF DPMI32}
  7792.                 push    eax                     // save ErrorAddr
  7793.  
  7794.                 // ' (Base=........ rel=........) '
  7795.                 mov     eax,'aB( '              // ' (Ba' 'se=_'
  7796.                 stosd
  7797.                 mov     eax,' =es'
  7798.                 stosd
  7799.                 dec     edi
  7800.                 mov     eax,code_base
  7801.                 Call    Hex2Str
  7802.  
  7803.                 mov     al,' '                  // ' ','rel='
  7804.                 stosb
  7805.                 mov     eax,'=ler'
  7806.                 stosd
  7807.                 pop     eax
  7808.                 push    eax
  7809.                 sub     eax,code_base
  7810.                 add     eax,$401000
  7811.                 Call    Hex2Str
  7812.  
  7813.                 mov     ax,' )'                 // ') '
  7814.                 stosw
  7815.  
  7816.                 pop     eax                     // restore ErrorAddr
  7817.                 {$ELSE}
  7818.                 mov     [edi].Byte,' '
  7819.                 inc     edi
  7820.                 {$ENDIF}
  7821.                 push    eax
  7822.                 mov     ecx,esp
  7823.                 push    eax                     // [1]:Addr
  7824.                 push    edi                     // [2]:FileName
  7825.                 push    ecx                     // [3]:Line#
  7826.                 Call    GetLocationInfo
  7827.                 pop     ecx                     // Line#
  7828.                 dec     edi
  7829.                 test    eax,eax
  7830.                 jz      @@1
  7831.                 inc     edi
  7832.                 movzx   eax,[edi].Byte
  7833.                 mov     [edi].Byte,'('
  7834.                 lea     edi,[edi+eax+1]
  7835.                 mov     al,'#'
  7836.                 stosb
  7837.                 xchg    eax,ecx
  7838.                 Call    Int2Str
  7839.                 mov     al,')'
  7840.                 stosb
  7841.               @@1:
  7842.                 mov     ecx,ExceptionNo
  7843.                 jecxz   @@WriteError            // Exception ?
  7844.                 mov     eax,'xE( '              // ' (Exception '
  7845.                 stosd                           //  └──┘└──┘└──┘
  7846.                 mov     eax,'tpec'
  7847.                 stosd
  7848.                 mov     eax,' noi'
  7849.                 stosd
  7850.                 xchg    eax,ecx
  7851.                 Call    Hex2Str
  7852.                 mov     al,')'                  // ')'
  7853.                 stosb
  7854.               @@WriteError:
  7855.                 mov     eax,'DIT '              // ' TID=#'
  7856.                 stosd
  7857.                 mov     al,'='
  7858.                 stosb
  7859.                 Call    GetThreadId
  7860.                 Call    Int2Str
  7861.                 mov     eax,0A0D00h + '.'       // '.', CR, LF, #0
  7862.                 stosd                           // Zero terminated!
  7863.                 dec     edi
  7864.                 pop     eax
  7865.                 sub     edi,eax
  7866.                 lea     ecx,[edi-1]
  7867.                 mov     [eax],cl
  7868. end;
  7869.  
  7870. // EXPECTS:     eax     = Exit Code
  7871. //              ecx     = Return address
  7872.  
  7873. procedure _Terminate; {&USES None} {&FRAME-}
  7874. asm
  7875.                 mov     ExitCode,eax
  7876.                 mov     ErrorAddr,ecx
  7877.                 Call    DoExitProcs
  7878.                 cmp     ErrorAddr,0
  7879.                 jz      @@NoError
  7880.                 sub     esp,256
  7881.                 mov     eax,esp
  7882.                 push    eax                     // Result: String
  7883.                 push    eax
  7884.                 Call    _RunErrorStr
  7885.                 Call    SysFileStdErr
  7886.                 pop     edx
  7887.                 movzx   ecx,[edx].Byte
  7888.                 inc     edx
  7889.                 push    0                          // Actual
  7890.                 mov     esi,esp
  7891.                 push    eax                        // [1]:DWord = Handle
  7892.                 push    edx                        // [2]:PChar = Buffer
  7893.                 push    ecx                        // [3]:DWord = Count
  7894.                 push    esi                        // [4]:DWord = @ByteWrite
  7895.                 Call    SysFileWrite
  7896.                 pop     eax
  7897.               @@NoError:
  7898.                 push    ExitCode                // [1]:Longint = Exit Code
  7899.                 Call    SysCtrlExitProcess
  7900. end;
  7901.  
  7902. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ Threads and Thread Local Storage ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  7903.  
  7904. // Creates a new thread and installs system exception handler for it.
  7905.  
  7906. type
  7907.   PThreadRec = ^TThreadRec;
  7908.   TThreadRec = record
  7909.     Func: TThreadFunc;
  7910.     Param: Pointer;
  7911.   end;
  7912.  
  7913. function BeginThread(SecurityAttributes: Pointer; StackSize: Longint;
  7914.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  7915.                      CreationFlags: Longint; var ThreadId: Longint): Longint;
  7916. var
  7917.   P: PThreadRec;
  7918. begin
  7919.   New(P);
  7920.   P^.Func := ThreadFunc;
  7921.   P^.Param := Parameter;
  7922.   Result := SysCtrlCreateThread(SecurityAttributes,
  7923.     StackSize, @ThreadStartup, P, CreationFlags, ThreadId);
  7924.   if Result = 0 then
  7925.     IsMultiThread := True;
  7926. end;
  7927.  
  7928. // Terminates the current thread. Note that control does not return to
  7929. // the thread code. Thread also terminates after final 'end' of the
  7930. // thread's function statement part.
  7931.  
  7932. procedure EndThread(ExitCode: Longint); {&USES None} {&FRAME-}
  7933. asm
  7934.                 jmp     SysCtrlExitThread
  7935. end;
  7936.  
  7937. // Temporarily suspends execution of the thread until ResumeThread is
  7938. // issued. Returns 0 if the operation was successful, or non-zero
  7939. // System error code otherwise
  7940.  
  7941. function SuspendThread(Handle: Longint): Longint; {&USES None} {&FRAME-}
  7942. asm
  7943.                 jmp     SysCtrlSuspendThread
  7944. end;
  7945.  
  7946. // Restarts the thread that was previously stopped by SuspendThread.
  7947.  
  7948. function ResumeThread(Handle: Longint): Longint; {&USES None} {&FRAME-}
  7949. asm
  7950.                 jmp     SysCtrlResumeThread
  7951. end;
  7952.  
  7953. // Terminates another thread in the current process. If thread 1 is
  7954. // specified, the entire process terminates.
  7955.  
  7956. function KillThread(Handle: Longint): Longint; {&USES None} {&FRAME-}
  7957. asm
  7958.                 jmp     SysCtrlKillThread
  7959. end;
  7960.  
  7961. const
  7962.   escFileName   = $3F;
  7963.   escLineNo     = $3E;
  7964.   escLineOfs    = $3D;
  7965.   escEnd        = $3C;
  7966.   escFirst      = $3C;
  7967.  
  7968. type
  7969.   TPointerList = Array[1..1] of Pointer;
  7970.   PPointerList = ^TPointerList;
  7971.  
  7972.   TSemMgr = procedure(var Sem: Longint);
  7973.  
  7974.   PSharedMem = ^TSharedMem;
  7975.   TSharedMem = record
  7976.     TlsPerThread  : PPointerList;   // Actual TLS
  7977.     MaxThreadCount: Longint;        // Max thread ID so far
  7978.     TlsSemaphore  : Longint;        // Semaphore used by Tls Mgr
  7979.     TlsMemMgr     : PMemoryManager; // Memory Manager used by Tls Mgr
  7980.     TlsSemMgr     : TSemMgr;        // Semaphore Manager used by Tls Mgr
  7981.   end;
  7982.  
  7983.   PModuleEntry = ^TModuleEntry;
  7984.   TModuleEntry = record
  7985.     TlsStart:  Longint;
  7986.     TlsSize:   Longint;  // (*)
  7987.     CodeStart: Cardinal;
  7988.     LocInfo:   PChar;
  7989.   end;
  7990.  
  7991.   PThreadEntry = ^TThreadEntry;
  7992.   TThreadEntry = record
  7993.     Next: PThreadEntry;  // Next entry for thread, for next module
  7994.     TlsSize: Longint;    // Duplicate of (*)
  7995.     Data: record end;
  7996.   end;
  7997.  
  7998. function GetLocationInfo(Addr: Pointer; var AFileName: ShortString; var ALineNo: Longint): Pointer;
  7999. var
  8000.   P,FileName: PChar;
  8001.   LastOfs: Pointer;
  8002.   I,CodeStart,LineNo,StartLineNo,LastLineNo: Longint;
  8003.   NewFile: Boolean;
  8004.   AOfs: Cardinal absolute Addr;
  8005. begin
  8006.   LineNo := -1;
  8007.   Result := Ptr(-1);
  8008.   LastLineNo := 0;
  8009.   LastOfs := nil;
  8010.   P := PChar(TlsSharedMem) + SizeOf(TSharedMem);
  8011.   while PModuleEntry(P)^.TlsStart <> -1 do
  8012.   begin
  8013.     if PModuleEntry(P)^.CodeStart <= AOfs then
  8014.     begin
  8015.       Dec(AOfs, PModuleEntry(P)^.CodeStart);
  8016.       CodeStart := PModuleEntry(P)^.CodeStart;
  8017.       P := PModuleEntry(P)^.LocInfo;
  8018.       if P = nil then
  8019.         Break;
  8020.       repeat
  8021.         case Ord(P^) of
  8022.  
  8023.           escEnd:
  8024.             Break;
  8025.  
  8026.           escFileName:
  8027.             begin
  8028.               Inc(P);
  8029.               FileName := P;
  8030.               Inc(P, Ord(P^) + 1);
  8031.               NewFile := True;
  8032.               Continue;
  8033.             end;
  8034.  
  8035.           escLineNo:
  8036.             begin
  8037.               Inc(LineNo, PSmallWord(@P[1])^);
  8038.               Inc(P, 3);
  8039.               Continue;
  8040.             end;
  8041.  
  8042.           escLineOfs:
  8043.             begin
  8044.               Inc(LineNo, PSmallWord(@P[1])^);
  8045.               Inc(Longint(Result), PLongint(@P[3])^);
  8046.               Inc(P, 7);
  8047.             end;
  8048.  
  8049.           else
  8050.             Inc(LineNo, PByte(P)^ shr 6);
  8051.             Inc(Longint(Result), PByte(P)^ and $3F);
  8052.             Inc(P);
  8053.         end;
  8054.         if Longint(Result) = AOfs then
  8055.         begin
  8056.           LastOfs := Result;
  8057.           LastLineNo := LineNo;
  8058.         end;
  8059.         if Longint(Result) >= AOfs then
  8060.           if (Longint(Result) - AOfs <= 10) or not NewFile then
  8061.             begin
  8062.               AFileName[0] := FileName^;        // Copy the string length
  8063.               I := 0;
  8064.               while I < Ord(FileName^) do       // Decode the name itself
  8065.               begin
  8066.                 Inc(I);
  8067.                 AFileName[I] := Chr(Ord(FileName[I]) xor $AA);
  8068.               end;
  8069.               ALineNo := SmallWord(LastLineNo);
  8070.               Result := Ptr(Longint(LastOfs) + CodeStart);
  8071.               Exit;
  8072.             end
  8073.           else
  8074.             Break;
  8075.         LastOfs := Result;
  8076.         LastLineNo := LineNo;
  8077.         NewFile := False;
  8078.       until False;
  8079.       Break;
  8080.     end;
  8081.     Inc(P, SizeOf(TModuleEntry));
  8082.   end;
  8083.   Result := nil;
  8084. end;
  8085.  
  8086. // Reallocate Tls-per-thread pointer list, if necessary
  8087.  
  8088. procedure RightSizeTlsPerThread(_UpdateMaxCount: Boolean);
  8089. var
  8090.   Count: Longint;
  8091.   OldSize: Longint;
  8092.   P: Pointer;
  8093. begin
  8094.   with PSharedMem(TlsSharedMem)^ do
  8095.     begin
  8096.       Count := GetThreadId;
  8097.       if Count > MaxThreadCount then
  8098.         begin
  8099.           TlsSemMgr(TlsSemaphore);    // Exclusive access!
  8100.           P := TlsMemMgr.GetMem(4*Count);
  8101.           FillChar(P^, 4*Count, 0);
  8102.           if TlsPerThread <> nil then
  8103.             begin
  8104.               OldSize := MaxThreadCount*4;
  8105.               Move(TlsPerThread^, P^, OldSize);
  8106.               TlsMemMgr.FreeMem(TlsPerThread);
  8107.             end;
  8108.           TlsPerThread := P;
  8109.           if _UpdateMaxCount then
  8110.             MaxThreadCount := Count;
  8111.           asm
  8112.             mov  edx,TlsSharedMem
  8113.             lea  eax,[edx].TSharedMem.TlsSemaphore
  8114.             lock btr dword ptr [eax],0
  8115.           end;
  8116.         end;
  8117.     end;
  8118. end;
  8119.  
  8120. // Free TLS allocated for this thread - thread is terminating
  8121.  
  8122. procedure FreeTLS;
  8123. var
  8124.   ID: Longint;
  8125.   p: PThreadEntry;
  8126.   pNext: PThreadEntry;
  8127. begin
  8128.   ID := GetThreadID;
  8129.   with PSharedMem(TlsSharedMem)^ do
  8130.     begin
  8131.       TlsSemMgr(TlsSemaphore);
  8132.       p := TlsPerThread^[ID];
  8133.       if assigned(p) then
  8134.         begin
  8135.           TlsPerThread^[ID] := nil;
  8136.           while assigned(p) do
  8137.             begin
  8138.               pNext := p^.Next;
  8139.               TlsMemMgr.FreeMem(p);
  8140.               p := pNext;
  8141.             end;
  8142.         end;
  8143.       asm
  8144.         mov  edx,TlsSharedMem
  8145.         lea  eax,[edx].TSharedMem.TlsSemaphore
  8146.         lock btr dword ptr [eax],0
  8147.       end;
  8148.     end;
  8149. end;
  8150.  
  8151. // Allocate TLS for a newly started thread
  8152.  
  8153. procedure AllocateTls_NewThread;
  8154. var
  8155.   pModule: PModuleEntry;
  8156.   pHead: PThreadEntry;
  8157.   p: PThreadEntry;
  8158.   ID: Longint;
  8159.   MemMgr: PMemoryManager;
  8160.   Bytes: Longint;
  8161. begin
  8162.   ID := GetThreadId;
  8163.   // Determine if any action is necessary
  8164.   with PSharedMem(TlsSharedMem)^ do
  8165.     if (ID <= MaxThreadCount) and (TlsPerThread^[ID] <> nil) then
  8166.       exit;
  8167.  
  8168.   pHead := nil;
  8169.   MemMgr := PSharedMem(TlsSharedMem)^.TlsMemMgr;
  8170.   pModule := PModuleEntry(PChar(TlsSharedMem) + SizeOf(TSharedMem));
  8171.   while pModule^.TlsSize <> -1 do
  8172.     begin
  8173.       Bytes := pModule^.TlsSize + SizeOf(TThreadEntry);
  8174.       if pHead = nil then
  8175.         begin
  8176.           pHead := MemMgr.GetMem(Bytes);
  8177.           p := pHead;
  8178.         end
  8179.       else
  8180.         begin
  8181.           p^.Next := MemMgr.GetMem(Bytes);
  8182.           p := p^.Next;
  8183.         end;
  8184.       FillChar(P^, Bytes, 0);
  8185.       p^.TlsSize := pModule^.TlsSize;
  8186.       inc(pModule);
  8187.     end;
  8188.  
  8189.   // Now add pHead to the end of the TlsPerThread list
  8190.   RightSizeTlsPerThread(False);
  8191.   with PSharedMem(TlsSharedMem)^ do
  8192.     begin
  8193.       TlsPerThread^[ID] := pHead;
  8194.       if ID > MaxThreadCount then
  8195.         MaxThreadCount := ID;
  8196.     end;
  8197.  
  8198.   // Set default values of tls for thread
  8199.   FileMode := $42; // Default value
  8200. end;
  8201.  
  8202. // Allocate more TLS for each thread when a new module is loaded
  8203. // This assumes the global block is already updated with module info
  8204.  
  8205. procedure AllocateTls_NewModule;
  8206. var
  8207.   pModule: PModuleEntry;
  8208.   pPrevModule: PModuleEntry;
  8209.   pCurModule: PModuleEntry;
  8210.   pPrevThread: PThreadEntry;
  8211.   pCurThread: PThreadEntry;
  8212.   tid: Longint;
  8213.   MemMgr: PMemoryManager;
  8214.   Bytes: Longint;
  8215. begin
  8216.   MemMgr := PSharedMem(TlsSharedMem)^.TlsMemMgr;
  8217.   pModule := PModuleEntry(PChar(TlsSharedMem) + SizeOf(TSharedMem));
  8218.   // pPrev is now last module added; add its TLS for all threads
  8219.   RightSizeTlsPerThread(True);
  8220.   with PSharedMem(TlsSharedMem)^ do
  8221.     for tid := 1 to MaxThreadCount do
  8222.       begin
  8223.         if TlsPerThread^[tid] <> nil then
  8224.           begin
  8225.             pPrevThread := nil;
  8226.             pCurThread := TlsPerThread^[tid];
  8227.             pPrevModule := nil;
  8228.             pCurModule := pModule;
  8229.             while (pCurThread <> nil) and (pCurModule^.TlsSize <> -1) do
  8230.               begin
  8231.                 pPrevModule := pCurModule;
  8232.                 inc(pCurModule);
  8233.                 pPrevThread := pCurThread;
  8234.                 pCurThread := pCurThread^.Next;
  8235.               end;
  8236.             if (pCurThread = nil) and (pPrevThread <> nil) and (pCurModule^.TlsSize <> -1) then
  8237.               begin
  8238.                 Bytes := pCurModule^.TlsSize + SizeOf(TThreadEntry);
  8239.                 pPrevThread^.Next := MemMgr.GetMem(Bytes);
  8240.                 pCurThread := pPrevThread^.Next;
  8241.               end
  8242.             else
  8243.               pCurThread := nil;
  8244.           end;
  8245.         if assigned(pCurThread) then
  8246.           begin
  8247.             FillChar(pCurThread^, Bytes, 0);
  8248.             pCurThread^.TlsSize := pCurModule^.TlsSize;
  8249.             FileMode := $42;
  8250.           end;
  8251.       end;
  8252. end;
  8253.  
  8254. // Adds TLS segment paramters for a current EXE or DLL to the TL table,
  8255. // located in the named shared memory
  8256. // EXPECTS:     eax     = Base TLS@
  8257. //              edx     = Unit segment map address
  8258.  
  8259. procedure AddToTls; {&USES ebx,esi,edi} {&FRAME-}
  8260. asm
  8261.                 cld
  8262.                 mov     ebx,eax
  8263.                 lea     edi,[eax+TYPE TSharedMem]
  8264.                 or      eax,-1
  8265.                 mov     ecx,eax
  8266.                 repne   scasd
  8267.                 mov     eax,[edx+0]             // Starting@ of the TLS segment
  8268.                 cmp     eax,[edx+4]
  8269.                 je      @@1                     // No THREADVARs have been declared
  8270.                 mov     [edi-4].TModuleEntry.TlsStart,eax
  8271.                 sub     eax,[edx+4]             // Ending address
  8272.                 neg     eax
  8273.                 mov     [edi-4].TModuleEntry.TlsSize,eax
  8274.                 mov     eax,[edx+8]             // Starting code offset
  8275.                 mov     [edi-4].TModuleEntry.CodeStart,eax
  8276.                 mov     eax,[edx+12]            // Location
  8277.                 inc     eax                     // -1 => not available ?
  8278.                 jz      @@NoLoc
  8279.                 lea     eax,[edx+eax+12-1]      // relative offset
  8280.               @@NoLoc:
  8281.                 mov     [edi-4].TModuleEntry.LocInfo,eax
  8282.               @@1:
  8283. // Calculates the total size of the TLS data found in the TLS table
  8284.                 lea     edi,[ebx+TYPE TSharedMem]
  8285.                 xor     ecx,ecx
  8286.               @@2:
  8287.                 cmp     [edi].Longint,-1        // Done ?
  8288.                 je      @@3
  8289.                 add     ecx,[edi].TModuleEntry.TlsSize
  8290.                 add     edi,TYPE TModuleEntry
  8291.                 jmp     @@2
  8292.               @@3:
  8293.                 sub     edi,ebx
  8294.                 mov     TlsSharedMemSize,edi
  8295.                 call    AllocateTls_NewThread   // Make sure TLS exists for current thread
  8296.                 call    AllocateTls_NewModule   // Allocate more TLS for other threads
  8297. end;
  8298.  
  8299. // Clears the address the TLS segment in the shared memory region map
  8300. // so if the other DLL will be loaded later on by DosLoadModule
  8301. // which have the same TLS segment address, the old Tls segment will
  8302. // be ignored.
  8303. // EXCEPTS:     ecx     = Unit segment map address
  8304.  
  8305. procedure RemoveFromTls; {&USES None} {&FRAME-}
  8306. asm
  8307.                 mov     edx,TlsSharedMem
  8308.                 add     edx,TYPE TSharedMem
  8309.               @@1:
  8310.                 cmp     [edx].Longint,-1        // Done ?
  8311.                 je      @@2
  8312.                 add     edx,TYPE TModuleEntry
  8313.                 mov     eax,[edx-TYPE TModuleEntry].TModuleEntry.TlsStart
  8314.                 cmp     eax,[ecx]               // Starting Tls segment@
  8315.                 jne     @@1                     // Zero address, so it will not be found anymore
  8316.                 and     [edx-TYPE TModuleEntry].TModuleEntry.TlsStart,0
  8317.               @@2:
  8318. end;
  8319.  
  8320. // Returns an address of the THREADVAR variable
  8321. function _GetTlsVar(var TlsVar): Pointer; {&USES ebx,ecx,edx,esi,edi} {&FRAME-}
  8322. asm
  8323.                 mov     eax,TlsVar
  8324.                 xor     ecx,ecx
  8325.                 mov     esi,TlsSharedMem
  8326.                 lea     edx,[esi+TYPE TSharedMem]
  8327.               @@1:
  8328.                 mov     ebx,[edx].TModuleEntry.TlsStart
  8329.                 cmp     ebx,-1                  // Not found, wrong TLS address is given
  8330.                 jz      @@RET                   // return the address itself
  8331.                 cmp     eax,ebx
  8332.                 jb      @@2
  8333.                 add     ebx,[edx].TModuleEntry.TlsSize
  8334.                 cmp     eax,ebx
  8335.                 jb      @@3
  8336.               @@2:
  8337.                 add     ecx,[edx].TModuleEntry.TlsSize
  8338.                 add     edx,TYPE TModuleEntry
  8339.                 jmp     @@1
  8340.               @@3:
  8341.                 sub     eax,[edx].TModuleEntry.TlsStart
  8342.                 lea     ebx,[eax+ecx]           // ebx := Offset within TLS
  8343.  
  8344.                 Call    GetThreadId
  8345.                 dec     eax
  8346.                 mov     ecx,eax                 // ecx := ThreadID-1
  8347.  
  8348.                 lea     eax,[esi].TSharedMem.TlsSemaphore
  8349.                 push    eax
  8350.                 push    ecx
  8351.                 push    eax
  8352.                 Call    [esi].TSharedMem.TlsSemMgr  // exclusive access!
  8353.                 pop     ecx
  8354.  
  8355.                 mov     edi,[esi].TSharedMem.TlsPerThread
  8356.                 lea     eax,[edi+ecx*4]         // Tls[Thread]
  8357.                 mov     eax,[eax]
  8358.  
  8359.                 pop     ecx
  8360.            lock btr     dword ptr [ecx],0       // reset semaphore
  8361.  
  8362.                 // Walk chain of tls to find offset in ebx
  8363.               @@4:
  8364.                 cmp     ebx,[eax].TThreadEntry.TlsSize
  8365.                 jle     @@ThisModule
  8366.                 sub     ebx,[eax].TThreadEntry.TlsSize
  8367.                 mov     eax,[eax].TThreadEntry.Next
  8368.                 jmp     @@4
  8369.               @@ThisModule:
  8370.                 add     eax,OFFSET TThreadEntry.Data
  8371.                 add     eax,ebx
  8372.               @@RET:
  8373. end;
  8374.  
  8375. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ SYSTEM DEPENDENT INTERFACE ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  8376.  
  8377. const
  8378.  // User Exception Handler Return Codes
  8379.   XCPT_CONTINUE_SEARCH          = $00000000;  // exception not handled
  8380.   XCPT_CONTINUE_EXECUTION       = $FFFFFFFF;  // exception handled
  8381.  
  8382. {$IFDEF OS2}
  8383.  
  8384. type
  8385.   Tib  = record
  8386.     Tib_PExchain:         Pointer;
  8387.     Tib_PStack:           Pointer;
  8388.     Tib_PStackLimit:      Pointer;
  8389.     Tib_PTib2:            Pointer;
  8390.     Tib_Version:          Longint;
  8391.     Tib_Ordinal:          Longint;
  8392.   end;
  8393.  
  8394.   Tib2  = record
  8395.     Tib2_ulTid:           Longint;
  8396.     Tib2_ulPri:           Longint;
  8397.     Tib2_Version:         Longint;
  8398.     Tib2_usMCCount:       SmallWord;
  8399.     Tib2_fMCForceFlag:    SmallWord;
  8400.   end;
  8401.  
  8402. procedure DosRaiseException;     orgname; external;
  8403. procedure DosUnwindException;    orgname; external;
  8404.  
  8405. {$ENDIF}
  8406. {$IFDEF WIN32}
  8407.  
  8408. procedure RtlUnwind;             orgname; external;
  8409. procedure GetEnvironmentStrings; orgname; external;
  8410. procedure GetModuleHandle;       orgname; external;
  8411. procedure TlsAlloc;              orgname; external;
  8412. procedure TlsSetValue;           orgname; external;
  8413. procedure RaiseException(Code,Flags,ArgCount: Longint; var Args: Longint); stdcall; orgname; external;
  8414. function TlsGetValue(Index: Longint): Longint; stdcall; orgname; external;
  8415. function TlsFree(TlsIndex: Longint): Boolean;  orgname; external;
  8416.  
  8417. const
  8418.   TlsIndex:    Longint = -1;
  8419.  
  8420. {$ENDIF}
  8421. {$IFDEF DPMI32}
  8422.  
  8423. type
  8424.   { -> DPMI32.PAS }
  8425.   Tib  = record
  8426.     Tib_PExchain:         Pointer;
  8427.     Tib_PStack:           Pointer;
  8428.     Tib_PStackLimit:      Pointer;
  8429.   end;
  8430.  
  8431. procedure dpmi_RaiseException;   orgname; external;
  8432. procedure dpmi_UnwindException;  orgname; external;
  8433. function  SysGetThreadId:longint;orgname; external;
  8434.  
  8435. {$ENDIF}
  8436.  
  8437. {$IFDEF WIN32}
  8438. procedure AllocWin32tid; {&uses esi} {&frame-}
  8439. asm
  8440.                 mov     esi,TlsSharedMem
  8441.                 { Prevent multiple threads from initialising in parallel }
  8442.                 lea     eax,[esi].TSharedMem.TlsSemaphore
  8443.                 push    eax
  8444.                 push    eax
  8445.                 Call    [esi].TSharedMem.TlsSemMgr
  8446.  
  8447.                 mov     ecx,[esi].TSharedMem.MaxThreadCount
  8448.                 dec     ecx
  8449.                 mov     eax,[esi].TSharedMem.TlsPerThread
  8450.               @@1:      // Find previously used, now free, tid
  8451.                 cmp     dword ptr [eax+ecx*4],0
  8452.                 je      @@2
  8453.                 dec     ecx
  8454.                 js      @@3
  8455.                 jmp     @@1
  8456.               @@3:      // Did not find free slot: use MaxId+1
  8457.                 mov     ecx,[esi].TSharedMem.MaxThreadCount
  8458.               @@2:      // Found free slot
  8459.                 inc     ecx
  8460.                 push    ecx             // [2]:DWord = Tid
  8461.                 push    TlsIndex        // [1]:DWord = TlsIndex
  8462.                 Call    TlsSetValue     // Win32 API
  8463.  
  8464.                 pop     eax             // Reset semaphore
  8465.            lock btr     dword ptr [eax],0
  8466. end;
  8467. {$ENDIF WIN32}
  8468.  
  8469. { Initialise Thread Local Storage for a newly started thread, or
  8470.   for a thread that was not started using BeginThread but is trying
  8471.   to access a TLS variable }
  8472. procedure InitialiseTLS; {&uses none} {&Frame-}
  8473. asm
  8474. {$IFDEF WIN32}
  8475.                 call    AllocWin32tid
  8476. {$ENDIF}
  8477.                 Call    AllocateTls_NewThread
  8478. end;
  8479.  
  8480. // Installs system exception handler and activates the thread code.
  8481.  
  8482. function ThreadStartup(P: Longint): Longint; {&USES None} {&FRAME+}
  8483. asm
  8484.                 Call    _FpuInit
  8485.                 xor     eax,eax
  8486.                 push    ebp
  8487.                 push    OFFSET _ExceptionHandler
  8488.                 push    fs:[eax].Longint
  8489.                 mov     fs:[eax],esp
  8490.                 call    GetThreadId
  8491.                 or      eax,eax
  8492. {$IFDEF WIN32}
  8493.                 jnz     @@TLSInitialised // TLS already initialised
  8494. {$ENDIF}
  8495.                 call    InitialiseTLS
  8496.               @@TLSInitialised:
  8497.                 mov     ebx,P
  8498.                 mov     ecx,[ebx].TThreadRec.Param
  8499.                 mov     edx,[ebx].TThreadRec.Func
  8500.                 push    ebx
  8501.                 Call    _MemFree
  8502.                 push    ecx
  8503.                 Call    edx                     // Call thread function
  8504. {$IFDEF OS2}    add     esp,4  {$ENDIF}
  8505.                 call    FreeTLS
  8506.                 xor     edx,edx
  8507.                 pop     fs:[edx].Longint
  8508.                 pop     ecx
  8509.                 pop     ebp
  8510.                 push    eax
  8511.                 Call    EndThread       // OS/2 2.0 does not like RET from thread code
  8512. end;
  8513.  
  8514. {$IFDEF OS2}
  8515. // Returns Thread ID for the current thread
  8516.  
  8517. function GetThreadId: Longint; {&USES None} {&FRAME-}
  8518. asm
  8519.                 mov     eax,fs:[0].Tib.Tib_PTib2
  8520.                 mov     eax,[eax].Tib2.Tib2_ulTid
  8521. end;
  8522. {$ENDIF OS2}
  8523.  
  8524. {$IFDEF WIN32}
  8525. function GetThreadId: Longint;
  8526. begin
  8527.   Result := TlsGetValue(TlsIndex);
  8528.   { Fix designed to make sure TLS is properly initialised for threads
  8529.     started without using VP's BeginThread mechanism }
  8530.   if Result = 0 then
  8531.     begin
  8532.       InitialiseTLS;
  8533.       Result := TlsGetValue(TlsIndex);
  8534.     end;
  8535. end;
  8536.  
  8537. procedure InitTidTls; {&USES ALL}
  8538. asm
  8539.                 cmp     TlsIndex,-1
  8540.                 jne     @@RET
  8541.                 Call    TlsAlloc        // Win32 API function
  8542.                 mov     TlsIndex,eax
  8543.                 push    1               // [2]:DWord = TID
  8544.                 push    eax             // [1]:DWord = TlsIndex
  8545.                 Call    TlsSetValue     // Win32 API function
  8546.               @@RET:
  8547. end;
  8548. {$ENDIF WIN32}
  8549.  
  8550. {$IFDEF DPMI32}
  8551. function GetThreadId: Longint;
  8552. begin
  8553.   Result := SysGetThreadId;
  8554. end;
  8555. {$ENDIF}
  8556.  
  8557. {$IFDEF LINUX}
  8558. type
  8559.   TThreadInfo = record
  8560.     ExceptChain: Pointer; // Head of exception registration chain
  8561.     Stack:       Pointer; // Lower limit of stack
  8562.     StackLimit:  Pointer; // Upper limit of stack
  8563.     Handle:      LongInt; // One-based thread handle
  8564.     ThreadPid:   LongInt; // PID of thread itself
  8565.     ProcessPid:  LongInt; // PID of process to which thread belongs
  8566.     State:       LongInt; // State of thread
  8567.     TibSelector: LongInt; // Selector pointing to thread information block
  8568.   end;
  8569.  
  8570. procedure SysRaiseException;   orgname; external;
  8571. procedure SysUnwindException;  orgname; external;
  8572.  
  8573. function GetThreadId: Longint; {&USES NONE} {&FRAME-}
  8574. asm
  8575.                 mov     eax,fs:[0].TThreadInfo.Handle
  8576. end;
  8577. {$ENDIF LINUX}
  8578.  
  8579. // Exception handling variables per platform
  8580.  
  8581. const
  8582.   System_RaiseException: Pointer =
  8583.    {$IFDEF OS2}    @DosRaiseException    {$ENDIF}
  8584.    {$IFDEF WIN32}  @RaiseException       {$ENDIF}
  8585.    {$IFDEF DPMI32} @Dpmi_RaiseException  {$ENDIF}
  8586.    {$IFDEF LINUX}  @SysRaiseException    {$ENDIF}
  8587.    ;
  8588.   System_UnwindException : Pointer =
  8589.    {$IFDEF OS2}    @DosUnwindException   {$ENDIF}
  8590.    {$IFDEF WIN32}  @RtlUnwind            {$ENDIF}
  8591.    {$IFDEF DPMI32} @Dpmi_UnwindException {$ENDIF}
  8592.    {$IFDEF LINUX}  @SysUnwindException   {$ENDIF}
  8593.    ;
  8594.    System_Xcpt_Continue_Search =
  8595.    {$IFDEF WIN32}  1
  8596.           {$ELSE}  0 {$ENDIF}
  8597.    ;
  8598.  
  8599.  
  8600. // ▒▒▒▒▒▒▒▒▒▒▒▒▒[ INITIALIZATION/TERMINATION ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  8601.  
  8602. // EXPECTS:     eax     = Command line parameters
  8603. //              ecx     = Environment block@
  8604. //              edx     = Module Handle
  8605.  
  8606. // Initialization code of the SYSTEM unit
  8607. // EXPECTS:     eax     = Stack Size ($M StackSize)
  8608. //              ecx     = Offset of the unit segment map
  8609.  
  8610. {&USES None} {&FRAME-}
  8611. procedure _InitExe(Params,EnvPtr: Pointer; Reserved,ModHandle,RetAddr: Longint); assembler;
  8612. var
  8613.   RegRec: TExcFrame;
  8614. asm
  8615. {$IFDEF DPMI32}
  8616.                 // SAVE PSP SELECTOR
  8617.                 mov     sel_psp,es
  8618.                 mov     seldata,ds
  8619.                 mov     stacksize,eax
  8620.                 // DS=ES=SS
  8621.                 push    ds
  8622.                 pop     es
  8623.                 push    [ecx+8].longint
  8624.                 pop     code_base
  8625. {$ENDIF}
  8626.                 cld
  8627.                 push    ecx
  8628. {$IFDEF LINUX}
  8629.                 call    SysLowInit
  8630. {$ENDIF}
  8631. {$IFDEF OS2}
  8632. // Adjust Tib_PStack, because it points to the start of the DGROUP,
  8633. // not to the end of the stack
  8634.                 mov     edx,fs:[Tib.Tib_PStackLimit]
  8635.                 sub     edx,eax
  8636.                 mov     fs:[Tib.Tib_PStack],edx
  8637. {$ENDIF OS2}
  8638. {$IFDEF WIN32}
  8639.                 Call    InitTidTls
  8640. {$ENDIF WIN32}
  8641.                 Call    SysCtrlGetTlsMapMem
  8642.                 mov     TlsSharedMem,eax
  8643.                 pop     edx
  8644.                 Call    AddToTls
  8645. // Initialize global variables
  8646. {$IFDEF OS2}
  8647.                 mov     eax,EnvPtr
  8648.                 mov     Environment,eax
  8649.                 mov     eax,ModHandle
  8650.                 mov     ModuleHandle,eax
  8651. {$ENDIF OS2}
  8652. {$IFDEF WIN32}
  8653.                 Call    GetEnvironmentStrings
  8654.                 mov     Environment,eax
  8655.                 push    0
  8656.                 Call    GetModuleHandle
  8657.                 mov     ModuleHandle,eax
  8658.                 mov     HInstance,eax
  8659. {$ENDIF WIN32}
  8660. {$IFDEF DPMI32}
  8661.                 Call    SysLowInit
  8662. {$ENDIF DPMI32}
  8663.                 Call    SysCtrlSelfAppType
  8664.                 cmp     eax,3                   // 1:NOVIO,2:VIO,3:PM
  8665.                 setb    IsConsole
  8666. // Set Exception Handler
  8667.                 lea     eax,RegRec              // System error handler
  8668.                 xor     edx,edx                 // Insert System handler
  8669.                 mov     ecx,fs:[edx]            // into the chain
  8670.                 mov     fs:[edx],eax
  8671.                 mov     [eax].TExcFrame.Next,ecx
  8672.                 mov     [eax].TExcFrame.Desc,OFFSET _ExceptionHandler
  8673.                 mov     [eax].TExcFrame.hEBP,ebp
  8674.                 PopArgs 0                       // Since parameters are pushed by OS/2
  8675. // Exception Registration records must be on stack and must reside there while
  8676. // thread's code is executed, so leave it on stack and exit via jmp
  8677.                 jmp     DWord Ptr [esp+@Locals] // Return@
  8678. end;
  8679.  
  8680. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ DLL SUPPORT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  8681.  
  8682. // DLL initialization/termination code start
  8683. // EXPECTS:     ecx     = Unit segment map@
  8684. //              ZF      = 1 if Initialization
  8685.  
  8686. procedure _InitDll; {&USES None} {&FRAME-}
  8687. asm
  8688. {$IFDEF LNX_DPMI}
  8689.                 // Not implemented
  8690.                 nop
  8691. {$ENDIF}
  8692. {$IFDEF OS2}
  8693.                 cmp     [esp+0Ch].Longint,0     // Initialization ?
  8694.                 jnz     @@End
  8695.                 push    ecx
  8696.                 Call    SysCtrlGetTlsMapMem
  8697.                 mov     TlsSharedMem,eax
  8698.                 pop     edx
  8699.                 Call    AddToTls
  8700.                 jmp     @@RET
  8701.               @@End:
  8702.                 Call    DoExitProcs
  8703.                 Call    RemoveFromTls
  8704.               @@RET:
  8705.                 cmp     [esp+0Ch].Longint,0     // Initialization ?
  8706. {$ENDIF OS2}
  8707. {$IFDEF WIN32}
  8708.                 cmp     [esp+0Ch].Longint,1     // Initialization ?
  8709.                 jb      @@End
  8710.                 ja      @@RET
  8711.                 mov     HInstance,0
  8712.  
  8713.                 Call    InitTidTls
  8714.                 push    ecx
  8715.                 Call    SysCtrlGetTlsMapMem
  8716.                 mov     TlsSharedMem,eax
  8717.                 pop     edx
  8718.                 Call    AddToTls
  8719.                 jmp     @@RET
  8720.               @@End:
  8721.                 Call    DoExitProcs
  8722.                 Call    RemoveFromTls
  8723.               @@RET:
  8724.                 cmp     [esp+0Ch].Longint,1     // Initialization ?
  8725. {$ENDIF WIN32}
  8726. end;
  8727.  
  8728. // DLL initialization/termination code start
  8729. // Non-zero ExitCode indicates success
  8730.  
  8731. procedure _InitDllEnd(ExitCode: Longint); {&USES None} {&FRAME-}
  8732. asm
  8733. {$IFDEF LNX_DPMI}
  8734.                 // Not implemented
  8735.                 nop
  8736. {$ENDIF LNX_DPMI}
  8737. {$IFDEF OS2}
  8738.                 mov     eax,ExitCode
  8739.                 leave                           { Restore stack frame         }
  8740.                 PopArgs 0                       { Return to OS/2              }
  8741. {$ENDIF OS2}
  8742. {$IFDEF WIN32}
  8743.                 mov     eax,ExitCode
  8744.                 leave
  8745.                 PopArgs 4*3
  8746. {$ENDIF WIN32}
  8747. end;
  8748.  
  8749. //▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ EXCEPTION HANDLING ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
  8750.  
  8751. // Notification exceptions are used to inform a debugger of the current state
  8752. // of a program while the program is handling an exception. This helps the
  8753. // debugger to trace TRY blocks even if an exception is raised. The debugger
  8754. // sets DebugHook to True to enable generation of the notification exceptions.
  8755.  
  8756. // Exception#           |ParamCount|  Param1            | Param2
  8757. // ---------------------+----------+--------------------+----------------
  8758. // cLanguageReRaise     |    0     |    -               |   -
  8759. // cLanguageExcept      |    2     |  @ExceptionHandler | Exception Report record
  8760. // cLanguageFinally     |    2     |  @ExceptionHandler | Exception Report record
  8761. // cLanguageTerminate   |    1     |  @ReturnAddress    |   -
  8762. // cLanguageUnhandled   |    2     |  Exception Object  | Exception address
  8763. // cNonLanguageException|    2     |  Exception Object  | Exception context record
  8764.  
  8765. {$IFDEF OS2}
  8766. procedure RaiseNotification(ArgCount,Arg1,Arg2,Code: Longint); assembler; {&USES eax,ecx,edx} {&FRAME-}
  8767. var
  8768.   ER: TXcptReportRecord;
  8769. asm
  8770.                 cmp     DebugHook,1
  8771.                 jne     @@RET
  8772.                 mov     eax,Code                // Exception number
  8773.                 mov     edx,ArgCount            // Number of parameters
  8774.                 mov     ER.ExceptionNum,eax
  8775.                 mov     ER.cParameters,edx
  8776.                 xor     eax,eax
  8777.                 mov     ER.ExceptionAddress,eax
  8778.                 mov     ER.NestedXcptReportRecord,eax
  8779.                 mov     ER.fHandlerFlags,cContinuable
  8780.                 mov     eax,Arg1
  8781.                 mov     edx,Arg2                // Arguments
  8782.                 mov     ER.ExceptionInfo[0].Longint,eax
  8783.                 mov     ER.ExceptionInfo[4].Longint,edx
  8784.                 lea     eax,ER                  // [1]:Report
  8785.                 push    eax
  8786.                 Call    DosRaiseException
  8787.                 pop     eax                     // Stack cleanup
  8788.               @@RET:
  8789. end;
  8790.  
  8791. // Returns ZF=1 if exception must be ignored
  8792. // EXPECTS:     eax     = @ of the exception report record
  8793.  
  8794. procedure XcptIgnored; {&USES ecx} {&FRAME-}
  8795. asm
  8796.                 mov     ecx,[eax].TXcptReportRecord.ExceptionNum
  8797.                 cmp     ecx,XCPT_GUARD_PAGE_VIOLATION
  8798.                 je      @@RET
  8799.                 cmp     ecx,XCPT_PROCESS_TERMINATE
  8800.                 je      @@RET
  8801.                 cmp     ecx,XCPT_ASYNC_PROCESS_TERMINATE
  8802.                 je      @@RET
  8803.                 cmp     ecx,XCPT_UNWIND
  8804.               @@RET:
  8805. end;
  8806. {$ENDIF OS2}
  8807.  
  8808. {$IFDEF WIN32}
  8809. {$SAVES eax,ebx,ecx,edx,esi,edi}
  8810.  
  8811. procedure RaiseNotification(ArgCount,Arg1,Arg2,Code: Longint);
  8812. var
  8813.   Args: array[0..1] of Longint;
  8814. begin
  8815.   if Ord(DebugHook) = 1 then
  8816.   begin
  8817.     Args[0] := Arg1;
  8818.     Args[1] := Arg2;
  8819.     RaiseException(Code, cContinuable, ArgCount, Args[0]);
  8820.   end;
  8821. end;
  8822.  
  8823. {$SAVES ebx,esi,edi}
  8824. {$ENDIF WIN32}
  8825.  
  8826. {$IFDEF LNX_DPMI}
  8827. procedure RaiseNotification(ArgCount,Arg1,Arg2,Code: Longint); assembler;{$FRAME-}{$USES NONE}
  8828. asm
  8829.                 nop
  8830. end;
  8831. {$ENDIF LINUX}
  8832.  
  8833. procedure NotifyReRaise; {&USES None} {&FRAME-}
  8834. asm
  8835.                 push    0
  8836.                 push    0
  8837.                 push    0
  8838.                 push    cLanguageReRaise
  8839.                 Call    RaiseNotification
  8840. end;
  8841.  
  8842. procedure NotifyExcept; {&USES None} {&FRAME-}
  8843. asm
  8844.                 push    2
  8845.                 push    ecx
  8846.                 push    edx
  8847.                 push    cLanguageExcept
  8848.                 Call    RaiseNotification
  8849. end;
  8850.  
  8851. procedure NotifyExitFinally; {&USES None} {&FRAME-}
  8852. asm
  8853.                 push    2
  8854.                 push    ecx
  8855.                 push    edx
  8856.                 push    cLanguageFinally
  8857.                 Call    RaiseNotification
  8858. end;
  8859.  
  8860. procedure NotifyExceptFinally; {&USES ecx} {&FRAME-}
  8861. asm
  8862.                 mov     eax,[ecx+1]
  8863.                 cmp     [ecx].Byte,0E9h         // near jmp
  8864.                 je      @@1
  8865.                 cmp     [ecx].Byte,0EBh         // short jmp
  8866.                 jne     @@2
  8867.                 movsx   eax,al
  8868.                 sub     ecx,3
  8869.               @@1:
  8870.                 lea     ecx,[eax+ecx+5]
  8871.               @@2:
  8872.                 Call    NotifyExitFinally
  8873. end;
  8874.  
  8875. procedure NotifyTerminate; {&USES None} {&FRAME-}
  8876. asm
  8877.                 push    1
  8878.                 push    ecx
  8879.                 push    ecx
  8880.                 push    cLanguageTerminate
  8881.                 Call    RaiseNotification
  8882. end;
  8883.  
  8884. // EXPECTS:     eax     = Language exception object
  8885. //              edx     = Exception address
  8886.  
  8887. procedure NotifyUnhandled; {&USES None} {&FRAME-}
  8888. asm
  8889.                 push    2
  8890.                 push    eax
  8891.                 push    edx
  8892.                 push    cLanguageUnhandled
  8893.                 Call    RaiseNotification
  8894. end;
  8895.  
  8896. // EXPECTS:     eax     = Language exception object
  8897. //              edx     = Exception context record
  8898.  
  8899. procedure NotifyNonLanguage; {&USES eax} {&FRAME-}
  8900. asm
  8901.                 push    2
  8902.                 push    eax
  8903.                 push    edx
  8904.                 push    cNonLanguageException
  8905.                 Call    RaiseNotification
  8906. end;
  8907.  
  8908. // In the TRY..EXCEPT block, handles any oncoming exceptions
  8909.  
  8910. procedure _XcptAny(Report,Registration,Context,Void: Pointer); {&USES None} {&FRAME-}
  8911. asm
  8912.                 mov     eax,Report
  8913.                 mov     edx,Registration
  8914.                 test    [eax].TXcptReportRecord.fHandlerFlags,cUnwindInProgress
  8915.                 jnz     @@RET
  8916.                 mov     edx,[eax].TXcptReportRecord.ExceptObject
  8917.                 mov     ecx,[eax].TXcptReportRecord.ExceptAddr
  8918.                 cmp     [eax].TXcptReportRecord.ExceptionNum,cLanguageException
  8919.                 je      @@Language
  8920. {$IFDEF OS2}
  8921.                 Call    XcptIgnored
  8922.                 je      @@RET
  8923. {$ENDIF}
  8924.                 Call    _FpuInit
  8925.                 mov     edx,ExceptObjProc
  8926.                 test    edx,edx
  8927.                 jz      @@RET
  8928.                 push    eax                     // [1]:PXcptReportRecord
  8929.                 Call    edx
  8930.                 test    eax,eax
  8931.                 je      @@RET
  8932.                 mov     edx,Context
  8933.                 Call    NotifyNonLanguage
  8934.                 mov     edx,eax
  8935.                 mov     eax,Report
  8936.                 mov     ecx,[eax].TXcptReportRecord.ExceptionAddress
  8937.               @@Language:
  8938.                 or      [eax].TXcptReportRecord.fHandlerFlags,cUnwinding
  8939.                 push    ebx
  8940.                 push    esi
  8941.                 push    edi
  8942.                 push    ebp
  8943.                 push    fs:[0].Longint          // Topmost frame
  8944. // Construct TRaise frame on stack
  8945.                 push    eax                     // TRaiseFrame.ExceptionRecord
  8946.                 push    edx                     // TRaiseFrame.ExceptObject
  8947.                 push    ecx                     // TRaiseFrame.ExceptAddr
  8948.                 mov     edx,Registration[8*4]
  8949. {$IFDEF WIN32}  push    0            {$ENDIF}   // Win32: Extra parameter
  8950.                 push    eax                     // [3]: Report
  8951.                 push    OFFSET @@TargetEIP      // [2]: Target EIP
  8952.                 push    edx                     // [1]: Registration
  8953.                 call    System_UnwindException  // Platform-dependent const
  8954.               @@TargetEIP:
  8955. {$IFDEF OS2}    add     esp,4*3      {$ENDIF}   // OS/2: Manual stack clean
  8956.                 mov     edx,Report[8*4]
  8957.                 mov     edi,Registration[8*4]
  8958.                 push    OFFSET RaiseList
  8959.                 Call    _GetTlsVar
  8960.                 push    [eax].Longint           // TRaiseFrame.NextRaise
  8961.                 mov     [eax],esp
  8962.                 mov     ebp,[edi].TExcFrame.hEBP
  8963.                 mov     ecx,[edi].TExcFrame.Desc
  8964.                 mov     [edi].TExcFrame.Desc,OFFSET @@ExceptFinally
  8965.                 add     ecx,TExcDesc.Instructions
  8966.                 Call    NotifyExcept
  8967.                 jmp     ecx
  8968. @@ExceptFinally:
  8969.                 jmp     _XcptFinally
  8970.  
  8971. // Exception handler for a TRY...EXCEPT exception handler code. Control
  8972. // gets here if an execption is raised from the EXCEPT part.
  8973.  
  8974.                 push    OFFSET RaiseList
  8975.                 Call    _GetTlsVar
  8976.                 mov     ecx,[eax]
  8977.                 mov     edx,[ecx].TRaiseFrame.NextRaise
  8978.                 mov     [eax],edx
  8979.                 push    [ecx].TRaiseFrame.ExceptObject
  8980.                 Call    TObject.Free
  8981.                 ret
  8982.               @@RET:
  8983.                 mov     eax,System_Xcpt_Continue_Search
  8984. end;
  8985.  
  8986. // In the TRY..EXCEPT block, handles oncoming exception by looking for a
  8987. // first matching ON exception handler
  8988.  
  8989. procedure _XcptOn(Report,Registration,Context,Void: Pointer); {&USES None} {&FRAME-}
  8990. asm
  8991.                 mov     eax,Report
  8992.                 test    [eax].TXcptReportRecord.fHandlerFlags,cUnwindInProgress
  8993.                 jne     @@RET
  8994.                 cmp     [eax].TXcptReportRecord.ExceptionNum,cLanguageException
  8995.                 je      @@Language
  8996. {$IFDEF OS2}
  8997.                 Call    XcptIgnored
  8998.                 je      @@RET
  8999. {$ENDIF}
  9000.                 Call    _FpuInit
  9001.                 mov     edx,ExceptClsProc
  9002.                 test    edx,edx
  9003.                 jz      @@RET
  9004.                 push    eax                     // [1]:PXcptReportRecord
  9005.                 Call    edx
  9006.                 test    eax,eax
  9007.                 jnz     @@Find
  9008.                 jmp     @@RET
  9009.               @@Language:
  9010.                 mov     eax,[eax].TXcptReportRecord.ExceptObject
  9011.                 mov     eax,[eax].clVTable
  9012.               @@Find:
  9013.                 mov     edx,Registration        // eax = Exception VMT@
  9014.                 push    ebx
  9015.                 push    esi
  9016.                 push    edi
  9017.                 push    ebp
  9018.                 mov     ecx,[edx].TExcFrame.Desc
  9019.                 mov     ebx,[ecx].TExcDesc.Cnt
  9020.                 lea     esi,[ecx].TExcDesc.ExcTab
  9021.                 mov     ebp,eax
  9022.               @@1:
  9023.                 mov     eax,[esi].TExcDescEntry.vTable
  9024.                 test    eax,eax                 // ELSE part ?
  9025.                 jz      @@DoHandler             // Yes: execute handler
  9026.                 mov     edi,ebp                 // load VMT of exception object
  9027.               @@2:
  9028.                 cmp     eax,edi
  9029.                 je      @@DoHandler
  9030.                 mov     ecx,[eax].vtInstanceSize// CMP Instance Sizes
  9031.                 cmp     ecx,[edi].vtInstanceSize
  9032.                 jne     @@Parent
  9033.                 mov     eax,[eax].vtClassName   // CMP Exception Names
  9034.                 mov     edx,[edi].vtClassName
  9035.                 mov     cl,[eax]
  9036.                 cmp     cl,[edx]
  9037.                 jne     @@Parent
  9038.                 push    eax                     // [1]: Str1
  9039.                 push    edx                     // [2]: Str2
  9040.                 Call    _StrCmp
  9041.                 jne     @@Parent
  9042.                 mov     eax,[esi].TExcDescEntry.vTable
  9043.                 mov     edx,[edi].vtTypeInfo
  9044.                 mov     eax,[eax].vtTypeInfo
  9045.                 test    edx,edx
  9046.                 jz      @@Parent
  9047.                 test    eax,eax
  9048.                 jz      @@Parent                // CMP unit names
  9049.                 movzx   ecx,[eax].TTypeInfo.Name.Byte
  9050.                 cmp     cl,[edx].TTypeInfo.Name.Byte
  9051.                 jne     @@Parent
  9052.                 lea     eax,[eax+ecx].TTypeInfo.Name[1].TClassRTTI.UnitName
  9053.                 lea     edx,[edx+ecx].TTypeInfo.Name[1].TClassRTTI.UnitName
  9054.                 push    eax
  9055.                 push    edx
  9056.                 Call    _StrCmp
  9057.                 je      @@DoHandler
  9058.               @@Parent:
  9059.                 mov     edi,[edi].vtParent
  9060.                 mov     eax,[esi].TExcDescEntry.vTable
  9061.                 test    edi,edi
  9062.                 jnz     @@2
  9063.                 add     esi,TYPE TExcDescEntry
  9064.                 dec     ebx
  9065.                 jnz     @@1
  9066.                 pop     ebp
  9067.                 pop     edi
  9068.                 pop     esi
  9069.                 pop     ebx
  9070.                 jmp     @@RET
  9071. { Exception is found }
  9072.               @@DoHandler:
  9073.                 mov     eax,Report[4*4]
  9074.                 mov     edx,[eax].TXcptReportRecord.ExceptObject
  9075.                 mov     ecx,[eax].TXcptReportRecord.ExceptAddr
  9076.                 cmp     [eax].TXcptReportRecord.ExceptionNum,cLanguageException
  9077.                 je      @@HaveObject
  9078.                 push    eax                     // [1]:PXcptReportRecord
  9079.                 Call    ExceptObjProc
  9080.                 mov     edx,Context[4*4]
  9081.                 Call    NotifyNonLanguage
  9082.                 mov     edx,eax
  9083.                 mov     eax,Report[4*4]
  9084.                 mov     ecx,[eax].TXcptReportRecord.ExceptionAddress
  9085.               @@HaveObject:
  9086.                 or      [eax].TXcptReportRecord.fHandlerFlags,cUnwinding
  9087.                 push    fs:[0].Longint          // Topmost frame
  9088. // Construct TRaise frame on stack
  9089.                 push    eax                     // TRaiseFrame.ExceptionRecord
  9090.                 push    edx                     // TRaiseFrame.ExceptObject
  9091.                 push    ecx                     // TRaiseFrame.ExceptAddr
  9092.                 mov     edx,Registration[8*4]
  9093.                 push    esi                     // Handler entry
  9094. {$IFDEF WIN32}  push    0 {$ENDIF}
  9095.                 push    eax                     // [3]: Report
  9096.                 push    OFFSET @@TargetEIP      // [2]: Target EIP
  9097.                 push    edx                     // [1]: Registration
  9098.                 call    System_UnwindException  // Platform-dependent const
  9099.               @@TargetEIP:
  9100. {$IFDEF OS2}    add     esp,4*3      {$ENDIF}   // OS/2: Manual stack clean
  9101.                 pop     ecx                     // Handler entry
  9102.                 mov     edx,Report[8*4]
  9103.                 mov     edi,Registration[8*4]
  9104.                 push    OFFSET RaiseList
  9105.                 Call    _GetTlsVar
  9106.                 push    [eax].Longint           // TRaiseFrame.NextRaise
  9107.                 mov     [eax],esp
  9108.                 mov     ebp,[edi].TExcFrame.hEBP
  9109.                 mov     [edi].TExcFrame.Desc,OFFSET @@ExceptFinally
  9110.                 mov     eax,[esp].TRaiseFrame.ExceptObject
  9111.                 mov     ecx,[ecx].TExcDescEntry.Handler
  9112.                 Call    NotifyExcept
  9113.                 jmp     ecx                     // eax = Exception object for
  9114. @@ExceptFinally:                                // >> on E: Exception <<
  9115.                 jmp     _XcptFinally
  9116.  
  9117. // Exception handler for a TRY...EXCEPT exception handler code. Control
  9118. // gets here if an execption is raised from the EXCEPT part.
  9119.  
  9120.                 push    OFFSET RaiseList
  9121.                 CALL    _GetTlsVar
  9122.                 mov     ecx,[eax]               // RaiseList
  9123.                 mov     edx,[ecx].TRaiseFrame.NextRaise
  9124.                 mov     [eax],edx               // RaiseList
  9125.                 push    [ecx].TRaiseFrame.ExceptObject
  9126.                 Call    TObject.Free
  9127.                 ret
  9128.               @@RET:
  9129.                 mov     eax,System_Xcpt_Continue_Search
  9130. end;
  9131.  
  9132. // In the TRY..FINALLY block, executes FINALLY statement part
  9133.  
  9134. procedure _XcptFinally(Report,Registration,Context,Void: Pointer); {&USES None} {&FRAME-}
  9135. asm
  9136.                 mov     eax,Report
  9137.                 test    [eax].TXcptReportRecord.fHandlerFlags,cUnwindInProgress
  9138.                 jz      @@RET
  9139. {$IFDEF OS2}
  9140.                 Call    XcptIgnored
  9141.                 je      @@RET
  9142. {$ENDIF}
  9143.                 mov     edx,eax
  9144.                 mov     eax,Registration
  9145.                 mov     ecx,[eax].TExcFrame.Desc
  9146.                 mov     [eax].TExcFrame.Desc,OFFSET @@RET
  9147.                 push    ebx
  9148.                 push    esi
  9149.                 push    edi
  9150.                 push    ebp
  9151.                 mov     ebp,[eax].TExcFrame.hEBP
  9152.                 add     ecx,TExcDesc.Instructions
  9153.                 Call    NotifyExceptFinally
  9154.                 Call    ecx
  9155.                 pop     ebp
  9156.                 pop     edi
  9157.                 pop     esi
  9158.                 pop     ebx
  9159.               @@RET:
  9160.                 mov     eax,System_Xcpt_Continue_Search
  9161. end;
  9162.  
  9163. // Exit from TRY statement. Here we should determine which block type is it
  9164.  
  9165. procedure _XcptTryExit; {&USES eax,ecx,edx} {&FRAME-}
  9166. asm
  9167.                 xor     edx,edx
  9168.                 mov     eax,[esp+4][@Uses].TExcFrame.Next
  9169.                 mov     ecx,[esp+4][@Uses].TExcFrame.Desc
  9170.                 mov     fs:[edx],eax
  9171.                 mov     eax,[ecx].TExcDesc.Jmp.Distance
  9172.                 lea     eax,[ecx+eax].TExcDesc.Jmp[5]
  9173.                 cmp     eax,OFFSET _XcptFinally         // TRY..FINALLY block ?
  9174.                 jne     @@RET                           // No, TRY..EXCEPT => exit
  9175.                 add     ecx,TExcDesc.Instructions       // edx=0
  9176.                 Call    NotifyExitFinally               // Yes, execute FINALLY part
  9177.                 Call    ecx
  9178.                 mov     ecx,[esp][@Uses]
  9179.                 xor     edx,edx
  9180.                 Call    NotifyExitFinally
  9181.               @@RET:
  9182.                 PopArgs 12                      // Pop out exception frame
  9183. end;
  9184.  
  9185. // In the TRY...EXCEPT statement disposes of exception object and
  9186. // gets rid of exception
  9187.  
  9188. procedure _XcptDone(Report,Registration,Context,Void: Pointer); {&USES None} {&FRAME-}
  9189. asm
  9190. //              Pop RaiseList
  9191.                 push    OFFSET RaiseList
  9192.                 Call    _GetTlsVar
  9193.                 mov     edx,[eax]
  9194.                 mov     ecx,[edx].TRaiseFrame.NextRaise
  9195.                 mov     [eax],ecx
  9196. //              Destroy exception object
  9197.                 push    [edx].TRaiseFrame.ExceptObject
  9198.                 Call    TObject.Free
  9199.                 pop     ecx                     // Return address
  9200.                 mov     esp,Registration[9*4]   // Exception Frame
  9201.                 xor     eax,eax
  9202.                 pop     fs:[eax].Longint        // Previous frame
  9203.                 pop     eax                     // Exception handler@
  9204.                 pop     ebp                     // Saved EBP
  9205.                 Call    NotifyTerminate
  9206.                 jmp     ecx
  9207. end;
  9208.  
  9209. // Raises an exception on the return address
  9210.  
  9211. procedure _XcptRaise(Exception: Pointer); {&USES None} {&FRAME-}
  9212. asm
  9213. {$IFDEF WIN32}
  9214.                 mov     eax,[esp]
  9215.                 push    esp                     // [4]:Pointer = @arguments: @, Exception class
  9216.                 push    2                       // [3]:DWord = Argument count
  9217.                 push    cNonContinuable         // [3]:DWord = Flags
  9218.                 push    cLanguageException      // [1]:DWord = Exception #
  9219.                 push    eax                     // Return@
  9220.                 jmp     RaiseException
  9221. {$ELSE (~WIN32)}
  9222.                 pop     eax                     // Return address
  9223.                 pop     ecx                     // Exception object
  9224.                 sub     esp,TYPE TXcptReportRecord
  9225.                 mov     [esp].TXcptReportRecord.ExceptAddr,eax
  9226.                 mov     [esp].TXcptReportRecord.ExceptionAddress,eax
  9227.                 mov     [esp].TXcptReportRecord.ExceptObject,ecx
  9228.                 mov     [esp].TXcptReportRecord.cParameters,2
  9229.                 mov     [esp].TXcptReportRecord.fHandlerFlags,cNonContinuable
  9230.                 mov     [esp].TXcptReportRecord.ExceptionNum,cLanguageException
  9231.                 and     [esp].TXcptReportRecord.NestedXcptReportRecord,0
  9232.                 mov     ecx,esp
  9233.                 push    eax                     // Return address
  9234.                 push    ecx                     // [1]:Exception report record
  9235.                 call    System_RaiseException
  9236. {$IFDEF OS2}    pop     eax  {$ENDIF OS2}       // Stack cleanup
  9237. {$ENDIF ~WIN32}
  9238. end;
  9239.  
  9240. // Re-raises exception inside exception handler code
  9241.  
  9242. procedure _XcptRaiseAg(Report,Registration,Context,Void: Pointer); {&USES None} {&FRAME-}
  9243. asm
  9244.                 mov     eax,Registration[10*4]
  9245.                 mov     [eax].TExcFrame.Desc,OFFSET @@RET
  9246. //              Pop RaiseList
  9247.                 push    OFFSET RaiseList
  9248.                 Call    _GetTlsVar
  9249.                 mov     edx,[eax]               // RaiseList
  9250.                 mov     ecx,[edx].TRaiseFrame.NextRaise
  9251.                 mov     [eax],ecx               // RaiseList
  9252. //              Destroy object created for a non-language exception
  9253.                 mov     eax,[edx].TRaiseFrame.ExceptionRecord
  9254.                 and     [eax].TXcptReportRecord.fHandlerFlags,NOT cUnwinding
  9255.                 cmp     [eax].TXcptReportRecord.ExceptionNum,cLanguageException
  9256.                 je      @@Language
  9257.                 push    [edx].TRaiseFrame.ExceptObject
  9258.                 Call    TObject.Free
  9259.                 Call    NotifyReRaise
  9260.               @@Language:
  9261.                 xor     eax,eax
  9262.                 add     esp,5*4                 // Return@ + RaiseFrame
  9263.                 pop     ecx                     // Topmost frame
  9264.                 mov     edx,fs:[eax]
  9265.                 mov     edx,[edx].TExcFrame.Next
  9266.                 mov     [ecx].TExcFrame.Next,edx
  9267.                 pop     ebp
  9268.                 pop     edi
  9269.                 pop     esi
  9270.                 pop     ebx
  9271.               @@RET:
  9272.                 mov     eax,System_Xcpt_Continue_Search
  9273. end;
  9274.  
  9275. procedure _ExceptionHandler(Report,Registration,Context,Void: Pointer); assembler; {&USES ebx,esi,edi} {&FRAME+}
  9276. type
  9277.   ExceptionData = record
  9278.     No: Longint;
  9279.     EC: Byte;
  9280.   end;
  9281. const
  9282.   ExcpCount = 14;
  9283.   ExcpData: array [1..ExcpCount] of ExceptionData =
  9284.   (
  9285.     (No: XCPT_ARRAY_BOUNDS_EXCEEDED;    EC: RTE_Range_Check           ),
  9286.     (No: XCPT_FLOAT_DENORMAL_OPERAND;   EC: RTE_FP_Denormal_Operand   ),
  9287.     (No: XCPT_FLOAT_DIVIDE_BY_ZERO;     EC: RTE_Zero_Divide           ),
  9288.     (No: XCPT_FLOAT_INEXACT_RESULT;     EC: RTE_FP_Inexact_Result     ),
  9289.     (No: XCPT_FLOAT_INVALID_OPERATION;  EC: RTE_Invalid_FP_Operation  ),
  9290.     (No: XCPT_FLOAT_OVERFLOW;           EC: RTE_FP_Overflow           ),
  9291.     (No: XCPT_FLOAT_STACK_CHECK;        EC: RTE_Invalid_FP_Operation  ),
  9292.     (No: XCPT_FLOAT_UNDERFLOW;          EC: RTE_FP_Underflow          ),
  9293.     (No: XCPT_INTEGER_DIVIDE_BY_ZERO;   EC: RTE_Zero_Divide           ),
  9294.     (No: XCPT_INTEGER_OVERFLOW;         EC: RTE_Integer_Overflow      ),
  9295.     (No: XCPT_PRIVILEGED_INSTRUCTION;   EC: RTE_Privileged_Instruction),
  9296.     (No: XCPT_ACCESS_VIOLATION;         EC: RTE_Access_Violation      ),
  9297.     (No: XCPT_UNABLE_TO_GROW_STACK;     EC: RTE_Stack_Overflow        ),
  9298. {$IFDEF OS2}
  9299.     (No: XCPT_SIGNAL;                   EC: 0                         )
  9300. {$ENDIF OS2}
  9301. {$IFDEF WIN32}
  9302.     (No: XCPT_CONTROL_C_EXIT;           EC: RTE_Exception             )
  9303. {$ENDIF WIN32}
  9304. {$IFDEF DPMI32}
  9305.     (No: xcpt_Ctrl_Break;               EC: 0                         )
  9306. {$ENDIF DPMI32}
  9307. {$IFDEF LINUX}
  9308.     (No: xcpt_Ctrl_Break;               EC: 0                         )
  9309. {$ENDIF LINUX}
  9310.   );
  9311. asm
  9312.                 lea     esi,XcptProc
  9313.                 mov     ebx,[esi]               // XcptProc
  9314.               @@1:
  9315.                 mov     ecx,[esi]
  9316.                 jecxz   @@2
  9317.                 and     [esi].Longint,0         // Protect from infinite loop
  9318.                 push    Void                    // 4
  9319.                 push    Context                 // 3
  9320.                 push    Registration            // 2
  9321.                 push    Report                  // 1
  9322.                 Call    ecx
  9323. {$IFDEF OS2}    add     esp,4*4  {$ENDIF}       // OS/2: Stack cleanup
  9324.                 test    eax,eax                 // XCPT_CONTINUE_SEARCH ?
  9325.                 jz      @@1                     // Yes, search another handler
  9326.                 mov     [esi],ebx
  9327.                 jmp     @@RET                   // Exception is handled
  9328.               @@2:
  9329.                 mov     [esi],ebx               // Restore XcptProc
  9330.                 mov     eax,Report
  9331.                 test    [eax].TXcptReportRecord.fHandlerFlags,cUnwindInProgress
  9332.                 jnz     @@Done
  9333. {$IFDEF OS2}
  9334.                 Call    XcptIgnored
  9335.                 je      @@Done
  9336. {$ENDIF}
  9337.                 Call    _FpuInit
  9338.                 mov     edx,Registration
  9339. {$IFDEF WIN32}  push    0 {$ENDIF}
  9340.                 push    eax
  9341.                 push    OFFSET @@TargetEIP
  9342.                 push    edx
  9343.                 call    System_UnwindException  // Platform-dependent const
  9344.               @@TargetEIP:
  9345. {$IFDEF OS2}    add     esp,4*3      {$ENDIF}   // OS/2: Manual stack clean
  9346.                 mov     ebx,Report
  9347.                 mov     edx,[ebx].TXcptReportRecord.ExceptAddr
  9348.                 mov     eax,[ebx].TXcptReportRecord.ExceptObject
  9349.                 cmp     [ebx].TXcptReportRecord.ExceptionNum,cLanguageException
  9350.                 je      @@Language
  9351.                 mov     edx,ExceptObjProc
  9352.                 test    edx,edx
  9353.                 jz      @@MapToRunError
  9354.                 push    ebx                     // [1]:PXcptReportRecord
  9355.                 Call    edx
  9356.                 test    eax,eax
  9357.                 jz      @@MapToRunError
  9358.                 mov     edx,[ebx].TXcptReportRecord.ExceptionAddress
  9359.               @@Language:
  9360.                 Call    NotifyUnhandled
  9361.                 mov     ebx,edx
  9362.                 mov     ecx,ExceptProc
  9363.                 jecxz   @@NoExceptProc
  9364.                 push    eax                     // [1]:Exception Object
  9365.                 push    edx                     // [2]:Exception Address
  9366.                 Call    ecx
  9367.               @@NoExceptProc:
  9368.                 mov     ecx,Report
  9369.                 push    217                     // [1]:ErrorCode
  9370.                 push    ebx                     // Return address = exception@
  9371.                 jmp     _RunError
  9372.  
  9373. // Maps OS/2 System exceptions to run-time errors
  9374.  
  9375.               @@MapToRunError:
  9376.                 mov     ecx,Report
  9377.                 lea     edx,ExcpData
  9378.               @@3:
  9379.                 mov     eax,[ecx].TXcptReportRecord.ExceptionNum
  9380.                 cmp     eax,[edx].ExceptionData.No
  9381.                 mov      al,[edx].ExceptionData.EC
  9382.                 je      @@Error
  9383.                 add     edx,TYPE ExceptionData
  9384.                 cmp     edx,OFFSET ExcpData[ExcpCount*TYPE ExceptionData]
  9385.                 jne     @@3
  9386.                 mov     al,RTE_Exception
  9387.               @@Error:
  9388.                 test    al,al                   // We have to pass a few
  9389.                 jz      @@Done                  // exceptions to default handler
  9390.                 movzx   eax,al
  9391.                 push    eax                                          // [1]:Error Code
  9392.                 push    [ecx].TXcptReportRecord.ExceptionAddress // [2]:Address
  9393.                 mov     eax,[ecx].TXcptReportRecord.ExceptionNum
  9394.                 mov     ExceptionNo,eax
  9395.                 jmp     _RunError
  9396.  
  9397.               @@Done:
  9398.                 xor     eax,eax                 // XCPT_CONTINUE_SEARCH
  9399.               @@RET:
  9400. end;
  9401.  
  9402. begin
  9403.   DoInit;
  9404. end.
  9405.  
  9406.