home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sibdemo3.zip / SOURCE.DAT / SOURCE / RTL / SYSTEM.PAS < prev    next >
Pascal/Delphi Source File  |  1998-05-21  |  451KB  |  17,932 lines
  1. {VAL auf Überlauf abtesten}
  2.  
  3. UNIT System;
  4.  
  5. {$S-,I-,Q-,R-}
  6.  
  7. {***************************************************************************
  8.  *                                                                         *
  9.  * SPEED PASCAL for OS/2 V 2.0                                             *
  10.  * (C) 1992..95 SpeedSoft Software                                         *
  11.  *                                                                         *
  12.  * Unit SYSTEM : Low level basic functions                                 *
  13.  *                                                                         *
  14.  * Note: Compile with DWORD align !!                                       *
  15.  *                                                                         *
  16.  ***************************************************************************}
  17.  
  18. INTERFACE
  19.  
  20. //General functions
  21. FUNCTION Swap(i:INTEGER):INTEGER;
  22.  
  23. //General constants
  24. CONST
  25.      MINSHORTINT  = -128;
  26.      MAXSHORTINT  = 127;
  27.      MAXINT       = 32767;
  28.      MININT       =-32768;
  29.      MAXLONGINT   = 2147483647;
  30.      {$IFDEF DOSOS2}    //BP doesn't accept this
  31.      MINLONGINT   =-2147483647;
  32.      {$ELSE}
  33.      MINLONGINT   =-2147483648;
  34.      {$ENDIF}
  35.      MINBYTE      = 0;
  36.      MAXBYTE      = 255;
  37.      MINWORD      = 0;
  38.      MAXWORD      = 65535;
  39.      MAXLONGWORD  = $ffffffff;
  40.      MINLONGWORD  = 0;
  41.      NULLHANDLE   = 0;
  42.      SCUPointer:POINTER=NIL;
  43.  
  44. PROCEDURE Beep(Freq,duration:LONGWORD);
  45.  
  46. //General types
  47. TYPE
  48.     PChar    =^CSTRING;
  49.     PString  =^STRING;
  50.     Cardinal =LONGWORD;
  51.     AnsiChar =CHAR;
  52.  
  53.     PDATETIME=^DATETIME;
  54.     DATETIME=RECORD
  55.                   CASE INTEGER OF
  56.                      1: ( hour:BYTE;
  57.                           min:BYTE;
  58.                           sec:BYTE;
  59.                           hundredths:BYTE;
  60.                           day:BYTE;
  61.                           month:BYTE;
  62.                           year:WORD;
  63.                           timezone:INTEGER;
  64.                           weekday:BYTE;
  65.                         );
  66.                      2: ( hours:BYTE;
  67.                           minutes:BYTE;
  68.                           seconds:BYTE;
  69.                         );
  70.              END;
  71.  
  72.     {Generic procedure pointer}
  73.     TProcedure = procedure;
  74.  
  75. // Memory management functions
  76.  
  77. TYPE
  78.     HeapFunc=FUNCTION(size:LONGWORD):Integer;
  79.  
  80. VAR
  81.     HeapOrg:Pointer;           {Bottom of heap}
  82.     HeapEnd:Pointer;           {End of heap}
  83.     HeapPtr:Pointer;           {Actual heap position}
  84.     FreeList:Pointer;          {List of free blocks}
  85.     HeapTop:POINTER;           {Highest heap adress that has been commited}
  86.     HeapSize:LONGWORD;         {Size of heap}
  87.     HeapError:HeapFunc;        {Heap Error Function}
  88.     HeapResult:LONGWORD;       {Result from last heap function}
  89.     MemAvailBytes:LONGWORD;
  90.  
  91. FUNCTION  MaxAvail:LongWord;
  92. FUNCTION  MemAvail:LongWord;
  93. PROCEDURE GetMem(VAR p:Pointer;size:LongWord);
  94. PROCEDURE GetSharedMem(VAR pp:Pointer;size:LongWord);
  95. {$IFDEF OS2}
  96. PROCEDURE GetNamedSharedMem(CONST Name:STRING;VAR pp:POINTER;size:LongWord);
  97. FUNCTION AccessNamedSharedMem(CONST Name:STRING;VAR pp:POINTER):BOOLEAN;
  98. PROCEDURE FreeNamedSharedMem(CONST Name:STRING);
  99. {$ENDIF}
  100. FUNCTION AccessSharedMem(p:POINTER):BOOLEAN;
  101. PROCEDURE Mark(VAR p:POINTER);
  102. PROCEDURE Release(VAR p:POINTER);
  103. PROCEDURE FreeMem(p:pointer;size:LongWord);
  104. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  105. PROCEDURE GetAPIMem(VAR p:POINTER;size:LONGWORD);
  106. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  107. PROCEDURE NewSystemHeap;
  108. FUNCTION  CreateSystemHeap(Size:LONGWORD):BOOLEAN;
  109. PROCEDURE DestroySystemHeap;
  110. PROCEDURE DestroyHeap(Heap:POINTER);
  111. {Use this rotines to synchronize heap access when a thread is killed and
  112.  you don't know the state of the thread. This prevents heap corruption}
  113. {$IFDEF OS2}
  114. PROCEDURE RequestHeapMutex;
  115. PROCEDURE ReleaseHeapMutex;
  116. {$ENDIF}
  117.  
  118. {use this routine to write trace messages to the sibyl VDE}
  119. PROCEDURE Trace(CONST Value:STRING);
  120.  
  121. // Error functions
  122. VAR
  123.    ExitCode:LONGWORD;
  124.    ErrorAdr:POINTER;
  125.    ExitProc:POINTER;
  126.  
  127. PROCEDURE RunError(Code:LONGWORD);
  128. PROCEDURE Halt(Code:LONGWORD);
  129.  
  130. // Random numbers support
  131. VAR
  132.    RandSeed:LONGWORD;
  133.  
  134. PROCEDURE Randomize;
  135. FUNCTION  Random(value:word):word;
  136.  
  137. //Direct memory access
  138. PROCEDURE Move(CONST source;VAR dest;size:LongWord);
  139. PROCEDURE FillChar(VAR dest;size:LongWord;value:byte);
  140. FUNCTION CompareMem(VAR Buf1,Buf2;Size:LONGWORD):BOOLEAN;
  141.  
  142. //LongJmp support
  143.  
  144. TYPE Jmp_Buf=ARRAY[0..8] OF LONGWORD;
  145.  
  146. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  147. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  148.  
  149. //String functions
  150. FUNCTION Pos(CONST item,source:STRING):BYTE;
  151. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  152. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  153. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  154.  
  155. FUNCTION AnsiPOS(CONST item,source:AnsiString):LONGINT;
  156. FUNCTION AnsiPOSStr(CONST item:STRING;CONST source:AnsiString):LONGINT;
  157. FUNCTION AnsiCopy(CONST Source:AnsiString;Index,Count:LONGINT):AnsiString;
  158. PROCEDURE AnsiInsert(CONST Source:AnsiString; VAR S:AnsiString; Index:LONGINT);
  159. PROCEDURE AnsiInsertStr(CONST Source:String; VAR S:AnsiString; Index:LONGINT);
  160. PROCEDURE AnsiDelete(VAR S:AnsiString; Index,Count:LONGINT);
  161. PROCEDURE AnsiSetLength(VAR S:AnsiString;NewLength:LONGINT);
  162. PROCEDURE AnsiSetString(VAR S:AnsiString;Buffer:PChar;Len:LONGINT);
  163. PROCEDURE SetLength(VAR S:String;NewLength:LONGINT);
  164. PROCEDURE SetString(VAR S:String;Buffer:PChar;Len:LONGINT);
  165. PROCEDURE UniqueStr(VAR S:AnsiString);
  166.  
  167.  
  168. FUNCTION ToHex(l:LONGWORD):STRING;
  169. PROCEDURE SubStr(VAR source:STRING;start,ende:Byte);
  170. PROCEDURE UpcaseStr(VAR s:STRING);
  171.  
  172. {$IFDEF OS2}
  173. PROCEDURE InitPM;
  174. {$ENDIF}
  175.  
  176. //Floating point support
  177. CONST
  178.     rad=1;
  179.     deg=2;
  180.     gra=3;
  181.  
  182. VAR
  183.     IsNotRad:BOOLEAN;
  184.     ToRad,FromRad:EXTENDED;
  185.     FPUResult:WORD;
  186.  
  187. PROCEDURE SetTrigMode(mode:BYTE);
  188.  
  189. CONST
  190.      PI=3.141592653589793240;
  191.  
  192.  
  193. //CLASS support
  194.  
  195. {TYPE
  196.       (* Class structures layout, particulary also valid for objects *)
  197.       PClassInfoLayout=^TClassInfoLayout;
  198.       TClassInfoLayout=RECORD
  199.                              ClassSize:LONGWORD;
  200.                              ParentObjectAddr:POINTER;
  201.                              FieldAdress:POINTER;
  202.                              (*Class Info following here*)
  203.                        END;
  204.  
  205.       PDmtLayout=^TDmtLayout;
  206.       TDmtLayout=RECORD
  207.                        NumDmts:LONGWORD;  (*Number of entries*)
  208.                        (*entries follow here
  209.                          each entry is 8 byte long
  210.                          the first DWord contains the message id,
  211.                          the second DWord contains the VMT index*)
  212.                  END;
  213.  
  214.       PVmtLayOut=^TVmtLayOut;
  215.       TVmtLayOut=RECORD
  216.                        Dmt:PDmtLayout;  (*Pointer to DMT*)
  217.                        ClassInfo:PClassInfoLayout;
  218.                        ClassSize:LONGWORD;
  219.                        VmtSize:LONGWORD; (*Number of entries*)
  220.                        (*entries follow here
  221.                          each entry is 4 byte long and contains
  222.                          the address for that VMT index*)
  223.                  END;
  224.       TClassLayout=RECORD
  225.                          Vmt:PVmtLayout;
  226.                          (*Object variables follow here*)
  227.                    END;}
  228.  
  229. {Property type codes}
  230. TYPE
  231.      TPropertyType=BYTE;
  232.  
  233. CONST
  234.      PropType_Unsigned  =TPropertyType($80);
  235.      PropType_Signed    =TPropertyType($81);
  236.      PropType_Float     =TPropertyType($82);
  237.      PropType_Class     =TPropertyType($83);
  238.      PropType_String    =TPropertyType($84);
  239.      PropType_Enum      =TPropertyType($85);
  240.      PropType_Set       =TPropertyType($86);
  241.      PropType_Boolean   =TPropertyType($87);
  242.      PropType_Char      =TPropertyType($88);
  243.      PropType_CString   =TPropertyType($89);
  244.      PropType_ClassVar  =TPropertyType($8a);
  245.      PropType_ProcVar   =TPropertyType($8b);
  246.      PropType_FuncVar   =TPropertyType($8c);
  247.      PropType_Record    =TPropertyType($8d);
  248.      PropType_Link      =TPropertyType($8e);
  249.  
  250. {Property info record}
  251. TYPE
  252.     TPropertyReadWriteKind=BYTE;
  253.  
  254. CONST
  255.     PropReadWriteKind_Illegal       = TPropertyReadWriteKind(0);
  256.     PropReadWriteKind_VarOffset     = TPropertyReadWriteKind(1);
  257.     PropReadWriteKind_MethodOfs     = TPropertyReadWriteKind(2);
  258.     PropReadWriteKind_VmtIndex      = TPropertyReadWriteKind(3);
  259.  
  260. TYPE
  261.      TPropertyReadWriteRecord=RECORD
  262.                                     CASE Kind:TPropertyReadWriteKind OF
  263.                                         1:(VarOffset:LONGWORD);
  264.                                         2:(MethodAddress:POINTER);
  265.                                         3:(VmtIndex:LONGWORD);
  266.                               END;
  267.  
  268. TYPE TPropertyScope=Byte;
  269.  
  270. CONST
  271.      PropScope_Published  = 8;
  272.      PropScope_Stored     = 16;
  273.  
  274. TYPE TPropertyTypeInfo=RECORD
  275.                              Typ:TPropertyType;
  276.                              Size:LONGWORD;
  277.                              PropInfo:Pointer;
  278.                              NameTable:Pointer;
  279.                              TypeInfo:Pointer;
  280.                              Scope:TPropertyScope;
  281.                              Read:TPropertyReadWriteRecord;
  282.                              Write:TPropertyReadWriteRecord;
  283.                        END;
  284.  
  285. {Property enumeration}
  286. TYPE
  287.     TPropertyEnumProc=PROCEDURE(CONST PropertyName:PString;CONST Info:TPropertyTypeInfo);
  288.  
  289. TYPE
  290.     TObject = CLASS;
  291.     TClass  = CLASS OF TObject;
  292.     TObject = CLASS
  293.       PUBLIC
  294.             CONSTRUCTOR Create;
  295.             DESTRUCTOR Destroy; VIRTUAL;
  296.             PROCEDURE Free;
  297.             CLASS FUNCTION NewInstance: TObject;
  298.             PROCEDURE FreeInstance; VIRTUAL;
  299.             CLASS FUNCTION InitInstance(Instance: Pointer): TObject;
  300.             CLASS FUNCTION ClassType: TClass;
  301.             CLASS FUNCTION ClassName: STRING;
  302.             CLASS FUNCTION ClassUnit: STRING;
  303.             CLASS FUNCTION ClassParent: TClass;
  304.             CLASS FUNCTION ClassInfo: POINTER; //conflicts with PMWIN CLASSINFO
  305.             CLASS FUNCTION InstanceSize: LONGWORD;
  306.             CLASS FUNCTION InheritsFrom(AClass: TClass): BOOLEAN;
  307.             FUNCTION GetPropertyTypeInfo(PropertyName:STRING;VAR Info:TPropertyTypeInfo):BOOLEAN;
  308.             PROCEDURE EnumProperties(EnumProc:TPropertyEnumProc);
  309.             PROCEDURE DefaultHandler(VAR Message); VIRTUAL;
  310.             PROCEDURE DefaultFrameHandler(VAR Message); VIRTUAL;
  311.             PROCEDURE Dispatch(VAR Message);
  312.             PROCEDURE DispatchCommand(VAR Message;Command:LONGWORD);
  313.             PROCEDURE FrameDispatch(VAR Message);
  314.             CLASS FUNCTION MethodAddress(Name: STRING): POINTER;
  315.             CLASS FUNCTION VMTIndex(Name: STRING): LONGINT;
  316.             CLASS FUNCTION MethodName(Address: POINTER): STRING;
  317.             FUNCTION FieldAddress(Name: STRING): POINTER;
  318.     END;
  319.  
  320. //TextScreen IO support
  321. VAR
  322.    Input,Output:TEXT;
  323.  
  324. CONST
  325.      { CRT modes }
  326.      BW40          = 0;            { 40x25 B/W on Color Adapter   }
  327.      CO40          = 1;            { 40x25 Color on Color Adapter }
  328.      BW80          = 2;            { 80x25 B/W on Color Adapter   }
  329.      CO80          = 3;            { 80x25 Color on Color Adapter }
  330.      Mono          = 7;            { 80x25 on Monochrome Adapter  }
  331.      Font8x8       = 256;          { Add-in for 8x8 font          }
  332.  
  333. VAR
  334.    WindMin: WORD;    { Window upper left coordinates  }
  335.    WindMax: WORD;    { Window lower right coordinates }
  336.    LastMode: Word;   { Current text mode              }
  337.    TextAttr: BYTE;   { Current text attribute         }
  338.  
  339.    ApplicationType:BYTE;
  340.  
  341. CONST
  342.    DirectVideo: BOOLEAN = False; { Enable direct video addressing }
  343.    CheckSnow: BOOLEAN   = True;  { Enable snow filtering }
  344.  
  345. TYPE TScreenInOutClass=CLASS
  346.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  347.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  348.          PROCEDURE WriteLF;VIRTUAL;
  349.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  350.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  351.      END;
  352.  
  353.      TPMScreenInOutClass=CLASS
  354.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  355.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  356.          PROCEDURE WriteLF;VIRTUAL;
  357.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  358.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  359.          PROCEDURE Error;
  360.      END;
  361.  
  362. {$IFDEF OS2}
  363.      IMPORTS
  364.           FUNCTION WinInitializeAPI(flOptions:LONGWORD):LONGWORD;
  365.                           APIENTRY;             'PMWIN' index 763;
  366.           FUNCTION WinTerminateAPI(ahab:LONGWORD):BOOLEAN;
  367.                          APIENTRY;             'PMWIN' index 888;
  368.           FUNCTION WinCreateMsgQueueAPI(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  369.                           APIENTRY;             'PMWIN' index 716;
  370.           FUNCTION WinDestroyMsgQueueAPI(ahmq:LONGWORD):BOOLEAN;
  371.                           APIENTRY;             'PMWIN' index 726;
  372.      END;
  373. {$ENDIF}
  374.  
  375. VAR ScreenInOut:TScreenInOutClass;
  376.  
  377. {$IFDEF OS2}
  378. VAR
  379.     VioScrollDnProc:FUNCTION (usTopRow,usLeftCol,usBotRow,usRightCol,
  380.                               cbLines:LONGWORD;VAR pCell;ahvio:LONGWORD):WORD;CDECL;
  381.     VioScrollUpProc:FUNCTION (usTopRow,usLeftCol,usBotRow,usRightCol,
  382.                               cbLines:LONGWORD;VAR pCell;ahvio:LONGWORD):WORD;CDECL;
  383.     VioGetModeProc:FUNCTION (VAR apvioModeInfo;ahvio:LONGWORD):WORD;CDECL;
  384.     VioSetModeProc:FUNCTION (VAR apvioModeInfo;ahvio:LONGWORD):WORD;CDECL;
  385.     VioWhereXProc:FUNCTION:BYTE;CDECL;
  386.     VioWhereYProc:FUNCTION:BYTE;CDECL;
  387.     VioSetCurPosProc:FUNCTION (usRow,usColumn:LONGWORD;ahvio:LONGWORD):WORD;CDECL;
  388.     VioReadCellStrProc:FUNCTION (VAR pchCellStr;VAR pcb:WORD;usRow,
  389.                                  usColumn:LONGWORD;ahvio:LONGWORD):WORD;CDECL;
  390.     VioGetConfigProc:FUNCTION (usConfigId:LONGWORD;VAR pvioin;
  391.                                ahvio:LONGWORD):WORD;CDECL;
  392.     KbdStringInProc: FUNCTION (VAR apch;VAR pchIn;fsWait:LONGWORD;
  393.                                ahkbd:LONGWORD):WORD;CDECL;
  394.     ReadKeyProc:FUNCTION:CHAR;CDECL;
  395.     KeyPressedProc:FUNCTION:BOOLEAN;CDECL;
  396. {$ENDIF}
  397.  
  398. //File I/O support
  399. TYPE
  400. {$IFDEF OS2}
  401.       {Extended attributes information returned by GetEAInfo}
  402.       PFEADATA=^TFEADATA;
  403.       TFEADATA=ARRAY[0..65535] OF BYTE;
  404.       PHOLDFEA=^THOLDFEA;
  405.       THOLDFEA=RECORD
  406.                      {oNextEntryOffset:LONGWORD; // new field}
  407.                      fEA:BYTE;                  // Flag byte
  408.                      cbName:BYTE;
  409.                      cbValue:WORD;
  410.                      szName:CSTRING;
  411.                      aValue:PFEADATA;
  412.                      Deleted:BOOLEAN;           //true to delete EA on write
  413.                      next:PHOLDFEA;
  414.       END;
  415. {$ENDIF}
  416.  
  417.       P_FileBuffer=^T_FileBuffer;
  418.       T_FileBuffer=ARRAY[0..MaxLongInt-1] OF BYTE; {handled dynamically}
  419.  
  420.       FileRec = RECORD
  421.                       Handle          : LongWord;     {FileHandle            }
  422.                       RecSize         : LongWord;     {Record size           }
  423.                       Name            : STRING;       {(Long) file name      }
  424.                       {$IFDEF OS2}
  425.                       EAS             : PHOLDFEA;     {extended attributes   }
  426.                       {$ENDIF}
  427.                       {$IFDEF WIN95}
  428.                       EAS             : POINTER;      {Unused                }
  429.                       {$ENDIF}
  430.                       Mode            : LONGWORD;     {Current file mode     }
  431.                       Reserved        : POINTER;      {for private extensions}
  432.                       Block           : LONGWORD;     {current block in file }
  433.                       LBlock          : LONGWORD;     {Last block in file    }
  434.                       Offset          : LONGWORD;     {Current offset in Block}
  435.                       LOffset         : LONGWORD;     {Last Offset in LBlock }
  436.                       Changed         : LONGBOOL;     {TRUE if Block has changed}
  437.                       Buffer          : P_FileBuffer; {I/O Buffer            }
  438.                       MaxCacheMem     : LONGWORD;     {Size of I/O Buffer    }
  439.                       Flags           : LONGWORD;     {Assign flags $6666    }
  440.                       Reserved1       : WORD;         {dont use              }
  441.                       BufferBytes     : WORD;         {dont use              }
  442.                       {312 byte til here}
  443.                 END;
  444.  
  445. VAR
  446.    InOutRes:LONGWORD;
  447.  
  448. FUNCTION IOResult: Integer;
  449. {$IFDEF OS2}
  450. FUNCTION OS2Result: Integer;
  451. {$ENDIF}
  452.  
  453. {$IFDEF OS2}
  454. CONST
  455.    //Sharing options - use this way: FileMode:=(FileMode AND 15) OR Value;
  456.    fmDenyRead   = $30;   {deny read access by other processes         }
  457.    fmDenyWrite  = $20;   {deny write access by other processes        }
  458.    fmDenyNone   = $40;   {deny neither read nor write                 }
  459.    fmDenyBoth   = $10;   {deny both read and write access (standard)  }
  460.  
  461.    {FileMode values}
  462.    fmClosed     = 0;
  463.    fmInput      = 0 OR fmDenyWrite; {Read only                                   }
  464.    fmOutput     = 1 OR fmDenyRead;  {Write only                                  }
  465.    fmInOut      = 2 OR fmDenyNone;  {allow both read and write access (standard) }
  466. {$ENDIF}
  467. {$IFDEF WIN95}
  468. CONST
  469.    {FileMode values}
  470.    fmDenyRead   = $00000002; {deny read access by other processes         }
  471.    fmDenyWrite  = $00000001; {deny write access by other processes        }
  472.    fmDenyNone   = $00000003; {deny neither read nor write                 }
  473.    fmDenyBoth   = $0;        {deny both read and write access (standard)  }
  474.  
  475.    fmClosed     = 0;
  476.    fmInput      = $80000000 or fmDenyWrite; {Read only                                   }
  477.    fmOutput     = $40000000 or fmDenyRead;  {Write only                                  }
  478.    fmInOut      = $C0000000 or fmDenyNone;  {allow both read and write access (standard) }
  479. {$ENDIF}
  480.  
  481. CONST
  482.    {Seek Origin Constants}
  483.    Seek_Begin     = 0;   //Seek from beginning of file
  484.    Seek_Current   = 1;   //Seek from current position of file
  485.    Seek_End       = 2;   //Seek from end of file
  486.  
  487. VAR
  488.    FileMode:LONGWORD;   {file mode for both reset and rewrite}
  489.    SeekMode:LONGWORD;   {seek mode for seek                  }
  490.  
  491. TYPE TextFile=TEXT;
  492.  
  493. PROCEDURE Assign(VAR f:FILE;CONST s:STRING);
  494. PROCEDURE AssignFile(VAR f:FILE;CONST s:STRING);
  495. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  496. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  497. PROCEDURE Close(VAR f:FILE);
  498. PROCEDURE CloseFile(VAR f:FILE);
  499. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  500. PROCEDURE BlockWrite(VAR f:file;VAR Buf;Count:LongWord;VAR result:LONGWORD);
  501. PROCEDURE Rename(VAR f:file;NewName:String);
  502. PROCEDURE Truncate(VAR f:FILE);
  503. PROCEDURE Append(VAR f:Text);
  504. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  505. FUNCTION SeekEof(VAR F :Text):Boolean;
  506. FUNCTION SeekEoln(VAR F:Text):Boolean;
  507. FUNCTION FilePos(VAR f:FILE):LONGWORD;
  508. FUNCTION FileSize(VAR f:FILE):LONGWORD;
  509. FUNCTION Eof(VAR f:FILE):BOOLEAN;
  510. FUNCTION Eoln(VAR F:Text):Boolean;
  511. PROCEDURE Erase(VAR f:FILE);
  512. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  513. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  514.  
  515. //Funtions for manipulating EAS
  516. //EAS will be written with a DosClose call, but the file should then
  517. //not be occupied by another process or thread, Close must have
  518. //exclusive access to the file or EA setting will fail ! When using
  519. //the standard filemode with fmdenyBoth this is save
  520. {$IFDEF OS2}
  521. FUNCTION GetEAData(VAR f:FILE):PHOLDFEA;
  522. PROCEDURE SetEAData(VAR f:FILE;EAData:PHOLDFEA);
  523. PROCEDURE DeleteEAData(VAR f:FILE);
  524. {$ENDIF}
  525.  
  526. //Functions for manipulating directories
  527. PROCEDURE ChDir(CONST path:STRING);
  528. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  529. PROCEDURE RmDir(CONST dir:STRING);
  530. PROCEDURE MkDir(CONST dir:STRING);
  531.  
  532. FUNCTION  PARAMSTR(item:Byte):STRING;
  533. FUNCTION  PARAMCOUNT:Byte;
  534.  
  535. //Exception Management
  536. {$IFDEF OS2}
  537.   {
  538.    * ExceptionReportRecord
  539.    *
  540.    * This structure contains machine independant information about an
  541.    * exception/unwind. No system exception will ever have more than
  542.    * EXCEPTION_MAXIMUM_PARAMETERS parameters. User exceptions are not
  543.    * bound to this limit.
  544.    }
  545. CONST
  546.     EXCEPTION_MAXIMUM_PARAMETERS =4;  { Enough for all system exceptions. }
  547.  
  548. TYPE
  549.     PEXCEPTIONREPORTRECORD=^EXCEPTIONREPORTRECORD;
  550.     EXCEPTIONREPORTRECORD=RECORD
  551.              ExceptionNum:LONGWORD;     { exception number }
  552.              fHandlerFlags:LONGWORD;
  553.              NestedExceptionReportRecord:PEXCEPTIONREPORTRECORD;
  554.              ExceptionAddress:POINTER;
  555.              cParameters:LONGWORD; { Size of Exception Specific Info }
  556.              ExceptionInfo:ARRAY[0..EXCEPTION_MAXIMUM_PARAMETERS] OF LONGWORD;
  557.     END;
  558.  
  559.     {
  560.      * ExceptionRegistrationRecord
  561.      *
  562.      * These are linked together to form a chain of exception handlers that
  563.      * will be dispatched to upon receipt of an exception.
  564.     }
  565.     _ERR=POINTER; {Exception handler entry address}
  566.  
  567.     SysException=Class;  {forward definition}
  568.  
  569.     PEXCEPTIONREGISTRATIONRECORD=^EXCEPTIONREGISTRATIONRECORD;
  570.     EXCEPTIONREGISTRATIONRECORD=RECORD
  571.               prev_structure:PEXCEPTIONREGISTRATIONRECORD;
  572.               ExceptionHandler:_ERR;
  573.               {this fields are new !!}
  574.               ObjectType:SysException;
  575.               jmpWorker:jmp_buf;
  576.     END;
  577.  
  578.     PFPEG=^FPREG;
  579.     FPREG=RECORD {pack 1}
  580.                losig:LONGWORD;
  581.                hisig:LONGWORD;
  582.                signexp:WORD;
  583.           END;
  584.  
  585.     PCONTEXTRECORD=^CONTEXTRECORD;
  586.     CONTEXTRECORD=RECORD
  587.                   ContextFlags:LONGWORD;
  588.                   ctx_env:ARRAY[0..6] OF LONGWORD;
  589.                   ctx_stack:ARRAY[0..7] OF FPREG;
  590.                   ctx_SegGs:LONGWORD;
  591.                   ctx_SegFs:LONGWORD;
  592.                   ctx_SegEs:LONGWORD;
  593.                   ctx_SegDs:LONGWORD;
  594.                   ctx_RegEdi:LONGWORD;
  595.                   ctx_RegEsi:LONGWORD;
  596.                   ctx_RegEax:LONGWORD;
  597.                   ctx_RegEbx:LONGWORD;
  598.                   ctx_RegEcx:LONGWORD;
  599.                   ctx_RegEdx:LONGWORD;
  600.                   ctx_RegEbp:LONGWORD;
  601.                   ctx_RegEip:LONGWORD;
  602.                   ctx_SegCs:LONGWORD;
  603.                   ctx_EFlags:LONGWORD;
  604.                   ctx_RegEsp:LONGWORD;
  605.                   ctx_SegSs:LONGWORD;
  606.            END;
  607. {$ENDIF}
  608. {$IFDEF WIN95}
  609. //Exception Management
  610.  
  611.   { Exceptions }
  612. CONST
  613.      SIZE_OF_80387_REGISTERS      = 80;
  614.  
  615. TYPE
  616.     PFLOATING_SAVE_AREA=^FLOATING_SAVE_AREA;
  617.     FLOATING_SAVE_AREA=RECORD
  618.                              ControlWord:LONGWORD;
  619.                              StatusWord:LONGWORD;
  620.                              TagWord:LONGWORD;
  621.                              ErrorOffset:LONGWORD;
  622.                              ErrorSelector:LONGWORD;
  623.                              DataOffset:LONGWORD;
  624.                              DataSelector:LONGWORD;
  625.                              RegisterArea:ARRAY[0..SIZE_OF_80387_REGISTERS-1] OF BYTE;
  626.                              Cr0NpxState:LONGWORD;
  627.     END;
  628.  
  629. TYPE
  630.     PCONTEXT=^CONTEXT;
  631.     CONTEXT=RECORD
  632.                   ContextFlags:LONGWORD;
  633.                   Dr0:LONGWORD;
  634.                   Dr1:LONGWORD;
  635.                   Dr2:LONGWORD;
  636.                   Dr3:LONGWORD;
  637.                   Dr6:LONGWORD;
  638.                   Dr7:LONGWORD;
  639.  
  640.                   FloatSave:FLOATING_SAVE_AREA;
  641.  
  642.                   SegGs:LONGWORD;
  643.                   SegFs:LONGWORD;
  644.                   SegEs:LONGWORD;
  645.                   SegDs:LONGWORD;
  646.  
  647.                   Edi:LONGWORD;
  648.                   Esi:LONGWORD;
  649.                   Ebx:LONGWORD;
  650.                   Edx:LONGWORD;
  651.                   Ecx:LONGWORD;
  652.                   Eax:LONGWORD;
  653.  
  654.                   Ebp:LONGWORD;
  655.                   Eip:LONGWORD;
  656.                   SegCs:LONGWORD;
  657.                   EFlags:LONGWORD;
  658.                   Esp:LONGWORD;
  659.                   SegSs:LONGWORD;
  660.     END;
  661.  
  662. CONST
  663.      EXCEPTION_CONTINUABLE         = 0; // Continuable exception
  664.      EXCEPTION_NONCONTINUABLE      = 1; // Noncontinuable exception
  665.      EXCEPTION_MAXIMUM_PARAMETERS  =15; // maximum number of exception parameters
  666.  
  667. TYPE
  668.     PEXCEPTION_RECORD=^EXCEPTION_RECORD;
  669.     EXCEPTION_RECORD=RECORD
  670.                            ExceptionCode:LONGWORD;
  671.                            ExceptionFlags:LONGWORD;
  672.                            ExceptionRecord:PEXCEPTION_RECORD;
  673.                            ExceptionAddress:POINTER;
  674.                            NumberParameters:LONGWORD;
  675.                            ExceptionInformation:ARRAY[0..EXCEPTION_MAXIMUM_PARAMETERS-1] OF LONGWORD;
  676.     END;
  677.  
  678. TYPE
  679.     PEXCEPTION_POINTERS=^EXCEPTION_POINTERS;
  680.     EXCEPTION_POINTERS=RECORD
  681.                              ExceptionRecord:PEXCEPTION_RECORD;
  682.                              ContextRecord:PCONTEXT;
  683.     END;
  684.  
  685. TYPE
  686.   SysException=CLASS;
  687.  
  688.   PExcptInfo=^TExcptInfo;
  689.   TExcptInfo=RECORD
  690.                      TryAddr:POINTER;
  691.                      ExcptAddr:POINTER;
  692.                      OldEBP,OldESP:LONGWORD;
  693.                      OldFPUControl:LONGWORD;
  694.                      ExcptObject:SysException;
  695.                      ThreadId:LONGWORD;
  696.                      Next:PExcptInfo;
  697.                      Last:PExcptInfo;
  698.   END;
  699. {$ENDIF}
  700.  
  701.   { Exceptions }
  702.   //base exception record - derive all new exceptions from that !
  703.   SysException = CLASS(TObject)
  704.       PRIVATE
  705.             FMessage: PString;
  706.             FHelpContext:LONGINT;
  707.             FUNCTION GetMessage: STRING;
  708.             PROCEDURE SetMessage(CONST Value: STRING);
  709.       PUBLIC
  710.             {$IFDEF OS2}
  711.             ReportRecord:EXCEPTIONREPORTRECORD;
  712.             {$ENDIF}
  713.             {$IFDEF WIN95}
  714.             ReportRecord:EXCEPTION_RECORD;
  715.             {$ENDIF}
  716.             ExcptNum:LONGWORD;
  717.             CameFromRTL:BOOLEAN;
  718.             Nested:BOOLEAN;
  719.             ExcptAddr:POINTER;
  720.             RTLExcptAddr:POINTER;
  721.             {$IFDEF OS2}
  722.             RegistrationRecord:EXCEPTIONREGISTRATIONRECORD;
  723.             ContextRecord:CONTEXTRECORD;
  724.             {$ENDIF}
  725.             {$IFDEF WIN95}
  726.             ContextRecord:CONTEXT;
  727.             {$ENDIF}
  728.  
  729.             CONSTRUCTOR Create(CONST Msg: STRING);
  730.             DESTRUCTOR Destroy;OVERRIDE;
  731.       PUBLIC
  732.             PROPERTY HelpContext:LONGINT read FHelpContext write FHelpContext;
  733.             PROPERTY Message:STRING read GetMessage write SetMessage;
  734.             PROPERTY  MessagePtr: PString read FMessage;
  735.   END;
  736.  
  737.   //General exception class
  738.   SysExceptClass = class OF SysException;
  739.  
  740.   //Software generated excpetions
  741.   EProcessTerm = CLASS(SysException);
  742.  
  743.   //Hardware generated exceptions
  744.   EProcessorException = CLASS(SysException);
  745.   EFault = CLASS(EProcessorException);
  746.   EGPFault = CLASS(EFault);
  747.   EStackFault = CLASS(EFault);
  748.   EPageFault = CLASS(EFault);
  749.   EInvalidOpCode = CLASS(EFault);
  750.   EBreakpoint = CLASS(EProcessorException);
  751.   ESingleStep = CLASS(EProcessorException);
  752.  
  753.   //Memory exceptions
  754.   EOutOfMemory = CLASS(SysException);
  755.   EInvalidPointer = CLASS(SysException);
  756.   EInvalidHeap    = CLASS(SysException);
  757.  
  758.   //Input/Output exceptions
  759.   EInOutError = CLASS(SysException)
  760.      PUBLIC
  761.            ErrorCode: Integer;
  762.   END;
  763.   EFileNotFound=CLASS(EInOutError);
  764.   EInvalidFileName=CLASS(EInOutError);
  765.   ETooManyOpenFiles=CLASS(EInOutError);
  766.   EAccessDenied=CLASS(EInOutError);
  767.   EEndOfFile=CLASS(EInOutError);
  768.   EDiskFull=CLASS(EInOutError);
  769.   EInvalidInput=CLASS(EInOutError);
  770.  
  771.   //Integer math exceptions
  772.   EIntError = CLASS(SysException);
  773.   EDivByZero = CLASS(EIntError);
  774.   ERangeError = CLASS(EIntError);
  775.   EIntOverflow = CLASS(EIntError);
  776.  
  777.   //Floating point math exceptions
  778.   EMathError = CLASS(SysException);
  779.   EInvalidOp = CLASS(EMathError);
  780.   EZeroDivide = CLASS(EMathError);
  781.   EOverflow = CLASS(EMathError);
  782.   EUnderflow = CLASS(EMathError);
  783.  
  784.   //type cast exceptions
  785.   EInvalidCast = CLASS(SysException);
  786.  
  787.   //Silent exceptions
  788.   EAbort = CLASS(SysException);
  789.  
  790. PROCEDURE Abort;
  791.  
  792. //PM Routines
  793. VAR
  794.     DllModule:LONGWORD;
  795.     DllTerminating:LONGWORD;
  796.     DllInitTermResult:LONGWORD;
  797.     ModuleCount:BYTE;
  798.  
  799.     RaiseIOError:BOOLEAN;
  800.  
  801. {$IFDEF OS2}
  802. FUNCTION WinInitialize(flOptions:LONGWORD):LONGWORD;
  803. FUNCTION WinTerminate(ahab:LONGWORD):BOOLEAN;
  804. FUNCTION WinCreateMsgQueue(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  805. FUNCTION WinDestroyMsgQueue(ahmq:LONGWORD):BOOLEAN;
  806. PROCEDURE SelToFlat(VAR p:POINTER);
  807. {$ENDIF}
  808. PROCEDURE MainDispatchLoop;
  809.  
  810. //Variant support
  811. FUNCTION VarType(CONST v:VARIANT):WORD;
  812. FUNCTION VarIsNull(CONST v:VARIANT):BOOLEAN;
  813.  
  814. //Variant type constants (also in BASIS.PAS)
  815. CONST
  816.      VarEmpty      = $0000;
  817.      VarNull       = $0001;
  818.      VarSmallInt   = $0002;
  819.      VarInteger    = $0003;
  820.      VarLongint    = $0004;
  821.      VarSingle     = $0005;
  822.      VarDouble     = $0006;
  823.      VarExtended   = $0007;
  824.      VarBoolean    = $0008;
  825.      VarByte       = $0009;
  826.      VarWord       = $000a;
  827.      VarLongWord   = $000b;
  828.      VarChar       = $000c;
  829.      VarComp       = $000d;
  830.      VarCurrency   = $000e;
  831.      VarString     = $0100;
  832.  
  833.      VarTypeMask   = $0fff;
  834.  
  835. TYPE EVariantError=CLASS(SysException);
  836.  
  837.      //Variant Record
  838.      TVarData=RECORD
  839.                     VType:WORD;
  840.                     CASE Integer OF
  841.                        0:(Data:ARRAY[1..5] OF WORD;reserved1,reserved2:WORD);
  842.                        VarSmallInt:(VSmallInt:ShortInt);
  843.                        VarInteger:(VInteger:Integer);
  844.                        VarLongint:(VLongInt:LONGINT);
  845.                        VarSingle:(VSingle:Single);
  846.                        VarDouble:(VDouble:Double);
  847.                        VarExtended:(VExtended:Extended);
  848.                        VarComp:(VComp:Comp);
  849.                        VarBoolean:(VBoolean:Boolean);
  850.                        VarByte:(VByte:BYTE);
  851.                        VarWord:(VWord:Word);
  852.                        VarLongWord:(VLongWord:LongWord);
  853.                        VarChar:(VChar:Char);
  854.                        VarString:(VString:Pointer);
  855.                        VarCurrency:(VCurrency:Currency);
  856.      END;
  857.  
  858. //Open array support
  859. CONST
  860.      vtInteger    =0;
  861.      vtBoolean    =1;
  862.      vtChar       =2;
  863.      vtExtended   =3;
  864.      vtString     =4;
  865.      vtPointer    =5;
  866.      vtPChar      =6;
  867.      vtObject     =7;
  868.      vtClass      =8;
  869.      vtWideChar   =9;
  870.      vtPWideChar  =10;
  871.      vtAnsiString =11;
  872.      vtCurrency   =12;
  873.      vtVariant    =13;
  874.  
  875. TYPE
  876.      //Open Array Record
  877.      TVarRec=RECORD
  878.                    CASE VType:BYTE OF
  879.                        vtInteger:(VInteger:LONGINT);
  880.                        vtBoolean:(VBoolean:Boolean);
  881.                        vtChar:(VChar:Char);
  882.                        vtExtended:(VExtended:^Extended);
  883.                        vtString:(VString:^ShortString);
  884.                        vtPointer:(VPointer:Pointer);
  885.                        vtPChar:(VPChar:PChar);
  886.                        vtObject:(VObject:TObject);
  887.                        vtClass:(VClass:TClass);
  888.                        //vtWideChar:(VWideChar:WideChar);
  889.                        //vtPWideChar:(VPWideChar:PWideChar);
  890.                        vtAnsiString:(VAnsiString:Pointer);
  891.                        vtCurrency:(VCurrency:^Currency);
  892.                        vtVariant:(VVariant:^Variant);
  893.              END;
  894.  
  895. //Named resource management
  896. FUNCTION FindIconRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  897. FUNCTION FindBitmapRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  898. FUNCTION FindStringTableRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  899. FUNCTION GetStringTableEntry(CONST Table:STRING;Ident:WORD):STRING;
  900.  
  901. //Thread support
  902. TYPE TThreadFunc=FUNCTION(Param:POINTER):LONGINT;
  903.  
  904.      EAssertionFailed=Class(SysException);
  905.  
  906. CONST
  907.      //BeginThread options
  908.      {$IFDEF OS2}
  909.      THREAD_SUSPENDED     =1;
  910.      {$ENDIF}
  911.      {$IFDEF WIN95}
  912.      THREAD_SUSPENDED     =4;
  913.      {$ENDIF}
  914.  
  915. FUNCTION GetThreadId:LONGWORD;
  916. FUNCTION BeginThread(SecurityAttrs:POINTER;StackSize:LONGWORD;
  917.                      ThreadFunc:TThreadFunc;Parameter:Pointer;
  918.                      Options:LONGWORD;VAR id:LONGWORD):LONGWORD;
  919. PROCEDURE KillThread(atid:LONGWORD);
  920. PROCEDURE EndThread(ExitCode:LONGINT);
  921.  
  922. FUNCTION IsConsole:BOOLEAN;
  923. FUNCTION IsLibrary:BOOLEAN;
  924.  
  925. FUNCTION AppHandle:LONGWORD;
  926. FUNCTION MainAppHandle:LONGWORD;
  927. FUNCTION AppQueueHandle:LONGWORD;
  928. FUNCTION MainAppQueueHandle:LONGWORD;
  929. FUNCTION HInstance:LONGWORD;
  930.  
  931. IMPLEMENTATION
  932.  
  933. PROCEDURE Assertion(Expression:Boolean;Const Msg:String;line:LongWord;
  934.                     Const FileName:String);
  935. Var s:String;
  936. Begin
  937.      If not Expression Then
  938.      Begin
  939.           If Msg='' Then s:='Assertion failed'
  940.           Else s:=Msg;
  941.           s:=s+#13#10+'in '+FileName+' ('+tostr(Line)+')';
  942.           Raise EAssertionFailed.Create(s);
  943.      End;
  944. End;
  945.  
  946. VAR AppHandleIntern,AppQueueHandleIntern:LONGWORD;
  947.  
  948. FUNCTION MainAppHandle:LONGWORD;
  949. BEGIN
  950.      result:=AppHandleIntern;
  951. END;
  952.  
  953. FUNCTION MainAppQueueHandle:LONGWORD;
  954. BEGIN
  955.      result:=AppQueueHandleIntern;
  956. END;
  957.  
  958. {$IFDEF OS2}
  959. FUNCTION WinQueryAnchorBlock(ahwnd:LONGWORD):LONGWORD;
  960.                           APIENTRY;           external 'PMWIN' index 800;
  961.  
  962. FUNCTION WinQueryActiveWindow(hwndDesktop:LONGWORD):LONGWORD;
  963.                           APIENTRY;           external 'PMWIN' index 799;
  964.  
  965. CONST
  966.      HWND_DESKTOP           =1;
  967. {$ENDIF}
  968.  
  969. FUNCTION AppHandle:LONGWORD;
  970. {$IFDEF OS2}
  971. VAR id:LONGINT;
  972. {$ENDIF}
  973. BEGIN
  974.      result:=AppHandleIntern;
  975.      {$IFDEF OS2}
  976.      ASM
  977.         MOV EDI,$0c
  978.         db $64
  979.         MOV EBX,[EDI]          //MOV EBX,FS:[EDI]
  980.         MOV EBX,[EBX]          //get thread ID
  981.         DEC EBX
  982.         MOV id,EBX
  983.      END;
  984.  
  985.      IF id>0 THEN IF ApplicationType=1 THEN
  986.      BEGIN
  987.           result:=WinQueryAnchorBlock(HWND_DESKTOP);
  988.           IF result=0 THEN result:=WinQueryAnchorBlock(WinQueryActiveWindow(HWND_DESKTOP));
  989.           IF result=0 THEN result:=AppHandleIntern;
  990.      END;
  991.      {$ENDIF}
  992. END;
  993.  
  994. //Thread information block (TIB)
  995. TYPE
  996.     PTIB2=^TIB2;
  997.     TIB2=RECORD
  998.               tib2_ultid:LONGWORD;             { Thread I.D. }
  999.               tib2_ulpri:LONGWORD;             { Thread priority }
  1000.               tib2_version:LONGWORD;           { Version number for this structure }
  1001.               tib2_usMCCount:WORD;        { Must Complete count }
  1002.               tib2_fMCForceFlag:WORD;     { Must Complete force flag }
  1003.          END;
  1004.  
  1005.     PTIB=^TIB;
  1006.     TIB=RECORD
  1007.               tib_pexchain:POINTER;     { Head of exception handler chain }
  1008.               tib_pstack:POINTER;       { Pointer to base of stack }
  1009.               tib_pstacklimit:POINTER;  { Pointer to end of stack }
  1010.               tib_ptib2:PTIB2;          { Pointer to system specific TIB }
  1011.               tib_version:LONGWORD;        { Version number for this TIB structure }
  1012.               tib_ordinal:LONGWORD;        { Thread ordinal number        }
  1013.         END;
  1014.  
  1015.  
  1016. //Process Information Block (PIB)
  1017. TYPE
  1018.     PPIB=^PIB;
  1019.     PIB=RECORD
  1020.              pib_ulpid:LONGWORD;          { Process I.D. }
  1021.              pib_ulppid:LONGWORD;         { Parent process I.D. }
  1022.              pib_hmte:LONGWORD;           { Program (.EXE) module handle }
  1023.              pib_pchcmd:PChar;         { Command line pointer }
  1024.              pib_pchenv:PChar;         { Environment pointer }
  1025.              pib_flstatus:LONGWORD;       { Process' status bits }
  1026.              pib_ultype:LONGWORD;         { Process' type code }
  1027.        END;
  1028.  
  1029.  
  1030. {$IFDEF OS2}
  1031. FUNCTION DosGetInfoBlocks(VAR pptib:PTIB;VAR pppib:PPIB):LONGWORD;
  1032.                     APIENTRY;    external 'DOSCALLS' index 312;
  1033.  
  1034. FUNCTION WinQueueFromId(ahab:LONGWORD;idPid:LONGWORD;idTid:LONGWORD):LONGWORD;
  1035.                     APIENTRY;    external 'PMWIN' index 993;
  1036. {$ENDIF}
  1037.  
  1038. FUNCTION AppQueueHandle:LONGWORD;
  1039. {$IFDEF OS2}
  1040. VAR tib:PTIB;
  1041.     pib:PPIB;
  1042. {$ENDIF}
  1043. BEGIN
  1044.      result:=AppQueueHandleIntern;
  1045.  
  1046.      {$IFDEF OS2}
  1047.      tib:=NIL;
  1048.      pib:=NIL;
  1049.      DosGetInfoBlocks(tib,pib);
  1050.      IF ((tib<>NIL)AND(tib^.tib_ptib2<>NIL)AND(pib<>NIL)) THEN
  1051.        IF tib^.tib_ptib2^.tib2_ultid>1 THEN //not for main thread
  1052.      BEGIN
  1053.           result:=WinQueueFromId(AppHandle,pib^.pib_ulpid,tib^.tib_ptib2^.tib2_ultid);
  1054.           IF result=0 THEN result:=AppQueueHandleIntern;
  1055.      END;
  1056.      {$ENDIF}
  1057. END;
  1058.  
  1059. FUNCTION HInstance:LONGWORD;
  1060. BEGIN
  1061.      result:=AppHandle;
  1062. END;
  1063.  
  1064. //Currency constants
  1065. CONST ToCurrency:Extended=10000;
  1066.       FromCurrency:Extended=0.0001;
  1067.  
  1068. //Variant support
  1069.  
  1070. FUNCTION Variant2Str(CONST v:VARIANT):STRING;
  1071. VAR
  1072.     p:POINTER;
  1073.     s:^SINGLE ABSOLUTE p;
  1074.     e:^EXTENDED ABSOLUTE p;
  1075.     d:^DOUBLE ABSOLUTE p;
  1076.     si:^SHORTINT ABSOLUTE p;
  1077.     i:^INTEGER ABSOLUTE p;
  1078.     li:^LONGINT ABSOLUTE p;
  1079.     b:^BYTE ABSOLUTE p;
  1080.     w:^WORD ABSOLUTE p;
  1081.     co:^COMP ABSOLUTE p;
  1082.     cu:^Currency ABSOLUTE p;
  1083.     lw:^LONGWORD ABSOLUTE p;
  1084.     bo:^BOOLEAN ABSOLUTE p;
  1085.     c:^CHAR ABSOLUTE p;
  1086. BEGIN
  1087.      p:=@v;
  1088.      inc(p,2);
  1089.      CASE VarType(v) AND VarTypeMask OF
  1090.         VarEmpty:result:='';
  1091.         VarNull:Raise EVariantError.Create('Access to invalid variant variable');
  1092.         VarSmallInt:STR(si^,result);
  1093.         VarInteger:STR(i^,result);
  1094.         VarLongint:STR(li^,result);
  1095.         VarSingle:STR(s^,result);
  1096.         VarDouble:STR(d^,result);
  1097.         VarExtended:STR(e^,result);
  1098.         VarComp:STR(co^,result);
  1099.         VarCurrency:STR(cu^,result);
  1100.         VarBoolean:IF bo^ THEN result:='TRUE' ELSE result:='FALSE';
  1101.         VarByte:STR(b^,result);
  1102.         VarWord:STR(w^,result);
  1103.         VarLongWord:STR(lw^,result);
  1104.         VarChar:result:=c^;
  1105.         VarString:
  1106.         BEGIN
  1107.              ASM
  1108.                 MOV EAX,v
  1109.                 ADD EAX,2
  1110.                 PUSH EAX                     //Ansi string
  1111.                 PUSH DWORD PTR result        //result buffer address
  1112.                 PUSHL 255
  1113.                 CALLN32 SYSTEM.!AssignAnsi2Str
  1114.              END;
  1115.         END;
  1116.      END; {case}
  1117. END;
  1118.  
  1119. FUNCTION Variant2CStr(CONST v:VARIANT):CSTRING;
  1120. BEGIN
  1121.      result:=Variant2Str(v);
  1122. END;
  1123.  
  1124. FUNCTION Variant2AnsiStr(CONST v:VARIANT):AnsiString;
  1125. BEGIN
  1126.      IF VarType(v) AND VarTypeMask=VarString THEN
  1127.      BEGIN
  1128.           ASM
  1129.              MOV EAX,v
  1130.              ADD EAX,2
  1131.              PUSH EAX
  1132.              MOV EAX,result
  1133.              PUSH EAX
  1134.              CALLN32 SYSTEM.!AnsiCopy
  1135.           END;
  1136.      END
  1137.      ELSE result:=Variant2Str(v);
  1138. END;
  1139.  
  1140.  
  1141.  
  1142.  
  1143. FUNCTION Variant2LongInt(CONST v:VARIANT):LONGINT;
  1144. VAR
  1145.     p:POINTER;
  1146.     s:^SINGLE ABSOLUTE p;
  1147.     e:^EXTENDED ABSOLUTE p;
  1148.     d:^DOUBLE ABSOLUTE p;
  1149.     si:^SHORTINT ABSOLUTE p;
  1150.     i:^INTEGER ABSOLUTE p;
  1151.     li:^LONGINT ABSOLUTE p;
  1152.     b:^BYTE ABSOLUTE p;
  1153.     w:^WORD ABSOLUTE p;
  1154.     lw:^LONGWORD ABSOLUTE p;
  1155.     bo:^BOOLEAN ABSOLUTE p;
  1156.     c:^CHAR ABSOLUTE p;
  1157.     co:^COMP ABSOLUTE p;
  1158.     cu:^Currency ABSOLUTE p;
  1159.     ss:STRING;
  1160.     cc:INTEGER;
  1161. BEGIN
  1162.      p:=@v;
  1163.      inc(p,2);
  1164.      CASE VarType(v) AND VarTypeMask OF
  1165.         VarEmpty:result:=0;
  1166.         VarNull:Raise EVariantError.Create('Access to invalid variant variable');
  1167.         VarSmallInt:result:=si^;
  1168.         VarInteger:result:=i^;
  1169.         VarLongint:result:=li^;
  1170.         VarSingle:result:=s^;
  1171.         VarDouble:result:=d^;
  1172.         VarExtended:result:=e^;
  1173.         VarComp:result:=co^;
  1174.         VarCurrency:result:=cu^;
  1175.         VarBoolean:IF bo^ THEN result:=1 ELSE result:=0;
  1176.         VarByte:result:=b^;
  1177.         VarWord:result:=w^;
  1178.         VarLongWord:result:=lw^;
  1179.         VarChar:result:=ord(c^);
  1180.         VarString:
  1181.         BEGIN
  1182.              ASM
  1183.                 MOV EAX,v
  1184.                 ADD EAX,2
  1185.                 PUSH EAX            //Ansi string
  1186.                 LEA EAX,ss
  1187.                 PUSH EAX
  1188.                 PUSHL 255
  1189.                 CALLN32 SYSTEM.!AssignAnsi2Str
  1190.              END;
  1191.              VAL(ss,result,cc);
  1192.              IF cc<>0 THEN Raise EVariantError.Create('Invalid numeric format');
  1193.         END;
  1194.      END; {case}
  1195. END;
  1196.  
  1197. FUNCTION Variant2LongWord(CONST v:VARIANT):LONGWORD;
  1198. VAR
  1199.     p:POINTER;
  1200.     s:^SINGLE ABSOLUTE p;
  1201.     e:^EXTENDED ABSOLUTE p;
  1202.     d:^DOUBLE ABSOLUTE p;
  1203.     si:^SHORTINT ABSOLUTE p;
  1204.     i:^INTEGER ABSOLUTE p;
  1205.     li:^LONGINT ABSOLUTE p;
  1206.     b:^BYTE ABSOLUTE p;
  1207.     w:^WORD ABSOLUTE p;
  1208.     lw:^LONGWORD ABSOLUTE p;
  1209.     bo:^BOOLEAN ABSOLUTE p;
  1210.     c:^CHAR ABSOLUTE p;
  1211.     co:^COMP ABSOLUTE p;
  1212.     cu:^Currency ABSOLUTE p;
  1213.     ss:STRING;
  1214.     cc:INTEGER;
  1215. BEGIN
  1216.      p:=@v;
  1217.      inc(p,2);
  1218.      CASE VarType(v) AND VarTypeMask OF
  1219.         VarEmpty:result:=0;
  1220.         VarNull:Raise EVariantError.Create('Access to invalid variant variable');
  1221.         VarSmallInt:result:=si^;
  1222.         VarInteger:result:=i^;
  1223.         VarLongint:result:=li^;
  1224.         VarSingle:result:=s^;
  1225.         VarDouble:result:=d^;
  1226.         VarExtended:result:=e^;
  1227.         VarComp:result:=co^;
  1228.         VarCurrency:result:=cu^;
  1229.         VarBoolean:IF bo^ THEN result:=1 ELSE result:=0;
  1230.         VarByte:result:=b^;
  1231.         VarWord:result:=w^;
  1232.         VarLongWord:result:=lw^;
  1233.         VarChar:result:=ord(c^);
  1234.         VarString:
  1235.         BEGIN
  1236.              ASM
  1237.                 MOV EAX,v
  1238.                 ADD EAX,2
  1239.                 PUSH EAX            //Ansi string
  1240.                 LEA EAX,ss
  1241.                 PUSH EAX
  1242.                 PUSHL 255
  1243.                 CALLN32 SYSTEM.!AssignAnsi2Str
  1244.              END;
  1245.              VAL(ss,result,cc);
  1246.              IF cc<>0 THEN Raise EVariantError.Create('Invalid numeric format');
  1247.         END;
  1248.      END; {case}
  1249. END;
  1250.  
  1251. FUNCTION Variant2Extended(CONST v:VARIANT):EXTENDED;
  1252. VAR
  1253.     p:POINTER;
  1254.     s:^SINGLE ABSOLUTE p;
  1255.     e:^EXTENDED ABSOLUTE p;
  1256.     d:^DOUBLE ABSOLUTE p;
  1257.     si:^SHORTINT ABSOLUTE p;
  1258.     i:^INTEGER ABSOLUTE p;
  1259.     li:^LONGINT ABSOLUTE p;
  1260.     b:^BYTE ABSOLUTE p;
  1261.     w:^WORD ABSOLUTE p;
  1262.     lw:^LONGWORD ABSOLUTE p;
  1263.     bo:^BOOLEAN ABSOLUTE p;
  1264.     c:^CHAR ABSOLUTE p;
  1265.     co:^COMP ABSOLUTE p;
  1266.     cu:^Currency ABSOLUTE p;
  1267.     ss:STRING;
  1268.     cc:INTEGER;
  1269. BEGIN
  1270.      p:=@v;
  1271.      inc(p,2);
  1272.      CASE VarType(v) AND VarTypeMask OF
  1273.         VarEmpty:result:=0;
  1274.         VarNull:Raise EVariantError.Create('Access to invalid variant variable');
  1275.         VarSmallInt:result:=si^;
  1276.         VarInteger:result:=i^;
  1277.         VarLongint:result:=li^;
  1278.         VarSingle:result:=s^;
  1279.         VarDouble:result:=d^;
  1280.         VarExtended:result:=e^;
  1281.         VarComp:result:=co^;
  1282.         VarCurrency:result:=cu^;
  1283.         VarBoolean:IF bo^ THEN result:=1 ELSE result:=0;
  1284.         VarByte:result:=b^;
  1285.         VarWord:result:=w^;
  1286.         VarLongWord:result:=lw^;
  1287.         VarChar:result:=ord(c^);
  1288.         VarString:
  1289.         BEGIN
  1290.              ASM
  1291.                 MOV EAX,v
  1292.                 ADD EAX,2
  1293.                 PUSH EAX            //Ansi string
  1294.                 LEA EAX,ss
  1295.                 PUSH EAX
  1296.                 PUSHL 255
  1297.                 CALLN32 SYSTEM.!AssignAnsi2Str
  1298.              END;
  1299.              VAL(ss,result,cc);
  1300.              IF cc<>0 THEN Raise EVariantError.Create('Invalid numeric format');
  1301.         END;
  1302.      END; {case}
  1303. END;
  1304.  
  1305. FUNCTION Variant2LongBool(CONST v:VARIANT):LONGBOOL;
  1306. VAR
  1307.     p:POINTER;
  1308.     s:^SINGLE ABSOLUTE p;
  1309.     e:^EXTENDED ABSOLUTE p;
  1310.     d:^DOUBLE ABSOLUTE p;
  1311.     si:^SHORTINT ABSOLUTE p;
  1312.     i:^INTEGER ABSOLUTE p;
  1313.     li:^LONGINT ABSOLUTE p;
  1314.     b:^BYTE ABSOLUTE p;
  1315.     w:^WORD ABSOLUTE p;
  1316.     lw:^LONGWORD ABSOLUTE p;
  1317.     bo:^BOOLEAN ABSOLUTE p;
  1318.     c:^CHAR ABSOLUTE p;
  1319.     co:^COMP ABSOLUTE p;
  1320.     cu:^Currency ABSOLUTE p;
  1321.     ss:STRING;
  1322.     ee:EXTENDED;
  1323.     cc:INTEGER;
  1324. BEGIN
  1325.      p:=@v;
  1326.      inc(p,2);
  1327.      CASE VarType(v) AND VarTypeMask OF
  1328.         VarEmpty:result:=FALSE;
  1329.         VarNull:Raise EVariantError.Create('Access to invalid variant variable');
  1330.         VarSmallInt:result:=si^<>0;
  1331.         VarInteger:result:=i^<>0;
  1332.         VarLongint:result:=li^<>0;
  1333.         VarSingle:result:=s^<>0;
  1334.         VarDouble:result:=d^<>0;
  1335.         VarExtended:result:=e^<>0;
  1336.         VarComp:result:=co^<>0;
  1337.         VarCurrency:result:=cu^<>0;
  1338.         VarBoolean:result:=bo^;
  1339.         VarByte:result:=b^<>0;
  1340.         VarWord:result:=w^<>0;
  1341.         VarLongWord:result:=lw^<>0;
  1342.         VarChar:result:=ord(c^)<>0;
  1343.         VarString:
  1344.         BEGIN
  1345.              ASM
  1346.                 MOV EAX,v
  1347.                 ADD EAX,2
  1348.                 PUSH EAX            //Ansi string
  1349.                 LEA EAX,ss
  1350.                 PUSH EAX
  1351.                 PUSHL 255
  1352.                 CALLN32 SYSTEM.!AssignAnsi2Str
  1353.              END;
  1354.              UpcaseStr(ss);
  1355.              IF ss='TRUE' THEN result:=TRUE
  1356.              ELSE IF ss='FALSE' THEN result:=FALSE
  1357.              ELSE
  1358.              BEGIN
  1359.                 VAL(ss,ee,cc);
  1360.                 IF cc<>0 THEN Raise EVariantError.Create('Invalid boolean format');
  1361.                 result:=ee<>0;
  1362.              END;
  1363.         END;
  1364.      END; {case}
  1365. END;
  1366.  
  1367. FUNCTION VarType(CONST v:VARIANT):WORD;ASSEMBLER;
  1368. ASM
  1369.    MOV EAX,v
  1370.    MOV AX,[EAX]
  1371.    MOV result,AX
  1372. END;
  1373.  
  1374. FUNCTION VarIsNull(CONST v:VARIANT):BOOLEAN;ASSEMBLER;
  1375. ASM
  1376.    MOV EAX,v
  1377.    CMP EAX,0
  1378.    JE !vi01
  1379.    MOV AX,[EAX]
  1380. !vi01:
  1381.    CMP AX,0
  1382.    SETE AL
  1383.    MOV Result,AL
  1384. END;
  1385.  
  1386. CONST VarConversionProcs:ARRAY[VarSmallInt..VarCurrency] OF POINTER=
  1387.                (@Variant2LongInt{VarSmallInt},
  1388.                 @Variant2LongInt{VarInteger},
  1389.                 @Variant2LongInt{VarLongint},
  1390.                 @Variant2Extended{VarSingle},
  1391.                 @Variant2Extended{VarDouble},
  1392.                 @Variant2Extended{VarExtended},
  1393.                 @Variant2LongBool{VarBoolean},
  1394.                 @Variant2LongWord{VarByte},
  1395.                 @Variant2LongWord{VarWord},
  1396.                 @Variant2LongWord{VarLongWord},
  1397.                 @Variant2LongWord{VarChar},
  1398.                 @Variant2Extended{VarComp},
  1399.                 @Variant2Extended{VarCurrency}
  1400.               );
  1401.  
  1402. FUNCTION VarAsType(const v:VARIANT;VType:INTEGER):Variant;
  1403. VAR s:AnsiString;
  1404.     pp:POINTER;  {conversion address}
  1405.     res:LONGWORD;
  1406. BEGIN
  1407.      IF VType=VarType(v) AND VarTypeMask THEN
  1408.      BEGIN
  1409.           result:=v;
  1410.           exit;
  1411.      END;
  1412.  
  1413.      CASE VType OF
  1414.         VarString:
  1415.         BEGIN
  1416.              ASM
  1417.                 PUSH DWORD PTR v
  1418.                 LEA EAX,s
  1419.                 PUSH EAX
  1420.                 CALLN32 SYSTEM.Variant2AnsiStr
  1421.              END;
  1422.              result:=s;
  1423.         END
  1424.         ELSE
  1425.         BEGIN
  1426.              IF ((VType<VarSmallInt)OR(VType>VarCurrency)) THEN
  1427.                Raise EVariantError.Create('Illegal variant type');
  1428.              pp:=VarConversionProcs[VType];
  1429.              ASM
  1430.                 PUSH DWORD PTR v
  1431.                 LEA EAX,pp
  1432.                 CALLN32 [EAX]
  1433.                 MOV res,EAX
  1434.              END;
  1435.              CASE VType OF
  1436.                 VarSmallInt,VarInteger,VarLongInt,VarByte,VarWord,
  1437.                 VarLongWord,VarChar,VarBoolean:
  1438.                 BEGIN
  1439.                      ASM
  1440.                         MOV EAX,result
  1441.                         MOV EBX,res
  1442.                         MOV [EAX+2],EBX
  1443.                      END;
  1444.                 END;
  1445.                 VarSingle:
  1446.                 BEGIN
  1447.                      ASM
  1448.                         MOV EAX,DWORD PTR result
  1449.                         FSTP DWORD PTR [EAX+2]
  1450.                      END;
  1451.                 END;
  1452.                 VarDouble:
  1453.                 BEGIN
  1454.                      ASM
  1455.                         MOV EAX,DWORD PTR result
  1456.                         FSTP QWORD PTR [EAX+2]
  1457.                      END;
  1458.                 END;
  1459.                 VarExtended:
  1460.                 BEGIN
  1461.                      ASM
  1462.                         MOV EAX,DWORD PTR result
  1463.                         FSTP TBYTE PTR [EAX+2]
  1464.                      END;
  1465.                 END;
  1466.                 VarComp:
  1467.                 BEGIN
  1468.                      ASM
  1469.                         MOV EAX,DWORD PTR result
  1470.                         FISTP QWORD PTR [EAX+2]
  1471.                      END;
  1472.                 END;
  1473.                 VarCurrency:
  1474.                 BEGIN
  1475.                      ASM
  1476.                         MOV EAX,DWORD PTR result
  1477.                         FISTP QWORD PTR [EAX+2]
  1478.                      END;
  1479.                 END;
  1480.              END; {case}
  1481.         END;
  1482.      END; {case}
  1483.      TVarData(result).VType:=VType;
  1484. END;
  1485.  
  1486. PROCEDURE VarCast(VAR Dest:Variant;CONST source:Variant;VarType:Integer);
  1487. BEGIN
  1488.      Dest:=VarAsType(source,VarType);
  1489. END;
  1490.  
  1491. {Variant operation codes}
  1492. CONST
  1493.     S_Times=1;
  1494.     S_Div=2;
  1495.     S_Divide=3;
  1496.     S_Mod=4;
  1497.     S_And=5;
  1498.     S_Shl=6;
  1499.     S_Shr=7;
  1500.     S_Plus=8;
  1501.     S_Minus=9;
  1502.     S_Xor=10;
  1503.     S_Or=11;
  1504.     S_Not=12;
  1505.     S_Negate=13;
  1506.  
  1507. CONST OpIndex:ARRAY[VarSmallInt..VarCurrency] OF WORD=
  1508.            (0{VarSmallInt},
  1509.             0{VarInteger},
  1510.             0{VarLongInt},
  1511.             1{VarSingle},
  1512.             1{VarDouble},
  1513.             1{VarExtended},
  1514.             4{VarBoolean},
  1515.             2{VarByte},
  1516.             2{VarWord},
  1517.             2{VarLongWord},
  1518.             2{VarChar},
  1519.             1{VarComp},
  1520.             1{VarCurrency}
  1521.            );
  1522.  
  1523. CONST OpCommonTypes:ARRAY[0..4,0..4] OF WORD=
  1524.   (
  1525.    (VarLongInt,VarExtended,VarLongInt,VarExtended,VarLongint),   {LONGINT row}
  1526.    (VarExtended,VarExtended,VarExtended,VarExtended,VarExtended),{EXTENDED row}
  1527.    (VarLongInt,VarExtended,VarLongWord,VarExtended,VarLongWord), {LONGWORD row}
  1528.    (VarExtended,VarExtended,VarExtended,VarString,VarBoolean),   {AnsiString row}
  1529.    (VarLongInt,VarExtended,VarLongWord,VarBoolean,VarBoolean)    {Boolean row}
  1530.   );
  1531.  
  1532. FUNCTION VariantOp(v1,v2:VARIANT;op:LONGWORD):VARIANT;
  1533. VAR v1Type:WORD;
  1534.     v2Type:WORD;
  1535.     i1,i2:LONGINT;
  1536.     resultType:WORD;
  1537.  
  1538.     pp1:POINTER;
  1539.     pp2:POINTER;
  1540.     ppres:POINTER;
  1541.  
  1542.     pp1_longint:^LONGINT ABSOLUTE pp1;
  1543.     pp1_longword:^LONGWORD ABSOLUTE pp1;
  1544.     pp1_Extended:^EXTENDED ABSOLUTE pp1;
  1545.     pp1_Boolean:^BOOLEAN ABSOLUTE pp1;
  1546.     pp1_Ansi:^AnsiString ABSOLUTE pp1;
  1547.  
  1548.     pp2_longint:^LONGINT ABSOLUTE pp2;
  1549.     pp2_longword:^LONGWORD ABSOLUTE pp2;
  1550.     pp2_Extended:^EXTENDED ABSOLUTE pp2;
  1551.     pp2_Boolean:^BOOLEAN ABSOLUTE pp2;
  1552.     pp2_Ansi:^AnsiString ABSOLUTE pp2;
  1553.  
  1554.     ppres_longint:^LONGINT ABSOLUTE ppres;
  1555.     ppres_longword:^LONGWORD ABSOLUTE ppres;
  1556.     ppres_Extended:^EXTENDED ABSOLUTE ppres;
  1557.     ppres_Boolean:^BOOLEAN ABSOLUTE ppres;
  1558.     ppres_Ansi:^AnsiString ABSOLUTE ppres;
  1559. BEGIN
  1560.      pp1:=@v1;
  1561.      inc(pp1,2);
  1562.      pp2:=@v2;
  1563.      inc(pp2,2);
  1564.      ppres:=@result;
  1565.      inc(ppres,2);
  1566.  
  1567.      v1Type:=VarType(v1) AND VarTypeMask;
  1568.      v2Type:=VarType(v2) AND VarTypeMask;
  1569.      IF ((v1Type=varEmpty)OR(v2Type=VarEmpty)) THEN
  1570.        Raise EVariantError.Create('Illegal variant operation on empty variant');
  1571.      IF v1Type<>VarString THEN i1:=OpIndex[v1Type]
  1572.      ELSE i1:=3;
  1573.      IF v2Type<>VarString THEN i2:=OpIndex[v2Type]
  1574.      ELSE i2:=3;
  1575.  
  1576.      resultType:=OpCommonTypes[i1,i2];
  1577.      CASE Op OF
  1578.         S_Times:IF resultType IN [VarString,VarBoolean] THEN
  1579.                    resultType:=VarDouble;
  1580.         S_Div:IF not (resultType IN [VarLongint,VarLongWord]) THEN
  1581.                 resultType:=VarLongint;
  1582.         S_Divide:resultType:=VarExtended;
  1583.         S_Mod:IF not (resultType IN [VarLongint,VarLongWord]) THEN
  1584.                 resultType:=VarLongint;
  1585.         S_And:IF not (resultType IN [VarLongint,VarLongWord,VarBoolean]) THEN
  1586.                 resultType:=VarLongint;
  1587.         S_Shl:IF not (resultType IN [VarLongint,VarLongWord]) THEN
  1588.                 resultType:=VarLongint;
  1589.         S_Shr:IF not (resultType IN [VarLongint,VarLongWord]) THEN
  1590.                 resultType:=VarLongint;
  1591.         S_Plus:IF resultType=VarBoolean THEN resultType:=VarDouble;
  1592.         S_Minus:IF resultType IN [VarString,VarBoolean] THEN
  1593.                    resultType:=VarDouble;
  1594.         S_OR:IF not (resultType IN [VarLongint,VarLongWord,VarBoolean]) THEN
  1595.                 resultType:=VarLongint;
  1596.         S_Xor:IF not (resultType IN [VarLongint,VarLongWord,VarBoolean]) THEN
  1597.                 resultType:=VarLongint;
  1598.      END;
  1599.      IF resultType IN [VarLongint,VarLongWord] THEN IF Op=S_Divide THEN
  1600.        resultType:=VarExtended;
  1601.      v1:=VarAsType(v1,ResultType);
  1602.      v2:=VarAsType(v2,ResultType);
  1603.  
  1604.      CASE Op OF
  1605.         S_Times:
  1606.         BEGIN
  1607.              {real and integers allowed}
  1608.              CASE resultType OF
  1609.                 VarLongint:ppres_Longint^:=pp1_LongInt^ * pp2_Longint^;
  1610.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ * pp2_LongWord^;
  1611.                 VarExtended:ppres_Extended^:=pp1_Extended^ * pp2_Extended^;
  1612.              END; {case}
  1613.         END;
  1614.         S_Div:
  1615.         BEGIN
  1616.              {Only integers allowed}
  1617.              CASE resultType OF
  1618.                 VarLongint:ppres_Longint^:=pp1_LongInt^ DIV pp2_Longint^;
  1619.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ DIV pp2_LongWord^;
  1620.              END; {case}
  1621.         END;
  1622.         S_Divide:
  1623.         BEGIN
  1624.              {only reals allowed}
  1625.              ppres_Extended^:=pp1_Extended^ / pp2_Extended^;
  1626.         END;
  1627.         S_Mod:
  1628.         BEGIN
  1629.              {Only integers allowed}
  1630.              CASE resultType OF
  1631.                 VarLongint:ppres_Longint^:=pp1_LongInt^ MOD pp2_Longint^;
  1632.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ MOD pp2_LongWord^;
  1633.              END; {case}
  1634.         END;
  1635.         S_And:
  1636.         BEGIN
  1637.              {Only integers and boolean types allowed}
  1638.              CASE resultType OF
  1639.                 VarLongint:ppres_Longint^:=pp1_LongInt^ AND pp2_Longint^;
  1640.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ AND pp2_LongWord^;
  1641.                 VarBoolean:ppres_Boolean^:=pp1_Boolean^ AND pp2_Boolean^;
  1642.              END; {case}
  1643.         END;
  1644.         S_Shl:
  1645.         BEGIN
  1646.              {Only integers allowed}
  1647.              CASE resultType OF
  1648.                 VarLongint:ppres_Longint^:=pp1_LongInt^ SHL pp2_Longint^;
  1649.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ SHL pp2_LongWord^;
  1650.              END; {case}
  1651.         END;
  1652.         S_Shr:
  1653.         BEGIN
  1654.              {Only integers allowed}
  1655.              CASE resultType OF
  1656.                 VarLongint:ppres_Longint^:=pp1_LongInt^ SHR pp2_Longint^;
  1657.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ SHR pp2_LongWord^;
  1658.              END; {case}
  1659.         END;
  1660.         S_Plus:
  1661.         BEGIN
  1662.              {real and integers and AnsiStrings allowed}
  1663.              CASE resultType OF
  1664.                 VarLongint:ppres_Longint^:=pp1_LongInt^ + pp2_Longint^;
  1665.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ + pp2_LongWord^;
  1666.                 VarExtended:ppres_Extended^:=pp1_Extended^ + pp2_Extended^;
  1667.                 VarString:
  1668.                 BEGIN
  1669.                      ppres_Longint^:=0;  {Clear destination ansi}
  1670.                      ppres_Ansi^:=pp1_Ansi^ + pp2_Ansi^;
  1671.                 END;
  1672.              END; {case}
  1673.         END;
  1674.         S_Minus:
  1675.         BEGIN
  1676.              {real and integers allowed}
  1677.              CASE resultType OF
  1678.                 VarLongint:ppres_Longint^:=pp1_LongInt^ - pp2_Longint^;
  1679.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ - pp2_LongWord^;
  1680.                 VarExtended:ppres_Extended^:=pp1_Extended^ - pp2_Extended^;
  1681.              END; {case}
  1682.         END;
  1683.         S_OR:
  1684.         BEGIN
  1685.              {Only integers and boolean types allowed}
  1686.              CASE resultType OF
  1687.                 VarLongint:ppres_Longint^:=pp1_LongInt^ OR pp2_Longint^;
  1688.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ OR pp2_LongWord^;
  1689.                 VarBoolean:ppres_Boolean^:=pp1_Boolean^ OR pp2_Boolean^;
  1690.              END; {case}
  1691.         END;
  1692.         S_Xor:
  1693.         BEGIN
  1694.              {Only integers and boolean types allowed}
  1695.              CASE resultType OF
  1696.                 VarLongint:ppres_Longint^:=pp1_LongInt^ XOR pp2_Longint^;
  1697.                 VarLongWord:ppres_LongWord^:=pp1_LongWord^ XOR pp2_LongWord^;
  1698.                 VarBoolean:ppres_Boolean^:=pp1_Boolean^ XOR pp2_Boolean^;
  1699.              END; {case}
  1700.         END;
  1701.      END;
  1702.  
  1703.      TVarData(result).VType:=resultType;
  1704. END;
  1705.  
  1706. FUNCTION VariantNegNot(v1:VARIANT;op:LONGWORD):VARIANT;
  1707. VAR v1Type:WORD;
  1708.     resultType:WORD;
  1709.  
  1710.     pp1:POINTER;
  1711.     ppres:POINTER;
  1712.  
  1713.     pp1_longint:^LONGINT ABSOLUTE pp1;
  1714.     pp1_longword:^LONGWORD ABSOLUTE pp1;
  1715.     pp1_Extended:^EXTENDED ABSOLUTE pp1;
  1716.     pp1_Boolean:^BOOLEAN ABSOLUTE pp1;
  1717.     pp1_Ansi:^AnsiString ABSOLUTE pp1;
  1718.  
  1719.     ppres_longint:^LONGINT ABSOLUTE ppres;
  1720.     ppres_longword:^LONGWORD ABSOLUTE ppres;
  1721.     ppres_Extended:^EXTENDED ABSOLUTE ppres;
  1722.     ppres_Boolean:^BOOLEAN ABSOLUTE ppres;
  1723.     ppres_Ansi:^AnsiString ABSOLUTE ppres;
  1724. BEGIN
  1725.      pp1:=@v1;
  1726.      inc(pp1,2);
  1727.      ppres:=@result;
  1728.      inc(ppres,2);
  1729.  
  1730.      v1Type:=VarType(v1) AND VarTypeMask;
  1731.      IF v1Type=varEmpty THEN
  1732.        Raise EVariantError.Create('Illegal variant operation on empty variant');
  1733.  
  1734.      resultType:=v1Type;
  1735.      CASE Op OF
  1736.         S_Negate:IF resultType IN [VarString,VarBoolean] THEN
  1737.                     resultType:=VarDouble;
  1738.         S_Not:IF not (resultType IN [VarBoolean,VarLongint,VarLongWord])
  1739.                 THEN resultType:=VarLongint;
  1740.      END;
  1741.      v1:=VarAsType(v1,ResultType);
  1742.  
  1743.      CASE Op OF
  1744.         S_Negate:
  1745.         BEGIN
  1746.              {real and integers allowed}
  1747.              CASE resultType OF
  1748.                 VarLongint:ppres_Longint^:=-pp1_LongInt^;
  1749.                 VarLongWord:ppres_LongWord^:=-pp1_LongWord^;
  1750.                 VarExtended:ppres_Extended^:=-pp1_Extended^;
  1751.              END; {case}
  1752.         END;
  1753.         S_NOT:
  1754.         BEGIN
  1755.              {Only Booleans and integers allowed}
  1756.              CASE resultType OF
  1757.                 VarLongint:ppres_Longint^:=NOT pp1_LongInt^;
  1758.                 VarLongWord:ppres_LongWord^:=NOT pp1_LongWord^;
  1759.                 VarBoolean:ppres_Boolean^:=NOT pp1_Boolean^;
  1760.              END; {case}
  1761.         END;
  1762.      END;
  1763.  
  1764.      TVarData(result).VType:=resultType;
  1765. END;
  1766.  
  1767. FUNCTION VariantCmp(v1,v2:VARIANT):BYTE;
  1768. VAR v1Type:WORD;
  1769.     v2Type:WORD;
  1770.     i1,i2:LONGINT;
  1771.     resultType:WORD;
  1772.  
  1773.     pp1:POINTER;
  1774.     pp2:POINTER;
  1775.     ppres:POINTER;
  1776.  
  1777.     pp1_longint:^LONGINT ABSOLUTE pp1;
  1778.     pp1_longword:^LONGWORD ABSOLUTE pp1;
  1779.     pp1_Extended:^EXTENDED ABSOLUTE pp1;
  1780.     pp1_Boolean:^BOOLEAN ABSOLUTE pp1;
  1781.     pp1_Ansi:^AnsiString ABSOLUTE pp1;
  1782.  
  1783.     pp2_longint:^LONGINT ABSOLUTE pp2;
  1784.     pp2_longword:^LONGWORD ABSOLUTE pp2;
  1785.     pp2_Extended:^EXTENDED ABSOLUTE pp2;
  1786.     pp2_Boolean:^BOOLEAN ABSOLUTE pp2;
  1787.     pp2_Ansi:^AnsiString ABSOLUTE pp2;
  1788.  
  1789.     ppres_longint:^LONGINT ABSOLUTE ppres;
  1790.     ppres_longword:^LONGWORD ABSOLUTE ppres;
  1791.     ppres_Extended:^EXTENDED ABSOLUTE ppres;
  1792.     ppres_Boolean:^BOOLEAN ABSOLUTE ppres;
  1793.     ppres_Ansi:^AnsiString ABSOLUTE ppres;
  1794. BEGIN
  1795.      pp1:=@v1;
  1796.      inc(pp1,2);
  1797.      pp2:=@v2;
  1798.      inc(pp2,2);
  1799.      ppres:=@result;
  1800.      inc(ppres,2);
  1801.  
  1802.      v1Type:=VarType(v1) AND VarTypeMask;
  1803.      v2Type:=VarType(v2) AND VarTypeMask;
  1804.      IF ((v1Type=varEmpty)OR(v2Type=VarEmpty)) THEN
  1805.      BEGIN
  1806.           IF ((v1Type=VarEmpty)AND(v2Type=VarEmpty)) THEN result:=1
  1807.           ELSE
  1808.           BEGIN
  1809.                IF v1Type=VarEmpty THEN result:=0
  1810.                ELSE result:=2;
  1811.           END;
  1812.           exit;
  1813.      END;
  1814.      IF v1Type<>VarString THEN i1:=OpIndex[v1Type]
  1815.      ELSE i1:=3;
  1816.      IF v2Type<>VarString THEN i2:=OpIndex[v2Type]
  1817.      ELSE i2:=3;
  1818.  
  1819.      resultType:=OpCommonTypes[i1,i2];
  1820.      v1:=VarAsType(v1,ResultType);
  1821.      v2:=VarAsType(v2,ResultType);
  1822.  
  1823.      CASE ResultType OF
  1824.         VarLongInt:IF pp1_Longint^=pp2_Longint^ THEN result:=1
  1825.                    ELSE IF pp1_Longint^>pp2_Longint^ THEN result:=2
  1826.                    ELSE result:=0;
  1827.         VarLongWord:IF pp1_LongWord^=pp2_LongWord^ THEN result:=1
  1828.                     ELSE IF pp1_LongWord^>pp2_LongWord^ THEN result:=2
  1829.                     ELSE result:=0;
  1830.         VarBoolean:IF pp1_Boolean^=pp2_Boolean^ THEN result:=1
  1831.                    ELSE result:=0;
  1832.         VarString:IF pp1_Ansi^=pp2_Ansi^ THEN result:=1
  1833.                     ELSE IF pp1_Ansi^>pp2_Ansi^ THEN result:=2
  1834.                     ELSE result:=0;
  1835.         VarExtended:IF pp1_Extended^=pp2_Extended^ THEN result:=1
  1836.                     ELSE IF pp1_Extended^>pp2_Extended^ THEN result:=2
  1837.                     ELSE result:=0;
  1838.      END; {case}
  1839. END;
  1840.  
  1841.  
  1842. ASSEMBLER
  1843.  
  1844. //(op1,op2,result,operation)
  1845. SYSTEM.!VariantOp PROC NEAR32
  1846.       PUSH EBP
  1847.       MOV EBP,ESP
  1848.       SUB ESP,16
  1849.  
  1850.       PUSH EAX
  1851.       PUSH EBX
  1852.       PUSH ECX
  1853.       PUSH EDX
  1854.       PUSH ESI
  1855.       PUSH EDI
  1856.  
  1857.       PUSH DWORD PTR [EBP+20]     //first operand
  1858.       PUSH DWORD PTR [EBP+16]     //second operand
  1859.       PUSH DWORD PTR [EBP+8]      //operation to perform
  1860.       LEA EAX,[EBP-16]            //temp result
  1861.       PUSH EAX
  1862.       CALLN32 SYSTEM.VariantOp
  1863.  
  1864.       LEA ESI,[EBP-16]            //temp result
  1865.       MOV EDI,[EBP+12]            //result value
  1866.       CLD
  1867.       MOV ECX,4
  1868.       REP MOVSD
  1869.  
  1870.       POP EDI
  1871.       POP ESI
  1872.       POP EDX
  1873.       POP ECX
  1874.       POP EBX
  1875.       POP EAX
  1876.       LEAVE
  1877.       RETN32 16
  1878. SYSTEM.!VariantOp ENDP
  1879.  
  1880. //(op,result,operation)
  1881. SYSTEM.!VariantNegNot PROC NEAR32
  1882.       PUSH EBP
  1883.       MOV EBP,ESP
  1884.       SUB ESP,16
  1885.  
  1886.       PUSH EAX
  1887.       PUSH EBX
  1888.       PUSH ECX
  1889.       PUSH EDX
  1890.       PUSH ESI
  1891.       PUSH EDI
  1892.  
  1893.       PUSH DWORD PTR [EBP+16]  //operand
  1894.       PUSH DWORD PTR [EBP+8]   //operation to perform
  1895.       LEA EAX,[EBP-16]         //temp result
  1896.       PUSH EAX
  1897.       CALLN32 SYSTEM.VariantNegNot
  1898.  
  1899.       LEA ESI,[EBP-16]         //temp result
  1900.       MOV EDI,[EBP+12]         //result value
  1901.       CLD
  1902.       MOV ECX,4
  1903.       REP MOVSD
  1904.  
  1905.       POP EDI
  1906.       POP ESI
  1907.       POP EDX
  1908.       POP ECX
  1909.       POP EBX
  1910.       POP EAX
  1911.       LEAVE
  1912.       RETN32 12
  1913. SYSTEM.!VariantNegNot ENDP
  1914.  
  1915. //(op1,op2)
  1916. SYSTEM.!VariantCmp PROC NEAR32
  1917.       PUSH EBP
  1918.       MOV EBP,ESP
  1919.  
  1920.       PUSH EAX
  1921.       PUSH EBX
  1922.       PUSH ECX
  1923.       PUSH EDX
  1924.       PUSH ESI
  1925.       PUSH EDI
  1926.  
  1927.       PUSH DWORD PTR [EBP+12]    //first operand
  1928.       PUSH DWORD PTR [EBP+8]     //second operand
  1929.       CALLN32 SYSTEM.VariantCmp
  1930.  
  1931.       CMP AL,1           //0 op1<op2
  1932.                          //1 op1=op2
  1933.                          //2 op1>op2
  1934.  
  1935.       POP EDI
  1936.       POP ESI
  1937.       POP EDX
  1938.       POP ECX
  1939.       POP EBX
  1940.       POP EAX
  1941.       LEAVE
  1942.       RETN32 8
  1943. SYSTEM.!VariantCmp ENDP
  1944.  
  1945. //(Source,Dest,DestLen)
  1946. SYSTEM.!Variant2Signed PROC NEAR32
  1947.       PUSH EBP
  1948.       MOV EBP,ESP
  1949.  
  1950.       PUSH EAX
  1951.       PUSH EBX
  1952.       PUSH ECX
  1953.       PUSH EDX
  1954.       PUSH ESI
  1955.       PUSH EDI
  1956.  
  1957.       PUSH DWORD PTR [EBP+16]   //Source
  1958.       CALLN32 SYSTEM.Variant2Longint
  1959.  
  1960.       MOV EBX,[EBP+8]           //DestLen
  1961.       MOV ESI,[EBP+12]          //Dest
  1962.       CMP ESI,0
  1963.       JNE !VarSignAssign
  1964.       //called as function
  1965.       POP EDI
  1966.       POP ESI
  1967.       POP EDX
  1968.       POP ECX
  1969.       POP EBX
  1970.       ADD ESP,4     //old EAX
  1971.       LEAVE
  1972.       RETN32 12
  1973. !VarSignAssign:
  1974.       CMP EBX,1
  1975.       JNE !not_ShortInt
  1976.       MOV [ESI],AL
  1977.       JMP !VarSignEx
  1978. !not_ShortInt:
  1979.       CMP EBX,2
  1980.       JNE !not_Integer
  1981.       MOV [ESI],AX
  1982.       JMP !VarSignEx
  1983. !not_Integer:
  1984.       MOV [ESI],EAX
  1985. !VarSignEx:
  1986.       POP EDI
  1987.       POP ESI
  1988.       POP EDX
  1989.       POP ECX
  1990.       POP EBX
  1991.       POP EAX
  1992.       LEAVE
  1993.       RETN32 12
  1994. SYSTEM.!Variant2Signed ENDP
  1995.  
  1996. //(Source,Dest,DestLen)
  1997. SYSTEM.!Variant2UnSigned PROC NEAR32
  1998.       PUSH EBP
  1999.       MOV EBP,ESP
  2000.  
  2001.       PUSH EAX
  2002.       PUSH EBX
  2003.       PUSH ECX
  2004.       PUSH EDX
  2005.       PUSH ESI
  2006.       PUSH EDI
  2007.  
  2008.       PUSH DWORD PTR [EBP+16]     //Source
  2009.       CALLN32 SYSTEM.Variant2LongWord
  2010.  
  2011.       MOV EBX,[EBP+8]             //DestLen
  2012.       MOV ESI,[EBP+12]            //Dest
  2013.       CMP ESI,0
  2014.       JNE !VarUnSignAssign
  2015.       //called as function
  2016.       POP EDI
  2017.       POP ESI
  2018.       POP EDX
  2019.       POP ECX
  2020.       POP EBX
  2021.       ADD ESP,4     //old EAX
  2022.       LEAVE
  2023.       RETN32 12
  2024. !VarUnSignAssign:
  2025.       CMP EBX,1
  2026.       JNE !not_Byte
  2027.       MOV [ESI],AL
  2028.       JMP !VarUnSignEx
  2029. !not_Byte:
  2030.       CMP EBX,2
  2031.       JNE !not_Word
  2032.       MOV [ESI],AX
  2033.       JMP !VarUnSignEx
  2034. !not_Word:
  2035.       MOV [ESI],EAX
  2036. !VarUnSignEx:
  2037.       POP EDI
  2038.       POP ESI
  2039.       POP EDX
  2040.       POP ECX
  2041.       POP EBX
  2042.       POP EAX
  2043.       LEAVE
  2044.       RETN32 12
  2045. SYSTEM.!Variant2UnSigned ENDP
  2046.  
  2047. //(Source,Dest,DestLen)
  2048. SYSTEM.!Variant2Real PROC NEAR32
  2049.       PUSH EBP
  2050.       MOV EBP,ESP
  2051.  
  2052.       PUSH EAX
  2053.       PUSH EBX
  2054.       PUSH ECX
  2055.       PUSH EDX
  2056.       PUSH ESI
  2057.       PUSH EDI
  2058.  
  2059.       PUSH DWORD PTR [EBP+16]         //Source
  2060.       CALLN32 SYSTEM.Variant2Extended
  2061.  
  2062.       MOV EBX,[EBP+8]                 //DestLen
  2063.       MOV ESI,[EBP+12]                //Dest
  2064.       CMP ESI,0
  2065.       JE !VarRealEx                   //called as function
  2066.       CMP EBX,4
  2067.       JNE !not_Single
  2068.       FSTP DWORD PTR [ESI]
  2069.       JMP !VarRealEx
  2070. !not_Single:
  2071.       CMP EBX,8
  2072.       JNE !not_Double
  2073.       FSTP QWORD PTR [ESI]
  2074.       JMP !VarRealEx
  2075. !not_Double:
  2076.       FSTP TBYTE PTR [ESI]
  2077. !VarRealEx:
  2078.       POP EDI
  2079.       POP ESI
  2080.       POP EDX
  2081.       POP ECX
  2082.       POP EBX
  2083.       POP EAX
  2084.       LEAVE
  2085.       RETN32 12
  2086. SYSTEM.!Variant2Real ENDP
  2087.  
  2088. //(Source,Dest)
  2089. SYSTEM.!Variant2Comp PROC NEAR32
  2090.       PUSH EBP
  2091.       MOV EBP,ESP
  2092.  
  2093.       PUSH EAX
  2094.       PUSH EBX
  2095.       PUSH ECX
  2096.       PUSH EDX
  2097.       PUSH ESI
  2098.       PUSH EDI
  2099.  
  2100.       PUSH DWORD PTR [EBP+12]    //Source
  2101.       CALLN32 SYSTEM.Variant2Extended
  2102.  
  2103.       MOV ESI,[EBP+8]           //Dest
  2104.       CMP ESI,0
  2105.       JE !VarCompEx             //called as function
  2106.  
  2107.       FISTP QWORD PTR [ESI]
  2108. !VarCompEx:
  2109.       POP EDI
  2110.       POP ESI
  2111.       POP EDX
  2112.       POP ECX
  2113.       POP EBX
  2114.       POP EAX
  2115.       LEAVE
  2116.       RETN32 8
  2117. SYSTEM.!Variant2Comp ENDP
  2118.  
  2119. //(Source,Dest)
  2120. SYSTEM.!Variant2Currency PROC NEAR32
  2121.       PUSH EBP
  2122.       MOV EBP,ESP
  2123.  
  2124.       PUSH EAX
  2125.       PUSH EBX
  2126.       PUSH ECX
  2127.       PUSH EDX
  2128.       PUSH ESI
  2129.       PUSH EDI
  2130.  
  2131.       PUSH DWORD PTR [EBP+12]    //Source
  2132.       CALLN32 SYSTEM.Variant2Extended
  2133.  
  2134.       MOV ESI,[EBP+8]           //Dest
  2135.       CMP ESI,0
  2136.       JE !VarCompEx             //called as function
  2137.  
  2138.       FLDT SYSTEM.ToCurrency  //*10000
  2139.       FMULP ST(1),ST
  2140.       FRNDINT
  2141.       FISTP QWORD PTR [ESI]
  2142. !VarCompEx:
  2143.       POP EDI
  2144.       POP ESI
  2145.       POP EDX
  2146.       POP ECX
  2147.       POP EBX
  2148.       POP EAX
  2149.       LEAVE
  2150.       RETN32 8
  2151. SYSTEM.!Variant2Currency ENDP
  2152.  
  2153.  
  2154. //(Source,Dest,DestLen)
  2155. SYSTEM.!Variant2Bool PROC NEAR32
  2156.       PUSH EBP
  2157.       MOV EBP,ESP
  2158.  
  2159.       PUSH EAX
  2160.       PUSH EBX
  2161.       PUSH ECX
  2162.       PUSH EDX
  2163.       PUSH ESI
  2164.       PUSH EDI
  2165.  
  2166.       PUSH DWORD PTR [EBP+16]         //Source
  2167.       CALLN32 SYSTEM.Variant2LongBool
  2168.  
  2169.       MOV EBX,[EBP+8]                 //DestLen
  2170.       MOV ESI,[EBP+12]                //Dest
  2171.       CMP ESI,0
  2172.       JNE !VarBoolAssign
  2173.       //called as function
  2174.       POP EDI
  2175.       POP ESI
  2176.       POP EDX
  2177.       POP ECX
  2178.       POP EBX
  2179.       ADD ESP,4     //old EAX
  2180.       LEAVE
  2181.       RETN32 12
  2182. !VarBoolAssign:
  2183.       CMP EBX,1
  2184.       JNE !not_Boolean
  2185.       MOV [ESI],AL
  2186.       JMP !VarBoolEx
  2187. !not_Boolean:
  2188.       CMP EBX,2
  2189.       JNE !not_WordBool
  2190.       MOV [ESI],AX
  2191.       JMP !VarBoolEx
  2192. !not_WordBool:
  2193.       MOV [ESI],EAX
  2194. !VarBoolEx:
  2195.       POP EDI
  2196.       POP ESI
  2197.       POP EDX
  2198.       POP ECX
  2199.       POP EBX
  2200.       POP EAX
  2201.       LEAVE
  2202.       RETN32 12
  2203. SYSTEM.!Variant2Bool ENDP
  2204.  
  2205. //(Source,Dest)
  2206. SYSTEM.!Variant2Str PROC NEAR32
  2207.       PUSH EBP
  2208.       MOV EBP,ESP
  2209.  
  2210.       PUSH EAX
  2211.       PUSH EBX
  2212.       PUSH ECX
  2213.       PUSH EDX
  2214.       PUSH ESI
  2215.       PUSH EDI
  2216.  
  2217.       PUSH DWORD PTR [EBP+12]                //Source
  2218.       PUSH DWORD PTR [EBP+8]                 //Dest
  2219.       CALLN32 SYSTEM.Variant2Str
  2220.  
  2221.       POP EDI
  2222.       POP ESI
  2223.       POP EDX
  2224.       POP ECX
  2225.       POP EBX
  2226.       POP EAX
  2227.       LEAVE
  2228.       RETN32 8
  2229. SYSTEM.!Variant2Str ENDP
  2230.  
  2231. //(Source,Dest)
  2232. SYSTEM.!Variant2CStr PROC NEAR32
  2233.       PUSH EBP
  2234.       MOV EBP,ESP
  2235.  
  2236.       PUSH EAX
  2237.       PUSH EBX
  2238.       PUSH ECX
  2239.       PUSH EDX
  2240.       PUSH ESI
  2241.       PUSH EDI
  2242.  
  2243.       PUSH DWORD PTR [EBP+12]     //Source
  2244.       PUSH DWORD PTR [EBP+8]      //Dest
  2245.       CALLN32 SYSTEM.Variant2CStr
  2246.  
  2247.       POP EDI
  2248.       POP ESI
  2249.       POP EDX
  2250.       POP ECX
  2251.       POP EBX
  2252.       POP EAX
  2253.       LEAVE
  2254.       RETN32 8
  2255. SYSTEM.!Variant2CStr ENDP
  2256.  
  2257. //(Source,Dest)
  2258. SYSTEM.!Variant2AnsiStr PROC NEAR32
  2259.       PUSH EBP
  2260.       MOV EBP,ESP
  2261.  
  2262.       PUSH EAX
  2263.       PUSH EBX
  2264.       PUSH ECX
  2265.       PUSH EDX
  2266.       PUSH ESI
  2267.       PUSH EDI
  2268.  
  2269.       PUSH DWORD PTR [EBP+12]  //Source
  2270.       PUSH DWORD PTR [EBP+8]   //Dest
  2271.       CALLN32 SYSTEM.Variant2AnsiStr
  2272.  
  2273.       //increase reference pointer by 1
  2274.       MOV EAX,[EBP+8]          //Dest
  2275.       MOV EAX,[EAX]
  2276.       CMP EAX,0
  2277.       JE !is0_ansi
  2278.       INC DWORD PTR [EAX-8]
  2279. !is0_ansi:
  2280.       POP EDI
  2281.       POP ESI
  2282.       POP EDX
  2283.       POP ECX
  2284.       POP EBX
  2285.       POP EAX
  2286.       LEAVE
  2287.       RETN32 8
  2288. SYSTEM.!Variant2AnsiStr ENDP
  2289.  
  2290. //(Source,Dest)
  2291. SYSTEM.!VariantCopy PROC NEAR32
  2292.    PUSH EBP
  2293.    MOV EBP,ESP
  2294.  
  2295.    PUSH EAX
  2296.    PUSH EBX
  2297.    PUSH ECX
  2298.    PUSH EDX
  2299.    PUSH ESI
  2300.    PUSH EDI
  2301.  
  2302.    MOV ESI,[EBP+12]        //Source
  2303.    MOV EDI,[EBP+8]         //Dest
  2304.    MOV ECX,4
  2305.    REP
  2306.    MOVSD                   //Copy variant
  2307.  
  2308.    MOV ESI,[EBP+12]        //Source
  2309.    MOV EDI,[EBP+8]         //Dest
  2310.    MOV AX,[ESI]
  2311.    AND AX,$0FFF            //mask type
  2312.    CMP AX,$0100            //is it a ansi string ??
  2313.    JNE !not_a_Ansi4
  2314.    ADD ESI,2
  2315.    ADD EDI,2
  2316.    MOVD [EDI],0            //clear dest Ansi
  2317.    PUSH ESI
  2318.    PUSH EDI
  2319.    CALLN32 SYSTEM.!AnsiCopy
  2320. !not_a_Ansi4:
  2321.  
  2322.    POP EDI
  2323.    POP ESI
  2324.    POP EDX
  2325.    POP ECX
  2326.    POP EBX
  2327.    POP EAX
  2328.  
  2329.    LEAVE
  2330.    RETN32 8
  2331. SYSTEM.!VariantCopy ENDP
  2332.  
  2333. //(Source,Dest)
  2334. SYSTEM.!VariantCreate PROC NEAR32
  2335.       PUSH EBP
  2336.       MOV EBP,ESP
  2337.  
  2338.       MOV ESI,[EBP+12]  //Source
  2339.       MOV EDI,[EBP+8]   //Dest
  2340.       MOV ECX,4
  2341.       REP
  2342.       MOVSD             //Copy variant
  2343.  
  2344.       MOV ESI,[EBP+12]  //Source
  2345.       MOV EDI,[EBP+8]   //Dest
  2346.       MOV AX,[ESI]
  2347.       AND AX,$0FFF      //mask type
  2348.       CMP AX,$0100      //is it a ansi string ??
  2349.       JNE !not_a_Ansi3
  2350.       ADD ESI,2
  2351.       ADD EDI,2
  2352.       PUSH ESI
  2353.       PUSH EDI
  2354.       CALLN32 SYSTEM.!AnsiCreate
  2355. !not_a_Ansi3:
  2356.       LEAVE
  2357.       RETN32 8
  2358. SYSTEM.!VariantCreate ENDP
  2359.  
  2360. //(Source,Dest)
  2361. SYSTEM.!VariantCreate_Clear PROC NEAR32
  2362.      PUSH EBP
  2363.      MOV EBP,ESP
  2364.  
  2365.      PUSH DWORD PTR [EBP+12]  //Source
  2366.      PUSH DWORD PTR [EBP+8]   //Dest
  2367.      CALLN32 SYSTEM.!VariantCreate
  2368.  
  2369.      MOV ESI,[EBP+12]         //Source
  2370.      CALLN32 SYSTEM.!FreeConstVariant
  2371.  
  2372.      LEAVE
  2373.      RETN32 8
  2374. SYSTEM.!VariantCreate_Clear ENDP
  2375.  
  2376. //ESI address of variant
  2377. SYSTEM.!FreeVariantAnsiStr PROC NEAR32
  2378.       MOV AX,[ESI]
  2379.       AND AX,$0FFF  //mask type
  2380.       CMP AX,$0100  //is it a ansi string ??
  2381.       JNE !not_a_Ansi
  2382.       ADD ESI,2     //points to ansi string
  2383.       CALLN32 SYSTEM.!FreeAnsiStr
  2384.       SUB ESI,2
  2385. !not_a_Ansi:
  2386.       RETN32
  2387. SYSTEM.!FreeVariantAnsiStr ENDP
  2388.  
  2389. //(Variant)
  2390. SYSTEM.!UniqueVariant0 PROC NEAR32
  2391.       PUSH EBP
  2392.       MOV EBP,ESP
  2393.       SUB ESP,4
  2394.  
  2395.       PUSH EAX
  2396.       PUSH EBX
  2397.       PUSH ECX
  2398.       PUSH EDX
  2399.       PUSH EDI
  2400.       PUSH ESI
  2401.  
  2402.       MOV ESI,[EBP+8]         //Variant
  2403.       MOV AX,[ESI]
  2404.       AND AX,$0FFF            //mask type
  2405.       CMP AX,$0100            //is it a ansi string ??
  2406.       JNE !not_a_Ansi5
  2407.       ADD ESI,2               //points to ansi string
  2408.       PUSH ESI                //source and dest
  2409.       CALLN32 SYSTEM.!AnsiCreate_Clear
  2410.       MOV ESI,[EBP+8]
  2411.       ADD ESI,2
  2412.       MOV EAX,[ESI]
  2413.       CMP EAX,0
  2414.       JE !not_a_Ansi5
  2415.       MOVD [EAX-8],0          //reference count to 0
  2416. !not_a_Ansi5:
  2417.       POP ESI
  2418.       POP EDI
  2419.       POP EDX
  2420.       POP ECX
  2421.       POP EBX
  2422.       POP EAX
  2423.  
  2424.       LEAVE
  2425.       RETN32 4
  2426. SYSTEM.!UniqueVariant0 ENDP
  2427.  
  2428. //(VAR Type,TypeInfo:POINTER)
  2429. SYSTEM.!FreeVariantAnsiType PROC NEAR32
  2430.       PUSH EBP
  2431.       MOV EBP,ESP
  2432.  
  2433.       PUSH EAX
  2434.       PUSH EBX
  2435.       PUSH ECX
  2436.       PUSH EDX
  2437.       PUSH EDI
  2438.       PUSH ESI
  2439.  
  2440.       MOV ESI,[EBP+8]    //TypeInfo
  2441.       INC ESI
  2442.       MOV EDI,[EBP+12]   //Type to free
  2443.       CMP ESI,1
  2444.       JE !No_valid_type
  2445.       CMP EDI,0
  2446.       JE !No_valid_type
  2447.  
  2448.       CMPB [ESI-1],2     //RECORD ?
  2449.       JNE !No_Record
  2450.       //Type is a record
  2451. !Rec:
  2452.       MOV AL,[ESI]
  2453.       INC ESI
  2454.       CMP AL,0           //End of list
  2455.       JE !No_valid_type
  2456.  
  2457.       MOV EBX,EDI
  2458.       ADD EBX,[ESI]      //Calculate address
  2459.       ADD ESI,4
  2460.  
  2461.       CMP AL,1           //Is it an ansi string ??
  2462.       JNE !No_Ansi_Rec
  2463.       PUSH ESI
  2464.       PUSH EDI
  2465.       MOV ESI,EBX
  2466.       CALLN32 SYSTEM.!FreeAnsiStr
  2467.       POP EDI
  2468.       POP ESI
  2469.       JMP !Rec
  2470.  
  2471. !No_Ansi_Rec:
  2472.       CMP AL,2           //Is it a variant ??
  2473.       JNE !No_Variant_Rec
  2474.       PUSH EBX
  2475.       CALLN32 SYSTEM.!FreeVariant
  2476.       JMP !Rec
  2477.  
  2478. !No_Variant_Rec:
  2479.       CMP AL,3
  2480.       JNE !No_valid_type
  2481.       //it is a nested type info
  2482.       PUSH EBX
  2483.       PUSH DWORD PTR [ESI]  //nested type info
  2484.       ADD ESI,4
  2485.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2486.       JMP !Rec           //next entry
  2487.  
  2488. !No_Record:
  2489.       CMPB [ESI-1],3     //OBJECT or CLASS ?
  2490.       JNE !No_Class
  2491.       //Type is object or class
  2492.       PUSH EDI
  2493.       PUSH DWORD PTR [ESI] //Parent type info
  2494.       ADD ESI,4
  2495.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2496.       JMP !Rec
  2497.  
  2498. !No_Class:
  2499.       CMPB [ESI-1],4     //Array ?
  2500.       JNE !No_Array
  2501.       //Type is an array
  2502.       MOV ECX,[ESI]      //array high index
  2503.       ADD ESI,4
  2504.       MOV EDX,[ESI]      //array elem size
  2505.       ADD ESI,4
  2506. !AAgain:
  2507.       PUSH ECX
  2508.       PUSH EDX
  2509.       PUSH ESI
  2510.       PUSH EDI
  2511.  
  2512.       CMPB [ESI],1
  2513.       JNE !No_AAnsi
  2514.  
  2515.       MOV ESI,EDI
  2516.       CALLN32 SYSTEM.!FreeAnsiStr
  2517.       JMP !AWeiter
  2518. !No_AAnsi:
  2519.       CMPB [ESI],2
  2520.       JNE !No_AVariant
  2521.  
  2522.       PUSH EDI
  2523.       CALLN32 SYSTEM.!FreeVariant
  2524.       JMP !AWeiter
  2525. !No_AVariant:
  2526.       //nested info
  2527.       PUSH EDI
  2528.       PUSH DWORD PTR [ESI+1]
  2529.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2530. !AWeiter:
  2531.       POP EDI
  2532.       POP ESI
  2533.       POP EDX
  2534.       POP ECX
  2535.       ADD EDI,EDX        //next array item
  2536.       LOOP !AAgain       //loop through array indizes
  2537.  
  2538. !No_Array:
  2539.       CMPB [ESI-1],5     //Pointer ??
  2540.       JNE !No_valid_type
  2541.       //Type is a pointer, pointers are passed by value !!!
  2542.       CMP EDI,0
  2543.       JE !No_valid_type  //Pointer is nil
  2544.  
  2545.       CMPB [ESI],1
  2546.       JNE !No_PAnsi
  2547.  
  2548.       MOV ESI,EDI
  2549.       CALLN32 SYSTEM.!FreeAnsiStr
  2550.       JMP !No_valid_type
  2551. !No_PAnsi:
  2552.       CMPB [ESI],2
  2553.       JNE !No_PVariant
  2554.  
  2555.       PUSH EDI
  2556.       CALLN32 SYSTEM.!FreeVariant
  2557.       JMP !No_valid_type
  2558. !No_PVariant:
  2559.       PUSH EDI
  2560.       PUSH DWORD PTR [ESI+1]  //Type info
  2561.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2562.  
  2563. !No_valid_type:
  2564.       POP ESI
  2565.       POP EDI
  2566.       POP EDX
  2567.       POP ECX
  2568.       POP EBX
  2569.       POP EAX
  2570.  
  2571.       LEAVE
  2572.       RETN32 8
  2573. SYSTEM.!FreeVariantAnsiType ENDP
  2574.  
  2575. SYSTEM.!FreeObjectVariantAnsi PROC NEAR32
  2576.       PUSH EBP
  2577.       MOV EBP,ESP
  2578.  
  2579.       PUSH EAX
  2580.  
  2581.       PUSH DWORD PTR [EBP+8]   //class/object to free
  2582.       PUSH DWORD PTR [EAX+12]  //typeinfo within VMT of object
  2583.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2584.  
  2585.       POP EAX
  2586.       LEAVE
  2587.       RETN32  //dont pop !
  2588. SYSTEM.!FreeObjectVariantAnsi ENDP
  2589.  
  2590. SYSTEM.!FreePointerVariantAnsi PROC NEAR32
  2591.       PUSH EBP
  2592.       MOV EBP,ESP
  2593.  
  2594.       PUSH DWORD PTR [EBP+16]  //pointer to free
  2595.       PUSH DWORD PTR [EBP+8]   //type info
  2596.       CALLN32 SYSTEM.!FreeVariantAnsiType
  2597.  
  2598.       LEAVE
  2599.       RETN32 4   //dont pop others !
  2600. SYSTEM.!FreePointerVariantAnsi ENDP
  2601.  
  2602. //(Variant)
  2603. SYSTEM.!FreeVariant PROC NEAR32
  2604.       PUSH EBP
  2605.       MOV EBP,ESP
  2606.  
  2607.       PUSH EAX
  2608.       PUSH EBX
  2609.       PUSH ECX
  2610.       PUSH EDX
  2611.       PUSH EDI
  2612.       PUSH ESI
  2613.  
  2614.       MOV ESI,[EBP+8]     //Variant
  2615.       CALLN32 SYSTEM.!FreeVariantAnsiStr
  2616.  
  2617.       MOV ESI,[EBP+8]     //Variant
  2618.       MOVD [ESI],0
  2619.       MOVD [ESI+4],0
  2620.  
  2621.       POP ESI
  2622.       POP EDI
  2623.       POP EDX
  2624.       POP ECX
  2625.       POP EBX
  2626.       POP EAX
  2627.  
  2628.       LEAVE
  2629.       RETN32 4
  2630. SYSTEM.!FreeVariant ENDP
  2631.  
  2632. SYSTEM.!FreeConstVariant PROC NEAR32
  2633.       MOV AX,[ESI]
  2634.       AND AX,$0FFF       //mask type
  2635.       CMP AX,$0100       //is it a ansi string ??
  2636.       JNE !not_a_Ansi1
  2637.       ADD ESI,2          //points to ansi string
  2638.       CALLN32 SYSTEM.!FreeConstAnsi
  2639.       SUB ESI,2
  2640. !not_a_Ansi1:
  2641.       RETN32
  2642. SYSTEM.!FreeConstVariant ENDP
  2643.  
  2644. END;
  2645.  
  2646. //Ansi string support
  2647.  
  2648. FUNCTION AnsiPos(CONST item,source:AnsiString):LONGINT;
  2649. BEGIN
  2650.      ASM
  2651.          MOV EAX,0
  2652.          MOV ESI,item           //item
  2653.          CMP ESI,0
  2654.          JE Lab4
  2655.          MOV EDX,[ESI-4]
  2656.          OR EDX,EDX
  2657.          JE lab2
  2658.          MOV EDI,source         //source
  2659.          CMP EDI,0
  2660.          JE Lab4
  2661.          MOV ECX,[EDI-4]
  2662.          SUB ECX,EDX
  2663.          JB lab2
  2664.          INC ECX
  2665. lab1:
  2666.          CLD
  2667.          LODSB
  2668.          REPNE
  2669.          SCASB
  2670.          JNE lab2
  2671.          MOV EAX,EDI
  2672.          MOV EBX,ECX
  2673.          MOV ECX,EDX
  2674.          DEC ECX
  2675.          REPE
  2676.          CMPSB
  2677.          JE lab3
  2678.          MOV EDI,EAX
  2679.          MOV ECX,EBX
  2680.          MOV ESI,item      //item
  2681.          JMP lab1
  2682. Lab2:
  2683.          XOR EAX,EAX
  2684.          JMP Lab4
  2685. lab3:
  2686.          SUB EAX,Source    //source
  2687. Lab4:
  2688.          MOV result,EAX
  2689.      END;
  2690. END;
  2691.  
  2692. FUNCTION AnsiPosStr(CONST item:STRING;CONST source:AnsiString):LONGINT;
  2693. VAR s:AnsiString;
  2694. BEGIN
  2695.      s:=Item;
  2696.      result:=AnsiPos(s,source);
  2697. END;
  2698.  
  2699. FUNCTION AnsiCopy(CONST Source:AnsiString;Index,Count:LONGINT):AnsiString;
  2700. BEGIN
  2701.      ASM
  2702.         MOV EDI,Result               //Destination string
  2703.         MOVD [EDI+0],0               //Empty String
  2704.  
  2705.         MOV ESI,Source               //Source string
  2706.         CMP ESI,0
  2707.         JE !_CopyE
  2708.  
  2709.         MOV ECX,Count                //Count
  2710.         CMP ECX,1
  2711.         JL !_CopyE
  2712.  
  2713.         MOV EAX,Index                //Index
  2714.         CMP EAX,1
  2715.         JNL !_Copy1
  2716.         MOV EAX,1                    //Index:=1
  2717. !_Copy1:
  2718.         MOV EBX,[ESI-4]              //Length of Source
  2719.         CMP EAX,EBX
  2720.         JA !_CopyE                   //Index greater than string
  2721.  
  2722.         MOV EDX,EAX
  2723.         ADD EDX,ECX                  //Index+Count
  2724.         CMP EDX,EBX
  2725.         JNA !_Copy2
  2726.         MOV ECX,EBX
  2727.         SUB ECX,EAX
  2728.         INC ECX                      //Count := Length(S)-Index+1
  2729. !_Copy2:
  2730.         PUSH EDI
  2731.         PUSH ESI
  2732.         PUSH ECX
  2733.         PUSH EAX
  2734.  
  2735.         PUSH EDI
  2736.         PUSH ECX
  2737.         CALLN32 SYSTEM.AnsiSetLength
  2738.  
  2739.         POP EAX
  2740.         POP ECX
  2741.         POP ESI
  2742.         POP EDI
  2743.         MOV EDI,[EDI]
  2744.  
  2745.         ADD ESI,EAX                  //first char
  2746.         DEC ESI
  2747.         CLD
  2748.         MOV EDX,ECX
  2749.         SHR ECX,2
  2750.         REP
  2751.         MOVSD
  2752.         MOV ECX,EDX
  2753.         AND ECX,3
  2754.         REP
  2755.         MOVSB
  2756. !_CopyE:
  2757.      END;
  2758. END;
  2759.  
  2760. PROCEDURE AnsiInsert(CONST Source:AnsiString; VAR S:AnsiString; Index:LONGINT);
  2761. BEGIN
  2762.      IF Length(Source) = 0 THEN exit;
  2763.      IF Length(S) = 0 THEN
  2764.      BEGIN
  2765.           S := Source;
  2766.           exit;
  2767.      END;
  2768.      IF Index < 1 THEN Index := 1;
  2769.      IF Index > Length(S) THEN Index := Length(S)+1;
  2770.      S := AnsiCopy(S,1,Index-1) + Source + AnsiCopy(S,Index,Length(S)-Index+1);
  2771. END;
  2772.  
  2773. PROCEDURE AnsiInsertStr(CONST Source:String; VAR S:AnsiString; Index:LONGINT);
  2774. VAR ss:AnsiString;
  2775. BEGIN
  2776.      ss:=Source;
  2777.      AnsiInsert(s,ss,Index);
  2778. END;
  2779.  
  2780. PROCEDURE AnsiDelete(VAR S:AnsiString; Index,Count:LONGINT);
  2781. BEGIN
  2782.      IF Index < 1 THEN exit;
  2783.      IF Index > Length(S) THEN exit;
  2784.      IF Count < 1 THEN exit;
  2785.      IF Index+Count > Length(S) THEN Count := Length(S)-Index+1;
  2786.      S := AnsiCopy(S,1,Index-1) + AnsiCopy(S,Index+Count,Length(S)-Index-Count+1);
  2787. END;
  2788.  
  2789. PROCEDURE SetLength(VAR s:STRING;NewLength:LONGINT);
  2790. BEGIN
  2791.      s[0]:=chr(NewLength);
  2792. END;
  2793.  
  2794. PROCEDURE AnsiSetLength(VAR S:AnsiString;NewLength:LONGINT);
  2795. VAR Temp:AnsiString;
  2796. BEGIN
  2797.      ASM
  2798.         MOV EAX,NewLength
  2799.         ADD EAX,9 //Len of string plus 8 byte + zero termination byte
  2800.         LEA ESI,Temp
  2801.         PUSH ESI
  2802.         PUSH EAX
  2803.         CALLN32 SYSTEM.GetMem
  2804.  
  2805.         MOV EDI,Temp
  2806.         MOV EAX,NewLength
  2807.         MOV [EDI+4],EAX     //set new length
  2808.         MOVD [EDI],2        //reference count is 2 (!!)
  2809.         ADD EDI,8           //AnsiString starts at offset 8
  2810.         MOV Temp,EDI
  2811.         MOV ESI,S
  2812.         MOV ESI,[ESI]
  2813.         CMP ESI,0
  2814.         JE !ex
  2815.  
  2816.         MOV ECX,[ESI-4]    //get length of string
  2817.         CLD
  2818.         MOV EDX,ECX
  2819.         SHR ECX,2
  2820.         REP
  2821.         MOVSD
  2822.         MOV ECX,EDX
  2823.         AND ECX,3
  2824.         REP
  2825.         MOVSB
  2826.  
  2827.         //check if we can free source
  2828.         MOV ESI,S
  2829.         CALLN32 SYSTEM.!FreeAnsiStr
  2830. !ex:
  2831.         MOV ESI,S
  2832.         MOV EAX,Temp
  2833.         MOV [ESI],EAX
  2834.      END;
  2835. END;
  2836.  
  2837. PROCEDURE SetString(VAR s:STRING;Buffer:PChar;Len:LONGINT);
  2838. BEGIN
  2839.      s[0]:=chr(Len);
  2840.      IF Buffer<>NIL THEN Move(Buffer^,s[1],Len);
  2841. END;
  2842.  
  2843. PROCEDURE AnsiSetString(VAR S:AnsiString;Buffer:PChar;Len:LONGINT);
  2844. BEGIN
  2845.      AnsiSetLength(S,Len);
  2846.      IF Buffer<>NIL THEN
  2847.      BEGIN
  2848.           ASM
  2849.              MOV EDI,S
  2850.              MOV EDI,[EDI]
  2851.              MOV ESI,Buffer
  2852.              MOV ECX,Len
  2853.              CLD
  2854.              MOV EDX,ECX
  2855.              SHR ECX,2
  2856.              REP
  2857.              MOVSD
  2858.              MOV ECX,EDX
  2859.              AND ECX,3
  2860.              REP
  2861.              MOVSB
  2862.           END;
  2863.      END;
  2864. END;
  2865.  
  2866. ASSEMBLER
  2867.  
  2868. SYSTEM.!AnsiCmp PROC NEAR32
  2869.               CLD
  2870.               PUSH EBP
  2871.               MOV EBP,ESP
  2872.  
  2873.               PUSH EAX
  2874.               PUSH EBX
  2875.               PUSH ECX
  2876.               PUSH EDI
  2877.               PUSH ESI
  2878.  
  2879.               MOV AL,1
  2880.               MOV AH,0
  2881.               MOV ESI,[EBP+12]
  2882.               MOV ESI,[ESI]
  2883.               MOV EDI,[EBP+8]
  2884.               MOV EDI,[EDI]
  2885.               CMP ESI,EDI
  2886.               JE _nl3        //ok
  2887.               CMP EDI,0
  2888.               JNE _nl2_r1
  2889.               //ESI=NIL
  2890.               CMPB [ESI],0
  2891.               JE _nl3        //both empty
  2892.               JMP _nl2
  2893. _nl2_r1:
  2894.               MOV AH,2
  2895.               CMP ESI,0
  2896.               JNE _nl2_r2
  2897.               //EDI=NIL
  2898.               CMPB [EDI],0
  2899.               JE _nl3       //both empty
  2900.               JMP _nl2
  2901. _nl2_r2:
  2902.               MOV BX,$0101
  2903.               MOV EAX,[ESI-4]
  2904.               CMP EAX,[EDI-4]
  2905.               JE !_norene1
  2906.               MOV BL,0        //length does not match - strings cannot be equal
  2907.               CMP EAX,[EDI-4]
  2908. !_norene1:
  2909.               JBE _nl1
  2910.               MOV EAX,[EDI-4]
  2911. _nl1:
  2912.               MOV ECX,EAX
  2913.               CLD
  2914.               REP
  2915.               CMPSB
  2916.               JNE _nl3
  2917.               MOV AX,BX  //BL,BH are equal if length matches
  2918. _nl2:
  2919.               CMP AL,AH
  2920. _nl3:
  2921.               PUSHF
  2922.  
  2923.               //check if we can free first operand
  2924.               MOV ESI,[EBP+12]
  2925.               MOV EDI,[ESI]
  2926.               CMP EDI,0
  2927.               JE !AnsiCmp1
  2928.               CMPD [EDI-8],0
  2929.               JNE !AnsiCmp1
  2930.               CALLN32 SYSTEM.!FreeAnsiStr
  2931. !AnsiCmp1:
  2932.               //check if we can free second operand
  2933.               MOV ESI,[EBP+8]
  2934.               MOV EDI,[ESI]
  2935.               CMP EDI,0
  2936.               JE !AnsiCmpEx
  2937.               CMPD [EDI-8],0
  2938.               JNE !AnsiCmpEx
  2939.               CALLN32 SYSTEM.!FreeAnsiStr
  2940. !AnsiCmpEx:
  2941.               POPF
  2942.               POP ESI
  2943.               POP EDI
  2944.               POP ECX
  2945.               POP EBX
  2946.               POP EAX
  2947.  
  2948.               LEAVE
  2949.               RETN32 8
  2950. SYSTEM.!AnsiCmp ENDP
  2951.  
  2952. //(Dest,Source)
  2953. SYSTEM.!AnsiAdd PROC NEAR32
  2954.       PUSH EBP
  2955.       MOV EBP,ESP
  2956.  
  2957.       PUSH EAX
  2958.       PUSH EBX
  2959.       PUSH ECX
  2960.       PUSH EDX
  2961.       PUSH EDI
  2962.       PUSH ESI
  2963.  
  2964.       MOV ESI,[EBP+12]        //Dest
  2965.       MOV ESI,[ESI]
  2966.       CMP ESI,0
  2967.       JNE !AnsiAddOk          //destination not empty
  2968.  
  2969.       MOV ESI,[EBP+8]         //Source
  2970.       MOV EDI,[EBP+12]        //Dest
  2971.       MOV EDX,[ESI]
  2972.       MOV [EDI],EDX
  2973.       PUSH DWORD PTR [EBP+12] //Dest
  2974.       CALLN32 SYSTEM.!AnsiCreate_Clear
  2975.       MOV ESI,[EBP+12]        //Dest
  2976.       MOV ESI,[ESI]
  2977.       CMP ESI,0               //destination is empty
  2978.       JE !AnsiAddEx
  2979.       MOVD [ESI-8],0          //reference count to 0
  2980.       JMP !AnsiAddEx
  2981. !AnsiAddOk:
  2982.       //destination string is not empty
  2983.       MOV EDI,[EBP+8]         //Source
  2984.       MOV EDI,[EDI]
  2985.       CMP EDI,0
  2986.       JE !AnsiAddEx           //source is empty
  2987.  
  2988.       MOV EBX,[ESI-4]         //length of destination string
  2989.       MOV EAX,[EDI-4]         //length of source string
  2990.       ADD EAX,EBX             //length of destination string
  2991.       PUSH EBX
  2992.       PUSH DWORD PTR [EBP+12] //Dest
  2993.       PUSH EAX
  2994.       CALLN32 SYSTEM.AnsiSetLength
  2995.       POP EBX
  2996.  
  2997.       MOV EDI,[EBP+12]        //Dest
  2998.       MOV EDI,[EDI]
  2999.       MOVD [EDI-8],0          //reference count is 0
  3000.       ADD EDI,EBX             //Add old length of destination
  3001.       MOV ESI,[EBP+8]         //source
  3002.       MOV ESI,[ESI]
  3003.       MOV ECX,[ESI-4]         //length of source
  3004.       CLD
  3005.       MOV EDX,ECX
  3006.       SHR ECX,2
  3007.       REP
  3008.       MOVSD
  3009.       MOV ECX,EDX
  3010.       AND ECX,3
  3011.       REP
  3012.       MOVSB
  3013.       MOV AL,0   //terminate with 0
  3014.       STOSB
  3015.  
  3016.       //check if we can free source
  3017.       MOV ESI,[EBP+8]         //Source
  3018.       MOV EDI,[ESI]
  3019.       CMPD [EDI-8],0
  3020.       JNE !AnsiAddEx
  3021.       CALLN32 SYSTEM.!FreeAnsiStr
  3022. !AnsiAddEx:
  3023.       POP ESI
  3024.       POP EDI
  3025.       POP EDX
  3026.       POP ECX
  3027.       POP EBX
  3028.       POP EAX
  3029.  
  3030.       LEAVE
  3031.       RETN32 8
  3032. SYSTEM.!AnsiAdd ENDP
  3033.  
  3034. SYSTEM.!FreeAnsiStr PROC NEAR32
  3035.    //ESI address of Ansi string to free
  3036.    CMP ESI,0
  3037.    JE !String_Nil
  3038.    MOV EDI,[ESI]
  3039.    CMP EDI,0
  3040.    JE !String_Nil
  3041.    CMPD [EDI-8],0  //reference count is 0 (function result) -> free
  3042.    JE !Free_Ansi
  3043.    DECD [EDI-8]    //decrement reference count
  3044.    JNE !String_Nil //free only if reference count reaches 0
  3045. !Free_Ansi:
  3046.    PUSH ESI
  3047.    SUB EDI,8
  3048.    PUSH EDI
  3049.    MOV EAX,[EDI+4] //get len of Ansi string
  3050.    ADD EAX,9       //Len of string plus 8 byte + zero termination byte
  3051.    PUSH EAX
  3052.    CALLN32 SYSTEM.FreeMem
  3053.    //clear value
  3054.    POP ESI
  3055.    MOVD [ESI],0
  3056. !String_Nil:
  3057.    RETN32
  3058. SYSTEM.!FreeAnsiStr ENDP
  3059.  
  3060. SYSTEM.!DecAnsi PROC NEAR32
  3061.    PUSH EDI
  3062.    PUSH EBX
  3063.  
  3064.    MOV EBX,ESP
  3065.    MOV EDI,[EBX+12]
  3066.    MOV EDI,[EDI]
  3067.    CMP EDI,0
  3068.    JE !No_AnsiDec
  3069.    DECD [EDI-8]     //dec reference counter for function results
  3070. !No_AnsiDec:
  3071.    POP EBX
  3072.    POP EDI
  3073.    RETN32 4
  3074. SYSTEM.!DecAnsi ENDP
  3075.  
  3076. SYSTEM.!FreeConstAnsi PROC NEAR32
  3077. //Address of Ansi String in ESI
  3078.      MOV EDI,[ESI]
  3079.      CMP EDI,0
  3080.      JE !FreeAnsi0_0
  3081.      CMPD [EDI-8],0   //free only string with reference count 0
  3082.      JNE !FreeAnsi0
  3083. !Free_it:
  3084.      CALLN32 SYSTEM.!FreeAnsiStr
  3085.      JMP !FreeAnsi0_0
  3086. !FreeAnsi0:
  3087.      CMPD [EDI-8],$F0000000
  3088.      JE !Free_it
  3089.      JB !FreeAnsi0_0
  3090.      SUBD [EDI-8],$F0000000
  3091. !FreeAnsi0_0:
  3092.      RETN32
  3093. SYSTEM.!FreeConstAnsi ENDP
  3094.  
  3095. //(s)
  3096. SYSTEM.!FreeAnsi PROC NEAR32
  3097.    PUSH EBP
  3098.    MOV EBP,ESP
  3099.  
  3100.    PUSH EAX
  3101.    PUSH EBX
  3102.    PUSH ECX
  3103.    PUSH EDX
  3104.    PUSH ESI
  3105.    PUSH EDI
  3106.  
  3107.    MOV ESI,[EBP+8]       //Destination Ansi String
  3108.    CALLN32 SYSTEM.!FreeAnsiStr
  3109.  
  3110.    MOV ESI,[EBP+8]
  3111.    MOVD [ESI],0
  3112.  
  3113.    POP EDI
  3114.    POP ESI
  3115.    POP EDX
  3116.    POP ECX
  3117.    POP EBX
  3118.    POP EAX
  3119.  
  3120.    LEAVE
  3121.    RETN32 4
  3122. SYSTEM.!FreeAnsi ENDP
  3123.  
  3124. //(NewValue,s)
  3125. SYSTEM.!NewAnsiStr PROC NEAR32
  3126.    PUSH EBP
  3127.    MOV EBP,ESP
  3128.  
  3129.    PUSH EAX
  3130.    PUSH EBX
  3131.    PUSH ECX
  3132.    PUSH EDX
  3133.    PUSH ESI
  3134.    PUSH EDI
  3135.  
  3136.    MOV ESI,[EBP+8]              //Destination Ansi String
  3137.    CALLN32 SYSTEM.!FreeAnsiStr  //ESI contains address
  3138.  
  3139.    //clear destination Ansi
  3140.    MOVD [ESI],0
  3141.  
  3142.    MOV EDI,[EBP+12]             //String value to assign
  3143.    MOVZXB EAX,[EDI+0]
  3144.    CMP EAX,0
  3145.    JE !Ansi_0_10
  3146.    ADD EAX,9 //Len of string plus 8 byte + zero termination byte
  3147.    PUSH ESI
  3148.    PUSH EAX
  3149.    CALLN32 SYSTEM.GetMem
  3150.  
  3151.    MOV EDI,[EBP+8]              //Destination Ansi String
  3152.    MOV EDI,[EDI]
  3153.    MOVD [EDI],1                 //reference count to 1
  3154.    MOV ESI,[EBP+12]             //String value to assign
  3155.    MOVZXB ECX,[ESI+0]
  3156.    MOV [EDI+4],ECX              //set len
  3157.    INC ESI
  3158.    ADD EDI,8
  3159.    CLD
  3160.    MOV EDX,ECX
  3161.    SHR ECX,2
  3162.    REP
  3163.    MOVSD
  3164.    MOV ECX,EDX
  3165.    AND ECX,3
  3166.    REP
  3167.    MOVSB
  3168.    MOV AL,0                     //terminate with 0
  3169.    STOSB
  3170.  
  3171.    MOV EDI,[EBP+8]              //Destination Ansi String
  3172.    ADDD [EDI],8                 //AnsiString starts at offset 8
  3173. !Ansi_0_10:
  3174.    POP EDI
  3175.    POP ESI
  3176.    POP EDX
  3177.    POP ECX
  3178.    POP EBX
  3179.    POP EAX
  3180.  
  3181.    LEAVE
  3182.    RETN32 8
  3183. SYSTEM.!NewAnsiStr ENDP
  3184.  
  3185. //(NewValue,s)
  3186. SYSTEM.!NewAnsiStr0 PROC NEAR32
  3187.       PUSH EBP
  3188.       MOV EBP,ESP
  3189.       PUSH ESI
  3190.  
  3191.       MOV ESI,[EBP+8]   //Destination Ansi String
  3192.       MOVD [ESI],0
  3193.  
  3194.       PUSH DWORD PTR [EBP+12]  //String to assign
  3195.       PUSH ESI
  3196.       CALLN32 SYSTEM.!NewAnsiStr
  3197.  
  3198.       MOV ESI,[EBP+8]   //Destination Ansi String
  3199.       MOV ESI,[ESI]
  3200.       CMP ESI,0
  3201.       JE !Ansi0_exit
  3202.       MOVD [ESI-8],0       //reference count to 0
  3203. !Ansi0_exit:
  3204.       POP ESI
  3205.       LEAVE
  3206.       RETN32 8
  3207. SYSTEM.!NewAnsiStr0 ENDP
  3208.  
  3209. //(NewValue,s)
  3210. SYSTEM.!NewAnsiStrTemp PROC NEAR32
  3211.       PUSH EBP
  3212.       MOV EBP,ESP
  3213.       PUSH ESI
  3214.  
  3215.       MOV ESI,[EBP+8]               //Destination Ansi String
  3216.       MOVD [ESI],0
  3217.  
  3218.       PUSH DWORD PTR [EBP+12]       //String value to assign
  3219.       PUSH ESI
  3220.       CALLN32 SYSTEM.!NewAnsiStr
  3221.  
  3222.       MOV ESI,[EBP+8]               //Destination Ansi String
  3223.       MOV ESI,[ESI]
  3224.       CMP ESI,0
  3225.       JE !Ansi0_exit0
  3226.       MOVD [ESI-8],$F0000000       //reference count to $F0000000
  3227. !Ansi0_exit0:
  3228.       POP ESI
  3229.       LEAVE
  3230.       RETN32 8
  3231. SYSTEM.!NewAnsiStrTemp ENDP
  3232.  
  3233. //(Source,Dest)
  3234. SYSTEM.!AnsiCreate PROC NEAR32
  3235.      PUSH EBP
  3236.      MOV EBP,ESP
  3237.      PUSH EAX
  3238.      PUSH EBX
  3239.      PUSH ECX
  3240.      PUSH EDX
  3241.      PUSH ESI
  3242.      PUSH EDI
  3243.  
  3244.      MOV ESI,[EBP+12] //Source
  3245.      MOV EDI,[EBP+8]  //Dest
  3246.      MOV ESI,[ESI]
  3247.      MOVD [EDI],0     //Clear destination
  3248.      CMP ESI,0
  3249.      JE !No_Create
  3250.      PUSH ESI
  3251.      MOV EAX,[ESI-4]  //Get length
  3252.      ADD EAX,9        //8 byte for info + 1 Byte for zero terminator
  3253.      PUSH EDI
  3254.      PUSH EAX
  3255.      CALLN32 SYSTEM.GetMem
  3256.  
  3257.      POP ESI          //Source
  3258.      MOV EDI,[EBP+8]  //Dest
  3259.      MOV EDI,[EDI]
  3260.      SUB ESI,8
  3261.      MOV ECX,[ESI+4]  //get length
  3262.      ADD ECX,9        //8 byte for info + 1 Byte for zero terminator
  3263.      CLD
  3264.      MOV EDX,ECX
  3265.      SHR ECX,2
  3266.      REP
  3267.      MOVSD
  3268.      MOV ECX,EDX
  3269.      AND ECX,3
  3270.      REP
  3271.      MOVSB
  3272.  
  3273.      MOV EDI,[EBP+8]  //Dest
  3274.      MOV ESI,[EDI]
  3275.      ADDD [EDI],8     //AnsiString starts at offset 8
  3276.      MOVD [ESI],1     //reference count is 1
  3277. !No_Create:
  3278.      POP EDI
  3279.      POP ESI
  3280.      POP EDX
  3281.      POP ECX
  3282.      POP EBX
  3283.      POP EAX
  3284.      LEAVE
  3285.      RETN32 8
  3286. SYSTEM.!AnsiCreate ENDP
  3287.  
  3288. //Makes copies of parameters
  3289. //(Source)
  3290. SYSTEM.!AnsiCreate_Clear PROC NEAR32
  3291.      PUSH EBP
  3292.      MOV EBP,ESP
  3293.      SUB ESP,4
  3294.  
  3295.      PUSH EAX
  3296.      PUSH EBX
  3297.      PUSH ECX
  3298.      PUSH EDX
  3299.      PUSH ESI
  3300.      PUSH EDI
  3301.  
  3302.      MOV ESI,[EBP+8]         //Source
  3303.      MOV ESI,[ESI]
  3304.      PUSH ESI
  3305.  
  3306.      PUSH DWORD PTR [EBP+8]   //Source
  3307.      PUSH DWORD PTR [EBP+8]   //Dest
  3308.      CALLN32 SYSTEM.!AnsiCreate
  3309.  
  3310.      POP EDI
  3311.      MOV [EBP-4],EDI          //restore old value
  3312.      LEA ESI,[EBP-4]
  3313.      CALLN32 SYSTEM.!FreeConstAnsi
  3314. !cisok:
  3315.      POP EDI
  3316.      POP ESI
  3317.      POP EDX
  3318.      POP ECX
  3319.      POP EBX
  3320.      POP EAX
  3321.      LEAVE
  3322.      RETN32 4
  3323. SYSTEM.!AnsiCreate_Clear ENDP
  3324.  
  3325. //Makes copies of parameters for copy on write semantics s[index]:=...
  3326. //(Source)
  3327. SYSTEM.!AnsiCopy_Clear PROC NEAR32
  3328.      PUSH EBP
  3329.      MOV EBP,ESP
  3330.      SUB ESP,4
  3331.  
  3332.      PUSH EAX
  3333.      PUSH EBX
  3334.      PUSH ECX
  3335.      PUSH EDX
  3336.      PUSH ESI
  3337.      PUSH EDI
  3338.  
  3339.      MOV ESI,[EBP+8]         //Source
  3340.      MOV ESI,[ESI]
  3341.      CMPD [ESI-8],1          //only for strings with reference count >1
  3342.      JBE !cisok_cc
  3343.      PUSH ESI
  3344.  
  3345.      PUSH DWORD PTR [EBP+8]   //Source
  3346.      PUSH DWORD PTR [EBP+8]   //Dest
  3347.      CALLN32 SYSTEM.!AnsiCreate
  3348.  
  3349.      POP EDI
  3350.      MOV [EBP-4],EDI          //restore old value
  3351.      LEA ESI,[EBP-4]
  3352.      CALLN32 SYSTEM.!FreeAnsiStr
  3353. !cisok_cc:
  3354.      POP EDI
  3355.      POP ESI
  3356.      POP EDX
  3357.      POP ECX
  3358.      POP EBX
  3359.      POP EAX
  3360.      LEAVE
  3361.      RETN32 4
  3362. SYSTEM.!AnsiCopy_Clear ENDP
  3363.  
  3364. //(Source,Dest)
  3365. SYSTEM.!AnsiCreate0 PROC NEAR32
  3366.       PUSH EBP
  3367.       MOV EBP,ESP
  3368.       PUSH EAX
  3369.       PUSH EBX
  3370.       PUSH ECX
  3371.       PUSH EDX
  3372.       PUSH ESI
  3373.       PUSH EDI
  3374.  
  3375.       PUSH DWORD PTR [EBP+12]  //Source
  3376.       PUSH DWORD PTR [EBP+8]   //Dest
  3377.       CALLN32 SYSTEM.!AnsiCreate
  3378.  
  3379.       MOV ESI,[EBP+8]          //Dest
  3380.       MOV ESI,[ESI]
  3381.       CMP ESI,0
  3382.       JE !Ansi3_exit
  3383.       MOVD [ESI-8],0       //reference count to 0
  3384. !Ansi3_exit:
  3385.       POP EDI
  3386.       POP ESI
  3387.       POP EDX
  3388.       POP ECX
  3389.       POP EBX
  3390.       POP EAX
  3391.       LEAVE
  3392.       RETN32 8
  3393. SYSTEM.!AnsiCreate0 ENDP
  3394.  
  3395. //(Source,Dest)
  3396. SYSTEM.!AnsiCopy PROC NEAR32
  3397.    PUSH EBP
  3398.    MOV EBP,ESP
  3399.  
  3400.    PUSH EAX
  3401.    PUSH EBX
  3402.    PUSH ECX
  3403.    PUSH EDX
  3404.    PUSH ESI
  3405.    PUSH EDI
  3406.  
  3407.    MOV ESI,[EBP+8]    //Dest
  3408.    MOV EDI,[EBP+12]   //Source
  3409.    MOV EDI,[EDI]
  3410.    CMP EDI,[ESI]
  3411.    JE !Ansi_0_3       //contents are equal
  3412.  
  3413.    CALLN32 SYSTEM.!FreeAnsiStr  //free dest str if reference count reaches 0
  3414.  
  3415.    MOV EDI,[EBP+12]   //Source
  3416.    MOV EDI,[EDI]
  3417.    CMP EDI,0
  3418.    JE !Ansi_0_3
  3419.    INCD [EDI-8]       //inc reference count
  3420. !Ansi_0_3:
  3421.    MOV [ESI],EDI
  3422.  
  3423.    POP EDI
  3424.    POP ESI
  3425.    POP EDX
  3426.    POP ECX
  3427.    POP EBX
  3428.    POP EAX
  3429.  
  3430.    LEAVE
  3431.    RETN32 8
  3432. SYSTEM.!AnsiCopy ENDP
  3433.  
  3434. //(Source,Dest,MaxLen)
  3435. SYSTEM.!AssignAnsi2Str PROC NEAR32
  3436.    PUSH EBP
  3437.    MOV EBP,ESP
  3438.  
  3439.    PUSH EAX
  3440.    PUSH EBX
  3441.    PUSH ECX
  3442.    PUSH EDX
  3443.    PUSH ESI
  3444.    PUSH EDI
  3445.  
  3446.    MOV EDI,[EBP+12]   //Dest
  3447.    MOVB [EDI],0
  3448.    MOV ESI,[EBP+16]   //Source
  3449.    MOV ESI,[ESI]
  3450.    CMP ESI,0
  3451.    JE !Ansi_0
  3452.    MOV ECX,[ESI-4]    //get length of Ansi String
  3453.    MOV EDX,[EBP+8]    //MaxLen
  3454.    CMP ECX,EDX
  3455.    JB !len_ok
  3456.    MOV ECX,EDX       //limit size
  3457. !len_ok:
  3458.    MOV [EDI],CL
  3459.    INC EDI
  3460.    CLD
  3461.    MOV EDX,ECX
  3462.    SHR ECX,2
  3463.    REP
  3464.    MOVSD
  3465.    MOV ECX,EDX
  3466.    AND ECX,3
  3467.    REP
  3468.    MOVSB
  3469.  
  3470.    //free Ansi if it has a length of 0
  3471.    MOV ESI,[EBP+16]    //Source
  3472.    MOV EDI,[ESI]
  3473.    CMPD [EDI-8],0
  3474.    JNE !Ansi_0
  3475.    CALLN32 SYSTEM.!FreeAnsiStr
  3476. !Ansi_0:
  3477.    POP EDI
  3478.    POP ESI
  3479.    POP EDX
  3480.    POP ECX
  3481.    POP EBX
  3482.    POP EAX
  3483.  
  3484.    LEAVE
  3485.    RETN32 12
  3486. SYSTEM.!AssignAnsi2Str ENDP
  3487.  
  3488. //(Source,Dest,MaxLen)
  3489. SYSTEM.!AssignAnsi2PChar PROC NEAR32
  3490.    PUSH EBP
  3491.    MOV EBP,ESP
  3492.  
  3493.    PUSH EAX
  3494.    PUSH EBX
  3495.    PUSH ECX
  3496.    PUSH EDX
  3497.    PUSH ESI
  3498.    PUSH EDI
  3499.  
  3500.    MOV EDI,[EBP+12]    //Dest
  3501.    MOVB [EDI],0
  3502.    MOV ESI,[EBP+16]    //Source
  3503.    MOV ESI,[ESI]
  3504.    CMP ESI,0
  3505.    JE !Ansi_0_1
  3506.    MOV ECX,[ESI-4]     //get length of Ansi String
  3507.    MOV EDX,[EBP+8]     //MaxLen
  3508.    CMP ECX,EDX
  3509.    JB !len_ok_1
  3510.    MOV ECX,EDX         //limit size
  3511. !len_ok_1:
  3512.    INC ECX             //copy with 0 terminator
  3513.    CLD
  3514.    MOV EDX,ECX
  3515.    SHR ECX,2
  3516.    REP
  3517.    MOVSD
  3518.    MOV ECX,EDX
  3519.    AND ECX,3
  3520.    REP
  3521.    MOVSB
  3522.  
  3523.    //free Ansi if it has a length of 0
  3524.    MOV ESI,[EBP+16]     //Source
  3525.    MOV EDI,[ESI]
  3526.    CMPD [EDI-8],0
  3527.    JNE !Ansi_0_1
  3528.    CALLN32 SYSTEM.!FreeAnsiStr
  3529. !Ansi_0_1:
  3530.    POP EDI
  3531.    POP ESI
  3532.    POP EDX
  3533.    POP ECX
  3534.    POP EBX
  3535.    POP EAX
  3536.  
  3537.    LEAVE
  3538.    RETN32 12
  3539. SYSTEM.!AssignAnsi2PChar ENDP
  3540.  
  3541. //(Source,Dest)
  3542. SYSTEM.!CSTRING2ANSI PROC NEAR32
  3543.    PUSH EBP
  3544.    MOV EBP,ESP
  3545.  
  3546.    PUSH EAX
  3547.    PUSH EBX
  3548.    PUSH ECX
  3549.    PUSH EDX
  3550.    PUSH ESI
  3551.    PUSH EDI
  3552.  
  3553.    MOV ESI,[EBP+8]    //Dest
  3554.    CALLN32 SYSTEM.!FreeAnsiStr  //free str if reference count reaches 0
  3555.  
  3556.    //clear dest string
  3557.    MOVD [ESI],0
  3558.    //determine length of CString
  3559.    MOV EDI,[EBP+12]  //Source
  3560.    MOV ECX,$0FFFFFFFF
  3561.    XOR AL,AL
  3562.    CLD
  3563.    REPNE
  3564.    SCASB
  3565.    NOT ECX
  3566.    DEC ECX          //without #0
  3567.    CMP ECX,0
  3568.    JE !Ansi_0_5     //empty cstring
  3569.    PUSH ECX
  3570.  
  3571.    PUSH DWORD PTR [EBP+8]  //Dest
  3572.    ADD ECX,9        //8 byte for info + 1 byte for terminating 0
  3573.    PUSH ECX
  3574.    CALLN32 SYSTEM.GetMem
  3575.  
  3576.    POP ECX
  3577.    MOV ESI,[EBP+8]  //Dest
  3578.    MOV EDI,[ESI]
  3579.    MOVD [EDI],1     //reference count to 1
  3580.    MOV [EDI+4],ECX  //set len
  3581.    ADD EDI,8        //String starts at offset 8
  3582.    MOV [ESI],EDI    //set destination
  3583.    MOV ESI,[EBP+12] //Source
  3584.  
  3585.    INC ECX          //copy with #0
  3586.    CLD
  3587.    MOV EDX,ECX
  3588.    SHR ECX,2
  3589.    REP
  3590.    MOVSD
  3591.    MOV ECX,EDX
  3592.    AND ECX,3
  3593.    REP
  3594.    MOVSB
  3595. !Ansi_0_5:
  3596.    POP EDI
  3597.    POP ESI
  3598.    POP EDX
  3599.    POP ECX
  3600.    POP EBX
  3601.    POP EAX
  3602.  
  3603.    LEAVE
  3604.    RETN32 8
  3605. SYSTEM.!CSTRING2ANSI ENDP
  3606.  
  3607. //(Source,Dest)
  3608. SYSTEM.!CSTRING2ANSI0 PROC NEAR32
  3609.       PUSH EBP
  3610.       MOV EBP,ESP
  3611.       PUSH ESI
  3612.  
  3613.       MOV ESI,[EBP+8] //Dest
  3614.       MOVD [ESI],0
  3615.  
  3616.       PUSH DWORD PTR [EBP+12] //Source
  3617.       PUSH ESI
  3618.       CALLN32 SYSTEM.!CString2Ansi
  3619.  
  3620.       MOV ESI,[EBP+8] //Dest
  3621.       MOV ESI,[ESI]
  3622.       CMP ESI,0
  3623.       JE !Ansi1_exit
  3624.       MOVD [ESI-8],0       //reference count to 0
  3625. !Ansi1_exit:
  3626.       POP ESI
  3627.       LEAVE
  3628.       RETN32 8
  3629. SYSTEM.!CSTRING2ANSI0 ENDP
  3630.  
  3631. //(Source,Dest)
  3632. SYSTEM.!CSTRING2ANSITemp PROC NEAR32
  3633.       PUSH EBP
  3634.       MOV EBP,ESP
  3635.       PUSH ESI
  3636.  
  3637.       MOV ESI,[EBP+8] //Dest
  3638.       MOVD [ESI],0
  3639.  
  3640.       PUSH DWORD PTR [EBP+12] //Source
  3641.       PUSH ESI
  3642.       CALLN32 SYSTEM.!CString2Ansi
  3643.  
  3644.       MOV ESI,[EBP+8] //Dest
  3645.       MOV ESI,[ESI]
  3646.       CMP ESI,0
  3647.       JE !Ansi1_exit0
  3648.       MOVD [ESI-8],$F0000000       //reference count to $F0000000
  3649. !Ansi1_exit0:
  3650.       POP ESI
  3651.       LEAVE
  3652.       RETN32 8
  3653. SYSTEM.!CSTRING2ANSITemp ENDP
  3654.  
  3655.  
  3656. END;
  3657.  
  3658. PROCEDURE UniqueStr(VAR S:AnsiString);
  3659. VAR s1:AnsiString;
  3660. BEGIN
  3661.      ASM
  3662.         MOV EDI,S
  3663.         MOV EDI,[EDI]
  3664.         CMP EDI,0
  3665.         JNE !Ansi_0_3_u
  3666.         LEAVE
  3667.         RETN32 4
  3668. !Ansi_0_3_u:
  3669.         CMPD [EDI-8],1       //check reference count
  3670.         JA !Ansi_0_3_u1
  3671.         LEAVE
  3672.         RETN32 4
  3673. !Ansi_0_3_u1:
  3674.         PUSH DWORD PTR S   //Source
  3675.         LEA EAX,s1         //Dest
  3676.         PUSH EAX
  3677.         CALLN32 SYSTEM.!AnsiCreate
  3678.      END;
  3679.      S:=s1;
  3680. END;
  3681.  
  3682.  
  3683. //General functions
  3684.  
  3685. {$HINTS OFF}
  3686. FUNCTION Assigned(p: Pointer): Boolean;ASSEMBLER;
  3687. ASM
  3688.   MOV EAX,p
  3689.   CMP EAX,0
  3690.   SETNE AL
  3691.   LEAVE
  3692.   RETN32 4
  3693. END;
  3694. {$HINTS ON}
  3695.  
  3696. PROCEDURE Check_Is(o:TObject;ClassInfo:TClass);
  3697. VAR bo:BOOLEAN;
  3698. BEGIN
  3699.      ASM
  3700.         PUSH EAX
  3701.         PUSH EBX
  3702.         PUSH ECX
  3703.         PUSH EDX
  3704.         PUSH ESI
  3705.         PUSH EDI
  3706.      END;
  3707.      IF o=NIL THEN bo:=FALSE
  3708.      ELSE
  3709.      BEGIN
  3710.           IF ((ClassInfo<>NIL)AND(ClassInfo.ClassName='Exception')And
  3711.               (o.InheritsFrom(SysException))) THEN bo:=TRUE
  3712.           ELSE bo:=o.InheritsFrom(ClassInfo);
  3713.      END;
  3714.      ASM
  3715.         POP EDI
  3716.         POP ESI
  3717.         POP EDX
  3718.         POP ECX
  3719.         POP EBX
  3720.         POP EAX
  3721.         CMPB bo,1
  3722.         LEAVE
  3723.         RETN32 8
  3724.      END;
  3725. END;
  3726.  
  3727. PROCEDURE Check_Is_Class(c:TClass;ClassInfo:TClass);
  3728. VAR bo:BOOLEAN;
  3729. BEGIN
  3730.      ASM
  3731.         PUSH EAX
  3732.         PUSH EBX
  3733.         PUSH ECX
  3734.         PUSH EDX
  3735.         PUSH ESI
  3736.         PUSH EDI
  3737.      END;
  3738.      bo:=c.InheritsFrom(ClassInfo);
  3739.      ASM
  3740.         POP EDI
  3741.         POP ESI
  3742.         POP EDX
  3743.         POP ECX
  3744.         POP EBX
  3745.         POP EAX
  3746.         CMPB bo,1
  3747.         LEAVE
  3748.         RETN32 8
  3749.      END;
  3750. END;
  3751.  
  3752. PROCEDURE Check_As(o:TObject;ClassInfo:TClass);
  3753. VAR Adr:LONGINT;
  3754.     e:EInvalidCast;
  3755. BEGIN
  3756.      ASM
  3757.         PUSHAD
  3758.         MOV EAX,[EBP+4]
  3759.         SUB EAX,5
  3760.         MOV Adr,EAX
  3761.      END;
  3762.      IF not o.InheritsFrom(ClassInfo) THEN
  3763.      BEGIN
  3764.           e.Create('Invalid type cast (EInvalidCast)');
  3765.           e.CameFromRTL:=TRUE;
  3766.           e.RTLExcptAddr:=POINTER(Adr);
  3767.           raise e;
  3768.      END;
  3769.      ASM
  3770.         POPAD
  3771.         LEAVE
  3772.         RETN32 8
  3773.      END;
  3774. END;
  3775.  
  3776.  
  3777. PROCEDURE SelToFlat(VAR p:POINTER);
  3778. BEGIN
  3779.      asm
  3780.        mov edi,p
  3781.        mov eax,[edi+0]
  3782.        ror eax,16
  3783.        shr ax,3
  3784.        rol eax,16
  3785.        mov [edi+0],eax
  3786.     end;
  3787. END;
  3788.  
  3789.  
  3790. PROCEDURE OverflowError;
  3791. VAR e:EIntOverflow;
  3792.     Adr:LONGWORD;
  3793. BEGIN
  3794.      ASM
  3795.         MOV EAX,[EBP+4]
  3796.         SUB EAX,5
  3797.         MOV Adr,EAX
  3798.      END;
  3799.      e.Create('Integer Overflow (EIntOverflow)');
  3800.      e.CameFromRTL:=TRUE;
  3801.      e.RTLExcptAddr:=POINTER(Adr);
  3802.      Raise e;
  3803. END;
  3804.  
  3805. VAR MinStack:LONGWORD;
  3806.     StackSize:LONGWORD;
  3807.  
  3808. PROCEDURE StackError(Adr:LONGWORD);
  3809. VAR e:EStackFault;
  3810. BEGIN
  3811.      e.Create('Stack overflow (EStackFault)');
  3812.      e.CameFromRTL:=TRUE;
  3813.      e.RTLExcptAddr:=POINTER(Adr);
  3814.      Raise e;
  3815. END;
  3816.  
  3817. PROCEDURE CheckStack(Needed:LONGWORD);
  3818. VAR ESP1:LONGWORD;
  3819.     Adr:LONGWORD;
  3820. BEGIN
  3821.      ASM
  3822.         PUSHAD
  3823.         MOV ESP1,ESP
  3824.         MOV EAX,[EBP+4]
  3825.  
  3826.         SUB EAX,5
  3827.         MOV Adr,EAX
  3828.      END;
  3829.      IF ESP1>MinStack THEN IF ESP1<MinStack+StackSize THEN
  3830.      BEGIN
  3831.           IF ((ESP1-Needed<MinStack)OR(ESP1-Needed>MinStack+StackSize))
  3832.             THEN StackError(Adr);
  3833.      END;
  3834.      ASM
  3835.         POPAD
  3836.      END;
  3837. END;
  3838.  
  3839. PROCEDURE RangeCheckError(Adr:LONGWORD);
  3840. VAR e:ERangeError;
  3841. BEGIN
  3842.      e.Create('Range check error (ERangeError)');
  3843.      e.CameFromRTL:=TRUE;
  3844.      e.RTLExcptAddr:=POINTER(Adr);
  3845.      Raise e;
  3846. END;
  3847.  
  3848. PROCEDURE CheckRange(U,O,V:LONGINT);
  3849. VAR Adr:LONGWORD;
  3850. BEGIN
  3851.      ASM
  3852.         PUSH EAX
  3853.         MOV EAX,[EBP+4]
  3854.         SUB EAX,5
  3855.         MOV Adr,EAX
  3856.  
  3857.         MOV EAX,V
  3858.         CMP EAX,U
  3859.         JL !err_this_xxx
  3860.         MOV EAX,V
  3861.         CMP EAX,O
  3862.         JG !err_this_xxx
  3863.  
  3864.         POP EAX
  3865.         LEAVE
  3866.         RETN32 12
  3867. !err_this_xxx:
  3868.         POP EAX
  3869.         PUSH DWORD PTR Adr
  3870.         CALLN32 SYSTEM.RangeCheckError
  3871.      END;
  3872. END;
  3873.  
  3874. PROCEDURE CheckRangeUnsigned(U,O,V:LONGWORD);
  3875. VAR Adr:LONGWORD;
  3876. BEGIN
  3877.      ASM
  3878.         PUSH EAX
  3879.         MOV EAX,[EBP+4]
  3880.         SUB EAX,5
  3881.         MOV Adr,EAX
  3882.  
  3883.         MOV EAX,V
  3884.         CMP EAX,U
  3885.         JB !err_this_xxx1
  3886.         MOV EAX,V
  3887.         CMP EAX,O
  3888.         JA !err_this_xxx1
  3889.  
  3890.         POP EAX
  3891.         LEAVE
  3892.         RETN32 12
  3893. !err_this_xxx1:
  3894.         POP EAX
  3895.         PUSH DWORD PTR Adr
  3896.         CALLN32 SYSTEM.RangeCheckError
  3897.      END;
  3898. END;
  3899.  
  3900. PROCEDURE CheckRange2(Nr,V:LONGINT);
  3901. VAR Adr:LONGWORD;
  3902. BEGIN
  3903.      ASM
  3904.          PUSH EAX
  3905.          MOV EAX,[EBP+4]
  3906.          SUB EAX,5
  3907.          MOV Adr,EAX
  3908.  
  3909.          MOV EAX,Nr
  3910.          CMP EAX,1
  3911.          JNE !my_lab1
  3912.  
  3913.          MOV EAX,V
  3914.          CMP EAX,MINSHORTINT
  3915.          JL !err_this_xxx2
  3916.          CMP EAX,MAXSHORTINT
  3917.          JG !err_this_xxx2
  3918.          jmp !ex_this_xxx
  3919. !my_lab1:
  3920.          CMP EAX,2
  3921.          JNE !my_lab2
  3922.  
  3923.          MOV EAX,V
  3924.          CMP EAX,MININT
  3925.          JL !err_this_xxx2
  3926.          CMP EAX,MAXINT
  3927.          JG !err_this_xxx2
  3928.          jmp !ex_this_xxx
  3929. !my_lab2:
  3930.          CMP EAX,4
  3931.          JNE !ex_this_xxx
  3932.  
  3933.          MOV EAX,V
  3934.          CMP EAX,MINLONGINT
  3935.          JL !err_this_xxx2
  3936.          CMP EAX,MAXLONGINT
  3937.          JG !err_this_xxx2
  3938. !ex_this_xxx:
  3939.          POP EAX
  3940.          LEAVE
  3941.          RETN32 8
  3942. !err_this_xxx2:
  3943.          POP EAX
  3944.          PUSH DWORD PTR Adr
  3945.          CALLN32 SYSTEM.RangeCheckError
  3946.      END;
  3947. END;
  3948.  
  3949. PROCEDURE CheckRangeUnsigned2(Nr,V:LONGWORD);
  3950. VAR Adr:LONGWORD;
  3951. BEGIN
  3952.      ASM
  3953.          PUSH EAX
  3954.          MOV EAX,[EBP+4]
  3955.          SUB EAX,5
  3956.          MOV Adr,EAX
  3957.  
  3958.          MOV EAX,Nr
  3959.          CMP EAX,1
  3960.          JNE !my_lab1w
  3961.  
  3962.          MOV EAX,V
  3963.          CMP EAX,MINBYTE
  3964.          JB !err_this_xxx2w
  3965.          CMP EAX,MAXBYTE
  3966.          JA !err_this_xxx2w
  3967.          jmp !ex_this_xxxw
  3968. !my_lab1w:
  3969.          CMP EAX,2
  3970.          JNE !my_lab2w
  3971.  
  3972.          MOV EAX,V
  3973.          CMP EAX,MINWORD
  3974.          JB !err_this_xxx2w
  3975.          CMP EAX,MAXWORD
  3976.          JA !err_this_xxx2w
  3977.          jmp !ex_this_xxxw
  3978. !my_lab2w:
  3979.          CMP EAX,4
  3980.          JNE !ex_this_xxxw
  3981.  
  3982.          MOV EAX,V
  3983.          CMP EAX,MINLONGWORD
  3984.          JB !err_this_xxx2w
  3985.          CMP EAX,MAXLONGWORD
  3986.          JA !err_this_xxx2w
  3987. !ex_this_xxxw:
  3988.          POP EAX
  3989.          LEAVE
  3990.          RETN32 8
  3991. !err_this_xxx2w:
  3992.          POP EAX
  3993.          PUSH DWORD PTR Adr
  3994.          CALLN32 SYSTEM.RangeCheckError
  3995.      END;
  3996. END;
  3997.  
  3998. FUNCTION Swap(i:INTEGER):INTEGER;
  3999. BEGIN
  4000.      Swap:=lo(i)*256+hi(i);
  4001. END;
  4002.  
  4003. VAR
  4004.    MaxWindMin: WORD;    { Max Window upper left coordinates  }
  4005.    MaxWindMax: WORD;    { Max Window lower right coordinates }
  4006.    Redirect,RedirectOut,RedirectIn:BOOLEAN;
  4007.  
  4008. //PM routines
  4009.  
  4010. {$IFDEF OS2}
  4011. IMPORTS
  4012.   FUNCTION WinMessageBox(hwndParent,hwndOwner:LONGWORD;pszText,pszCaption:CSTRING;
  4013.                          idWindow,flStyle:LONGWORD):LONGWORD;
  4014.                           APIENTRY;             'PMWIN' index 789;
  4015. END;
  4016.  
  4017. FUNCTION WinInitialize(flOptions:LONGWORD):LONGWORD;
  4018. VAR tib:PTIB;
  4019.     pib:PPIB;
  4020. LABEL l;
  4021. BEGIN
  4022.      DosGetInfoBlocks(tib,pib);
  4023.      IF ((tib<>NIL)AND(tib^.tib_ptib2<>NIL)) THEN
  4024.      BEGIN
  4025.           IF tib^.tib_ptib2^.tib2_ultid=1 THEN goto l; {1st thread}
  4026.           result:=WinInitializeAPI(flOptions);
  4027.      END
  4028.      ELSE
  4029.      BEGIN
  4030. l:
  4031.           IF AppHandleIntern=0 THEN AppHandleIntern:=WinInitializeAPI(flOptions);
  4032.           result:=AppHandleIntern;
  4033.      END;
  4034. END;
  4035.  
  4036. FUNCTION WinTerminate(ahab:LONGWORD):BOOLEAN;
  4037. BEGIN
  4038.      IF ahab=AppHandleIntern THEN
  4039.      BEGIN
  4040.           WinTerminate:=FALSE;
  4041.           exit;
  4042.      END;
  4043.      WinTerminate:=WinTerminateAPI(ahab);
  4044. END;
  4045.  
  4046. FUNCTION WinCreateMsgQueue(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  4047. LABEL l;
  4048. BEGIN
  4049.      IF ahab=AppHandleIntern THEN
  4050.      BEGIN
  4051.          IF AppQueueHandleIntern<>0 THEN
  4052.          BEGIN
  4053.               IF cmsg<>0 THEN
  4054.               BEGIN
  4055.                    WinDestroyMsgQueueAPI(AppQueueHandleIntern);
  4056.                    goto l;
  4057.               END
  4058.               ELSE WinCreateMsgQueue:=AppQueueHandleIntern;
  4059.          END
  4060.          ELSE
  4061.          BEGIN
  4062. l:
  4063.               AppQueueHandleIntern:=WinCreateMsgQueueAPI(ahab,cmsg);
  4064.               result:=AppQueueHandleIntern;
  4065.          END;
  4066.      END
  4067.      ELSE result:=WinCreateMsgQueueAPI(ahab,cmsg);
  4068. END;
  4069.  
  4070. FUNCTION WinDestroyMsgQueue(ahmq:LONGWORD):BOOLEAN;
  4071. BEGIN
  4072.      IF ahmq=AppQueueHandleIntern THEN result:=FALSE
  4073.      ELSE result:=WinDestroyMsgQueueAPI(ahmq);
  4074. END;
  4075. {$ENDIF}
  4076.  
  4077. {$IFDEF WIN95}
  4078. VAR
  4079.    ExcptList:PExcptInfo;
  4080.    ExcptMutex:LONGWORD;
  4081.  
  4082.  
  4083. TYPE
  4084.     PCOORD=^COORD;
  4085.     COORD=RECORD
  4086.                 X:INTEGER;
  4087.                 Y:INTEGER;
  4088.     END;
  4089.  
  4090.     PSMALL_RECT=^SMALL_RECT;
  4091.     SMALL_RECT=RECORD
  4092.                      Left:INTEGER;
  4093.                      Top:INTEGER;
  4094.                      Right:INTEGER;
  4095.                      Bottom:INTEGER;
  4096.     END;
  4097.  
  4098.     PCONSOLE_SCREEN_BUFFER_INFO=^CONSOLE_SCREEN_BUFFER_INFO;
  4099.     CONSOLE_SCREEN_BUFFER_INFO=RECORD
  4100.                                      dwSize:COORD;
  4101.                                      dwCursorPosition:COORD;
  4102.                                      wAttributes:WORD;
  4103.                                      srWindow:SMALL_RECT;
  4104.                                      dwMaximumWindowSize:COORD;
  4105.     END;
  4106.  
  4107.     PCHAR_INFO=^CHAR_INFO;
  4108.     CHAR_INFO=RECORD
  4109.                     Char:RECORD
  4110.                        CASE Integer OF
  4111.                            1:(UniCodeChar:WORD);
  4112.                            2:(AsciiChar:CHAR);
  4113.                     END;
  4114.                     Attributes:WORD;
  4115.     END;
  4116.  
  4117. CONST
  4118.      ENABLE_PROCESSED_INPUT =$0001;
  4119.      ENABLE_LINE_INPUT      =$0002;
  4120.      ENABLE_ECHO_INPUT      =$0004;
  4121.      ENABLE_WINDOW_INPUT    =$0008;
  4122.      ENABLE_MOUSE_INPUT     =$0010;
  4123.  
  4124.      ENABLE_PROCESSED_OUTPUT    =$0001;
  4125.      ENABLE_WRAP_AT_EOL_OUTPUT  =$0002;
  4126.  
  4127. IMPORTS
  4128.        FUNCTION SetFilePointer(hFile:LONGWORD;lDistanceToMove:LONGINT;
  4129.                                VAR lpDistanceToMoveHigh:LONGINT;
  4130.                                dwMoveMethod:LONGWORD):LONGWORD;
  4131.                   APIENTRY;  'KERNEL32' name 'SetFilePointer';
  4132.        FUNCTION WriteFile(hFile:LONGWORD;CONST lpBuffer;nNumberOfBytesToWrite:LONGWORD;
  4133.                           VAR lpNumberOfBytesWritten:LONGWORD;
  4134.                           VAR lpOverlapped):LONGBOOL;
  4135.                   APIENTRY;  'KERNEL32' name 'WriteFile';
  4136.        FUNCTION ReadFile(hFile:LONGWORD;VAR lpBuffer;nNumberOfBytesToRead:LONGWORD;
  4137.                          VAR lpNumberOfBytesRead:LONGWORD;
  4138.                          VAR lpOverlapped):LONGBOOL;
  4139.                   APIENTRY;  'KERNEL32' name 'ReadFile';
  4140.        FUNCTION CreateFile(CONST lpFileName:CSTRING;dwDesiredAccess:LONGWORD;
  4141.                            dwShareMode:LONGWORD;VAR lpSecurityAttributes;
  4142.                            deCreationDisposition,dwFlagsAndAttributes:LONGWORD;
  4143.                            hTemplateFile:LONGWORD):LONGWORD;
  4144.                   APIENTRY;  'KERNEL32' name 'CreateFileA';
  4145.        FUNCTION CloseHandle(hObject:LONGWORD):LONGBOOL;
  4146.                   APIENTRY;  'KERNEL32' name 'CloseHandle';
  4147.        FUNCTION SetCurrentDirectory(CONST lpPathName:CSTRING):LONGBOOL;
  4148.                   APIENTRY;  'KERNEL32' name 'SetCurrentDirectoryA';
  4149.        FUNCTION GetCurrentDirectory(nBufferLength:LONGWORD;VAR lpBuffer:CSTRING):LONGWORD;
  4150.                   APIENTRY;  'KERNEL32' name 'GetCurrentDirectoryA';
  4151.        FUNCTION RemoveDirectory(CONST lpPathName:CSTRING):LONGBOOL;
  4152.                   APIENTRY;  'KERNEL32' name 'RemoveDirectoryA';
  4153.        FUNCTION CreateDirectory(CONST lpPathName:CSTRING;
  4154.                                 VAR lpSecurityAttributes):LONGBOOL;
  4155.                   APIENTRY;  'KERNEL32' name 'CreateDirectoryA';
  4156.        FUNCTION MoveFile(CONST lpExistingFileName,lpNewFileName:CSTRING):LONGBOOL;
  4157.                   APIENTRY;  'KERNEL32' name 'MoveFileA';
  4158.        FUNCTION DeleteFile(CONST lpFileName:CSTRING):LONGBOOL;
  4159.                   APIENTRY;  'KERNEL32' name 'DeleteFileA';
  4160.        FUNCTION SetEndOfFile(hFile:LONGWORD):LONGBOOL;
  4161.                   APIENTRY;  'KERNEL32' name 'SetEndOfFile';
  4162.        FUNCTION GetConsoleScreenBufferInfo(hConsoleOutput:LONGWORD;
  4163.                                     VAR lpConsoleScreenBufferInfo:CONSOLE_SCREEN_BUFFER_INFO):LONGBOOL;
  4164.              APIENTRY;  'KERNEL32' name 'GetConsoleScreenBufferInfo';
  4165.        FUNCTION FillConsoleOutputAttribute(hConsoleOutput:LONGWORD;wAttribute:WORD;
  4166.                                     nLength:LONGWORD;dwWriteCoord:LONGWORD;
  4167.                                     VAR lpNumberOfAttrsWritten:LONGWORD):LONGBOOL;
  4168.              APIENTRY;  'KERNEL32' name 'FillConsoleOutputAttribute';
  4169.        FUNCTION SetConsoleCursorPosition(hConsoleOutput:LONGWORD;dwCursorPosition:LONGWORD):LONGBOOL;
  4170.              APIENTRY;  'KERNEL32' name 'SetConsoleCursorPosition';
  4171.        FUNCTION GetStdHandle(nStdHandle:LONGWORD):LONGWORD;
  4172.                   APIENTRY;  'KERNEL32' name 'GetStdHandle';
  4173.        FUNCTION ReadConsoleOutputAttribute(hConsoleOutput:LONGWORD;VAR lpAttribute:WORD;
  4174.                                     nLength:LONGWORD;dwReadCoord:LONGWORD;
  4175.                                     VAR lpNumberOfAttrsRead:LONGWORD):LONGBOOL;
  4176.              APIENTRY;  'KERNEL32' name 'ReadConsoleOutputAttribute';
  4177.        FUNCTION SetConsoleMode(hConsoleHandle:LONGWORD;dwMode:LONGWORD):LONGBOOL;
  4178.              APIENTRY;  'KERNEL32' name 'SetConsoleMode';
  4179.        FUNCTION ScrollConsoleScreenBuffer(hConsoleOutput:LONGWORD;
  4180.                                    VAR lpScrollRectangle:SMALL_RECT;
  4181.                                    VAR lpClipRectangle:SMALL_RECT;
  4182.                                    dwDestinationOrigin:LONGWORD{COORD};
  4183.                                    CONST lpFill:CHAR_INFO):LONGBOOL;
  4184.              APIENTRY;  'KERNEL32' name 'ScrollConsoleScreenBufferA';
  4185.        FUNCTION WaitForSingleObject(hHandle:LONGWORD;dwMilliseconds:LONGWORD):LONGWORD;
  4186.                   APIENTRY;  'KERNEL32' name 'WaitForSingleObject';
  4187.        FUNCTION ReleaseMutex(hMutex:LONGWORD):LONGBOOL;
  4188.                   APIENTRY;  'KERNEL32' name 'ReleaseMutex';
  4189.        FUNCTION CreateMutex(VAR lpMutexAttributes;
  4190.                             bInitialOwner:LONGBOOL;CONST lpName:CSTRING):LONGWORD;
  4191.                   APIENTRY;  'KERNEL32' name 'CreateMutexA';
  4192.        FUNCTION SetUnhandledExceptionFilter(lpTopLevelFilter:POINTER):POINTER;
  4193.                   APIENTRY;  'KERNEL32' name 'SetUnhandledExceptionFilter';
  4194.        FUNCTION GetCurrentThreadId:LONGWORD;
  4195.                   APIENTRY;  'KERNEL32' name 'GetCurrentThreadId';
  4196.        PROCEDURE ExitProcess(RetCode:LONGWORD);
  4197.                              'KERNEL32' name 'ExitProcess';
  4198. END;
  4199.  
  4200. //************************************************************************
  4201. //
  4202. //
  4203. // Memory support management functions
  4204. //
  4205. //
  4206. //************************************************************************
  4207.  
  4208. IMPORTS
  4209.        FUNCTION GetLastError:LONGWORD;
  4210.                   APIENTRY;  'KERNEL32' name 'GetLastError';
  4211.        FUNCTION HeapCreate(flOptions:LONGWORD;dwInitialSize:LONGWORD;
  4212.                            dwMaximumSize:LONGWORD):POINTER;
  4213.                   APIENTRY;  'KERNEL32' name 'HeapCreate';
  4214.        FUNCTION HeapDestroy(hHeap:POINTER):LONGBOOL;
  4215.                   APIENTRY;  'KERNEL32' name 'HeapDestroy';
  4216.        FUNCTION GlobalAlloc(uFlags:LONGWORD;dwBytes:LONGWORD):POINTER;
  4217.                   APIENTRY;  'KERNEL32' name 'GlobalAlloc';
  4218.        FUNCTION GlobalFree(hMem:POINTER):POINTER;
  4219.                   APIENTRY;  'KERNEL32' name 'GlobalFree';
  4220.        FUNCTION HeapAlloc(hHeap:POINTER;dwFlags,dwBytes:LONGWORD):POINTER;
  4221.                   APIENTRY;  'KERNEL32' name 'HeapAlloc';
  4222.        FUNCTION HeapFree(hHeap:POINTER;dwFlags:LONGWORD;lpMem:POINTER):LONGBOOL;
  4223.                   APIENTRY;  'KERNEL32' name 'HeapFree';
  4224.        PROCEDURE GetSystemTime(VAR lpSystemTime);
  4225.                   APIENTRY;  'KERNEL32' name 'GetSystemTime';
  4226.        FUNCTION GetMessage(VAR lpMsg;ahwnd,wMsgFilterMin,wMsgFilterMax:LONGWORD):LONGBOOL;
  4227.                 APIENTRY; 'USER32' name 'GetMessageA';
  4228.        FUNCTION DispatchMessage(VAR lpMsg):LONGINT;
  4229.                 APIENTRY; 'USER32' name 'DispatchMessageA';
  4230. END;
  4231. {$ENDIF}
  4232.  
  4233. //Exception management
  4234.  
  4235.  
  4236. {The standard exception class}
  4237. FUNCTION SysException.GetMessage:STRING;
  4238. BEGIN
  4239.      GetMessage:=FMessage^;
  4240. END;
  4241.  
  4242. PROCEDURE SysException.SetMessage(CONST Value:STRING);
  4243. BEGIN
  4244.      IF FMessage<>NIL THEN
  4245.        FreeMem(FMessage,length(FMessage^)+1);
  4246.      GetMem(FMessage,length(value)+1);
  4247.      FMessage^:=value;
  4248. END;
  4249.  
  4250. CONSTRUCTOR SysException.Create(CONST msg:STRING);
  4251. BEGIN
  4252.      Inherited Create;
  4253.  
  4254.      Message:=msg;
  4255. END;
  4256.  
  4257. DESTRUCTOR SysException.Destroy;
  4258. BEGIN
  4259.      IF FMessage<>NIL THEN
  4260.        FreeMem(FMessage,length(FMessage^)+1);
  4261.      Inherited Destroy;
  4262. END;
  4263.  
  4264. PROCEDURE Abort;
  4265. BEGIN
  4266.      RAISE EAbort.Create('');
  4267. END;
  4268.  
  4269. {$IFDEF OS2}
  4270. //OS2 Exception numbers
  4271. CONST
  4272.      XCPT_GUARD_PAGE_VIOLATION       =$80000001;
  4273.      XCPT_DATATYPE_MISALIGNMENT      =$C000009E;
  4274.      XCPT_BREAKPOINT                 =$C000009F;
  4275.      XCPT_SINGLE_STEP                =$C00000A0;
  4276.      XCPT_ACCESS_VIOLATION           =$C0000005;
  4277.      XCPT_ILLEGAL_INSTRUCTION        =$C000001C;
  4278.      XCPT_FLOAT_DENORMAL_OPERAND     =$C0000094;
  4279.      XCPT_FLOAT_DIVIDE_BY_ZERO       =$C0000095;
  4280.      XCPT_FLOAT_INEXACT_RESULT       =$C0000096;
  4281.      XCPT_FLOAT_INVALID_OPERATION    =$C0000097;
  4282.      XCPT_FLOAT_OVERFLOW             =$C0000098;
  4283.      XCPT_FLOAT_STACK_CHECK          =$C0000099;
  4284.      XCPT_FLOAT_UNDERFLOW            =$C000009A;
  4285.      XCPT_INTEGER_DIVIDE_BY_ZERO     =$C000009B;
  4286.      XCPT_INTEGER_OVERFLOW           =$C000009C;
  4287.      XCPT_PRIVILEGED_INSTRUCTION     =$C000009D;
  4288.      XCPT_IN_PAGE_ERROR              =$C0000006;
  4289.      XCPT_PROCESS_TERMINATE          =$C0010001;
  4290.      XCPT_ASYNC_PROCESS_TERMINATE    =$C0010002;
  4291.      XCPT_NONCONTINUABLE_EXCEPTION   =$C0000024;
  4292.      XCPT_INVALID_DISPOSITION        =$C0000025;
  4293.      XCPT_INVALID_LOCK_SEQUENCE      =$C000001D;
  4294.      XCPT_ARRAY_BOUNDS_EXCEEDED      =$C0000093;
  4295.      XCPT_B1NPX_ERRATA_02            =$C0010004;
  4296.      XCPT_UNWIND                     =$C0000026;
  4297.      XCPT_BAD_STACK                  =$C0000027;
  4298.      XCPT_INVALID_UNWIND_TARGET      =$C0000028;
  4299.      XCPT_SIGNAL                     =$C0010003;
  4300.  
  4301.      XCPT_INTERNAL_RTL               =$E0000000;
  4302.  
  4303. {return values}
  4304. CONST
  4305.      XCPT_CONTINUE_SEARCH    =$00000000;     { exception not handled   }
  4306.      XCPT_CONTINUE_EXECUTION =$FFFFFFFF;     { exception handled       }
  4307.      XCPT_CONTINUE_STOP      =$00716668;     { exception handled by    }
  4308.                                              { debugger (VIA DosDebug) }
  4309.  
  4310. VAR
  4311.    RegisterInfo:STRING;
  4312.  
  4313. {$HINTS OFF}
  4314. {The exception handler. Incoming exceptions will come here first}
  4315. FUNCTION ExcptHandler(VAR p1:EXCEPTIONREPORTRECORD;
  4316.                       VAR p2:EXCEPTIONREGISTRATIONRECORD;
  4317.                       VAR p3:CONTEXTRECORD;
  4318.                       pv:POINTER):LONGWORD;CDECL;
  4319. BEGIN
  4320.      {Jump to the label set by setjmp}
  4321.      WITH p3 DO
  4322.        Registerinfo:= #13#10'at CS:EIP  ='+
  4323.                       ToHex(ctx_SegCs )+':'+ToHex(ctx_RegEip);
  4324.  
  4325.  
  4326.      IF POINTER(p2.ObjectType)=NIL THEN {no object associated}
  4327.      BEGIN
  4328.           //Handle all hardware exceptions
  4329.           //all other exceptions will be notified by an exception class
  4330.           CASE p1.ExceptionNum OF
  4331.               XCPT_BREAKPOINT:
  4332.                 p2.ObjectType:=EBreakPoint.Create('Breakpoint exception (EBreakPoint) occured'+
  4333.                                                   RegisterInfo);
  4334.               XCPT_BAD_STACK:
  4335.                 p2.ObjectType:=EStackFault.Create('Stack fault exception (EStackFault) occured'+
  4336.                                                   RegisterInfo);
  4337.               XCPT_ACCESS_VIOLATION:
  4338.                 p2.ObjectType:=EGPFault.Create('Access violation exception (EGPFault) occured'+
  4339.                                                RegisterInfo);
  4340.               XCPT_IN_PAGE_ERROR:
  4341.                 p2.ObjectType:=EPageFault.Create('Page fault exception (EPageFault) occured'+
  4342.                                                  RegisterInfo);
  4343.               XCPT_ILLEGAL_INSTRUCTION,XCPT_PRIVILEGED_INSTRUCTION:
  4344.                 p2.ObjectType:=EInvalidOpCode.Create('Invalid instruction exception (EInvalidOpCode) occured'+
  4345.                                                      RegisterInfo);
  4346.               XCPT_SINGLE_STEP:
  4347.                 p2.ObjectType:=ESingleStep.Create('Single step exception (ESingleStep) occured'+
  4348.                                                   RegisterInfo);
  4349.               XCPT_INTEGER_DIVIDE_BY_ZERO:
  4350.                 p2.ObjectType:=EDivByZero.Create('Integer divide by zero exception (EDivByZero) occured'+
  4351.                                                  RegisterInfo);
  4352.               XCPT_INTEGER_OVERFLOW:
  4353.                 p2.ObjectType:=EIntOverFlow.Create('Integer overflow exception (EIntOverFlow) occured'+
  4354.                                                    RegisterInfo);
  4355.               XCPT_FLOAT_DIVIDE_BY_ZERO:
  4356.                 p2.ObjectType:=EZeroDivide.Create('Float zero divide exception (EZeroDivide) occured'+
  4357.                                                   RegisterInfo);
  4358.               XCPT_FLOAT_INVALID_OPERATION:
  4359.                 p2.ObjectType:=EInvalidOp.Create('Float invalid operation exception (EInvalidOp) occured'+
  4360.                                                  RegisterInfo);
  4361.               XCPT_FLOAT_OVERFLOW:
  4362.                 p2.ObjectType:=EOverFlow.Create('Float overflow exception (EOverFlow) occured'+
  4363.                                                 RegisterInfo);
  4364.               XCPT_FLOAT_UNDERFLOW:
  4365.                 p2.ObjectType:=EUnderFlow.Create('Float underflow exception (EUnderFlow) occured'+
  4366.                                                  RegisterInfo);
  4367.               XCPT_FLOAT_DENORMAL_OPERAND,XCPT_FLOAT_INEXACT_RESULT,
  4368.               XCPT_FLOAT_STACK_CHECK:
  4369.                  p2.ObjectType:=EMathError.Create('General float exception (EMathError) occured'+
  4370.                                                   RegisterInfo);
  4371.               XCPT_PROCESS_TERMINATE: {don't handle}
  4372.               BEGIN
  4373.                    {p2.ObjectType:=EProcessTerm.Create('Process terminated exception (EProcessTerm) occured');}
  4374.                    {}ExcptHandler:=XCPT_CONTINUE_SEARCH;
  4375.                    exit;{}
  4376.               END;
  4377.               XCPT_ASYNC_PROCESS_TERMINATE:  {Don't handle}
  4378.               BEGIN
  4379.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  4380.                    exit;
  4381.               END;
  4382.               XCPT_GUARD_PAGE_VIOLATION: {Don't handle}
  4383.               BEGIN
  4384.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  4385.                    exit;
  4386.               END;
  4387.               XCPT_ARRAY_BOUNDS_EXCEEDED:
  4388.                  p2.ObjectType:=ERangeError.Create('Range check error exception (ERangeError) occured'+
  4389.                                                  RegisterInfo);
  4390.               XCPT_INTERNAL_RTL:
  4391.               BEGIN
  4392.                    ExcptHandler:=XCPT_CONTINUE_EXECUTION;
  4393.                    exit;
  4394.               END;
  4395.               ELSE  {Don't handle}
  4396.               BEGIN
  4397.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  4398.                    exit;
  4399.                    {p2.ObjectType:=EFault.Create('Unknown hardware exception (EFault) occured');}
  4400.               END;
  4401.           END; {case}
  4402.      END;
  4403.      p2.ObjectType.ReportRecord:=p1;
  4404.      p2.ObjectType.RegistrationRecord:=p2;
  4405.      p2.ObjectType.ExcptNum:=p1.ExceptionNum;
  4406.      p2.ObjectType.ExcptAddr:=POINTER(p3.ctx_RegEIP);
  4407.      p2.ObjectType.ContextRecord:=p3;
  4408.      longjmp(p2.jmpWorker,LONGWORD(p2.ObjectType));
  4409. END;
  4410. {$HINTS ON}
  4411.  
  4412. IMPORTS
  4413.      FUNCTION DosRaiseException(VAR Pexcept:EXCEPTIONREPORTRECORD):LONGWORD;
  4414.                    APIENTRY;             'DOSCALLS' index 356;
  4415. END;
  4416.  
  4417. VAR ExceptDebugText:STRING;
  4418.  
  4419. PROCEDURE InitPM;
  4420. Begin
  4421.      If AppHandleIntern=0 Then If ApplicationType=1 Then
  4422.      Begin
  4423.           AppHandleIntern:=WinInitialize(0);
  4424.           AppQueueHandleIntern:=WinCreateMsgQueue(AppHandleIntern,0);
  4425.      End;
  4426. End;
  4427.  
  4428. PROCEDURE ExcptRunError(e:SysException);
  4429. VAR
  4430.    s:STRING;
  4431.    cs:CSTRING;
  4432.    cTitle:CSTRING;
  4433.    RepRec:EXCEPTIONREPORTRECORD;
  4434. BEGIN
  4435.      TRY
  4436.         IF e.CameFromRTL THEN IF not e.Nested THEN
  4437.         BEGIN
  4438.              e.Nested:=TRUE;
  4439.              RepRec.ExceptionNum:=XCPT_INTERNAL_RTL;
  4440.              RepRec.fHandlerFlags:=0;
  4441.              RepRec.NestedExceptionReportRecord:=NIL;
  4442.              RepRec.ExceptionAddress:=NIL;
  4443.              RepRec.cParameters:=2;
  4444.              RepRec.ExceptionInfo[0]:=LONGWORD(e.RTLExcptAddr);
  4445.              RepRec.ExceptionInfo[1]:=LONGWORD(e.FMessage);
  4446.              ExceptDebugText:=e.ClassName;
  4447.              RepRec.ExceptionInfo[2]:=LONGWORD(@ExceptDebugText);
  4448.              DosRaiseException(RepRec);
  4449.         END;
  4450.      FINALLY
  4451.         e.ExcptAddr:=e.RTLExcptAddr;
  4452.      END;
  4453.  
  4454.      IF POINTER(e.ExcptAddr)<>NIL THEN
  4455.        s:='Exception occured: '+e.Message+' at '+tohex(LONGWORD(e.ExcptAddr))+
  4456.            #13#10'Program is terminated.'
  4457.      ELSE
  4458.        s:='Exception occured: '+e.Message+
  4459.            #13#10'Program is terminated.';
  4460.  
  4461.      IF ApplicationType=1 THEN
  4462.      BEGIN
  4463.           cs:=s;
  4464.           cTitle:='Exception occured';
  4465.           InitPM;
  4466.           WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  4467.      END
  4468.      ELSE Writeln(s);
  4469.      Halt;
  4470. END;
  4471.  
  4472. PROCEDURE RaiseException(objekt:SysException;adress:LONGWORD);
  4473. VAR
  4474.    PRegisRec:PEXCEPTIONREGISTRATIONRECORD;  {top exception registration record}
  4475.    ReportRec:EXCEPTIONREPORTRECORD;
  4476.    ContextRec:CONTEXTRECORD;
  4477.    RepRec:EXCEPTIONREPORTRECORD;
  4478. BEGIN
  4479.      ASM
  4480.         MOV ESI,0
  4481.         db $64   //SEG FS
  4482.         MOV EAX,[ESI+0]
  4483.         MOV PRegisRec,EAX
  4484.      END;
  4485.  
  4486.      IF LONGWORD(PRegisRec)=$ffffffff THEN {no handler installed}
  4487.      BEGIN
  4488.           ExcptRunError(objekt);
  4489.      END;
  4490.  
  4491.      PRegisRec^.ObjectType:=objekt;  {set exception type}
  4492.      {set up context record}
  4493.      fillchar(ContextRec,sizeof(CONTEXTRECORD),0);
  4494.      {set up report record}
  4495.      fillchar(ReportRec,sizeof(EXCEPTIONREPORTRECORD),0);
  4496.      IF Adress=0 THEN
  4497.      BEGIN
  4498.           ASM
  4499.              MOV EAX,[EBP+4]
  4500.              MOV Adress,EAX
  4501.           END;
  4502.      END;
  4503.  
  4504.      {Objekt.Nested:=TRUE;}
  4505.      {Objekt.CameFromRTL:=TRUE;}
  4506.      Objekt.RTLExcptAddr:=POINTER(Adress);
  4507.      RepRec.ExceptionNum:=XCPT_INTERNAL_RTL;
  4508.      RepRec.fHandlerFlags:=0;
  4509.      RepRec.NestedExceptionReportRecord:=NIL;
  4510.      RepRec.ExceptionAddress:=NIL;
  4511.      RepRec.cParameters:=2;
  4512.      RepRec.ExceptionInfo[0]:=LONGWORD(Objekt.RTLExcptAddr);
  4513.      RepRec.ExceptionInfo[1]:=LONGWORD(Objekt.FMessage);
  4514.      ExceptDebugText:=Objekt.ClassName;
  4515.      RepRec.ExceptionInfo[2]:=LONGWORD(@ExceptDebugText);
  4516.      DosRaiseException(RepRec);
  4517.  
  4518.      ReportRec.ExceptionAddress:=POINTER(Adress);
  4519.      ExcptHandler(ReportRec,PRegisRec^,ContextRec,NIL);
  4520. END;
  4521.  
  4522. PROCEDURE FreeExceptInstance(e:SysException);
  4523. BEGIN
  4524.      IF e<>NIL THEN e.Free;
  4525. END;
  4526.  
  4527. PROCEDURE RaiseExceptionAgain(e:SysException);
  4528. VAR
  4529.    PRegisRec:PEXCEPTIONREGISTRATIONRECORD;  {top exception registration record}
  4530. BEGIN
  4531.      IF ((e=NIL)OR(e is EAbort)) THEN exit;
  4532.      ASM
  4533.         MOV ESI,0
  4534.         db $64   //SEG FS
  4535.         MOV EAX,[ESI+0]
  4536.         MOV PRegisRec,EAX
  4537.      END;
  4538.      IF LONGWORD(PRegisRec)=$ffffffff THEN {no handler installed}
  4539.      BEGIN
  4540.           ExcptRunError(e);
  4541.      END;
  4542.      PRegisRec^.ObjectType:=e;  {set exception type}
  4543.      ExcptHandler(e.ReportRecord,PRegisRec^,e.ContextRecord,NIL);
  4544. END;
  4545.  
  4546. PROCEDURE Beep(Freq,duration:LONGWORD);
  4547. BEGIN
  4548.      ASM
  4549.          PUSH DWORD PTR duration
  4550.          PUSH DWORD PTR freq
  4551.          MOV AL,2
  4552.          CALLDLL DOSCALLS,286  //DosBeep
  4553.          ADD ESP,8
  4554.      END;
  4555. END;
  4556. {$ENDIF}
  4557. {$IFDEF WIN95}
  4558. //Win95 Exception numbers
  4559.  
  4560. CONST
  4561.      STATUS_WAIT_0                    =$00000000;
  4562.      STATUS_ABANDONED_WAIT_0          =$00000080;
  4563.      STATUS_USER_APC                  =$000000C0;
  4564.      STATUS_TIMEOUT                   =$00000102;
  4565.      STATUS_PENDING                   =$00000103;
  4566.      STATUS_GUARD_PAGE_VIOLATION      =$80000001;
  4567.      STATUS_DATATYPE_MISALIGNMENT     =$80000002;
  4568.      STATUS_BREAKPOINT                =$80000003;
  4569.      STATUS_SINGLE_STEP               =$80000004;
  4570.      STATUS_ACCESS_VIOLATION          =$C0000005;
  4571.      STATUS_IN_PAGE_ERROR             =$C0000006;
  4572.      STATUS_NO_MEMORY                 =$C0000017;
  4573.      STATUS_ILLEGAL_INSTRUCTION       =$C000001D;
  4574.      STATUS_NONCONTINUABLE_EXCEPTION  =$C0000025;
  4575.      STATUS_INVALID_DISPOSITION       =$C0000026;
  4576.      STATUS_ARRAY_BOUNDS_EXCEEDED     =$C000008C;
  4577.      STATUS_FLOAT_DENORMAL_OPERAND    =$C000008D;
  4578.      STATUS_FLOAT_DIVIDE_BY_ZERO      =$C000008E;
  4579.      STATUS_FLOAT_INEXACT_RESULT      =$C000008F;
  4580.      STATUS_FLOAT_INVALID_OPERATION   =$C0000090;
  4581.      STATUS_FLOAT_OVERFLOW            =$C0000091;
  4582.      STATUS_FLOAT_STACK_CHECK         =$C0000092;
  4583.      STATUS_FLOAT_UNDERFLOW           =$C0000093;
  4584.      STATUS_INTEGER_DIVIDE_BY_ZERO    =$C0000094;
  4585.      STATUS_INTEGER_OVERFLOW          =$C0000095;
  4586.      STATUS_PRIVILEGED_INSTRUCTION    =$C0000096;
  4587.      STATUS_STACK_OVERFLOW            =$C00000FD;
  4588.      STATUS_CONTROL_C_EXIT            =$C000013A;
  4589.  
  4590. CONST
  4591.      EXCEPTION_ACCESS_VIOLATION     =STATUS_ACCESS_VIOLATION;
  4592.      EXCEPTION_DATATYPE_MISALIGNMENT=STATUS_DATATYPE_MISALIGNMENT;
  4593.      EXCEPTION_BREAKPOINT           =STATUS_BREAKPOINT;
  4594.      EXCEPTION_SINGLE_STEP          =STATUS_SINGLE_STEP;
  4595.      EXCEPTION_ARRAY_BOUNDS_EXCEEDED=STATUS_ARRAY_BOUNDS_EXCEEDED;
  4596.      EXCEPTION_FLT_DENORMAL_OPERAND =STATUS_FLOAT_DENORMAL_OPERAND;
  4597.      EXCEPTION_FLT_DIVIDE_BY_ZERO   =STATUS_FLOAT_DIVIDE_BY_ZERO;
  4598.      EXCEPTION_FLT_INEXACT_RESULT   =STATUS_FLOAT_INEXACT_RESULT;
  4599.      EXCEPTION_FLT_INVALID_OPERATION=STATUS_FLOAT_INVALID_OPERATION;
  4600.      EXCEPTION_FLT_OVERFLOW         =STATUS_FLOAT_OVERFLOW;
  4601.      EXCEPTION_FLT_STACK_CHECK      =STATUS_FLOAT_STACK_CHECK;
  4602.      EXCEPTION_FLT_UNDERFLOW        =STATUS_FLOAT_UNDERFLOW;
  4603.      EXCEPTION_INT_DIVIDE_BY_ZERO   =STATUS_INTEGER_DIVIDE_BY_ZERO;
  4604.      EXCEPTION_INT_OVERFLOW         =STATUS_INTEGER_OVERFLOW;
  4605.      EXCEPTION_PRIV_INSTRUCTION     =STATUS_PRIVILEGED_INSTRUCTION;
  4606.      EXCEPTION_IN_PAGE_ERROR        =STATUS_IN_PAGE_ERROR;
  4607.      EXCEPTION_ILLEGAL_INSTRUCTION  =STATUS_ILLEGAL_INSTRUCTION;
  4608.      EXCEPTION_NONCONTINUABLE_EXCEPTION=STATUS_NONCONTINUABLE_EXCEPTION;
  4609.      EXCEPTION_STACK_OVERFLOW       =STATUS_STACK_OVERFLOW;
  4610.      EXCEPTION_INVALID_DISPOSITION  =STATUS_INVALID_DISPOSITION;
  4611.      EXCEPTION_GUARD_PAGE           =STATUS_GUARD_PAGE_VIOLATION;
  4612.      CONTROL_C_EXIT                 =STATUS_CONTROL_C_EXIT;
  4613.                                              { debugger (VIA DosDebug) }
  4614.  
  4615.      EXCEPTION_INTERNAL_RTL         =$E0000000;
  4616.  
  4617. {return values}
  4618. CONST
  4619.      EXCEPTION_EXECUTE_HANDLER       = 1;
  4620.      EXCEPTION_CONTINUE_SEARCH       = 0;
  4621.      EXCEPTION_CONTINUE_EXECUTION    =-1;
  4622.  
  4623. VAR
  4624.    RegisterInfo:STRING;
  4625.  
  4626.  
  4627.  
  4628. PROCEDURE NewExceptionFilter(ExcptInfo:PExcptInfo);
  4629. VAR Dummy:PExcptInfo;
  4630. BEGIN
  4631.      ExcptInfo^.Next:=NIL;
  4632.      ExcptInfo^.ExcptObject:=NIL;
  4633.      ASM
  4634.         MOV EDI,ExcptInfo
  4635.         ADD EDI,8
  4636.         MOV EAX,[EBP+0]     //old EBP
  4637.         MOV [EDI+0],EAX
  4638.         MOV EAX,EBP
  4639.         ADD EAX,12         //Old ESP
  4640.         MOV [EDI+4],EAX
  4641.         FSTCW [EDI+8]      //Old FPU Control
  4642.      END;
  4643.  
  4644.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  4645.  
  4646.      IF ExcptList=NIL THEN
  4647.      BEGIN
  4648.           ExcptList:=ExcptInfo;
  4649.           ExcptList^.Last:=NIL;
  4650.      END
  4651.      ELSE
  4652.      BEGIN
  4653.           dummy:=ExcptList;
  4654.           WHILE dummy^.next<>NIL DO dummy:=dummy^.Next;
  4655.           dummy^.Next:=ExcptInfo;
  4656.           dummy^.Next^.Last:=Dummy;
  4657.      END;
  4658.  
  4659.      ReleaseMutex(ExcptMutex);
  4660. END;
  4661.  
  4662. PROCEDURE ReleaseExceptionFilter(ExcptInfo:PExcptInfo);
  4663. VAR Dummy:PExcptInfo;
  4664. LABEL l;
  4665. BEGIN
  4666.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  4667.  
  4668.      dummy:=ExcptList;
  4669.      WHILE dummy<>NIL DO
  4670.      BEGIN
  4671.           IF dummy=ExcptInfo THEN
  4672.           BEGIN
  4673.                IF dummy^.Last=NIL THEN
  4674.                BEGIN
  4675.                     ExcptList:=dummy^.Next;
  4676.                     IF ExcptList<>NIL THEN ExcptList^.Last:=NIL;
  4677.                END
  4678.                ELSE
  4679.                BEGIN
  4680.                     IF dummy^.Next<>NIL THEN
  4681.                         dummy^.Next^.Last:=dummy^.Last;
  4682.                     dummy^.Last^.Next:=dummy^.Next;
  4683.                END;
  4684.                goto l;
  4685.           END;
  4686.           dummy:=dummy^.Next;
  4687.      END;
  4688. l:
  4689.      ReleaseMutex(ExcptMutex);
  4690. END;
  4691.  
  4692. {The exception handler. Incoming exceptions will come here first}
  4693. FUNCTION ExcptHandler(VAR ExceptionInfo:EXCEPTION_POINTERS):LONGINT;APIENTRY;
  4694. VAR Dummy:PExcptInfo;
  4695.     ExcptAddr:POINTER;
  4696.     Found:PExcptInfo;
  4697.     ThreadId:LONGWORD;
  4698. LABEL l,l1;
  4699. BEGIN
  4700.      IF ExcptList=NIL THEN
  4701.      BEGIN
  4702. l:
  4703.           result:=EXCEPTION_CONTINUE_SEARCH;  //terminate process
  4704.           exit;
  4705.      END
  4706.      ElSE
  4707.      BEGIN
  4708.           IF ExceptionInfo.ExceptionRecord^.ExceptionFlags=EXCEPTION_NONCONTINUABLE
  4709.             THEN goto l; {dont handle}
  4710.  
  4711.           ThreadId:=GetCurrentThreadId;
  4712.  
  4713.           {Search exception handler}
  4714.           WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  4715.  
  4716.           ExcptAddr:=ExceptionInfo.ExceptionRecord^.ExceptionAddress;
  4717.  
  4718.           dummy:=ExcptList;
  4719.           WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  4720.           Found:=NIL;
  4721.           WHILE dummy<>NIL DO
  4722.           BEGIN
  4723.                {IF LONGWORD(ExcptAddr)>=LONGWORD(dummy^.TryAddr) THEN
  4724.                  IF LONGWORD(ExcptAddr)<=LONGWORD(dummy^.ExcptAddr) THEN
  4725.                    Found:=dummy;}
  4726.                IF dummy^.ThreadId=ThreadId THEN
  4727.                BEGIN
  4728.                     Found:=dummy;
  4729.                     goto l1;
  4730.                END;
  4731.  
  4732.                dummy:=dummy^.Last;
  4733.           END;
  4734. l1:
  4735.           IF Found=NIL THEN
  4736.             IF ExcptList<>NIL THEN Found:=ExcptList;
  4737.  
  4738.           ReleaseMutex(ExcptMutex);
  4739.  
  4740.           IF Found=NIL THEN goto l;
  4741.  
  4742.           Registerinfo:= #13#10'at CS:EIP  ='+
  4743.                     ToHex(LONGWORD(ExceptionInfo.ContextRecord^.SegCS))+':'
  4744.                     +ToHex(LONGWORD(ExcptAddr));
  4745.      END;
  4746.  
  4747.      //Handle all hardware exceptions
  4748.      //all other exceptions will be notified by an exception class
  4749.      CASE ExceptionInfo.ExceptionRecord^.ExceptionCode OF
  4750.               EXCEPTION_BREAKPOINT:
  4751.                 Found^.ExcptObject:=EBreakPoint.Create('Breakpoint exception (EBreakPoint) occured'+
  4752.                                                   RegisterInfo);
  4753.               EXCEPTION_STACK_OVERFLOW:
  4754.                 Found^.ExcptObject:=EStackFault.Create('Stack fault exception (EStackFault) occured'+
  4755.                                                   RegisterInfo);
  4756.               EXCEPTION_ACCESS_VIOLATION:
  4757.                 Found^.ExcptObject:=EGPFault.Create('Access violation exception (EGPFault) occured'+
  4758.                                                RegisterInfo);
  4759.               EXCEPTION_IN_PAGE_ERROR:
  4760.                 Found^.ExcptObject:=EPageFault.Create('Page fault exception (EPageFault) occured'+
  4761.                                                  RegisterInfo);
  4762.               EXCEPTION_ILLEGAL_INSTRUCTION,EXCEPTION_PRIV_INSTRUCTION:
  4763.                 Found^.ExcptObject:=EInvalidOpCode.Create('Invalid instruction exception (EInvalidOpCode) occured'+
  4764.                                                  RegisterInfo);
  4765.               EXCEPTION_SINGLE_STEP:
  4766.                 Found^.ExcptObject:=ESingleStep.Create('Single step exception (ESingleStep) occured'+
  4767.                                                  RegisterInfo);
  4768.               EXCEPTION_INT_DIVIDE_BY_ZERO:
  4769.                 Found^.ExcptObject:=EDivByZero.Create('Integer divide by zero exception (EDivByZero) occured'+
  4770.                                                  RegisterInfo);
  4771.               EXCEPTION_INT_OVERFLOW:
  4772.                 Found^.ExcptObject:=EIntOverFlow.Create('Integer overflow exception (EIntOverFlow) occured'+
  4773.                                                  RegisterInfo);
  4774.               EXCEPTION_FLT_DIVIDE_BY_ZERO:
  4775.                 Found^.ExcptObject:=EZeroDivide.Create('Float zero divide exception (EZeroDivide) occured'+
  4776.                                                  RegisterInfo);
  4777.               EXCEPTION_FLT_INVALID_OPERATION:
  4778.                 Found^.ExcptObject:=EInvalidOp.Create('Float invalid operation exception (EInvalidOp) occured'+
  4779.                                                  RegisterInfo);
  4780.               EXCEPTION_FLT_OVERFLOW:
  4781.                 Found^.ExcptObject:=EOverFlow.Create('Float overflow exception (EOverFlow) occured'+
  4782.                                                  RegisterInfo);
  4783.               EXCEPTION_FLT_UNDERFLOW:
  4784.                 Found^.ExcptObject:=EUnderFlow.Create('Float underflow exception (EUnderFlow) occured'+
  4785.                                                  RegisterInfo);
  4786.               EXCEPTION_FLT_DENORMAL_OPERAND,EXCEPTION_FLT_INEXACT_RESULT,
  4787.               EXCEPTION_FLT_STACK_CHECK:
  4788.                  Found^.ExcptObject:=EMathError.Create('General float exception (EMathError) occured'+
  4789.                                                  RegisterInfo);
  4790.               EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
  4791.                  Found^.ExcptObject:=ERangeError.Create('Range check error exception (ERangeError) occured'+
  4792.                                                  RegisterInfo);
  4793.               EXCEPTION_INTERNAL_RTL:
  4794.               BEGIN
  4795.                    //Found^.ExcptObject already set !
  4796.                    //result:=EXCEPTION_CONTINUE_EXECUTION;
  4797.                    //exit;
  4798.               END;
  4799.               ELSE goto l; {Don't handle}
  4800.      END; {case}
  4801.  
  4802.      {Win95 generated exception}
  4803.      Found^.ExcptObject.ReportRecord:=ExceptionInfo.ExceptionRecord^;
  4804.      Found^.ExcptObject.ExcptNum:=ExceptionInfo.ExceptionRecord^.ExceptionCode;
  4805.      Found^.ExcptObject.ContextRecord:=ExceptionInfo.ContextRecord^;
  4806.      Found^.ExcptObject.ExcptAddr:=ExcptAddr;
  4807.  
  4808.      {Jump to the label set by try}
  4809.      ExceptionInfo.ContextRecord^.EAX:=LONGWORD(Found^.ExcptObject);
  4810.      ExceptionInfo.ContextRecord^.EIP:=LONGWORD(Found^.ExcptAddr);
  4811.      ExceptionInfo.ContextRecord^.EBP:=Found^.OldEBP;
  4812.      ExceptionInfo.ContextRecord^.ESP:=Found^.OldESP;
  4813.      ExceptionInfo.ContextRecord^.FloatSave.ControlWord:=Found^.OldFPUControl;
  4814.      result:=EXCEPTION_CONTINUE_EXECUTION;  //run except handling
  4815. END;
  4816.  
  4817. IMPORTS
  4818.      PROCEDURE RaiseExceptionAPI(dwExceptionCode,dwExceptionFlags:LONGWORD;
  4819.                               nNumberOfArguments:LONGWORD;VAR lpArguments);
  4820.                   APIENTRY;  'KERNEL32' name 'RaiseException';
  4821.     FUNCTION MessageBox(ahwnd:LONGWORD;CONST lpText,lpCaption:CSTRING;
  4822.                         uType:LONGWORD):LONGWORD;
  4823.                APIENTRY; 'USER32' name 'MessageBoxA';
  4824. END;
  4825.  
  4826. PROCEDURE ExcptRunError(e:SysException);
  4827. VAR
  4828.    s:STRING;
  4829.    cs:CSTRING;
  4830.    cTitle:CSTRING;
  4831.    Arguments:ARRAY[0..1] OF LONGWORD;
  4832. Label go;
  4833. BEGIN
  4834.      If e=Nil Then
  4835.      BEGIN
  4836.           s:='Unhandled Debugger Exception';
  4837.           goto go;
  4838.      END;
  4839.  
  4840.      try
  4841.         IF e.CameFromRTL THEN IF not e.Nested THEN
  4842.         BEGIN
  4843.              e.Nested:=TRUE;
  4844.              Arguments[0]:=LONGWORD(e.RTLExcptAddr);
  4845.              Arguments[1]:=LONGWORD(e.FMessage);
  4846.              RaiseExceptionAPI(EXCEPTION_INTERNAL_RTL,0,2,Arguments);
  4847.  
  4848.              //If RaiseExceptionAPI returns from call, the exception was
  4849.              //not transferred to a handler, so we do it manually :-(
  4850.              goto go;
  4851.         END;
  4852.      finally
  4853.         e.ExcptAddr:=e.RTLExcptAddr;
  4854.      end;
  4855.  
  4856.      IF POINTER(e.ExcptAddr)<>NIL THEN
  4857.        s:='Exception occured: '+e.Message+' at '+tohex(LONGWORD(e.ExcptAddr))+
  4858.            #13#10'Program is terminated.'
  4859.      ELSE
  4860.        s:='Exception occured: '+e.Message+
  4861.            #13#10'Program is terminated.';
  4862. go:
  4863.      IF ApplicationType=1 THEN
  4864.      BEGIN
  4865.           cs:=s;
  4866.           cTitle:='Exception occured';
  4867.           MessageBox(0,cs,ctitle,0);
  4868.      END
  4869.      ELSE Writeln(s);
  4870.      Halt;
  4871. END;
  4872.  
  4873. CONST ProcessDebugged:Boolean=FALSE;
  4874.  
  4875. PROCEDURE RaiseException(objekt:SysException;adress:LONGWORD);
  4876. VAR ExcptAddr:POINTER;
  4877.     dummy,Found:PExcptInfo;
  4878.     ThreadId:LONGWORD;
  4879.     Arguments:ARRAY[0..1] OF LONGWORD;
  4880. LABEL l1;
  4881. BEGIN
  4882.      IF Adress=0 THEN
  4883.      BEGIN
  4884.           ASM
  4885.              MOV EAX,[EBP+4]
  4886.              MOV Adress,EAX
  4887.           END;
  4888.      END;
  4889.  
  4890.      ThreadId:=GetCurrentThreadId;
  4891.  
  4892.      {Search exception handler}
  4893.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  4894.  
  4895.      ExcptAddr:=POINTER(Adress);
  4896.  
  4897.      dummy:=ExcptList;
  4898.      IF dummy<>NIL THEN WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  4899.      Found:=NIL;
  4900.      WHILE dummy<>NIL DO
  4901.      BEGIN
  4902.           {IF LONGWORD(ExcptAddr)>=LONGWORD(dummy^.TryAddr) THEN
  4903.             IF LONGWORD(ExcptAddr)<=LONGWORD(dummy^.ExcptAddr) THEN
  4904.                Found:=dummy;}
  4905.           IF dummy^.ThreadId=ThreadId THEN
  4906.           BEGIN
  4907.                Found:=dummy;
  4908.                goto l1;
  4909.           END;
  4910.  
  4911.           dummy:=dummy^.Last;
  4912.      END;
  4913. l1:
  4914.      IF Found=NIL THEN
  4915.         IF ExcptList<>NIL THEN Found:=ExcptList;
  4916.  
  4917.      ReleaseMutex(ExcptMutex);
  4918.  
  4919.      IF Found=NIL THEN ExcptRunError(Objekt);
  4920.  
  4921.      Found^.ExcptObject:=Objekt;
  4922.  
  4923.      Objekt.RTLExcptAddr:=Pointer(Adress);
  4924.      Arguments[0]:=LongWord(Objekt.RTLExcptAddr);
  4925.      Arguments[1]:=LONGWORD(Objekt.FMessage);
  4926.  
  4927.      //If this process is debugged, give the debugger a chance to handle
  4928.      //the exception
  4929.      If ProcessDebugged Then
  4930.        RaiseExceptionAPI(EXCEPTION_INTERNAL_RTL,0,2,Arguments);
  4931.  
  4932.      //If RaiseExceptionAPI returns from call, the exception was
  4933.      //not transferred to a handler, so we do it manually :-(
  4934.      ASM
  4935.         MOV EAX,Objekt
  4936.         MOV EDI,Found
  4937.         PUSH DWORD PTR [EDI+8]    //old EBP
  4938.         POP EBP
  4939.         MOV ESP,[EDI+12] //old ESP
  4940.         FLDCW [EDI+16]   //old FPU Control Word
  4941.  
  4942.         JMP [EDI+4]        //jump into exception handler
  4943.      END;
  4944. END;
  4945.  
  4946. PROCEDURE FreeExceptInstance(e:SysException);
  4947. BEGIN
  4948.      IF e<>NIL THEN e.Free;
  4949. END;
  4950.  
  4951. PROCEDURE RaiseExceptionAgain(e:SysException);
  4952. BEGIN
  4953.      IF e=NIL THEN exit;
  4954.      RaiseException(e,LONGWORD(e.ExcptAddr));
  4955. END;
  4956.  
  4957. PROCEDURE Beep(Freq,duration:LONGWORD);
  4958. BEGIN
  4959.      ASM
  4960.          PUSH DWORD PTR duration
  4961.          PUSH DWORD PTR freq
  4962.          CALLDLL KERNEL32,'Beep'
  4963.      END;
  4964. END;
  4965. {$ENDIF}
  4966.  
  4967.  
  4968. //File I/O support
  4969. {$IFDEF OS2}
  4970. TYPE
  4971.     PFEA2=^FEA2;
  4972.     FEA2=RECORD {pack 1}
  4973.                  oNextEntryOffset:LONGWORD;    { new field }
  4974.                  fEA:BYTE;
  4975.                  cbName:BYTE;
  4976.                  cbValue:WORD;
  4977.                  szName:CSTRING[1];    { new field }
  4978.     END;
  4979.  
  4980.     PFEA2LIST=^FEA2LIST;
  4981.     FEA2LIST=RECORD {pack 1}
  4982.                    cbList:LONGWORD;
  4983.                    list:ARRAY[0..0] OF FEA2;
  4984.     END;
  4985.  
  4986.     PGEA2=^GEA2;
  4987.     GEA2=RECORD {pack 1}
  4988.                  oNextEntryOffset:LONGWORD;  { new field }
  4989.                  cbName:BYTE;
  4990.                  szName:ARRAY[0..0] OF BYTE; { new field }
  4991.     END;
  4992.  
  4993.     PGEA2LIST=^GEA2LIST;
  4994.     GEA2LIST=RECORD      { pack 1 }
  4995.                    cbList:LONGWORD;
  4996.                    list:ARRAY [0..0] OF GEA2;
  4997.     END;
  4998.  
  4999.     PEAOP2=^EAOP2;
  5000.     EAOP2=RECORD  { pack 1 }
  5001.                 fpGEA2List:PGEA2LIST;       { GEA set }
  5002.                 fpFEA2List:PFEA2LIST;       { FEA set }
  5003.                 oError:LONGWORD;            { offset of FEA error }
  5004.     END;
  5005.  
  5006. CONST
  5007.      MAX_GEA         = 500;  // Max size for a GEA List
  5008.  
  5009.  
  5010. IMPORTS
  5011.    FUNCTION DosOpen(pszFileName:CSTRING;VAR pHf:LONGWORD;VAR pulAction:LONGWORD;
  5012.                     cbFile,ulAttribute,fsOpenFlags,fsOpenMode:LONGWORD;
  5013.                     VAR apeaop2{:EAOP2}):LONGWORD;
  5014.                     APIENTRY;             'DOSCALLS' index 273;
  5015.    FUNCTION DosEnumAttribute(ulRefType:LONGWORD;VAR pvFile;ulEntry:LONGWORD;
  5016.                              VAR pvBuf;cbBuf:LONGWORD;VAR pulCount:LONGWORD;
  5017.                              ulInfoLevel:LONGWORD):LONGWORD;
  5018.                     APIENTRY;             'DOSCALLS' index 372;
  5019.    FUNCTION DosQueryPathInfo(VAR pszPathName:CSTRING;ulInfoLevel:LONGWORD;
  5020.                              VAR pInfoBuf;cbInfoBuf:LONGWORD):LONGWORD;
  5021.                     APIENTRY;             'DOSCALLS' index 223;
  5022.    FUNCTION DosQueryFileInfo(hf:LONGWORD;ulInfoLevel:LONGWORD;
  5023.                              VAR pInfo;cbInfoBuf:LONGWORD):LONGWORD;
  5024.                     APIENTRY;             'DOSCALLS' index 279;
  5025.    FUNCTION DosSetPathInfo(pszPathName:CSTRING;ulInfoLevel:LONGWORD;VAR pInfoBuf;
  5026.                         cbInfoBuf,flOptions:LONGWORD):LONGWORD;
  5027.                     APIENTRY;             'DOSCALLS' index 219;
  5028.    FUNCTION DosSetFileInfo(hf:LONGWORD;ulInfoLevel:LONGWORD;VAR pInfoBuf;
  5029.                         cbInfoBuf:LONGWORD):LONGWORD;
  5030.                     APIENTRY;             'DOSCALLS' index 218;
  5031.    FUNCTION DosClose(ahFile:LONGWORD):LONGWORD;
  5032.                     APIENTRY;             'DOSCALLS' index 257;
  5033.    FUNCTION DosSetFilePtr(ahFile:LONGWORD;ib:LONGINT;method:LONGWORD;
  5034.                        VAR ibActual:LONGWORD):LONGWORD;
  5035.                     APIENTRY;             'DOSCALLS' index 256;
  5036.    FUNCTION DosCreateDir(pszDirName:CSTRING;VAR apeaop2:EAOP2):LONGWORD;
  5037.                     APIENTRY;             'DOSCALLS' index 270;
  5038.    FUNCTION DosDeleteDir(pszDir:CSTRING):LONGWORD;
  5039.                     APIENTRY;             'DOSCALLS' index 226;
  5040.    FUNCTION DosSetDefaultDisk(disknum:LONGWORD):LONGWORD;
  5041.                     APIENTRY;             'DOSCALLS' index 220;
  5042.    FUNCTION DosQueryCurrentDisk(VAR pdisknum,plogical:LONGWORD):LONGWORD;
  5043.                     APIENTRY;             'DOSCALLS' index 275;
  5044.    FUNCTION DosSetCurrentDir(pszDir:CSTRING):LONGWORD;
  5045.                     APIENTRY;             'DOSCALLS' index 255;
  5046.    FUNCTION DosQueryCurrentDir_API(disknum:LONGWORD;VAR pBuf;
  5047.                             VAR pcbBuf:LONGWORD):LONGWORD;
  5048.                     APIENTRY;             'DOSCALLS' index 274;
  5049.    FUNCTION DosRead(ahFile:LONGWORD;VAR pBuffer;cbRead:LONGWORD;
  5050.                  VAR pcbActual:LONGWORD):LONGWORD;
  5051.                     APIENTRY;             'DOSCALLS' index 281;
  5052.    FUNCTION DosWrite(ahFile:LONGWORD;VAR pBuffer;cbWrite:LONGWORD;
  5053.                   VAR pcbActual:LONGWORD):LONGWORD;
  5054.                     APIENTRY;             'DOSCALLS' index 282;
  5055.    FUNCTION DosMove(VAR pszOld,pszNew:CSTRING):LONGWORD;
  5056.                     APIENTRY;             'DOSCALLS' index 271;
  5057.    FUNCTION DosSetFileSize(ahFile:LONGWORD;cbSize:LONGWORD):LONGWORD;
  5058.                     APIENTRY;             'DOSCALLS' index 272;
  5059.    FUNCTION DosDelete(VAR pszFile:CSTRING):LONGWORD;
  5060.                     APIENTRY;             'DOSCALLS' index 259;
  5061. END;
  5062.  
  5063. FUNCTION DosQueryCurrentDir(disknum:LONGWORD;VAR pBuf;
  5064.                             VAR pcbBuf:LONGWORD):LONGWORD;
  5065. BEGIN
  5066.      ASM
  5067.         xor eax,eax
  5068.         db $64,$ff,$30  //pushd fs:[eax]
  5069.      END;
  5070.      result:=DosQueryCurrentDir_API(disknum,pBuf,pcbBuf);
  5071.      ASM
  5072.         xor eax,eax
  5073.         db $64,$8f,$00  //popd fs:[eax]
  5074.      END;
  5075. END;
  5076. {$ENDIF}
  5077.  
  5078. FUNCTION IOResult: Integer;
  5079. BEGIN
  5080.   {$IFDEF OS2}
  5081.   case InOutRes of
  5082.   19: Result:=150;
  5083.   21: Result:=152;
  5084.   23: Result:=154;
  5085.   25: Result:=156;
  5086.   26: Result:=157;
  5087.   27: Result:=158;
  5088.   32: Result:=5;
  5089.   33: Result:=5;
  5090.   110: Result:=2;
  5091.   else Result:=InOutRes;
  5092.   end;
  5093.   {$ENDIF}
  5094.   {$IFDEF WIN95}
  5095.   result:=InOutRes;
  5096.   {$ENDIF}
  5097.   InOutRes:=0;
  5098. END;
  5099.  
  5100. {$IFDEF OS2}
  5101. FUNCTION OS2Result: Integer;
  5102. BEGIN
  5103.   OS2Result:=InOutRes;
  5104.   InOutRes:=0;
  5105. END;
  5106. {$ENDIF}
  5107.  
  5108. VAR
  5109.    FileBufSize:LONGWORD;  {Standard file buffer size (32768 bytes}
  5110.  
  5111. PROCEDURE Assign(VAR f:FILE;CONST s:String);
  5112. VAR ff:^FileRec;
  5113. BEGIN
  5114.      ff:=@f;
  5115.      fillchar(f,sizeof(f),0);
  5116.      ff^.Name:=s;                  {Assign name to file variable}
  5117.      ff^.Flags:=$6666;             {File successfully assigned}
  5118.      ff^.Handle:=$ffffffff;        {No valid handle}
  5119.      ff^.MaxCacheMem:=FileBufSize; {Initial bufsize}
  5120.      ff^.Buffer:=NIL;
  5121.      IF ff^.MaxCacheMem<16 THEN ff^.MaxCacheMem:=16;
  5122.      InOutRes:=0;                  {Clear InOutRes variable}
  5123. END;
  5124.  
  5125. PROCEDURE AssignFile(VAR f:FILE;CONST s:String);
  5126. BEGIN
  5127.      Assign(f,s);
  5128. END;
  5129.  
  5130. PROCEDURE InvalidFileNameError(Adr:LONGINT);
  5131. VAR
  5132.    e:EInvalidFileName;
  5133. BEGIN
  5134.      e.Create('Invalid file name (EInvalidFileName)');
  5135.      e.CameFromRTL:=TRUE;
  5136.      e.RTLExcptAddr:=POINTER(Adr);
  5137.      e.ErrorCode:=206; {filename exceeds range}
  5138.      RAISE e;
  5139. END;
  5140.  
  5141. PROCEDURE InOutError(Code:LONGWORD;Adr:LONGWORD);
  5142. VAR
  5143.    e:EInOutError;
  5144. BEGIN
  5145.      e.Create('Input/Output error (EInOutError)');
  5146.      e.ErrorCode:=code;
  5147.      e.CameFromRTL:=TRUE;
  5148.      e.RTLExcptAddr:=POINTER(Adr);
  5149.      RAISE e;
  5150. END;
  5151.  
  5152. CONST
  5153.      {Modes for FileBlockIO}
  5154.      ReadMode        = 1;
  5155.      WriteMode       = 2;
  5156.  
  5157. {$IFDEF OS2}
  5158. PROCEDURE FileBlockIO(VAR f:FILE;BlockNr:LONGWORD;Mode:LONGWORD;
  5159.                       VAR result:LONGWORD);
  5160. VAR
  5161.    l:LONGWORD;
  5162.    po:LONGWORD;
  5163.    temp:LONGWORD;
  5164.    ff:^FileRec;
  5165. BEGIN
  5166.      ff:=@f;
  5167.      InOutRes:=0;
  5168.      IF ff^.changed THEN
  5169.      BEGIN
  5170.           ff^.changed:=FALSE;
  5171.           FileBlockIO(f,ff^.block,WriteMode,Temp);
  5172.           IF InOutRes<>0 THEN exit;
  5173.      END;
  5174.  
  5175.      IF blocknr=ff^.LBlock THEN l:=ff^.LOffset
  5176.      ELSE l:=ff^.MaxCacheMem;
  5177.      po:=ff^.MaxCacheMem*blocknr;
  5178.      InOutRes:=DosSetFilePtr(ff^.Handle,po,0,Temp);
  5179.      IF InOutRes<>0 THEN exit;
  5180.  
  5181.      IF l>0 THEN
  5182.      BEGIN
  5183.           CASE Mode OF
  5184.               WriteMode:
  5185.               BEGIN
  5186.                    InOutRes:=DosWrite(ff^.Handle,ff^.Buffer^,l,result);
  5187.               END;
  5188.               ReadMode:
  5189.               BEGIN
  5190.                    InOutRes:=DosRead(ff^.Handle,ff^.Buffer^,l,result);
  5191.               END;
  5192.           END; {case}
  5193.      END;
  5194. END;
  5195. {$ENDIF}
  5196. {$IFDEF WIN95}
  5197. PROCEDURE FileBlockIO(VAR f:FILE;BlockNr:LONGWORD;Mode:LONGWORD;
  5198.                       VAR result:LONGWORD);
  5199. VAR
  5200.    l:LONGWORD;
  5201.    po:LONGWORD;
  5202.    temp:LONGWORD;
  5203.    ff:^FileRec;
  5204. BEGIN
  5205.      ff:=@f;
  5206.      InOutRes:=0;
  5207.      IF ff^.changed THEN
  5208.      BEGIN
  5209.           ff^.changed:=FALSE;
  5210.           FileBlockIO(f,ff^.block,WriteMode,Temp);
  5211.           IF InOutRes<>0 THEN exit;
  5212.      END;
  5213.  
  5214.      IF blocknr=ff^.LBlock THEN l:=ff^.LOffset
  5215.      ELSE l:=ff^.MaxCacheMem;
  5216.      po:=ff^.MaxCacheMem*blocknr;
  5217.      Temp:=SetFilePointer(ff^.Handle,po,NIL,0);  //Seek from file BEGIN
  5218.      IF Temp=$ffffffff THEN
  5219.      BEGIN
  5220.           InOutRes:=GetLastError;
  5221.           exit;
  5222.      END;
  5223.  
  5224.      IF l>0 THEN
  5225.      BEGIN
  5226.           CASE Mode OF
  5227.               WriteMode:
  5228.               BEGIN
  5229.                    IF not WriteFile(ff^.Handle,ff^.Buffer^,l,result,NIL) THEN
  5230.                    BEGIN
  5231.                        InOutRes:=GetLastError;
  5232.                    END;
  5233.               END;
  5234.               ReadMode:
  5235.               BEGIN
  5236.                    IF not ReadFile(ff^.Handle,ff^.Buffer^,l,result,NIL) THEN
  5237.                    BEGIN
  5238.                         InOutRes:=GetLastError;
  5239.                    END;
  5240.               END;
  5241.           END; {case}
  5242.      END;
  5243. END;
  5244. {$ENDIF}
  5245.  
  5246. {$IFDEF OS2}
  5247. FUNCTION FileFileSize(VAR f:FILE):LONGWORD;
  5248. VAR
  5249.    ff:^FileRec;
  5250.    Temp,Temp1,Temp2:LONGWORD;
  5251. BEGIN
  5252.      ff:=@f;
  5253.  
  5254.      InOutRes:=DosSetFilePtr(ff^.Handle,0,1,Temp);
  5255.      IF InOutRes<>0 THEN exit;
  5256.  
  5257.      InOutRes:=DosSetFilePtr(ff^.Handle,0,2,Temp1);
  5258.      IF InOutRes<>0 THEN exit;
  5259.  
  5260.      InOutRes:=DosSetFilePtr(ff^.Handle,Temp,0,Temp2);
  5261.      IF InOutRes<>0 THEN exit;
  5262.  
  5263.      FileFileSize:=Temp1;
  5264. END;
  5265.  
  5266. FUNCTION FileFilePos(VAR f:FILE):LONGWORD;
  5267. VAR
  5268.    ff:^FileRec;
  5269.    Temp:LONGWORD;
  5270. BEGIN
  5271.      ff:=@f;
  5272.  
  5273.      InOutRes:=DosSetFilePtr(ff^.Handle,0,1,Temp);
  5274.      IF InOutRes<>0 THEN exit;
  5275.  
  5276.      FileFilePos:=Temp;
  5277. END;
  5278. {$ENDIF}
  5279. {$IFDEF WIN95}
  5280. FUNCTION FileFileSize(VAR f:FILE):LONGWORD;
  5281. VAR
  5282.    ff:^FileRec;
  5283.    Temp,Temp1,Temp2:LONGWORD;
  5284. BEGIN
  5285.      ff:=@f;
  5286.  
  5287.      InOutRes:=0;
  5288.      Temp:=SetFilePointer(ff^.Handle,0,NIL,1); //get current pos
  5289.      IF Temp=$ffffffff THEN
  5290.      BEGIN
  5291.           InOutRes:=GetLastError;
  5292.           exit;
  5293.      END;
  5294.  
  5295.      Temp1:=SetFilePointer(ff^.Handle,0,NIL,2); //get length
  5296.      IF Temp1=$ffffffff THEN
  5297.      BEGIN
  5298.           InOutRes:=GetLastError;
  5299.           exit;
  5300.      END;
  5301.  
  5302.      Temp2:=SetFilePointer(ff^.Handle,Temp,NIL,0);  //restore position
  5303.      IF Temp2=$ffffffff THEN
  5304.      BEGIN
  5305.           InOutRes:=GetLastError;
  5306.           exit;
  5307.      END;
  5308.  
  5309.      FileFileSize:=Temp1;
  5310. END;
  5311.  
  5312. FUNCTION FileFilePos(VAR f:FILE):LONGWORD;
  5313. VAR
  5314.    ff:^FileRec;
  5315.    Temp:LONGWORD;
  5316. BEGIN
  5317.      ff:=@f;
  5318.  
  5319.      InOutRes:=0;
  5320.      Temp:=SetFilePointer(ff^.Handle,0,NIL,1);
  5321.      IF Temp=$ffffffff THEN
  5322.      BEGIN
  5323.           InOutRes:=GetLastError;
  5324.           exit;
  5325.      END;
  5326.  
  5327.      FileFilePos:=Temp;
  5328. END;
  5329. {$ENDIF}
  5330.  
  5331.  
  5332. VAR OpenedFiles:ARRAY[1..51] OF LONGWORD; {Handles for opened files}
  5333.     OpenedFilesCount:BYTE;
  5334.  
  5335. {$IFDEF OS2}
  5336. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  5337. VAR
  5338.    action:LONGWORD;
  5339.    ff:^FileRec;
  5340.    c:CSTRING;
  5341.    e:EFileNotFound;
  5342.    Size,Temp:LONGWORD;
  5343.    SaveIOError:BOOLEAN;
  5344.    Adr:LONGWORD;
  5345. BEGIN
  5346.      ASM
  5347.         MOV EAX,[EBP+4]
  5348.         SUB EAX,5
  5349.         MOV Adr,EAX
  5350.      END;
  5351.      InOutRes:=0;
  5352.      ff:=@f;
  5353.      ff^.RecSize:=recsize;
  5354.  
  5355.      IF ff^.flags<>$6666 THEN
  5356.      BEGIN
  5357.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5358.           ELSE
  5359.           BEGIN
  5360.                InOutRes:=206;
  5361.                exit;
  5362.           END;
  5363.      END;
  5364.  
  5365.      IF ff^.Handle<>$ffffffff THEN
  5366.      BEGIN
  5367.          {Close file first}
  5368.          SaveIoError:=RaiseIOError;
  5369.          RaiseIOError:=FALSE;
  5370.          Close(f);
  5371.          RaiseIoError:=SaveIoError;
  5372.          (*InOutRes:=85; {File already assigned}
  5373.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5374.          ELSE exit;*)
  5375.      END;
  5376.  
  5377.      IF ff^.Name='' THEN {rewrite standard output}
  5378.      BEGIN
  5379.           ff^:=FileRec(Output);
  5380.           exit;
  5381.      END;
  5382.  
  5383.      ff^.Buffer:=NIL;
  5384.  
  5385.      c:=ff^.Name;
  5386.      {for rewrite no extended attributes can be determined - use reset !}
  5387.      InOutRes:=DosOpen(c,ff^.Handle,action,0,$20,18,FileMode,NIL{EAOP2});
  5388.      IF InOutRes<>0 THEN
  5389.      BEGIN
  5390.           ff^.Handle:=$ffffffff;
  5391.           IF RaiseIOError THEN
  5392.           BEGIN
  5393.                e.Create('File not found (EFileNotFound)');
  5394.                e.CameFromRTL:=TRUE;
  5395.                e.RTLExcptAddr:=POINTER(Adr);
  5396.                e.ErrorCode:=InOutRes;
  5397.                RAISE e;
  5398.           END
  5399.           ELSE exit;
  5400.      END;
  5401.  
  5402.      ff^.Mode:=FileMode;
  5403.      ff^.Reserved1:=0;
  5404.      ff^.BufferBytes:=0;
  5405.  
  5406.      {Set the buffer values}
  5407.  
  5408.      size:=FileFileSize(f);
  5409.      IF InOutRes<>0 THEN
  5410.      BEGIN
  5411.           ff^.Handle:=$ffffffff;
  5412.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5413.           ELSE exit;
  5414.      END;
  5415.  
  5416.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  5417.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  5418.  
  5419.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  5420.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  5421.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  5422.      FileBlockIO(f,0,readmode,Temp);
  5423.      IF InOutRes<>0 THEN
  5424.      BEGIN
  5425.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5426.           ELSE exit;
  5427.      END;
  5428.      ff^.Block:=0;
  5429.      ff^.Offset:=0;
  5430. END;
  5431. {$ENDIF}
  5432. {$IFDEF WIN95}
  5433. TYPE
  5434.     PSECURITY_ATTRIBUTES=^SECURITY_ATTRIBUTES;
  5435.     SECURITY_ATTRIBUTES=RECORD
  5436.                               nLength:LONGWORD;
  5437.                               lpSecurityDescriptor:POINTER;
  5438.                               bInheritHandle:LongBool;
  5439.                         END;
  5440.  
  5441. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  5442. VAR
  5443.    ff:^FileRec;
  5444.    c:CSTRING;
  5445.    e:EFileNotFound;
  5446.    Size,Temp:LONGWORD;
  5447.    SaveIOError:BOOLEAN;
  5448.    Adr:LONGINT;
  5449.    {SA:SECURITY_ATTRIBUTES;}
  5450. BEGIN
  5451.      ASM
  5452.         MOV EAX,[EBP+4]
  5453.         SUB EAX,5
  5454.         MOV Adr,EAX
  5455.      END;
  5456.      InOutRes:=0;
  5457.      ff:=@f;
  5458.      ff^.RecSize:=recsize;
  5459.  
  5460.      IF ff^.flags<>$6666 THEN
  5461.      BEGIN
  5462.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5463.           ELSE
  5464.           BEGIN
  5465.                InOutRes:=206;
  5466.                exit;
  5467.           END;
  5468.      END;
  5469.  
  5470.      IF ff^.Handle<>$ffffffff THEN
  5471.      BEGIN
  5472.          {Close file first}
  5473.          SaveIoError:=RaiseIOError;
  5474.          RaiseIOError:=FALSE;
  5475.          Close(f);
  5476.          RaiseIoError:=SaveIoError;
  5477.          (*InOutRes:=85; {File already assigned}
  5478.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5479.          ELSE exit;*)
  5480.      END;
  5481.  
  5482.      ff^.Buffer:=NIL;
  5483.      c:=ff^.Name;
  5484.      {for rewrite no extended attributes can be determined - use reset !}
  5485.      {
  5486.      SA.nLength:=sizeof(SA);
  5487.      SA.lpSecurityDescriptor:=Nil;
  5488.      SA.bInheritHandle:=True;
  5489.      }
  5490.      ff^.Handle:=CreateFile(c,FileMode AND not 3,FileMode AND 3,Nil{SA},2,$00000080,0);
  5491.      IF ff^.Handle=-1 THEN
  5492.      BEGIN
  5493.           InOutRes:=GetLastError;
  5494.           ff^.Handle:=$ffffffff;
  5495.           IF RaiseIOError THEN
  5496.           BEGIN
  5497.                e.Create('File not found (EFileNotFound)');
  5498.                e.ErrorCode:=InOutRes;
  5499.                e.CameFromRTL:=TRUE;
  5500.                e.RTLExcptAddr:=POINTER(Adr);
  5501.                RAISE e;
  5502.           END
  5503.           ELSE exit;
  5504.      END;
  5505.  
  5506.      ff^.Mode:=FileMode;
  5507.      ff^.Reserved1:=0;
  5508.  
  5509.      {Set the buffer values}
  5510.  
  5511.      size:=FileFileSize(f);
  5512.      IF InOutRes<>0 THEN
  5513.      BEGIN
  5514.           ff^.Handle:=$ffffffff;
  5515.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5516.           ELSE exit;
  5517.      END;
  5518.  
  5519.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  5520.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  5521.  
  5522.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  5523.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  5524.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  5525.      FileBlockIO(f,0,readmode,Temp);
  5526.      IF InOutRes<>0 THEN
  5527.      BEGIN
  5528.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5529.           ELSE exit;
  5530.      END;
  5531.      ff^.Block:=0;
  5532.      ff^.Offset:=0;
  5533. END;
  5534. {$ENDIF}
  5535.  
  5536. {$IFDEF OS2}
  5537. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  5538. VAR
  5539.    action:LONGWORD;
  5540.    ff:^FileRec;
  5541.    c:CSTRING;
  5542.  
  5543.    p:POINTER;
  5544.    pAllocc:POINTER;
  5545.    pBigAlloc:POINTER;
  5546.    cbBigAlloc:WORD;
  5547.    ulEntryNum:LONGWORD;
  5548.    ulEnumCnt:LONGWORD;
  5549.    pLastIn:PHOLDFEA;
  5550.    pNewFEA:PHOLDFEA;
  5551.    pFEA:PFEA2;
  5552.    pGEAList:PGEA2LIST;
  5553.    eaopGet:EAOP2;
  5554.    apHoldFEA:PHOLDFEA;
  5555.    e:EFileNotFound;
  5556.    size,Temp:LONGWORD;
  5557.    SaveIoError:BOOLEAN;
  5558.    Adr:LONGINT;
  5559. LABEL l;
  5560. BEGIN
  5561.      ASM
  5562.         MOV EAX,[EBP+4]
  5563.         SUB EAX,5
  5564.         MOV Adr,EAX
  5565.      END;
  5566.      InOutRes:=0;
  5567.      ff:=@f;
  5568.      ff^.RecSize:=recsize;
  5569.      IF ff^.flags<>$6666 THEN
  5570.      BEGIN
  5571.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5572.           ELSE
  5573.           BEGIN
  5574.                InOutRes:=206;
  5575.                exit;
  5576.           END;
  5577.      END;
  5578.  
  5579.      IF ff^.Handle<>$ffffffff THEN
  5580.      BEGIN
  5581.          {Close file first}
  5582.          SaveIoError:=RaiseIOError;
  5583.          RaiseIOError:=FALSE;
  5584.          Close(f);
  5585.          RaiseIoError:=SaveIoError;
  5586.          (*InOutRes:=85; {File already assigned}
  5587.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5588.          ELSE exit;*)
  5589.      END;
  5590.  
  5591.      ff^.Buffer:=NIL;
  5592.  
  5593.      IF ff^.Name='' THEN  {reset input}
  5594.      BEGIN
  5595.           ff^:=FileRec(Input);
  5596.           exit;
  5597.      END;
  5598.  
  5599.      c:=ff^.Name;
  5600.  
  5601.      {open and read extended attributes}
  5602.      InOutRes:=DosOpen(c,ff^.Handle,action,0,0,1,FileMode,NIL{EAOP2});
  5603.      IF InOutRes<>0 THEN
  5604.      BEGIN
  5605.           ff^.Handle:=$ffffffff;
  5606.           IF RaiseIOError THEN
  5607.           BEGIN
  5608.                e.Create('File not found (EFileNotFound)');
  5609.                e.CameFromRTL:=TRUE;
  5610.                e.RTLExcptAddr:=POINTER(Adr);
  5611.                e.ErrorCode:=InOutRes;
  5612.                RAISE e;
  5613.           END
  5614.           ELSE exit;
  5615.      END;
  5616.  
  5617.      {Query extended attributes}
  5618.  
  5619.      pAllocc:=NIL;     // Holds the FEA struct returned by DosEnumAttribute
  5620.                        // used to create the GEA2LIST for DosQueryPathInfo
  5621.      pBigAlloc:=NIL;   // Temp buffer to hold each EA as it is read in
  5622.      cbBigAlloc:=0;    // Size of buffer
  5623.  
  5624.      ulEntryNum := 1;  // count of current EA to read (1-relative)
  5625.  
  5626.      pLastIn:=NIL;     // Points to last EA added, so new EA can link
  5627.      pNewFEA:=NIL;     // Struct to build the new EA in
  5628.  
  5629.      GetMem(pAllocc, MAX_GEA);
  5630.      pFEA := pAllocc;  // pFEA always uses pAlloc buffer
  5631.  
  5632.      apHoldFEA := NIL; // Reset the pointer for the EA linked list
  5633.  
  5634.      WHILE TRUE DO     // Loop continues until there are no more EAs */
  5635.      BEGIN
  5636.           ulEnumCnt := 1;
  5637.           IF DosEnumAttribute(0,ff^.Handle,ulEntryNum,pAllocc^,
  5638.                               MAX_GEA,ulEnumCnt,1) <>0 THEN
  5639.           BEGIN
  5640.                {There was some sort of error}
  5641.                goto l;
  5642.           END;
  5643.  
  5644.           IF ulEnumCnt <> 1 THEN goto l;  // All the EAs have been read
  5645.  
  5646.           inc(ulEntryNum);
  5647.  
  5648.           GetMem(pNewFEA, sizeof(THOLDFEA));
  5649.  
  5650.           pNewFEA^.cbName := pFEA^.cbName;  // Fill in the HoldFEA structure
  5651.           pNewFEA^.cbValue:= pFEA^.cbValue;
  5652.           pNewFEA^.fEA    := pFEA^.fEA;
  5653.           pNewFEA^.next   := NIL;
  5654.  
  5655.           pNewFEA^.szName:=pFEA^.szName;  // Copy in EA Name
  5656.  
  5657.           cbBigAlloc := sizeof(FEA2LIST) + pNewFEA^.cbName +
  5658.                         pNewFEA^.cbValue;
  5659.  
  5660.           GetMem(pBigAlloc, cbBigAlloc);
  5661.  
  5662.           pGEAList := pAllocc;          // Set up GEAList structure
  5663.  
  5664.           pGEAList^.cbList := sizeof(GEA2LIST) + pNewFEA^.cbName; // +1 for NULL
  5665.           pGEAList^.list[0].oNextEntryOffset := 0;
  5666.           pGEAList^.list[0].cbName := pNewFEA^.cbName;
  5667.  
  5668.           CSTRING(pGEAList^.list[0].szName):=pNewFEA^.szName;
  5669.  
  5670.           eaopGet.fpGEA2List := pAllocc;
  5671.           eaopGet.fpFEA2List := pBigAlloc;
  5672.  
  5673.           eaopGet.fpFEA2List^.cbList := cbBigAlloc;
  5674.  
  5675.           DosQueryFileInfo(ff^.Handle,       // Get the complete EA info
  5676.                            3,
  5677.                            eaopGet,
  5678.                            sizeof(EAOP2));
  5679.  
  5680.           getmem(pNewFEA^.aValue,pNewFEA^.cbValue); //memory for data
  5681.           p:=pBigAlloc;
  5682.           inc(p,sizeof(FEA2LIST)+pNewFEA^.cbName-1);
  5683.           move(p^,pNewFEA^.aValue^, pNewFEA^.cbValue);
  5684.  
  5685.  
  5686.           FreeMem(pBigAlloc,cbBigAlloc); // Release the temp Enum buffer
  5687.  
  5688.           IF apHoldFEA = NIL THEN         // If first EA, set pHoldFEA
  5689.                apHoldFEA := pNewFEA
  5690.           ELSE
  5691.              pLastIn^.next := pNewFEA;
  5692.  
  5693.           pLastIn := pNewFEA;            // Update the end of the list
  5694.           pLastIn^.Deleted:=FALSE;       //EA is valid
  5695.      END;  {While}
  5696. l:
  5697.  
  5698.      IF pLastIn<>NIL THEN pLastIn^.Next:=NIL;
  5699.      FreeMem(pAllocc,MAX_GEA);           // Free up the GEA buf for DosEnum
  5700.  
  5701.      ff^.EAS:=apHoldFEA;
  5702.      ff^.Mode:=FileMode;
  5703.      ff^.Reserved1:=0;
  5704.      ff^.BufferBytes:=0;
  5705.  
  5706.      {Set the buffer values}
  5707.  
  5708.      size:=FileFileSize(f);
  5709.      IF InOutRes<>0 THEN
  5710.      BEGIN
  5711.           ff^.Handle:=$ffffffff;
  5712.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5713.           ELSE exit;
  5714.      END;
  5715.  
  5716.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  5717.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  5718.  
  5719.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  5720.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  5721.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  5722.      FileBlockIO(f,0,readmode,Temp);
  5723.      IF InOutRes<>0 THEN
  5724.      BEGIN
  5725.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5726.           ELSE exit;
  5727.      END;
  5728.      ff^.Block:=0;
  5729.      ff^.Offset:=0;
  5730. END;
  5731.  
  5732. {Get extended attributes from a file}
  5733. FUNCTION GetEAData(VAR f:FILE):PHOLDFEA;
  5734. VAR
  5735.    ff:^FileRec;
  5736.    Adr:LONGINT;
  5737. BEGIN
  5738.      ASM
  5739.         MOV EAX,[EBP+4]
  5740.         SUB EAX,5
  5741.         MOV Adr,EAX
  5742.      END;
  5743.      ff:=@f;
  5744.      InOutRes:=0;
  5745.      IF ff^.flags<>$6666 THEN
  5746.      BEGIN
  5747.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5748.           ELSE
  5749.           BEGIN
  5750.                GetEAData:=NIL;
  5751.                InOutRes:=206;
  5752.                exit;
  5753.           END;
  5754.      END;
  5755.  
  5756.      IF ff^.Handle=$ffffffff THEN
  5757.      BEGIN
  5758.          InOutRes:=6; {Invalid handle}
  5759.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5760.          ELSE exit;
  5761.      END;
  5762.  
  5763.      GetEAData:=ff^.EAS;
  5764. END;
  5765.  
  5766. {use with care !}
  5767. PROCEDURE EraseEAData(VAR f:FILE);
  5768. VAR
  5769.    ff:^FileRec;
  5770.    pFEA,next:PHOLDFEA;
  5771.    Adr:LONGINT;
  5772. BEGIN
  5773.      ASM
  5774.         MOV EAX,[EBP+4]
  5775.         SUB EAX,5
  5776.         MOV Adr,EAX
  5777.      END;
  5778.      ff:=@f;
  5779.      InOutRes:=0;
  5780.      IF ff^.flags<>$6666 THEN
  5781.      BEGIN
  5782.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5783.           ELSE
  5784.           BEGIN
  5785.                InOutRes:=206;
  5786.                exit;
  5787.           END;
  5788.      END;
  5789.  
  5790.      IF ff^.Handle=$ffffffff THEN
  5791.      BEGIN
  5792.          InOutRes:=6; {Invalid handle}
  5793.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5794.          ELSE exit;
  5795.      END;
  5796.  
  5797.      pFEA:=ff^.EAS;
  5798.      WHILE pFEA<>NIL DO
  5799.      BEGIN
  5800.           freemem(pFEA^.aValue,pFEA^.cbValue);
  5801.           next:=pFEA^.next;
  5802.           dispose(pFEA);
  5803.           pFEA:=next;
  5804.      END;
  5805.      ff^.EAS:=NIL;
  5806. END;
  5807.  
  5808. {use with care}
  5809. PROCEDURE SetEAData(VAR f:FILE;EAData:PHOLDFEA);
  5810. VAR
  5811.    ff:^FileRec;
  5812.    dummy:PHOLDFEA;
  5813.    Adr:LONGINT;
  5814. BEGIN
  5815.      ASM
  5816.         MOV EAX,[EBP+4]
  5817.         SUB EAX,5
  5818.         MOV Adr,EAX
  5819.      END;
  5820.      ff:=@f;
  5821.      InOutRes:=0;
  5822.      IF ff^.flags<>$6666 THEN
  5823.      BEGIN
  5824.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5825.           ELSE
  5826.           BEGIN
  5827.                InOutRes:=206;
  5828.                exit;
  5829.           END;
  5830.      END;
  5831.  
  5832.      IF ff^.Handle=$ffffffff THEN
  5833.      BEGIN
  5834.          InOutRes:=6; {Invalid handle}
  5835.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5836.          ELSE exit;
  5837.      END;
  5838.  
  5839.      {Erase old EA Data}
  5840.      EraseEAData(f);
  5841.      ff^.EAS:=NIL;
  5842.  
  5843.      {copy the EA Data}
  5844.      WHILE EAData<>NIL DO
  5845.      BEGIN
  5846.           IF ff^.EAS=NIL THEN
  5847.           BEGIN
  5848.                new(ff^.EAS);
  5849.                dummy:=ff^.EAS;
  5850.           END
  5851.           ELSE
  5852.           BEGIN
  5853.                dummy:=ff^.EAS;
  5854.                WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  5855.                new(dummy^.next);
  5856.                dummy:=dummy^.next;
  5857.           END;
  5858.  
  5859.           move(EAData^,dummy^,sizeof(THOLDFEA));
  5860.           getmem(dummy^.aValue,dummy^.cbValue);
  5861.           move(EAData^.aValue^,dummy^.avalue^,dummy^.cbValue);
  5862.           dummy^.Next:=NIL;
  5863.  
  5864.           EAData:=EAData^.Next;
  5865.      END;
  5866. END;
  5867.  
  5868. {use with care !}
  5869. PROCEDURE DeleteEAData(VAR f:FILE);
  5870. VAR
  5871.    ff:^FileRec;
  5872.    pFEA:PHOLDFEA;
  5873.    Adr:LONGINT;
  5874. BEGIN
  5875.      ASM
  5876.         MOV EAX,[EBP+4]
  5877.         SUB EAX,5
  5878.         MOV Adr,EAX
  5879.      END;
  5880.      ff:=@f;
  5881.      InOutRes:=0;
  5882.      IF ff^.flags<>$6666 THEN
  5883.      BEGIN
  5884.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  5885.           ELSE
  5886.           BEGIN
  5887.                InOutRes:=206;
  5888.                exit;
  5889.           END;
  5890.      END;
  5891.  
  5892.      IF ff^.Handle=$ffffffff THEN
  5893.      BEGIN
  5894.          InOutRes:=6; {Invalid handle}
  5895.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5896.          ELSE exit;
  5897.      END;
  5898.  
  5899.      pFEA:=ff^.EAS;
  5900.      WHILE pFEA<>NIL DO
  5901.      BEGIN
  5902.           pFEA^.Deleted:=TRUE;
  5903.  
  5904.           pFEA:=pFEA^.Next;
  5905.      END;
  5906. END;
  5907.  
  5908.  
  5909.  
  5910.  
  5911. {Write extended attributes to an open file
  5912.  The file need not to be opened but assigned
  5913.  and the EA data must have been set using SetEAData
  5914.  If the file is opened its sharing rights should not
  5915.  conflict with exclusive write access}
  5916. PROCEDURE WriteEAData(VAR f:FILE);
  5917. VAR
  5918.    ff:^FileRec;
  5919.    pDL:PHOLDFEA;
  5920.    pHFEA:PHOLDFEA;
  5921.    eaopWrite:EAOP2;
  5922.    aBuf:ARRAY[0..MAX_GEA] OF CHAR;
  5923.    aPtr:^CSTRING;
  5924.    pFEA:PFEA2;
  5925.    usMemNeeded:LONGWORD;
  5926.    pulPtr:^LONGWORD;
  5927.    c:CSTRING;
  5928.    p:POINTER;
  5929.    Adr:LONGINT;
  5930. BEGIN
  5931.    ASM
  5932.       MOV EAX,[EBP+4]
  5933.       SUB EAX,5
  5934.       MOV Adr,EAX
  5935.    END;
  5936.    ff:=@f;
  5937.    pHFEA:=ff^.EAS;
  5938.    aPtr:=NIL;
  5939.    pFEA:=@aBuf[4];
  5940.    pulPtr:=@aBuf;
  5941.    c:=ff^.Name;
  5942.    InOutRes:=0;
  5943.  
  5944.    IF ff^.flags<>$6666 THEN
  5945.    BEGIN
  5946.         IF RaiseIOError THEN InvalidFileNameError(Adr)
  5947.         ELSE
  5948.         BEGIN
  5949.              InOutRes:=206;
  5950.              exit;
  5951.         END;
  5952.    END;
  5953.  
  5954.    IF ff^.Handle=$ffffffff THEN
  5955.    BEGIN
  5956.         InOutRes:=6; {Invalid handle}
  5957.         IF RaiseIOError THEN InOutError(InOutRes,Adr)
  5958.         ELSE exit;
  5959.    END;
  5960.  
  5961.    eaopWrite.fpFEA2List := @aBuf;
  5962.    pFEA^.fEA     := 0;
  5963.    pFEA^.cbValue := 0;
  5964.  
  5965.    pDL:=ff^.EAS;
  5966.    WHILE pDL<>NIL DO      // Clean out all the deleted EA names
  5967.    BEGIN
  5968.       IF pDL^.Deleted THEN
  5969.       BEGIN
  5970.            pFEA^.cbName := pDL^.cbName;
  5971.            pulPtr^:= sizeof(FEA2LIST) + pFEA^.cbName;
  5972.            pFEA^.szName:=pDL^.szName;
  5973.            pFEA^.oNextEntryOffset := 0; {last entry}
  5974.                                      // Delete EA's by saying cbValue=0
  5975.            {DosSetPathInfo(c,2,eaopWrite,sizeof(EAOP2),$10);}
  5976.            DosSetFileInfo(ff^.Handle,2,eaopWrite,sizeof(EAOP2));
  5977.       END;
  5978.       pDL := pDL^.next;
  5979.    END;
  5980.  
  5981.    WHILE pHFEA<>NIL DO      // Go through each HoldFEA
  5982.    BEGIN
  5983.       IF not pHFEA^.Deleted THEN
  5984.       BEGIN
  5985.            usMemNeeded := sizeof(FEA2LIST) + pHFEA^.cbName+1 +
  5986.                                  pHFEA^.cbValue;
  5987.            GetMem(aPtr, usMemNeeded);
  5988.  
  5989.            eaopWrite.fpFEA2List := POINTER(aPtr);  // Fill in eaop struct
  5990.            eaopWrite.fpFEA2List^.cbList := usMemNeeded;
  5991.  
  5992.            eaopWrite.fpFEA2List^.list[0].fEA     := pHFEA^.fEA;
  5993.            eaopWrite.fpFEA2List^.list[0].cbName  := pHFEA^.cbName;
  5994.            eaopWrite.fpFEA2List^.list[0].cbValue := pHFEA^.cbValue;
  5995.            eaopWrite.fpFEA2List^.list[0].oNextEntryOffset := 0; {last entry}
  5996.  
  5997.            CSTRING(eaopWrite.fpFEA2List^.list[0].szName):=pHFEA^.szName;
  5998.            p:=@eaopWrite.fpFEA2List^.list[0].szName;
  5999.            inc(p,pHFEA^.cbName+1);
  6000.            move(pHFEA^.aValue^,p^,pHFEA^.cbValue);
  6001.  
  6002.            {InOutRes := DosSetPathInfo(c,2,eaopWrite,sizeof(EAOP2),$10);}
  6003.            {InOutRes:=}DosSetFileInfo(ff^.Handle,2,eaopWrite,sizeof(EAOP2));
  6004.  
  6005.            {IF InOutRes<>0 THEN
  6006.            BEGIN
  6007.                  IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6008.                  ELSE exit;
  6009.            END;}
  6010.  
  6011.            FreeMem(aPtr,usMemNeeded); // Free up the FEALIST struct
  6012.       END;
  6013.  
  6014.       pHFEA := pHFEA^.next;
  6015.    END;
  6016. END;
  6017. {$ENDIF}
  6018. {$IFDEF WIN95}
  6019. CONST
  6020.     GENERIC_READ            =$80000000;
  6021.     GENERIC_WRITE           =$40000000;
  6022.  
  6023. CONST
  6024.     FILE_SHARE_READ         =$00000001;
  6025.     FILE_SHARE_WRITE        =$00000002;
  6026.  
  6027.     OPEN_EXISTING           =3;
  6028.     FILE_ATTRIBUTE_NORMAL   =$00000080;
  6029.  
  6030. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  6031. VAR
  6032.    ff:^FileRec;
  6033.    c:CSTRING;
  6034.    e:EFileNotFound;
  6035.    size,Temp:LONGWORD;
  6036.    SaveIoError:BOOLEAN;
  6037.    Adr:LONGINT;
  6038.    {SA:SECURITY_ATTRIBUTES;}
  6039. BEGIN
  6040.      ASM
  6041.         MOV EAX,[EBP+4]
  6042.         SUB EAX,5
  6043.         MOV Adr,EAX
  6044.      END;
  6045.      InOutRes:=0;
  6046.      ff:=@f;
  6047.      ff^.RecSize:=recsize;
  6048.      IF ff^.flags<>$6666 THEN
  6049.      BEGIN
  6050.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6051.           ELSE
  6052.           BEGIN
  6053.                InOutRes:=206;
  6054.                exit;
  6055.           END;
  6056.      END;
  6057.  
  6058.      IF ff^.Handle<>$ffffffff THEN
  6059.      BEGIN
  6060.          {Close file first}
  6061.          SaveIoError:=RaiseIOError;
  6062.          RaiseIOError:=FALSE;
  6063.          Close(f);
  6064.          RaiseIoError:=SaveIoError;
  6065.          (*InOutRes:=85; {File already assigned}
  6066.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6067.          ELSE exit;*)
  6068.      END;
  6069.  
  6070.      ff^.Buffer:=NIL;
  6071.      c:=ff^.Name;
  6072.  
  6073.      {open and read extended attributes}
  6074.      {
  6075.      SA.nLength:=sizeof(SA);
  6076.      SA.lpSecurityDescriptor:=Nil;
  6077.      SA.bInheritHandle:=True;
  6078.      }
  6079.      ff^.Handle:=CreateFile(c,FileMode AND not 3,FileMode AND 3,Nil{SA},OPEN_EXISTING,$00000080,0);
  6080.      IF ff^.Handle=-1 THEN
  6081.      BEGIN
  6082.           If ff^.Handle=-1 Then
  6083.           Begin
  6084.                InOutRes:=GetLastError;
  6085.                ff^.Handle:=$ffffffff;
  6086.                IF RaiseIOError THEN
  6087.                BEGIN
  6088.                     e.Create('File not found (EFileNotFound)');
  6089.                     e.CameFromRTL:=TRUE;
  6090.                     e.RTLExcptAddr:=POINTER(Adr);
  6091.                     e.ErrorCode:=InOutRes;
  6092.                     RAISE e;
  6093.                END
  6094.                ELSE exit;
  6095.           End;
  6096.      END;
  6097.  
  6098.      ff^.EAS:=NIL;
  6099.      ff^.Mode:=FileMode;
  6100.      ff^.Reserved1:=0;
  6101.  
  6102.      {Set the buffer values}
  6103.  
  6104.      size:=FileFileSize(f);
  6105.      IF InOutRes<>0 THEN
  6106.      BEGIN
  6107.           ff^.Handle:=$ffffffff;
  6108.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6109.           ELSE exit;
  6110.      END;
  6111.  
  6112.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  6113.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  6114.  
  6115.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  6116.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  6117.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  6118.      FileBlockIO(f,0,readmode,Temp);
  6119.      IF InOutRes<>0 THEN
  6120.      BEGIN
  6121.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6122.           ELSE exit;
  6123.      END;
  6124.      ff^.Block:=0;
  6125.      ff^.Offset:=0;
  6126. END;
  6127. {$ENDIF}
  6128.  
  6129. {$IFDEF OS2}
  6130. PROCEDURE Close(VAR f:FILE);
  6131. VAR
  6132.    ff:^FileRec;
  6133.    Temp:LONGWORD;
  6134.    t:BYTE;
  6135.    Adr:LONGINT;
  6136. LABEL l;
  6137. BEGIN
  6138.      ASM
  6139.         MOV EAX,[EBP+4]
  6140.         SUB EAX,5
  6141.         MOV Adr,EAX
  6142.      END;
  6143.      ff:=@f;
  6144.      IF ff^.flags<>$6666 THEN
  6145.      BEGIN
  6146.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6147.           ELSE
  6148.           BEGIN
  6149.                InOutRes:=206;
  6150.                exit;
  6151.           END;
  6152.      END;
  6153.  
  6154.      IF ff^.Handle=$ffffffff THEN
  6155.      BEGIN
  6156.           InOutRes:=6; {Invalid handle}
  6157.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6158.           ELSE exit;
  6159.      END;
  6160.  
  6161.      IF ff^.Buffer=NIL THEN
  6162.      BEGIN
  6163.           InOutRes:=DosClose(ff^.Handle);
  6164.           IF InOutRes<>0 THEN
  6165.           BEGIN
  6166.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6167.               ELSE exit;
  6168.           END;
  6169.           ff^.Mode:=0;            {closed}
  6170.           ff^.Flags:=$6666;       {File successfully assigned}
  6171.           ff^.Handle:=$ffffffff;  {No valid handle}
  6172.           exit;
  6173.      END;
  6174.  
  6175.      InOutRes:=0;
  6176.      {Write buffer to file}
  6177.      IF ff^.changed THEN
  6178.      BEGIN
  6179.           ff^.changed:=FALSE;
  6180.           FileBlockIO(F,ff^.block,WriteMode,Temp);
  6181.           IF InOutRes<>0 THEN
  6182.           BEGIN
  6183.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6184.               ELSE exit;
  6185.           END;
  6186.      END;
  6187.  
  6188.      {Write EA's to the file}
  6189.      WriteEAData(f);
  6190.  
  6191.      FOR t:=1 TO OpenedFilesCount DO
  6192.      BEGIN
  6193.           IF OpenedFiles[t]=ff^.Handle THEN
  6194.           BEGIN
  6195.                move(OpenedFiles[t+1],OpenedFiles[t],(50-t)*4);
  6196.                dec(OpenedFilesCount);
  6197.                goto l;
  6198.           END;
  6199.      END;
  6200. l:
  6201.      InOutRes:=DosClose(ff^.Handle);
  6202.      IF InOutRes<>0 THEN
  6203.      BEGIN
  6204.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6205.           ELSE exit;
  6206.      END;
  6207.  
  6208.      EraseEAData(f);
  6209.      ff^.Mode:=0;            {closed}
  6210.      ff^.Flags:=$6666;       {File successfully assigned}
  6211.      ff^.Handle:=$ffffffff;  {No valid handle}
  6212.  
  6213.      {free file buffers}
  6214.      IF ff^.Buffer<>NIL THEN FreeMem(ff^.Buffer,ff^.MaxCacheMem);
  6215.      ff^.Buffer:=NIL;
  6216. END;
  6217.  
  6218. PROCEDURE CloseAllOpenedFiles;
  6219. VAR t:BYTE;
  6220. BEGIN
  6221.      FOR t:=1 TO OpenedFilesCount DO DosClose(OpenedFiles[t]);
  6222.      OpenedFilesCount:=0;
  6223. END;
  6224. {$ENDIF}
  6225. {$IFDEF WIN95}
  6226. PROCEDURE Close(VAR f:FILE);
  6227. VAR
  6228.    ff:^FileRec;
  6229.    Temp:LONGWORD;
  6230.    t:BYTE;
  6231.    Adr:LONGINT;
  6232. LABEL l;
  6233. BEGIN
  6234.      ASM
  6235.         MOV EAX,[EBP+4]
  6236.         SUB EAX,5
  6237.         MOV Adr,EAX
  6238.      END;
  6239.      InOutRes:=0;
  6240.      ff:=@f;
  6241.      IF ff^.flags<>$6666 THEN
  6242.      BEGIN
  6243.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6244.           ELSE
  6245.           BEGIN
  6246.                InOutRes:=206;
  6247.                exit;
  6248.           END;
  6249.      END;
  6250.  
  6251.      IF ff^.Handle=$ffffffff THEN
  6252.      BEGIN
  6253.           InOutRes:=6; {Invalid handle}
  6254.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6255.           ELSE exit;
  6256.      END;
  6257.  
  6258.      IF ff^.Buffer=NIL THEN
  6259.      BEGIN
  6260.           IF not CloseHandle(ff^.Handle) THEN
  6261.           BEGIN
  6262.               InOutRes:=GetLastError;
  6263.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6264.               ELSE exit;
  6265.           END;
  6266.           ff^.Mode:=0;            {closed}
  6267.           ff^.Flags:=$6666;       {File successfully assigned}
  6268.           ff^.Handle:=$ffffffff;  {No valid handle}
  6269.           exit;
  6270.      END;
  6271.  
  6272.      InOutRes:=0;
  6273.      {Write buffer to file}
  6274.      IF ff^.changed THEN
  6275.      BEGIN
  6276.           ff^.changed:=FALSE;
  6277.           FileBlockIO(F,ff^.block,WriteMode,Temp);
  6278.           IF InOutRes<>0 THEN
  6279.           BEGIN
  6280.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6281.               ELSE exit;
  6282.           END;
  6283.      END;
  6284.  
  6285.      FOR t:=1 TO OpenedFilesCount DO
  6286.      BEGIN
  6287.           IF OpenedFiles[t]=ff^.Handle THEN
  6288.           BEGIN
  6289.                move(OpenedFiles[t+1],OpenedFiles[t],(50-t)*4);
  6290.                dec(OpenedFilesCount);
  6291.                goto l;
  6292.           END;
  6293.      END;
  6294. l:
  6295.      IF not CloseHandle(ff^.Handle) THEN
  6296.      BEGIN
  6297.           InOutRes:=GetLastError;
  6298.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6299.           ELSE exit;
  6300.      END;
  6301.  
  6302.      ff^.Mode:=0;            {closed}
  6303.      ff^.Flags:=$6666;       {File successfully assigned}
  6304.      ff^.Handle:=$ffffffff;  {No valid handle}
  6305.  
  6306.      {free file buffers}
  6307.      IF ff^.Buffer<>NIL THEN FreeMem(ff^.Buffer,ff^.MaxCacheMem);
  6308.      ff^.Buffer:=NIL;
  6309. END;
  6310.  
  6311. PROCEDURE CloseAllOpenedFiles;
  6312. VAR t:BYTE;
  6313. BEGIN
  6314.      FOR t:=1 TO OpenedFilesCount DO CloseHandle(OpenedFiles[t]);
  6315.      OpenedFilesCount:=0;
  6316. END;
  6317. {$ENDIF}
  6318.  
  6319. PROCEDURE CloseFile(VAR f:FILE);
  6320. BEGIN
  6321.      Close(f);
  6322. END;
  6323.  
  6324. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  6325. VAR
  6326.    ff:^FileRec;
  6327.    pBlock:LONGWORD;
  6328.    POffset:LONGWORD;
  6329.    Temp:LONGWORD;
  6330.    Adr:LONGINT;
  6331. BEGIN
  6332.      ASM
  6333.         MOV EAX,[EBP+4]
  6334.         SUB EAX,5
  6335.         MOV Adr,EAX
  6336.      END;
  6337.      ff:=@f;
  6338.      IF ff^.flags<>$6666 THEN
  6339.      BEGIN
  6340.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6341.           ELSE
  6342.           BEGIN
  6343.                InOutRes:=206;
  6344.                exit;
  6345.           END;
  6346.      END;
  6347.  
  6348.      IF ff^.Handle=$ffffffff THEN
  6349.      BEGIN
  6350.           InOutRes:=6; {Invalid handle}
  6351.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6352.           ELSE exit;
  6353.      END;
  6354.  
  6355.      n:=n*ff^.RecSize;
  6356.  
  6357.      CASE SeekMode OF
  6358.         Seek_Current:inc(n,FilePos(f)*ff^.RecSize);   //Seek_Current
  6359.         Seek_End:inc(n,FileSize(f)*ff^.RecSize);      //Seek_End
  6360.      END;
  6361.  
  6362.      IF ff^.Buffer=NIL THEN
  6363.      BEGIN
  6364.           {$IFDEF OS2}
  6365.           InOutRes:=DosSetFilePtr(ff^.Handle,n,Seek_Begin,Temp);
  6366.           IF RaiseIOError THEN InOutError(InOutRes,Adr);
  6367.           {$ENDIF}
  6368.           {$IFDEF WIN95}
  6369.           Temp:=SetFilePointer(ff^.Handle,n,NIL,0);  //Seek from file BEGIN
  6370.           IF Temp=$ffffffff THEN
  6371.           BEGIN
  6372.               InOutRes:=GetLastError;
  6373.               IF RaiseIOError THEN InOutError(InOutRes,Adr);
  6374.           END;
  6375.           {$ENDIF}
  6376.           exit;
  6377.      END;
  6378.  
  6379.      InOutRes:=0;
  6380.      pblock:=n DIV ff^.maxcachemem;
  6381.      poffset:=n MOD ff^.maxcachemem;
  6382.      IF n>ff^.loffset+ff^.maxcachemem*ff^.lblock THEN
  6383.      BEGIN
  6384.           IF ff^.Mode AND (fmOutput OR fmInOut)<>0 THEN
  6385.           BEGIN
  6386.                ff^.loffset:=poffset;
  6387.                ff^.lblock:=pblock;
  6388.           END
  6389.           ELSE
  6390.           BEGIN
  6391.                InOutRes:=38;  {Illegal pos}
  6392.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6393.                ELSE exit;
  6394.           END;
  6395.      END;
  6396.      IF pblock<>ff^.block THEN
  6397.      BEGIN
  6398.           FileBlockIO(f,pblock,ReadMode,Temp);
  6399.           IF InOutRes<>0 THEN
  6400.           BEGIN
  6401.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6402.               ELSE exit;
  6403.           END;
  6404.      END;
  6405.      ff^.offset:=poffset;
  6406.      ff^.block:=pblock;
  6407. END;
  6408.  
  6409.  
  6410. FUNCTION FilePos(var f:file):LongWord;
  6411. VAR
  6412.    ff:^FileRec;
  6413.    result:LONGWORD;
  6414.    Adr:LONGINT;
  6415. BEGIN
  6416.      ASM
  6417.         MOV EAX,[EBP+4]
  6418.         SUB EAX,5
  6419.         MOV Adr,EAX
  6420.      END;
  6421.      ff:=@f;
  6422.      IF ff^.flags<>$6666 THEN
  6423.      BEGIN
  6424.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6425.           ELSE
  6426.           BEGIN
  6427.                InOutRes:=206;
  6428.                exit;
  6429.           END;
  6430.      END;
  6431.  
  6432.      IF ff^.Handle=$ffffffff THEN
  6433.      BEGIN
  6434.           InOutRes:=6; {Invalid handle}
  6435.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6436.           ELSE exit;
  6437.      END;
  6438.  
  6439.      InOutRes:=0;
  6440.      result:=ff^.block*ff^.maxcachemem+ff^.offset;
  6441.      FilePos:=result DIV ff^.RecSize;
  6442. END;
  6443.  
  6444. FUNCTION Eof(var f:file):Boolean;
  6445. VAR
  6446.    size:LONGWORD;
  6447.    ff:^FileRec;
  6448.    SaveIO:BOOLEAN;
  6449.    Adr:LONGINT;
  6450. BEGIN
  6451.      ASM
  6452.         MOV EAX,[EBP+4]
  6453.         SUB EAX,5
  6454.         MOV Adr,EAX
  6455.         MOV EAX,f
  6456.         CMP EAX,0
  6457.         JNE !Eof_ok
  6458.         MOV EAX,OFFSET(SYSTEM.Input)
  6459.         MOV f,EAX
  6460. !Eof_ok:
  6461.      END;
  6462.      ff:=@f;
  6463.  
  6464.      IF ff^.flags<>$6666 THEN
  6465.      BEGIN
  6466.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6467.           ELSE
  6468.           BEGIN
  6469.                InOutRes:=206;
  6470.                exit;
  6471.           END;
  6472.      END;
  6473.  
  6474.      IF ff^.Handle=$ffffffff THEN
  6475.      BEGIN
  6476.           InOutRes:=6; {Invalid handle}
  6477.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6478.           ELSE exit;
  6479.      END;
  6480.  
  6481.      IF ff^.Reserved1 AND 1=1 THEN
  6482.      BEGIN
  6483.           eof:=TRUE;
  6484.           exit;
  6485.      END;
  6486.  
  6487.      IF ff^.Buffer=NIL THEN
  6488.      BEGIN
  6489.           InOutRes:=0;
  6490.           SaveIO:=RaiseIOError;
  6491.           RaiseIOError:=FALSE;
  6492.           size:=FileFileSize(f);
  6493.           RaiseIOError:=SaveIO;
  6494.           IF InOutRes<>0 THEN
  6495.           BEGIN
  6496.                {$IFDEF OS2}
  6497.                IF ((ff^.Handle=0{Input})OR(ff^.Handle=1{Output})) THEN
  6498.                {$ELSE}
  6499.                IF ((ff^.Handle=GetStdHandle(-10){Input})OR(ff^.Handle=GetStdHandle(-11){Output})) THEN
  6500.                {$ENDIF}
  6501.                BEGIN
  6502.                     Eof:=FALSE;
  6503.                     exit;
  6504.                END
  6505.                ELSE
  6506.                BEGIN
  6507.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6508.                     ELSE exit;
  6509.                END;
  6510.           END
  6511.           ELSE
  6512.           BEGIN
  6513.                Eof:=Size=FileFilePos(f);
  6514.                IF InOutRes<>0 THEN
  6515.                BEGIN
  6516.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6517.                     ELSE exit;
  6518.                END;
  6519.           END;
  6520.           exit;
  6521.      END;
  6522.  
  6523.      InOutRes:=0;
  6524.      Eof:=(ff^.offset=ff^.loffset)AND(ff^.block=ff^.lblock);
  6525. END;
  6526.  
  6527. FUNCTION Eoln(VAR F:Text):Boolean;
  6528. VAR
  6529.     Adr:LONGINT;
  6530.     fi:^FileRec;
  6531.     Offset:LONGINT;
  6532.     Value:BYTE;
  6533.     SaveIoError:BOOLEAN;
  6534.     Res:LONGWORD;
  6535. BEGIN
  6536.      ASM
  6537.         MOV EAX,[EBP+4]
  6538.         SUB EAX,5
  6539.         MOV Adr,EAX
  6540.         MOV EAX,f
  6541.         CMP EAX,0
  6542.         JNE !Eoln_ok
  6543.         MOV EAX,OFFSET(SYSTEM.Input)
  6544.         MOV f,EAX
  6545. !Eoln_ok:
  6546.      END;
  6547.  
  6548.      fi:=@f;
  6549.  
  6550.      IF fi^.flags<>$6666 THEN
  6551.      BEGIN
  6552.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6553.           ELSE
  6554.           BEGIN
  6555.                InOutRes:=206;
  6556.                exit;
  6557.           END;
  6558.      END;
  6559.  
  6560.      IF fi^.Handle=$ffffffff THEN
  6561.      BEGIN
  6562.          InOutRes:=6; {Invalid handle}
  6563.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6564.          ELSE exit;
  6565.      END;
  6566.  
  6567.      IF eof(f) THEN
  6568.      BEGIN
  6569.           result:=TRUE;
  6570.           exit;
  6571.      END;
  6572.  
  6573.      Offset:=fi^.Offset;
  6574.  
  6575.      IF fi^.Buffer=NIL THEN
  6576.      BEGIN
  6577.           IF lo(fi^.BufferBytes)=1 THEN
  6578.           BEGIN
  6579.                Value:=Hi(fi^.BufferBytes);
  6580.           END
  6581.           ELSE
  6582.           BEGIN
  6583.                SaveIOError:=RaiseIOError;
  6584.                RaiseIOError:=FALSE;
  6585.                BlockRead(f,Value,1,Res);
  6586.                Seek(f,FilePos(f)-1);
  6587.                RaiseIOError:=SaveIOError;
  6588.                IF Res=0 THEN Value:=26; {EOF}
  6589.           END;
  6590.      END
  6591.      ELSE value:=fi^.Buffer^[Offset];
  6592.  
  6593.      IF value IN [13,10,26] THEN result:=TRUE
  6594.      ELSE result:=FALSE;
  6595. END;
  6596.  
  6597.  
  6598. FUNCTION FileSize(var f:file):LongWord;
  6599. VAR
  6600.    result:LONGWORD;
  6601.    ff:^FileRec;
  6602.    Adr:LONGINT;
  6603. BEGIN
  6604.      ASM
  6605.         MOV EAX,[EBP+4]
  6606.         SUB EAX,5
  6607.         MOV Adr,EAX
  6608.      END;
  6609.      ff:=@f;
  6610.      IF ff^.flags<>$6666 THEN
  6611.      BEGIN
  6612.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6613.           ELSE
  6614.           BEGIN
  6615.                InOutRes:=206;
  6616.                exit;
  6617.           END;
  6618.      END;
  6619.  
  6620.      IF ff^.Handle=$ffffffff THEN
  6621.      BEGIN
  6622.           InOutRes:=6; {Invalid handle}
  6623.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6624.           ELSE exit;
  6625.      END;
  6626.  
  6627.      InOutRes:=0;
  6628.      result:=ff^.lblock*ff^.maxcachemem+ff^.loffset;
  6629.      FileSize:=result DIV ff^.RecSize;
  6630. END;
  6631.  
  6632. {$IFDEF OS2}
  6633. PROCEDURE Truncate(VAR f:FILE);
  6634. VAR
  6635.    ff:^FileRec;
  6636.    Adr:LONGINT;
  6637. BEGIN
  6638.      ASM
  6639.         MOV EAX,[EBP+4]
  6640.         SUB EAX,5
  6641.         MOV Adr,EAX
  6642.      END;
  6643.      ff:=@f;
  6644.      IF ff^.flags<>$6666 THEN
  6645.      BEGIN
  6646.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6647.           ELSE
  6648.           BEGIN
  6649.                InOutRes:=206;
  6650.                exit;
  6651.           END;
  6652.      END;
  6653.      InOutRes:=DosSetFileSize(ff^.Handle,FilePos(f));
  6654.      IF InOutRes<>0 THEN
  6655.      BEGIN
  6656.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6657.           ELSE exit;
  6658.      END;
  6659.      ff^.lOffset:=ff^.Offset;
  6660.      ff^.lBlock:=ff^.Block;
  6661. END;
  6662. {$ENDIF}
  6663. {$IFDEF WIN95}
  6664. PROCEDURE Truncate(VAR f:FILE);
  6665. VAR
  6666.    ff:^FileRec;
  6667.    Adr:LONGINT;
  6668. BEGIN
  6669.      ASM
  6670.         MOV EAX,[EBP+4]
  6671.         SUB EAX,5
  6672.         MOV Adr,EAX
  6673.      END;
  6674.      ff:=@f;
  6675.      IF ff^.flags<>$6666 THEN
  6676.      BEGIN
  6677.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  6678.           ELSE
  6679.           BEGIN
  6680.                InOutRes:=206;
  6681.                exit;
  6682.           END;
  6683.      END;
  6684.      IF not SetEndOfFile(ff^.Handle) THEN
  6685.      BEGIN
  6686.           InOutRes:=GetLastError;
  6687.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6688.           ELSE exit;
  6689.      END;
  6690.      ff^.lOffset:=ff^.Offset;
  6691.      ff^.lBlock:=ff^.Block;
  6692. END;
  6693. {$ENDIF}
  6694.  
  6695. PROCEDURE Append(VAR f:Text);
  6696. VAR
  6697.    l:LONGWORD;
  6698.    saveseek:LONGWORD;
  6699.    Adr:LONGINT;
  6700.  
  6701.    FUNCTION PrecChar:Char;
  6702.    BEGIN
  6703.         Seek(f,FilePos(f)-1);
  6704.         BlockRead(f,Result,1);
  6705.    END;
  6706. BEGIN
  6707.      ASM
  6708.         MOV EAX,[EBP+4]
  6709.         SUB EAX,5
  6710.         MOV Adr,EAX
  6711.      END;
  6712.      Reset(f,1);
  6713.      IF InOutRes<>0 THEN
  6714.      BEGIN
  6715.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6716.           ELSE exit;
  6717.      END;
  6718.  
  6719.      l:=Filesize(f);
  6720.      IF InOutRes=0 THEN
  6721.      BEGIN
  6722.           SaveSeek:=seekmode;
  6723.           seekmode:=0; {from file BEGIN}
  6724.           Seek(f,l);
  6725.           seekmode:=saveseek;
  6726.      END
  6727.      ELSE
  6728.      BEGIN
  6729.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6730.           ELSE exit;
  6731.      END;
  6732.  
  6733.      SaveSeek:=seekmode;
  6734.      seekmode:=0; {from file BEGIN}
  6735.      WHILE (FilePos(f)>1)AND(PrecChar=^Z) DO Seek(f,Filepos(f)-1);
  6736.      seekmode:=saveseek;
  6737. END;
  6738.  
  6739. {$IFDEF OS2}
  6740. PROCEDURE ChDir(CONST path:STRING);
  6741. VAR c:CSTRING;
  6742.     Adr:LONGINT;
  6743.     s:STRING;
  6744. LABEL doit;
  6745. BEGIN
  6746.      ASM
  6747.         MOV EAX,[EBP+4]
  6748.         SUB EAX,5
  6749.         MOV Adr,EAX
  6750.      END;
  6751.  
  6752.      IF length(Path)=2 THEN IF Path[2]=':' THEN
  6753.      BEGIN
  6754.           InOutRes:=DosSetDefaultDisk(ord(upcase(path[1]))-64);
  6755.           IF InOutRes<>0 THEN
  6756.           BEGIN
  6757.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6758.                ELSE exit;
  6759.           END;
  6760.           GetDir(0,s);
  6761.           ChDir(s);
  6762.           exit;
  6763.      END;
  6764.  
  6765.      IF POS(':\',path)=2 THEN {drive letter preceding}
  6766.      BEGIN
  6767.           InOutRes:=DosSetDefaultDisk(ord(upcase(path[1]))-64);
  6768.           IF InOutRes<>0 THEN
  6769.           BEGIN
  6770.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6771.                ELSE exit;
  6772.           END;
  6773.           c:=upcase(path[1])+':\';
  6774.           InOutRes:=DosSetCurrentDir(c);  {move to root directory}
  6775.           IF InOutRes<>0 THEN
  6776.           BEGIN
  6777.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6778.                ELSE exit;
  6779.           END;
  6780.           s:=Path;
  6781.           delete(s,1,3);
  6782.           IF s='' THEN exit;
  6783.           c:=s;
  6784.           goto doit;
  6785.      END;
  6786.  
  6787.      IF path[length(Path)]='\' THEN
  6788.      BEGIN
  6789.           s:=Path;
  6790.           dec(s[0]);
  6791.           c:=s;
  6792.      END
  6793.      ELSE c:=path;
  6794. doit:
  6795.      InOutRes:=DosSetCurrentDir(c);
  6796.      IF InOutRes<>0 THEN
  6797.      BEGIN
  6798.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6799.           ELSE exit;
  6800.      END;
  6801. END;
  6802.  
  6803. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  6804. VAR
  6805.    c:CSTRING;
  6806.    drivemap,curdrive,MaxLen:LONGWORD;
  6807.    Adr:LONGINT;
  6808. BEGIN
  6809.      ASM
  6810.         MOV EAX,[EBP+4]
  6811.         SUB EAX,5
  6812.         MOV Adr,EAX
  6813.      END;
  6814.  
  6815.      IF Drive=0 THEN
  6816.      BEGIN
  6817.           {query current drive}
  6818.           InOutRes:=DosQueryCurrentDisk(curdrive,drivemap);
  6819.           IF InOutRes<>0 THEN
  6820.           BEGIN
  6821.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6822.                ELSE exit;
  6823.           END;
  6824.      END
  6825.      ELSE curdrive:=drive;
  6826.  
  6827.      MaxLen:=250;
  6828.      InOutRes:=DosQueryCurrentDir(curdrive,c,MaxLen);
  6829.      IF InOutRes<>0 THEN
  6830.      BEGIN
  6831.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6832.           ELSE exit;
  6833.      END;
  6834.  
  6835.      path:=chr(curDrive+64)+':\'+c;
  6836. END;
  6837.  
  6838. PROCEDURE RmDir(CONST dir:STRING);
  6839. VAR
  6840.    c:CSTRING;
  6841.    Adr:LONGINT;
  6842. BEGIN
  6843.      ASM
  6844.         MOV EAX,[EBP+4]
  6845.         SUB EAX,5
  6846.         MOV Adr,EAX
  6847.      END;
  6848.      c:=Dir;
  6849.      InOutRes:=DosDeleteDir(c);
  6850.      IF InOutRes<>0 THEN
  6851.      BEGIN
  6852.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6853.           ELSE exit;
  6854.      END;
  6855. END;
  6856.  
  6857. PROCEDURE MkDir(CONST dir:STRING);
  6858. VAR
  6859.    c:CSTRING;
  6860.    Adr:LONGINT;
  6861. BEGIN
  6862.      c:=dir;
  6863.      InOutRes:=DosCreateDir(c,NIL);
  6864.      IF InOutRes<>0 THEN
  6865.      BEGIN
  6866.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6867.           ELSE exit;
  6868.      END;
  6869. END;
  6870. {$ENDIF}
  6871. {$IFDEF WIN95}
  6872. PROCEDURE ChDir(CONST path:STRING);
  6873. VAR c:CSTRING;
  6874.     Adr:LONGINT;
  6875. BEGIN
  6876.      ASM
  6877.         MOV EAX,[EBP+4]
  6878.         SUB EAX,5
  6879.         MOV Adr,EAX
  6880.      END;
  6881.      InOutRes:=0;
  6882.      c:=path;
  6883.      IF not SetCurrentDirectory(c) THEN
  6884.      BEGIN
  6885.           InOutRes:=GetLastError;
  6886.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6887.           ELSE exit;
  6888.      END;
  6889. END;
  6890.  
  6891. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  6892. VAR
  6893.    c:CSTRING;
  6894.    Adr:LONGINT;
  6895.    OldRaise:BOOLEAN;
  6896.    temp:String;
  6897. BEGIN
  6898.      ASM
  6899.         MOV EAX,[EBP+4]
  6900.         SUB EAX,5
  6901.         MOV Adr,EAX
  6902.      END;
  6903.      IF Drive<>0 THEN
  6904.      BEGIN
  6905.           GetDir(0,Temp);
  6906.           OldRaise:=RaiseIOError;
  6907.           RaiseIOError:=FALSE;
  6908.           temp:=chr(drive+64)+':';
  6909.           ChDir(temp);
  6910.           RaiseIOError:=OldRaise;
  6911.           IF InOutRes<>0 THEN
  6912.           BEGIN
  6913.                InOutRes:=2;
  6914.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6915.                ELSE exit;
  6916.           END;
  6917.           GetDir(0,path);
  6918.           ChDir(temp);
  6919.           exit;
  6920.      END;
  6921.  
  6922.      IF GetCurrentDirectory(255,c)=0 THEN
  6923.      BEGIN
  6924.           InOutRes:=1;
  6925.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6926.           ELSE exit;
  6927.      END;
  6928.      path:=c;
  6929. END;
  6930.  
  6931. PROCEDURE RmDir(CONST dir:STRING);
  6932. VAR
  6933.    c:CSTRING;
  6934.    Adr:LONGINT;
  6935. BEGIN
  6936.      ASM
  6937.         MOV EAX,[EBP+4]
  6938.         SUB EAX,5
  6939.         MOV Adr,EAX
  6940.      END;
  6941.      c:=Dir;
  6942.      IF not RemoveDirectory(c) THEN
  6943.      BEGIN
  6944.           InOutRes:=GetLastError;
  6945.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6946.           ELSE exit;
  6947.      END;
  6948. END;
  6949.  
  6950. PROCEDURE MkDir(CONST dir:STRING);
  6951. VAR
  6952.    c:CSTRING;
  6953.    Adr:LONGINT;
  6954. BEGIN
  6955.      ASM
  6956.         MOV EAX,[EBP+4]
  6957.         SUB EAX,5
  6958.         MOV Adr,EAX
  6959.      END;
  6960.      c:=dir;
  6961.      IF not CreateDirectory(c,NIL) THEN
  6962.      BEGIN
  6963.           InOutRes:=GetLastError;
  6964.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  6965.           ELSE exit;
  6966.      END;
  6967. END;
  6968.  
  6969. {$ENDIF}
  6970.  
  6971. PROCEDURE FileExpand(VAR f:FILE);
  6972. VAR
  6973.    ff:^FileRec;
  6974. BEGIN
  6975.      ff:=@f;
  6976.      inc(ff^.LOffset);
  6977.      IF ff^.LOffset=ff^.MaxCacheMem THEN
  6978.      BEGIN
  6979.           inc(ff^.LBlock);
  6980.           ff^.LOffset:=0;
  6981.      END;
  6982. END;
  6983.  
  6984. {$IFDEF OS2}
  6985. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  6986. VAR
  6987.    ff:^FileRec;
  6988.    pp:P_FileBuffer;
  6989.    t:LONGWORD;
  6990.    Temp:LONGWORD;
  6991.    Offset,Size:LONGWORD;
  6992.    OldBlock,OldOfs:LONGINT;
  6993.    MaxCacheMem:LONGWORD;
  6994.    Adr:LONGINT;
  6995.    TempResult:LONGINT;
  6996. BEGIN
  6997.      ASM
  6998.         MOV EAX,result
  6999.         CMP EAX,0        //result var present
  7000.         JNE !prr
  7001.         LEA EAX,TempResult
  7002.         MOV result,EAX
  7003. !prr:
  7004.      END;
  7005.  
  7006.      IF Count=0 THEN
  7007.      BEGIN
  7008.           result:=0;
  7009.           exit;
  7010.      END;
  7011.  
  7012.      ASM
  7013.         MOV EAX,[EBP+4]
  7014.         SUB EAX,5
  7015.         MOV Adr,EAX
  7016.      END;
  7017.      ff:=@f;
  7018.      pp:=@Buf;
  7019.      InOutRes:=0;
  7020.  
  7021.      IF ff^.flags<>$6666 THEN
  7022.      BEGIN
  7023.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7024.           ELSE
  7025.           BEGIN
  7026.                InOutRes:=206;
  7027.                exit;
  7028.           END;
  7029.      END;
  7030.  
  7031.      IF ff^.Handle=$ffffffff THEN
  7032.      BEGIN
  7033.          InOutRes:=6; {Invalid handle}
  7034.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7035.          ELSE exit;
  7036.      END;
  7037.  
  7038.      IF ff^.Buffer=NIL THEN
  7039.      BEGIN
  7040.           InOutRes:=DosRead(ff^.Handle,pp^,Count*ff^.RecSize,result);
  7041.           IF InOutRes<>0 THEN
  7042.           BEGIN
  7043.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7044.                ELSE exit;
  7045.           END;
  7046.           exit;
  7047.      END;
  7048.  
  7049.      result:=0;
  7050.      Offset:=ff^.Offset;
  7051.      Size:=Count*ff^.RecSize;
  7052.      MaxCacheMem:=ff^.MaxCacheMem;
  7053.  
  7054.      IF Size>MaxCacheMem THEN
  7055.      BEGIN
  7056.           {Block ist größer als Cache}
  7057.           IF (ff^.Block*MaxCacheMem)+Offset+Size>(ff^.LBlock*MaxCacheMem)+ff^.LOffset THEN
  7058.             Size:=((ff^.LBlock*MaxCacheMem)+ff^.LOffset)-
  7059.                   ((ff^.Block*MaxCacheMem)+Offset);
  7060.  
  7061.           IF ff^.Changed THEN
  7062.           BEGIN
  7063.                ff^.Changed:=FALSE;
  7064.                OldBlock:=ff^.LBlock;    {temporaray save}
  7065.                OldOfs:=ff^.LOffset;
  7066.                ff^.LBlock:=ff^.Block;
  7067.                ff^.LOffset:=Offset;
  7068.                {alten Block Schreiben}
  7069.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  7070.                IF InOutRes<>0 THEN
  7071.                BEGIN
  7072.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7073.                     ELSE exit;
  7074.                END;
  7075.                ff^.LBlock:=OldBlock;
  7076.                ff^.LOffset:=OldOfs;
  7077.           END
  7078.           ELSE
  7079.           BEGIN
  7080.                InOutRes:=DosSetFilePtr(ff^.Handle,
  7081.                          (ff^.Block*MaxCacheMem)+Offset,0,Temp);
  7082.                IF InOutRes<>0 THEN
  7083.                BEGIN
  7084.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7085.                     ELSE exit;
  7086.                END;
  7087.           END;
  7088.  
  7089.           InOutRes:=DosRead(ff^.Handle,Buf,size,result);
  7090.           IF InOutRes<>0 THEN
  7091.           BEGIN
  7092.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7093.                ELSE exit;
  7094.           END;
  7095.           size:=result; {tatsächlich gelesen}
  7096.  
  7097.           {set file buffer}
  7098.           Temp:=Offset+size;
  7099.           t:=Temp MOD MaxCacheMem;
  7100.  
  7101.           IF size<MaxCacheMem THEN
  7102.           BEGIN
  7103.                t:=size;
  7104.                move(pp^{[size-t]},ff^.Buffer^,t);
  7105.                inc(ff^.Block,Temp DIV MaxCacheMem);
  7106.                ff^.Offset:=t;
  7107.                ff^.LBlock:=ff^.Block;
  7108.                ff^.LOffset:=ff^.Offset;
  7109.           END
  7110.           ELSE
  7111.           BEGIN
  7112.                {nächsten Block lesen}
  7113.                ff^.Changed:=FALSE;
  7114.                inc(ff^.Block,Temp DIV MaxCacheMem);
  7115.  
  7116.                FileBlockIO(f,ff^.block,ReadMode,Temp);
  7117.                IF InOutRes<>0 THEN
  7118.                BEGIN
  7119.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7120.                     ELSE exit;
  7121.                END;
  7122.                ff^.offset:=t;
  7123.           END;
  7124.  
  7125.           IF ff^.Block>ff^.LBlock THEN
  7126.           BEGIN
  7127.                ff^.LBlock:=ff^.Block;
  7128.                ff^.LOffset:=ff^.Offset;
  7129.           END;
  7130.  
  7131.           result:=result DIV ff^.RecSize;
  7132.           exit;
  7133.      END;
  7134.  
  7135.      IF ff^.block=ff^.LBlock THEN
  7136.      BEGIN
  7137.           IF Offset+size<ff^.LOffset THEN
  7138.           BEGIN
  7139.                {im letzten Block}
  7140.                move(ff^.Buffer^[Offset],pp^,size);
  7141.                inc(ff^.Offset,size);
  7142.                inc(result,size);
  7143.                result:=result DIV ff^.RecSize;
  7144.                exit;
  7145.           END;
  7146.      END
  7147.      ELSE
  7148.      BEGIN
  7149.           {irgendwo vor dem letzten Block}
  7150.           IF Offset+Size<MaxCacheMem THEN
  7151.           BEGIN
  7152.                move(ff^.Buffer^[Offset],pp^,size);
  7153.                inc(ff^.Offset,size);
  7154.                inc(result,size);
  7155.                result:=result DIV ff^.RecSize;
  7156.                exit;
  7157.           END;
  7158.      END;
  7159.  
  7160.      ff^.reserved1:=ff^.reserved1 and not 1;
  7161.  
  7162.      ASM
  7163.         MOV ECX,0
  7164. !Again:
  7165.         CMP ECX,Size
  7166.         JAE !Abort
  7167.  
  7168.         PUSH ECX
  7169.  
  7170.         PUSH DWORD PTR ff
  7171.         CALLN32 SYSTEM.EOF
  7172.  
  7173.         POP ECX
  7174.         CMP AL,0
  7175.         JNE !Abort    //its EOF
  7176.  
  7177.         {pp^[t-1]:=ff^.Buffer^[ff^.offset];}
  7178.         MOV EBX,pp
  7179.         ADD EBX,ECX
  7180.         MOV EDI,ff
  7181.         MOV ESI,[EDI].FileRec.Buffer
  7182.         ADD ESI,[EDI].FileRec.Offset
  7183.         MOV AL,[ESI]
  7184.         MOV [EBX],AL
  7185.         {inc(ff^.offset);}
  7186.         INCD [EDI].FileRec.Offset
  7187.         {inc(result);}
  7188.         MOV EAX,Result
  7189.         INCD [EAX]
  7190.  
  7191.         {IF ff^.offset=maxcachemem THEN}
  7192.         MOV EAX,MaxCacheMem
  7193.         CMP [EDI].FileRec.Offset,EAX
  7194.         JNE !False
  7195.  
  7196.         {FileBlockIO(f,ff^.block+1,ReadMode,Temp);}
  7197.         PUSH ECX
  7198.  
  7199.         PUSH EDI
  7200.         MOV EAX,[EDI].FileRec.Block
  7201.         INC EAX
  7202.         PUSH EAX
  7203.         PUSHL ReadMode
  7204.         LEA EAX,Temp
  7205.         PUSH EAX
  7206.         CALLN32 SYSTEM.FileBlockIO
  7207.  
  7208.         POP ECX
  7209.         {IF InOutRes<>0 THEN}
  7210.         CMPD SYSTEM.InOutRes,0
  7211.         JE !False1
  7212.  
  7213.         {IF RaiseIOError THEN InOutError(InOutRes,Adr)}
  7214.         CMPB SYSTEM.RaiseIOError,0
  7215.         JE !Abort
  7216.         PUSH DWORD PTR SYSTEM.InOutRes
  7217.         PUSH DWORD PTR Adr
  7218.         CALLN32 SYSTEM.InOutError
  7219. !False1:
  7220.         {ff^.offset:=0;}
  7221.         MOV EDI,ff
  7222.         MOVD [EDI].FileRec.Offset,0
  7223.         {inc(ff^.block);}
  7224.         INCD [EDI].FileRec.Block
  7225. !False:
  7226.         INC ECX
  7227.         JMP !Again
  7228. !Abort:
  7229.      END;
  7230.  
  7231.      result:=result DIV ff^.RecSize;
  7232. END;
  7233.  
  7234. PROCEDURE BlockWrite(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  7235. VAR
  7236.    ff:^FileRec;
  7237.    pp:P_FileBuffer;
  7238.    t,Temp:LONGWORD;
  7239.    size:LONGWORD;
  7240.    Offset:LONGWORD;
  7241.    Adr:LONGINT;
  7242.    TempResult:LONGINT;
  7243. LABEL l,l1,ex;
  7244. BEGIN
  7245.      ASM
  7246.         MOV EAX,result
  7247.         CMP EAX,0        //result var present
  7248.         JNE !prw
  7249.         LEA EAX,TempResult
  7250.         MOV result,EAX
  7251. !prw:
  7252.      END;
  7253.  
  7254.      IF Count=0 THEN
  7255.      BEGIN
  7256.           result:=0;
  7257.           exit;
  7258.      END;
  7259.  
  7260.      ASM
  7261.         MOV EAX,[EBP+4]
  7262.         SUB EAX,5
  7263.         MOV Adr,EAX
  7264.      END;
  7265.      ff:=@f;
  7266.      pp:=@Buf;
  7267.      InOutRes:=0;
  7268.  
  7269.      IF ff^.flags<>$6666 THEN
  7270.      BEGIN
  7271.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7272.           ELSE
  7273.           BEGIN
  7274.                InOutRes:=206;
  7275.                goto ex;
  7276.           END;
  7277.      END;
  7278.  
  7279.      IF ff^.Handle=$ffffffff THEN
  7280.      BEGIN
  7281.          InOutRes:=6; {Invalid handle}
  7282.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7283.          ELSE goto ex;
  7284.      END;
  7285.  
  7286.      IF ff^.Buffer=NIL THEN
  7287.      BEGIN
  7288.           InOutRes:=DosWrite(ff^.Handle,pp^,Count*ff^.RecSize,result);
  7289.           IF InOutRes<>0 THEN
  7290.           BEGIN
  7291.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7292.                ELSE goto ex;
  7293.           END;
  7294.           goto ex;
  7295.      END;
  7296.  
  7297.      result:=0;
  7298.      InOutRes:=0;
  7299.      size:=Count*ff^.RecSize;
  7300.      Offset:=ff^.Offset;
  7301.  
  7302.      IF ff^.block=ff^.LBlock THEN
  7303.      BEGIN
  7304.           IF Offset=ff^.LOffset THEN
  7305.           BEGIN
  7306.                {am ende der Datei (im letzten Block und an LOffset)}
  7307.                IF Offset+size<ff^.MaxCacheMem THEN
  7308.                BEGIN
  7309.                     move(pp^,ff^.Buffer^[Offset],size);
  7310.                     inc(ff^.Offset,size);
  7311.                     inc(ff^.LOffset,size);
  7312.                     inc(result,size);
  7313.                     ff^.Changed:=TRUE;
  7314.                     result:=result DIV ff^.RecSize;
  7315.                     goto ex;
  7316.                END
  7317.                ELSE
  7318.                BEGIN
  7319.                     {Groesse geht über alten Block hinaus}
  7320. l:
  7321.                     ff^.Changed:=FALSE;
  7322.                     {alten Block Schreiben}
  7323.                     FileBlockIO(f,ff^.Block,WriteMode,Temp);
  7324.                     IF InOutRes<>0 THEN
  7325.                     BEGIN
  7326.                          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7327.                          ELSE goto ex;
  7328.                     END;
  7329. l1:
  7330.                     InOutRes:=DosWrite(ff^.Handle,Buf,size,result);
  7331.                     IF InOutRes<>0 THEN
  7332.                     BEGIN
  7333.                         IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7334.                         ELSE goto ex;
  7335.                     END;
  7336.                     size:=result; {Tatsächlich geschrieben}
  7337.  
  7338.                     {set file buffer}
  7339.                     Temp:=Offset+size;
  7340.                     t:=Temp MOD ff^.MaxCacheMem;
  7341.                     move(pp^[size-t],ff^.Buffer^,t);
  7342.  
  7343.                     inc(ff^.Block,Temp DIV ff^.MaxCacheMem);
  7344.                     ff^.Offset:=t;
  7345.  
  7346.                     {we are at the end of the file}
  7347.                     ff^.LBlock:=ff^.Block;
  7348.                     ff^.LOffset:=ff^.Offset;
  7349.                     result:=result DIV ff^.RecSize;
  7350.                     goto ex;
  7351.                END;
  7352.           END
  7353.           ELSE
  7354.           BEGIN
  7355.                {im letzten Block aber nicht an LOffset}
  7356.                IF Offset+size<ff^.LOffset THEN
  7357.                BEGIN
  7358.                     move(pp^,ff^.Buffer^[Offset],size);
  7359.                     inc(ff^.Offset,size);
  7360.                     inc(result,size);
  7361.                     ff^.Changed:=TRUE;
  7362.                     result:=result DIV ff^.RecSize;
  7363.                     goto ex;
  7364.                END;
  7365.                {ELSE goto l;}
  7366.           END;
  7367.      END
  7368.      ELSE
  7369.      BEGIN
  7370.           {irgendwo vor dem letzten Block}
  7371.           IF Offset+Size<ff^.MaxCacheMem THEN
  7372.           BEGIN
  7373.                move(pp^,ff^.Buffer^[Offset],size);
  7374.                inc(ff^.Offset,size);
  7375.                inc(result,size);
  7376.                ff^.Changed:=TRUE;
  7377.                result:=result DIV ff^.RecSize;
  7378.                goto ex;
  7379.           END;
  7380.      END;
  7381.  
  7382.      ff^.reserved1:=ff^.reserved1 and not 1;
  7383.  
  7384.      ASM
  7385.         MOV ECX,0
  7386. !Again:
  7387.         CMP ECX,Size
  7388.         JAE !Abort
  7389.  
  7390.         {value:=pp^[t-1];}
  7391.         MOV EBX,pp
  7392.         ADD EBX,ECX
  7393.         MOV AL,[EBX]
  7394.         {IF value<>ff^.Buffer^[ff^.offset] THEN}
  7395.         MOV EDI,ff
  7396.         MOV ESI,[EDI].FileRec.Buffer
  7397.         ADD ESI,[EDI].FileRec.Offset
  7398.         CMP AL,[ESI]
  7399.         JE !Ok
  7400.  
  7401.         MOV [ESI],AL
  7402.         MOVB [EDI].FileRec.Changed,1
  7403. !Ok:
  7404.         {IF EOF(f) THEN}
  7405.         PUSH ECX
  7406.  
  7407.         PUSH EDI
  7408.         CALLN32 SYSTEM.Eof
  7409.         CMP AL,0
  7410.         JE !notEof
  7411.  
  7412.         {ff^.changed:=TRUE;}
  7413.         MOV EDI,ff
  7414.         MOVB [EDI].FileRec.Changed,1
  7415.         {FileExpand(f);}
  7416.         PUSH EDI
  7417.         CALLN32 SYSTEM.FileExpand
  7418. !NotEof:
  7419.         POP ECX
  7420.         MOV EDI,ff
  7421.         {inc(ff^.Offset);}
  7422.         INCD [EDI].FileRec.Offset
  7423.         MOV EAX,Result
  7424.         INCD [EAX]
  7425.  
  7426.         {IF ff^.Offset=ff^.MaxCacheMem THEN}
  7427.         MOV EAX,[EDI].FileRec.Offset
  7428.         CMP EAX,[EDI].FileRec.MaxCacheMem
  7429.         JNE !Skip
  7430.  
  7431.         MOVB [EDI].FileRec.Changed,0
  7432.         {alten Block Schreiben}
  7433.         PUSH ECX
  7434.  
  7435.         PUSH EDI
  7436.         PUSH DWORD PTR [EDI].FileRec.Block
  7437.         PUSHL WriteMode
  7438.         LEA EAX,Temp
  7439.         PUSH EAX
  7440.         CALLN32 SYSTEM.FileBlockIO
  7441.         POP ECX
  7442.         CMPD System.InOutRes,0
  7443.         JE !io1ok
  7444.  
  7445.         CMPB System.RaiseIOError,0
  7446.         JE !Abort
  7447.         PUSH DWORD PTR System.InOutRes
  7448.         PUSH DWORD PTR Adr
  7449.         CALLN32 System.InOutError
  7450. !io1Ok:
  7451.         {neuen Block lesen}
  7452.         PUSH ECX
  7453.         MOV EDI,ff
  7454.         {ff^.Offset:=0;}
  7455.         MOVD [EDI].FileRec.Offset,0
  7456.         {inc(ff^.Block);}
  7457.         INCD [EDI].FileRec.Block
  7458.         {FileBlockIO(f,ff^.Block,ReadMode,Temp);}
  7459.         PUSH  EDI
  7460.         PUSH DWORD PTR [EDI].FileRec.Block
  7461.         PUSHL ReadMode
  7462.         LEA EAX,Temp
  7463.         PUSH EAX
  7464.         CALLN32 SYSTEM.FileBlockIO
  7465.         POP ECX
  7466.         {IF InOutRes<>0 THEN}
  7467.         CMPD System.InOutRes,0
  7468.         JE !Skip
  7469.  
  7470.         CMPB System.RaiseIOError,0
  7471.         JE !Abort
  7472.  
  7473.         PUSH DWORD PTR System.InOutRes
  7474.         PUSH DWORD PTR Adr
  7475.         CALLN32 SYSTEM.InOutError
  7476. !Skip:
  7477.         INC ECX
  7478.         JMP !Again
  7479. !Abort:
  7480.      END;
  7481.      result:=result DIV ff^.RecSize;
  7482. ex:
  7483. END;
  7484. {$ENDIF}
  7485. {$IFDEF WIN95}
  7486. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  7487. VAR
  7488.    ff:^FileRec;
  7489.    pp:P_FileBuffer;
  7490.    t:LONGWORD;
  7491.    Temp:LONGWORD;
  7492.    Offset,Size:LONGWORD;
  7493.    OldBlock,OldOfs:LONGINT;
  7494.    MaxCacheMem:LONGWORD;
  7495.    Adr:LONGINT;
  7496.    TempResult:LONGINT;
  7497. BEGIN
  7498.      ASM
  7499.         MOV EAX,result
  7500.         CMP EAX,0        //result var present
  7501.         JNE !prr
  7502.         LEA EAX,TempResult
  7503.         MOV result,EAX
  7504. !prr:
  7505.      END;
  7506.  
  7507.      IF Count=0 THEN
  7508.      BEGIN
  7509.           result:=0;
  7510.           exit;
  7511.      END;
  7512.  
  7513.      ASM
  7514.         MOV EAX,[EBP+4]
  7515.         SUB EAX,5
  7516.         MOV Adr,EAX
  7517.      END;
  7518.      ff:=@f;
  7519.      pp:=@Buf;
  7520.      InOutRes:=0;
  7521.  
  7522.      IF ff^.flags<>$6666 THEN
  7523.      BEGIN
  7524.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7525.           ELSE
  7526.           BEGIN
  7527.                InOutRes:=206;
  7528.                exit;
  7529.           END;
  7530.      END;
  7531.  
  7532.      IF ff^.Handle=$ffffffff THEN
  7533.      BEGIN
  7534.          InOutRes:=6; {Invalid handle}
  7535.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7536.          ELSE exit;
  7537.      END;
  7538.  
  7539.      IF ff^.Buffer=NIL THEN
  7540.      BEGIN
  7541.           IF not ReadFile(ff^.Handle,pp^,Count*ff^.RecSize,result,NIL) THEN
  7542.           BEGIN
  7543.                InOutRes:=GetLastError;
  7544.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7545.                ELSE exit;
  7546.           END;
  7547.           exit;
  7548.      END;
  7549.  
  7550.      result:=0;
  7551.      Offset:=ff^.Offset;
  7552.      Size:=Count*ff^.RecSize;
  7553.      MaxCacheMem:=ff^.MaxCacheMem;
  7554.  
  7555.      IF Size>MaxCacheMem THEN
  7556.      BEGIN
  7557.           {Block ist größer als Cache}
  7558.           IF (ff^.Block*MaxCacheMem)+Offset+Size>(ff^.LBlock*MaxCacheMem)+ff^.LOffset THEN
  7559.             Size:=((ff^.LBlock*MaxCacheMem)+ff^.LOffset)-
  7560.                   ((ff^.Block*MaxCacheMem)+Offset);
  7561.  
  7562.           IF ff^.Changed THEN
  7563.           BEGIN
  7564.                ff^.Changed:=FALSE;
  7565.                OldBlock:=ff^.LBlock;    {temporaray save}
  7566.                OldOfs:=ff^.LOffset;
  7567.                ff^.LBlock:=ff^.Block;
  7568.                ff^.LOffset:=Offset;
  7569.                {alten Block Schreiben}
  7570.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  7571.                IF InOutRes<>0 THEN
  7572.                BEGIN
  7573.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7574.                     ELSE exit;
  7575.                END;
  7576.                ff^.LBlock:=OldBlock;
  7577.                ff^.LOffset:=OldOfs;
  7578.           END
  7579.           ELSE
  7580.           BEGIN
  7581.                Temp:=SetFilePointer(ff^.Handle,
  7582.                          (ff^.Block*MaxCacheMem)+Offset,NIL,0);
  7583.                IF Temp=$ffffffff THEN
  7584.                BEGIN
  7585.                     InOutRes:=GetLastError;
  7586.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7587.                     ELSE exit;
  7588.                END;
  7589.           END;
  7590.  
  7591.           IF not ReadFile(ff^.Handle,Buf,Size,result,NIL) THEN
  7592.           BEGIN
  7593.                InOutRes:=GetLastError;
  7594.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7595.                ELSE exit;
  7596.           END;
  7597.           size:=result; {tatsächlich gelesen}
  7598.  
  7599.           {set file buffer}
  7600.           Temp:=Offset+size;
  7601.           t:=Temp MOD MaxCacheMem;
  7602.  
  7603.           IF size<MaxCacheMem THEN
  7604.           BEGIN
  7605.                move(pp^[size-t],ff^.Buffer^,t);
  7606.                inc(ff^.Block,Temp DIV MaxCacheMem);
  7607.                ff^.Offset:=t;
  7608.                ff^.LBlock:=ff^.Block;
  7609.                ff^.LOffset:=ff^.Offset;
  7610.           END
  7611.           ELSE
  7612.           BEGIN
  7613.                {nächsten Block lesen}
  7614.                ff^.Changed:=FALSE;
  7615.                inc(ff^.Block,Temp DIV MaxCacheMem);
  7616.  
  7617.                FileBlockIO(f,ff^.block,ReadMode,Temp);
  7618.                IF InOutRes<>0 THEN
  7619.                BEGIN
  7620.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7621.                     ELSE exit;
  7622.                END;
  7623.                ff^.offset:=t;
  7624.           END;
  7625.  
  7626.           IF ff^.Block>ff^.LBlock THEN
  7627.           BEGIN
  7628.                ff^.LBlock:=ff^.Block;
  7629.                ff^.LOffset:=ff^.Offset;
  7630.           END;
  7631.  
  7632.           result:=result DIV ff^.RecSize;
  7633.           exit;
  7634.      END;
  7635.  
  7636.      IF ff^.block=ff^.LBlock THEN
  7637.      BEGIN
  7638.           IF Offset+size<ff^.LOffset THEN
  7639.           BEGIN
  7640.                {im letzten Block}
  7641.                move(ff^.Buffer^[Offset],pp^,size);
  7642.                inc(ff^.Offset,size);
  7643.                inc(result,size);
  7644.                result:=result DIV ff^.RecSize;
  7645.                exit;
  7646.           END;
  7647.      END
  7648.      ELSE
  7649.      BEGIN
  7650.           {irgendwo vor dem letzten Block}
  7651.           IF Offset+Size<MaxCacheMem THEN
  7652.           BEGIN
  7653.                move(ff^.Buffer^[Offset],pp^,size);
  7654.                inc(ff^.Offset,size);
  7655.                inc(result,size);
  7656.                result:=result DIV ff^.RecSize;
  7657.                exit;
  7658.           END;
  7659.      END;
  7660.  
  7661.      ff^.reserved1:=ff^.reserved1 and not 1;
  7662.  
  7663.      FOR t:=1 TO Size DO
  7664.      BEGIN
  7665.           IF eof(f) THEN
  7666.           BEGIN
  7667.                result:=result DIV ff^.RecSize;
  7668.                exit;
  7669.           END;
  7670.  
  7671.           pp^[t-1]:=ff^.Buffer^[ff^.offset];
  7672.           inc(ff^.offset);
  7673.           inc(result);
  7674.           IF ff^.offset=maxcachemem THEN
  7675.           BEGIN
  7676.                FileBlockIO(f,ff^.block+1,ReadMode,Temp);
  7677.                IF InOutRes<>0 THEN
  7678.                BEGIN
  7679.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7680.                     ELSE exit;
  7681.                END;
  7682.                ff^.offset:=0;
  7683.                inc(ff^.block);
  7684.           END;
  7685.      END;
  7686.      result:=result DIV ff^.RecSize;
  7687. END;
  7688.  
  7689. PROCEDURE BlockWrite(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  7690. VAR
  7691.    ff:^FileRec;
  7692.    pp:P_FileBuffer;
  7693.    t,Temp:LONGWORD;
  7694.    value:BYTE;
  7695.    size:LONGWORD;
  7696.    Offset:LONGWORD;
  7697.    Adr:LONGINT;
  7698.    TempResult:LONGINT;
  7699. LABEL l,l1;
  7700. BEGIN
  7701.      ASM
  7702.         MOV EAX,result
  7703.         CMP EAX,0        //result var present
  7704.         JNE !prw
  7705.         LEA EAX,TempResult
  7706.         MOV result,EAX
  7707. !prw:
  7708.      END;
  7709.  
  7710.      IF Count=0 THEN
  7711.      BEGIN
  7712.           result:=0;
  7713.           exit;
  7714.      END;
  7715.  
  7716.      ASM
  7717.         MOV EAX,[EBP+4]
  7718.         SUB EAX,5
  7719.         MOV Adr,EAX
  7720.      END;
  7721.      ff:=@f;
  7722.      pp:=@Buf;
  7723.      InOutRes:=0;
  7724.  
  7725.      IF ff^.flags<>$6666 THEN
  7726.      BEGIN
  7727.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7728.           ELSE
  7729.           BEGIN
  7730.                InOutRes:=206;
  7731.                exit;
  7732.           END;
  7733.      END;
  7734.  
  7735.      IF ff^.Handle=$ffffffff THEN
  7736.      BEGIN
  7737.          InOutRes:=6; {Invalid handle}
  7738.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7739.          ELSE exit;
  7740.      END;
  7741.  
  7742.      IF ff^.Buffer=NIL THEN
  7743.      BEGIN
  7744.           IF not WriteFile(ff^.Handle,pp^,Count*ff^.RecSize,result,NIL) THEN
  7745.           BEGIN
  7746.                InOutRes:=GetLastError;
  7747.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7748.                ELSE exit;
  7749.           END;
  7750.           exit;
  7751.      END;
  7752.  
  7753.      result:=0;
  7754.      InOutRes:=0;
  7755.      size:=Count*ff^.RecSize;
  7756.      Offset:=ff^.Offset;
  7757.  
  7758.      IF ff^.block=ff^.LBlock THEN
  7759.      BEGIN
  7760.           IF Offset=ff^.LOffset THEN
  7761.           BEGIN
  7762.                {am ende der Datei (im letzten Block und an LOffset)}
  7763.                IF Offset+size<ff^.MaxCacheMem THEN
  7764.                BEGIN
  7765.                     move(pp^,ff^.Buffer^[Offset],size);
  7766.                     inc(ff^.Offset,size);
  7767.                     inc(ff^.LOffset,size);
  7768.                     inc(result,size);
  7769.                     ff^.Changed:=TRUE;
  7770.                     result:=result DIV ff^.RecSize;
  7771.                     exit;
  7772.                END
  7773.                ELSE
  7774.                BEGIN
  7775.                     {Groesse geht über alten Block hinaus}
  7776. l:
  7777.                     ff^.Changed:=FALSE;
  7778.                     {alten Block Schreiben}
  7779.                     FileBlockIO(f,ff^.Block,WriteMode,Temp);
  7780.                     IF InOutRes<>0 THEN
  7781.                     BEGIN
  7782.                          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7783.                          ELSE exit;
  7784.                     END;
  7785. l1:
  7786.                     IF not WriteFile(ff^.Handle,Buf,Size,result,NIL) THEN
  7787.                     BEGIN
  7788.                         InOutRes:=GetLastError;
  7789.                         IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7790.                         ELSE exit;
  7791.                     END;
  7792.                     size:=result; {Tatsächlich geschrieben}
  7793.  
  7794.                     {set file buffer}
  7795.                     Temp:=Offset+size;
  7796.                     t:=Temp MOD ff^.MaxCacheMem;
  7797.                     move(pp^[size-t],ff^.Buffer^,t);
  7798.  
  7799.                     inc(ff^.Block,Temp DIV ff^.MaxCacheMem);
  7800.                     ff^.Offset:=t;
  7801.  
  7802.                     {we are at the end of the file}
  7803.                     ff^.LBlock:=ff^.Block;
  7804.                     ff^.LOffset:=ff^.Offset;
  7805.                     result:=result DIV ff^.RecSize;
  7806.                     exit;
  7807.                END;
  7808.           END
  7809.           ELSE
  7810.           BEGIN
  7811.                {im letzten Block aber nicht an LOffset}
  7812.                IF Offset+size<ff^.LOffset THEN
  7813.                BEGIN
  7814.                     move(pp^,ff^.Buffer^[Offset],size);
  7815.                     inc(ff^.Offset,size);
  7816.                     inc(result,size);
  7817.                     ff^.Changed:=TRUE;
  7818.                     result:=result DIV ff^.RecSize;
  7819.                     exit;
  7820.                END;
  7821.                {ELSE goto l;}
  7822.           END;
  7823.      END
  7824.      ELSE
  7825.      BEGIN
  7826.           {irgendwo vor dem letzten Block}
  7827.           IF Offset+Size<ff^.MaxCacheMem THEN
  7828.           BEGIN
  7829.                move(pp^,ff^.Buffer^[Offset],size);
  7830.                inc(ff^.Offset,size);
  7831.                inc(result,size);
  7832.                ff^.Changed:=TRUE;
  7833.                result:=result DIV ff^.RecSize;
  7834.                exit;
  7835.           END;
  7836.      END;
  7837.  
  7838.      ff^.reserved1:=ff^.reserved1 and not 1;
  7839.  
  7840.      FOR t:=1 TO size DO
  7841.      BEGIN
  7842.           value:=pp^[t-1];
  7843.           IF value<>ff^.Buffer^[ff^.offset] THEN
  7844.           BEGIN
  7845.                ff^.Buffer^[ff^.offset]:=value;
  7846.                ff^.Changed:=TRUE;
  7847.           END;
  7848.           IF EOF(f) THEN
  7849.           BEGIN
  7850.                ff^.changed:=TRUE;
  7851.                FileExpand(f);
  7852.           END;
  7853.           inc(ff^.Offset);
  7854.           inc(Result);
  7855.  
  7856.           IF ff^.Offset=ff^.MaxCacheMem THEN
  7857.           BEGIN
  7858.                ff^.Changed:=FALSE;
  7859.                {alten Block Schreiben}
  7860.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  7861.                IF InOutRes<>0 THEN
  7862.                BEGIN
  7863.                     IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7864.                     ELSE exit;
  7865.                END;
  7866.                {neuen Block lesen}
  7867.                ff^.Offset:=0;
  7868.                inc(ff^.Block);
  7869.                FileBlockIO(f,ff^.Block,ReadMode,Temp);
  7870.                IF InOutRes<>0 THEN
  7871.                BEGIN
  7872.                    IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7873.                    ELSE exit;
  7874.                END;
  7875.           END;
  7876.      END;
  7877.      result:=result DIV ff^.RecSize;
  7878. END;
  7879. {$ENDIF}
  7880.  
  7881. {$IFDEF OS2}
  7882. PROCEDURE Rename(VAR f:file;NewName:String);
  7883. VAR
  7884.    c,c1:CSTRING;
  7885.    ff:^FileRec;
  7886.    Adr:LONGINT;
  7887. BEGIN
  7888.      ASM
  7889.         MOV EAX,[EBP+4]
  7890.         SUB EAX,5
  7891.         MOV Adr,EAX
  7892.      END;
  7893.      ff:=@f;
  7894.      c:=NewName;
  7895.      c1:=ff^.Name;
  7896.      InOutRes:=DosMove(c1,c);
  7897.      IF InOutRes<>0 THEN
  7898.      BEGIN
  7899.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7900.           ELSE exit;
  7901.      END;
  7902. END;
  7903.  
  7904. PROCEDURE Erase(VAR f:file);
  7905. VAR
  7906.    ff:^FileRec;
  7907.    c:CSTRING;
  7908.    Adr:LONGINT;
  7909. BEGIN
  7910.      ASM
  7911.         MOV EAX,[EBP+4]
  7912.         SUB EAX,5
  7913.         MOV Adr,EAX
  7914.      END;
  7915.      ff:=@f;
  7916.      IF ff^.flags<>$6666 THEN
  7917.      BEGIN
  7918.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7919.           ELSE
  7920.           BEGIN
  7921.                InOutRes:=206;
  7922.                exit;
  7923.           END;
  7924.      END;
  7925.      c:=ff^.name;
  7926.      InOutRes:=DosDelete(c);
  7927.      IF InOutRes<>0 THEN
  7928.      BEGIN
  7929.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7930.           ELSE exit;
  7931.      END;
  7932. END;
  7933. {$ENDIF}
  7934. {$IFDEF WIN95}
  7935. PROCEDURE Rename(VAR f:file;NewName:String);
  7936. VAR
  7937.    c,c1:CSTRING;
  7938.    ff:^FileRec;
  7939.    Adr:LONGINT;
  7940. BEGIN
  7941.      ASM
  7942.         MOV EAX,[EBP+4]
  7943.         SUB EAX,5
  7944.         MOV Adr,EAX
  7945.      END;
  7946.      ff:=@f;
  7947.      c:=NewName;
  7948.      c1:=ff^.Name;
  7949.      IF not MoveFile(c1,c) THEN
  7950.      BEGIN
  7951.           InOutRes:=GetLastError;
  7952.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7953.           ELSE exit;
  7954.      END;
  7955. END;
  7956.  
  7957. PROCEDURE Erase(VAR f:file);
  7958. VAR
  7959.    ff:^FileRec;
  7960.    c:CSTRING;
  7961.    Adr:LONGINT;
  7962. BEGIN
  7963.      ASM
  7964.         MOV EAX,[EBP+4]
  7965.         SUB EAX,5
  7966.         MOV Adr,EAX
  7967.      END;
  7968.      ff:=@f;
  7969.      IF ff^.flags<>$6666 THEN
  7970.      BEGIN
  7971.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  7972.           ELSE
  7973.           BEGIN
  7974.                InOutRes:=206;
  7975.                exit;
  7976.           END;
  7977.      END;
  7978.      c:=ff^.name;
  7979.      IF not DeleteFile(c) THEN
  7980.      BEGIN
  7981.           InOutRes:=GetLastError;
  7982.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  7983.           ELSE exit;
  7984.      END;
  7985. END;
  7986.  
  7987. {$ENDIF}
  7988.  
  7989. {$HINTS OFF}
  7990. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  7991. BEGIN
  7992.      IF BufSize<4096 THEN BufSize:=4096;
  7993. END;
  7994. {$HINTS ON}
  7995.  
  7996. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  7997. BEGIN
  7998.      if BufSize>16*1024 then SetFileBuf(F,Buf,BufSize);
  7999. END;
  8000.  
  8001. PROCEDURE StrWriteText({VAR f:FILE}CONST s:STRING;format:LONGWORD);
  8002. VAR
  8003.     fi:^FILE;
  8004.     ss:STRING;
  8005.     fillup:BYTE;
  8006.     Adr:LONGINT;
  8007.     SaveIO:BOOLEAN;
  8008.     BlockWriteResult:LONGWORD;
  8009. BEGIN
  8010.      ASM
  8011.         MOV EAX,[EBP+16]  //VAR f:FILE
  8012.         MOV fi,EAX
  8013.      END;
  8014.      ASM
  8015.         MOV EAX,[EBP+4]
  8016.         SUB EAX,5
  8017.         MOV Adr,EAX
  8018.      END;
  8019.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  8020.      IF format>length(s) THEN
  8021.      BEGIN
  8022.           fillup:=format-length(s);  {erst soviele Leerzeichen}
  8023.           fillchar(ss[0],fillup,32);
  8024.           SaveIO:=RaiseIOError;
  8025.           RaiseIOError:=FALSE;
  8026.           BlockWrite(fi^,ss[0],fillup);
  8027.           RaiseIOError:=SaveIO;
  8028.           IF InOutRes<>0 THEN
  8029.           BEGIN
  8030.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8031.                ELSE exit;
  8032.           END;
  8033.      END;
  8034.      SaveIO:=RaiseIOError;
  8035.      RaiseIOError:=FALSE;
  8036.      {must do this in ASM because s is constant parameter}
  8037.      ASM
  8038.         PUSH DWORD PTR fi
  8039.         MOV EDI,s
  8040.         INC EDI
  8041.         PUSH EDI
  8042.         DEC EDI
  8043.         MOVZXB EAX,[EDI+0]
  8044.         PUSH EAX
  8045.         LEA EAX,BlockWriteResult
  8046.         PUSH EAX
  8047.         CALLN32 SYSTEM.BlockWrite
  8048.      END;
  8049.      RaiseIOError:=SaveIO;
  8050.      IF InOutRes<>0 THEN
  8051.      BEGIN
  8052.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8053.           ELSE exit;
  8054.      END;
  8055. END;
  8056.  
  8057.  
  8058.  
  8059. PROCEDURE CStrWriteText({VAR f:FILE}CONST s:CSTRING;format:LONGWORD);
  8060. VAR
  8061.     ss:STRING;
  8062.     l:LONGWORD;
  8063.     fi:^FILE;
  8064.     fillup:BYTE;
  8065.     Adr:LONGINT;
  8066.     SaveIO:BOOLEAN;
  8067.     BlockWriteResult:LONGWORD;
  8068. BEGIN
  8069.      ASM
  8070.         MOV EAX,[EBP+16]  //VAR f:FILE
  8071.         MOV fi,EAX
  8072.      END;
  8073.      ASM
  8074.         MOV EAX,[EBP+4]
  8075.         SUB EAX,5
  8076.         MOV Adr,EAX
  8077.      END;
  8078.      l:=length(s);
  8079.      IF Format+l>255 THEN Format:=255-l;
  8080.      IF format>l THEN
  8081.      BEGIN
  8082.           fillup:=format-l;
  8083.           fillchar(ss[0],fillup,32);
  8084.           SaveIO:=RaiseIOError;
  8085.           RaiseIOError:=FALSE;
  8086.           BlockWrite(fi^,ss[0],fillup);
  8087.           RaiseIOError:=SaveIO;
  8088.           IF InOutRes<>0 THEN
  8089.           BEGIN
  8090.                IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8091.                ELSE exit;
  8092.           END;
  8093.      END;
  8094.      SaveIO:=RaiseIOError;
  8095.      RaiseIOError:=FALSE;
  8096.      {must do this in ASM because s is constant parameter}
  8097.      ASM
  8098.         PUSH DWORD PTR fi
  8099.         PUSH DWORD PTR s
  8100.         PUSH DWORD PTR l
  8101.         LEA EAX,BlockWriteResult
  8102.         PUSH EAX
  8103.         CALLN32 SYSTEM.BlockWrite
  8104.      END;
  8105.      RaiseIOError:=SaveIO;
  8106.      IF InOutRes<>0 THEN
  8107.      BEGIN
  8108.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8109.           ELSE exit;
  8110.      END;
  8111. END;
  8112.  
  8113. PROCEDURE ArrayWriteText({VAR f:FILE}CONST s;format:LONGWORD;MaxLen:LONGWORD);
  8114. VAR fi:^File;
  8115.     pc:PChar;
  8116. BEGIN
  8117.      ASM
  8118.         MOV EAX,[EBP+20]  //VAR f:FILE
  8119.         MOV fi,EAX
  8120.      END;
  8121.      GetMem(pc,MaxLen+1);
  8122.      Move(s,pc^,MaxLen);
  8123.      pc^[MaxLen]:=#0;  //terminate PChar
  8124.      ASM
  8125.         PUSH DWORD PTR fi
  8126.         PUSH DWORD PTR pc
  8127.         PUSH DWORD PTR Format
  8128.         CALLN32 SYSTEM.CStrWriteText
  8129.         ADD ESP,4  //Pop f
  8130.      END;
  8131.      FreeMem(pc,MaxLen+1);
  8132. END;
  8133.  
  8134. PROCEDURE AnsiStrWriteText({VAR f:FILE}CONST s:AnsiString;format:LONGWORD);ASSEMBLER;
  8135. ASM
  8136.    MOV EBX,[EBP+12]  //s
  8137.    CMP EBX,0         //AnsiString is empty
  8138.    JE !ex
  8139.    PUSH DWORD PTR [EBP+16]    //f
  8140.    PUSH EBX
  8141.    PUSH DWORD PTR [EBP+8]     //format
  8142.    JE !ex
  8143.    CALLN32 SYSTEM.CStrWriteText
  8144.    ADD ESP,4         //get VAR f
  8145. !ex:
  8146. END;
  8147.  
  8148. PROCEDURE VariantWriteText({VAR f:FILE}CONST v:Variant;format:LONGWORD);
  8149. VAR fi:^FILE;
  8150.     s:STRING;
  8151. BEGIN
  8152.      ASM
  8153.         MOV EAX,[EBP+16]  //f:FILE
  8154.         MOV fi,EAX
  8155.      END;
  8156.      IF VarType(v) and VarTypeMask=varString THEN
  8157.      BEGIN
  8158.           ASM
  8159.              PUSH DWORD PTR fi
  8160.              MOV EAX,v
  8161.              PUSH DWORD PTR [EAX+2]  //by value !!
  8162.              PUSH DWORD PTR format
  8163.              CALLN32 SYSTEM.AnsiStrWriteText
  8164.           END;
  8165.      END
  8166.      ELSE
  8167.      BEGIN
  8168.           s:=String(v);
  8169.           ASM
  8170.              PUSH DWORD PTR fi
  8171.              LEA EAX,s
  8172.              PUSH EAX
  8173.              PUSH DWORD PTR format
  8174.              CALLN32 SYSTEM.StrWriteText
  8175.           END;
  8176.      END;
  8177. END;
  8178.  
  8179. {Float value is in ST(0) !}
  8180. PROCEDURE WriteExtendedText({VAR f:FILE}Format1,Format2:LONGWORD);
  8181. VAR
  8182.    float:EXTENDED;
  8183.    fi:^FILE;
  8184.    s:STRING;
  8185.    Adr:LONGINT;
  8186.    SaveIO:BOOLEAN;
  8187. BEGIN
  8188.      ASM
  8189.         MOV EAX,[EBP+4]
  8190.         SUB EAX,5
  8191.         MOV Adr,EAX
  8192.      END;
  8193.      ASM
  8194.         MOV EAX,[EBP+16]  //VAR f:FILE
  8195.         MOV fi,EAX
  8196.         FSTPT float
  8197.  
  8198.         PUSH DWORD PTR Format1
  8199.         PUSH DWORD PTR Format2     //Nachkommas
  8200.         LEA EAX,float
  8201.         PUSH EAX
  8202.         LEA EAX,s
  8203.         PUSH EAX
  8204.         CALLN32 SYSTEM.!Extended2Str
  8205.       END;
  8206.       SaveIO:=RaiseIOError;
  8207.       RaiseIOError:=FALSE;
  8208.       BlockWrite(fi^,s[1],length(s));
  8209.       RaiseIOError:=SaveIO;
  8210.       IF InOutRes<>0 THEN
  8211.       BEGIN
  8212.            IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8213.            ELSE exit;
  8214.       END;
  8215. END;
  8216.  
  8217. {Float value is in ST(0) !}
  8218. PROCEDURE WriteCurrencyText({VAR f:FILE}Format1,Format2:LONGWORD);
  8219. VAR
  8220.    float:EXTENDED;
  8221.    fi:^FILE;
  8222.    s:STRING;
  8223.    Adr:LONGINT;
  8224.    SaveIO:BOOLEAN;
  8225. BEGIN
  8226.      ASM
  8227.         MOV EAX,[EBP+4]
  8228.         SUB EAX,5
  8229.         MOV Adr,EAX
  8230.      END;
  8231.      IF Format2>4 THEN Format2:=4;  //Immer 4 Nachkommas
  8232.      ASM
  8233.         MOV EAX,[EBP+16]  //VAR f:FILE
  8234.         MOV fi,EAX
  8235.         FRNDINT
  8236.         FLDT SYSTEM.FromCurrency  //*0.0001
  8237.         FMULP ST(1),ST
  8238.         FSTPT float
  8239.  
  8240.         PUSH DWORD PTR Format1
  8241.         PUSH DWORD PTR Format2     //Nachkommas
  8242.         LEA EAX,float
  8243.         PUSH EAX
  8244.         LEA EAX,s
  8245.         PUSH EAX
  8246.         CALLN32 SYSTEM.!Extended2Str
  8247.       END;
  8248.       SaveIO:=RaiseIOError;
  8249.       RaiseIOError:=FALSE;
  8250.       BlockWrite(fi^,s[1],length(s));
  8251.       RaiseIOError:=SaveIO;
  8252.       IF InOutRes<>0 THEN
  8253.       BEGIN
  8254.            IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8255.            ELSE exit;
  8256.       END;
  8257. END;
  8258.  
  8259.  
  8260. {$HINTS OFF}
  8261. {Float value is in ST(0) !}
  8262. PROCEDURE WriteCompText({VAR f:FILE}Format1,Format2:LONGWORD);
  8263. VAR
  8264.    aComp:COMP;
  8265.    fi:^FILE;
  8266.    s:STRING;
  8267.    Adr:LONGINT;
  8268.    SaveIO:BOOLEAN;
  8269. BEGIN
  8270.      ASM
  8271.         MOV EAX,[EBP+4]
  8272.         SUB EAX,5
  8273.         MOV Adr,EAX
  8274.      END;
  8275.      ASM
  8276.         MOV EAX,[EBP+16]  //VAR f:FILE
  8277.         MOV fi,EAX
  8278.         FISTP QWORD PTR aComp
  8279.  
  8280.         PUSH DWORD PTR Format1
  8281.         PUSHL 0           //keine Nachkommas
  8282.         LEA EAX,aComp
  8283.         PUSH EAX
  8284.         LEA EAX,s
  8285.         PUSH EAX
  8286.         CALLN32 SYSTEM.!Comp2Str
  8287.       END;
  8288.       SaveIO:=RaiseIOError;
  8289.       RaiseIOError:=FALSE;
  8290.       BlockWrite(fi^,s[1],length(s));
  8291.       RaiseIOError:=SaveIO;
  8292.       IF InOutRes<>0 THEN
  8293.       BEGIN
  8294.            IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8295.            ELSE exit;
  8296.       END;
  8297. END;
  8298. {$HINTS ON}
  8299.  
  8300. PROCEDURE WriteLongintText({VAR f:FILE}Value:LONGINT;Format:LONGWORD);
  8301. VAR
  8302.    fi:^FILE;
  8303.    s:STRING;
  8304.    Adr:LONGINT;
  8305.    SaveIO:BOOLEAN;
  8306. BEGIN
  8307.      ASM
  8308.         MOV EAX,[EBP+4]
  8309.         SUB EAX,5
  8310.         MOV Adr,EAX
  8311.         MOV EAX,[EBP+16]  //VAR f:FILE
  8312.         MOV fi,EAX
  8313.      END;
  8314.  
  8315.      STR(Value:Format,s);
  8316.      SaveIO:=RaiseIOError;
  8317.      RaiseIOError:=FALSE;
  8318.      BlockWrite(fi^,s[1],length(s));
  8319.      RaiseIOError:=SaveIO;
  8320.      IF InOutRes<>0 THEN
  8321.      BEGIN
  8322.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8323.           ELSE exit;
  8324.      END;
  8325. END;
  8326.  
  8327. PROCEDURE WriteLongWordText({VAR f:FILE}Value:LONGWORD;Format:LONGWORD);
  8328. VAR
  8329.    fi:^FILE;
  8330.    s:STRING;
  8331.    Adr:LONGINT;
  8332.    SaveIO:BOOLEAN;
  8333. BEGIN
  8334.      ASM
  8335.         MOV EAX,[EBP+4]
  8336.         SUB EAX,5
  8337.         MOV Adr,EAX
  8338.         MOV EAX,[EBP+16]  //VAR f:FILE
  8339.         MOV fi,EAX
  8340.      END;
  8341.  
  8342.      STR(Value:Format,s);
  8343.      SaveIO:=RaiseIOError;
  8344.      RaiseIOError:=FALSE;
  8345.      BlockWrite(fi^,s[1],length(s));
  8346.      RaiseIOError:=SaveIO;
  8347.      IF InOutRes<>0 THEN
  8348.      BEGIN
  8349.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8350.           ELSE exit;
  8351.      END;
  8352. END;
  8353.  
  8354. {$HINTS OFF}
  8355. PROCEDURE WriteBooleanText({VAR f:FILE}Value:Boolean;Format:LONGWORD);
  8356. VAR
  8357.    fi:^FILE;
  8358.    s:STRING;
  8359.    Adr:LONGINT;
  8360.    SaveIO:BOOLEAN;
  8361. BEGIN
  8362.      ASM
  8363.         MOV EAX,[EBP+4]
  8364.         SUB EAX,5
  8365.         MOV Adr,EAX
  8366.         MOV EAX,[EBP+16]  //VAR f:FILE
  8367.         MOV fi,EAX
  8368.      END;
  8369.  
  8370.      IF Value THEN s:='TRUE'
  8371.      ELSE s:='FALSE';
  8372.      SaveIO:=RaiseIOError;
  8373.      RaiseIOError:=FALSE;
  8374.      BlockWrite(fi^,s[1],length(s));
  8375.      RaiseIOError:=SaveIO;
  8376.      IF InOutRes<>0 THEN
  8377.      BEGIN
  8378.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8379.           ELSE exit;
  8380.      END;
  8381. END;
  8382. {$HINTS ON}
  8383.  
  8384. PROCEDURE WriteCharText({VAR f:FILE}Value:Char;Format:LONGWORD);
  8385. VAR
  8386.    fi:^FILE;
  8387.    s:STRING;
  8388.    Adr:LONGINT;
  8389. BEGIN
  8390.      ASM
  8391.         MOV EAX,[EBP+4]
  8392.         SUB EAX,5
  8393.         MOV Adr,EAX
  8394.         MOV EAX,[EBP+16]  //VAR f:FILE
  8395.         MOV fi,EAX
  8396.      END;
  8397.      s:=Value;
  8398.      ASM
  8399.         PUSH DWORD PTR fi
  8400.         LEA EAX,s
  8401.         PUSH EAX
  8402.         PUSH DWORD PTR Format
  8403.         CALLN32 SYSTEM.StrWriteText
  8404.         ADD ESP,4
  8405.      END;
  8406. END;
  8407.  
  8408.  
  8409. PROCEDURE WritelnText(VAR f:FILE);
  8410. VAR
  8411.    w:WORD;
  8412.    Adr:LONGINT;
  8413.    SaveIO:BOOLEAN;
  8414. BEGIN
  8415.      ASM
  8416.         MOV EAX,[EBP+4]
  8417.         SUB EAX,5
  8418.         MOV Adr,EAX
  8419.      END;
  8420.      {Write #13#10}
  8421.      w:=$0a0d;
  8422.      SaveIO:=RaiseIOError;
  8423.      RaiseIOError:=FALSE;
  8424.      BlockWrite(f,w,2);
  8425.      RaiseIOError:=SaveIO;
  8426.      IF InOutRes<>0 THEN
  8427.      BEGIN
  8428.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8429.           ELSE exit;
  8430.      END;
  8431. END;
  8432.  
  8433. {$HINTS OFF}
  8434. PROCEDURE WriteText(VAR f:FILE);
  8435. BEGIN
  8436.      {do nothing here - just pop f}
  8437. END;
  8438. {$HINTS ON}
  8439.  
  8440. PROCEDURE FileWrite({VAR f:FILE)}VAR Buf;size:LONGWORD);
  8441. VAR
  8442.    fi:^FILE;
  8443.    fr:^FileRec;
  8444.    Adr:LONGINT;
  8445.    SaveIO:BOOLEAN;
  8446. BEGIN
  8447.      ASM
  8448.         MOV EAX,[EBP+16]  //VAR f:FILE
  8449.         MOV fi,EAX
  8450.         MOV fr,EAX
  8451.      END;
  8452.      ASM
  8453.         MOV EAX,[EBP+4]
  8454.         SUB EAX,5
  8455.         MOV Adr,EAX
  8456.      END;
  8457.      SaveIO:=RaiseIOError;
  8458.      RaiseIOError:=FALSE;
  8459.      BlockWrite(fi^,Buf,size DIV fr^.RecSize);
  8460.      RaiseIOError:=SaveIO;
  8461.      IF InOutRes<>0 THEN
  8462.      BEGIN
  8463.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8464.           ELSE exit;
  8465.      END;
  8466. END;
  8467.  
  8468. PROCEDURE FileRead({VAR f:FILE}VAR Buf;size:LONGWORD);
  8469. VAR
  8470.    fi:^FILE;
  8471.    fr:^FileRec;
  8472.    Adr:LONGINT;
  8473.    SaveIO:BOOLEAN;
  8474. BEGIN
  8475.      ASM
  8476.         MOV EAX,[EBP+4]
  8477.         SUB EAX,5
  8478.         MOV Adr,EAX
  8479.      END;
  8480.      ASM
  8481.         MOV EAX,[EBP+16]  //VAR f:FILE
  8482.         MOV fi,EAX
  8483.         MOV fr,EAX
  8484.      END;
  8485.  
  8486.      SaveIO:=RaiseIOError;
  8487.      RaiseIOError:=FALSE;
  8488.      BlockRead(fi^,Buf,size DIV fr^.RecSize);
  8489.      RaiseIOError:=SaveIO;
  8490.      IF InOutRes<>0 THEN
  8491.      BEGIN
  8492.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8493.           ELSE exit;
  8494.      END;
  8495. END;
  8496.  
  8497. FUNCTION SeekEoln(VAR F:Text):Boolean;
  8498. VAR
  8499.     Adr:LONGINT;
  8500.     fi:^FileRec;
  8501.     Offset:LONGINT;
  8502.     Value:BYTE;
  8503.     SaveIoError:BOOLEAN;
  8504.     Res:LONGWORD;
  8505.     t:BYTE;
  8506.     s:STRING;
  8507. BEGIN
  8508.      ASM
  8509.         MOV EAX,[EBP+4]
  8510.         SUB EAX,5
  8511.         MOV Adr,EAX
  8512.      END;
  8513.  
  8514.      fi:=@f;
  8515.  
  8516.      IF fi^.flags<>$6666 THEN
  8517.      BEGIN
  8518.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  8519.           ELSE
  8520.           BEGIN
  8521.                InOutRes:=206;
  8522.                exit;
  8523.           END;
  8524.      END;
  8525.  
  8526.      IF fi^.Handle=$ffffffff THEN
  8527.      BEGIN
  8528.          InOutRes:=6; {Invalid handle}
  8529.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8530.          ELSE exit;
  8531.      END;
  8532.  
  8533.      IF eof(f) THEN
  8534.      BEGIN
  8535.           result:=TRUE;
  8536.           exit;
  8537.      END;
  8538.  
  8539.      Offset:=fi^.Offset;
  8540.  
  8541.      IF fi^.Buffer=NIL THEN
  8542.      BEGIN
  8543.           IF lo(fi^.BufferBytes)=1 THEN
  8544.           BEGIN
  8545.                Value:=Hi(fi^.BufferBytes);
  8546.           END
  8547.           ELSE
  8548.           BEGIN
  8549.                SaveIOError:=RaiseIOError;
  8550.                RaiseIOError:=FALSE;
  8551.                BlockRead(f,Value,1,Res);
  8552.                Seek(f,FilePos(f)-1);
  8553.                RaiseIOError:=SaveIOError;
  8554.                IF Res=0 THEN Value:=26; {EOF}
  8555.           END;
  8556.      END
  8557.      ELSE value:=fi^.Buffer^[Offset];
  8558.  
  8559.      IF value IN [13,10,26] THEN result:=TRUE
  8560.      ELSE
  8561.      BEGIN
  8562.           IF not (value IN [9,32]) THEN result:=FALSE
  8563.           ELSE  {must read the line}
  8564.           BEGIN
  8565.                SaveIOError:=RaiseIOError;
  8566.                RaiseIOError:=FALSE;
  8567.  
  8568.                Offset:=FilePos(f);
  8569.                Readln(f,s);
  8570.                Seek(f,Offset);
  8571.  
  8572.                RaiseIOError:=SaveIOError;
  8573.                result:=TRUE;
  8574.                FOR t:=1 TO length(s) DO
  8575.                  IF not (s[t] IN [#9,#32]) THEN result:=FALSE;
  8576.           END;
  8577.      END;
  8578. END;
  8579.  
  8580. FUNCTION SeekEof(Var F :Text):Boolean;
  8581. VAR
  8582.     Adr:LONGINT;
  8583.     fi:^FileRec;
  8584.     OldFP:LONGWORD;
  8585.     ch:Char;
  8586. BEGIN
  8587.      ASM
  8588.         MOV EAX,[EBP+4]
  8589.         SUB EAX,5
  8590.         MOV Adr,EAX
  8591.      END;
  8592.  
  8593.      fi:=@f;
  8594.  
  8595.      IF fi^.flags<>$6666 THEN
  8596.      BEGIN
  8597.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  8598.           ELSE
  8599.           BEGIN
  8600.                InOutRes:=206;
  8601.                exit;
  8602.           END;
  8603.      END;
  8604.  
  8605.      IF fi^.Handle=$ffffffff THEN
  8606.      BEGIN
  8607.          InOutRes:=6; {Invalid handle}
  8608.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8609.          ELSE exit;
  8610.      END;
  8611.  
  8612.      OldFP := FilePos(F);
  8613.  
  8614.      WHILE not Eof(F) DO
  8615.      BEGIN
  8616.           Read(F,ch);
  8617.           IF not (ch IN [#32,#9,#13,#10]) THEN break;
  8618.      END;
  8619.  
  8620.      Result := Eof(f);
  8621.      Seek(F,OldFP);
  8622. END;
  8623.  
  8624. PROCEDURE TextRead({VAR f:TEXT;}VAR s:STRING;Typ,MaxLen:LONGWORD);
  8625. VAR
  8626.    fi:^FileRec;
  8627.    fi2:^TEXT;
  8628.    Offset,Ende,t,Temp,Res:LONGWORD;
  8629.    Count:WORD;
  8630.    Value:BYTE;
  8631.    SaveIoError:BOOLEAN;
  8632.    Adr:LONGINT;
  8633. LABEL l,skip;
  8634. BEGIN
  8635.      ASM
  8636.         MOV EAX,[EBP+4]
  8637.         SUB EAX,5
  8638.         MOV Adr,EAX
  8639.      END;
  8640.      ASM
  8641.         MOV EAX,[EBP+20]  //VAR f:TEXT
  8642.         MOV fi,EAX
  8643.         MOV fi2,EAX
  8644.      END;
  8645.  
  8646.      IF fi^.flags<>$6666 THEN
  8647.      BEGIN
  8648.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  8649.           ELSE
  8650.           BEGIN
  8651.                InOutRes:=206;
  8652.                exit;
  8653.           END;
  8654.      END;
  8655.  
  8656.      IF fi^.Handle=$ffffffff THEN
  8657.      BEGIN
  8658.          InOutRes:=6; {Invalid handle}
  8659.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8660.          ELSE exit;
  8661.      END;
  8662.  
  8663.      fi^.reserved1:=fi^.reserved1 and not 1;
  8664.  
  8665.      IF eof(fi2^) THEN
  8666.      BEGIN
  8667.           (*InOutRes:=38;  {Handle EOF}
  8668.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8669.           ELSE exit;*)
  8670.           CASE Typ OF
  8671.             1:s:=''; {String}
  8672.             2:s:=chr(26); {Char}
  8673.             3:s:=''; {Number}
  8674.             ELSE s:='';
  8675.           END; {case}
  8676.           exit;
  8677.      END;
  8678.  
  8679.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  8680.      ELSE Ende:=fi^.LOffset;
  8681.  
  8682.      Count:=0;
  8683.      s:='';
  8684.  
  8685.      Offset:=fi^.Offset;
  8686.  
  8687.      IF fi^.Buffer=NIL THEN
  8688.      BEGIN
  8689.           Offset:=0;
  8690.           Ende:=256;
  8691.      END;
  8692.  
  8693.      fi^.reserved1:=fi^.reserved1 and not 1;
  8694. l:
  8695.      FOR t:=Offset TO Ende-1 DO
  8696.      BEGIN
  8697.           IF fi^.Buffer=NIL THEN
  8698.           BEGIN
  8699.                IF lo(fi^.BufferBytes)=1 THEN
  8700.                BEGIN
  8701.                     Value:=Hi(fi^.BufferBytes);
  8702.                     fi^.BufferBytes:=0;
  8703.                END
  8704.                ELSE
  8705.                BEGIN
  8706.                     SaveIOError:=RaiseIOError;
  8707.                     RaiseIOError:=FALSE;
  8708.                     BlockRead(fi2^,Value,1,Res);
  8709.                     RaiseIOError:=SaveIOError;
  8710.                     IF InOutRes<>0 THEN
  8711.                     BEGIN
  8712.                          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8713.                          ELSE exit;
  8714.                     END;
  8715.                     IF Res=0 THEN Value:=26; {EOF}
  8716.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  8717.                END;
  8718.           END
  8719.           ELSE value:=fi^.Buffer^[t];
  8720.  
  8721.           IF value=26 {EOF} THEN
  8722.           BEGIN
  8723.                {SaveIoError:=RaiseIoError;
  8724.                RaiseIOError:=FALSE;
  8725.                Seek(fi2^,FileSize(fi2^));
  8726.                RaiseIOError:=SaveIoError;}
  8727.                fi^.Reserved1:=fi^.Reserved1 OR 1;  {mark EOF}
  8728.                IF Count>255 THEN Count:=255;
  8729.                s[0]:=chr(Count);
  8730.                IF s='' THEN s:=#26;
  8731.                inc(fi^.Offset);
  8732.                fi^.BufferBytes:=0;
  8733.                exit;
  8734.           END;
  8735.  
  8736.           CASE Typ OF
  8737.             1:  {String}
  8738.             BEGIN
  8739.                  CASE value OF
  8740.                    13,10:
  8741.                    BEGIN
  8742.                         IF Count>255 THEN Count:=255;
  8743.                         IF Count>255 THEN Count:=255;
  8744.                         s[0]:=chr(Count);
  8745.                         exit;
  8746.                    END;
  8747.                  END; {case}
  8748.             END;
  8749.             2:  {Char}
  8750.             BEGIN
  8751.                  s[1]:=chr(Value);
  8752.                  s[0]:=#1;
  8753.  
  8754.                  IF fi^.Buffer<>NIL THEN inc(fi^.Offset)
  8755.                  ELSE fi^.BufferBytes:=0;
  8756.                  IF fi^.Offset=Ende THEN
  8757.                  BEGIN
  8758.                       IF Eof(fi2^) THEN exit;
  8759.  
  8760.                       {Ende erreicht --> erweitern}
  8761.                       IF fi^.Buffer=NIL THEN exit;
  8762.                       FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  8763.                       IF InOutRes<>0 THEN
  8764.                       BEGIN
  8765.                           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8766.                           ELSE exit;
  8767.                       END;
  8768.                       fi^.offset:=0;
  8769.                       inc(fi^.block);
  8770.                  END;
  8771.                  exit;
  8772.             END;
  8773.             3:  {Number}
  8774.             BEGIN
  8775.                  CASE value OF
  8776.                    13,10,32,9:
  8777.                    BEGIN
  8778.                         IF Count=0 THEN goto skip; {skip preceding chars}
  8779.                         IF Count>255 THEN Count:=255;
  8780.                         s[0]:=chr(Count);
  8781.                         exit;
  8782.                    END;
  8783.                  END; {case}
  8784.             END;
  8785.           END; {case}
  8786.  
  8787.           inc(Count);
  8788.           IF Count<256 THEN IF Count<=MaxLen THEN s[Count]:=chr(value);
  8789. skip:
  8790.           inc(fi^.Offset);
  8791.           fi^.BufferBytes:=0;
  8792.           IF Count>=MaxLen THEN
  8793.           BEGIN
  8794.                IF Count>255 THEN Count:=255;
  8795.                s[0]:=chr(Count);
  8796.                exit;
  8797.           END;
  8798.      END;
  8799.  
  8800.      IF eof(fi2^) THEN
  8801.      BEGIN
  8802.           (*InOutRes:=38;  {Handle EOF}
  8803.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8804.           ELSE exit;*)
  8805.           IF Count>255 THEN Count:=255;
  8806.           s[0]:=chr(Count);
  8807.           exit;
  8808.      END;
  8809.  
  8810.      {Ende erreicht --> erweitern}
  8811.      IF fi^.Buffer<>NIL THEN
  8812.      BEGIN
  8813.           FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  8814.           IF InOutRes<>0 THEN
  8815.           BEGIN
  8816.               IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8817.               ELSE exit;
  8818.           END;
  8819.  
  8820.           fi^.offset:=0;
  8821.           inc(fi^.block);
  8822.      END;
  8823.  
  8824.      IF eof(fi2^) THEN
  8825.      BEGIN
  8826.           InOutRes:=38;  {Handle EOF}
  8827.           IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8828.           ELSE exit;
  8829.      END;
  8830.  
  8831.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  8832.      ELSE Ende:=fi^.LOffset;
  8833.      Offset:=fi^.Offset;
  8834.      IF fi^.Buffer=NIL THEN
  8835.      BEGIN
  8836.           Offset:=0;
  8837.           Ende:=256;
  8838.      END;
  8839.      goto l;
  8840. END;
  8841.  
  8842. PROCEDURE TextReadLF(VAR f:TEXT);
  8843. VAR
  8844.    fi:^FileRec;
  8845.    Offset,Ende,t,Temp,Res:LONGWORD;
  8846.    Value:BYTE;
  8847.    Read13,Read10:BOOLEAN;
  8848.    Adr:LONGINT;
  8849.    SaveIO:BOOLEAN;
  8850. LABEL l;
  8851. BEGIN
  8852.      ASM
  8853.         MOV EAX,[EBP+4]
  8854.         SUB EAX,5
  8855.         MOV Adr,EAX
  8856.      END;
  8857.      fi:=@f;
  8858.  
  8859.      IF fi^.flags<>$6666 THEN
  8860.      BEGIN
  8861.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  8862.           ELSE
  8863.           BEGIN
  8864.                InOutRes:=206;
  8865.                exit;
  8866.           END;
  8867.      END;
  8868.  
  8869.      IF fi^.Handle=$ffffffff THEN
  8870.      BEGIN
  8871.          InOutRes:=6; {Invalid handle}
  8872.          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8873.          ELSE exit;
  8874.      END;
  8875.  
  8876.      fi^.reserved1:=fi^.reserved1 and not 1;
  8877.  
  8878.      IF Eof(f) THEN exit;
  8879.  
  8880.      Offset:=fi^.Offset;
  8881.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  8882.      ELSE Ende:=fi^.LOffset;
  8883.  
  8884.      IF fi^.Buffer=NIL THEN
  8885.      BEGIN
  8886.           Offset:=0;
  8887.           Ende:=256;
  8888.      END;
  8889.  
  8890.      Read13:=FALSE;
  8891.      Read10:=FALSE;
  8892. l:
  8893.      FOR t:=Offset TO Ende-1 DO
  8894.      BEGIN
  8895.           IF fi^.Buffer=NIL THEN
  8896.           BEGIN
  8897.                IF lo(fi^.BufferBytes)=1 THEN
  8898.                BEGIN
  8899.                     Value:=Hi(fi^.BufferBytes);
  8900.                     fi^.BufferBytes:=0;
  8901.                END
  8902.                ELSE
  8903.                BEGIN
  8904.                     SaveIO:=RaiseIOError;
  8905.                     RaiseIOError:=FALSE;
  8906.                     BlockRead(f,Value,1,Res);
  8907.                     RaiseIOError:=SaveIO;
  8908.                     IF InOutRes<>0 THEN
  8909.                     BEGIN
  8910.                          IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8911.                          ELSE exit;
  8912.                     END;
  8913.                     IF Res=0 THEN Value:=26; {EOF}
  8914.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  8915.                END;
  8916.           END
  8917.           ELSE value:=fi^.Buffer^[t];
  8918.           CASE value OF
  8919.             26: {EOF}
  8920.             BEGIN
  8921.                fi^.Reserved1:=fi^.Reserved1 OR 1; {mark EOF}
  8922.                exit;
  8923.             END;
  8924.             13:
  8925.             BEGIN
  8926.                  IF ((Read13)OR(Read10)) THEN
  8927.                  BEGIN
  8928.                       fi^.BufferBytes:=0;
  8929.                       exit;
  8930.                  END;
  8931.                  Read13:=TRUE;
  8932.             END;
  8933.             10:
  8934.             BEGIN
  8935.                  IF Read10 THEN
  8936.                  BEGIN
  8937.                       fi^.BufferBytes:=0;
  8938.                       exit;
  8939.                  END;
  8940.                  {$IFDEF OS2}
  8941.                  IF fi^.Handle=0{Input} THEN IF Read13 THEN
  8942.                  {$ELSE}
  8943.                  IF fi^.Handle=GetStdHandle(-10){Input} THEN IF Read13 THEN
  8944.                  {$ENDIF}
  8945.                  BEGIN
  8946.                       fi^.BufferBytes:=0;
  8947.                       exit;
  8948.                  END;
  8949.                  Read10:=TRUE;
  8950.             END;
  8951.             ELSE
  8952.             BEGIN
  8953.                  IF Read13 THEN
  8954.                  BEGIN
  8955.                       fi^.BufferBytes:=0;
  8956.                       exit;
  8957.                  END;
  8958.                  IF Read10 THEN
  8959.                  BEGIN
  8960.                       fi^.BufferBytes:=0;
  8961.                       exit;
  8962.                  END;
  8963.             END;
  8964.           END; {case}
  8965.           inc(fi^.Offset);
  8966.           fi^.BufferBytes:=0;
  8967.      END;
  8968.  
  8969.      IF Eof(f) THEN exit;
  8970.  
  8971.      {Ende erreicht --> erweitern}
  8972.      IF fi^.Buffer<>NIL THEN
  8973.      BEGIN
  8974.          FileBlockIO(f,fi^.block+1,ReadMode,Temp);
  8975.          IF InOutRes<>0 THEN
  8976.          BEGIN
  8977.              IF RaiseIOError THEN InOutError(InOutRes,Adr)
  8978.              ELSE exit;
  8979.          END;
  8980.          fi^.offset:=0;
  8981.          inc(fi^.block);
  8982.      END;
  8983.  
  8984.      IF eof(f) THEN exit;
  8985.  
  8986.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  8987.      ELSE Ende:=fi^.LOffset;
  8988.      Offset:=fi^.Offset;
  8989.      IF fi^.Buffer=NIL THEN
  8990.      BEGIN
  8991.           Offset:=0;
  8992.           Ende:=256;
  8993.      END;
  8994.      goto l;
  8995. END;
  8996.  
  8997. PROCEDURE ReadLnText(VAR source:TEXT);
  8998. BEGIN
  8999.      TextReadLF(source);
  9000. END;
  9001.  
  9002. //TextScreen IO support
  9003.  
  9004. TYPE ProcVar=PROCEDURE;
  9005.  
  9006. {$IFDEF OS2}
  9007. PROCEDURE TScreenInOutClass.WriteStr(CONST s:STRING);
  9008. VAR
  9009.    actual:LONGWORD;
  9010.    by,by1:LONGWORD;
  9011.    Handle:LONGWORD;
  9012.    b:BYTE;
  9013.    ff:^FileRec;
  9014.    s1,s2:STRING;
  9015.    y:LONGINT;
  9016.    Fill:WORD;
  9017. LABEL l,l1;
  9018. BEGIN
  9019.      ff:=@Output;
  9020.      Handle:=ff^.Handle;
  9021.  
  9022.      IF RedirectOut THEN goto l1;
  9023.  
  9024.      s1:=s;
  9025.      b:=Pos(#13#10,s1);
  9026.      WHILE b<>0 DO
  9027.      BEGIN
  9028.           s2:=s1;
  9029.           s1:=copy(s1,1,b-1);
  9030.           WriteStr(s1);
  9031.           s1:=#13#10;
  9032.           ASM
  9033.             LEA EAX,actual
  9034.             PUSH EAX                //pcbActual
  9035.             LEA EDI,s1
  9036.             MOVZXB EAX,[EDI]
  9037.             PUSH EAX               //cbWrite
  9038.             INC EDI
  9039.             PUSH EDI               //pBuffer
  9040.             PUSH DWORD PTR Handle  //FileHandle
  9041.             MOV AL,4
  9042.             CALLDLL DosCalls,282   //DosWrite
  9043.             ADD ESP,16
  9044.           END;
  9045.           y:=VioWhereYProc;
  9046.           IF y-1>Hi(WindMax) THEN
  9047.           BEGIN
  9048.               {Scroll window}
  9049.               Fill:= 32 + WORD(TextAttr) SHL 8;
  9050.               VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  9051.                               Hi(WindMax),Lo(WindMax),
  9052.                               1,Fill,0);
  9053.               dec(y);
  9054.           END;
  9055.           GotoXY(1,y-Hi(WindMin));
  9056.           s1:=copy(s2,b+2,length(s2)-(b+1));
  9057.           b:=Pos(#13#10,s1);
  9058.      END;
  9059.  
  9060.      IF length(s1)>(Lo(WindMax)-Lo(WindMin)-
  9061.               (VioWhereXProc-lo(WindMin)))+1 THEN
  9062.      BEGIN
  9063.           by:=(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+2;
  9064.           by1:=length(s1)-by;
  9065. l:
  9066.           ASM
  9067.              LEA EAX,actual
  9068.              PUSH EAX               //pcbActual
  9069.              LEA EDI,s1
  9070.              INC EDI
  9071.              PUSH DWORD PTR by      //cbWrite
  9072.              PUSH EDI               //pBuffer
  9073.              PUSH DWORD PTR Handle  //FileHandle
  9074.              MOV AL,4
  9075.              CALLDLL DosCalls,282   //DosWrite
  9076.              ADD ESP,16
  9077.           END;
  9078.           s1:=copy(s1,by+1,length(s1)-by);
  9079.  
  9080.           IF ((WindMin<>MaxWindMin)OR(WindMax<>MaxWindMax)) THEN WriteLF;
  9081.  
  9082.           IF length(s1)>(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+1 THEN
  9083.           BEGIN
  9084.                by:=(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+2;
  9085.                by1:=length(s1)-by;
  9086.                goto l;
  9087.           END;
  9088.  
  9089.           ASM
  9090.              LEA EAX,actual
  9091.              PUSH EAX               //pcbActual
  9092.              LEA EDI,s1
  9093.              INC EDI
  9094.              PUSH DWORD PTR by1     //cbWrite
  9095.              PUSH EDI               //pBuffer
  9096.              PUSH DWORD PTR Handle  //FileHandle
  9097.              MOV AL,4
  9098.              CALLDLL DosCalls,282   //DosWrite
  9099.              ADD ESP,16
  9100.           END;
  9101.  
  9102.           exit;
  9103.      END;
  9104. l1:
  9105.      ASM
  9106.         LEA EAX,actual
  9107.         PUSH EAX                //pcbActual
  9108.         LEA EDI,s1
  9109.         MOVZXB EAX,[EDI]
  9110.         PUSH EAX               //cbWrite
  9111.         INC EDI
  9112.         PUSH EDI               //pBuffer
  9113.         PUSH DWORD PTR Handle  //FileHandle
  9114.         MOV AL,4
  9115.         CALLDLL DosCalls,282   //DosWrite
  9116.         ADD ESP,16
  9117.      END;
  9118. END;
  9119. {$ENDIF}
  9120. {$IFDEF WIN95}
  9121. PROCEDURE TScreenInOutClass.WriteStr(CONST s:STRING);
  9122. VAR
  9123.    actual:LONGWORD;
  9124.    by,by1:LONGWORD;
  9125.    Handle:LONGWORD;
  9126.    b:BYTE;
  9127.    ff:^FileRec;
  9128.    s1,s2:STRING;
  9129.    x,y:LONGINT;
  9130.    Fill:WORD;
  9131.    csbi:CONSOLE_SCREEN_BUFFER_INFO;
  9132.    coPos:COORD;
  9133.    sr:SMALL_RECT;
  9134.    ci:CHAR_INFO;
  9135. LABEL l,l1;
  9136. BEGIN
  9137.      ff:=@Output;
  9138.      Handle:=ff^.Handle;
  9139.  
  9140.      IF RedirectOut THEN goto l1;
  9141.  
  9142.      s1:=s;
  9143.      b:=Pos(#13#10,s1);
  9144.      WHILE b<>0 DO
  9145.      BEGIN
  9146.           s2:=s1;
  9147.           s1:=copy(s1,1,b-1);
  9148.           WriteStr(s1);
  9149.           s1:=#13#10;
  9150.           WriteFile(ff^.Handle,s1[1],length(s1),actual,NIL);
  9151.           GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  9152.           y:=csbi.dwCursorPosition.Y+1;
  9153.           IF y-1>Hi(WindMax) THEN
  9154.           BEGIN
  9155.               {Scroll window}
  9156.               Fill:= TextAttr;
  9157.               sr.Left:=lo(WindMin);
  9158.               sr.Right:=lo(WindMax)+1;
  9159.               sr.Top:=hi(WindMin)+1;
  9160.               sr.Bottom:=hi(WindMax);
  9161.               coPos.X:=lo(WindMin);
  9162.               coPos.Y:=hi(WindMin);
  9163.               ci.Char.AsciiChar:=#32;
  9164.               ci.Attributes:=Fill;
  9165.               ScrollConsoleScreenBuffer(ff^.Handle,sr,NIL,LONGWORD(coPos),ci);
  9166.               dec(y);
  9167.           END;
  9168.           GotoXY(1,y-Hi(WindMin));
  9169.           s1:=copy(s2,b+2,length(s2)-(b+1));
  9170.           b:=Pos(#13#10,s1);
  9171.      END;
  9172.  
  9173.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  9174.      x:=csbi.dwCursorPosition.X+1;
  9175.      IF length(s1)>(Lo(WindMax)-Lo(WindMin)-
  9176.               (x-lo(WindMin)))+1 THEN
  9177.      BEGIN
  9178.           by:=(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+2;
  9179.           by1:=length(s1)-by;
  9180. l:
  9181.           WriteFile(ff^.Handle,s1[1],by,actual,NIL);
  9182.           s1:=copy(s1,by+1,length(s1)-by);
  9183.  
  9184.           IF ((WindMin<>MaxWindMin)OR(WindMax<>MaxWindMax)) THEN WriteLF;
  9185.  
  9186.           GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  9187.           x:=csbi.dwCursorPosition.X+1;
  9188.           IF length(s1)>(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+1 THEN
  9189.           BEGIN
  9190.                by:=(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+2;
  9191.                by1:=length(s1)-by;
  9192.                goto l;
  9193.           END;
  9194.  
  9195.           WriteFile(ff^.Handle,s1[1],by1,actual,NIL);
  9196.  
  9197.           exit;
  9198.      END;
  9199. l1:
  9200.      WriteFile(ff^.Handle,s1[1],length(s1),actual,NIL);
  9201. END;
  9202. {$ENDIF}
  9203.  
  9204. PROCEDURE TScreenInOutClass.WriteCStr(CONST s:CSTRING);
  9205. VAR
  9206.    c:STRING;
  9207.    b:LONGWORD;
  9208.    pc:^CSTRING;
  9209. LABEL l;
  9210. BEGIN
  9211.      pc:=@s;
  9212. l:
  9213.      b:=Length(pc^);
  9214.      IF b<255 THEN
  9215.      BEGIN
  9216.           c:=pc^;
  9217.           WriteStr(c);
  9218.      END
  9219.      ELSE
  9220.      BEGIN
  9221.           move(pc^,c[1],255);
  9222.           c[0]:=#255;
  9223.           inc(pc,255);
  9224.           WriteStr(c);
  9225.           goto l;
  9226.      END;
  9227. END;
  9228.  
  9229. {$IFDEF OS2}
  9230. PROCEDURE TScreenInOutClass.WriteLF;
  9231. VAR y:BYTE;
  9232.     Fill:WORD;
  9233.     s:STRING[3];
  9234.     actual:LONGWORD;
  9235.     ff:^FileRec;
  9236.     Handle:LONGWORD;
  9237. BEGIN
  9238.      s:=#13#10;
  9239.      ff:=@Output;
  9240.      Handle:=ff^.Handle;
  9241.  
  9242.      ASM
  9243.         LEA EAX,actual
  9244.         PUSH EAX                //pcbActual
  9245.         LEA EDI,s
  9246.         MOVZXB EAX,[EDI]
  9247.         PUSH EAX               //cbWrite
  9248.         INC EDI
  9249.         PUSH EDI               //pBuffer
  9250.         PUSH DWORD PTR Handle  //FileHandle
  9251.         MOV AL,4
  9252.         CALLDLL DosCalls,282   //DosWrite
  9253.         ADD ESP,16
  9254.      END;
  9255.  
  9256.      y:=VioWhereYProc;
  9257.      IF y-1>Hi(WindMax) THEN
  9258.      BEGIN
  9259.           {Scroll window}
  9260.           Fill:= 32 + WORD(TextAttr) SHL 8;
  9261.           VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  9262.                           Hi(WindMax),Lo(WindMax),
  9263.                           1,Fill,0);
  9264.           dec(y);
  9265.      END;
  9266.      GOTOXY(1,y-Hi(WindMin));
  9267. END;
  9268.  
  9269. PROCEDURE TScreenInOutClass.ReadLF(VAR s:STRING);
  9270. TYPE
  9271.     STRINGINBUF=RECORD
  9272.                      cb:WORD;
  9273.                      cchIn:WORD;
  9274.                 END;
  9275. VAR
  9276.     t:BYTE;
  9277.     ff:^FileRec;
  9278.     y:LONGINT;
  9279.     Fill:WORD;
  9280. BEGIN
  9281.      {si.cb:=255;
  9282.      si.cchin:=0;
  9283.      KbdStringInProc(s[1],si,0,0);
  9284.      s[0]:=chr(si.cchIn);}
  9285.      ASM
  9286.         PUSHL OFFSET(SYSTEM.Input)
  9287.         MOV EAX,s
  9288.         PUSH EAX
  9289.         PUSHL 1
  9290.         PUSHL 255
  9291.         CALLN32 SYSTEM.TextRead
  9292.         ADD ESP,8
  9293.         PUSHL OFFSET(SYSTEM.Input)
  9294.         CALLN32 SYSTEM.TextReadLF
  9295.      END;
  9296.      t:=Pos(#26,s);
  9297.      IF t<>0 THEN
  9298.      BEGIN
  9299.           ff:=@Input;
  9300.           ff^.Reserved1:=ff^.Reserved1 OR 1; {mark EOF}
  9301.           s[0]:=chr(t-1);
  9302.      END;
  9303.      y:=VioWhereYProc;
  9304.      IF y-1>Hi(WindMax) THEN
  9305.      BEGIN
  9306.           {Scroll window}
  9307.           Fill:= 32 + WORD(TextAttr) SHL 8;
  9308.           VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  9309.                           Hi(WindMax),Lo(WindMax),
  9310.                           1,Fill,0);
  9311.           dec(y);
  9312.      END;
  9313.      ScreenInOut.GotoXY(1,y-Hi(WindMin));
  9314. END;
  9315. {$ENDIF}
  9316. {$IFDEF WIN95}
  9317. PROCEDURE TScreenInOutClass.WriteLF;
  9318. VAR y:BYTE;
  9319.     Fill:WORD;
  9320.     coPos:COORD;
  9321.     csbi:CONSOLE_SCREEN_BUFFER_INFO;
  9322.     ff:^FileRec;
  9323.     Actual:LONGWORD;
  9324.     sr:SMALL_RECT;
  9325.     ci:CHAR_INFO;
  9326.     s:STRING;
  9327. BEGIN
  9328.      s:=#13#10;
  9329.      ff:=@Output;
  9330.      WriteFile(ff^.Handle,s[1],length(s),actual,NIL);
  9331.  
  9332.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  9333.      y:=csbi.dwCursorPosition.Y+1;
  9334.      IF y-1>Hi(WindMax) THEN
  9335.      BEGIN
  9336.           {Scroll window}
  9337.           Fill:= TextAttr;
  9338.           {Scroll window}
  9339.           sr.Left:=lo(WindMin);
  9340.           sr.Right:=lo(WindMax);
  9341.           sr.Top:=hi(WindMin)+1;
  9342.           sr.Bottom:=hi(WindMax);
  9343.           coPos.X:=lo(WindMin);
  9344.           coPos.Y:=hi(WindMin);
  9345.           ci.Char.AsciiChar:=#32;
  9346.           ci.Attributes:=Fill;
  9347.           ScrollConsoleScreenBuffer(ff^.Handle,sr,NIL,LONGWORD(coPos),ci);
  9348.           dec(y);
  9349.      END;
  9350.      GOTOXY(1,y-Hi(WindMin));
  9351. END;
  9352.  
  9353. PROCEDURE TScreenInOutClass.ReadLF(VAR s:STRING);
  9354. VAR ff:^FileRec;
  9355.     Actual:LONGWORD;
  9356. BEGIN
  9357.      ff:=@Input;
  9358.      ReadFile(ff^.Handle,s[1],255,Actual,NIL);
  9359.      s[0]:=chr(Actual);
  9360.      IF s[length(s)]=#10 THEN dec(s[0]);
  9361.      IF s[length(s)]=#13 THEN dec(s[0]);
  9362. END;
  9363. {$ENDIF}
  9364.  
  9365. {$IFDEF OS2}
  9366. PROCEDURE TScreenInOutClass.GotoXY(x,y:BYTE);
  9367. BEGIN
  9368.      X:=X-1+Lo(WindMin);
  9369.      Y:=Y-1+Hi(WindMin);
  9370.      IF (X<=Lo(WindMax))and(Y<=Hi(WindMax)) THEN VioSetCurPosProc(Y,X,0);
  9371. END;
  9372. {$ENDIF}
  9373. {$IFDEF WIN95}
  9374. PROCEDURE TScreenInOutClass.GotoXY(x,y:BYTE);
  9375. VAR coPos:COORD;
  9376.     ff:^FileRec;
  9377. BEGIN
  9378.      X:=X-1+Lo(WindMin);
  9379.      Y:=Y-1+Hi(WindMin);
  9380.      IF (X<=Lo(WindMax))and(Y<=Hi(WindMax)) THEN
  9381.      BEGIN
  9382.           ff:=@Output;
  9383.           coPos.X:=X;
  9384.           coPos.Y:=Y;
  9385.           SetConsoleCursorPosition(ff^.Handle,LONGWORD(coPos));
  9386.      END;
  9387. END;
  9388.  
  9389. {$ENDIF}
  9390.  
  9391. {$IFDEF OS2}
  9392. PROCEDURE TPMScreenInOutClass.Error;
  9393. VAR
  9394.    cs:CSTRING;
  9395.    cTitle:CSTRING;
  9396. BEGIN
  9397.      ctitle:='Wrong linker target';
  9398.      cs:='PM Linker mode does not support text screen IO.'+#13+
  9399.          'Use the unit WinCrt if you wish to use text'+#13+
  9400.          'screen IO inside PM applications.';
  9401.      InitPM;
  9402.      WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  9403.      Halt(0);
  9404. END;
  9405. {$ENDIF}
  9406. {$IFDEF WIN95}
  9407. PROCEDURE TPMScreenInOutClass.Error;
  9408. BEGIN
  9409.      MessageBox(0,'Win95 GUI linker target does not support textscreen I/O'#13+
  9410.                   'Use the Unit WINCRT if you wish to use'#13
  9411.                   'textscreen I/O within GUI applications','Error',0);
  9412.      Halt(0);
  9413. END;
  9414. {$ENDIF}
  9415.  
  9416. {$HINTS OFF}
  9417. PROCEDURE TPMScreenInOutClass.WriteStr(CONST s:STRING);
  9418. BEGIN
  9419.      Error;
  9420. END;
  9421.  
  9422. PROCEDURE TPMScreenInOutClass.WriteCStr(CONST s:CSTRING);
  9423. BEGIN
  9424.      Error;
  9425. END;
  9426.  
  9427. PROCEDURE TPMScreenInOutClass.WriteLF;
  9428. BEGIN
  9429.      Error;
  9430. END;
  9431.  
  9432. PROCEDURE TPMScreenInOutClass.ReadLF(VAR s:STRING);
  9433. BEGIN
  9434.      Error;
  9435. END;
  9436.  
  9437. PROCEDURE TPMScreenInOutClass.GotoXY(x,y:BYTE);
  9438. BEGIN
  9439.      Error;
  9440. END;
  9441. {$HINTS ON}
  9442.  
  9443. {$IFDEF OS2}
  9444. IMPORTS
  9445.       FUNCTION DosLoadModule(pszName:CSTRING;cbName:LONGWORD;pszModname:CSTRING;
  9446.                              VAR phmod:LONGWORD):LONGWORD;
  9447.                     APIENTRY;             'DOSCALLS' index 318;
  9448.       FUNCTION DosQueryProcAddr(hmod:LONGWORD;ordinal:LONGWORD;
  9449.                                 VAR pszName:CSTRING;
  9450.                                 VAR ppfn:ProcVar):LONGWORD;
  9451.                     APIENTRY;             'DOSCALLS' index 321;
  9452. END;
  9453.  
  9454. TYPE
  9455.     VIOMODEINFO=RECORD {pack 1}
  9456.                      cb:WORD;
  9457.                      fbType:BYTE;
  9458.                      color:BYTE;
  9459.                      col:WORD;
  9460.                      row:WORD;
  9461.                      hres:WORD;
  9462.                      vres:WORD;
  9463.                      fmt_ID:BYTE;
  9464.                      attrib:BYTE;
  9465.                      buf_addr:LONGWORD;
  9466.                      buf_length:LONGWORD;
  9467.                      full_length:LONGWORD;
  9468.                      partial_length:LONGWORD;
  9469.                      ext_data_addr:POINTER;
  9470.                 END;
  9471.  
  9472. PROCEDURE InitScreenInOutPM;
  9473. VAR
  9474.    c:TPMScreenInOutClass;
  9475. BEGIN
  9476.      c.Create;
  9477.      ScreenInOut:=TScreenInOutClass(c);
  9478. END;
  9479.  
  9480. Var sg:CString;
  9481.  
  9482. PROCEDURE InitScreenInOut;
  9483. VAR VioModule:LONGWORD;
  9484.     s:CSTRING;
  9485.     VioMode:VioModeInfo;
  9486.     Size,Value:WORD;
  9487. LABEL l;
  9488. BEGIN
  9489.      ScreenInOut.Create;
  9490.  
  9491.      IF DosLoadModule(s,255,'KBDVIO32',VioModule)<>0 THEN
  9492.      BEGIN
  9493. l:
  9494.           {ScreenInOut.WriteStr('RunError 217');}
  9495.           {$IFDEF OS2}
  9496.           sg:='Cannot load KBDVIO32.DLL. Program is terminated.';
  9497.           VioModule:=0;
  9498.           DosWrite(1,sg,length(sg),VioModule);
  9499.           Halt;
  9500.           {$ENDIF}
  9501.           {$IFDEF WIN32}
  9502.           RunError(217);  {could not load KBDVIO32}
  9503.           {$ENDIF}
  9504.      END;
  9505.  
  9506.      IF DosQueryProcAddr(VioModule,40,NIL,ProcVar(VioScrollDnProc))<>0 THEN goto l;
  9507.      IF DosQueryProcAddr(VioModule,41,NIL,ProcVar(VioScrollUpProc))<>0 THEN goto l;
  9508.      IF DosQueryProcAddr(VioModule,33,NIL,ProcVar(VioGetModeProc))<>0 THEN goto l;
  9509.      IF DosQueryProcAddr(VioModule,34,NIL,ProcVar(VioSetModeProc))<>0 THEN goto l;
  9510.      IF DosQueryProcAddr(VioModule,3,NIL,ProcVar(VioWhereXProc))<>0 THEN goto l;
  9511.      IF DosQueryProcAddr(VioModule,4,NIL,ProcVar(VioWhereYProc))<>0 THEN goto l;
  9512.      IF DosQueryProcAddr(VioModule,30,NIL,ProcVar(VioSetCurPosProc))<>0 THEN goto l;
  9513.      IF DosQueryProcAddr(VioModule,36,NIL,ProcVar(VioReadCellStrProc))<>0 THEN goto l;
  9514.      IF DosQueryProcAddr(VioModule,64,NIL,ProcVar(VioGetConfigProc))<>0 THEN goto l;
  9515.  
  9516.      IF DosQueryProcAddr(VioModule,9,NIL,ProcVar(KbdStringInProc))<>0 THEN goto l;
  9517.      IF DosQueryProcAddr(VioModule,1,NIL,ProcVar(ReadKeyProc))<>0 THEN goto l;
  9518.      IF DosQueryProcAddr(VioModule,2,NIL,ProcVar(KeyPressedProc))<>0 THEN goto l;
  9519.  
  9520.      VioMode.cb := SizeOf(VioModeInfo);
  9521.      VioGetModeProc(VioMode, 0);
  9522.  
  9523.      WITH VioMode DO
  9524.      BEGIN
  9525.           IF Col = 40 THEN LastMode := BW40
  9526.           ELSE LastMode := BW80;
  9527.           IF (fbType AND 4) = 0 THEN
  9528.              IF LastMode = BW40 THEN LastMode := CO40
  9529.           ELSE LastMode := CO80;
  9530.           IF Color = 0 THEN LastMode := Mono;
  9531.           IF Row > 25 THEN Inc(LastMode,Font8x8);
  9532.      END;
  9533.  
  9534.      WindMin := 0;
  9535.      WindMax := VioMode.Col - 1 + (VioMode.Row - 1) SHL 8;
  9536.      MaxWindMin :=WindMin;
  9537.      MaxWindMax :=WindMax;
  9538.  
  9539.      Size := 2;
  9540.      VioReadCellStrProc(Value, Size, VioWhereYProc-1, VioWhereXProc-1, 0);
  9541.      TextAttr := Hi(Value) AND $7F;
  9542. END;
  9543. {$ENDIF}
  9544. {$IFDEF WIN95}
  9545. PROCEDURE InitScreenInOut;
  9546. VAR
  9547.     Value:WORD;
  9548.     csbi:CONSOLE_SCREEN_BUFFER_INFO;
  9549.     ff:^FileRec;
  9550.     co:COORD;
  9551.     Actual:LONGWORD;
  9552. BEGIN
  9553.      ScreenInOut.Create;
  9554.  
  9555.      ff:=@Output;
  9556.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  9557.  
  9558.      WITH csbi DO
  9559.      BEGIN
  9560.           IF dwSize.X = 40 THEN LastMode := CO40
  9561.           ELSE LastMode := CO80;
  9562.           IF dwSize.Y > 25 THEN Inc(LastMode,Font8x8);
  9563.      END;
  9564.  
  9565.      WindMin := 0;
  9566.      WindMax := csbi.dwSize.X - 1 + (csbi.dwSize.Y - 1) SHL 8;
  9567.      MaxWindMin :=WindMin;
  9568.      MaxWindMax :=WindMax;
  9569.  
  9570.      co.X:=1;
  9571.      co.Y:=1;
  9572.  
  9573.      ReadConsoleOutputAttribute(ff^.Handle,Value,2,LONGWORD(co),Actual);
  9574.      TextAttr := Hi(Value) AND $7F;
  9575.  
  9576.      ff:=@Input;
  9577.      SetConsoleMode(ff^.Handle,ENABLE_PROCESSED_INPUT OR ENABLE_LINE_INPUT OR
  9578.        ENABLE_ECHO_INPUT OR ENABLE_WINDOW_INPUT OR ENABLE_MOUSE_INPUT OR
  9579.        ENABLE_PROCESSED_OUTPUT OR ENABLE_WRAP_AT_EOL_OUTPUT);
  9580. END;
  9581.  
  9582. PROCEDURE InitScreenInOutPM;
  9583. VAR
  9584.    c:TPMScreenInOutClass;
  9585. BEGIN
  9586.      c.Create;
  9587.      ScreenInOut:=TScreenInOutClass(c);
  9588. END;
  9589. {$ENDIF}
  9590.  
  9591. PROCEDURE LongInt2Str(l:LONGINT;Format:LONGWORD;VAR result:STRING);FORWARD;
  9592. PROCEDURE LongWord2Str(l:LONGWORD;Format:LONGWORD;VAR result:STRING);FORWARD;
  9593. PROCEDURE StrWrite(CONST s:STRING;format:LONGWORD);FORWARD;
  9594.  
  9595. PROCEDURE BooleanWrite(l:LONGBOOL;Format:LONGWORD);
  9596. BEGIN
  9597.      IF l THEN StrWrite('TRUE',Format)
  9598.      ELSE StrWrite('FALSE',Format);
  9599. END;
  9600.  
  9601. PROCEDURE CharWrite(l:char;Format:LONGWORD);
  9602. VAR s:STRING;
  9603. BEGIN
  9604.      s[0]:=#1;
  9605.      s[1]:=l;
  9606.      StrWrite(s,Format);
  9607. END;
  9608.  
  9609. PROCEDURE LongintWrite(l:LONGINT;Format:LONGWORD);
  9610. VAR s:STRING;
  9611. BEGIN
  9612.      Longint2Str(l,Format,s);
  9613.      StrWrite(s,0);
  9614. END;
  9615.  
  9616. PROCEDURE LongwordWrite(l:LONGWORD;Format:LONGWORD);
  9617. VAR s:STRING;
  9618. BEGIN
  9619.      Longword2Str(l,Format,s);
  9620.      StrWrite(s,0);
  9621. END;
  9622.  
  9623. PROCEDURE StrWrite(CONST s:STRING;format:LONGWORD);
  9624. VAR ss:STRING;
  9625.     p:^STRING;
  9626. BEGIN
  9627.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  9628.      IF format>length(s) THEN
  9629.      BEGIN
  9630.           format:=format-length(s);
  9631.           ss[0]:=chr(format+length(s));
  9632.           fillchar(ss[1],format,32);
  9633.           p:=@s;
  9634.           move(p^[1],ss[format+1],length(s));
  9635.           ScreenInOut.WriteStr(ss);
  9636.      END
  9637.      ELSE ScreenInOut.WriteStr(s);
  9638. END;
  9639.  
  9640. PROCEDURE CStrWrite(CONST s:CSTRING;format:LONGWORD);
  9641. VAR ss:CSTRING;
  9642.     p:^CSTRING;
  9643.     l:LONGWORD;
  9644. BEGIN
  9645.      l:=length(s);
  9646.      IF ((format>l)AND(l+format<255)) THEN
  9647.      BEGIN
  9648.           format:=format-l;
  9649.           fillchar(ss[0],format,32);
  9650.           p:=@s;
  9651.           move(p^[0],ss[format],l+1);
  9652.           ScreenInOut.WriteCStr(ss);
  9653.      END
  9654.      ELSE ScreenInOut.WriteCStr(s);
  9655. END;
  9656.  
  9657. PROCEDURE ArrayWrite(CONST s;format:LONGWORD;MaxLen:LONGWORD);
  9658. VAR pc:PChar;
  9659. BEGIN
  9660.      GetMem(pc,MaxLen+1);
  9661.      Move(s,pc^,MaxLen);
  9662.      pc^[MaxLen]:=#0;  //terminate PChar
  9663.      CStrWrite(pc^,Format);
  9664.      FreeMem(pc,MaxLen+1);
  9665. END;
  9666.  
  9667. PROCEDURE AnsiStrWrite(CONST s:AnsiString;Format:LONGWORD);
  9668. BEGIN
  9669.      IF PChar(s)=NIL THEN exit;  {String is empty}
  9670.      CStrWrite(PChar(s)^,format);
  9671. END;
  9672.  
  9673. PROCEDURE VariantWrite(CONST v:VARIANT;Format:LONGWORD);
  9674. VAR s:STRING;
  9675. BEGIN
  9676.      IF VarType(v) and VarTypeMask=varString THEN
  9677.      BEGIN
  9678.           ASM
  9679.              MOV EAX,v
  9680.              PUSH DWORD PTR [EAX+2]  //by value !!
  9681.              PUSH DWORD PTR Format
  9682.              CALLN32 SYSTEM.AnsiStrWrite
  9683.           END;
  9684.      END
  9685.      ELSE
  9686.      BEGIN
  9687.           s:=String(v);
  9688.           StrWrite(s,Format);
  9689.      END;
  9690. END;
  9691.  
  9692. PROCEDURE WriteLine;
  9693. BEGIN
  9694.      ScreenInOut.WriteLF;
  9695. END;
  9696.  
  9697. PROCEDURE ReadLine;
  9698. VAR
  9699.    s:STRING;
  9700. BEGIN
  9701.      ScreenInOut.ReadLF(s);
  9702. END;
  9703.  
  9704. PROCEDURE StrRead(VAR s:STRING);
  9705. BEGIN
  9706.      ScreenInOut.ReadLF(s);
  9707. END;
  9708.  
  9709. CONST
  9710.      Typ_String   = 1;
  9711.      Typ_Char     = 2;
  9712.      Typ_Number   = 3;
  9713.  
  9714. PROCEDURE GetNextStr(VAR s,Ziel:STRING;Typ:LONGWORD);
  9715. VAR t:BYTE;
  9716. LABEL l;
  9717. BEGIN
  9718.      IF s='' THEN
  9719.      BEGIN
  9720.           StrRead(s);
  9721.           s:=s+#13#10;
  9722.      END;
  9723.  
  9724.      Ziel:='';
  9725.      CASE Typ OF
  9726.         Typ_String:
  9727.         BEGIN
  9728.              {copy whole}
  9729.              IF s=#13#10 THEN Ziel:=''
  9730.              ELSE
  9731.              BEGIN
  9732.                   Ziel:=Copy(s,1,length(s)-2);
  9733.                   s:=#13#10;
  9734.              END;
  9735.         END;
  9736.         Typ_Char:
  9737.         BEGIN
  9738.              Ziel:=s[1];
  9739.              Delete(s,1,1);
  9740.         END;
  9741.         Typ_Number:
  9742.         BEGIN
  9743. l:
  9744.              IF length(s)<3 THEN  {am Zeilenende ??}
  9745.              BEGIN
  9746.                   StrRead(s);
  9747.                   s:=s+#13#10;
  9748.              END;
  9749.  
  9750.              {Skip spaces}
  9751.              IF s[1]=#32 THEN
  9752.              BEGIN
  9753.                   Delete(s,1,1);
  9754.                   goto l;
  9755.              END;
  9756.  
  9757.              FOR t:=1 TO length(s) DO
  9758.              BEGIN
  9759.                  CASE s[t] OF
  9760.                     #9,#13,#10,#32:  {Trennzeichen}
  9761.                     BEGIN
  9762.                          Ziel:=Copy(s,1,t-1);
  9763.                          Delete(s,1,t-1); {Trenner nicht mit löschen}
  9764.                          exit;
  9765.                     END;
  9766.                  END; {case}
  9767.              END;
  9768.         END;
  9769.      END; {case}
  9770. END;
  9771.  
  9772.  
  9773. //************************************************************************
  9774. // CLASS support
  9775. //************************************************************************
  9776.  
  9777. {Constructor for all classes}
  9778. CONSTRUCTOR TObject.Create;
  9779. BEGIN
  9780.      {
  9781.      p:=POINTER(SELF);
  9782.      inc(p,4);
  9783.      fillchar(p^,4,0);
  9784.      }
  9785.      {InitInstance(POINTER(SELF));} {Memory is always initialized with zero}
  9786. END;
  9787.  
  9788. {Destructor for all classes}
  9789. DESTRUCTOR TObject.Destroy;
  9790. BEGIN
  9791. END;
  9792.  
  9793. FUNCTION TObject.GetPropertyTypeInfo(PropertyName:STRING;VAR Info:TPropertyTypeInfo):BOOLEAN;
  9794. VAR l,c:^LONGWORD;
  9795.     ps:^STRING;
  9796.     s:STRING;
  9797. BEGIN
  9798.      result:=FALSE;
  9799.      UpcaseStr(PropertyName);
  9800.  
  9801.      l:=POINTER(SELF);
  9802.      l:=POINTER(l^);  //VMT address
  9803.      WHILE l<>NIL DO
  9804.      BEGIN
  9805.           inc(l,4);
  9806.           l:=POINTER(l^);  //Class info
  9807.           c:=l;
  9808.           inc(l,12);
  9809.           l:=POINTER(l^);  //Property info
  9810.           inc(l,4);
  9811.           Info.NameTable:=Pointer(l^);
  9812.           inc(l,4);        //Start of Properties
  9813.           ps:=Pointer(l);
  9814.           WHILE ps^[0]<>#0 DO
  9815.           BEGIN
  9816.                IF ps^[0]=PropertyName[0] THEN  //found !!
  9817.                BEGIN
  9818.                     s:=ps^;
  9819.                     UpcaseStr(s);
  9820.                     IF s=PropertyName THEN
  9821.                     BEGIN
  9822.                          result:=TRUE;
  9823.                          inc(l,ord(ps^[0])+1); //skip name
  9824.                          Info.Scope:=l^ AND 255;
  9825.  
  9826.                          inc(l);
  9827.                          l:=Pointer(l^);     //Type and access info
  9828.  
  9829.                          IF ((Info.Scope AND 24=0)OR(l=NIL)) THEN
  9830.                          BEGIN
  9831.                               result:=FALSE;  //not a published property
  9832.                               exit;
  9833.                          END;
  9834.  
  9835.                          Info.PropInfo:=Pointer(l);
  9836.                          Info.Read.Kind:=l^ AND 255;
  9837.                          inc(l);
  9838.                          IF Info.Read.Kind<>0 THEN
  9839.                          BEGIN
  9840.                               Info.Read.VarOffset:=l^;
  9841.                               inc(l,4);
  9842.                          END;
  9843.                          Info.Write.Kind:=l^ AND 255;
  9844.                          inc(l);
  9845.                          IF Info.Write.Kind<>0 THEN
  9846.                          BEGIN
  9847.                               Info.Write.VarOffset:=l^;
  9848.                               inc(l,4);
  9849.                          END;
  9850.                          Info.Size:=l^;
  9851.                          inc(l,4);
  9852.                          Info.TypeInfo:=Pointer(l);
  9853.                          Info.Typ:=l^ AND 255;
  9854.  
  9855.                          exit;
  9856.                     END;
  9857.                END;
  9858.  
  9859.                inc(l,ord(ps^[0])+6);    //skip this entry
  9860.                ps:=Pointer(l);
  9861.           END;
  9862.  
  9863.           inc(c,4);
  9864.           l:=Pointer(c^);  //Parent VMT or NIL
  9865.      END;
  9866. END;
  9867.  
  9868. PROCEDURE TObject.EnumProperties(EnumProc:TPropertyEnumProc);
  9869. VAR l,l1,c:^LONGWORD;
  9870.     ps:^STRING;
  9871.     Info:TPropertyTypeInfo;
  9872. BEGIN
  9873.      l:=POINTER(SELF);
  9874.      l:=POINTER(l^);  //VMT address
  9875.      WHILE l<>NIL DO
  9876.      BEGIN
  9877.           inc(l,4);
  9878.           l:=POINTER(l^);  //Class info
  9879.           c:=l;
  9880.           inc(l,12);
  9881.           l:=POINTER(l^);  //Property info
  9882.           inc(l,4);        //onto Name Table
  9883.           Info.NameTable:=Pointer(l^);
  9884.           inc(l,4);        //Start of Properties
  9885.           ps:=Pointer(l);
  9886.           WHILE ps^[0]<>#0 DO
  9887.           BEGIN
  9888.                inc(l,ord(ps^[0])+1); //skip name
  9889.                Info.Scope:=l^ AND 255;
  9890.                inc(l);
  9891.                l1:=l;
  9892.                inc(l1,4);
  9893.  
  9894.                l:=Pointer(l^);     //Type and access info
  9895.                IF l<>NIL THEN
  9896.                BEGIN
  9897.                     Info.PropInfo:=Pointer(l);
  9898.                     Info.Read.Kind:=l^ AND 255;
  9899.                     inc(l);
  9900.                     IF Info.Read.Kind<>0 THEN
  9901.                     BEGIN
  9902.                          Info.Read.VarOffset:=l^;
  9903.                          inc(l,4);
  9904.                     END;
  9905.                     Info.Write.Kind:=l^ AND 255;
  9906.                     inc(l);
  9907.                     IF Info.Write.Kind<>0 THEN
  9908.                     BEGIN
  9909.                          Info.Write.VarOffset:=l^;
  9910.                          inc(l,4);
  9911.                     END;
  9912.  
  9913.                     Info.Size:=l^;
  9914.                     inc(l,4);
  9915.                     Info.TypeInfo:=Pointer(l);
  9916.                     Info.Typ:=l^ AND 255;
  9917.                END
  9918.                ELSE
  9919.                BEGIN
  9920.                     Info.PropInfo:=NIL;
  9921.                     Info.Read.Kind:=0;
  9922.                     Info.Write.Kind:=0;
  9923.                     Info.Size:=0;
  9924.                     Info.TypeInfo:=NIL;
  9925.                     Info.Typ:=0;
  9926.                END;
  9927.                EnumProc(ps,Info);
  9928.  
  9929.                l:=l1;
  9930.                ps:=Pointer(l);
  9931.           END;
  9932.  
  9933.           inc(c,4);
  9934.           l:=Pointer(c^);  //Parent VMT or NIL
  9935.      END;
  9936. END;
  9937.  
  9938. {Frees an instance of a class}
  9939. PROCEDURE TObject.Free;
  9940. BEGIN
  9941.      IF POINTER(SELF)<>NIL THEN Self.Destroy;
  9942. END;
  9943.  
  9944. {frees an Instance of a class}
  9945. PROCEDURE TObject.FreeInstance;
  9946. BEGIN
  9947.      {FreeInstance is normally called by the Destructor to
  9948.       deallocate memory for the object. In Speed-Pascal the
  9949.       memory deallocation is done by the compiler thus
  9950.       overriding this method has no effect}
  9951. END;
  9952.  
  9953. {Gets class information from the ClassInfo structure}
  9954. CLASS FUNCTION TObject.ClassInfo: Pointer;
  9955. BEGIN
  9956.      ASM
  9957.         MOV EAX,!ClassInfo
  9958.         MOV EAX,[EAX+4]
  9959.         MOV Result,EAX
  9960.      END;
  9961. END;
  9962.  
  9963. {Returns size of an instance of a class of TObject or a class derived
  9964.  from TObject from the ClassInfo structure}
  9965. CLASS FUNCTION TObject.InstanceSize:LONGWORD;
  9966. BEGIN
  9967.      ASM
  9968.         MOV EAX,0
  9969.         MOV EDI,!ClassInfo //Get Object pointer
  9970.         CMP EDI,0
  9971.         JE !InstanceSize_NoInfo
  9972.         MOV EDI,[EDI+4]     //Get class info pointer
  9973.         CMP EDI,0
  9974.         JE !InstanceSize_NoInfo
  9975.         MOV EAX,[EDI+0]     //Get class size
  9976. !InstanceSize_NoInfo:
  9977.         MOV Result,EAX
  9978.      END;
  9979. END;
  9980.  
  9981. {Generates a new instance of a class from the ClassInfo structure
  9982.  and calls the constructor for that class}
  9983. CLASS FUNCTION TObject.NewInstance: TObject;
  9984. BEGIN
  9985.      {NewInstance is normally called by the Constructor to
  9986.       allocate memory for the object. In Speed-Pascal the
  9987.       memory allocation is done by the compiler thus
  9988.       overriding this method has no effect}
  9989.      result:=SELF;
  9990. END;
  9991.  
  9992. {Initializes an Instance from the ClassInfo structure given by Instance}
  9993. CLASS FUNCTION TObject.InitInstance(Instance: Pointer): TObject;
  9994. BEGIN
  9995.      {Fill the object with zeros. Object must be initialized with Create !}
  9996.      inc(Instance,4);
  9997.      FillChar(Instance^,InstanceSize-4,0);
  9998.      dec(Instance,4);
  9999.      InitInstance:=TObject(Instance);
  10000. END;
  10001.  
  10002. CLASS FUNCTION TObject.ClassName: STRING;
  10003. VAR ps:^STRING;
  10004. BEGIN
  10005.      ASM
  10006.         MOV EAX,0
  10007.         MOV EDI,!ClassInfo //Get Object pointer
  10008.         CMP EDI,0
  10009.         JE !ClassName_NoInfo
  10010.         MOV EDI,[EDI+4]     //Get class info pointer
  10011.         CMP EDI,0
  10012.         JE !ClassName_NoInfo
  10013.         LEA EDI,[EDI+16]    //points to class name
  10014.         MOV EAX,EDI
  10015. !ClassName_NoInfo:
  10016.         MOV ps,EAX
  10017.      END;
  10018.      IF ps<>NIL THEN ClassName:=ps^
  10019.      ELSE ClassName:='';
  10020. END;
  10021.  
  10022. CLASS FUNCTION TObject.ClassUnit:STRING;
  10023. VAR ps:^STRING;
  10024. BEGIN
  10025.      ASM
  10026.         MOV EAX,0
  10027.         MOV EDI,!ClassInfo //Get Object pointer
  10028.         CMP EDI,0
  10029.         JE !ClassUnit_NoInfo
  10030.         MOV EDI,[EDI+4]     //Get class info pointer
  10031.         CMP EDI,0
  10032.         JE !ClassUnit_NoInfo
  10033.         LEA EDI,[EDI+16]    //points to class name
  10034.         MOVZXB EAX,[EDI+0]  //overreas class name
  10035.         ADD EDI,EAX
  10036.         INC EDI
  10037.         MOV EAX,EDI
  10038. !ClassUnit_NoInfo:
  10039.         MOV ps,EAX
  10040.      END;
  10041.      IF ps<>NIL THEN ClassUnit:=ps^
  10042.      ELSE ClassUnit:='';
  10043. END;
  10044.  
  10045. {$HINTS OFF}
  10046. {Default handler for messages}
  10047. PROCEDURE TObject.DefaultHandler(VAR Message);
  10048. BEGIN
  10049.      {Do nothing here !}
  10050. END;
  10051.  
  10052. {Default frame handler for messages}
  10053. PROCEDURE TObject.DefaultFrameHandler(VAR Message);
  10054. BEGIN
  10055.      {Do nothing here !}
  10056. END;
  10057. {$HINTS ON}
  10058.  
  10059. {Dispatches dynamic methods}
  10060. PROCEDURE TObject.Dispatch(VAR Message);
  10061. BEGIN
  10062.      {Check if there's a DMT entry for the message
  10063.       The message ID MUST be the first DWORD of Message !!
  10064.       If an entry is found call the message handler}
  10065.      ASM
  10066.         MOV EDI,Message
  10067.         MOV EAX,[EDI+0]  //Get message index
  10068.         MOV EDI,SELF     //Get Object
  10069.         MOV ESI,[EDI+0]  //Get VMT pointer
  10070.         MOV EDI,[ESI+0]  //Get DMT pointer
  10071.         MOV ECX,[EDI+0]  //Get number of DMT entries
  10072.         ADD EDI,4
  10073.         PUSH ECX
  10074.         CLD
  10075.         REPNE SCASW
  10076.         JNE !EndeDispatch
  10077.  
  10078.         //Message found
  10079.         POP     EAX
  10080.         ADD     EAX,EAX
  10081.         SUB     EAX,ECX
  10082.         SUB     EDI,4
  10083.         MOV     EAX,[EDI+EAX*2]
  10084.         PUSH DWORD PTR Message    //Message Parameter
  10085.         PUSH DWORD PTR SELF       //SELF Pointer to object
  10086.         CALLN32 [ESI+EAX*4]       //call VMT method
  10087.         LEAVE
  10088.         RETN32 8
  10089. !EndeDispatch:
  10090.         POP ECX
  10091.      END; {case}
  10092.  
  10093.      {other case call the Default handler}
  10094.      DefaultHandler(Message);
  10095. END;
  10096.  
  10097. {Dispatches dynamic methods}
  10098. PROCEDURE TObject.DispatchCommand(VAR Message;Command:LONGWORD);
  10099. BEGIN
  10100.      {Check if there's a DMT entry for the WM_COMMAND message}
  10101.      ASM
  10102.         MOV EAX,Command  //Get message index
  10103.         MOV EDI,SELF     //Get Object
  10104.         MOV ESI,[EDI+0]  //Get VMT pointer
  10105.         MOV EDI,[ESI+0]  //Get DMT pointer
  10106.         MOV ECX,[EDI+0]  //Get number of DMT entries
  10107.         ADD EDI,4
  10108.         PUSH ECX
  10109.         CLD
  10110.         REPNE SCASW
  10111.         JNE !EndeDispatch_2
  10112.  
  10113.         //Message found
  10114.         POP     EAX
  10115.         ADD     EAX,EAX
  10116.         SUB     EAX,ECX
  10117.         SUB     EDI,4
  10118.         MOV     EAX,[EDI+EAX*2]
  10119.         PUSH DWORD PTR Message       //Message Parameter
  10120.         PUSH DWORD PTR SELF          //SELF Pointer to object
  10121.         CALLN32 [ESI+EAX*4]          //call VMT method
  10122.         LEAVE
  10123.         RETN32 12
  10124. !EndeDispatch_2:
  10125.         POP ECX
  10126.      END; {case}
  10127.  
  10128.      {other case call the Default handler}
  10129.      DefaultHandler(Message);
  10130. END;
  10131.  
  10132. {Dispatches dynamic methods}
  10133. PROCEDURE TObject.FrameDispatch(VAR Message);
  10134. BEGIN
  10135.      {Check if there's a DMT entry for the message
  10136.       The message ID MUST be the first DWORD of Message !!
  10137.       If an entry is found call the message handler}
  10138.       ASM
  10139.         MOV EDI,Message
  10140.         MOV EAX,[EDI+0]  //Get message index
  10141.         MOV EDI,SELF     //Get Object
  10142.         MOV ESI,[EDI+0]  //Get VMT pointer
  10143.         MOV EDI,[ESI+0]  //Get DMT pointer
  10144.         MOV ECX,[EDI+0]  //Get number of DMT entries
  10145.         ADD EDI,4
  10146.         PUSH ECX
  10147.         CLD
  10148.         REPNE SCASW
  10149.         JNE !EndeDispatch
  10150.  
  10151.         //Message found
  10152.         POP     EAX
  10153.         ADD     EAX,EAX
  10154.         SUB     EAX,ECX
  10155.         SUB     EDI,4
  10156.         MOV     EAX,[EDI+EAX*2]
  10157.         PUSH DWORD PTR Message       //Message Parameter
  10158.         PUSH DWORD PTR SELF          //SELF Pointer to object
  10159.         CALLN32 [ESI+EAX*4]          //call VMT method
  10160.         LEAVE
  10161.         RETN32 8
  10162. !EndeDispatch:
  10163.         POP ECX
  10164.      END; {case}
  10165.  
  10166.      {other case call the Default handler}
  10167.      DefaultFrameHandler(Message);
  10168. END;
  10169.  
  10170.  
  10171. ASSEMBLER
  10172.  
  10173. SYSTEM.!GetMethodName PROC NEAR32
  10174.         //INPUT : EAX adress to find
  10175.         //        EDI VMT pointer
  10176.         //OUTPUT: String adress or NIL in EAX
  10177.  
  10178.         MOV EDI,[EDI+4]     //Get class info pointer
  10179.         LEA EDI,[EDI+16]    //points to class name
  10180.         MOVZXB EBX,[EDI+0]  //get Class name length
  10181.         INC EDI
  10182.         ADD EDI,EBX
  10183.         MOVZXB EBX,[EDI+0]  //get Unit name length
  10184.         INC EDI
  10185.         ADD EDI,EBX         //points on first method adress
  10186. !MLoop:
  10187.         CMPD [EDI+0],0      //end of list ??
  10188.         JE !MELoop
  10189.  
  10190.         CMP [EDI+0],EAX     //Method found
  10191.         JNE !MWLoop
  10192.  
  10193.         //Method found
  10194.         LEA EAX,[EDI+4]     //points to Method name
  10195.         JMP !MEFLoop
  10196. !MWLoop:
  10197.         ADD EDI,4
  10198.         MOVZXB EBX,[EDI+0]  //get method name length
  10199.         INC EDI
  10200.         ADD EDI,EBX         //points to next method address
  10201.         JMP !MLoop          //try next
  10202. !MELoop:
  10203.         MOV EAX,0           //not found
  10204. !MEFLoop:
  10205.         RETN32
  10206. SYSTEM.!GetMethodName ENDP
  10207.  
  10208. END;
  10209.  
  10210. {returns the Method Name for an adress or an empty string}
  10211. CLASS FUNCTION TObject.MethodName(Address: POINTER): STRING;
  10212. VAR ps:^STRING;
  10213.     Class_Info:POINTER;
  10214. BEGIN
  10215.      ps:=NIL;  {Default}
  10216.      ASM
  10217.         MOV EDI,!ClassInfo     //get Class info pointer
  10218.         MOV Class_Info,EDI     //get address to find
  10219. !MAgain:
  10220.         MOV EDI,Class_Info
  10221.         MOV EAX,Address
  10222.         CALLN32 SYSTEM.!GetMethodName //search for method
  10223.         CMP EAX,0
  10224.         JE !Nfound
  10225.  
  10226.         //Method was found
  10227.         MOV ps,EAX
  10228.         JMP !Mfound
  10229. !Nfound:
  10230.         //Method not found, check parent
  10231.         MOV EDI,Class_Info    //Actual class
  10232.         MOV EDI,[EDI+4]       //Get class info pointer
  10233.         MOV EAX,[EDI+4]       //Get parent class adress info
  10234.         MOV Class_Info,EAX
  10235.         CMP EAX,0
  10236.         JNE !MAgain           //Try again if parents exist
  10237. !Mfound:
  10238.      END;
  10239.  
  10240.      IF ps=NIL THEN MethodName:=''
  10241.      ELSE MethodName:=ps^;
  10242. END;
  10243.  
  10244. ASSEMBLER
  10245.  
  10246. SYSTEM.!GetMethodAddress PROC NEAR32
  10247.         //INPUT : ESI pointer to string to find
  10248.         //        EDI VMT pointer
  10249.         //OUTPUT: method pointer or NIL in EAX
  10250.  
  10251.         MOV EDI,[EDI+4]     //Get class info pointer
  10252.         LEA EDI,[EDI+16]    //points to class name
  10253.         MOVZXB EBX,[EDI+0]  //get Class name length
  10254.         INC EDI
  10255.         ADD EDI,EBX
  10256.         MOVZXB EBX,[EDI+0]  //get Unit name length
  10257.         INC EDI
  10258.         ADD EDI,EBX         //points on first method adress
  10259.         MOV CL,[ESI+0]      //get method string length
  10260. !ALoop:
  10261.         MOV EDX,EDI         //save pointer
  10262.         MOV EBX,ESI         //save pointer
  10263.         CMPD [EDI+0],0      //end of list ??
  10264.         JE !AELoop
  10265.         ADD EDI,4           //onto name
  10266.  
  10267.         CMP CL,[EDI+0]      //length correct
  10268.         JNE !AWLoop
  10269.  
  10270.         //length was correct
  10271.         MOVZX ECX,CL        //String length
  10272.         INC EDI
  10273.         INC ESI
  10274.         CLD
  10275.         REP
  10276.         CMPSB               //Compare strings
  10277.         JNE !AWLoop
  10278.  
  10279.         //Method was found
  10280.         MOV EAX,[EDX+0]     //get method adress
  10281.         JMP !AEFLoop
  10282. !AWLoop:
  10283.         MOV EDI,EDX         //get old pointer
  10284.         MOV ESI,EBX         //get old pointer
  10285.         ADD EDI,4
  10286.         MOVZXB EAX,[EDI+0]  //get method name length
  10287.         INC EDI
  10288.         ADD EDI,EAX         //points to next method address
  10289.         MOV CL,[ESI+0]
  10290.         JMP !ALoop          //try next
  10291. !AELoop:
  10292.         MOV EAX,0           //not found
  10293. !AEFLoop:
  10294.         RETN32
  10295. SYSTEM.!GetMethodAddress ENDP
  10296.  
  10297. END;
  10298.  
  10299. {returns the adress of a method or NIL}
  10300. CLASS FUNCTION TObject.MethodAddress(Name: STRING): POINTER;
  10301. VAR
  10302.    Adr:POINTER;
  10303.    Class_Info:POINTER;
  10304. BEGIN
  10305.      Adr:=NIL;  {Default}
  10306.      UpcaseStr(Name);
  10307.  
  10308.      ASM
  10309.         MOV EDI,!ClassInfo     //get Class info pointer
  10310.         MOV Class_Info,EDI     //get address to find
  10311. !AAgain_1:
  10312.         MOV EDI,Class_Info
  10313.         LEA ESI,Name
  10314.         CALLN32 SYSTEM.!GetMethodAddress //search for method
  10315.         CMP EAX,0
  10316.         JE !ANfound
  10317.  
  10318.         //Method was found
  10319.         MOV Adr,EAX
  10320.         JMP !AMfound
  10321. !ANfound:
  10322.         //Method not found, check parent
  10323.         MOV EDI,Class_Info    //Actual class
  10324.         MOV EDI,[EDI+4]       //Get class info pointer
  10325.         MOV EAX,[EDI+4]       //Get parent class adress info
  10326.         MOV Class_Info,EAX
  10327.         CMP EAX,0
  10328.         JNE !AAgain_1         //Try again if parents exist
  10329. !AMfound:
  10330.      END;
  10331.  
  10332.      MethodAddress:=Adr;
  10333. END;
  10334.  
  10335. CLASS FUNCTION TObject.VMTIndex(Name: STRING): LONGINT;
  10336. VAR Adr:POINTER;
  10337.     res:LONGINT;
  10338. BEGIN
  10339.      res:=-1;
  10340.      result:=-1;
  10341.      Adr:=MethodAddress(Name);
  10342.      IF Adr=NIL THEN exit;
  10343.      ASM
  10344.         MOV EDI,!ClassInfo     //get Class info pointer
  10345.         ADD EDI,16             //First VMT metod
  10346.         MOV EAX,Adr
  10347.         MOV EBX,4
  10348. !AAgain_11:
  10349.         CMPD [EDI],0
  10350.         JE !Ende
  10351.         CMP [EDI],EAX
  10352.         JE !Found
  10353.         ADD EDI,4
  10354.         INC EBX
  10355.         JMP !AAgain_11
  10356. !Found:
  10357.         MOV res,EBX
  10358. !Ende:
  10359.      END;
  10360.      result:=res;
  10361. END;
  10362.  
  10363. ASSEMBLER
  10364.  
  10365. SYSTEM.!GetFieldOffset PROC NEAR32
  10366.                //INPUT : ESI pointer to string to find
  10367.                //        EDI VMT pointer
  10368.                //OUTPUT: field offset or 0 in EAX
  10369.  
  10370.                MOV EDI,[EDI+8]     //Field info start
  10371.                MOV AL,[ESI+0]      //get method string length
  10372.                INC ESI
  10373. !FLoop:
  10374.                MOV EDX,EDI         //save pointer
  10375.                MOV EBX,ESI         //save pointer
  10376.                CMPD [EDI+0],0      //end of list ??
  10377.                JE !FELoop
  10378.  
  10379.                CMP AL,[EDI+4]      //length correct
  10380.                JNE !FWLoop
  10381.  
  10382.                //length was correct
  10383.                MOVZX ECX,AL        //String length
  10384.                ADD EDI,5           //onto first char
  10385.                CLD
  10386.                REP
  10387.                CMPSB               //Compare strings
  10388.                JNE !FWLoop
  10389.  
  10390.                //Method was found
  10391.                MOV EAX,[EDX+0]     //get method adress
  10392.                JMP !FEFLoop
  10393. !FWLoop:
  10394.                MOV EDI,EDX         //get old pointer
  10395.                MOV ESI,EBX         //get old pointer
  10396.                ADD EDI,4
  10397.                MOVZXB EBX,[EDI+0]  //get method name length
  10398.                INC EDI
  10399.                ADD EDI,EBX         //points to next method address
  10400.                JMP !FLoop          //try next
  10401. !FELoop:
  10402.                MOV EAX,0           //not found
  10403. !FEFLoop:
  10404.                RETN32
  10405. SYSTEM.!GetFieldOffset ENDP
  10406.  
  10407. END;
  10408.  
  10409. FUNCTION TObject.FieldAddress(Name: STRING): POINTER;
  10410. VAR
  10411.    Adr:POINTER;
  10412.    Class_Info:POINTER;
  10413. BEGIN
  10414.      Adr:=NIL;  {Default}
  10415.      UpcaseStr(Name);
  10416.  
  10417.      ASM
  10418.         MOV EDI,SELF            //get object pointer
  10419.         MOV EDI,[EDI+0]         //get VMT Pointer
  10420.         MOV EDI,[EDI+4]         //get Class info pointer
  10421.         MOV Class_Info,EDI      //get address to find
  10422. !FAgain:
  10423.         MOV EDI,Class_Info
  10424.         LEA ESI,Name
  10425.         CALLN32 SYSTEM.!GetFieldOffset //search for method
  10426.         CMP EAX,0
  10427.         JE !FNfound
  10428.  
  10429.         //Method was found
  10430.         MOV EBX,SELF
  10431.         MOV Adr,EBX
  10432.         ADD Adr,EAX
  10433.         JMP !FMfound
  10434. !FNfound:
  10435.         //Method not found, check parent
  10436.         MOV EDI,Class_Info      //Actual class
  10437.         MOV EDI,[EDI+4]         //Get class info pointer
  10438.         CMP EDI,0
  10439.         JE !FMfound             //not found
  10440.         MOV EAX,[EDI+4]         //Get parent class adress info
  10441.         MOV Class_Info,EAX
  10442.         CMP EAX,0
  10443.         JNE !FAgain             //Try again if parents exist
  10444. !FMfound:
  10445.      END;
  10446.  
  10447.      FieldAddress:=Adr;
  10448. END;
  10449.  
  10450. {returns type of a class}
  10451. CLASS FUNCTION TObject.ClassType: TClass;
  10452. BEGIN
  10453.      ASM
  10454.         MOV EAX,!ClassInfo
  10455.         MOV Result,EAX
  10456.      END;
  10457. END;
  10458.  
  10459. {Returns Parent Class pointer of the Object or NIL}
  10460. CLASS FUNCTION TObject.ClassParent: TClass;
  10461. BEGIN
  10462.      ASM
  10463.         MOV EAX,0
  10464.         MOV EDI,!ClassInfo     //get Class info pointer
  10465.         CMP EDI,0
  10466.         JE !ClassParent_NoInfo
  10467.         MOV EDI,[EDI+4]        //points to Class information
  10468.         CMP EDI,0
  10469.         JE !ClassParent_NoInfo
  10470.         MOV EAX,[EDI+4]        //Get Parent Class pointer
  10471. !ClassParent_NoInfo:
  10472.         MOV Result,EAX
  10473.      END;
  10474. END;
  10475.  
  10476. {returns true if the Class is derived from AClass, otherwise FALSE}
  10477. {Softmode will only be enabled within the Sibyl IDE - it will only
  10478.  check if names match}
  10479. CONST InheritsSoftMode:BOOLEAN=FALSE;
  10480.  
  10481. CLASS FUNCTION TObject.InheritsFrom(AClass: TClass): BOOLEAN;
  10482. BEGIN
  10483.      Result:=FALSE; //Default
  10484.      IF InheritsSoftMode THEN
  10485.      BEGIN
  10486.          ASM
  10487.              MOV EDI,!ClassInfo     //get Class info pointer
  10488.              MOV EAX,AClass         //class to check
  10489.              CMP EAX,0
  10490.              JE !SmIELoop
  10491.              MOV EAX,[EAX+4]        //get Class info pointer
  10492.              LEA EBX,[EAX+16]       //Name of first class
  10493. !SmILoop:
  10494.              CMP EDI,0
  10495.              JE !SmIELoop
  10496.              PUSH EBX
  10497.              PUSH EDI
  10498.  
  10499.              MOV ESI,[EDI+4]        //get Class info pointer
  10500.              LEA EDI,[ESI+16]       //Name of second class
  10501.              MOV AL,0
  10502.              MOV CL,[EBX+0]
  10503.              CMP CL,[EDI+0]
  10504.              JNE !SmNoMatch
  10505.              INC EBX
  10506.              INC EDI
  10507.              CLD
  10508.              MOV ESI,EBX
  10509.              MOVZX ECX,CL
  10510.              CLD
  10511.              REP
  10512.              CMPSB
  10513.              SETE AL
  10514. !SmNoMatch:
  10515.              POP EDI
  10516.              POP EBX
  10517.              CMP AL,1               //is it this class ?
  10518.              JNE !SmIWLoop
  10519.  
  10520.              //The Class was found
  10521.              MOV DWORD PTR Result,1
  10522.              JMP !SmIELoop
  10523. !SmIWLoop:
  10524.              //try parent class
  10525.              MOV EDI,[EDI+4]       //points to class info
  10526.              MOV EDI,[EDI+4]       //get parent info
  10527.              CMP EDI,0
  10528.              JNE !SmILoop
  10529. !SmIELoop:
  10530.           END;
  10531.      END
  10532.      ELSE
  10533.      BEGIN
  10534.           ASM
  10535.              MOV EDI,!ClassInfo     //get Class info pointer
  10536.              MOV EAX,AClass         //class to check
  10537.              MOV DWORD PTR Result,0 //Default
  10538. !ILoop:
  10539.              CMP EDI,EAX            //is it this class ?
  10540.              JNE !IWLoop
  10541.  
  10542.              //The Class was found
  10543.              MOV DWORD PTR Result,1
  10544.              JMP !IELoop
  10545. !IWLoop:
  10546.              //try parent class
  10547.              MOV EDI,[EDI+4]       //points to class info
  10548.              MOV EDI,[EDI+4]       //get parent info
  10549.              CMP EDI,0
  10550.              JNE !ILoop
  10551. !IELoop:
  10552.           END;
  10553.      END;
  10554. END;
  10555.  
  10556. {internally: returns true if the Class1 is derived from Class2 otherwise FALSE}
  10557. FUNCTION CheckDerived(Class1,Class2: TClass): BOOLEAN;
  10558. BEGIN
  10559.      ASM
  10560.         MOV EDI,Class1         //get Class info pointer
  10561.         MOV EAX,Class2         //class to check
  10562.         MOV DWORD PTR Result,0 //Default
  10563. !ILoop11:
  10564.         CMP EDI,EAX            //is it this class ?
  10565.         JNE !IWLoop11
  10566.  
  10567.         //The Class was found
  10568.         MOV DWORD PTR Result,1
  10569.         JMP !IELoop11
  10570. !IWLoop11:
  10571.         //try parent class
  10572.         MOV EDI,[EDI+4]       //points to class info
  10573.         MOV EDI,[EDI+4]       //get parent info
  10574.         CMP EDI,0
  10575.         JNE !ILoop11
  10576. !IELoop11:
  10577.      END;
  10578. END;
  10579.  
  10580. ASSEMBLER
  10581.  
  10582. //Abstract method (causes Runtime Error 210)
  10583. SYSTEM.!Abstract PROC NEAR32
  10584.              PUSHL 210
  10585.              CALLN32 SYSTEM.RunError
  10586. SYSTEM.!Abstract ENDP
  10587.  
  10588. END;
  10589.  
  10590. //************************************************************************
  10591. // LongJmp support
  10592. //************************************************************************
  10593.  
  10594.  
  10595. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  10596. BEGIN
  10597.      ASM
  10598.         MOV EDI,JmpBuf
  10599.         MOV EAX,[EBP+0]
  10600.         MOV [EDI+0],EAX
  10601.         MOV EAX,[EBP+4]
  10602.         MOV [EDI+4],EAX
  10603.         MOV EAX,EBP
  10604.         ADD EAX,12
  10605.         MOV [EDI+8],EAX
  10606.         MOV ESI,0
  10607.         db $64   //SEG FS
  10608.         MOV EAX,[ESI+0]
  10609.         MOV [EDI+$18],EAX
  10610.         FSTCW [EDI+$1C]
  10611.         XOR EAX,EAX
  10612.         MOV Result,EAX
  10613.      END;
  10614. END;
  10615.  
  10616. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  10617. BEGIN
  10618.      ASM
  10619.         {$IFDEF OS2}
  10620.         MOV EDI,JmpBuf
  10621.         PUSHL 0
  10622.         MOV EAX,*ljmpret
  10623.         PUSH EAX
  10624.         PUSH DWORD PTR [EDI+$18]
  10625.         MOV AL,3
  10626.         CALLDLL DosCalls,357  //DosUnwindException
  10627.         {$ENDIF}
  10628. ljmpret:
  10629.         MOV EDI,JmpBuf
  10630.         db $db,$e3              //FINIT Init FPU
  10631.         FWAIT
  10632.         FLDCW [EDI+$1C]
  10633.         MOV EAX,RetVal
  10634.         AND EAX,EAX
  10635.         JNZ !rtv0
  10636.         MOV EAX,1
  10637. !rtv0:
  10638.         PUSH DWORD PTR [EDI+0]
  10639.         POP EBP
  10640.         MOV ESP,[EDI+8]
  10641.         ADD EDI,4
  10642.         db $0ff,$27       //JMP NEAR32 [EDI+0] --> jump into proc
  10643.      END;
  10644. END;
  10645.  
  10646. //***************************************************
  10647. // String Support routines
  10648. //***************************************************
  10649.  
  10650. PROCEDURE UpcaseStr(VAR s:STRING);
  10651. BEGIN
  10652.      ASM
  10653.         MOV EDI,s
  10654.         XOR ECX,ECX
  10655.         MOV CL,[EDI+0]
  10656.         OR CL,CL
  10657.         JE !usend
  10658.         INC EDI
  10659.         MOV EBX,*ustab
  10660.         CLD
  10661. !usfilter:
  10662.         MOV AL,[EDI+0]
  10663.         XLAT
  10664.         STOSB
  10665.         DEC ECX
  10666.         JNZ !usfilter
  10667. !usend:
  10668.         LEAVE
  10669.         RETN32 4
  10670. ustab:
  10671.        db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20
  10672.        db 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38
  10673.        db 39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57
  10674.        db 58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76
  10675.        db 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96
  10676.        db 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83
  10677.        db 84,85,86,87,88,89,90
  10678.        db 123,124,125,126,127,128,129,130,131,132,133,134,135,136,137
  10679.        db 138,139,140,141,142,143,144,145,146,147,148,149,150,151,152
  10680.        db 153,154,155,156,157,158,159,160,161,162,163,164,165,166,167
  10681.        db 168,169,170,171,172,173,174,175,176,177,178,179,180,181,182
  10682.        db 183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198
  10683.        db 199,200,201,202,203,204,205,206,207,208,209,210,211,212,213
  10684.        db 214,215,216,217,218,219,220,221,222,223,224,225,226,227,228
  10685.        db 229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244
  10686.        db 245,246,247,248,249,250,251,252,253,254,255
  10687.      END;
  10688. END;
  10689.  
  10690. PROCEDURE LongWord2Str(l:LONGWORD;Format:LONGWORD;VAR result:STRING);
  10691. BEGIN
  10692.      ASM
  10693.         PUSH EAX
  10694.         PUSH EBX
  10695.         PUSH ECX
  10696.         PUSH EDX
  10697.         PUSH EDI
  10698.         PUSH ESI
  10699.  
  10700.         MOV EAX,l
  10701.         MOV EBX,10
  10702.         XOR ECX,ECX
  10703. Lw46_1nn:
  10704.         XOR EDX,EDX
  10705.         DIV EBX
  10706.         PUSH DX
  10707.         INC CX
  10708.         OR EAX,EAX
  10709.         JNE Lw46_1nn
  10710.  
  10711.         MOV ESI,Result
  10712.         MOVB [ESI+0],0
  10713.         MOV EDI,ESI
  10714.  
  10715.         CMP ECX,Format
  10716.         JAE Lw47nn
  10717.  
  10718.         //format the string
  10719.         MOV EAX,Format
  10720.         SUB EAX,ECX
  10721.         MOV [ESI+0],AL
  10722.         INC EDI
  10723.         PUSH ECX
  10724.  
  10725.         MOV ECX,EAX
  10726.         MOV AL,32
  10727.         CLD
  10728.         REP STOSB       //fill up with space
  10729.  
  10730.         DEC EDI
  10731.         POP ECX
  10732. Lw47nn:
  10733.         POP AX
  10734.         ADD AL,48
  10735.         INCB [ESI+0]
  10736.         INC EDI
  10737.         MOV [EDI+0],AL
  10738.         LOOP Lw47nn
  10739.      END;
  10740.  
  10741.      ASM
  10742.         POP ESI
  10743.         POP EDI
  10744.         POP EDX
  10745.         POP ECX
  10746.         POP EBX
  10747.         POP EAX
  10748.      END;
  10749. END;
  10750.  
  10751. PROCEDURE LongWord2AnsiStr(l:LONGWORD;Format:LONGWORD;VAR result:AnsiString);
  10752. VAR s:STRING;
  10753. BEGIN
  10754.      ASM
  10755.         PUSH EAX
  10756.         PUSH EBX
  10757.         PUSH ECX
  10758.         PUSH EDX
  10759.         PUSH EDI
  10760.         PUSH ESI
  10761.      END;
  10762.      LongWord2Str(l,Format,s);
  10763.      result:=s;
  10764.      ASM
  10765.         POP ESI
  10766.         POP EDI
  10767.         POP EDX
  10768.         POP ECX
  10769.         POP EBX
  10770.         POP EAX
  10771.      END;
  10772. END;
  10773.  
  10774. FUNCTION GetBoolValue(b:BOOLEAN):STRING;
  10775. BEGIN
  10776.      ASM
  10777.         PUSH EAX
  10778.         PUSH EBX
  10779.         PUSH ECX
  10780.         PUSH EDX
  10781.         PUSH EDI
  10782.         PUSH ESI
  10783.      END;
  10784.      IF b THEN GetBoolValue:='TRUE'
  10785.      ELSE GetBoolValue:='FALSE';
  10786.      ASM
  10787.         POP ESI
  10788.         POP EDI
  10789.         POP EDX
  10790.         POP ECX
  10791.         POP EBX
  10792.         POP EAX
  10793.      END;
  10794. END;
  10795.  
  10796. PROCEDURE LongInt2Str(l:LONGINT;Format:LONGWORD;VAR result:STRING);
  10797. VAR
  10798.    IsNeg:BOOLEAN;
  10799. BEGIN
  10800.      ASM
  10801.         PUSH EAX
  10802.         PUSH EBX
  10803.         PUSH ECX
  10804.         PUSH EDX
  10805.         PUSH EDI
  10806.         PUSH ESI
  10807.  
  10808.         MOV BYTE PTR IsNeg,0
  10809.         MOV EAX,l
  10810.         MOV EBX,10
  10811.         XOR ECX,ECX
  10812.         CMP EAX,0
  10813.         JNL Lw46_1
  10814.         NEG EAX
  10815.         MOV BYTE PTR IsNeg,1
  10816. Lw46_1:
  10817.         XOR EDX,EDX
  10818.         DIV EBX
  10819.         PUSH DX
  10820.         INC CX
  10821.         OR EAX,EAX
  10822.         JNE Lw46_1
  10823.  
  10824.         MOV ESI,Result
  10825.         MOVB [ESI+0],0
  10826.         MOV EDI,ESI
  10827.  
  10828.         MOV EBX,ECX
  10829.  
  10830.         CMP BYTE PTR IsNeg,1
  10831.         JNE !nin1
  10832.         INC EBX
  10833. !nin1:
  10834.         CMP EBX,Format
  10835.         JAE Lw47_1n
  10836.  
  10837.         //format the string
  10838.         MOV EAX,Format
  10839.         SUB EAX,EBX
  10840.         MOV [ESI+0],AL
  10841.         INC EDI
  10842.         PUSH ECX
  10843.  
  10844.         MOV ECX,EAX
  10845.         MOV AL,32
  10846.         CLD
  10847.         REP STOSB        //fill up with space
  10848.  
  10849.         DEC EDI
  10850.         POP ECX
  10851. Lw47_1n:
  10852.         CMP BYTE PTR IsNeg,1
  10853.         JNE Lw47
  10854.         INC EDI
  10855.         INCB [ESI+0]
  10856.         MOVB [EDI+0],45  //'-'
  10857. Lw47:
  10858.         POP AX
  10859.         ADD AL,48
  10860.         INCB [ESI+0]
  10861.         INC EDI
  10862.         MOV [EDI+0],AL
  10863.         LOOP Lw47
  10864.      END;
  10865.  
  10866.      ASM
  10867.         POP ESI
  10868.         POP EDI
  10869.         POP EDX
  10870.         POP ECX
  10871.         POP EBX
  10872.         POP EAX
  10873.      END;
  10874. END;
  10875.  
  10876. PROCEDURE LongInt2AnsiStr(l:LONGINT;Format:LONGWORD;VAR result:AnsiSTRING);
  10877. VAR s:STRING;
  10878. BEGIN
  10879.      ASM
  10880.         PUSH EAX
  10881.         PUSH EBX
  10882.         PUSH ECX
  10883.         PUSH EDX
  10884.         PUSH EDI
  10885.         PUSH ESI
  10886.      END;
  10887.      LongInt2Str(l,Format,s);
  10888.      result:=s;
  10889.      ASM
  10890.         POP ESI
  10891.         POP EDI
  10892.         POP EDX
  10893.         POP ECX
  10894.         POP EBX
  10895.         POP EAX
  10896.      END;
  10897. END;
  10898.  
  10899. FUNCTION Pos(CONST item,source:STRING):BYTE;
  10900. VAR
  10901.    result:BYTE;
  10902. BEGIN
  10903.      ASM
  10904.          MOV ESI,item          //item
  10905.          CLD
  10906.          LODSB
  10907.          OR AL,AL
  10908.          JE lab2
  10909.          MOVZX EAX,AL
  10910.          MOV EDX,EAX
  10911.          MOV EDI,source        //source
  10912.          MOVZXB ECX,[EDI+0]
  10913.          SUB ECX,EDX
  10914.          JB lab2
  10915.          INC ECX
  10916.          INC EDI
  10917. lab1:
  10918.          LODSB
  10919.          REPNE
  10920.          SCASB
  10921.          JNE lab2
  10922.          MOV EAX,EDI
  10923.          MOV EBX,ECX
  10924.          MOV ECX,EDX
  10925.          DEC ECX
  10926.          REPE
  10927.          CMPSB
  10928.          JE lab3
  10929.          MOV EDI,EAX
  10930.          MOV ECX,EBX
  10931.          MOV ESI,item     //item
  10932.          INC ESI
  10933.          JMP lab1
  10934. Lab2:
  10935.          XOR EAX,EAX
  10936.          JMP Lab4
  10937. lab3:
  10938.          DEC EAX
  10939.          SUB EAX,source   //source
  10940. Lab4:
  10941.          MOV result,AL
  10942.      END;
  10943.      POS:=result;
  10944. END;
  10945.  
  10946. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  10947. BEGIN
  10948.      ASM
  10949.         MOV ESI,source              //Source string
  10950.         MOV EDI,Result              //Destination string
  10951.         MOVW [EDI+0],0              //Empty String
  10952.  
  10953.         MOVSXW ECX,Count            //Count
  10954.         CMP ECX,1
  10955.         JL !_CopyE
  10956.  
  10957.         MOVSXW EAX,Index            //Index
  10958.         CMP EAX,1
  10959.         JNL !_Copy1
  10960.         MOV EAX,1                    //Index:=1
  10961. !_Copy1:
  10962.         MOVZXB EBX,[ESI+0]           //Length of Source
  10963.         CMP EAX,EBX
  10964.         JA !_CopyE
  10965.  
  10966.         MOV EDX,EAX
  10967.         ADD EDX,ECX                  //Index+Count
  10968.         CMP EDX,EBX
  10969.         JNA !_Copy2
  10970.         MOV ECX,EBX
  10971.         SUB ECX,EAX
  10972.         INC ECX                      //Count := Length(S)-Index+1
  10973. !_Copy2:
  10974.         MOV [EDI+0],CL
  10975.         INC EDI
  10976.  
  10977.         ADD ESI,EAX                  //first char
  10978.         CLD
  10979.         MOV EDX,ECX
  10980.         SHR ECX,2
  10981.         REP
  10982.         MOVSD
  10983.         MOV ECX,EDX
  10984.         AND ECX,3
  10985.         REP
  10986.         MOVSB
  10987. !_CopyE:
  10988.      END;
  10989. END;
  10990.  
  10991. FUNCTION ToHex(l:LONGWORD):STRING;
  10992. VAR
  10993.     HexNum:STRING;
  10994.     result:STRING;
  10995.     r:LONGWORD;
  10996. BEGIN
  10997.      HexNum:='0123456789ABCDEF';
  10998.      result:='';
  10999.      WHILE l>=16 DO
  11000.      BEGIN
  11001.           r:=l MOD 16;
  11002.           l:=l DIV 16;
  11003.           result:=HexNum[r+1]+result;
  11004.      END;
  11005.      result:=HexNum[l+1]+result;
  11006.      WHILE length(result)<8 DO result:='0'+result;
  11007.      ToHex:='$'+Result;
  11008. END;
  11009.  
  11010. PROCEDURE SUBSTR(VAR source:STRING;start,ende:Byte);
  11011. BEGIN
  11012.       ASM
  11013.         CLD
  11014.         MOV ESI,source               //Source string
  11015.         MOV EDI,ESI                  //Destination string
  11016.  
  11017.         MOVZXB AX,[ESI+0]            //Length of source
  11018.         MOVZXB ECX,Start             //Index
  11019.         OR ECX,ECX
  11020.         JG !_Lab1_1
  11021.         MOV ECX,1
  11022. !_Lab1_1:
  11023.         ADD ESI,ECX
  11024.         SUB AX,CX
  11025.         JB !_Lab3_1
  11026.         INC AX
  11027.         MOVZXB CX,Ende              //Count
  11028.         OR CX,CX
  11029.         JGE !_Lab2_1
  11030.         XOR CX,CX
  11031. !_Lab2_1:
  11032.         CMP AX,CX
  11033.         JBE !_Lab4_1
  11034.         MOV AX,CX
  11035.         JMP !_Lab4_1
  11036. !_Lab3_1:
  11037.         XOR AX,AX
  11038. !_Lab4_1:
  11039.         CLD
  11040.         STOSB
  11041.         MOVZX ECX,AX
  11042.  
  11043.         MOV EDX,ECX
  11044.         SHR ECX,2
  11045.         REP
  11046.         MOVSD
  11047.         MOV ECX,EDX
  11048.         AND ECX,3
  11049.         REP
  11050.         MOVSB
  11051.      END;
  11052. END;
  11053.  
  11054. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  11055. BEGIN
  11056.      IF Length(Source) = 0 THEN exit;
  11057.      IF Length(S) = 0 THEN
  11058.      BEGIN
  11059.           S := Source;
  11060.           exit;
  11061.      END;
  11062.      IF Index < 1 THEN Index := 1;
  11063.      IF Index > Length(S) THEN Index := Length(S)+1;
  11064.      S := copy(S,1,Index-1) + Source + copy(S,Index,Length(S)-Index+1);
  11065. END;
  11066.  
  11067. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  11068. BEGIN
  11069.      IF Index < 1 THEN exit;
  11070.      IF Index > Length(S) THEN exit;
  11071.      IF Count < 1 THEN exit;
  11072.      IF Index+Count > Length(S) THEN Count := Length(S)-Index+1;
  11073.      S := copy(S,1,Index-1) + copy(S,Index+Count,Length(S)-Index-Count+1);
  11074. END;
  11075.  
  11076. FUNCTION ConvertStr2Long(VAR s:STRING):LONGINT;
  11077. VAR
  11078.    c:Integer;
  11079.    result:LONGINT;
  11080. BEGIN
  11081.      VAL(s,result,c);
  11082.      IF c<>0 THEN
  11083.      BEGIN
  11084.      END;
  11085.      ConvertStr2Long:=result;
  11086. END;
  11087.  
  11088. {Liefert Extended in ST(0) !!}
  11089. PROCEDURE ConvertStr2Extended(VAR s:STRING);
  11090. VAR
  11091.    c:Integer;
  11092.    result:Extended;
  11093. BEGIN
  11094.      VAL(s,result,c);
  11095.      IF c<>0 THEN
  11096.      BEGIN
  11097.      END;
  11098.      ASM
  11099.         FLDT result
  11100.      END;
  11101. END;
  11102.  
  11103.  
  11104. FUNCTION GetStrErrorPos(VAR s:STRING):LONGINT;
  11105. VAR t,t1:BYTE;
  11106. BEGIN
  11107.      result:=1;
  11108.      t:=1;
  11109.      IF t<=length(s) THEN IF s[t] IN ['+','-'] THEN inc(t);
  11110.      IF t<=length(s) THEN IF s[t]='$' THEN inc(t);
  11111.      FOR t1:=t TO length(s) DO
  11112.      BEGIN
  11113.           CASE s[t1] OF
  11114.             '0'..'9':;
  11115.             ELSE
  11116.             BEGIN
  11117.                  result:=t1;
  11118.                  exit;
  11119.             END;
  11120.           END;
  11121.      END;
  11122. END;
  11123.  
  11124. ASSEMBLER
  11125.  
  11126. SYSTEM.!Str2Long PROC NEAR32
  11127.         PUSH EBP
  11128.         MOV EBP,ESP
  11129.         SUB ESP,10
  11130.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  11131.  
  11132.         PUSH EAX
  11133.         PUSH EBX
  11134.         PUSH ECX
  11135.         PUSH EDX
  11136.         PUSH EDI
  11137.         PUSH ESI
  11138.  
  11139.         MOV EDI,[EBP+16]   //s
  11140.         MOV CL,[EDI+0]     //Länge
  11141.         MOVZX ECX,CL
  11142.  
  11143. !ndo_11:
  11144.         MOV AL,[EDI+1]
  11145.         CMP AL,32
  11146.         JNE !do_11
  11147.         CMP ECX,0
  11148.         JE !do_11
  11149.         DEC ECX
  11150.         INC EDI
  11151.         JMP !ndo_11       //skip spaces
  11152. !do_11:
  11153.         PUSH EDI
  11154.         ADD EDI,ECX
  11155.         CMPB [EDI+0],32
  11156.         JNE !do_11_1
  11157.         DEC ECX
  11158.         POP EDI
  11159.         JMP !do_11
  11160. !do_11_1:
  11161.         POP EDI
  11162.  
  11163.         MOVB [EBP-6],0
  11164.  
  11165.         MOVD [EBP-10],10   //Base
  11166.         MOV AL,[EDI+1]
  11167.         ADD EDI,ECX
  11168.         CMP AL,'$'         //Hexadecimal ??
  11169.         JNE !nohex
  11170.         MOVD [EBP-10],16   //Base
  11171.         CMP ECX,1
  11172.         JE !qerr
  11173.         DEC ECX
  11174. !nohex:
  11175.         CMP AL,'-'
  11176.         JNE !q2
  11177.         CMP ECX,1
  11178.         JE !qerr
  11179.         DEC ECX
  11180.         MOVB [EBP-6],1
  11181. !q2:
  11182.         CMP AL,'+'
  11183.         JNE !q1r1
  11184.         CMP ECX,1
  11185.         JE !qerr
  11186.         DEC ECX
  11187. !q1r1:
  11188.         MOV EBX,1
  11189.         MOV EAX,0
  11190.         MOV [EBP-4],EAX
  11191. !q1:
  11192.         MOV AL,[EDI+0]
  11193.         DEC EDI
  11194.         CMP AL,48
  11195.         JB !qerr
  11196.         CMP AL,57
  11197.         JNA !noqerr
  11198.  
  11199.         CMP AL,102
  11200.         JA !qerr
  11201.         CMP AL,65
  11202.         JB !qerr
  11203.         CMP AL,70
  11204.         JBE !hexnum
  11205.         CMP AL,97
  11206.         JB !qerr
  11207.         SUB AL,32       //To upper
  11208. !hexnum:
  11209.         CMPD [EBP-10],16
  11210.         JNE !qerr
  11211.         SUB AL,7
  11212. !noqerr:
  11213.         SUB AL,48
  11214.         MOVZX EAX,AL
  11215.         MUL EBX
  11216.         MOV EDX,[EBP-4]
  11217.         ADD EDX,EAX
  11218.         MOV [EBP-4],EDX
  11219.         MOV EAX,EBX
  11220.         MOV EBX,[EBP-10]  //Base
  11221.         MUL EBX
  11222.         MOV EBX,EAX
  11223.         LOOP !q1
  11224. !qerr:
  11225.         MOV EDI,[EBP+8]   //result
  11226.         XOR CH,CH
  11227.         MOV [EDI+0],CX
  11228.  
  11229.         // failure ??
  11230.         CMP CX,0
  11231.         JE !qqqq                 //no error
  11232.         PUSH DWORD PTR [EBP+16]  //s
  11233.         CALLN32 SYSTEM.GetStrErrorPos
  11234.         MOV EDI,[EBP+8]
  11235.         MOV [EDI+0],EAX
  11236.         MOV EAX,0
  11237.         JMP !q3
  11238. !qqqq:
  11239.         MOV EAX,[EBP-4]
  11240.         CMPB [EBP-6],1
  11241.         JNE !q3
  11242.         NEG EAX
  11243. !q3:
  11244.         MOV EDI,[EBP+12]  //l
  11245.         MOV [EDI+0],EAX
  11246.  
  11247.         POP ESI
  11248.         POP EDI
  11249.         POP EDX
  11250.         POP ECX
  11251.         POP EBX
  11252.         POP EAX
  11253.  
  11254.         LEAVE
  11255.         RETN32 12
  11256. SYSTEM.!Str2Long ENDP
  11257.  
  11258. SYSTEM.!Str2Word PROC NEAR32
  11259.         PUSH EBP
  11260.         MOV EBP,ESP
  11261.         SUB ESP,10
  11262.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  11263.  
  11264.         PUSH EAX
  11265.         PUSH EBX
  11266.         PUSH ECX
  11267.         PUSH EDX
  11268.         PUSH EDI
  11269.         PUSH ESI
  11270.  
  11271.         MOV EDI,[EBP+16]   //s
  11272.         MOV CL,[EDI+0]     //Länge
  11273.         MOVZX ECX,CL
  11274.  
  11275. !ndo_22:
  11276.         MOV AL,[EDI+1]
  11277.         CMP AL,32
  11278.         JNE !do_22
  11279.         CMP ECX,0
  11280.         JE !do_22
  11281.         DEC ECX
  11282.         INC EDI
  11283.         JMP !ndo_22
  11284. !do_22:
  11285.         PUSH EDI
  11286.         ADD EDI,ECX
  11287.         CMPB [EDI+0],32
  11288.         JNE !do_22_1
  11289.         DEC ECX
  11290.         POP EDI
  11291.         JMP !do_22
  11292. !do_22_1:
  11293.         POP EDI
  11294.  
  11295.         MOVB [EBP-6],0
  11296.  
  11297.         MOVD [EBP-10],10   //Base
  11298.         MOV AL,[EDI+1]
  11299.         ADD EDI,ECX
  11300.         CMP AL,'$'         //Hexadecimal ??
  11301.         JNE !__nohex
  11302.         MOVD [EBP-10],16   //Base
  11303.         CMP ECX,1
  11304.         JE !__qerr
  11305.         DEC ECX
  11306. !__nohex:
  11307.         CMP AL,'-'
  11308.         JNE !__q2
  11309.         CMP ECX,1
  11310.         JE !__qerr
  11311.         DEC ECX
  11312.         MOVB [EBP-6],1
  11313. !__q2:
  11314.         CMP AL,'+'
  11315.         JNE !__q2r1
  11316.         CMP ECX,1
  11317.         JE !__qerr
  11318.         DEC ECX
  11319. !__q2r1:
  11320.         MOV EBX,1
  11321.         MOV EAX,0
  11322.         MOV [EBP-4],EAX
  11323. !__q1:
  11324.         MOV AL,[EDI+0]
  11325.         DEC EDI
  11326.         CMP AL,48
  11327.         JB !__qerr
  11328.         CMP AL,57
  11329.         JNA !__noqerr
  11330.  
  11331.         CMP AL,102
  11332.         JA !__qerr
  11333.         CMP AL,65
  11334.         JB !__qerr
  11335.         CMP AL,70
  11336.         JBE !__hexnum
  11337.         CMP AL,97
  11338.         JB !__qerr
  11339.         SUB AL,32         //To upper
  11340. !__hexnum:
  11341.         CMPD [EBP-10],16
  11342.         JNE !__qerr
  11343.         SUB AL,7
  11344. !__noqerr:
  11345.         SUB AL,48
  11346.         MOVZX EAX,AL
  11347.         MUL EBX
  11348.         MOV EDX,[EBP-4]
  11349.         ADD EDX,EAX
  11350.         MOV [EBP-4],EDX
  11351.         MOV EAX,EBX
  11352.         MOV EBX,[EBP-10]    //Base
  11353.         MUL EBX
  11354.         MOV EBX,EAX
  11355.         LOOP !__q1
  11356. !__qerr:
  11357.         MOV EDI,[EBP+8]     //result
  11358.         XOR CH,CH
  11359.         MOV [EDI+0],CX
  11360.  
  11361.         // failure ??
  11362.         CMP CX,0
  11363.         JE !qqqq1                //no error
  11364.         PUSH DWORD PTR [EBP+16]  //s
  11365.         CALLN32 SYSTEM.GetStrErrorPos
  11366.         MOV EDI,[EBP+8]
  11367.         MOV [EDI+0],EAX
  11368.         MOV EAX,0
  11369.         JMP !__q3
  11370. !qqqq1:
  11371.         MOV EAX,[EBP-4]
  11372.         CMPB [EBP-6],1
  11373.         JNE !__q3
  11374.         NEG EAX
  11375. !__q3:
  11376.         MOV EDI,[EBP+12]    //l
  11377.         MOV [EDI+0],AX
  11378.  
  11379.         POP ESI
  11380.         POP EDI
  11381.         POP EDX
  11382.         POP ECX
  11383.         POP EBX
  11384.         POP EAX
  11385.  
  11386.         LEAVE
  11387.         RETN32 12
  11388. SYSTEM.!Str2Word ENDP
  11389.  
  11390. SYSTEM.!Str2Byte PROC NEAR32
  11391.         PUSH EBP
  11392.         MOV EBP,ESP
  11393.         SUB ESP,10
  11394.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  11395.  
  11396.         PUSH EAX
  11397.         PUSH EBX
  11398.         PUSH ECX
  11399.         PUSH EDX
  11400.         PUSH EDI
  11401.         PUSH ESI
  11402.  
  11403.         MOV EDI,[EBP+16]   //s
  11404.         MOV CL,[EDI+0]     //Länge
  11405.         MOVZX ECX,CL
  11406.  
  11407. !ndo_33:
  11408.         MOV AL,[EDI+1]
  11409.         CMP AL,32
  11410.         JNE !do_33
  11411.         CMP ECX,0
  11412.         JE !do_33
  11413.         DEC ECX
  11414.         INC EDI
  11415.         JMP !ndo_33
  11416. !do_33:
  11417.         PUSH EDI
  11418.         ADD EDI,ECX
  11419.         CMPB [EDI+0],32
  11420.         JNE !do_33_1
  11421.         DEC ECX
  11422.         POP EDI
  11423.         JMP !do_33
  11424. !do_33_1:
  11425.         POP EDI
  11426.  
  11427.         MOVB [EBP-6],0
  11428.  
  11429.         MOVD [EBP-10],10   //Base
  11430.         MOV AL,[EDI+1]
  11431.         ADD EDI,ECX
  11432.         CMP AL,'$'         //Hexadecimal ??
  11433.         JNE !___nohex
  11434.         CMP ECX,1
  11435.         JE !___qerr
  11436.         MOVD [EBP-10],16   //Base
  11437.         DEC ECX
  11438. !___nohex:
  11439.         CMP AL,'-'
  11440.         JNE !___q2
  11441.         CMP ECX,1
  11442.         JE !___qerr
  11443.         DEC ECX
  11444.         MOVB [EBP-6],1
  11445. !___q2:
  11446.         CMP AL,'+'
  11447.         JNE !___q2r1
  11448.         CMP ECX,1
  11449.         JE !___qerr
  11450.         DEC ECX
  11451. !___q2r1:
  11452.         MOV EBX,1
  11453.         MOV EAX,0
  11454.         MOV [EBP-4],EAX
  11455. !___q1:
  11456.         MOV AL,[EDI+0]
  11457.         DEC EDI
  11458.         CMP AL,48
  11459.         JB !___qerr
  11460.         CMP AL,57
  11461.         JNA !___noqerr
  11462.  
  11463.         CMP AL,102
  11464.         JA !___qerr
  11465.         CMP AL,65
  11466.         JB !___qerr
  11467.         CMP AL,70
  11468.         JBE !___hexnum
  11469.         CMP AL,97
  11470.         JB !___qerr
  11471.         SUB AL,32       //To upper
  11472. !___hexnum:
  11473.         CMPD [EBP-10],16
  11474.         JNE !___qerr
  11475.         SUB AL,7
  11476. !___noqerr:
  11477.         SUB AL,48
  11478.         MOVZX EAX,AL
  11479.         MUL EBX
  11480.         MOV EDX,[EBP-4]
  11481.         ADD EDX,EAX
  11482.         MOV [EBP-4],EDX
  11483.         MOV EAX,EBX
  11484.         MOV EBX,[EBP-10]    //Base
  11485.         MUL EBX
  11486.         MOV EBX,EAX
  11487.         LOOP !___q1
  11488. !___qerr:
  11489.         MOV EDI,[EBP+8]     //result
  11490.         XOR CH,CH
  11491.         MOV [EDI+0],CX
  11492.  
  11493.         // failure ??
  11494.         CMP CX,0
  11495.         JE !qqqq2                //no error
  11496.         PUSH DWORD PTR [EBP+16]  //s
  11497.         CALLN32 SYSTEM.GetStrErrorPos
  11498.         MOV EDI,[EBP+8]
  11499.         MOV [EDI+0],EAX
  11500.         MOV EAX,0
  11501.         JMP !___q3
  11502. !qqqq2:
  11503.         MOV EAX,[EBP-4]
  11504.         CMPB [EBP-6],1
  11505.         JNE !___q3
  11506.         NEG EAX
  11507. !___q3:
  11508.         MOV EDI,[EBP+12]    //l
  11509.         MOV [EDI+0],AL
  11510.  
  11511.         POP ESI
  11512.         POP EDI
  11513.         POP EDX
  11514.         POP ECX
  11515.         POP EBX
  11516.         POP EAX
  11517.  
  11518.         LEAVE
  11519.         RETN32 12
  11520. SYSTEM.!Str2Byte ENDP
  11521.  
  11522. END;
  11523.  
  11524. PROCEDURE AnsiStr2Byte(VAR s:AnsiString;VAR b:BYTE;VAR c:INTEGER);
  11525. VAR s1:STRING;
  11526. BEGIN
  11527.      ASM
  11528.         PUSH EAX
  11529.         PUSH EBX
  11530.         PUSH ECX
  11531.         PUSH EDX
  11532.         PUSH ESI
  11533.         PUSH EDI
  11534.      END;
  11535.  
  11536.      s1:=s;
  11537.      ASM
  11538.         LEA EAX,s1
  11539.         PUSH EAX
  11540.         PUSH DWORD PTR b
  11541.         PUSH DWORD PTR c
  11542.         CALLN32 SYSTEM.!Str2Byte
  11543.      END;
  11544.  
  11545.      ASM
  11546.         POP EDI
  11547.         POP ESI
  11548.         POP EDX
  11549.         POP ECX
  11550.         POP EBX
  11551.         POP EAX
  11552.      END;
  11553. END;
  11554.  
  11555. PROCEDURE AnsiStr2Word(VAR s:AnsiString;VAR b:WORD;VAR c:INTEGER);
  11556. VAR s1:STRING;
  11557. BEGIN
  11558.      ASM
  11559.         PUSH EAX
  11560.         PUSH EBX
  11561.         PUSH ECX
  11562.         PUSH EDX
  11563.         PUSH ESI
  11564.         PUSH EDI
  11565.      END;
  11566.  
  11567.      s1:=s;
  11568.      ASM
  11569.         LEA EAX,s1
  11570.         PUSH EAX
  11571.         PUSH DWORD PTR b
  11572.         PUSH DWORD PTR c
  11573.         CALLN32 SYSTEM.!Str2Word
  11574.      END;
  11575.  
  11576.      ASM
  11577.         POP EDI
  11578.         POP ESI
  11579.         POP EDX
  11580.         POP ECX
  11581.         POP EBX
  11582.         POP EAX
  11583.      END;
  11584.  
  11585. END;
  11586.  
  11587. PROCEDURE AnsiStr2Long(VAR s:AnsiString;VAR b:LONGINT;VAR c:INTEGER);
  11588. VAR s1:STRING;
  11589. BEGIN
  11590.      ASM
  11591.         PUSH EAX
  11592.         PUSH EBX
  11593.         PUSH ECX
  11594.         PUSH EDX
  11595.         PUSH ESI
  11596.         PUSH EDI
  11597.      END;
  11598.  
  11599.      s1:=s;
  11600.      ASM
  11601.         LEA EAX,s1
  11602.         PUSH EAX
  11603.         PUSH DWORD PTR b
  11604.         PUSH DWORD PTR c
  11605.         CALLN32 SYSTEM.!Str2Long
  11606.      END;
  11607.  
  11608.      ASM
  11609.         POP EDI
  11610.         POP ESI
  11611.         POP EDX
  11612.         POP ECX
  11613.         POP EBX
  11614.         POP EAX
  11615.      END;
  11616. END;
  11617.  
  11618. ASSEMBLER
  11619.  
  11620. SYSTEM.!AssignStr2Array PROC NEAR32
  11621.                 CLD
  11622.                 PUSH EBP
  11623.                 MOV EBP,ESP
  11624.  
  11625.                 PUSH EAX
  11626.                 PUSH EBX
  11627.                 PUSH ECX
  11628.                 PUSH EDX
  11629.                 PUSH EDI
  11630.                 PUSH ESI
  11631.  
  11632.                 MOV EDI,[EBP+8]    //Destination Array
  11633.                 MOV ESI,[EBP+12]   //Source String
  11634.  
  11635.                 MOVZXB ECX,[ESI+0]
  11636.                 INC ESI
  11637.  
  11638.                 MOV EDX,ECX
  11639.                 SHR ECX,2
  11640.                 REP
  11641.                 MOVSD
  11642.                 MOV ECX,EDX
  11643.                 AND ECX,3
  11644.                 REP
  11645.                 MOVSB
  11646.  
  11647.                 POP ESI
  11648.                 POP EDI
  11649.                 POP EDX
  11650.                 POP ECX
  11651.                 POP EBX
  11652.                 POP EAX
  11653.  
  11654.                 LEAVE
  11655.                 RETN32 8
  11656. SYSTEM.!AssignStr2Array ENDP
  11657.  
  11658. SYSTEM.!AssignCStr2Array PROC NEAR32
  11659.                 CLD
  11660.                 PUSH EBP
  11661.                 MOV EBP,ESP
  11662.  
  11663.                 PUSH EAX
  11664.                 PUSH EBX
  11665.                 PUSH ECX
  11666.                 PUSH EDX
  11667.                 PUSH EDI
  11668.                 PUSH ESI
  11669.  
  11670.                 MOV ESI,[EBP+12]   //Source CString
  11671.                 MOV EDI,ESI
  11672.                 MOV ECX,$0FFFFFFFF
  11673.                 XOR AL,AL
  11674.                 REPNE
  11675.                 SCASB
  11676.                 NOT ECX
  11677.  
  11678.                 MOV EDI,[EBP+8]    //Destination Array
  11679.  
  11680.                 MOV EDX,ECX
  11681.                 SHR ECX,2
  11682.                 REP
  11683.                 MOVSD
  11684.                 MOV ECX,EDX
  11685.                 AND ECX,3
  11686.                 REP
  11687.                 MOVSB
  11688.  
  11689.                 POP ESI
  11690.                 POP EDI
  11691.                 POP EDX
  11692.                 POP ECX
  11693.                 POP EBX
  11694.                 POP EAX
  11695.  
  11696.                 LEAVE
  11697.                 RETN32 8
  11698. SYSTEM.!AssignCStr2Array ENDP
  11699.  
  11700. SYSTEM.!StrCopy PROC NEAR32
  11701.                 CLD
  11702.                 PUSH EBP
  11703.                 MOV EBP,ESP
  11704.  
  11705.                 PUSH EAX
  11706.                 PUSH ECX
  11707.                 PUSH EDI
  11708.                 PUSH ESI
  11709.  
  11710.                 MOV EDI,[EBP+12]    //Destination String
  11711.                 MOV ESI,[EBP+16]    //Source String
  11712.                 MOV ECX,[EBP+8]     //Maximum length
  11713.                 LODSB
  11714.                 CMP AL,CL
  11715.                 JBE _L1
  11716.                 MOV AL,CL
  11717. _L1:
  11718.                 STOSB
  11719.                 MOVZX ECX,AL
  11720.  
  11721.                 MOV EAX,ECX
  11722.                 SHR ECX,2
  11723.                 REP
  11724.                 MOVSD
  11725.                 MOV ECX,EAX
  11726.                 AND ECX,3
  11727.                 REP
  11728.                 MOVSB
  11729.  
  11730.                 POP ESI
  11731.                 POP EDI
  11732.                 POP ECX
  11733.                 POP EAX
  11734.  
  11735.                 LEAVE
  11736.                 RETN32 12
  11737. SYSTEM.!StrCopy ENDP
  11738.  
  11739. SYSTEM.!AssignStr2PChar PROC NEAR32
  11740.                 CLD
  11741.  
  11742.                 PUSH EBP
  11743.                 MOV EBP,ESP
  11744.  
  11745.                 PUSH EAX
  11746.                 PUSH ECX
  11747.                 PUSH EDX
  11748.                 PUSH EDI
  11749.                 PUSH ESI
  11750.  
  11751.                 MOV EDI,[EBP+12]    //Destination CString
  11752.                 MOV ESI,[EBP+16]    //Source String
  11753.                 MOV ECX,[EBP+8]     //Maximum length
  11754.  
  11755.                 LODSB               //get length of source string
  11756.                 MOVZX EAX,AL
  11757.                 CMP EAX,ECX
  11758.                 JB _L1_1
  11759.                 MOV EAX,ECX
  11760. _L1_1:
  11761.                 MOV ECX,EAX
  11762.                 MOV EDX,EAX
  11763.                 SHR ECX,2
  11764.                 REP
  11765.                 MOVSD
  11766.                 MOV ECX,EDX
  11767.                 AND ECX,3
  11768.                 REP
  11769.                 MOVSB
  11770.  
  11771.                 MOV AL,0
  11772.                 STOSB            //terminate PChar
  11773.  
  11774.                 POP ESI
  11775.                 POP EDI
  11776.                 POP EDX
  11777.                 POP ECX
  11778.                 POP EAX
  11779.  
  11780.                 LEAVE
  11781.                 RETN32 12
  11782. SYSTEM.!AssignStr2PChar ENDP
  11783.  
  11784. SYSTEM.!AssignPChar2Str PROC NEAR32
  11785.                 CLD
  11786.                 PUSH EBP
  11787.                 MOV EBP,ESP
  11788.  
  11789.                 PUSH EAX
  11790.                 PUSH EBX
  11791.                 PUSH ECX
  11792.                 PUSH EDX
  11793.                 PUSH EDI
  11794.                 PUSH ESI
  11795.  
  11796.                 MOV ESI,[EBP+16]   //Source CString
  11797.                 MOV EDX,[EBP+8]    //Maximum length
  11798.  
  11799.                 MOV EDI,ESI        //Source CString
  11800.                 MOV ECX,$0FFFFFFFF
  11801.                 XOR AL,AL
  11802.                 REPNE
  11803.                 SCASB
  11804.                 NOT ECX
  11805.                 MOV EAX,ECX        //length of source string
  11806.                 DEC EAX            //without #0
  11807.  
  11808.                 MOV EDI,[EBP+12]   //Destination String
  11809.  
  11810.                 CMP EAX,EDX
  11811.                 JB _L1_2
  11812.                 MOV EAX,EDX        //set to maximum length
  11813. _L1_2:
  11814.                 MOV ECX,EAX
  11815.                 STOSB              //set string length
  11816.  
  11817.                 MOV EDX,ECX
  11818.                 SHR ECX,2
  11819.                 REP
  11820.                 MOVSD
  11821.                 MOV ECX,EDX
  11822.                 AND ECX,3
  11823.                 REP
  11824.                 MOVSB
  11825.  
  11826.                 POP ESI
  11827.                 POP EDI
  11828.                 POP EDX
  11829.                 POP ECX
  11830.                 POP EBX
  11831.                 POP EAX
  11832.  
  11833.                 LEAVE
  11834.                 RETN32 12
  11835. SYSTEM.!AssignPChar2Str ENDP
  11836.  
  11837. SYSTEM.!CopyArrayStr PROC NEAR32
  11838.                 CLD
  11839.                 MOV EBX,ESP
  11840.                 MOV EDI,[EBX+12]    //Destination String
  11841.                 MOV ESI,[EBX+16]    //Source Array
  11842.                 MOV ECX,[EBX+8]     //Maximum string length
  11843.                 DEC ECX             //minus length byte
  11844.                 MOV EAX,[EBX+4]     //Array length
  11845.  
  11846.                 CMP AL,CL
  11847.                 JBE _L11
  11848.                 MOV AL,CL
  11849. _L11:
  11850.                 STOSB               //String length
  11851.                 MOV CL,AL
  11852.                 MOVZX ECX,CL
  11853.  
  11854.                 MOV EDX,ECX
  11855.                 SHR ECX,2
  11856.                 REP
  11857.                 MOVSD
  11858.                 MOV ECX,EDX
  11859.                 AND ECX,3
  11860.                 REP
  11861.                 MOVSB
  11862.  
  11863.                 RETN32 16
  11864. SYSTEM.!CopyArrayStr ENDP
  11865.  
  11866. //(Source,Dest,MaxLen)
  11867. SYSTEM.!PCharCopy PROC NEAR32
  11868.          CLD
  11869.          PUSH EBP
  11870.          MOV EBP,ESP
  11871.  
  11872.          PUSH EAX
  11873.          PUSH EBX
  11874.          PUSH ECX
  11875.          PUSH EDX
  11876.          PUSH ESI
  11877.          PUSH EDI
  11878.  
  11879.          MOV EDI,[EBP+16]  //Source
  11880.          MOV ECX,$0FFFFFFFF
  11881.          XOR AL,AL
  11882.          REPNE
  11883.          SCASB
  11884.          NOT ECX
  11885.          MOV EDX,[EBP+8]   //Maximum length
  11886.          CMP EDX,ECX
  11887.          JAE _re
  11888.          MOV ECX,EDX
  11889. _re:
  11890.          MOV ESI,[EBP+16]  //Source
  11891.          MOV EDI,[EBP+12]  //Destination
  11892.  
  11893.          MOV EDX,ECX
  11894.          SHR ECX,2
  11895.          REP
  11896.          MOVSD
  11897.          MOV ECX,EDX
  11898.          AND ECX,3
  11899.          REP
  11900.          MOVSB
  11901.  
  11902.          POP EDI
  11903.          POP ESI
  11904.          POP EDX
  11905.          POP ECX
  11906.          POP EBX
  11907.          POP EAX
  11908.  
  11909.          LEAVE
  11910.          RETN32 12
  11911. SYSTEM.!PCharCopy ENDP
  11912.  
  11913. SYSTEM.!PCharLength PROC NEAR32
  11914.          PUSH EBP
  11915.          MOV EBP,ESP
  11916.  
  11917.          PUSH EBX
  11918.          PUSH EDI
  11919.          PUSH ECX
  11920.  
  11921.          MOV EDI,[EBP+8]   //Source
  11922.  
  11923.          XOR EAX,EAX
  11924.          CMP EDI,0
  11925.          JE _pcl
  11926.  
  11927.          MOV ECX,$0FFFFFFFF
  11928.          XOR AL,AL
  11929.          CLD
  11930.          REPNE
  11931.          SCASB
  11932.          NOT ECX
  11933.          MOV EAX,ECX
  11934.          DEC EAX           //without #0
  11935. _pcl:
  11936.          POP ECX
  11937.          POP EDI
  11938.          POP EBX
  11939.  
  11940.          LEAVE
  11941.          RETN32 4
  11942. SYSTEM.!PCharLength ENDP
  11943.  
  11944.  
  11945. SYSTEM.!StrAdd PROC NEAR32
  11946.         PUSH EBP
  11947.         MOV EBP,ESP
  11948.  
  11949.         PUSH EAX
  11950.         PUSH EBX
  11951.         PUSH ECX
  11952.         PUSH EDX
  11953.         PUSH EDI
  11954.         PUSH ESI
  11955.  
  11956.         MOV EDI,[EBP+12]    //Destination
  11957.         MOV ESI,[EBP+8]     //String to add
  11958.         MOVZXB ECX,[EDI+0]  //length of destination
  11959.         CLD
  11960.         LODSB               //length of string to add
  11961.         ADD [EDI+0],AL
  11962.         JNC _lll1
  11963.         MOVB [EDI+0],255
  11964.         MOV AL,CL
  11965.         NOT AL
  11966. _lll1:
  11967.         ADD EDI,ECX
  11968.         INC EDI
  11969.         MOV CL,AL
  11970.  
  11971.         MOV EDX,ECX
  11972.         SHR ECX,2
  11973.         REP
  11974.         MOVSD
  11975.         MOV ECX,EDX
  11976.         AND ECX,3
  11977.         REP
  11978.         MOVSB
  11979.  
  11980.         POP ESI
  11981.         POP EDI
  11982.         POP EDX
  11983.         POP ECX
  11984.         POP EBX
  11985.         POP EAX
  11986.  
  11987.         LEAVE
  11988.         RETN32 8
  11989. SYSTEM.!StrAdd ENDP
  11990.  
  11991. SYSTEM.!PCharAdd PROC NEAR32
  11992.         PUSH EBP
  11993.         MOV EBP,ESP
  11994.  
  11995.         PUSH EAX
  11996.         PUSH EBX
  11997.         PUSH ECX
  11998.         PUSH EDX
  11999.         PUSH EDI
  12000.         PUSH ESI
  12001.  
  12002.         CLD
  12003.  
  12004.         MOV ESI,[EBP+8]    //String to add
  12005.         MOV EDI,[EBP+8]    //String to add
  12006.         MOV ECX,$0FFFFFFFF
  12007.         XOR AL,AL
  12008.         REPNE
  12009.         SCASB
  12010.         NOT ECX            //length of string to add
  12011.         DEC ECX            //without #0
  12012.         MOV EBX,ECX
  12013.  
  12014.         MOV EDI,[EBP+12]   //Destination
  12015.         MOV ECX,$0FFFFFFFF
  12016.         XOR AL,AL
  12017.         REPNE
  12018.         SCASB
  12019.         NOT ECX            //length of destination
  12020.         DEC ECX            //without #0
  12021.  
  12022.         MOV EDI,[EBP+12]   //Destination
  12023.         ADD EDI,ECX        //add length to destination
  12024.  
  12025.         MOV ECX,EBX        //length of string to add
  12026.  
  12027.         MOV EDX,ECX
  12028.         SHR ECX,2
  12029.         REP
  12030.         MOVSD
  12031.         MOV ECX,EDX
  12032.         AND ECX,3
  12033.         REP
  12034.         MOVSB
  12035.  
  12036.         MOV AL,0
  12037.         STOSB              //terminate PChar
  12038.  
  12039.         POP ESI
  12040.         POP EDI
  12041.         POP EDX
  12042.         POP ECX
  12043.         POP EBX
  12044.         POP EAX
  12045.  
  12046.         LEAVE
  12047.         RETN32 8
  12048. SYSTEM.!PCharAdd ENDP
  12049.  
  12050. SYSTEM.!Str2PChar PROC NEAR32
  12051.                PUSH EBP
  12052.                MOV EBP,ESP
  12053.  
  12054.                PUSH EAX
  12055.                PUSH EBX
  12056.                PUSH ECX
  12057.                PUSH EDX
  12058.                PUSH EDI
  12059.                PUSH ESI
  12060.  
  12061.                MOV ESI,[EBP+8]     //String to convert
  12062.                MOV EDI,ESI
  12063.                MOVZXB ECX,[ESI+0]
  12064.                INC ESI
  12065.  
  12066.                CLD
  12067.                MOV EDX,ECX
  12068.                SHR ECX,2
  12069.                REP
  12070.                MOVSD
  12071.                MOV ECX,EDX
  12072.                AND ECX,3
  12073.                REP
  12074.                MOVSB
  12075.  
  12076.                MOV AL,0   //terminate PChar
  12077.                STOSB
  12078.  
  12079.                POP ESI
  12080.                POP EDI
  12081.                POP EDX
  12082.                POP ECX
  12083.                POP EBX
  12084.                POP EAX
  12085.  
  12086.                LEAVE
  12087.                RETN32 4
  12088. SYSTEM.!Str2PChar ENDP
  12089.  
  12090. SYSTEM.!PChar2Str PROC NEAR32
  12091.                PUSH EBP
  12092.                MOV EBP,ESP
  12093.  
  12094.                PUSH EAX
  12095.                PUSH EBX
  12096.                PUSH ECX
  12097.                PUSH EDX
  12098.                PUSH EDI
  12099.                PUSH ESI
  12100.  
  12101.                MOV EDI,[EBP+8]   //string to convert
  12102.  
  12103.                CLD
  12104.                MOV ECX,$0FFFFFFFF
  12105.                XOR AL,AL
  12106.                REPNE
  12107.                SCASB
  12108.                NOT ECX            //length of string
  12109.                DEC ECX            //without #0
  12110.                MOV EDX,ECX        //used to set len
  12111.  
  12112.                MOV ESI,[EBP+8]
  12113.                ADD ESI,ECX        //to last character of source
  12114.                DEC ESI
  12115.                MOV EDI,ESI
  12116.                INC EDI            //destination is 1 up
  12117.  
  12118.                STD                //move the bytes 1 up
  12119.                REP
  12120.                MOVSB
  12121.  
  12122.                MOV AL,DL          //set string length
  12123.                STOSB
  12124.                CLD
  12125.  
  12126.                POP ESI
  12127.                POP EDI
  12128.                POP EDX
  12129.                POP ECX
  12130.                POP EBX
  12131.                POP EAX
  12132.  
  12133.                LEAVE
  12134.                RETN32
  12135. SYSTEM.!PChar2Str ENDP
  12136.  
  12137. SYSTEM.!StringCmp PROC NEAR32
  12138.               CLD
  12139.               PUSH EBP
  12140.               MOV EBP,ESP
  12141.  
  12142.               PUSH EAX
  12143.               PUSH ECX
  12144.               PUSH EDI
  12145.               PUSH ESI
  12146.  
  12147.               MOV EDI,[EBP+8]
  12148.               MOV ESI,[EBP+12]
  12149.               LODSB
  12150.               MOV AH,[EDI+0]
  12151.               INC EDI
  12152.               MOV CL,AL
  12153.               CMP CL,AH
  12154.               JBE _nl1
  12155.               MOV CL,AH
  12156. _nl1:
  12157.               OR CL,CL
  12158.               JE _nl2
  12159.               MOVZX ECX,CL
  12160.               CLD
  12161.               REP
  12162.               CMPSB
  12163.               JNE _nl3
  12164. _nl2:
  12165.               CMP AL,AH
  12166. _nl3:
  12167.               POP ESI
  12168.               POP EDI
  12169.               POP ECX
  12170.               POP EAX
  12171.  
  12172.               LEAVE
  12173.               RETN32 8
  12174. SYSTEM.!StringCmp ENDP
  12175.  
  12176. SYSTEM.!StringEq PROC NEAR32
  12177.               CLD
  12178.               PUSH EBP
  12179.               MOV EBP,ESP
  12180.  
  12181.               PUSH EAX
  12182.               PUSH ECX
  12183.               PUSH EDI
  12184.               PUSH ESI
  12185.  
  12186.               MOV EDI,[EBP+12]
  12187.               MOV ESI,[EBP+8]
  12188.  
  12189.               LODSB
  12190.               CMP AL,[EDI]
  12191.               JNE _nl3eq
  12192.               CMP AL,0
  12193.               JE _nl3eq
  12194.               INC EDI
  12195.               MOVZX ECX,AL
  12196.               REP
  12197.               CMPSB
  12198. _nl3eq:
  12199.               POP ESI
  12200.               POP EDI
  12201.               POP ECX
  12202.               POP EAX
  12203.  
  12204.               LEAVE
  12205.               RETN32 8
  12206. SYSTEM.!StringEq ENDP
  12207.  
  12208. SYSTEM.!PCharCmp PROC NEAR32
  12209.               CLD
  12210.               PUSH EBP
  12211.               MOV EBP,ESP
  12212.  
  12213.               PUSH EAX
  12214.               PUSH EBX
  12215.               PUSH ECX
  12216.               PUSH EDX
  12217.               PUSH EDI
  12218.               PUSH ESI
  12219.  
  12220.               MOV EDI,[EBP+8]
  12221.               CLD
  12222.               MOV ECX,$0FFFFFFFF
  12223.               XOR AL,AL
  12224.               REPNE
  12225.               SCASB
  12226.               NOT ECX            //length of string
  12227.               DEC ECX            //without #0
  12228.               MOV EBX,ECX        //used to set len
  12229.  
  12230.               MOV EDI,[EBP+12]
  12231.               CLD
  12232.               MOV ECX,$0FFFFFFFF
  12233.               XOR AL,AL
  12234.               REPNE
  12235.               SCASB
  12236.               NOT ECX            //length of string
  12237.               DEC ECX            //without #0
  12238.               MOV EDX,ECX
  12239.  
  12240.               MOV EDI,[EBP+8]
  12241.               MOV ESI,[EBP+12]
  12242.  
  12243.               CMP EBX,ECX
  12244.               JNE _nl3_1
  12245. _nl1_1:
  12246.               OR ECX,ECX
  12247.               JE _nl2_1
  12248.  
  12249.               CLD
  12250.               REP
  12251.               CMPSB
  12252.               JNE _nl3_1
  12253. _nl2_1:
  12254.               CMP EBX,EDX
  12255. _nl3_1:
  12256.               POP ESI
  12257.               POP EDI
  12258.               POP EDX
  12259.               POP ECX
  12260.               POP EBX
  12261.               POP EAX
  12262.  
  12263.               LEAVE
  12264.               RETN32 8
  12265. SYSTEM.!PCharCmp ENDP
  12266.  
  12267. SYSTEM.!StrPCharCmp PROC NEAR32
  12268.               CLD
  12269.               PUSH EBP
  12270.               MOV EBP,ESP
  12271.  
  12272.               PUSH EAX
  12273.               PUSH EBX
  12274.               PUSH ECX
  12275.               PUSH EDX
  12276.               PUSH EDI
  12277.               PUSH ESI
  12278.  
  12279.               MOV EDI,[EBP+8]    //PChar
  12280.               CLD
  12281.               MOV ECX,$0FFFFFFFF
  12282.               XOR AL,AL
  12283.               REPNE
  12284.               SCASB
  12285.               NOT ECX            //length of string
  12286.               DEC ECX            //without #0
  12287.               MOV EBX,ECX        //used to set len
  12288.  
  12289.               MOV EDI,[EBP+12]   //Str
  12290.               MOVZXB ECX,[EDI]
  12291.               MOV EDX,ECX
  12292.  
  12293.               MOV EDI,[EBP+8]    //PChar
  12294.               MOV ESI,[EBP+12]   //Str
  12295.               INC ESI
  12296.  
  12297.               CMP EBX,ECX
  12298.               JNE _nl3_1_r1
  12299. _nl1_1_r1:
  12300.               OR ECX,ECX
  12301.               JE _nl2_1_r1
  12302.  
  12303.               CLD
  12304.               REP
  12305.               CMPSB
  12306.               JNE _nl3_1_r1
  12307. _nl2_1_r1:
  12308.               CMP EBX,EDX
  12309. _nl3_1_r1:
  12310.               POP ESI
  12311.               POP EDI
  12312.               POP EDX
  12313.               POP ECX
  12314.               POP EBX
  12315.               POP EAX
  12316.  
  12317.               LEAVE
  12318.               RETN32 8
  12319. SYSTEM.!StrPCharCmp ENDP
  12320.  
  12321. SYSTEM.!PCharStrCmp PROC NEAR32
  12322.               CLD
  12323.               PUSH EBP
  12324.               MOV EBP,ESP
  12325.  
  12326.               PUSH EAX
  12327.               PUSH EBX
  12328.               PUSH ECX
  12329.               PUSH EDX
  12330.               PUSH EDI
  12331.               PUSH ESI
  12332.  
  12333.               MOV EDI,[EBP+8]    //Str
  12334.               MOVZXB ECX,[EDI]
  12335.               MOV EBX,ECX        //used to set len
  12336.  
  12337.               MOV EDI,[EBP+12]   //PChar
  12338.               CLD
  12339.               MOV ECX,$0FFFFFFFF
  12340.               XOR AL,AL
  12341.               REPNE
  12342.               SCASB
  12343.               NOT ECX            //length of string
  12344.               DEC ECX            //without #0
  12345.               MOV EDX,ECX
  12346.  
  12347.               MOV EDI,[EBP+8]    //Str
  12348.               MOV ESI,[EBP+12]   //PChar
  12349.               INC EDI
  12350.  
  12351.               CMP EBX,ECX
  12352.               JNE _nl3_1_r2
  12353. _nl1_1_r2:
  12354.               OR ECX,ECX
  12355.               JE _nl2_1_r2
  12356.  
  12357.               CLD
  12358.               REP
  12359.               CMPSB
  12360.               JNE _nl3_1_r2
  12361. _nl2_1_r2:
  12362.               CMP EBX,EDX
  12363. _nl3_1_r2:
  12364.               POP ESI
  12365.               POP EDI
  12366.               POP EDX
  12367.               POP ECX
  12368.               POP EBX
  12369.               POP EAX
  12370.  
  12371.               LEAVE
  12372.               RETN32 8
  12373. SYSTEM.!PCharStrCmp ENDP
  12374.  
  12375. END;
  12376.  
  12377. //************************************************************************
  12378. // Error support functions
  12379. //************************************************************************
  12380.  
  12381. {$IFDEF OS2}
  12382. IMPORTS
  12383.        FUNCTION DosExit(action,result:LONGWORD):LONGWORD;
  12384.                     APIENTRY;             'DOSCALLS' index 234;
  12385. END;
  12386. {$ENDIF}
  12387.  
  12388. {$IFDEF OS2}
  12389. PROCEDURE ExitAll;
  12390. BEGIN
  12391.      IF ApplicationType=1 THEN {destroy PM}
  12392.      BEGIN
  12393.           WinDestroyMsgQueueAPI(AppQueueHandle);
  12394.           WinTerminateAPI(HInstance);
  12395.      END;
  12396.  
  12397.      DosExit(1,ExitCode);
  12398. END;
  12399.  
  12400. PROCEDURE ExitAllDLL;
  12401. BEGIN
  12402.      IF ApplicationType=1 THEN {destroy PM}
  12403.      BEGIN
  12404.           WinDestroyMsgQueueAPI(AppQueueHandle);
  12405.           WinTerminateAPI(HInstance);
  12406.      END;
  12407.  
  12408.      ExitProc:=NIL;
  12409. END;
  12410.  
  12411. PROCEDURE Halt(Code:LONGWORD);
  12412. BEGIN
  12413.      ExitCode:=Code;
  12414.  
  12415.      ASM
  12416. !exloop:
  12417.         PUSHL *!raddr                     //Return adress for ExitProc
  12418.         PUSH DWORD PTR SYSTEM.ExitProc    //ExitProc on Stack
  12419.         RETN32
  12420. !raddr:
  12421.         CMPD SYSTEM.DLLModule,0  //from DLL ????
  12422.         JE !exloop
  12423.         CMPD SYSTEM.ExitProc,0
  12424.         JNE !exloop           //until termination
  12425.      END;
  12426. END;
  12427.  
  12428. PROCEDURE HaltIntern(Code:LONGWORD);
  12429. VAR
  12430.    cs:CSTRING;
  12431.    cTitle:CSTRING;
  12432. BEGIN
  12433.      ExitCode:=Code;
  12434.  
  12435.      IF ExitCode<>0 THEN
  12436.      BEGIN
  12437.           IF ApplicationType=1 THEN
  12438.           BEGIN
  12439.                cs:='Speed Pascal/2 Runtime error '+tostr(ExitCode);
  12440.                cTitle:='Runtime error';
  12441.                InitPM;
  12442.                WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  12443.           END
  12444.           ELSE Writeln('Speed Pascal/2 Runtime error ',ExitCode);
  12445.      END;
  12446.  
  12447.      ASM
  12448. !exloop_11:
  12449.         PUSHL *!raddr_11                  //Return adress for ExitProc
  12450.         PUSH DWORD PTR SYSTEM.ExitProc    //ExitProc on Stack
  12451.         RETN32
  12452. !raddr_11:
  12453.         CMP DWORD PTR SYSTEM.DLLModule,0  //from DLL ????
  12454.         JE !exloop_11
  12455.         CMP DWORD PTR SYSTEM.ExitProc,0
  12456.         JNE !exloop_11           //until termination
  12457.      END;
  12458.      DosExit(1,ExitCode);
  12459. END;
  12460. {$ENDIF}
  12461. {$IFDEF WIN95}
  12462. PROCEDURE ExitAll;
  12463. BEGIN
  12464.      ExitProcess(ExitCode);
  12465. END;
  12466.  
  12467. PROCEDURE ExitAllDLL;
  12468. BEGIN
  12469.      ExitProc:=NIL;
  12470. END;
  12471.  
  12472. PROCEDURE Halt(Code:LONGWORD);
  12473. VAR
  12474.    cs:CSTRING;
  12475.    cTitle:CSTRING;
  12476. BEGIN
  12477.      ExitCode:=Code;
  12478.  
  12479.      IF ExitCode<>0 THEN
  12480.      BEGIN
  12481.           IF ApplicationType=1 THEN
  12482.           BEGIN
  12483.                cs:='Speed Pascal/2 Runtime error '+tostr(ExitCode);
  12484.                cTitle:='Runtime error';
  12485.                MessageBox(0,cs,ctitle,0);
  12486.           END
  12487.           ELSE Writeln('Speed Pascal/2 Runtime error ',ExitCode);
  12488.      END;
  12489.  
  12490.      ASM
  12491. !exloop:
  12492.         PUSHL *!raddr                     //Return adress for ExitProc
  12493.         PUSH DWORD PTR SYSTEM.ExitProc    //ExitProc on Stack
  12494.         RETN32
  12495. !raddr:
  12496.         CMPD SYSTEM.ExitProc,0
  12497.         JNE !exloop           //until termination
  12498.      END;
  12499. END;
  12500.  
  12501. PROCEDURE HaltIntern(Code:LONGWORD);
  12502. BEGIN
  12503.      ExitCode:=Code;
  12504.  
  12505.      ASM
  12506. !exloop_11:
  12507.         PUSHL *!raddr_11                  //Return adress for ExitProc
  12508.         PUSH DWORD PTR SYSTEM.ExitProc    //ExitProc on Stack
  12509.         RETN32
  12510. !raddr_11:
  12511.         JMP !exloop_11           //until termination
  12512.      END;
  12513. END;
  12514. {$ENDIF}
  12515.  
  12516. PROCEDURE RunError(Code:LONGWORD);
  12517. BEGIN
  12518.      HaltIntern(Code);
  12519. END;
  12520.  
  12521.  
  12522. //************************************************************************
  12523. //
  12524. //
  12525. // Memory support management functions
  12526. //
  12527. //
  12528. //************************************************************************
  12529.  
  12530. {$IFDEF OS2}
  12531. IMPORTS
  12532.        FUNCTION DosAllocMem(VAR ppb:POINTER;cb,flag:LONGWORD):LONGWORD;
  12533.                     APIENTRY;             'DOSCALLS' index 299;
  12534.        FUNCTION DosFreeMem(pb:POINTER):LONGWORD;
  12535.                     APIENTRY;             'DOSCALLS' index 304;
  12536.        FUNCTION DosSubAllocMem(pbBase:POINTER;VAR ppb:POINTER;
  12537.                         cb:LONGWORD):LONGWORD;
  12538.                     APIENTRY;             'DOSCALLS' index 345;
  12539.        FUNCTION DosSubFreeMem(pbBase:POINTER;pb:POINTER;
  12540.                               cb:LONGWORD):LONGWORD;
  12541.                     APIENTRY;             'DOSCALLS' index 346;
  12542.        FUNCTION DosSubSetMem(pbBase:POINTER;flag,cb:LONGWORD):LONGWORD;
  12543.                     APIENTRY;             'DOSCALLS' index 344;
  12544.        FUNCTION DosSubUnsetMem(pbBase:POINTER):LONGWORD;
  12545.                     APIENTRY;             'DOSCALLS' index 347;
  12546. END;
  12547.  
  12548. CONST
  12549.      PAG_READ          =$00000001;      { read access                }
  12550.      PAG_WRITE         =$00000002;      { write access               }
  12551.      PAG_COMMIT        =$00000010;      { commit storage             }
  12552.  
  12553.      DOSSUB_INIT       =$01;            { initialize pages           }
  12554.      DOSSUB_SPARSE_OBJ =$04;            { handle commitment          }
  12555.  
  12556.      DC_SEM_SHARED     =$01;            { heap Semaphore flag        }
  12557. {$ENDIF}
  12558.  
  12559. PROCEDURE ErrorInvalidPointer(Adr:LONGINT);
  12560. VAR
  12561.     e:EInvalidPointer;
  12562. BEGIN
  12563.      e.Create('Invalid pointer operation (EInvalidPointer)');
  12564.      e.CameFromRTL:=TRUE;
  12565.      e.RTLExcptAddr:=POINTER(Adr);
  12566.      raise e;
  12567. END;
  12568.  
  12569. PROCEDURE ErrorOutOfMemory(Adr:LONGINT);
  12570. VAR
  12571.    e:EOutOfMemory;
  12572. BEGIN
  12573.      e.Create('Out of memory (EOutOfMemory)');
  12574.      e.CameFromRTL:=TRUE;
  12575.      e.RTLExcptAddr:=POINTER(Adr);
  12576.      raise e;
  12577. END;
  12578.  
  12579. PROCEDURE ErrorInvalidHeap(Adr:LONGINT);
  12580. VAR
  12581.     e:EInvalidHeap;
  12582. BEGIN
  12583.      e.Create('Heap corrupted or destroyed (EInvalidHeap)');
  12584.      e.CameFromRTL:=TRUE;
  12585.      e.RTLExcptAddr:=POINTER(Adr);
  12586.      raise e;
  12587. END;
  12588.  
  12589. {$IFDEF OS2}
  12590. PROCEDURE GetAPIMem(VAR p:POINTER;Size:LONGWORD);
  12591. VAR Adr:LONGINT;
  12592. BEGIN
  12593.      IF DosAllocMem(p,Size,PAG_READ OR PAG_WRITE OR PAG_COMMIT)<>0 THEN
  12594.      BEGIN
  12595.           ASM
  12596.              MOV EAX,[EBP+4]
  12597.              SUB EAX,5
  12598.              MOV Adr,EAX
  12599.           END;
  12600.           ErrorOutOfMemory(Adr);
  12601.      END;
  12602. END;
  12603.  
  12604. {$HINTS OFF}
  12605. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  12606. VAR Adr:LONGINT;
  12607. BEGIN
  12608.      IF DosFreeMem(p)<>0 THEN
  12609.      BEGIN
  12610.           ASM
  12611.              MOV EAX,[EBP+4]
  12612.              SUB EAX,5
  12613.              MOV Adr,EAX
  12614.           END;
  12615.           ErrorInvalidPointer(Adr);
  12616.      END;
  12617. END;
  12618. {$HINTS ON}
  12619. {$ENDIF}
  12620.  
  12621. {$IFDEF WIN95}
  12622. PROCEDURE GetAPIMem(VAR p:POINTER;Size:LONGWORD);
  12623. VAR Adr:LONGINT;
  12624. BEGIN
  12625.      p:=GlobalAlloc(0,Size);  {Allocate fixed memory}
  12626.      IF p=NIL THEN
  12627.      BEGIN
  12628.           ASM
  12629.              MOV EAX,[EBP+4]
  12630.              SUB EAX,5
  12631.              MOV Adr,EAX
  12632.           END;
  12633.           ErrorOutOfMemory(Adr);
  12634.      END;
  12635. END;
  12636.  
  12637. {$HINTS OFF}
  12638. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  12639. VAR Adr:LONGINT;
  12640. BEGIN
  12641.      IF GlobalFree(p)<>NIL THEN
  12642.      BEGIN
  12643.           ASM
  12644.             MOV EAX,[EBP+4]
  12645.             SUB EAX,5
  12646.             MOV Adr,EAX
  12647.           END;
  12648.           ErrorInvalidPointer(Adr);
  12649.      END;
  12650. END;
  12651. {$HINTS ON}
  12652. {$ENDIF}
  12653.  
  12654. {$HINTS OFF}
  12655. PROCEDURE Mark(VAR p:POINTER);
  12656. BEGIN
  12657. END;
  12658.  
  12659. PROCEDURE Release(VAR p:POINTER);
  12660. BEGIN
  12661. END;
  12662.  
  12663. FUNCTION StdHeapError(size:LONGWORD):INTEGER;
  12664. BEGIN
  12665.      StdHeapError:=0;  {Raise Runtime error}
  12666. END;
  12667. {$HINTS ON}
  12668.  
  12669. {$IFDEF OS2}
  12670. IMPORTS
  12671. FUNCTION DosCreateMutexSem(pszName:CSTRING;VAR aphmtx:LONGWORD;flAttr:LONGWORD;
  12672.                            fState:LONGBOOL):LONGWORD;
  12673.                     APIENTRY;             'DOSCALLS' index 331;
  12674. FUNCTION DosRequestMutexSem(ahmtx:LONGWORD;ulTimeout:LONGWORD):LONGWORD;
  12675.                     APIENTRY;             'DOSCALLS' index 334;
  12676. FUNCTION DosReleaseMutexSem(ahmtx:LONGWORD):LONGWORD;
  12677.                     APIENTRY;             'DOSCALLS' index 335;
  12678. END;
  12679.  
  12680. CONST HeapFlag=$524E544C;
  12681.  
  12682. VAR HeapMutex:LONGWORD;
  12683.  
  12684. type
  12685.     PHeapList=^THeapList;
  12686.     THeapList=RECORD
  12687.                     Flag:LONGWORD;   {RNTM}
  12688.                     Size:LONGWORD;
  12689.                     LastLeak:PHeapList;
  12690.                     NextLeak:PHeapList;
  12691.     END;
  12692.  
  12693. type
  12694.     PHeapPages=^THeapPages;
  12695.     THeapPages=ARRAY[0..8191] OF PHeapList;  {Pointers to heap handles}
  12696.  
  12697. VAR LastHeapPage:PHeapList;
  12698.     LastHeapPageAdr:PHeapList;
  12699.     HeapStrategyBestFit:BOOLEAN;
  12700.  
  12701. PROCEDURE RequestHeapMutex;
  12702. BEGIN
  12703.      DosRequestMutexSem(HeapMutex,-1);
  12704. END;
  12705.  
  12706. PROCEDURE ReleaseHeapMutex;
  12707. BEGIN
  12708.      DosReleaseMutexSem(HeapMutex);
  12709. END;
  12710.  
  12711. PROCEDURE HeapErrorIntern(Code:LONGINT;Adr:LONGWORD);
  12712. BEGIN
  12713.      ReleaseHeapMutex; {!!}
  12714.      CASE Code OF
  12715.          1:
  12716.          BEGIN
  12717.               NewSystemHeap; {!!}
  12718.               ErrorOutOfMemory(Adr);
  12719.               Halt;
  12720.          END;
  12721.          2:
  12722.          BEGIN
  12723.               ErrorInvalidPointer(Adr);
  12724.               Halt;
  12725.          END;
  12726.          3:
  12727.          BEGIN
  12728.               NewSystemHeap; {!!}
  12729.               ErrorInvalidHeap(Adr);
  12730.               Halt;
  12731.          END;
  12732.          ELSE
  12733.          BEGIN
  12734.               ErrorInvalidPointer(Adr);
  12735.               Halt;
  12736.          END;
  12737.      END; {case}
  12738. END;
  12739.  
  12740. VAR MemPageSize:LONGWORD;
  12741.  
  12742. PROCEDURE AllocNewPage(Size:LONGWORD);ASSEMBLER;
  12743. VAR Adr:LONGWORD;
  12744. ASM
  12745.    MOV EAX,[EBP+4]
  12746.    SUB EAX,5
  12747.    MOV Adr,EAX
  12748.  
  12749.    MOV ECX,Size
  12750.    MOV EBX,SYSTEM.MemPageSize
  12751.    SUB EBX,40
  12752.    CMP ECX,EBX    //32730
  12753.    JBE !AllocSizeOk
  12754.  
  12755.    {ensure that we can write HeapList with at least 2 entries}
  12756.    ADD ECX,32
  12757.  
  12758. !AllocSizeOk:
  12759.    {round page up to multiple of 128K}
  12760.    MOV EBX,SYSTEM.MemPageSize
  12761.    SUB EBX,1
  12762.    MOV EDX,$FFFFFFFF
  12763.    SUB EDX,EBX
  12764.    ADD ECX,EBX    //32767
  12765.    AND ECX,EDX    //$FFFF8000
  12766.  
  12767.    {Allocate Page}
  12768.    MOV Size,ECX
  12769.  
  12770.    {IF DosAllocMem(LastHeapPage,size,PAG_READ OR PAG_WRITE OR PAG_COMMIT)<>0 THEN}
  12771.    PUSHL $13       {PAG_READ OR PAG_WRITE OR PAG_COMMIT}
  12772.    PUSH ECX
  12773.    PUSHL OFFSET(SYSTEM.LastHeapPage)
  12774.    MOV AL,3
  12775.    CALLDLL DosCalls,299    {DosAllocMem}
  12776.    ADD ESP,12
  12777.    CMP EAX,0
  12778.    JE !AllocNoError
  12779.  
  12780.    PUSHL 1   {Out of memory error}
  12781.    PUSH DWORD PTR Adr
  12782.    CALLN32 SYSTEM.HeapErrorIntern
  12783.  
  12784. !AllocNoError:
  12785.    MOV EDI,SYSTEM.HeapOrg
  12786.    MOV ECX,8191
  12787.  
  12788.    MOV EAX,0
  12789.    CLD
  12790.    REPNE
  12791.    SCASD
  12792.    CMP ECX,0
  12793.    JNE !AllocPageFound
  12794.  
  12795.    PUSHL 1  {Out of memory error}
  12796.    PUSH DWORD PTR Adr
  12797.    CALLN32 SYSTEM.HeapErrorIntern
  12798.  
  12799. !AllocPageFound:
  12800.    SUB EDI,4
  12801.    MOV EAX,SYSTEM.LastHeapPage      {dummy^[t]:=LastHeapPage}
  12802.    MOV [EDI],EAX
  12803.    MOV SYSTEM.LastHeapPageAdr,EDI   {LastHeapPageAdr:=@dummy^[t];}
  12804.  
  12805.    {First leak node - never changed}
  12806.    MOV EDI,SYSTEM.LastHeapPage
  12807.    MOV ECX,Size
  12808.  
  12809.    MOV [EDI].THeapList.Size,ECX        {LastHeapPage^.size:=Initial size;}
  12810.    MOVD [EDI].THeapList.Flag,HeapFlag  {LastHeapPage^.Flag:=HeapFlag;}
  12811.    MOVD [EDI].THeapList.LastLeak,0     {LastHeapPage^.LastLeak:=NIL;}
  12812.    MOV EAX,EDI
  12813.    ADD EAX,16                          {LastHeapPage^.NextLeak:=LastHeapPage+16;}
  12814.    MOV [EDI].THeapList.NextLeak,EAX
  12815.  
  12816.    {second leak node contains size of first leak (whole page-32 here}
  12817.    {This ensures that we have at least 2 page entries free}
  12818.    {EAX=LastHeapPage^.NextLeak}
  12819.    SUB ECX,32                          {LastHeapPage^.NextLeak^.size:=size-32;}
  12820.    MOV [EAX].THeapList.size,ECX
  12821.    MOV [EAX].THeapList.LastLeak,EDI    {LastHeapPage^.NextLeak^.LastLeak:=LastHeapPage;}
  12822.    MOVD [EAX].THeapList.NextLeak,0     {LastHeapPage^.NextLeak^.NextLeak:=NIL;}
  12823.    MOVD [EAX].THeapList.Flag,HeapFlag  {LastHeapPage^.NextLeak^.Flag:=HeapFlag;}
  12824. END;
  12825.  
  12826. PROCEDURE GetMem(VAR p:POINTER;size:LONGWORD);ASSEMBLER;
  12827. VAR OldEDI,OldECX,Adr:LONGWORD;
  12828. ASM
  12829.    MOV EAX,[EBP+4]
  12830.    SUB EAX,5
  12831.    MOV Adr,EAX
  12832.  
  12833.    CALLN32 SYSTEM.RequestHeapMutex
  12834.  
  12835.    MOVD OldEDI,0
  12836.  
  12837.    {IF LastHeapPage=NIL THEN}
  12838.    CMPD SYSTEM.LastHeapPage,0
  12839.    JNE !GetMemLastPageSet
  12840.  
  12841.    {Search for first page node allocated}
  12842. !GetMemScanMapStart:
  12843.    MOV EDI,SYSTEM.HeapOrg
  12844.    MOV ECX,8191
  12845. !GetMemScanMapAgain:
  12846.    {Scan for first Page<>NIL}
  12847.    MOV EAX,0
  12848.    CLD
  12849.    REPE
  12850.    SCASD
  12851.    CMP ECX,0
  12852.    JNE !GetMemPageFound
  12853.  
  12854.    {no previously allocated Page found --> new page}
  12855.    MOVD OldEDI,$FFFFFFFF     {dont loop again to scan map}
  12856.    MOV ECX,Size
  12857.    ADD ECX,4
  12858.    PUSH ECX
  12859.    CALLN32 SYSTEM.AllocNewPage
  12860.    JMP !GetMemLastPageSet
  12861.  
  12862. !GetMemPageFound:
  12863.    MOV OldEDI,EDI
  12864.    MOV OldECX,ECX
  12865.  
  12866.    {Calculate index for that item}
  12867.    MOV EAX,EDI
  12868.    SUB EAX,4
  12869.    MOV SYSTEM.LastHeapPageAdr,EAX
  12870.  
  12871.    MOV EAX,[EAX]     {get pointer to start of page}
  12872.    MOV SYSTEM.LastHeapPage,EAX
  12873.  
  12874. !GetMemLastPageSet:
  12875.  
  12876.    {Try to find the memory in LastHeapPage}
  12877.    MOV ECX,Size
  12878.    TEST ECX,ECX
  12879.    JNE !GetMemSizeOk
  12880.  
  12881.    MOV EDI,p
  12882.    MOVD [EDI],0
  12883.    CALLN32 SYSTEM.ReleaseHeapMutex
  12884.    LEAVE
  12885.    RETN32 8
  12886.  
  12887. !GetMemSizeOk:
  12888.    {Round up requested size to multiples of 16 and add 4 byte for page item}
  12889.    ADD ECX,4
  12890.    ADD ECX,15
  12891.    AND ECX,$FFFFFFF0
  12892.  
  12893.    MOV EDI,SYSTEM.LastHeapPage        {dummy:=LastHeapPage;}
  12894.    MOV ESI,EDI                         {Last:=LastHeapPage;}
  12895.    MOV EBX,0                           {Found:=NIL;}
  12896.    MOV EDX,$FFFFFFFF                   {FoundLen:=$FFFFFFFF;}
  12897.    JMP !GetMemLoop2
  12898.  
  12899. !GetMemLoop1:
  12900.    MOV ESI,EDI                         {Last:=dummy}
  12901.    MOV EDI,[EDI].THeapList.NextLeak    {dummy:=dummy^.NextLeak}
  12902.  
  12903. !GetMemLoop2:
  12904.    {WHILE dummy<>NIL DO}
  12905.    TEST EDI,EDI
  12906.    JE !GetMemLoopEnd
  12907.  
  12908.    CMPD [EDI].THeapList.Flag,HeapFlag  {IF dummy^.Flag<>HeapFlag}
  12909.    JE !GetMemFlagOk
  12910.  
  12911.    PUSHL 3           {HeapList Corrupted}
  12912.    PUSH DWORD PTR Adr
  12913.    CALLN32 SYSTEM.HeapErrorIntern
  12914.  
  12915. !GetMemFlagOk:
  12916.    {dont use first entry (contains overall size of page}
  12917.    CMP EDI,SYSTEM.LastHeapPage
  12918.    JE !GetMemLoop1
  12919.  
  12920.    {IF dummy^.Size>=len THEN}
  12921.    CMP [EDI].THeapList.Size,ECX
  12922.    JB !GetMemLoop1
  12923.  
  12924.    {IF dummy^.Size<>Len THEN}
  12925.    JNE !GetMemLenGreater
  12926.  
  12927. !GetMemFit:
  12928.    {Requested memory fits the leak}
  12929.    MOV EBX,EDI                         {Found:=dummy;}
  12930.    MOV EDX,ECX                         {FoundLen:=dummy^.size;}
  12931.    JMP !GetMemFoundOk
  12932.  
  12933. !GetMemLenGreater:
  12934.    {If Heap strategy is not "Best Fit" - use the first leak}
  12935.    CMPB SYSTEM.HeapStrategyBestFit,1          {Best fit ??}
  12936.    JNE !GetMemFit
  12937.  
  12938.    {IF dummy^.size<FoundLen THEN}
  12939.    CMP [EDI].THeapList.Size,EDX
  12940.    JA !GetMemLoop1
  12941.  
  12942.    MOV EBX,EDI                         {Found:=dummy;}
  12943.    MOV EDX,[EDI].THeapList.Size        {FoundLen:=dummy^.Size;}
  12944.    JMP !GetMemLoop1
  12945.  
  12946. !GetMemLoopEnd:
  12947.    {IF Found=NIL THEN}
  12948.    CMP EBX,0
  12949.    JNE !GetMemFoundOk
  12950.  
  12951.    {No leak found that fulfilles the request - try scan map again}
  12952.    MOV EDI,OldEDI
  12953.    CMP EDI,$FFFFFFFF
  12954.    JNE !GetMemScanMapPossible
  12955.  
  12956.    PUSHL 1               {Out of Memory}
  12957.    PUSH DWORD PTR Adr
  12958.    CALLN32 SYSTEM.HeapErrorIntern
  12959.  
  12960. !GetMemScanMapPossible:
  12961.    CMP EDI,0             {No previous scan}
  12962.    JE !GetMemScanMapStart
  12963.  
  12964.    MOV ECX,OldECX
  12965.    CMP ECX,0
  12966.    JA !GetMemScanMapAgain
  12967.  
  12968.    PUSHL 1               {Out of Memory}
  12969.    PUSH DWORD PTR Adr
  12970.    CALLN32 SYSTEM.HeapErrorIntern
  12971.  
  12972. !GetMemFoundOk:
  12973.    {Leak found}
  12974.  
  12975.    {IF Leak fits exactly use the next entry for NextLeak}
  12976.    MOV EAX,[EBX].THeapList.Size
  12977.    CMP EAX,ECX
  12978.    JNE !LeakIsGreater
  12979.  
  12980.    MOV ESI,[EBX].THeapList.NextLeak
  12981.    {Dont use last leak - in extreme case the size of LastLeak is 0 !}
  12982.    CMP ESI,0
  12983.    JE !LeakIsGreater
  12984.  
  12985.    {Leak fits exactly - delete leak and update leak list}
  12986.    MOV EAX,[EBX].THeapList.LastLeak
  12987.    MOV [EAX].THeapList.NextLeak,ESI
  12988.    MOV [ESI].THeapList.LastLeak,EAX
  12989.    JMP !GetMemEnd
  12990.  
  12991. !LeakIsGreater:
  12992.    {Leak is greater - shrink the leak}
  12993.    MOV ESI,EBX                         {Found^.LastLeak^.NextLeak:=Found+len;}
  12994.    ADD ESI,ECX
  12995.    MOV EAX,[EBX].THeapList.LastLeak
  12996.    MOV [EAX].THeapList.NextLeak,ESI
  12997.  
  12998.    {EBX=Found, ESI=Found^.NextLeak New, ECX=Len}
  12999.    MOV EAX,[EBX].THeapList.Size        {Found^.NextLeak New^.size:=Found^.size-Len;}
  13000.    SUB EAX,ECX
  13001.    MOV [ESI].THeapList.Size,EAX
  13002.    MOV EAX,[EBX].THeapList.NextLeak    {Found^.NextLeak New^.NextLeak:=Found^.NextLeak;}
  13003.    MOV [ESI].THeapList.NextLeak,EAX
  13004.    MOVD [ESI].THeapList.Flag,HeapFlag  {Found^.NextLeak New^.Flag:=HeapFlag;}
  13005.    MOV EAX,[EBX].THeapList.LastLeak    {Found^.NextLeak New^.LastLeak:=Found^.LastLeak;}
  13006.    MOV [ESI].THeapList.LastLeak,EAX
  13007.    MOV EAX,[ESI].THeapList.NextLeak    {Found^.NextLeak New^.NextLeak^.LastLeak:=Found;}
  13008.    CMP EAX,0
  13009.    JE !GetMemEnd
  13010.    MOV [EAX].THeapList.LastLeak,ESI
  13011. !GetMemEnd:
  13012.  
  13013.    {Set the page for which this item was allocated}
  13014.    MOV EAX,SYSTEM.LastHeapPageAdr
  13015.    MOV [EBX+0],EAX
  13016.    ADD EBX,4
  13017.  
  13018.    MOV EDI,p             {p:=Found}
  13019.    MOV [EDI+0],EBX
  13020.    PUSH EBX  //for FillMem
  13021.  
  13022.    // Inform Sibyl
  13023.    //PUSH DWORD PTR p
  13024.    //PUSH DWORD PTR size
  13025.    //CALLN32 SYSTEM.TraceGetMem
  13026.    //
  13027.  
  13028.    CALLN32 SYSTEM.ReleaseHeapMutex
  13029.  
  13030.    POP EDI   //for FillMem
  13031.  
  13032.    //Fill the allocated memory with zero
  13033.    CLD
  13034.    MOV ECX,Size
  13035.    SUB MemAvailBytes,ECX
  13036.    MOV EAX,0
  13037.    MOV EDX,ECX
  13038.    SHR ECX,2
  13039.    REP
  13040.    STOSD
  13041.    MOV ECX,EDX
  13042.    AND ECX,3
  13043.    REP
  13044.    STOSB
  13045.  
  13046.    LEAVE
  13047.    RETN32 8
  13048. END;
  13049.  
  13050. PROCEDURE SAVEGETMEM(var pp:Pointer;size:LongWord);
  13051. BEGIN
  13052.      ASM {!!}
  13053.         PUSH EAX
  13054.         PUSH EBX
  13055.         PUSH ECX
  13056.         PUSH EDX
  13057.         PUSH EDI
  13058.         PUSH ESI
  13059.      END;
  13060.  
  13061.      GetMem(pp,size);
  13062.  
  13063.      ASM {!!}
  13064.         POP ESI
  13065.         POP EDI
  13066.         POP EDX
  13067.         POP ECX
  13068.         POP EBX
  13069.         POP EAX
  13070.      END;
  13071. END;
  13072.  
  13073. IMPORTS
  13074.      FUNCTION DosAllocSharedMem(VAR ppb:POINTER;VAR pszName:CSTRING;
  13075.                                 cb,flag:LONGWORD):LONGWORD;
  13076.                     APIENTRY;             'DOSCALLS' index 300;
  13077.      FUNCTION DosGetSharedMem(pb:POINTER;flag:LONGWORD):LONGWORD;
  13078.                     APIENTRY;             'DOSCALLS' index 302;
  13079.      FUNCTION DosGetNamedSharedMem(VAR ppb:POINTER;pszName:CSTRING;
  13080.                                    flag:LONGWORD):LONGWORD;
  13081.                     APIENTRY;             'DOSCALLS' index 301;
  13082. END;
  13083.  
  13084. PROCEDURE GetSharedMem(var pp:Pointer;size:LongWord);
  13085. VAR Adr:LONGINT;
  13086. BEGIN
  13087.      IF DosAllocSharedMem(pp,NIL,size,$313) <> 0 THEN
  13088.      BEGIN
  13089.           ASM
  13090.             MOV EAX,[EBP+4]
  13091.             SUB EAX,5
  13092.             MOV Adr,EAX
  13093.           END;
  13094.           ErrorOutOfMemory(Adr);
  13095.      END;
  13096. END;
  13097.  
  13098. {$HINTS OFF}
  13099. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  13100. BEGIN
  13101.      DosFreeMem(p);
  13102. END;
  13103. {$HINTS ON}
  13104.  
  13105. PROCEDURE GetNamedSharedMem(CONST Name:STRING;VAR pp:POINTER;size:LongWord);
  13106. VAR c:CSTRING;
  13107.     Adr:LONGINT;
  13108. BEGIN
  13109.      c:='\SHAREMEM\'+Name;
  13110.      pp:=NIL;
  13111.      IF DosAllocSharedMem(pp,c,size,$13) <> 0 THEN
  13112.      BEGIN
  13113.           ASM
  13114.             MOV EAX,[EBP+4]
  13115.             SUB EAX,5
  13116.             MOV Adr,EAX
  13117.           END;
  13118.           ErrorOutOfMemory(Adr);
  13119.      END;
  13120. END;
  13121.  
  13122. FUNCTION AccessSharedMem(p:POINTER):BOOLEAN;
  13123. BEGIN
  13124.      result:=DosGetSharedMem(p,3)=0;
  13125. END;
  13126.  
  13127. FUNCTION AccessNamedSharedMem(CONST Name:STRING;VAR pp:POINTER):BOOLEAN;
  13128. VAR c:CSTRING;
  13129. BEGIN
  13130.      c:='\SHAREMEM\'+Name;
  13131.      result:=DosGetNamedSharedMem(pp,c,3)=0;
  13132.      IF not result THEN pp:=NIL;
  13133. END;
  13134.  
  13135. PROCEDURE FreeNamedSharedMem(CONST Name:STRING);
  13136. VAR p:POINTER;
  13137.     c:CSTRING;
  13138. BEGIN
  13139.      c:='\SHAREMEM\'+Name;
  13140.      IF not AccessNamedSharedMem(Name,p) THEN exit;
  13141.      //we do 2x free because shared memory has a free-counter that
  13142.      //increases each time the DosGetNamedSharedMem function is called
  13143.      FreeSharedMem(p,0);
  13144.      FreeSharedMem(p,0);
  13145. END;
  13146.  
  13147. PROCEDURE FreeMem(p:POINTER;size:LONGWORD);ASSEMBLER;
  13148. VAR Page:PHeapPages;
  13149.     PageOrg:PHeapList;
  13150.     Adr:LONGWORD;
  13151. ASM
  13152.    MOV EAX,[EBP+4]
  13153.    SUB EAX,5
  13154.    MOV Adr,EAX
  13155.  
  13156.    // Inform Sibyl
  13157.    //PUSH DWORD PTR p
  13158.    //PUSH DWORD PTR size
  13159.    //CALLN32 SYSTEM.TraceFreeMem
  13160.    //
  13161.  
  13162.    CALLN32 SYSTEM.RequestHeapMutex
  13163.  
  13164.    MOV ECX,Size
  13165.    TEST ECX,ECX
  13166.    JNE !FreeMemSizeOk
  13167.  
  13168.    CALLN32 SYSTEM.ReleaseHeapMutex
  13169.    LEAVE
  13170.    RETN32 8
  13171.  
  13172. !FreeMemSizeOk:
  13173.    MOV EDI,p
  13174.    JNE !FreeMemPointerOk
  13175.  
  13176.    PUSHL 2   {Illegal pointer operation}
  13177.    PUSH DWORD PTR Adr
  13178.    CALLN32 SYSTEM.HeapErrorIntern
  13179.  
  13180. !FreeMemPointerOk:
  13181.    MOVD [EDI],0      // NIL
  13182.    MOVD [EDI+4],0    // NIL
  13183.    ADD MemAvailBytes,ECX
  13184.    SUB EDI,4
  13185.    MOV EDI,[EDI]
  13186.    MOV Page,EDI     {Page record pointer}
  13187.    MOV EDI,[EDI]    {Page Pointer}
  13188.    MOV PageOrg,EDI
  13189.  
  13190.    ADD ECX,4
  13191.    ADD ECX,15
  13192.    AND ECX,$FFFFFFF0
  13193.  
  13194.    {EDI=Page Pointer, ECX=Size}
  13195.    MOV ESI,p
  13196.    MOV EDI,PageOrg
  13197.    SUB ESI,4
  13198.    JMP !FreeMemStartLoop
  13199.  
  13200. !FreeMemLoop1:
  13201.    MOV EDI,[EDI].THeapList.NextLeak
  13202.  
  13203. !FreeMemStartLoop:
  13204.    TEST EDI,EDI
  13205.    JNE !FreeMemPOk   {invalid pointer operation}
  13206.  
  13207.    PUSHL 2   {Illegal pointer operation}
  13208.    PUSH DWORD PTR Adr
  13209.    CALLN32 SYSTEM.HeapErrorIntern
  13210.  
  13211. !FreeMemPOk:
  13212.    CMP EDI,ESI
  13213.    JAE !FreeMemLabErr1
  13214.  
  13215.    CMPD [EDI].THeapList.Flag,HeapFlag
  13216.    JE !FreeMemLab1
  13217.  
  13218.    PUSHL 3         {Heap corrupted}
  13219.    PUSH DWORD PTR Adr
  13220.    CALLN32 SYSTEM.HeapErrorIntern
  13221.  
  13222. !FreeMemLab1:
  13223.    CMP [EDI].THeapList.NextLeak,ESI
  13224.    JB !FreeMemLoop1
  13225.  
  13226.    JMP !Proceed    {entry found}
  13227.  
  13228. !FreeMemLabErr1:
  13229.    PUSHL 2         {illegal pointer operation}
  13230.    PUSH DWORD PTR Adr
  13231.    CALLN32 SYSTEM.HeapErrorIntern
  13232.  
  13233. !Proceed:
  13234.    {The memory is between dummy and dummy^.NextLeak}
  13235.  
  13236.    {ESI=p-4, EDI=dummy (LastLeak), ECX=Len}
  13237.    MOV EAX,ESI
  13238.    ADD EAX,ECX
  13239.    CMP EAX,[EDI].THeapList.NextLeak
  13240.    JA !FreeMemLabErr1   {illegal pointer operation}
  13241.  
  13242.    MOV EAX,EDI          {EAX=LastLeak}
  13243.    ADD EAX,16
  13244.    {IF LastLeak<>PageOrg THEN Add Size}
  13245.    CMP EDI,PageOrg
  13246.    JE !FreeMemIsPageOrg
  13247.  
  13248.    SUB EAX,16           {Subtract 16 bytes because the size includes it}
  13249.    ADD EAX,[EDI].THeapList.Size
  13250.  
  13251. !FreeMemIsPageOrg:
  13252.    CMP ESI,EAX
  13253.    JAE !LeakOk
  13254.  
  13255.    PUSHL 2            {Illegal pointer operation}
  13256.    PUSH DWORD PTR Adr
  13257.    CALLN32 SYSTEM.HeapErrorIntern
  13258.  
  13259. !LeakOk:
  13260.    {dummy=EDI, Len=ECX, ESI=p-4}
  13261.  
  13262.    {erstes Loch erhalten !}
  13263.    {IF ((dummy<>PageOrg)AND(dummy+dummy^.size=p)) THEN}
  13264.    CMP EDI,PageOrg
  13265.    JE !FreeMemElseLab
  13266.  
  13267.    MOV EAX,EDI
  13268.    ADD EAX,[EDI].THeapList.size
  13269.    CMP EAX,ESI
  13270.    JNE !FreeMemElseLab
  13271.  
  13272.    {Speicher grenzt an Vorgängerloch - verschmelzen}
  13273.    MOV ESI,EDI                     {FreeP:=dummy;}
  13274.    ADD [ESI].THeapList.size,ECX    {inc(FreeP^.size,Len);}
  13275.    JMP !FreeMemElseEnd
  13276.  
  13277.    {ELSE}
  13278. !FreeMemElseLab:
  13279.  
  13280.    {FreeP=ESI=p}
  13281.    MOV [ESI].THeapList.Size,ECX                {FreeP^.size:=len;}
  13282.    MOV [ESI].THeapList.LastLeak,EDI            {FreeP^.LastLeak:=dummy;}
  13283.    MOV DWORD PTR [ESI].THeapList.Flag,HeapFlag {FreeP^.Flag:=HeapFlag;}
  13284.    MOV EDX,[EDI].THeapList.NextLeak            {FreeP^.NextLeak:=dummy^.NextLeak;}
  13285.    MOV [ESI].THeapList.NextLeak,EDX
  13286.    MOV [EDI].THeapList.NextLeak,ESI            {dummy^.NextLeak:=FreeP;}
  13287.    MOV [EDX].THeapList.LastLeak,ESI            {FreeP^.NextLeak^.LastLeak:=FreeP;}
  13288.  
  13289. !FreeMemElseEnd:
  13290.  
  13291.    {IF FreeP+FreeP^.size>=FreeP^.NextLeak THEN}
  13292.    MOV EAX,ESI
  13293.    ADD EAX,[ESI].THeapList.Size
  13294.    CMP EAX,[ESI].THeapList.NextLeak
  13295.    JB !FreeMemDone
  13296.  
  13297.    JE !LeaksAreOk
  13298.  
  13299.    PUSHL 2  {Illegal pointer operation}
  13300.    PUSH DWORD PTR Adr
  13301.    CALLN32 SYSTEM.HeapErrorIntern
  13302.  
  13303. !LeaksAreOk:
  13304.    {Speicher grenzt an Nachfolgelock - verschmelzen}
  13305.    MOV EDI,[ESI].THeapList.NextLeak     {inc(FreeP^.size,FreeP^.NextLeak^.size);}
  13306.    {EDI=FreeP^.NextLeak}
  13307.    MOV EAX,[EDI].THeapList.Size
  13308.    ADD [ESI].THeapList.Size,EAX
  13309.    {Clear Flag of next leak}
  13310.    MOVD [EDI].THeapList.Flag,0
  13311.  
  13312.    MOV EAX,[EDI].THeapList.NextLeak      {FreeP^.NextLeak:=FreeP^.NextLeak^.NextLeak;}
  13313.    MOV [ESI].THeapList.NextLeak,EAX
  13314.    CMP EAX,0                             {FreeP^.NextLeak can be NIL !}
  13315.    JE !FreeMemDone
  13316.    MOV [EAX].THeapList.LastLeak,ESI      {FreeP^.NextLeak^.LastLeak:=FreeP;}
  13317.  
  13318. !FreeMemDone:
  13319.  
  13320.    {Check if this is the last entry and LastLeak=Page Pointer}
  13321.    CMPD [ESI].THeapList.NextLeak,0       {IF FreeP^.NextLeak=NIL THEN}
  13322.    JNE !FreeMemExit
  13323.  
  13324.    MOV EBX,PageOrg                       {Page Pointer}
  13325.    CMP [ESI].THeapList.LastLeak,EBX      {IF FreeP^.LastLeak=Start of Page THEN}
  13326.    JNE !FreeMemExit
  13327.  
  13328.    {ensure that last entry starts immediately after Page start}
  13329.    {this ensures that no more memory is allocated bewteen these entries}
  13330.    {IF FreeP=Start OF Page+16 THEN}
  13331.    MOV EAX,EBX
  13332.    ADD EAX,16
  13333.    CMP ESI,EAX
  13334.    JNE !FreeMemExit
  13335.  
  13336.    {All storage was freed from the page > Free Page itself}
  13337.    PUSH EBX
  13338.    MOV AL,1
  13339.    CALLDLL DosCalls,304                  {DosFreeMem}
  13340.    ADD ESP,4
  13341.    CMP EAX,0
  13342.    JE !DosFreeMemOk
  13343.  
  13344.    PUSHL 2
  13345.    PUSH DWORD PTR Adr
  13346.    CALLN32 SYSTEM.HeapErrorIntern
  13347.  
  13348. !DosFreeMemOk:
  13349.    {dont use that page anymore}
  13350.    MOV EDI,Page
  13351.    MOV ESI,PageOrg
  13352.    MOV DWORD PTR Page,0
  13353.    MOV DWORD PTR PageOrg,0
  13354.  
  13355.    {EDI=Page, ESI=PageOrg
  13356.    {Clear the entry in the page table and clear LastHeapPage if not valid}
  13357.    MOV DWORD PTR [EDI],0
  13358.  
  13359.    {If this page was the active page - clear it}
  13360.    {IF LastHeapPage=PageOrg THEN}
  13361.    CMP SYSTEM.LastHeapPage,ESI
  13362.    JNE !FreeMemExit1   {Leave LastHeapPage and LastHeapPageAddr as they are}
  13363.  
  13364. !FreeMemExit:
  13365.    {Set LastHeapPage and LastHeapPageAdr to the current page}
  13366.    MOV EAX,PageOrg
  13367.    MOV SYSTEM.LastHeapPage,EAX
  13368.    MOV EAX,Page
  13369.    MOV SYSTEM.LastHeapPageAdr,EAX
  13370.  
  13371. !FreeMemExit1:
  13372.    CALLN32 SYSTEM.ReleaseHeapMutex
  13373.  
  13374.    LEAVE
  13375.    RETN32 8
  13376. END;
  13377.  
  13378. //These function is used by FAIL
  13379. PROCEDURE FreeClass(c:TObject);
  13380. BEGIN
  13381.     Try
  13382.        c.Free;
  13383.     Except
  13384.     End;
  13385. END;
  13386.  
  13387. //These function is used by FAIL
  13388. PROCEDURE FreeObject(p:POINTER;Len:LongWord);
  13389. BEGIN
  13390.     Try
  13391.        FreeMem(p,Len);
  13392.     Except
  13393.     End;
  13394. END;
  13395.  
  13396. PROCEDURE SAVEFREEMEM(pp:pointer;size:LongWord);
  13397. BEGIN
  13398.      ASM {!!}
  13399.         PUSH EAX
  13400.         PUSH EBX
  13401.         PUSH ECX
  13402.         PUSH EDX
  13403.         PUSH EDI
  13404.         PUSH ESI
  13405.      END;
  13406.  
  13407.      FreeMem(pp,size);
  13408.  
  13409.      ASM {!!}
  13410.         POP ESI
  13411.         POP EDI
  13412.         POP EDX
  13413.         POP ECX
  13414.         POP EBX
  13415.         POP EAX
  13416.      END;
  13417. END;
  13418.  
  13419. FUNCTION  MaxAvail:LongWord;
  13420. BEGIN
  13421.      result:=HeapSize;
  13422. END;
  13423. {$ENDIF}
  13424.  
  13425. {$IFDEF WIN95}
  13426. CONST
  13427.     HEAP_ZERO_MEMORY                =$00000008;
  13428.  
  13429. PROCEDURE GetMem(var p:Pointer;size:LongWord);
  13430. VAR
  13431.    i:INTEGER;
  13432.    Adr:LONGINT;
  13433. LABEL l;
  13434. BEGIN
  13435.      IF size=0 THEN
  13436.      BEGIN
  13437.           p:=NIL;
  13438.           exit;
  13439.      END;
  13440. l:
  13441.      p:=HeapAlloc(HeapOrg,0,(size+7) AND $FFFFFFF8);
  13442.      IF p=NIL THEN
  13443.      BEGIN
  13444.           i:=HeapError(size);
  13445.           CASE i OF
  13446.              1: p:=NIL;
  13447.              2: goto l;
  13448.              ELSE
  13449.              BEGIN
  13450.                   ASM
  13451.                      MOV EAX,[EBP+4]
  13452.                      SUB EAX,5
  13453.                      MOV Adr,EAX
  13454.                   END;
  13455.                   ErrorOutOfMemory(Adr);
  13456.              END;
  13457.           END;
  13458.           exit;
  13459.      END;
  13460.      FillChar(p^,(size+7) AND $FFFFFFF8,0);
  13461.      IF LONGWORD(p)>LONGWORD(HeapPtr) THEN HeapPtr:=p;
  13462.      dec(MemAvailBytes,(size+7) AND $FFFFFFF8);
  13463. END;
  13464.  
  13465. PROCEDURE SAVEGETMEM(var pp:Pointer;size:LongWord);
  13466. VAR
  13467.    i:INTEGER;
  13468.    Adr:LONGINT;
  13469. LABEL l;
  13470. BEGIN
  13471.      ASM {!!}
  13472.         PUSH EAX
  13473.         PUSH EBX
  13474.         PUSH ECX
  13475.         PUSH EDX
  13476.         PUSH EDI
  13477.         PUSH ESI
  13478.      END;
  13479. l:
  13480.      pp:=HeapAlloc(HeapOrg,0,(size+7) AND $FFFFFFF8);
  13481.      IF pp=NIL THEN
  13482.      BEGIN
  13483.           i:=HeapError(size);
  13484.           CASE i OF
  13485.              1: pp:=NIL;
  13486.              2: goto l;
  13487.              ELSE
  13488.              BEGIN
  13489.                   ASM
  13490.                      MOV EAX,[EBP+4]
  13491.                      SUB EAX,5
  13492.                      MOV Adr,EAX
  13493.                   END;
  13494.                   ErrorOutOfMemory(Adr);
  13495.              END;
  13496.           END;
  13497.           exit;
  13498.      END;
  13499.  
  13500.      FillChar(pp^,(size+7) AND $FFFFFFF8,0);
  13501.      IF LONGWORD(pp)>LONGWORD(HeapPtr) THEN HeapPtr:=pp;
  13502.      dec(MemAvailBytes,(size+7) AND $FFFFFFF8);
  13503.  
  13504.      ASM {!!}
  13505.         POP ESI
  13506.         POP EDI
  13507.         POP EDX
  13508.         POP ECX
  13509.         POP EBX
  13510.         POP EAX
  13511.      END;
  13512. END;
  13513.  
  13514. PROCEDURE FreeMem(p:pointer;size:LongWord);
  13515. VAR
  13516.    i:INTEGER;
  13517.    Adr:LONGINT;
  13518. LABEL l;
  13519. BEGIN
  13520.      IF size=0 THEN exit;
  13521.      //clear memory
  13522.      FillChar(p^,8,0);
  13523. l:
  13524.      IF not HeapFree(HeapOrg,0,p) THEN
  13525.      BEGIN
  13526.           Adr:=GetLastError;
  13527.           i:=HeapError(size);
  13528.           CASE i OF
  13529.              1: p:=NIL;
  13530.              2: goto l;
  13531.              ELSE
  13532.              BEGIN
  13533.                   ASM
  13534.                      MOV EAX,[EBP+4]
  13535.                      SUB EAX,5
  13536.                      MOV Adr,EAX
  13537.                   END;
  13538.                   ErrorInvalidPointer(Adr);
  13539.              END;
  13540.           END;
  13541.           exit;
  13542.      END;
  13543.  
  13544.      inc(MemAvailBytes,(size+7) AND $FFFFFFF8);
  13545. END;
  13546.  
  13547. //These function is used by FAIL
  13548. PROCEDURE FreeClass(c:TObject);
  13549. BEGIN
  13550.     Try
  13551.        c.Free;
  13552.     Except
  13553.     End;
  13554. END;
  13555.  
  13556. //These function is used by FAIL
  13557. PROCEDURE FreeObject(p:POINTER;Len:LongWord);
  13558. BEGIN
  13559.     Try
  13560.        FreeMem(p,Len);
  13561.     Except
  13562.     End;
  13563. END;
  13564.  
  13565. PROCEDURE SaveFreeMem(pp:pointer;size:LongWord);
  13566. BEGIN
  13567.      ASM {!!}
  13568.         PUSH EAX
  13569.         PUSH EBX
  13570.         PUSH ECX
  13571.         PUSH EDX
  13572.         PUSH EDI
  13573.         PUSH ESI
  13574.      END;
  13575.  
  13576.      FreeMem(pp,size);
  13577.  
  13578.      ASM {!!}
  13579.         POP ESI
  13580.         POP EDI
  13581.         POP EDX
  13582.         POP ECX
  13583.         POP EBX
  13584.         POP EAX
  13585.      END;
  13586. END;
  13587.  
  13588. PROCEDURE GetSharedMem(VAR pp:Pointer;size:LongWord);
  13589. VAR Adr:LONGWORD;
  13590. BEGIN
  13591.      pp:=GlobalAlloc($2000,Size);  {Allocate fixed shared memory}
  13592.      IF pp=NIL THEN
  13593.      BEGIN
  13594.           ASM
  13595.              MOV EAX,[EBP+4]
  13596.              SUB EAX,5
  13597.              MOV Adr,EAX
  13598.           END;
  13599.           ErrorOutOfMemory(Adr);
  13600.      END;
  13601. END;
  13602.  
  13603. {$HINTS OFF}
  13604. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  13605. VAR Adr:LONGINT;
  13606. BEGIN
  13607.      IF GlobalFree(p)<>NIL THEN
  13608.      BEGIN
  13609.           ASM
  13610.              MOV EAX,[EBP+4]
  13611.              SUB EAX,5
  13612.              MOV Adr,EAX
  13613.           END;
  13614.           ErrorInvalidPointer(Adr);
  13615.      END;
  13616. END;
  13617.  
  13618. FUNCTION AccessSharedMem(p:POINTER):BOOLEAN;
  13619. BEGIN
  13620.     Result:=TRUE;
  13621. END;
  13622. {$HINTS ON}
  13623.  
  13624. FUNCTION  MaxAvail:LongWord;
  13625. BEGIN
  13626.      MaxAvail:=LONGWORD(HeapEnd)-LONGWORD(HeapPtr);
  13627. END;
  13628. {$ENDIF}
  13629.  
  13630.  
  13631. FUNCTION  MemAvail:LongWord;
  13632. BEGIN
  13633.      result:=MemAvailBytes;
  13634. END;
  13635.  
  13636.  
  13637. {$IFDEF OS2}
  13638. FUNCTION CreateSystemHeap(Size:LONGWORD):BOOLEAN;
  13639. VAR
  13640.     r:LONGWORD;
  13641. BEGIN
  13642.      IF size>8192*8192 THEN size:=8192*8192;  {can only handle 64MB}
  13643.  
  13644.      {Allocate Heap Pages Record}
  13645.      r:=DosAllocMem(HeapOrg,8192*4,PAG_READ OR PAG_WRITE OR PAG_COMMIT);
  13646.      IF r=0 THEN
  13647.      BEGIN
  13648.           FillChar(HeapOrg^,8192*4,0);
  13649.           HeapEnd:=HeapOrg;
  13650.           HeapPtr:=HeapOrg;
  13651.           LastHeapPage:=NIL;
  13652.           LastHeapPageAdr:=NIL;
  13653.           HeapSize:=Size;
  13654.           MemAvailBytes:=Size;
  13655.      END
  13656.      ELSE
  13657.      BEGIN
  13658.           HeapOrg:=NIL;
  13659.           HeapEnd:=NIL;
  13660.           HeapPtr:=NIL;
  13661.           LastHeapPage:=NIL;
  13662.           LastHeapPageAdr:=NIL;
  13663.      END;
  13664.  
  13665.      result:=r=0;
  13666. END;
  13667.  
  13668. PROCEDURE DestroyHeap(Heap:POINTER);
  13669. VAR t:LONGINT;
  13670.     dummy:PHeapPages;
  13671.     Adr:LONGWORD;
  13672. BEGIN
  13673.      ASM
  13674.         MOV EAX,[EBP+4]
  13675.         SUB EAX,5
  13676.         MOV Adr,EAX
  13677.      END;
  13678.      dummy:=Heap;
  13679.      {Deallocate all allocated pages}
  13680.      FOR t:=0 TO 8191 DO IF dummy^[t]<>NIL THEN
  13681.      BEGIN
  13682.           IF DosFreeMem(dummy^[t])<>0 THEN HeapErrorIntern(2,Adr);
  13683.      END;
  13684.  
  13685.      {Deallocate Heap pages record}
  13686.      IF DosFreeMem(Heap)<>0 THEN HeapErrorIntern(2,Adr);
  13687. END;
  13688.  
  13689.  
  13690. PROCEDURE NewSystemHeap;  {delete old system heap and create new one}
  13691. VAR OldSize:LONGWORD;
  13692.     Adr:LONGWORD;
  13693. BEGIN
  13694.     RequestHeapMutex;
  13695.  
  13696.     ASM
  13697.         MOV EAX,[EBP+4]
  13698.         SUB EAX,5
  13699.         MOV Adr,EAX
  13700.     END;
  13701.  
  13702.     {Free old system heap and generate new}
  13703.     OldSize:=HeapSize;
  13704.     DestroySystemHeap;
  13705.     IF not CreateSystemHeap(OldSize) THEN
  13706.     BEGIN
  13707.          ReleaseHeapMutex;
  13708.          HeapErrorIntern(3,Adr);
  13709.     END
  13710.     ELSE ReleaseHeapMutex;
  13711. END;
  13712.  
  13713. PROCEDURE DestroySystemHeap;
  13714. BEGIN
  13715.      DestroyHeap(HeapOrg);
  13716.      HeapOrg:=NIL;
  13717.      HeapPtr:=NIL;
  13718.      HeapEnd:=NIL;
  13719.      FreeList:=NIL;
  13720.      HeapTop:=NIL;
  13721.      LastHeapPage:=NIL;
  13722.      LastHeapPageAdr:=NIL;
  13723. END;
  13724. {$ENDIF}
  13725.  
  13726. {$IFDEF WIN95}
  13727. {$HINTS OFF}
  13728. FUNCTION CreateHeap(size:LONGWORD):POINTER;
  13729. VAR
  13730.    p:POINTER;
  13731. BEGIN
  13732.      p:=HeapCreate(0,8192,0);  {Heap growable and serialize}
  13733.      CreateHeap:=p;
  13734. END;
  13735. {$HINTS ON}
  13736.  
  13737. PROCEDURE DestroyHeap(Heap:POINTER);
  13738. VAR Adr:LONGINT;
  13739. BEGIN
  13740.      IF not HeapDestroy(Heap) THEN
  13741.      BEGIN
  13742.           ASM
  13743.             MOV EAX,[EBP+4]
  13744.             SUB EAX,5
  13745.             MOV Adr,EAX
  13746.           END;
  13747.           ErrorInvalidPointer(Adr);
  13748.      END;
  13749. END;
  13750.  
  13751. FUNCTION CreateSystemHeap(size:LONGWORD):BOOLEAN;
  13752. BEGIN
  13753.      HeapSize:=Size;
  13754.      MemAvailBytes:=Size;
  13755.      HeapOrg:=CreateHeap(size);
  13756.      HeapPtr:=HeapOrg;
  13757.      HeapEnd:=HeapOrg;
  13758.      inc(HeapEnd,size);
  13759.      FreeList:=NIL;
  13760.      HeapTop:=HeapPtr;
  13761.      CreateSystemHeap:=HeapOrg<>NIL;
  13762. END;
  13763.  
  13764. PROCEDURE DestroySystemHeap;
  13765. BEGIN
  13766.      DestroyHeap(HeapOrg);
  13767.      HeapOrg:=NIL;
  13768.      HeapPtr:=NIL;
  13769.      HeapEnd:=NIL;
  13770.      FreeList:=NIL;
  13771.      HeapTop:=NIL;
  13772.      HeapSize:=0;
  13773. END;
  13774.  
  13775.  
  13776. PROCEDURE NewSystemHeap;  {delete old system heap and create new one}
  13777. VAR OldSize:LONGWORD;
  13778. BEGIN
  13779.     {Free old system heap and generate new}
  13780.     OldSize:=HeapSize;
  13781.     DestroySystemHeap;
  13782.     CreateSystemHeap(OldSize);
  13783. END;
  13784. {$ENDIF}
  13785.  
  13786. //**************************************************************************
  13787. //
  13788. //    Random support
  13789. //
  13790. //**************************************************************************}
  13791.  
  13792.  
  13793. CONST
  13794.    Factor:WORD=$8405;
  13795.  
  13796. {$IFDEF OS2}
  13797. IMPORTS
  13798.        FUNCTION DosGetDateTime(VAR pdt:DATETIME):LONGWORD;
  13799.                     APIENTRY;             'DOSCALLS' index 230;
  13800. END;
  13801.  
  13802. PROCEDURE Randomize;
  13803. VAR
  13804.    d:DateTime;
  13805. BEGIN
  13806.      DosGetDateTime(d);
  13807.      RandSeed:=(((d.Hour SHL 8)+d.Min) SHL 16)+
  13808.                 ((d.Sec SHL 8)+d.Hundredths);
  13809. END;
  13810. {$ENDIF}
  13811. {$IFDEF WIN95}
  13812. PROCEDURE Randomize;
  13813. VAR
  13814.    d:RECORD
  13815.            wYear:WORD;
  13816.            wMonth:WORD;
  13817.            wDayOfWeek:WORD;
  13818.            wDay:WORD;
  13819.            wHour:WORD;
  13820.            wMinute:WORD;
  13821.            wSecond:WORD;
  13822.            wMilliseconds:WORD;
  13823.      END;
  13824. BEGIN
  13825.      GetSystemTime(d);
  13826.      RandSeed:=(((d.wHour SHL 8)+d.wMinute) SHL 16)+
  13827.                 ((d.wSecond SHL 8)+d.wMilliseconds);
  13828. END;
  13829. {$ENDIF}
  13830.  
  13831. PROCEDURE NextRandom;
  13832. BEGIN
  13833.      ASM
  13834.         MOV AX,SYSTEM.RandSeed
  13835.         MOV BX,SYSTEM.RandSeed+2
  13836.         MOV CX,AX
  13837.         MULW SYSTEM.Factor
  13838.         SHL CX,3
  13839.         ADD CH,CL
  13840.         ADD DX,CX
  13841.         ADD DX,BX
  13842.         SHL BX,2
  13843.         ADD DX,BX
  13844.         ADD DH,BL
  13845.         MOV CL,5
  13846.         SHL BX,CL
  13847.         ADD DH,BL
  13848.         ADD AX,1
  13849.         ADC DX,0
  13850.         MOV SYSTEM.RandSeed,AX
  13851.         MOV SYSTEM.RandSeed+2,DX
  13852.      END;
  13853. END;
  13854.  
  13855. FUNCTION  Random(value:word):word;
  13856. BEGIN
  13857.      ASM
  13858.         CALLN32 SYSTEM.NextRandom
  13859.         MOV CX,DX
  13860.         MOV BX,value
  13861.         MUL BX
  13862.         MOV AX,CX
  13863.         MOV CX,DX
  13864.         MUL BX
  13865.         ADD AX,CX
  13866.         ADC DX,0
  13867.         MOV AX,DX
  13868.         MOV Result,AX
  13869.     END;
  13870. END;
  13871.  
  13872. FUNCTION FloatRandom:EXTENDED;
  13873. BEGIN
  13874.      result:=Random(8192)/8192;
  13875. END;
  13876.  
  13877. //************************************************************************
  13878. //
  13879. //
  13880. // Direct Memory access support
  13881. //
  13882. //
  13883. //************************************************************************
  13884.  
  13885. PROCEDURE Move(CONST source; VAR dest; size:LONGWORD);ASSEMBLER;
  13886. ASM
  13887.         MOV ESI,Source
  13888.         MOV EDI,Dest
  13889.         MOV ECX,Size
  13890.         CMP ESI,EDI
  13891.         JE !MoveEnd
  13892.         JA !MoveForw
  13893.         MOV EBX,ESI
  13894.         ADD EBX,ECX
  13895.         CMP EBX,EDI               // test overlapping
  13896.         JBE !MoveForw
  13897.  
  13898.         STD
  13899.         ADD ESI,ECX
  13900.         DEC ESI
  13901.         ADD EDI,ECX
  13902.         DEC EDI
  13903.         REP
  13904.         MOVSB
  13905.         CLD
  13906.         JMP !MoveEnd
  13907.  
  13908. !MoveForw:
  13909.         CLD
  13910.         MOV EDX,ECX
  13911.         SHR ECX,2
  13912.         REP
  13913.         MOVSD
  13914.         MOV ECX,EDX
  13915.         AND ECX,3
  13916.         REP
  13917.         MOVSB
  13918.  
  13919. !MoveEnd:
  13920. END;
  13921.  
  13922. PROCEDURE SaveMove(VAR source; VAR dest; size:LONGWORD);ASSEMBLER;
  13923. ASM
  13924.         PUSH EAX
  13925.         PUSH EBX
  13926.         PUSH ECX
  13927.         PUSH EDX
  13928.         PUSH EDI
  13929.         PUSH ESI
  13930.  
  13931.         MOV ESI,Source
  13932.         MOV EDI,Dest
  13933.         MOV ECX,Size
  13934.         CMP ESI,EDI
  13935.         JE !MoveEnd_1
  13936.         JA !MoveForw_1
  13937.         MOV EBX,ESI
  13938.         ADD EBX,ECX
  13939.         CMP EBX,EDI               // test overlapping
  13940.         JBE !MoveForw_1
  13941.  
  13942.         STD
  13943.         ADD ESI,ECX
  13944.         DEC ESI
  13945.         ADD EDI,ECX
  13946.         DEC EDI
  13947.         REP
  13948.         MOVSB
  13949.         CLD
  13950.         JMP !MoveEnd_1
  13951.  
  13952. !MoveForw_1:
  13953.         CLD
  13954.         MOV EDX,ECX
  13955.         SHR ECX,2
  13956.         REP
  13957.         MOVSD
  13958.         MOV ECX,EDX
  13959.         AND ECX,3
  13960.         REP
  13961.         MOVSB
  13962.  
  13963. !MoveEnd_1:
  13964.         POP ESI
  13965.         POP EDI
  13966.         POP EDX
  13967.         POP ECX
  13968.         POP EBX
  13969.         POP EAX
  13970. END;
  13971.  
  13972. ASSEMBLER
  13973. //(Buf1,Buf2,Size)
  13974. SYSTEM.!CompareMem PROC NEAR32
  13975.         PUSH EBP
  13976.         MOV EBP,ESP
  13977.         PUSH ECX
  13978.         PUSH EDI
  13979.         PUSH ESI
  13980.  
  13981.         CLD
  13982.         MOV ESI,[EBP+16]  //Buf1
  13983.         MOV EDI,[EBP+12]  //Buf2
  13984.         MOV ECX,[EBP+8]   //Size
  13985.         CLD
  13986.         REP
  13987.         CMPSB
  13988.  
  13989.         POP ESI
  13990.         POP EDI
  13991.         POP ECX
  13992.         LEAVE
  13993.         RETN32 12
  13994. SYSTEM.!CompareMem ENDP
  13995.  
  13996. END;
  13997.  
  13998. FUNCTION CompareMem(VAR Buf1,Buf2;Size:LONGWORD):BOOLEAN;
  13999. BEGIN
  14000.      ASM
  14001.         PUSH DWORD PTR Buf1
  14002.         PUSH DWORD PTR Buf2
  14003.         PUSH DWORD PTR Size
  14004.         CALLN32 SYSTEM.!CompareMem
  14005.         SETE AL
  14006.         MOV result,AL
  14007.      END;
  14008. END;
  14009.  
  14010. PROCEDURE FillChar(VAR dest;size:LongWord;value:byte);ASSEMBLER;
  14011.     ASM
  14012.         CLD
  14013.         //Note: Stack is dword aligned !
  14014.         MOV EDI,Dest      //Destination pointer
  14015.         MOV ECX,Size      //count
  14016.         CMP ECX,0
  14017.         JE !ex_fillc
  14018.         MOV AL,Value      //Value
  14019.         MOV AH,AL
  14020.         PUSH AX
  14021.         PUSH AX
  14022.         POP EAX
  14023.  
  14024.         MOV EDX,ECX
  14025.         SHR ECX,2
  14026.         REP
  14027.         STOSD
  14028.         MOV ECX,EDX
  14029.         AND ECX,3
  14030.         REP
  14031.         STOSB
  14032. !ex_fillc:
  14033.      END;
  14034.  
  14035. //Set support
  14036. ASSEMBLER
  14037.  
  14038. //(Set,LowRange,HighRange)
  14039. SYSTEM.!SetAddRange PROC NEAR32
  14040.        PUSH EBP
  14041.        MOV EBP,ESP
  14042.        PUSH EDI
  14043.        PUSH ECX
  14044.        PUSH EDX
  14045.        PUSH EAX
  14046.  
  14047.        MOV EDI,[EBP+16]      //Set
  14048.        MOVZXB ECX,[EBP+12]   //LowRange
  14049.        MOVZXB EDX,[EBP+8]    //HighRange
  14050. !SaAgain:
  14051.        CMP ECX,EDX
  14052.        JA !SaEnd
  14053.  
  14054.        MOVZX EAX,CL
  14055.        BTS [EDI],EAX
  14056.  
  14057.        INC ECX
  14058.        JMP !SaAgain
  14059. !SaEnd:
  14060.        POP EAX
  14061.        POP EDX
  14062.        POP ECX
  14063.        POP EDI
  14064.        LEAVE
  14065.        RETN32 12
  14066. SYSTEM.!SetAddRange ENDP
  14067.  
  14068. //(Set,LowRange,HighRange)
  14069. SYSTEM.!SetMinusRange PROC NEAR32
  14070.        PUSH EBP
  14071.        MOV EBP,ESP
  14072.        PUSH EDI
  14073.        PUSH ECX
  14074.        PUSH EDX
  14075.        PUSH EAX
  14076.  
  14077.        MOV EDI,[EBP+16]      //Set
  14078.        MOVZXB ECX,[EBP+12]   //LowRange
  14079.        MOVZXB EDX,[EBP+8]    //HighRange
  14080. !SmAgain:
  14081.        CMP ECX,EDX
  14082.        JA !SmEnd
  14083.  
  14084.        MOVZX EAX,CL
  14085.        BTR [EDI],EAX
  14086.  
  14087.        INC ECX
  14088.        JMP !SmAgain
  14089. !SmEnd:
  14090.        POP EAX
  14091.        POP EDX
  14092.        POP ECX
  14093.        POP EDI
  14094.        LEAVE
  14095.        RETN32 12
  14096. SYSTEM.!SetMinusRange ENDP
  14097.  
  14098. //(LowRange,HighRange,Sub)
  14099. SYSTEM.!GenRangeDWord PROC NEAR32
  14100.       PUSH EBP
  14101.       MOV EBP,ESP
  14102.       PUSH EBX
  14103.       PUSH ECX
  14104.       PUSH EDX
  14105.       PUSH ESI
  14106.       PUSH EDI
  14107.  
  14108.       MOV EAX,0   //result
  14109.  
  14110.       MOV ECX,[EBP+16]  //LowRange
  14111.       MOV EDX,[EBP+12]  //HighRange
  14112.       MOV ESI,[EBP+8]   //Sub
  14113. !SrAgain:
  14114.       CMP ECX,EDX
  14115.       JA !SrEnd
  14116.  
  14117.       MOVZX EBX,CL
  14118.       SUB EBX,ESI
  14119.       BTS EAX,EBX
  14120.  
  14121.       INC ECX
  14122.       JMP !SrAgain
  14123. !SrEnd:
  14124.       POP EDI
  14125.       POP ESI
  14126.       POP EDX
  14127.       POP ECX
  14128.       POP EBX
  14129.       LEAVE
  14130.       RETN32 12
  14131. SYSTEM.!GenRangeDWord ENDP
  14132.  
  14133. //(Quell,Ziel)
  14134. SYSTEM.SetOr32 PROC NEAR32
  14135.           PUSH EBP
  14136.           MOV EBP,ESP
  14137.  
  14138.           PUSH EAX
  14139.           PUSH EBX
  14140.           PUSH ECX
  14141.           PUSH EDX
  14142.           PUSH ESI
  14143.           PUSH EDI
  14144.  
  14145.           MOV EDI,[EBP+8]   //Ziel
  14146.           MOV ESI,[EBP+12]
  14147.           MOV ECX,8
  14148. !SAndl_1:
  14149.           MOV EAX,[ESI+0]
  14150.           OR EAX,[EDI+0]
  14151.           MOV [EDI+0],EAX
  14152.           ADD ESI,4
  14153.           ADD EDI,4
  14154.           LOOP !SAndl_1
  14155.  
  14156.           POP EDI
  14157.           POP ESI
  14158.           POP EDX
  14159.           POP ECX
  14160.           POP EBX
  14161.           POP EAX
  14162.  
  14163.           LEAVE
  14164.           RETN32 8
  14165. SYSTEM.SetOr32 ENDP
  14166.  
  14167. //(Quell,Ziel)
  14168. SYSTEM.SetAnd32 PROC NEAR32
  14169.           PUSH EBP
  14170.           MOV EBP,ESP
  14171.  
  14172.           PUSH EAX
  14173.           PUSH EBX
  14174.           PUSH ECX
  14175.           PUSH EDX
  14176.           PUSH ESI
  14177.           PUSH EDI
  14178.  
  14179.           MOV EDI,[EBP+8]   //Ziel
  14180.           MOV ESI,[EBP+12]
  14181.           MOV ECX,8
  14182. !SAndl:
  14183.           MOV EAX,[ESI+0]
  14184.           AND EAX,[EDI+0]
  14185.           MOV [EDI+0],EAX
  14186.           ADD ESI,4
  14187.           ADD EDI,4
  14188.           LOOP !SAndl
  14189.  
  14190.           POP EDI
  14191.           POP ESI
  14192.           POP EDX
  14193.           POP ECX
  14194.           POP EBX
  14195.           POP EAX
  14196.  
  14197.           LEAVE
  14198.           RETN32 8
  14199. SYSTEM.SetAnd32 ENDP
  14200.  
  14201. //(Quell,Ziel)
  14202. SYSTEM.SetMinus32 PROC NEAR32
  14203.           PUSH EBP
  14204.           MOV EBP,ESP
  14205.  
  14206.           PUSH EAX
  14207.           PUSH EBX
  14208.           PUSH ECX
  14209.           PUSH EDX
  14210.           PUSH ESI
  14211.           PUSH EDI
  14212.  
  14213.           MOV EDI,[EBP+8]   //Ziel
  14214.           MOV ESI,[EBP+12]
  14215.           MOV ECX,8
  14216. !SMinusl:
  14217.           MOV EAX,[ESI+0]
  14218.           NOT EAX
  14219.           AND EAX,[EDI+0]
  14220.           MOV [EDI+0],EAX
  14221.           ADD ESI,4
  14222.           ADD EDI,4
  14223.           LOOP !SMinusl
  14224.  
  14225.           POP EDI
  14226.           POP ESI
  14227.           POP EDX
  14228.           POP ECX
  14229.           POP EBX
  14230.           POP EAX
  14231.  
  14232.           LEAVE
  14233.           RETN32 8
  14234. SYSTEM.SetMinus32 ENDP
  14235.  
  14236.  
  14237. END;
  14238.  
  14239. //************************************************************************
  14240. //
  14241. //
  14242. // Floating point support
  14243. //
  14244. //
  14245. //************************************************************************
  14246.  
  14247. PROCEDURE SetTrigMode(mode:BYTE);
  14248. BEGIN
  14249.      CASE Mode OF
  14250.         Rad:IsNotRad:=FALSE;
  14251.         Deg:
  14252.         BEGIN
  14253.              ToRad:=0.01745329262;
  14254.              FromRad:=57.29577951;
  14255.              IsNotRad:=TRUE;
  14256.         END;
  14257.         Gra:
  14258.         BEGIN
  14259.              ToRad:=0.01570796327;
  14260.              FromRad:=63.66197724;
  14261.              IsNotRad:=TRUE;
  14262.         END;
  14263.      END; {case}
  14264. END;
  14265.  
  14266. CONST
  14267.     C10:LONGWORD=10;
  14268.     FPUControl:WORD=$133f;
  14269.     FPURound:WORD=$1f3f;
  14270.     FPURoundUp:WORD=$1b3f;
  14271.     Exponent:WORD=0;
  14272.     fl1:ARRAY[0..3] OF BYTE=(0,$42,$c0,$ff);
  14273.     fl2:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$fe,$3f); //0.7853...
  14274.     fl3:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$ff,$3f);
  14275.     fl4:ARRAY[0..3] OF BYTE=(0,$4a,$c0,$ff);
  14276.     fl5:ARRAY[0..3] OF BYTE=(0,0,0,$3f);
  14277.     fl6:ARRAY[0..9] OF BYTE=($85,$64,$de,$f9,$33,$f3,4,$b5,$ff,$3f);
  14278.     fl7:ARRAY[0..9] OF BYTE=($48,$7e,$2a,$92,$a2,$da,$0f,$c9,$ff,$3f); //PI/2
  14279.     fl8:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,$fe,$3f);  //0.5
  14280.     fl9:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,0,$40);    //2.0
  14281.     fl10:ARRAY[0..9] OF BYTE=($83,$ab,$4b,$ac,$dd,$8d,$5d,$93,0,$40); //ln(10)
  14282.     fl11:ARRAY[0..9] OF BYTE=($7e,$c0,$68,$77,$0d,$18,$72,$b1,$fe,$3f); //ln(2)
  14283.  
  14284.  
  14285. ASSEMBLER
  14286.  
  14287. SYSTEM.!FormatStr PROC NEAR32  //Format in AL, String in EDI
  14288.         //Format the string
  14289.         CMP AL,0
  14290.         JE !LLw47_1
  14291.  
  14292.         MOV AH,[EDI+0]  //Length of string
  14293.         CMP AH,AL
  14294.         JAE !LLw47_1    //No format to do
  14295.  
  14296.         SUB AL,AH       //Calculate spaces to add
  14297.         ADD [EDI+0],AL  //Set length to new value
  14298.         PUSH EDI
  14299.  
  14300.         MOVZX EBX,AH    //old length of string
  14301.         ADD EDI,EBX     //End of string
  14302.  
  14303.         MOVZX EBX,AL    //Count of spaces to add
  14304.         MOV ESI,EDI
  14305.         ADD EDI,EBX     //add count of spaces
  14306.  
  14307.         MOVZX ECX,AH    //Count (Length of string) to ECX
  14308.         INC ECX         //and #0
  14309.  
  14310.         STD             //From backwards
  14311.         REP
  14312.         MOVSB
  14313.  
  14314.         MOV ECX,EBX
  14315.         MOV AL,32       //Space
  14316.  
  14317.         POP EDI         //Pop it
  14318.         PUSH EDI
  14319.         INC EDI
  14320.         CLD
  14321.         REP
  14322.         STOSB
  14323.  
  14324.         POP EDI
  14325.         MOVZXB EAX,[EDI+0]
  14326.         INC EDI
  14327.         ADD EDI,EAX
  14328.         CLD
  14329. !LLw47_1:
  14330.         RETN32
  14331. SYSTEM.!FormatStr ENDP
  14332.  
  14333. SYSTEM.!RadArc PROC NEAR32      //Converts ST(0) to Rad
  14334.        CMPB SYSTEM.IsNotRad,1
  14335.        JNE !!!_l80
  14336.        FLDT SYSTEM.ToRad
  14337.        FMULP ST(1),ST
  14338. !!!_l80:
  14339.        RETN32
  14340. SYSTEM.!RadArc ENDP
  14341.  
  14342. SYSTEM.!NormRad PROC NEAR32     //Converts ST(0) to actual TrigMode
  14343.        CMPB SYSTEM.IsNotRad,1
  14344.        JNE !!!_l81
  14345.        FLDT SYSTEM.FromRad
  14346.        FMULP ST(1),ST
  14347. !!!_l81:
  14348.        RETN32
  14349. SYSTEM.!NormRad ENDP
  14350.  
  14351.  
  14352. SYSTEM.!Calculate PROC NEAR32
  14353. //Input EDI String
  14354. //CX Count
  14355. //Output Value in ST(0)
  14356.          PUSH EBP
  14357.          MOV EBP,ESP
  14358.          SUB ESP,4
  14359.          DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  14360. !!!weiter1:
  14361.          MOV AL,[EDI+0]
  14362.          SUB AL,$3a
  14363.          ADD AL,$0a
  14364.          JNB !!!ex
  14365.          XOR AH,AH
  14366.          MOV [EBP-2],AX
  14367.          FILDD SYSTEM.C10
  14368.          FMULP ST(1),ST
  14369.          FILDW [EBP-2]
  14370.          FADDP ST(1),ST
  14371.          FWAIT
  14372.          INC EDI
  14373.          DEC CX
  14374.          CMP CX,0
  14375.          JE !!!ex
  14376.          JMP !!!weiter1
  14377. !!!ex:
  14378.          LEAVE
  14379.          RETN32
  14380. SYSTEM.!Calculate ENDP
  14381.  
  14382. SYSTEM.!DivTab PROC NEAR32
  14383.         dw 0,0,0,32768,16383,0,0,0             //1
  14384.         dw 0,0,0,40960,16386,0,0,0             //10
  14385.         dw 0,0,0,51200,16389,0,0,0             //100
  14386.         dw 0,0,0,64000,16392,0,0,0             //1000
  14387.         dw 0,0,0,40000,16396,0,0,0             //10^4
  14388.         dw 0,0,0,50000,16399,0,0,0             //10^5
  14389.         dw 0,0,0,62500,16402,0,0,0             //10^6
  14390.         dw 0,0,32768,39062,16406,0,0,0         //10^7
  14391.         dw 0,0,8192,48828,16409,0,0,0          //10^8
  14392. SYSTEM.!DivTab ENDP
  14393.  
  14394. SYSTEM.!Power10Tab PROC NEAR32
  14395.            db 0,0,0,0,0,$20,$bc,$be,$19,$40                  //1.0E+8
  14396.            db 0,0,0,4,$bf,$c9,$1b,$8e,$34,$40                //1.0E+16
  14397.            db $9e,$b5,$70,$2b,$a8,$ad,$c5,$9d,$69,$40        //1.0E+32
  14398.            db $d5,$a6,$cf,$0ff,$49,$1f,$78,$c2,$d3,$40       //1.0E+64
  14399.            db $e0,$8c,$e9,$80,$c9,$47,$ba,$93,$a8,$41        //1.0E+128
  14400.            db $8e,$de,$0f9,$9d,$fb,$eb,$7e,$aa,$51,$43       //1.0E+256
  14401.            db $c7,$91,$0e,$a6,$ae,$a0,$19,$e3,$a3,$46        //1.0E+512
  14402.            db $17,$0c,$75,$81,$86,$75,$76,$c9,$48,$4d        //1.0E+1024
  14403.            db $e5,$5d,$3d,$c5,$5d,$3b,$8b,$9e,$92,$5a        //1.0E+2048
  14404.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  14405. SYSTEM.!Power10Tab ENDP
  14406.  
  14407. SYSTEM.!MaxMulTab PROC NEAR32
  14408.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  14409. SYSTEM.!MaxMulTab ENDP
  14410.  
  14411. SYSTEM.!DivMul10 PROC NEAR32
  14412. //Input: BX Count of divides/mult by 10
  14413. //       AL 0-mult 1-divide
  14414.         MOV CX,BX
  14415.         AND CX,7  //31 only values 0..31
  14416.         MOV ESI,@SYSTEM.!DivTab
  14417.         MOVZX ECX,CX
  14418.         SHL ECX,1
  14419.         SHL ECX,1
  14420.         SHL ECX,1
  14421.         SHL ECX,1
  14422.         ADD ESI,ECX
  14423.         FLDT [ESI+0]   //1..10^32 laden
  14424.         SHR BX,1
  14425.         SHR BX,1
  14426.         SHR BX,1                //divide numbers by 8
  14427.         MOV ESI,@SYSTEM.!Power10Tab
  14428.         CMP BX,0
  14429.         JE !!!process
  14430. !!!Power10:
  14431.         SHR BX,1
  14432.         JNB !!!mm            //until a bit is set
  14433.         FLDT [ESI+0]
  14434.         FMULP ST(1),ST
  14435. !!!mm:
  14436.         ADD ESI,10
  14437.         CMP BX,0
  14438.         JNE !!!Power10
  14439. !!!process:
  14440.         CMP AL,1
  14441.         JNE !!!_mul
  14442.         FDIVRP ST(1),ST
  14443.         RETN32
  14444. !!!_mul:
  14445.         FMULP ST(1),ST
  14446.         RETN32
  14447. SYSTEM.!DivMul10 ENDP
  14448.  
  14449. SYSTEM.!Str2Float PROC NEAR32
  14450. //Input EDI  String to convert
  14451. //      CX     Length of this string
  14452. //Output Floating point value in ST(0)
  14453.         PUSH EBP
  14454.         MOV EBP,ESP
  14455.         SUB ESP,6                //for Control word and sign
  14456.         DB $89,$04,$24           //Perform stack probe MOV [ESP],EAX
  14457.  
  14458.         MOVW SYSTEM.FPUResult,0
  14459.         FSTCW [EBP-2]            //Store control word
  14460.         FWAIT
  14461.         FCLEX                    //Clear exceptions
  14462.         FLDCW SYSTEM.FPUControl  //Load control word
  14463.         FWAIT
  14464.         FLDZ                     //Load +0.0
  14465.         MOVB [EBP-4],0           //sign is positive
  14466.         MOVW [EBP-6],0           //count of numbers after point
  14467. !!!again:
  14468.         CMP CX,0                 //String has zero length ?
  14469.         JE !!!Error
  14470.  
  14471.         MOV AL,[EDI+0]        //load character
  14472.         CMP AL,43  //'+'
  14473.         JNE !!!not_plus
  14474.         //Sign '+' was detected
  14475.         INC EDI
  14476.         DEC CX
  14477.         CMP CX,0
  14478.         JE !!!Error
  14479.         JMP !!!weiter
  14480. !!!not_plus:
  14481.         CMP AL,45   //'-'
  14482.         JNE !!!not_minus
  14483.         //Sign '-' was detected
  14484.         MOVB [EBP-4],1 //Sign is negative
  14485.         INC EDI
  14486.         DEC CX
  14487.         CMP CX,0
  14488.         JE !!!Error
  14489.         JMP !!!weiter
  14490. !!!not_minus:
  14491.         CMP AL,32
  14492.         JNE !!!weiter
  14493.         INC EDI
  14494.         DEC CX
  14495.         JMP !!!again
  14496. !!!weiter:
  14497.         CALLN32 SYSTEM.!Calculate   //Calculate numbers before point
  14498.         CMP CX,0
  14499.         JNE !!!a_exp
  14500.         CMPB [EBP-4],1
  14501.         JNE !!!no_exp
  14502.         FCHS
  14503.         FWAIT         //change sign
  14504.         JMP !!!no_exp
  14505. !!!a_exp:
  14506.         //Look for .
  14507.         MOV AL,[EDI+0]
  14508.         CMP AL,'.'
  14509.         JNE !!!Change
  14510.         DEC CX
  14511.         CMP CX,0
  14512.         JE !!!Change
  14513.         INC EDI
  14514.         PUSH CX
  14515.         CALLN32 SYSTEM.!Calculate    //Calculate numbers after point
  14516.         POP BX
  14517.         SUB BX,CX
  14518.         MOV [EBP-6],BX               //Count of numbers after point
  14519. !!!Change:
  14520.         //in ST(0) is now an integer value
  14521.         //[EBP-6] contains the current numbers after the point
  14522.         CMPB [EBP-4],1
  14523.         JNE !!!not_neg
  14524.         FCHS
  14525.         FWAIT         //change sign
  14526. !!!not_neg:
  14527.         //Check for exponent
  14528.         CMP CX,0
  14529.         JE !!!no_exp
  14530.         MOV AL,[EDI+0]
  14531.         CMP AL,'e'
  14532.         JE !!!exp
  14533.         CMP AL,'E'
  14534.         JNE !!!no_exp
  14535. !!!exp:
  14536.         //an exponent was detected
  14537.         INC EDI
  14538.         DEC CX
  14539.         CMP CX,0
  14540.         JE !!!Error
  14541.         FLDZ          //Load +0.0
  14542.         MOVB [EBP-4],0    //sign is positive
  14543.         MOV AL,[EDI+0]
  14544.         CMP AL,'-'
  14545.         JNE !!!no_minus
  14546.         MOVB [EBP-4],1   //sign is negative
  14547.         INC EDI
  14548.         DEC CX
  14549.         CMP CX,0
  14550.         JE !!!Error
  14551.         JMP !!!Calc
  14552. !!!no_minus:
  14553.         CMP AL,43   //'+'
  14554.         JNE !!!calc
  14555.         INC EDI
  14556.         DEC CX
  14557.         CMP CX,0
  14558.         JE !!!Error
  14559. !!!calc:
  14560.         CALLN32 SYSTEM.!Calculate
  14561.         FISTPW SYSTEM.Exponent      //Store integer value and pop
  14562.         MOV BX,SYSTEM.Exponent
  14563.         MOV AL,0                    //Mult
  14564.         CMPB [EBP-4],1
  14565.         JNE !!!make
  14566.         MOV AL,1                    //Divide if Exponent negative
  14567. !!!make:
  14568.         PUSH CX
  14569.         CALLN32 SYSTEM.!DivMul10
  14570.         POP CX
  14571. !!!no_exp:
  14572.         CMP CX,0
  14573.         JNE !!!Error                //invalid chars
  14574.         MOV BX,[EBP-6]
  14575.         MOV AL,1                    //Divide
  14576.         CALLN32 SYSTEM.!DivMul10
  14577.         JMP !!!ok
  14578. !!!Error:
  14579.         MOVW SYSTEM.InOutRes,1      //FPU error
  14580.         MOVW SYSTEM.FPUResult,1     //FPU error
  14581. !!!ok:
  14582.         LEAVE
  14583.         RETN32
  14584. SYSTEM.!Str2Float ENDP
  14585.  
  14586. SYSTEM.!Str2Real PROC NEAR32
  14587.        PUSH EBP
  14588.        MOV EBP,ESP
  14589.  
  14590.        PUSH EAX
  14591.        PUSH EBX
  14592.        PUSH ECX
  14593.        PUSH EDX
  14594.        PUSH EDI
  14595.        PUSH ESI
  14596.  
  14597.        MOV EDI,[EBP+16]
  14598.        MOV CL,[EDI+0]
  14599.        INC EDI
  14600.        XOR CH,CH
  14601.        CALLN32 SYSTEM.!Str2Float
  14602.        MOV EDI,[EBP+12]
  14603.        FSTPD [EDI+0]
  14604.  
  14605.        MOV EDI,[EBP+8]      //Result
  14606.        MOVW [EDI+0],0
  14607.        CMPW SYSTEM.FPUResult,0
  14608.        JE !!__fex1
  14609.        MOV ESI,[EBP+16]
  14610.        MOVZXB AX,[ESI+0]
  14611.        INC AX
  14612.        SUB AX,CX
  14613.        MOV [EDI+0],AX
  14614.        MOV EDI,[EBP+12]
  14615.        FLDZ
  14616.        FSTPD [EDI+0]
  14617. !!__fex1:
  14618.        POP ESI
  14619.        POP EDI
  14620.        POP EDX
  14621.        POP ECX
  14622.        POP EBX
  14623.        POP EAX
  14624.  
  14625.        LEAVE
  14626.        RETN32 12
  14627. SYSTEM.!Str2Real ENDP
  14628.  
  14629. SYSTEM.!Str2Double PROC NEAR32
  14630.        PUSH EBP
  14631.        MOV EBP,ESP
  14632.  
  14633.        PUSH EAX
  14634.        PUSH EBX
  14635.        PUSH ECX
  14636.        PUSH EDX
  14637.        PUSH EDI
  14638.        PUSH ESI
  14639.  
  14640.        MOV EDI,[EBP+16]
  14641.        MOV CL,[EDI+0]
  14642.        INC EDI
  14643.        XOR CH,CH
  14644.        CALLN32 SYSTEM.!Str2Float
  14645.        MOV EDI,[EBP+12]
  14646.        FSTPQ [EDI+0]
  14647.  
  14648.        MOV EDI,[EBP+8]     //Result
  14649.        MOVW [EDI+0],0
  14650.        CMPW SYSTEM.FPUResult,0
  14651.        JE !!__fex11
  14652.        MOV ESI,[EBP+16]
  14653.        MOVZXB AX,[ESI+0]
  14654.        INC AX
  14655.        SUB AX,CX
  14656.        MOV [EDI+0],AX
  14657.        MOV EDI,[EBP+12]
  14658.        FLDZ
  14659.        FSTPQ [EDI+0]
  14660. !!__fex11:
  14661.        POP ESI
  14662.        POP EDI
  14663.        POP EDX
  14664.        POP ECX
  14665.        POP EBX
  14666.        POP EAX
  14667.  
  14668.        LEAVE
  14669.        RETN32 12
  14670. SYSTEM.!Str2Double ENDP
  14671.  
  14672. SYSTEM.!Str2Comp PROC NEAR32
  14673.        PUSH EBP
  14674.        MOV EBP,ESP
  14675.  
  14676.        PUSH EAX
  14677.        PUSH EBX
  14678.        PUSH ECX
  14679.        PUSH EDX
  14680.        PUSH EDI
  14681.        PUSH ESI
  14682.  
  14683.        MOV EDI,[EBP+16]
  14684.        MOV CL,[EDI+0]
  14685.        INC EDI
  14686.        XOR CH,CH
  14687.        CALLN32 SYSTEM.!Str2Float
  14688.        MOV EDI,[EBP+12]
  14689.        FISTP QWORD PTR [EDI+0]
  14690.  
  14691.        MOV EDI,[EBP+8]     //Result
  14692.        MOVW [EDI+0],0
  14693.        CMPW SYSTEM.FPUResult,0
  14694.        JE !!__fex11_c
  14695.        MOV ESI,[EBP+16]
  14696.        MOVZXB AX,[ESI+0]
  14697.        INC AX
  14698.        SUB AX,CX
  14699.        MOV [EDI+0],AX
  14700.        MOV EDI,[EBP+12]
  14701.        FLDZ
  14702.        FISTP QWORD PTR [EDI+0]
  14703. !!__fex11_c:
  14704.        POP ESI
  14705.        POP EDI
  14706.        POP EDX
  14707.        POP ECX
  14708.        POP EBX
  14709.        POP EAX
  14710.  
  14711.        LEAVE
  14712.        RETN32 12
  14713. SYSTEM.!Str2Comp ENDP
  14714.  
  14715. SYSTEM.!Str2Currency PROC NEAR32
  14716.        PUSH EBP
  14717.        MOV EBP,ESP
  14718.  
  14719.        PUSH EAX
  14720.        PUSH EBX
  14721.        PUSH ECX
  14722.        PUSH EDX
  14723.        PUSH EDI
  14724.        PUSH ESI
  14725.  
  14726.        MOV EDI,[EBP+16]
  14727.        MOV CL,[EDI+0]
  14728.        INC EDI
  14729.        XOR CH,CH
  14730.        CALLN32 SYSTEM.!Str2Float
  14731.        MOV EDI,[EBP+12]
  14732.        FLDT SYSTEM.ToCurrency   //*10000
  14733.        FMULP ST(1),ST
  14734.        FRNDINT
  14735.        FISTP QWORD PTR [EDI+0]
  14736.  
  14737.        MOV EDI,[EBP+8]     //Result
  14738.        MOVW [EDI+0],0
  14739.        CMPW SYSTEM.FPUResult,0
  14740.        JE !!__fex11_c
  14741.        MOV ESI,[EBP+16]
  14742.        MOVZXB AX,[ESI+0]
  14743.        INC AX
  14744.        SUB AX,CX
  14745.        MOV [EDI+0],AX
  14746.        MOV EDI,[EBP+12]
  14747.        FLDZ
  14748.        FISTP QWORD PTR [EDI+0]
  14749. !!__fex11_c:
  14750.        POP ESI
  14751.        POP EDI
  14752.        POP EDX
  14753.        POP ECX
  14754.        POP EBX
  14755.        POP EAX
  14756.  
  14757.        LEAVE
  14758.        RETN32 12
  14759. SYSTEM.!Str2Currency ENDP
  14760.  
  14761.  
  14762. SYSTEM.!Str2Extended PROC NEAR32
  14763.        PUSH EBP
  14764.        MOV EBP,ESP
  14765.  
  14766.        PUSH EAX
  14767.        PUSH EBX
  14768.        PUSH ECX
  14769.        PUSH EDX
  14770.        PUSH EDI
  14771.        PUSH ESI
  14772.  
  14773.        MOV EDI,[EBP+16]
  14774.        MOV CL,[EDI+0]
  14775.        INC EDI
  14776.        XOR CH,CH
  14777.        CALLN32 SYSTEM.!Str2FLoat
  14778.        MOV EDI,[EBP+12]
  14779.        FSTPT [EDI+0]
  14780.  
  14781.        MOV EDI,[EBP+8]   //Result
  14782.        MOVW [EDI+0],0
  14783.        CMPW SYSTEM.FPUResult,0
  14784.        JE !!__fex111
  14785.        MOV ESI,[EBP+16]
  14786.        MOVZXB AX,[ESI+0]
  14787.        INC AX
  14788.        SUB AX,CX
  14789.        MOV [EDI+0],AX
  14790.        MOV EDI,[EBP+12]
  14791.        FLDZ
  14792.        FSTPT [EDI+0]
  14793. !!__fex111:
  14794.        POP ESI
  14795.        POP EDI
  14796.        POP EDX
  14797.        POP ECX
  14798.        POP EBX
  14799.        POP EAX
  14800.  
  14801.        LEAVE
  14802.        RETN32 12
  14803. SYSTEM.!Str2Extended ENDP
  14804.  
  14805. SYSTEM.!ValReal PROC NEAR32
  14806.         //Input EDI : Destination String
  14807.         //AX Kommastellen
  14808.         //BX Len oder 17h
  14809.         //Floatvalue in ST(0)
  14810.         PUSH EBP
  14811.         MOV EBP,ESP
  14812.         SUB ESP,264
  14813.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  14814.  
  14815.         MOV [EBP-260],AX  //Comma
  14816.         CMP BX,0
  14817.         JA !!6666
  14818.         MOV BX,1
  14819. !!6666:
  14820.         CMP BX,254    //$17
  14821.         JB !!6666_1
  14822.         MOV BX,$17
  14823. !!6666_1:
  14824.         MOV [EBP-258],BX  //Len
  14825.         MOV [EBP-264],EDI //s
  14826.  
  14827.         MOV CX,[EBP-260]  //Comma
  14828.         OR CX,CX
  14829.         JNS !!37ea
  14830.         MOV CX,8
  14831.         SUB CX,[EBP-258]  //Len
  14832.         CMP CX,$0FFFE
  14833.         JLE !!37ea
  14834.         MOV CX,$0FFFE
  14835. !!37ea:
  14836.         LEA EDI,[EBP-256] //result
  14837.         CALLN32 SYSTEM.!Real2Str1  //Get string in EDI and length in CX
  14838.  
  14839.         MOV ESI,EDI
  14840.         MOV EDI,[EBP-264]  //s
  14841.         MOV DX,255
  14842.         MOV AX,[EBP-258]   //Len
  14843.         CMP AX,CX
  14844.         JNL !!3812
  14845.         MOV AX,CX
  14846. !!3812:
  14847.         CLD
  14848.         STOSB
  14849.         SUB AX,CX
  14850.         JE !!3820
  14851.         PUSH CX
  14852.         MOVZX ECX,AX
  14853.         MOV AL,$20
  14854.         REP
  14855.         STOSB
  14856.         POP CX
  14857. !!3820:
  14858.         MOVZX ECX,CX
  14859.         REP
  14860.         MOVSB
  14861.  
  14862.         LEAVE
  14863.         RETN32
  14864. SYSTEM.!ValReal ENDP
  14865.  
  14866. SYSTEM.!!!!!Help1 PROC NEAR32
  14867.         FWAIT
  14868.         FSTCW [EBP-2]
  14869.         FWAIT
  14870.         FCLEX
  14871.         FLDCW SYSTEM.FpuControl
  14872.         FWAIT
  14873.         FSTPT [EBP-$14]
  14874.  
  14875.         XOR EDX,EDX
  14876.         CMP CX,$12
  14877.         JLE !!311a
  14878.         MOV CX,$12
  14879. !!311a:
  14880.         CMP CX,$0FFEE
  14881.         JNL !!3122
  14882.         MOV CX,$0FFEE
  14883. !!3122:
  14884.         RETN32
  14885. SYSTEM.!!!!!Help1 ENDP
  14886.  
  14887. SYSTEM.!!!!!Help2 PROC NEAR32
  14888.         MOV [EBP-$0c],AX
  14889.         FLDT [EBP-$14]
  14890.         SUB AX,$3FFF
  14891.         XOR EDX,EDX
  14892.         MOV DX,$4D10
  14893.         IMUL DX
  14894.         MOV [EBP-8],DX
  14895.         MOV AX,$11
  14896.         SUB AX,DX
  14897.         CALLN32 SYSTEM.!Div_Mul10
  14898.         FRNDINT
  14899.         MOV ESI,*Tabx1
  14900.         FLDT [ESI+0]
  14901.         FCOMP ST(1)
  14902.         FSTSW [EBP-4]
  14903.         FWAIT
  14904.         RETN32
  14905. Tabx1:
  14906.      db 0,0,$40,$76,$3a,$6b,$0b,$de,$3a,$40
  14907. SYSTEM.!!!!!Help2 ENDP
  14908.  
  14909. SYSTEM.!!!!!Help3 PROC NEAR32
  14910.         MOV AL,$45
  14911.         STOSB
  14912.         MOV AL,$2b
  14913.         MOV DX,[EBP-8]
  14914.         OR DX,DX
  14915.         JNS !!3280
  14916.         MOV AL,$2d
  14917.         NEG DX
  14918. !!3280:
  14919.         STOSB
  14920.         MOV EAX,$640a
  14921.         XCHG DX,AX
  14922.         DIV DH
  14923.         MOV DH,AH
  14924.         DB $66
  14925.         CBW
  14926.         DIV DL
  14927.         ADD AX,$3030
  14928.         STOSW
  14929.         MOV AL,DH
  14930.         DB $66
  14931.         CBW
  14932.         DIV DL
  14933.         ADD AX,$3030
  14934.         STOSW
  14935.         RETN32
  14936. SYSTEM.!!!!!Help3 ENDP
  14937.  
  14938. SYSTEM.!Real2Str1 PROC NEAR32
  14939.         PUSH EBP
  14940.         MOV EBP,ESP
  14941.         SUB ESP,$28
  14942.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  14943.  
  14944.         PUSH EDI
  14945.         CALLN32 SYSTEM.!!!!!Help1
  14946.  
  14947.         CLD
  14948.         NOP
  14949.         FWAIT
  14950.         MOV [EBP-6],CX
  14951.         MOV AX,[EBP-$0c]
  14952.         MOV [EBP-$0a],AX
  14953.         AND AX,$7FFF
  14954.         JE !!315c
  14955.         CMP AX,$7FFF
  14956.         JNE !!3165
  14957.         CMPW [EBP-$0e],$8000
  14958.         JE !!3149
  14959.         MOV AX,$414e
  14960.         STOSW
  14961.         MOV AL,$4e
  14962.         STOSB
  14963.         JMP !!3299
  14964. !!3149:
  14965.         CMPW [EBP-$0a],0
  14966.         JNS !!3152
  14967.         MOV AL,$2d
  14968.         STOSB
  14969. !!3152:
  14970.         MOV AX,$4e49
  14971.         STOSW
  14972.         MOV AL,$46
  14973.         STOSB
  14974.         JMP !!3299
  14975. !!315c:
  14976.         MOV [EBP-8],AX
  14977.         MOV [EBP-$28],AL
  14978.         JMP !!3216
  14979. !!3165:
  14980.         CALLN32 SYSTEM.!!!!!Help2
  14981.         TESTW [EBP-4],$4100
  14982.         JE !!31a1
  14983.         INCW [EBP-8]
  14984.         FILDD SYSTEM.C10
  14985.         FDIVRP ST(1),ST
  14986. !!31a1:
  14987.         PUSH EBP
  14988.         POP ESI
  14989.         FBSTPT [ESI-$14]
  14990.         MOV ESI,9
  14991.         LEA EBX,[EBP-$28]
  14992.         MOV CL,4
  14993.         FWAIT
  14994. !!31af:
  14995.         PUSH EDI
  14996.         LEA EDI,[EBP-$15]
  14997.         ADD EDI,ESI
  14998.         MOV AL,[EDI+0]
  14999.         POP EDI
  15000.         MOV AH,AL
  15001.         SHR AL,CL
  15002.         AND AH,$0F
  15003.         ADD AX,$3030
  15004.         MOV [EBX+0],AX
  15005.         ADD EBX,2
  15006.         DEC ESI
  15007.         JNE !!31af
  15008.  
  15009.         MOV [EBX+0],SI
  15010.         CMPW [EBP-6],0
  15011.         JL !!31d8
  15012.         CMPW [EBP-8],$24
  15013.         JL !!31d8
  15014.         MOVW [EBP-6],$0FFEE
  15015. !!31d8:
  15016.         MOV SI,[EBP-6]
  15017.         OR SI,SI
  15018.         JS !!31eb
  15019.         ADD SI,[EBP-8]
  15020.         INC SI
  15021.         JNS !!31ed
  15022.         MOVB [EBP-$28],0
  15023.         JMP !!3216
  15024. !!31eb:
  15025.         NEG SI
  15026. !!31ed:
  15027.         CMP SI,$12
  15028.         JNB !!3216
  15029.  
  15030.         MOVZX ESI,SI
  15031.         PUSH EDI
  15032.         LEA EDI,[EBP-$28]
  15033.         ADD EDI,ESI
  15034.         CMPB [EDI+0],$35
  15035.         MOVB [EDI+0],0
  15036.         POP EDI
  15037.         JB !!3216
  15038. !!31fc:
  15039.         DEC SI
  15040.         JS !!320e
  15041.         MOVZX ESI,SI
  15042.         PUSH EDI
  15043.         LEA EDI,[EBP-$28]
  15044.         ADD EDI,ESI
  15045.         INCB [EDI+0]
  15046.         CMPB [EDI+0],$39
  15047.         POP EDI
  15048.         JBE !!3216
  15049.  
  15050.         PUSH EDI
  15051.         LEA EDI,[EBP-$28]
  15052.         ADD EDI,ESI
  15053.         MOVB [EDI+0],0
  15054.         POP EDI
  15055.         JMP !!31fc
  15056. !!320e:
  15057.         INCW [EBP-8]
  15058.         MOVW [EBP-$28],$31
  15059. !!3216:
  15060.         XOR ESI,ESI
  15061.         MOV DX,[EBP-6]
  15062.         OR DX,DX
  15063.         JS !!3254
  15064.         CMPW [EBP-$0a],0
  15065.         JNS !!3228
  15066.         MOV AL,$2d
  15067.         STOSB
  15068. !!3228:
  15069.         MOV CX,[EBP-8]
  15070.         OR CX,CX
  15071.         JNS !!3234
  15072.         MOV AL,$30
  15073.         STOSB
  15074.         JMP !!323b
  15075. !!3234:
  15076.         PUSH EDI
  15077.         MOVZX ESI,SI
  15078.         LEA EDI,[EBP-$28]
  15079.         ADD EDI,ESI
  15080.         MOV AL,[EDI+0]
  15081.         INC SI
  15082.         POP EDI
  15083.         OR AL,AL
  15084.         JNE !!32b6
  15085.         MOV AL,$30
  15086.         DEC SI
  15087. !!32b6:
  15088.         STOSB
  15089.         DEC CX
  15090.         JNS !!3234
  15091. !!323b:
  15092.         OR DX,DX
  15093.         JE !!3299
  15094.         MOV AL,$2e
  15095.         STOSB
  15096. !!3242:
  15097.         INC CX
  15098.         JE !!324b
  15099. !!3245:
  15100.         MOV AL,$30
  15101.         STOSB
  15102.         DEC DX
  15103.         JNE !!3242
  15104. !!324b:
  15105.         DEC DX
  15106.         JS !!3299
  15107.         PUSH EDI
  15108.         MOVZX ESI,SI
  15109.         LEA EDI,[EBP-$28]
  15110.         ADD EDI,ESI
  15111.         MOV AL,[EDI+0]
  15112.         INC SI
  15113.         POP EDI
  15114.         OR AL,AL
  15115.         JNE !!32b6_1a
  15116.         MOV AL,$30
  15117.         DEC SI
  15118. !!32b6_1a:
  15119.         STOSB
  15120.         JMP !!324b
  15121. !!3254:
  15122.         MOV AL,$20
  15123.         CMPW [EBP-$0a],0
  15124.         JNS !!325e
  15125.         MOV AL,$2d
  15126. !!325e:
  15127.         STOSB
  15128.         PUSH EDI
  15129.         MOVZX ESI,SI
  15130.         LEA EDI,[EBP-$28]
  15131.         ADD EDI,ESI
  15132.         INC SI
  15133.         MOV AL,[EDI+0]
  15134.         POP EDI
  15135.         OR AL,AL
  15136.         JNE !!32b6_1b
  15137.         MOV AL,$30
  15138.         DEC SI
  15139. !!32b6_1b:
  15140.         STOSB
  15141.         INC DX
  15142.         JE !!3270
  15143.         MOV AL,$2e
  15144.         STOSB
  15145. !!3269:
  15146.         PUSH EDI
  15147.         MOVZX ESI,SI
  15148.         LEA EDI,[EBP-$28]
  15149.         ADD EDI,ESI
  15150.         INC SI
  15151.         MOV AL,[EDI+0]
  15152.         POP EDI
  15153.         OR AL,AL
  15154.         JNE !!32b6_1c
  15155.         MOV AL,$30
  15156.         DEC SI
  15157. !!32b6_1c:
  15158.         STOSB
  15159.         INC DX
  15160.         JNE !!3269
  15161. !!3270:
  15162.         CALLN32 SYSTEM.!!!!!Help3
  15163. !!3299:
  15164.         MOV ECX,EDI
  15165.         POP EDI
  15166.         SUB ECX,EDI
  15167.         FCLEX            //Clear Exceptions
  15168.         FLDCW [EBP-2]
  15169.         FWAIT
  15170.  
  15171.         LEAVE
  15172.         RETN32
  15173. {*Tab1:
  15174.      db 0,0,40h,76h,3ah,6bh,0bh,deh,3ah,40h}
  15175. SYSTEM.!Real2Str1 ENDP
  15176.  
  15177.  
  15178. SYSTEM.!Div_Mul10 PROC NEAR32
  15179.         CMP AX,$1000
  15180.         JLE !!3382
  15181.         PUSH ESI
  15182.         MOV ESI,@SYSTEM.!MaxMulTab
  15183.         FLDT [ESI+0]
  15184.         POP ESI
  15185.         FMULP ST(1),ST
  15186.         SUB AX,$1000
  15187. !!3382:
  15188.         CMP AX,$0F000
  15189.         JNL !!3393
  15190.         PUSH ESI
  15191.         MOV ESI,@SYSTEM.!MaxMulTab
  15192.         FLDT [ESI+0]
  15193.         POP ESI
  15194.         FDIVRP ST(1),ST
  15195.         ADD AX,$1000
  15196. !!3393:
  15197.         MOV BX,AX
  15198.         OR AX,AX
  15199.         JE !!33d4
  15200.         JNS !!339d
  15201.         NEG AX
  15202. !!339d:
  15203.         MOV SI,AX
  15204.         AND SI,7
  15205.         MOVZX ESI,SI
  15206.         SHL ESI,1
  15207.         SHL ESI,1
  15208.         SHL ESI,1
  15209.         SHL ESI,1
  15210.         PUSH EDI
  15211.         MOV EDI,@SYSTEM.!DivTab
  15212.         ADD EDI,ESI
  15213.         FLDT [EDI+0]
  15214.         POP EDI
  15215.         SHR AX,1
  15216.         SHR AX,1
  15217.         SHR AX,1
  15218.         MOV ESI,@SYSTEM.!Power10Tab
  15219.         JMP !!33c5
  15220. !!33b7:
  15221.         SHR AX,1
  15222.         JNB !!33c2
  15223.         FLDT [ESI+0]
  15224.         FMULP ST(1),ST
  15225. !!33c2:
  15226.         ADD ESI,10
  15227. !!33c5:
  15228.         OR AX,AX
  15229.         JNE !!33b7
  15230.         OR BX,BX
  15231.         JS !!33d1
  15232.         FMULP ST(1),ST
  15233. !!33d0:
  15234.         RETN32
  15235. !!33d1:
  15236.         FDIVRP ST(1),ST
  15237. !!33d4:
  15238.         RETN32
  15239. SYSTEM.!Div_Mul10 ENDP
  15240.  
  15241.  
  15242. SYSTEM.!Real2Str PROC NEAR32  //Format in [EBP+16]
  15243.         PUSH EBP
  15244.         MOV EBP,ESP
  15245.  
  15246.         PUSH EDI
  15247.         PUSH ESI
  15248.         PUSH EDX
  15249.         PUSH ECX
  15250.         PUSH EBX
  15251.         PUSH EAX
  15252.  
  15253.         MOV EDI,[EBP+12]
  15254.         FLDD [EDI+0]        //Load real value
  15255.         MOV EDI,[EBP+8]
  15256.         MOV EAX,[EBP+16]    //Nachkommastellen  (FFFFh alle)
  15257.         MOVZXB EBX,[EBP+20] //Format value
  15258.         CALLN32 SYSTEM.!ValReal
  15259.  
  15260.         MOV AL,[EBP+20]    //Format value
  15261.         MOV EDI,[EBP+8]
  15262.         CALLN32 SYSTEM.!FormatStr
  15263.  
  15264.         POP EAX
  15265.         POP EBX
  15266.         POP ECX
  15267.         POP EDX
  15268.         POP ESI
  15269.         POP EDI
  15270.  
  15271.         LEAVE
  15272.         RETN32 16
  15273. SYSTEM.!Real2Str ENDP
  15274.  
  15275. SYSTEM.!Double2Str PROC NEAR32  //Format in [EBP+16]
  15276.         PUSH EBP
  15277.         MOV EBP,ESP
  15278.  
  15279.         PUSH EDI
  15280.         PUSH ESI
  15281.         PUSH EDX
  15282.         PUSH ECX
  15283.         PUSH EBX
  15284.         PUSH EAX
  15285.  
  15286.         MOV EDI,[EBP+12]
  15287.         FLDQ [EDI+0]        //Load double value
  15288.         MOV EDI,[EBP+8]
  15289.         MOV EAX,[EBP+16]    //Nachkommastellen (FFFFh alle)
  15290.         MOV EBX,[EBP+20]    //Format value
  15291.         CALLN32 SYSTEM.!ValReal
  15292.  
  15293.         MOV AL,[EBP+20]     //Format value
  15294.         MOV EDI,[EBP+8]
  15295.         CALLN32 SYSTEM.!FormatStr
  15296.  
  15297.         POP EAX
  15298.         POP EBX
  15299.         POP ECX
  15300.         POP EDX
  15301.         POP ESI
  15302.         POP EDI
  15303.  
  15304.         LEAVE
  15305.         RETN32 16
  15306. SYSTEM.!Double2Str ENDP
  15307.  
  15308. SYSTEM.!Comp2Str PROC NEAR32  //Format in [EBP+16]
  15309.         PUSH EBP
  15310.         MOV EBP,ESP
  15311.  
  15312.         PUSH EDI
  15313.         PUSH ESI
  15314.         PUSH EDX
  15315.         PUSH ECX
  15316.         PUSH EBX
  15317.         PUSH EAX
  15318.  
  15319.         MOV EBX,[EBP+20]
  15320.         CMP EBX,23
  15321.         JNE !not_23
  15322.         MOVD [EBP+20],1
  15323. !not_23:
  15324.         MOV EDI,[EBP+12]
  15325.         FILD QWORD PTR [EDI+0]        //Load comp value
  15326.         MOV EDI,[EBP+8]
  15327.         MOV EAX,0                     //keine Nachkommas
  15328.         MOV EBX,[EBP+20]              //Format value
  15329.         CALLN32 SYSTEM.!ValReal
  15330.  
  15331.         MOV AL,[EBP+20]              //Format value
  15332.         MOV EDI,[EBP+8]
  15333.         CALLN32 SYSTEM.!FormatStr
  15334.  
  15335.         POP EAX
  15336.         POP EBX
  15337.         POP ECX
  15338.         POP EDX
  15339.         POP ESI
  15340.         POP EDI
  15341.  
  15342.         LEAVE
  15343.         RETN32 16
  15344. SYSTEM.!Comp2Str ENDP
  15345.  
  15346. SYSTEM.!Currency2Str PROC NEAR32  //Format in [EBP+16]
  15347.         PUSH EBP
  15348.         MOV EBP,ESP
  15349.  
  15350.         PUSH EDI
  15351.         PUSH ESI
  15352.         PUSH EDX
  15353.         PUSH ECX
  15354.         PUSH EBX
  15355.         PUSH EAX
  15356.  
  15357.         MOV EBX,[EBP+20]
  15358.         CMP EBX,23
  15359.         JNE !not_23
  15360.         MOVD [EBP+20],1
  15361. !not_23:
  15362.         MOV EDI,[EBP+12]
  15363.         FILD QWORD PTR [EDI+0]        //Load currency value
  15364.         FRNDINT
  15365.         FLDT SYSTEM.FromCurrency  //*0.0001
  15366.         FMULP ST(1),ST
  15367.         MOV EDI,[EBP+8]
  15368.         MOV EAX,4                     //vier Nachkommas
  15369.         MOV EBX,[EBP+20]              //Format value
  15370.         CALLN32 SYSTEM.!ValReal
  15371.  
  15372.         MOV AL,[EBP+20]              //Format value
  15373.         MOV EDI,[EBP+8]
  15374.         CALLN32 SYSTEM.!FormatStr
  15375.  
  15376.         POP EAX
  15377.         POP EBX
  15378.         POP ECX
  15379.         POP EDX
  15380.         POP ESI
  15381.         POP EDI
  15382.  
  15383.         LEAVE
  15384.         RETN32 16
  15385. SYSTEM.!Currency2Str ENDP
  15386.  
  15387.  
  15388. SYSTEM.!Extended2Str PROC NEAR32  //Format in [EBP+16]
  15389.         PUSH EBP
  15390.         MOV EBP,ESP
  15391.  
  15392.         PUSH EDI
  15393.         PUSH ESI
  15394.         PUSH EDX
  15395.         PUSH ECX
  15396.         PUSH EBX
  15397.         PUSH EAX
  15398.  
  15399.         MOV EDI,[EBP+12]
  15400.         FLDT [EDI+0]       //Load extended value
  15401.         MOV EDI,[EBP+8]
  15402.         MOV EAX,[EBP+16]   //Nachkommastellen (FFFFh alle)
  15403.         MOV EBX,[EBP+20]   //Format value
  15404.         CALLN32 SYSTEM.!ValReal
  15405.  
  15406.         MOV AL,[EBP+20]    //Format value
  15407.         MOV EDI,[EBP+8]
  15408.         CALLN32 SYSTEM.!FormatStr
  15409.  
  15410.         POP EAX
  15411.         POP EBX
  15412.         POP ECX
  15413.         POP EDX
  15414.         POP ESI
  15415.         POP EDI
  15416.  
  15417.         LEAVE
  15418.         RETN32 16
  15419. SYSTEM.!Extended2Str ENDP
  15420.  
  15421. SYSTEM.!Extended2StrReg PROC NEAR32  //Format in [EBP+12], extended value in ST(0)
  15422.         PUSH EBP
  15423.         MOV EBP,ESP
  15424.  
  15425.         PUSH EDI
  15426.         PUSH ESI
  15427.         PUSH EDX
  15428.         PUSH ECX
  15429.         PUSH EBX
  15430.         PUSH EAX
  15431.  
  15432.         MOV EDI,[EBP+8]
  15433.         MOV EAX,[EBP+12]   //Nachkommastellen (FFFFh alle)
  15434.         MOV EBX,[EBP+16]   //Format value
  15435.         CALLN32 SYSTEM.!ValReal
  15436.  
  15437.         MOV AL,[EBP+16]    //Format value
  15438.         MOV EDI,[EBP+8]
  15439.         CALLN32 SYSTEM.!FormatStr
  15440.  
  15441.         POP EAX
  15442.         POP EBX
  15443.         POP ECX
  15444.         POP EDX
  15445.         POP ESI
  15446.         POP EDI
  15447.  
  15448.         LEAVE
  15449.         RETN32 12
  15450. SYSTEM.!Extended2StrReg ENDP
  15451.  
  15452. SYSTEM.!WriteExtended PROC NEAR32   //Writes extended in ST
  15453.           PUSH EBP
  15454.           MOV EBP,ESP
  15455.           SUB ESP,260
  15456.           DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15457.           FSTPT [EBP-260]
  15458.  
  15459.           PUSH DWORD PTR [EBP+12]     //Format
  15460.           PUSH DWORD PTR [EBP+8]      //Nachkommas
  15461.           LEA EAX,[EBP-260]
  15462.           PUSH EAX
  15463.           LEA EAX,[EBP-250]
  15464.           PUSH EAX
  15465.           CALLN32 SYSTEM.!Extended2Str
  15466.  
  15467.           LEA EAX,[EBP-250]
  15468.           PUSH EAX
  15469.           PUSHL 0                //[EBP+8]  ???     //Format value
  15470.           CALLN32 SYSTEM.StrWrite
  15471.  
  15472.           LEAVE
  15473.           RETN32 8
  15474. SYSTEM.!WriteExtended ENDP
  15475.  
  15476. SYSTEM.!WriteCurrency PROC NEAR32   //Writes currency in ST
  15477.           PUSH EBP
  15478.           MOV EBP,ESP
  15479.           SUB ESP,260
  15480.           DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15481.           FRNDINT
  15482.           FLDT SYSTEM.FromCurrency
  15483.           FMULP ST(1),ST
  15484.           FSTPT [EBP-260]
  15485.  
  15486.           MOV EAX,[EBP+12]
  15487.           CMP EAX,23
  15488.           JNE !CurFOk
  15489.           CMPD [EBP+8],4
  15490.           JBE !CurFOk
  15491.           MOV EAX,0
  15492. !CurFOk:
  15493.           PUSH EAX
  15494.           MOV EAX,[EBP+8]             //Nachkommas
  15495.           CMP EAX,4
  15496.           JBE !CurCOk
  15497.           MOV EAX,4
  15498. !CurCOk:
  15499.           PUSH EAX
  15500.           LEA EAX,[EBP-260]
  15501.           PUSH EAX
  15502.           LEA EAX,[EBP-250]
  15503.           PUSH EAX
  15504.           CALLN32 SYSTEM.!Extended2Str
  15505.  
  15506.           LEA EAX,[EBP-250]
  15507.           PUSH EAX
  15508.           PUSHL 0                //[EBP+8]  ???     //Format value
  15509.           CALLN32 SYSTEM.StrWrite
  15510.  
  15511.           LEAVE
  15512.           RETN32 8
  15513. SYSTEM.!WriteCurrency ENDP
  15514.  
  15515.  
  15516. SYSTEM.!WriteComp PROC NEAR32   //Writes extended in ST
  15517.           PUSH EBP
  15518.           MOV EBP,ESP
  15519.           SUB ESP,260
  15520.           DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15521.           FISTP QWORD PTR [EBP-260]
  15522.  
  15523.           PUSH DWORD PTR [EBP+12]     //Format
  15524.           PUSHL 0                     //keine Nachkommas
  15525.           LEA EAX,[EBP-260]
  15526.           PUSH EAX
  15527.           LEA EAX,[EBP-250]
  15528.           PUSH EAX
  15529.           CALLN32 SYSTEM.!Comp2Str
  15530.  
  15531.           LEA EAX,[EBP-250]
  15532.           PUSH EAX
  15533.           PUSHL 0                //[EBP+8]  ???     //Format value
  15534.           CALLN32 SYSTEM.StrWrite
  15535.  
  15536.           LEAVE
  15537.           RETN32 8
  15538. SYSTEM.!WriteComp ENDP
  15539.  
  15540. SYSTEM.!FPULoadLong PROC NEAR32
  15541.             PUSH EBP
  15542.             MOV EBP,ESP
  15543.             FILDD [EBP+8]
  15544.             LEAVE
  15545.             RETN32 4
  15546. SYSTEM.!FPULoadLong ENDP
  15547.  
  15548.  
  15549. SYSTEM.!Sin PROC NEAR32   //calculate SIN in ST(0)
  15550.     CALLN32 SYSTEM.!RadArc
  15551.     FSIN
  15552.     RETN32
  15553. SYSTEM.!Sin ENDP
  15554.  
  15555. SYSTEM.!Cos PROC NEAR32   //calculate COS in ST(0)
  15556.     CALLN32 SYSTEM.!RadArc
  15557.     FCOS
  15558.     RETN32
  15559. SYSTEM.!Cos ENDP
  15560.  
  15561. SYSTEM.!Tan PROC NEAR32
  15562.        PUSH EBP
  15563.        MOV EBP,ESP
  15564.        SUB ESP,12
  15565.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15566.        PUSH EAX
  15567.  
  15568.        MOVW SYSTEM.FPUResult,0
  15569.        FSTPT [EBP-10]
  15570.        FLDT [EBP-10]
  15571.        CALLN32 SYSTEM.!Sin
  15572.        FLDT [EBP-10]
  15573.        CALLN32 SYSTEM.!Cos
  15574.        FTST
  15575.        FSTSW [EBP-12]
  15576.        FWAIT
  15577.        MOV AH,[EBP-11]
  15578.        SAHF
  15579.        JNE !!!_l50
  15580.        FSTP ST(0)
  15581.        FSTP ST(0)
  15582.        FLDZ
  15583.        MOVW SYSTEM.FPUResult,2
  15584.        JMP !!!_l51
  15585. !!!_l50:
  15586.        FDIVRP ST(1),ST
  15587. !!!_l51:
  15588.        POP EAX
  15589.        LEAVE
  15590.        RETN32
  15591. SYSTEM.!Tan ENDP
  15592.  
  15593. SYSTEM.!Cot PROC NEAR32
  15594.        PUSH EBP
  15595.        MOV EBP,ESP
  15596.        SUB ESP,12
  15597.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15598.        PUSH EAX
  15599.  
  15600.        MOVW SYSTEM.FPUResult,0
  15601.        FSTPT [EBP-10]
  15602.        FLDT [EBP-10]
  15603.        CALLN32 SYSTEM.!Cos
  15604.        FLDT [EBP-10]
  15605.        CALLN32 SYSTEM.!Sin
  15606.        FTST
  15607.        FSTSW [EBP-12]
  15608.        FWAIT
  15609.        MOV AH,[EBP-11]
  15610.        SAHF
  15611.        JNE !!!_l53
  15612.        FSTP ST(0)
  15613.        FSTP ST(0)
  15614.        FLDZ
  15615.        MOVW SYSTEM.FPUResult,2
  15616.        JMP !!!_l54
  15617. !!!_l53:
  15618.        FDIVRP ST(1),ST
  15619. !!!_l54:
  15620.        POP EAX
  15621.        LEAVE
  15622.        RETN32
  15623. SYSTEM.!Cot ENDP
  15624.  
  15625. SYSTEM.!ArcTan PROC NEAR32
  15626.        PUSH EBP
  15627.        MOV EBP,ESP
  15628.        SUB ESP,4
  15629.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15630.        PUSH EAX
  15631.        PUSH ECX
  15632.  
  15633.        MOVW SYSTEM.FPUResult,0
  15634.        FXAM             //Type of ST(0)
  15635.        FWAIT
  15636.        FSTSW [EBP-2]
  15637.        MOV AH,[EBP-1]
  15638.        SAHF
  15639.        XCHG CX,AX
  15640.        JB !!!_l30
  15641.        JNE !!!_l31
  15642.        JMP !!!_l32
  15643. !!!_l30:
  15644.        JE !!!_l32
  15645.        JNP !!!_l32
  15646.        FSTP ST(0)
  15647.        FLDT SYSTEM.fl3
  15648.        JMP !!!_l33
  15649. !!!_l31:
  15650.        FABS
  15651.        FLD1
  15652.        FCOM ST(1)
  15653.        FWAIT
  15654.        FSTSW [EBP-2]
  15655.        MOV AH,[EBP-1]
  15656.        SAHF
  15657.        JNE !!!_l34
  15658.        FCOMPP
  15659.        FLDT SYSTEM.fl2
  15660.        JMP !!!_l33
  15661. !!!_l34:
  15662.        JNB !!!_l35
  15663.        FXCH ST(1)
  15664. !!!_l35:
  15665.        FPATAN
  15666.        JNB !!!_l33
  15667.        FLDT SYSTEM.fl3
  15668.        FSUBP ST(1),ST
  15669.        XOR CH,2
  15670. !!!_l33:
  15671.        TEST CH,2
  15672.        JE !!!_l32
  15673.        FCHS
  15674.        FWAIT
  15675. !!!_l32:
  15676.        CALLN32 SYSTEM.!NormRad
  15677.        POP ECX
  15678.        POP EAX
  15679.        LEAVE
  15680.        RETN32
  15681. SYSTEM.!ArcTan ENDP
  15682.  
  15683. SYSTEM.!Sqrt PROC NEAR32
  15684.        FSQRT
  15685.        RETN32
  15686. SYSTEM.!Sqrt ENDP
  15687.  
  15688. SYSTEM.!ln PROC NEAR32
  15689.       PUSH EBP
  15690.       MOV EBP,ESP
  15691.       SUB ESP,10
  15692.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15693.       PUSH EAX
  15694.  
  15695.       MOVW SYSTEM.FPUResult,0
  15696.       FLDLN2
  15697.       FXCH ST(1)
  15698.       FXAM
  15699.       FWAIT
  15700.       FSTSW [EBP-10]
  15701.       MOV AH,[EBP-9]
  15702.       SAHF
  15703.       JB !!!_l20
  15704.       JE !!!_l21
  15705.       TEST AH,2
  15706.       JE !!!_l22
  15707. !!!_l21:
  15708.       FSTP ST(0)
  15709.       JMP !!!_l23
  15710. !!!_l20:
  15711.       FSTP ST(0)
  15712.       JE !!!_l24
  15713.       JNP !!!_l24
  15714. !!!_l23:
  15715.       FSTP ST(0)
  15716.       FLDD SYSTEM.fl1
  15717. !!!_l24:
  15718.       FTST
  15719.       JMP !!!_l29
  15720. !!!_l22:
  15721.       FLD ST(0)
  15722.       FSTPT [EBP-10]
  15723.       CMPW [EBP-2],$3fff
  15724.       JNE !!!_l25
  15725.       CMPW [EBP-4],$8000
  15726.       JNE !!!_l25
  15727.       FLD1
  15728.       FSUBP ST(1),ST
  15729.       FYL2XP1
  15730.       JMP !!!_l29
  15731. !!!_l25:
  15732.       FYL2X
  15733. !!!_l29:
  15734.       POP EAX
  15735.       LEAVE
  15736.       RETN32
  15737. SYSTEM.!ln ENDP
  15738.  
  15739. SYSTEM.!Exp PROC NEAR32
  15740.       PUSH EBP
  15741.       MOV EBP,ESP
  15742.       SUB ESP,16
  15743.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15744.       PUSH EAX
  15745.       PUSH EBX
  15746.       PUSH ECX
  15747.  
  15748.       MOVW SYSTEM.FPUResult,0
  15749.       FLDL2E
  15750.       FXCH ST(1)
  15751.       FXAM
  15752.       FWAIT
  15753.       FSTSW [EBP-6]
  15754.       FXCH ST(1)
  15755.       MOV AH,[EBP-5]
  15756.       SAHF
  15757.       XCHG BX,AX
  15758.       JB !!!_l40
  15759.       JNE !!!_l41
  15760.       FSTP ST(0)
  15761.       FSTP ST(0)
  15762.       FLD1
  15763.       FWAIT
  15764.       JMP !!!_l43
  15765. !!!_l40:
  15766.       FSTP ST(0)
  15767.       JE !!!_l44
  15768.       JNP !!!_l44
  15769. !!!_l48:
  15770.       FSTP ST(0)
  15771.       //FLDD SYSTEM.fl4
  15772.       FLDZ
  15773. !!!_l44:
  15774.       FTST
  15775.       FWAIT
  15776.       JMP !!!_l43
  15777. !!!_l41:
  15778.       FMULP ST(1),ST
  15779.       FABS
  15780.       FLDD SYSTEM.fl5
  15781.       FXCH ST(1)
  15782.       FSTPT [EBP-16]
  15783.       FLDT [EBP-16]
  15784.       FCOMPP
  15785.       FWAIT
  15786.       FSTSW [EBP-6]
  15787.       FLDT [EBP-16]
  15788.       TESTB [EBP-5],$41
  15789.       JE !!!_l46
  15790.       F2XM1
  15791.       FLD1
  15792.       FADDP ST(1),ST
  15793.       FWAIT
  15794.       JMP !!!_l47
  15795. !!!_l46:
  15796.       FLD1
  15797.       FLD ST(1)
  15798.       FWAIT
  15799.       FSTCW [EBP-6]
  15800.       FSCALE
  15801.       ORB [EBP-5],$0f
  15802.       FLDCW [EBP-6]
  15803.       FWAIT
  15804.       FRNDINT
  15805.       ANDB [EBP-5],$0f3
  15806.       FLDCW [EBP-6]
  15807.       FWAIT
  15808.       FIST DWORD PTR [EBP-4]
  15809.       FXCH ST(1)
  15810.       FCHS
  15811.       FXCH ST(1)
  15812.       FSCALE
  15813.       FSTP ST(1)
  15814.       FSUBP ST(1),ST
  15815.       CMPW [EBP-2],0
  15816.       JG !!!_l48
  15817.       F2XM1
  15818.       FLD1
  15819.       FADDP ST(1),ST
  15820.       FWAIT
  15821.       MOV CX,[EBP-4]
  15822.       SHR CX,1
  15823.       MOV [EBP-4],CX
  15824.       JNB !!!_l49
  15825.       FLDT SYSTEM.fl6
  15826.       FMULP ST(1),ST
  15827. !!!_l49:
  15828.       FILDW [EBP-4]
  15829.       FXCH ST(1)
  15830.       FSCALE
  15831.       FSTP ST(1)
  15832. !!!_l47:
  15833.       TEST BH,2
  15834.       JE !!!_l43
  15835.       FLD1
  15836.       FDIVP ST(1),ST
  15837. !!!_l43:
  15838.       POP ECX
  15839.       POP EBX
  15840.       POP EAX
  15841.       LEAVE
  15842.       RETN32
  15843. SYSTEM.!Exp ENDP
  15844.  
  15845. SYSTEM.!Frac PROC NEAR32
  15846.       PUSH EBP
  15847.       MOV EBP,ESP
  15848.       SUB ESP,12
  15849.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15850.       FSTPT [EBP-10]
  15851.       FLDT [EBP-10]
  15852.       FCLEX
  15853.       FLDCW SYSTEM.FPURound  //Load control word
  15854.       FWAIT
  15855.       FRNDINT
  15856.       FCLEX
  15857.       FLDCW SYSTEM.FPUControl //Load control word
  15858.       FWAIT
  15859.       FLDT [EBP-10]
  15860.       FXCH ST(1)
  15861.       FSUBP ST(1),ST
  15862.       LEAVE
  15863.       RETN32
  15864. SYSTEM.!Frac ENDP
  15865.  
  15866. SYSTEM.!Int PROC NEAR32
  15867.       FCLEX
  15868.       FLDCW SYSTEM.FPURound  //Load control word
  15869.       FWAIT
  15870.       FRNDINT
  15871.       FCLEX
  15872.       FLDCW SYSTEM.FPUControl //Load control word
  15873.       FWAIT
  15874.       RETN32
  15875. SYSTEM.!Int ENDP
  15876.  
  15877. SYSTEM.!Round PROC NEAR32
  15878.       PUSH EBP
  15879.       MOV EBP,ESP
  15880.       SUB ESP,10
  15881.       DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  15882.  
  15883.       FSTPT [EBP-10]
  15884.       FLDT [EBP-10]
  15885.       CALLN32 SYSTEM.!Frac
  15886.       FLDT [EBP-10]
  15887.       FADDP ST(1),ST
  15888.       CALLN32 SYSTEM.!Trunc
  15889.  
  15890.       LEAVE
  15891.       RETN32
  15892. SYSTEM.!Round ENDP
  15893.  
  15894. SYSTEM.!Trunc PROC NEAR32
  15895.       PUSH EBP
  15896.       MOV EBP,ESP
  15897.       SUB ESP,10
  15898.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15899.       FCLEX
  15900.       FLDCW SYSTEM.FPURound  //Load control word
  15901.       FWAIT
  15902.       FRNDINT
  15903.       FCLEX
  15904.       FLDCW SYSTEM.FPUControl //Load control word
  15905.       FWAIT
  15906.       FISTPD [EBP-10]
  15907.       MOV EAX,[EBP-10]
  15908.       LEAVE
  15909.       RETN32
  15910. SYSTEM.!Trunc ENDP
  15911.  
  15912. SYSTEM.!Sqr PROC NEAR32
  15913.       FLD St(0)
  15914.       FMULP ST(1),ST
  15915.       RETN32
  15916. SYSTEM.!Sqr ENDP
  15917.  
  15918. SYSTEM.!ArcSin PROC NEAR32
  15919.        PUSH EBP
  15920.        MOV EBP,ESP
  15921.        SUB ESP,12
  15922.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15923.        PUSH EAX
  15924.  
  15925.        MOVW SYSTEM.FPUResult,0
  15926.        FLD St(0)
  15927.        FABS
  15928.        FLD1
  15929.        FCOMPP
  15930.        FWAIT
  15931.        FSTSW [EBP-12]
  15932.        MOV AH,[EBP-11]
  15933.        SAHF
  15934.        JB !!!_l60
  15935.        JNE !!!_l62
  15936.        //ArcSin(1.0)=w*pi/2
  15937.        FLDT SYSTEM.fl7    //1.5707...
  15938.        FMULP ST(1),ST
  15939.        JMP !!!_l61
  15940. !!!_l62:
  15941.        FLD St(0)
  15942.        FSTPT [EBP-10]
  15943.        FLD St(0)
  15944.        FMULP ST(1),ST
  15945.        FLD1
  15946.        FSUBRP ST(1),ST
  15947.        FSQRT
  15948.        FLDT [EBP-10]
  15949.        FXCH ST(1)
  15950.        FDIVRP ST(1),ST
  15951.        CALLN32 SYSTEM.!ArcTan
  15952.        POP EAX
  15953.        LEAVE
  15954.        RETN32
  15955. !!!_l60:
  15956.        MOVW SYSTEM.FPUResult,3
  15957. !!!_l61:
  15958.        CALLN32 SYSTEM.!NormRad
  15959.        POP EAX
  15960.        LEAVE
  15961.        RETN32
  15962. SYSTEM.!ArcSin ENDP
  15963.  
  15964. SYSTEM.!ArcCos PROC NEAR32
  15965.        MOVW SYSTEM.FPUResult,0
  15966.        CALLN32 SYSTEM.!ArcSin
  15967.        FLDT SYSTEM.fl7   //PI/2
  15968.        FXCH ST(1)
  15969.        FSUBP ST(1),ST
  15970.        CALLN32 SYSTEM.!NormRad
  15971.        RETN32
  15972. SYSTEM.!ArcCos ENDP
  15973.  
  15974. SYSTEM.!ArcCot PROC NEAR32
  15975.        MOVW SYSTEM.FPUResult,0
  15976.        CALLN32 SYSTEM.!ArcTan
  15977.        FLDT SYSTEM.fl7   //PI/2
  15978.        FXCH ST(1)
  15979.        FSUBP ST(1),ST
  15980.        CALLN32 SYSTEM.!NormRad
  15981.        RETN32
  15982. SYSTEM.!ArcCot ENDP
  15983.  
  15984. SYSTEM.!Sinh PROC NEAR32
  15985.        MOVW SYSTEM.FPUResult,0
  15986.        CALLN32 SYSTEM.!Exp
  15987.        FLD St(0)
  15988.        FLD1
  15989.        FXCH ST(1)
  15990.        FDIVRP ST(1),ST
  15991.        FXCH ST(1)
  15992.        FSUBP ST(1),ST
  15993.        FLDT SYSTEM.fl8
  15994.        FMULP ST(1),ST
  15995.        RETN32
  15996. SYSTEM.!Sinh ENDP
  15997.  
  15998. SYSTEM.!Cosh PROC NEAR32
  15999.        MOVW SYSTEM.FPUResult,0
  16000.        CALLN32 SYSTEM.!Exp
  16001.        FLD St(0)
  16002.        FLD1
  16003.        FXCH ST(1)
  16004.        FDIVRP ST(1),ST
  16005.        FADDP ST(1),ST
  16006.        FWAIT
  16007.        FLDT SYSTEM.fl8
  16008.        FMULP ST(1),ST
  16009.        RETN32
  16010. SYSTEM.!Cosh ENDP
  16011.  
  16012. SYSTEM.!Tanh PROC NEAR32
  16013.        MOVW SYSTEM.FPUResult,0
  16014.        FLDT SYSTEM.fl9   //2.0
  16015.        FMULP ST(1),ST
  16016.        CALLN32 SYSTEM.!Exp
  16017.        FLD1
  16018.        FADDP ST(1),ST
  16019.        FWAIT
  16020.        FLDT SYSTEM.fl9   //2.0
  16021.        FXCH ST(1)
  16022.        FDIVRP ST(1),ST
  16023.        FLD1
  16024.        FSUBP ST(1),ST
  16025.        RETN32
  16026. SYSTEM.!Tanh ENDP
  16027.  
  16028. SYSTEM.!Coth PROC NEAR32
  16029.        PUSH EBP
  16030.        MOV EBP,ESP
  16031.        SUB ESP,12
  16032.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16033.        PUSH EAX
  16034.  
  16035.        MOVW SYSTEM.FPUResult,0
  16036.        FLD St(0)
  16037.        FSTPT [EBP-10]
  16038.        CALLN32 SYSTEM.!Sinh
  16039.        FTST
  16040.        FWAIT
  16041.        FSTSW [EBP-12]
  16042.        MOV AH,[EBP-11]
  16043.        SAHF
  16044.        JE !!!_l70
  16045.        FLDT [EBP-10]
  16046.        CALLN32 SYSTEM.!Cosh
  16047.        FXCH ST(1)
  16048.        FDIVRP ST(1),ST
  16049.        JMP !!!_l71
  16050. !!!_l70:
  16051.        MOVW SYSTEM.FPUResult,4
  16052. !!!_l71:
  16053.        POP EAX
  16054.        LEAVE
  16055.        RETN32
  16056. SYSTEM.!Coth ENDP
  16057.  
  16058. SYSTEM.!lg PROC NEAR32
  16059.        MOVW SYSTEM.FPUResult,0
  16060.        CALLN32 SYSTEM.!ln
  16061.        FLDT SYSTEM.fl10
  16062.        FDIVRP ST(1),ST
  16063.        RETN32
  16064. SYSTEM.!lg ENDP
  16065.  
  16066. SYSTEM.!lb PROC NEAR32
  16067.        MOVW SYSTEM.FPUResult,0
  16068.        CALLN32 SYSTEM.!ln
  16069.        FLDT SYSTEM.fl11
  16070.        FDIVRP ST(1),ST
  16071.        RETN32
  16072. SYSTEM.!lb ENDP
  16073.  
  16074. SYSTEM.!ReadReal PROC NEAR32
  16075.        PUSH EBP
  16076.        MOV EBP,ESP
  16077.        SUB ESP,262
  16078.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16079.        LEA EAX,[EBP-260]
  16080.        PUSH EAX
  16081.        CALLN32 SYSTEM.StrRead
  16082.        LEA EAX,[EBP-260]
  16083.        PUSH EAX
  16084.        PUSH DWORD PTR [EBP+8]
  16085.        LEA EAX,[EBP-262]
  16086.        PUSH EAX
  16087.        CALLN32 SYSTEM.!Str2Real
  16088.        LEAVE
  16089.        RETN32 4
  16090. SYSTEM.!ReadReal ENDP
  16091.  
  16092. SYSTEM.!ReadDouble PROC NEAR32
  16093.        PUSH EBP
  16094.        MOV EBP,ESP
  16095.        SUB ESP,262
  16096.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16097.        LEA EAX,[EBP-260]
  16098.        PUSH EAX
  16099.        CALLN32 SYSTEM.StrRead
  16100.        LEA EAX,[EBP-260]
  16101.        PUSH EAX
  16102.        PUSH DWORD PTR [EBP+8]
  16103.        LEA EAX,[EBP-262]
  16104.        PUSH EAX
  16105.        CALLN32 SYSTEM.!Str2Double
  16106.        LEAVE
  16107.        RETN32 4
  16108. SYSTEM.!ReadDouble ENDP
  16109.  
  16110. SYSTEM.!ReadExtended PROC NEAR32
  16111.        PUSH EBP
  16112.        MOV EBP,ESP
  16113.        SUB ESP,262
  16114.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16115.        LEA EAX,[EBP-260]
  16116.        PUSH EAX
  16117.        CALLN32 SYSTEM.StrRead
  16118.        LEA EAX,[EBP-260]
  16119.        PUSH EAX
  16120.        PUSH DWORD PTR [EBP+8]
  16121.        LEA EAX,[EBP-262]
  16122.        PUSH EAX
  16123.        CALLN32 SYSTEM.!Str2Extended
  16124.        LEAVE
  16125.        RETN32 4
  16126. SYSTEM.!ReadExtended ENDP
  16127.  
  16128. END;
  16129.  
  16130. PROCEDURE Real2AnsiStr(f:BYTE;n:LONGWORD;CONST r:Single;VAR result:AnsiString);
  16131. VAR s:STRING;
  16132. BEGIN
  16133.      ASM
  16134.         PUSH EDI
  16135.         PUSH ESI
  16136.         PUSH EDX
  16137.         PUSH ECX
  16138.         PUSH EBX
  16139.         PUSH EAX
  16140.  
  16141.         PUSH DWORD PTR f
  16142.         PUSH DWORD PTR n
  16143.         PUSH DWORD PTR r
  16144.         LEA EAX,s
  16145.         PUSH EAX
  16146.         CALLN32 SYSTEM.!Real2Str
  16147.      END;
  16148.      result:=s;
  16149.      ASM
  16150.         POP EAX
  16151.         POP EBX
  16152.         POP ECX
  16153.         POP EDX
  16154.         POP ESI
  16155.         POP EDI
  16156.      END;
  16157. END;
  16158.  
  16159. PROCEDURE Double2AnsiStr(f:BYTE;n:LONGWORD;CONST r:Double;VAR result:AnsiString);
  16160. VAR s:STRING;
  16161. BEGIN
  16162.      ASM
  16163.         PUSH EDI
  16164.         PUSH ESI
  16165.         PUSH EDX
  16166.         PUSH ECX
  16167.         PUSH EBX
  16168.         PUSH EAX
  16169.  
  16170.         PUSH DWORD PTR f
  16171.         PUSH DWORD PTR n
  16172.         PUSH DWORD PTR r
  16173.         LEA EAX,s
  16174.         PUSH EAX
  16175.         CALLN32 SYSTEM.!Double2Str
  16176.      END;
  16177.      result:=s;
  16178.      ASM
  16179.         POP EAX
  16180.         POP EBX
  16181.         POP ECX
  16182.         POP EDX
  16183.         POP ESI
  16184.         POP EDI
  16185.      END;
  16186. END;
  16187.  
  16188. PROCEDURE AnsiStr2Real(VAR s:AnsiString;VAR b:SINGLE;VAR c:INTEGER);
  16189. VAR s1:STRING;
  16190. BEGIN
  16191.      ASM
  16192.         PUSH EAX
  16193.         PUSH EBX
  16194.         PUSH ECX
  16195.         PUSH EDX
  16196.         PUSH ESI
  16197.         PUSH EDI
  16198.      END;
  16199.  
  16200.      s1:=s;
  16201.      ASM
  16202.         LEA EAX,s1
  16203.         PUSH EAX
  16204.         PUSH DWORD PTR b
  16205.         PUSH DWORD PTR c
  16206.         CALLN32 SYSTEM.!Str2Real
  16207.      END;
  16208.  
  16209.      ASM
  16210.         POP EDI
  16211.         POP ESI
  16212.         POP EDX
  16213.         POP ECX
  16214.         POP EBX
  16215.         POP EAX
  16216.      END;
  16217. END;
  16218.  
  16219. PROCEDURE AnsiStr2Double(VAR s:AnsiString;VAR b:DOUBLE;VAR c:INTEGER);
  16220. VAR s1:STRING;
  16221. BEGIN
  16222.      ASM
  16223.         PUSH EAX
  16224.         PUSH EBX
  16225.         PUSH ECX
  16226.         PUSH EDX
  16227.         PUSH ESI
  16228.         PUSH EDI
  16229.      END;
  16230.  
  16231.      s1:=s;
  16232.      ASM
  16233.         LEA EAX,s1
  16234.         PUSH EAX
  16235.         PUSH DWORD PTR b
  16236.         PUSH DWORD PTR c
  16237.         CALLN32 SYSTEM.!Str2Double
  16238.      END;
  16239.  
  16240.      ASM
  16241.         POP EDI
  16242.         POP ESI
  16243.         POP EDX
  16244.         POP ECX
  16245.         POP EBX
  16246.         POP EAX
  16247.      END;
  16248.  
  16249. END;
  16250.  
  16251. PROCEDURE AnsiStr2Comp(VAR s:AnsiString;VAR b:Comp;VAR c:INTEGER);
  16252. VAR s1:STRING;
  16253. BEGIN
  16254.      ASM
  16255.         PUSH EAX
  16256.         PUSH EBX
  16257.         PUSH ECX
  16258.         PUSH EDX
  16259.         PUSH ESI
  16260.         PUSH EDI
  16261.      END;
  16262.  
  16263.      s1:=s;
  16264.      ASM
  16265.         LEA EAX,s1
  16266.         PUSH EAX
  16267.         PUSH DWORD PTR b
  16268.         PUSH DWORD PTR c
  16269.         CALLN32 SYSTEM.!Str2Comp
  16270.      END;
  16271.  
  16272.      ASM
  16273.         POP EDI
  16274.         POP ESI
  16275.         POP EDX
  16276.         POP ECX
  16277.         POP EBX
  16278.         POP EAX
  16279.      END;
  16280.  
  16281. END;
  16282.  
  16283. PROCEDURE AnsiStr2Currency(VAR s:AnsiString;VAR b:Comp;VAR c:INTEGER);
  16284. VAR s1:STRING;
  16285. BEGIN
  16286.      ASM
  16287.         PUSH EAX
  16288.         PUSH EBX
  16289.         PUSH ECX
  16290.         PUSH EDX
  16291.         PUSH ESI
  16292.         PUSH EDI
  16293.      END;
  16294.  
  16295.      s1:=s;
  16296.      ASM
  16297.         LEA EAX,s1
  16298.         PUSH EAX
  16299.         PUSH DWORD PTR b
  16300.         PUSH DWORD PTR c
  16301.         CALLN32 SYSTEM.!Str2Currency
  16302.      END;
  16303.  
  16304.      ASM
  16305.         POP EDI
  16306.         POP ESI
  16307.         POP EDX
  16308.         POP ECX
  16309.         POP EBX
  16310.         POP EAX
  16311.      END;
  16312. END;
  16313.  
  16314. PROCEDURE AnsiStr2Extended(VAR s:AnsiString;VAR b:Extended;VAR c:INTEGER);
  16315. VAR s1:STRING;
  16316. BEGIN
  16317.      ASM
  16318.         PUSH EAX
  16319.         PUSH EBX
  16320.         PUSH ECX
  16321.         PUSH EDX
  16322.         PUSH ESI
  16323.         PUSH EDI
  16324.      END;
  16325.  
  16326.      s1:=s;
  16327.      ASM
  16328.         LEA EAX,s1
  16329.         PUSH EAX
  16330.         PUSH DWORD PTR b
  16331.         PUSH DWORD PTR c
  16332.         CALLN32 SYSTEM.!Str2Extended
  16333.      END;
  16334.  
  16335.      ASM
  16336.         POP EDI
  16337.         POP ESI
  16338.         POP EDX
  16339.         POP ECX
  16340.         POP EBX
  16341.         POP EAX
  16342.      END;
  16343. END;
  16344.  
  16345. PROCEDURE Comp2AnsiStr(f:BYTE;n:LONGWORD;CONST r:Comp;VAR result:AnsiString);
  16346. VAR s:STRING;
  16347. BEGIN
  16348.      ASM
  16349.         PUSH EDI
  16350.         PUSH ESI
  16351.         PUSH EDX
  16352.         PUSH ECX
  16353.         PUSH EBX
  16354.         PUSH EAX
  16355.  
  16356.         PUSH DWORD PTR f
  16357.         PUSH DWORD PTR n
  16358.         PUSH DWORD PTR r
  16359.         LEA EAX,s
  16360.         PUSH EAX
  16361.         CALLN32 SYSTEM.!Comp2Str
  16362.      END;
  16363.      result:=s;
  16364.      ASM
  16365.         POP EAX
  16366.         POP EBX
  16367.         POP ECX
  16368.         POP EDX
  16369.         POP ESI
  16370.         POP EDI
  16371.      END;
  16372. END;
  16373.  
  16374. PROCEDURE Currency2AnsiStr(f:BYTE;n:LONGWORD;CONST r:Currency;VAR result:AnsiString);
  16375. VAR s:STRING;
  16376. BEGIN
  16377.      ASM
  16378.         PUSH EDI
  16379.         PUSH ESI
  16380.         PUSH EDX
  16381.         PUSH ECX
  16382.         PUSH EBX
  16383.         PUSH EAX
  16384.  
  16385.         PUSH DWORD PTR f
  16386.         PUSH DWORD PTR n
  16387.         PUSH DWORD PTR r
  16388.         LEA EAX,s
  16389.         PUSH EAX
  16390.         CALLN32 SYSTEM.!Currency2Str
  16391.      END;
  16392.      result:=s;
  16393.      ASM
  16394.         POP EAX
  16395.         POP EBX
  16396.         POP ECX
  16397.         POP EDX
  16398.         POP ESI
  16399.         POP EDI
  16400.      END;
  16401. END;
  16402.  
  16403.  
  16404. PROCEDURE Extended2AnsiStr(f:BYTE;n:LONGWORD;CONST r:Extended;VAR result:AnsiString);
  16405. VAR s:STRING;
  16406. BEGIN
  16407.      ASM
  16408.         PUSH EDI
  16409.         PUSH ESI
  16410.         PUSH EDX
  16411.         PUSH ECX
  16412.         PUSH EBX
  16413.         PUSH EAX
  16414.  
  16415.         PUSH DWORD PTR f
  16416.         PUSH DWORD PTR n
  16417.         PUSH DWORD PTR r
  16418.         LEA EAX,s
  16419.         PUSH EAX
  16420.         CALLN32 SYSTEM.!Extended2Str
  16421.      END;
  16422.      result:=s;
  16423.      ASM
  16424.         POP EAX
  16425.         POP EBX
  16426.         POP ECX
  16427.         POP EDX
  16428.         POP ESI
  16429.         POP EDI
  16430.      END;
  16431. END;
  16432.  
  16433.  
  16434. ASSEMBLER
  16435.  
  16436. {$IFDEF OS2}
  16437. SYSTEM.!ParaInfo PROC NEAR32  //(AL=Function - 1 count of parameters to CL
  16438.                               //               2 Pointer to parameter CL to ESI
  16439.                               //Input:argument start in ESI
  16440.          MOV BX,0      //we start with parameter 0
  16441.          MOV DL,0      //we are not in " state
  16442.          CMP AL,2      //get parameter name ?
  16443.          JNE !no_name
  16444.          PUSH ESI
  16445.          CMP CL,0      //parameter 0 required ?
  16446.          JE !no_args
  16447.          POP ESI
  16448. !no_name:
  16449.          //Overread the EXE file name
  16450.          CLD
  16451.          PUSH AX
  16452. !rrloop:
  16453.          LODSB
  16454.          CMP AL,0
  16455.          JNE !rrloop
  16456.          POP AX
  16457.  
  16458.          MOV DL,0   //we are not in " state
  16459.          CMP AL,2   //get parameter name ?
  16460.          JE !get_argname
  16461.          MOV CL,255 //impossible parameter
  16462. !get_argname:
  16463.          XOR CH,CH
  16464.          MOV BX,1      //now finally we start with parameter 1
  16465.  
  16466.          LODSB
  16467.          //check whether the first character is a separator
  16468.          CMP AL,' '
  16469.          JE !aagain
  16470.          CMP AL,0   //is this already the end -->Urrgh !
  16471.          JNE !al2
  16472.          PUSHL 0    //The (nonexistent) parameters -->Throw it away guy !
  16473.          MOV BL,0   //No parameters
  16474.          JMP !no_args
  16475. !al2:
  16476.          DEC ESI    //restore old position
  16477. !aagain:
  16478.          PUSH ESI   //save last adress
  16479.          CMP CL,BL  //is the parameter reached ??
  16480.          JE !no_args
  16481. !readloop:
  16482.          LODSB
  16483.          CMP AL,0
  16484.          JE !no_args1  //No more arguments detected
  16485.          //check all separators possible
  16486.          CMP AL,'"'
  16487.          JNE !xxx1
  16488.          NOT DL
  16489. !xxx1:
  16490.          CMP AL,' '
  16491.          JNE !readloop
  16492.          CMP DL,0     //only increase param if we are not in " state
  16493.          JNE !readloop
  16494. !separator:
  16495.          //Check whether more separators follow
  16496.          LODSB
  16497.          CMP AL,' '
  16498.          JE !one_more
  16499.          CMP AL,0      //A zero parameter is stupid
  16500.          JNE !no_more
  16501.          POP EAX       //Clear stack
  16502.          PUSHL 0       //The (nonexistent) parameter -->Throw it away guy !
  16503.          JMP !no_args
  16504. !one_more:
  16505.          JMP !separator
  16506. !no_more:
  16507.          DEC ESI
  16508.          INC BX        //Increment parameter count
  16509.          MOV DL,0      //we are not in " state
  16510.          POP EAX       //clear stack
  16511.          JMP !aagain
  16512. !no_args1:
  16513.          //Argument index was invalid
  16514.          POP ESI   //Clear Stack
  16515.          PUSHL 0   //Pointer to parameter is NIL
  16516. !no_args:
  16517.          MOV CL,BL     //Parameter count
  16518.          POP ESI       //Adress of last parameter
  16519.          RETN32
  16520. SYSTEM.!ParaInfo ENDP
  16521. {$ENDIF}
  16522. {$IFDEF WIN95}
  16523. SYSTEM.!ParaInfo PROC NEAR32  //(AL=Function - 1 count of parameters to CL
  16524.                               //               2 Pointer to parameter CL to ESI
  16525.                               //Input:argument start in ESI
  16526.          MOV BX,0      //we start with parameter 0
  16527.          MOV DL,0      //we are not in " state
  16528.          CMP AL,2      //get parameter name ?
  16529.          JNE !no_name
  16530.          PUSH ESI
  16531.          CMP CL,0      //parameter 0 required ?
  16532.          JE !no_args
  16533.          POP ESI
  16534. !no_name:
  16535.          //Overread the EXE file name
  16536.          CLD
  16537.          PUSH AX
  16538. !rrloop:
  16539.          LODSB
  16540.          CMP AL,'"'
  16541.          JNE !xxx1
  16542.          NOT DL
  16543. !xxx1:
  16544.          CMP AL,32
  16545.          JNE !rrloop
  16546.          CMP DL,0
  16547.          JNE !rrloop  //we are inside ", so spaces are valid
  16548.          POP AX
  16549.  
  16550.          MOV DL,0   //we are not in " state
  16551.          CMP AL,2   //get parameter name ?
  16552.          JE !get_argname
  16553.          MOV CL,255 //impossible parameter
  16554. !get_argname:
  16555.          XOR CH,CH
  16556.          MOV BX,1      //now finally we start with parameter 1
  16557.  
  16558.          LODSB
  16559.          //check whether the first character is a separator
  16560.          CMP AL,' '
  16561.          JE !aagain
  16562.          CMP AL,0   //is this already the end -->Urrgh !
  16563.          JNE !al2
  16564.          PUSHL 0    //The (nonexistent) parameters -->Throw it away guy !
  16565.          MOV BL,0   //No parameters
  16566.          JMP !no_args
  16567. !al2:
  16568.          DEC ESI    //restore old position
  16569. !aagain:
  16570.          PUSH ESI   //save last adress
  16571.          CMP CL,BL  //is the parameter reached ??
  16572.          JE !no_args
  16573. !readloop:
  16574.          LODSB
  16575.          CMP AL,0
  16576.          JE !no_args1  //No more arguments detected
  16577.          //check all separators possible
  16578.          CMP AL,'"'
  16579.          JNE !xxx2
  16580.          NOT DL
  16581. !xxx2:
  16582.          CMP AL,' '
  16583.          JNE !readloop
  16584.          CMP DL,0     //only increase param if we are not in " state
  16585.          JNE !readloop
  16586. !separator:
  16587.          //Check whether more separators follow
  16588.          LODSB
  16589.          CMP AL,' '
  16590.          JE !one_more
  16591.          CMP AL,0      //A zero parameter is stupid
  16592.          JNE !no_more
  16593.          POP EAX       //Clear stack
  16594.          PUSHL 0       //The (nonexistent) parameter -->Throw it away guy !
  16595.          JMP !no_args
  16596. !one_more:
  16597.          JMP !separator
  16598. !no_more:
  16599.          DEC ESI
  16600.          INC BX        //Increment parameter count
  16601.          MOV DL,0      //we are not in " state
  16602.          POP EAX       //clear stack
  16603.          JMP !aagain
  16604. !no_args1:
  16605.          //Argument index was invalid
  16606.          POP ESI   //Clear Stack
  16607.          PUSHL 0   //Pointer to parameter is NIL
  16608. !no_args:
  16609.          MOV CL,BL     //Parameter count
  16610.          POP ESI       //Adress of last parameter
  16611.          RETN32
  16612. SYSTEM.!ParaInfo ENDP
  16613.  
  16614. {$ENDIF}
  16615.  
  16616. END;
  16617.  
  16618. FUNCTION  PARAMSTR(item:Byte):STRING;
  16619. VAR s,s1:STRING;
  16620. BEGIN
  16621.      ParamStr:='';  {Clear}
  16622.      ASM
  16623.          MOV CL,item                 //index to CL
  16624.          MOV AL,2                    //Get Parameter name
  16625.          MOV ESI,SYSTEM.ArgStart
  16626.          CALLN32 SYSTEM.!ParaInfo
  16627.          MOV EDI,[EBP+8]             //Result string
  16628.          MOVB [EDI+0],0              //Result string is empty
  16629.          LEA EDI,s                   //result string
  16630.          XOR AL,AL                   //Stringlen to 0
  16631.          STOSB
  16632.          CMP ESI,0                   //Parameter invalid ?
  16633.          JE _Lpe
  16634.  
  16635.          CLD
  16636.          LEA EDI,s    //result string
  16637.          XOR AL,AL    //Stringlen to 0
  16638.          STOSB
  16639.          MOV CL,0     //Len is 0
  16640.          MOV DL,0     //we are not in " state
  16641. __lp1:
  16642.          LODSB
  16643.          //Check all separators
  16644.          CMP AL,'"'
  16645.          JNE !xxx4
  16646.          NOT DL
  16647. !xxx4:
  16648.          CMP AL,' '
  16649.          JNE !xxx5
  16650.          CMP DL,0
  16651.          JE __Lps
  16652. !xxx5:
  16653.          CMP AL,0    //Last parameter
  16654.          JE __Lps
  16655.          INC CL
  16656.          //No separator --> save
  16657.          STOSB
  16658.          JMP __lp1
  16659. __Lps:
  16660.          LEA EDI,s             //Result string
  16661.          MOV [EDI+0],CL        //set Stringlen
  16662. _lpe:
  16663.     END;
  16664.     IF Length(s)>0 THEN IF s[1]='"' THEN Delete(s,1,1);
  16665.     IF s[Length(s)]='"' THEN dec(s[0]);
  16666.     IF item=0 THEN
  16667.     BEGIN
  16668.          IF pos('.',s)=0 THEN s:=s+'.EXE';
  16669.          IF pos('\',s)=0 THEN
  16670.          BEGIN
  16671.               getdir(0,s1);
  16672.               IF s1[length(s1)]='\' THEN dec(s1[0]);
  16673.               s:=s1+'\'+s;
  16674.          END;
  16675.     END;
  16676.     ParamStr:=s;
  16677. END;
  16678.  
  16679.  
  16680.  
  16681. FUNCTION PARAMCOUNT:Byte;
  16682. BEGIN
  16683.      ASM
  16684.         MOV AL,1  //get parametercount
  16685.         MOV CL,1  //avoid exit in !ParaInfo
  16686.         MOV ESI,SYSTEM.ArgStart
  16687.         CALLN32 SYSTEM.!ParaInfo
  16688.         MOV AL,CL
  16689.         XOR AH,AH
  16690.         MOV Result,AX
  16691.      END;
  16692. END;
  16693.  
  16694.  
  16695. //************************************************************************
  16696. //
  16697. //
  16698. // System initialization code and thread management
  16699. //
  16700. //
  16701. //************************************************************************
  16702.  
  16703. ASSEMBLER
  16704.  
  16705. SYSTEM.!CorrectArgList PROC NEAR32
  16706.                CLD
  16707.                MOVB SYSTEM.Redirect,0
  16708.                MOV ESI,SYSTEM.ArgStart
  16709.                CMP ESI,0
  16710.                JNE !cal1_rrloop
  16711.                RETN32
  16712.  
  16713. !cal1_rrloop:
  16714.                //Overread EXE file name
  16715.                LODSB
  16716.                CMP AL,0
  16717.                JNE !cal1_rrloop
  16718. !cal1_1:
  16719.                MOV AL,[ESI+0]
  16720.  
  16721.                CMP AL,32
  16722.                JNE !cal1_3
  16723.  
  16724.                CMPB [ESI+1],0
  16725.                JNE !cal1_3
  16726.                MOV AL,0
  16727. !cal1_3:
  16728.                CMP AL,'|'
  16729.                JE !cal1_51x
  16730.  
  16731.                CMP AL,'>'
  16732.                JE !cal1_5!
  16733.  
  16734.                CMP AL,'<'
  16735.                JNE !cal1_4
  16736.                MOVB SYSTEM.RedirectIn,1
  16737.                JMP !cal1_51x
  16738. !cal1_5!:
  16739.                MOVB SYSTEM.RedirectOut,1
  16740. !cal1_51x:
  16741.                pushl 1000
  16742.                pushl 1000
  16743.                calln32 system.beep
  16744.                //redirect symbol found
  16745.                //Set REDIRECT on TRUE
  16746.                MOVB SYSTEM.Redirect,1
  16747.                MOV EDI,ESI
  16748.                MOV AL,0
  16749. !cal1_51!:
  16750.                DEC EDI
  16751.                CMP EDI,SYSTEM.ArgStart
  16752.                JB !cal1_4
  16753.                CMPB [EDI+0],32
  16754.                JNE !cal1_4
  16755.                MOVB [EDI+0],0
  16756.                JMP !cal1_51!
  16757. !cal1_4:
  16758.                MOV [ESI+0],AL
  16759.                INC ESI
  16760.                CMP AL,0
  16761.                JNE !cal1_1
  16762.                RETN32
  16763. SYSTEM.!CorrectArgList ENDP
  16764.  
  16765. END;
  16766.  
  16767. TYPE
  16768.     PSCUFileFormat=^TSCUFileFormat;
  16769.     TSCUFileFormat=RECORD
  16770.                          Version:STRING[5];
  16771.                          ObjectOffset,ObjectLen:LONGINT;
  16772.                          NameTableOffset,NameTableLen:LONGINT;
  16773.                          ResourceOffset,ResourceLen:LONGINT;
  16774.                          ObjectCount:LONGINT;
  16775.                          UseEntry:LONGINT; {used by project management}
  16776.                          NextEntry:POINTER;
  16777.                    END;
  16778.  
  16779. PROCEDURE AddSCUData(Data:PSCUFileFormat);
  16780. VAR p:PSCUFileFormat;
  16781. BEGIN
  16782.      p:=Data^.NextEntry;
  16783.      Data^.NextEntry:=SCUPointer;
  16784.      SCUPointer:=Data;
  16785.      IF LongWord(p)=$FFFFFFFF THEN
  16786.      BEGIN
  16787.           p:=Data;
  16788.           inc(p,Data^.ResourceOffset+Data^.ResourceLen);
  16789.           AddSCUData(p);
  16790.      END;
  16791. END;
  16792.  
  16793. TYPE
  16794.     PDFMFileFormat=^TDFMFileFormat;
  16795.     TDFMFileFormat=RECORD
  16796.                          EntryData:POINTER;
  16797.                          EntryLen:LONGWORD;
  16798.                          NextEntry:PDFMFileFormat;
  16799.                    END;
  16800.  
  16801. PROCEDURE AddDFMData(Data:PDFMFileFormat;DataLen:LONGWORD);
  16802. VAR Temp:PDFMFileFormat;
  16803. BEGIN
  16804.      new(Temp);
  16805.      Temp^.EntryData:=Data;
  16806.      Temp^.EntryLen:=DataLen;
  16807.      Temp^.NextEntry:=SCUPointer;
  16808.      SCUPointer:=Temp;
  16809. END;
  16810.  
  16811. VAR ArgStart:POINTER;
  16812.     EnvStart:POINTER;
  16813.     SysTlsSize:LONGWORD;
  16814.  
  16815. {$IFDEF OS2}
  16816. IMPORTS
  16817.    FUNCTION DosCreateThread(VAR aptid:LONGWORD;pfn:POINTER;param:POINTER;flag:LONGWORD;
  16818.                             cbStack:LONGWORD):LONGWORD;
  16819.                    APIENTRY;             'DOSCALLS' index 311;
  16820.    FUNCTION DosKillThread(atid:LONGWORD):LONGWORD;
  16821.                    APIENTRY;             'DOSCALLS' index 111;
  16822.    FUNCTION DosSleep(msec:LONGWORD):LONGWORD;
  16823.                     APIENTRY;             'DOSCALLS' index 229;
  16824. END;
  16825. {$ENDIF}
  16826.  
  16827. {$IFDEF WIN95}
  16828. IMPORTS
  16829.    FUNCTION CreateThread(ThreadAttrs:Pointer;Stack:LONGWORD;
  16830.                          lpStartAddress:POINTER;
  16831.                          lpParameter:POINTER;dwCreationFlags:LONGWORD;
  16832.                          VAR lpThreadId:LONGWORD):LONGWORD;
  16833.                   APIENTRY;  'KERNEL32' name 'CreateThread';
  16834.    PROCEDURE ExitThread(ExitCode:LONGWORD);
  16835.                   APIENTRY;  'KERNEL32' name 'ExitThread';
  16836.    FUNCTION TlsAlloc:LONGWORD;
  16837.                   APIENTRY;  'KERNEL32' name 'TlsAlloc';
  16838.    FUNCTION TlsGetValue(dwTlsIndex:LONGWORD):POINTER;
  16839.                   APIENTRY;  'KERNEL32' name 'TlsGetValue';
  16840.    FUNCTION TlsSetValue(dwTlsIndex:LONGWORD;lpTlsValue:POINTER):LONGBOOL;
  16841.                   APIENTRY;  'KERNEL32' name 'TlsSetValue';
  16842.    FUNCTION TlsFree(dwTlsIndex:LONGWORD):LONGBOOL;
  16843.                   APIENTRY;  'KERNEL32' name 'TlsFree';
  16844. END;
  16845. {$ENDIF}
  16846.  
  16847. {$IFDEF OS2}
  16848. TYPE
  16849.     PTlsData=^TTlsData;
  16850.     TTlsData=ARRAY[0..1023] OF Pointer;
  16851.  
  16852. VAR TlsData:PTlsData;
  16853. {$ENDIF}
  16854. {$IFDEF WIN95}
  16855. VAR TlsIndex:LONGWORD;
  16856.     MainTls:POINTER;
  16857. {$ENDIF}
  16858.  
  16859. TYPE
  16860.     PThreadData=^TThreadData;
  16861.     TThreadData=RECORD
  16862.                       f:TThreadFunc;
  16863.                       p:Pointer;
  16864.                 END;
  16865.  
  16866. {$HINTS OFF}
  16867. PROCEDURE NewTlsData(id:LONGWORD;Data:POINTER);
  16868. BEGIN
  16869.      {$IFDEF OS2}
  16870.      IF TlsData=NIL THEN
  16871.      BEGIN
  16872.           DosAllocMem(TlsData,sizeof(TTlsData),PAG_READ OR PAG_WRITE OR PAG_COMMIT);
  16873.           FillChar(TlsData^,sizeof(TTlsData),0);
  16874.      END;
  16875.  
  16876.      TlsData^[id]:=Data;
  16877.      {$ENDIF}
  16878.      {$IFDEF WIN95}
  16879.      TlsSetValue(TlsIndex,Data);
  16880.      {$ENDIF}
  16881. END;
  16882. {$HINTS ON}
  16883.  
  16884. FUNCTION GetThreadId:LONGWORD;
  16885. BEGIN
  16886.      {$IFDEF OS2}
  16887.      ASM
  16888.         MOV EDI,$0c
  16889.         db $64
  16890.         MOV EBX,[EDI]          //MOV EBX,FS:[EDI]
  16891.         MOV EBX,[EBX]          //get thread ID
  16892.         MOV result,EBX
  16893.      END;
  16894.      {$ENDIF}
  16895.      {$IFDEF WIN95}
  16896.      result:=GetCurrentThreadId;
  16897.      {$ENDIF}
  16898. END;
  16899.  
  16900. FUNCTION SysThreadProc(Param:PThreadData):LONGINT;CDECL;
  16901. VAR f:TThreadFunc;
  16902.     p:Pointer;
  16903.     Data:POINTER;
  16904.     Diff:LONGWORD;
  16905. BEGIN
  16906.      f:=Param^.f;
  16907.      p:=Param^.p;
  16908.      Dispose(Param);
  16909.  
  16910.      Diff:=SysTlsSize+4096;
  16911.      Diff:=Diff DIV 4096;
  16912.      Diff:=Diff*4096;
  16913.  
  16914.      //provide local thread storage on the stack and clear it
  16915.      ASM
  16916.         MOV EDI,ESP
  16917.         SUB EDI,4
  16918.         SUB ESP,Diff
  16919.         MOV Data,ESP
  16920.         //Fill the TLS area with 0
  16921.         MOV ECX,Diff
  16922.         SHR ECX,2
  16923.         MOV EAX,0
  16924.         STD
  16925.         REP
  16926.         STOSD
  16927.         CLD
  16928.      END;
  16929.  
  16930.      NewTlsData(GetThreadId-1,Data);
  16931.      result:=f(p);
  16932.  
  16933.      EndThread(0);
  16934. END;
  16935.  
  16936. {$HINTS OFF}
  16937. FUNCTION BeginThread(SecurityAttrs:POINTER;StackSize:LONGWORD;
  16938.                      ThreadFunc:TThreadFunc;Parameter:Pointer;
  16939.                      Options:LONGWORD;VAR id:LONGWORD):LONGWORD;
  16940. VAR Data:PThreadData;
  16941. BEGIN
  16942.      inc(StackSize,SysTlsSize+4096);
  16943.      New(Data);
  16944.      Data^.f:=ThreadFunc;
  16945.      Data^.p:=Parameter;
  16946.      {$IFDEF OS2}
  16947.      DosCreateThread(result,@SysThreadProc,Data,Options,StackSize);
  16948.      id:=0;
  16949.      {$ENDIF}
  16950.      {$IFDEF WIN95}
  16951.      result:=CreateThread(SecurityAttrs,StackSize,@SysThreadProc,Data,Options,id);
  16952.      {$ENDIF}
  16953. END;
  16954. {$HINTS ON}
  16955.  
  16956. {$IFDEF WIN95}
  16957. IMPORTS
  16958.    FUNCTION TerminateThread(hThread:LONGWORD;dwExitCode:LONGWORD):LONGBOOL;
  16959.                   APIENTRY;  'KERNEL32' name 'TerminateThread';
  16960. END;
  16961. {$ENDIF}
  16962.  
  16963. PROCEDURE KillThread(atid:LONGWORD);
  16964. {$IFDEF OS2}
  16965. VAR r:LONGWORD;
  16966. {$ENDIF}
  16967. BEGIN
  16968.      {$IFDEF OS2}
  16969.      REPEAT
  16970.            r := DosKillThread(atid);
  16971.            IF r = 170 THEN DosSleep(50);  //wait a while
  16972.      UNTIL r <> 170;
  16973.      {$ENDIF}
  16974.      {$IFDEF WIN95}
  16975.      TerminateThread(atid,0);
  16976.      {$ENDIF}
  16977. END;
  16978.  
  16979.  
  16980. PROCEDURE EndThread(ExitCode:LONGINT);
  16981. BEGIN
  16982.      {$IFDEF OS2}
  16983.      DosExit(0,ExitCode);
  16984.      {$ENDIF}
  16985.      {$IFDEF WIN95}
  16986.      ExitThread(ExitCode);
  16987.      {$ENDIF}
  16988. END;
  16989.  
  16990. ASSEMBLER
  16991.  
  16992. {$IFDEF OS2}
  16993. SYSTEM.!GetTlsVar PROC NEAR32
  16994.       PUSH EDI
  16995.       PUSH EBX
  16996.  
  16997.       MOV EDI,$0c
  16998.       db $64
  16999.       MOV EBX,[EDI]          //MOV EBX,FS:[EDI]
  17000.       MOV EBX,[EBX]          //get thread ID
  17001.       MOV EAX,[EAX]          //get offset
  17002.       DEC EBX
  17003.       MOV EDI,SYSTEM.TlsData
  17004.       LEA EDI,[EDI+EBX*4]
  17005.       CMPD [EDI],0
  17006.       JNE !TlsOk
  17007.       //this thread was not started using BeginThread,
  17008.       //use global variable instead
  17009.       MOV EDI,SYSTEM.TlsData
  17010. !TlsOk:
  17011.       ADD EAX,[EDI]          //Add offset of local Tls segments
  17012.  
  17013.       POP EBX
  17014.       POP EDI
  17015.       RETN32
  17016. SYSTEM.!GetTlsVar ENDP
  17017. END;
  17018. {$ENDIF}
  17019. {$IFDEF WIN95}
  17020. SYSTEM.!GetTlsVar PROC NEAR32
  17021.       PUSH EBX
  17022.       PUSH ECX
  17023.       PUSH EDX
  17024.       PUSH ESI
  17025.       PUSH EDI
  17026.  
  17027.       PUSH EAX
  17028.  
  17029.       PUSH DWORD PTR SYSTEM.TlsIndex
  17030.       CALLDLL KERNEL32,'TlsGetValue'
  17031.       CMP EAX,0
  17032.       JNE !TlsOk
  17033.       //this thread was not started using BeginThread,
  17034.       //use global variable instead
  17035.       MOV EAX,SYSTEM.MainTls
  17036. !TlsOk:
  17037.       POP EBX
  17038.       ADD EAX,[EBX]   //Add offset
  17039.  
  17040.       POP EDI
  17041.       POP ESI
  17042.       POP EDX
  17043.       POP ECX
  17044.       POP EBX
  17045.       RETN32
  17046. SYSTEM.!GetTlsVar ENDP
  17047. END;
  17048. {$ENDIF}
  17049.  
  17050. {$IFDEF OS2}
  17051. PROCEDURE SystemInit(HeapSize,TheStackSize,TLSSize:LONGWORD);
  17052. VAR
  17053.    ff:^FileRec;
  17054.    ESPA:LONGWORD;
  17055.    Data:POINTER;
  17056. BEGIN
  17057.      ASM
  17058.         MOV ESPA,ESP
  17059.         MOVD SYSTEM.MemPageSize,8192
  17060.      END;
  17061.      SysTLSSize:=TLSSize;
  17062.      TlsData:=NIL;
  17063.      DosAllocMem(Data,SysTlsSize,PAG_READ OR PAG_WRITE OR PAG_COMMIT);
  17064.      NewTlsData(0,Data);
  17065.      StackSize:=TheStackSize;
  17066.      MinStack:=(ESPA-StackSize)+16384;
  17067.      IF DLLModule<>0 THEN ExitProc:=@ExitAllDLL
  17068.      ELSE ExitProc:=@ExitAll;
  17069.      RedirectIn:=FALSE;
  17070.      RedirectOut:=FALSE;
  17071.      Redirect:=FALSE;
  17072.      ASM
  17073.         //Initialize FPU
  17074.         FINIT
  17075.         FCLEX
  17076.         FLDCW SYSTEM.FPUControl
  17077.         FWAIT
  17078.  
  17079.         //correct arguments
  17080.         CALLN32 SYSTEM.!CorrectArgList
  17081.      END;
  17082.  
  17083.      FileBufSize:=32760;   {Standard file buffer size}
  17084.  
  17085.      ff:=@Input;
  17086.      ff^.Handle:=0; {Handle to standard input}
  17087.      ff^.RecSize:=1;
  17088.      ff^.Name:='';
  17089.      ff^.EAS:=NIL;
  17090.      ff^.Flags:=$6666;
  17091.      ff^.Mode:=0;
  17092.      ff^.Buffer:=NIL;
  17093.      ff^.MaxCacheMem:=0;
  17094.      ff^.Offset:=0;
  17095.      ff^.LOffset:=0;
  17096.      ff^.Block:=0;
  17097.      ff^.LBlock:=0;
  17098.      ff^.Reserved1:=0;
  17099.      ff^.BufferBytes:=0;
  17100.  
  17101.      ff:=@Output;
  17102.      ff^.Handle:=1; {Handle to standard output}
  17103.      ff^.RecSize:=1;
  17104.      ff^.Name:='';
  17105.      ff^.EAS:=NIL;
  17106.      ff^.Flags:=$6666;
  17107.      ff^.Mode:=0;
  17108.      ff^.Buffer:=NIL;
  17109.      ff^.MaxCacheMem:=0;
  17110.      ff^.Offset:=0;
  17111.      ff^.LOffset:=0;
  17112.      ff^.Block:=0;
  17113.      ff^.LBlock:=0;
  17114.      ff^.Reserved1:=0;
  17115.      ff^.BufferBytes:=0;
  17116.  
  17117.      HeapError:=StdHeapError;
  17118.      IF DosCreateMutexSem(NIL,HeapMutex,DC_SEM_SHARED,FALSE)<>0
  17119.        THEN RunError(218);
  17120.      HeapStrategyBestFit:=FALSE;
  17121.      LastHeapPage:=NIL;
  17122.      LastHeapPageAdr:=NIL;
  17123.      IF not CreateSystemHeap(HeapSize*1024) THEN RunError(218);
  17124.  
  17125.      {Initialize system variables}
  17126.      OpenedFilesCount:=0;
  17127.      InOutRes:=0;
  17128.      FileMode:=fmInOut;
  17129.      SeekMode:=0; {File BEGIN}
  17130.      SetTrigMode(rad);
  17131. END;
  17132. {$ENDIF}
  17133. {$IFDEF WIN95}
  17134. IMPORTS
  17135. FUNCTION GetCommandLine:PChar;
  17136.                   APIENTRY;  'KERNEL32' name 'GetCommandLineA';
  17137. FUNCTION GetModuleHandle(CONST lpModuleName:CSTRING):LONGWORD;
  17138.                   APIENTRY;  'KERNEL32' name 'GetModuleHandleA';
  17139. END;
  17140.  
  17141. PROCEDURE SystemInit(HeapSize,TheStackSize,TLSSize:LONGWORD);
  17142. VAR ff:^FileRec;
  17143.     ESPA:LONGWORD;
  17144.     Data:Pointer;
  17145.     SA:SECURITY_ATTRIBUTES;
  17146. BEGIN
  17147.      ASM
  17148.         MOV ESPA,ESP
  17149.      END;
  17150.      SysTLSSize:=TLSSize;
  17151.      TlsIndex:=TlsAlloc;
  17152.      Data:=GlobalAlloc(0,SysTlsSize);
  17153.      MainTls:=Data;
  17154.      NewTlsData(0,Data);
  17155.      StackSize:=TheStackSize;
  17156.      MinStack:=(ESPA-StackSize)+16384;
  17157.      ExcptList:=NIL;
  17158.      ArgStart:=GetCommandLine;
  17159.      DllModule:=GetModuleHandle(NIL);
  17160.      RedirectIn:=FALSE;
  17161.      RedirectOut:=FALSE;
  17162.      Redirect:=FALSE;
  17163.  
  17164.      IF ModuleCount<>0 THEN ExitProc:=@ExitAllDLL
  17165.      ELSE ExitProc:=@ExitAll;
  17166.      ASM
  17167.         //Initialize FPU
  17168.         FINIT
  17169.         FCLEX
  17170.         FLDCW SYSTEM.FPUControl
  17171.         FWAIT
  17172.  
  17173.         //correct arguments
  17174.         //CALLN32 SYSTEM.!CorrectArgList
  17175.      END;
  17176.  
  17177.      FileBufSize:=32760;   {Standard file buffer size}
  17178.  
  17179.      ff:=@Input;
  17180.      ff^.Handle:=GetStdHandle(-10); {Handle to standard input}
  17181.      ff^.RecSize:=1;
  17182.      ff^.Name:='';
  17183.      ff^.EAS:=NIL;
  17184.      ff^.Flags:=$6666;
  17185.      ff^.Mode:=0;
  17186.      ff^.Buffer:=NIL;
  17187.      ff^.MaxCacheMem:=0;
  17188.      ff^.Offset:=0;
  17189.      ff^.LOffset:=0;
  17190.      ff^.Block:=0;
  17191.      ff^.LBlock:=0;
  17192.      ff^.Reserved1:=0;
  17193.      ff^.BufferBytes:=0;
  17194.  
  17195.      ff:=@Output;
  17196.      ff^.Handle:=GetStdHandle(-11); {Handle to standard output}
  17197.      ff^.RecSize:=1;
  17198.      ff^.Name:='';
  17199.      ff^.EAS:=NIL;
  17200.      ff^.Flags:=$6666;
  17201.      ff^.Mode:=0;
  17202.      ff^.Buffer:=NIL;
  17203.      ff^.MaxCacheMem:=0;
  17204.      ff^.Offset:=0;
  17205.      ff^.LOffset:=0;
  17206.      ff^.Block:=0;
  17207.      ff^.LBlock:=0;
  17208.      ff^.Reserved1:=0;
  17209.      ff^.BufferBytes:=0;
  17210.  
  17211.      HeapError:=StdHeapError;
  17212.      IF not CreateSystemHeap(HeapSize*1024) THEN RunError(218);
  17213.      OpenedFilesCount:=0;
  17214.      InOutRes:=0;
  17215.      FileMode:=fmInOut;
  17216.      SeekMode:=0; {File BEGIN}
  17217.      SetTrigMode(rad);
  17218.  
  17219.  
  17220.      SA.nLength:=sizeof(SA);
  17221.      SA.lpSecurityDescriptor:=Nil;
  17222.      SA.bInheritHandle:=True;
  17223.      ExcptMutex:=CreateMutex(SA,FALSE,NIL);
  17224.      SetUnhandledExceptionFilter(@ExcptHandler);
  17225.  
  17226.      ScreenInOut.Create;
  17227.  
  17228.      exit;
  17229.  
  17230.      Asm
  17231.          CALLN32 SYSTEM.!ExceptionList //to get it linked
  17232.          CALLN32 SYSTEM.!DebugPresent  //to get it linked
  17233.      End;
  17234. END;
  17235.  
  17236. {$ENDIF}
  17237.  
  17238. {$IFDEF OS2}
  17239. TYPE
  17240.             POINTL=RECORD
  17241.                   x:LONGINT;
  17242.                   y:LONGINT;
  17243.             END;
  17244.  
  17245.             QMSG=RECORD
  17246.                hwnd:LONGWORD;
  17247.                msg:LONGWORD;
  17248.                mp1:LONGWORD;
  17249.                mp2:LONGWORD;
  17250.                time:LONGWORD;
  17251.                ptl:POINTL;
  17252.                reserved:LONGWORD;
  17253.             END;
  17254.  
  17255. PROCEDURE MainDispatchLoop;
  17256. VAR _qmsg:QMSG;
  17257. BEGIN
  17258.      ASM
  17259. !ndis:
  17260.         PUSHL 0
  17261.         PUSHL 0
  17262.         PUSHL 0
  17263.         LEA EAX,_qmsg
  17264.         PUSH EAX
  17265.         PUSH DWORD PTR SYSTEM.AppHandleIntern
  17266.         MOV AL,5
  17267.         CALLDLL PMWIN,915  //WinGetMsg
  17268.         ADD ESP,20
  17269.         CMP EAX,0
  17270.         JE !exdis
  17271.  
  17272.         LEA EAX,_qmsg
  17273.         PUSH EAX
  17274.         PUSH DWORD PTR SYSTEM.AppHandleIntern
  17275.         MOV AL,2
  17276.         CALLDLL PMWIN,912  //WinDispatchMsg
  17277.         ADD ESP,8
  17278.         JMP !ndis
  17279. !exdis:
  17280.      END;
  17281. END;
  17282. {$ENDIF}
  17283.  
  17284. {$IFDEF WIN95}
  17285. PROCEDURE MainDispatchLoop;
  17286. VAR msg:RECORD
  17287.               hwnd:LONGWORD;
  17288.               message:LONGWORD;
  17289.               wParam:LONGWORD;
  17290.               lParam:LONGWORD;
  17291.               time:LONGWORD;
  17292.               pt:RECORD x,y:LONGINT; END;
  17293.          END;
  17294.  
  17295. BEGIN
  17296.      while GetMessage (msg,0, 0, 0) DO DispatchMessage (msg);
  17297. END;
  17298. {$ENDIF}
  17299.  
  17300. {*****************************************************************************
  17301.  *                                                                           *
  17302.  * Named resource management                                                 *
  17303.  *                                                                           *
  17304.  *                                                                           *
  17305.  *****************************************************************************}
  17306.  
  17307. TYPE
  17308.      PQuickAccess=^TQuickAccess;
  17309.      TQuickAccess=ARRAY[0..256] OF LONGWORD;
  17310.      PStringListQuickAccess=^TStringListQuickAccess;
  17311.      TStringListQuickAccess=ARRAY[0..1] OF TQuickAccess;
  17312.      PHighestQuickAccess=^THighestQuickAccess;
  17313.      THighestQuickAccess=ARRAY[0..1] OF Byte;
  17314.  
  17315.      PNamedRes=^TNamedRes;
  17316.      TNamedRes=RECORD
  17317.                      Res:POINTER;
  17318.                      {Quick access for string tables, Array of offsets for Item*256}
  17319.                      QuickAccess:PStringListQuickAccess;
  17320.                      HighestQuickAccess:PHighestQuickAccess;
  17321.                      next:PNamedRes;
  17322.                END;
  17323.  
  17324. CONST NamedBitmaps:PNamedRes=NIL;
  17325.       NamedIcons:PNamedRes=NIL;
  17326.       NamedStrings:PNamedRes=NIL;
  17327.  
  17328.  
  17329. FUNCTION AddRes(VAR r:PNamedRes;p:POINTER):PNamedRes;
  17330. BEGIN
  17331.      IF r=NIL THEN
  17332.      BEGIN
  17333.           new(r);
  17334.           result:=r;
  17335.           result^.Next:=NIL;
  17336.      END
  17337.      ELSE
  17338.      BEGIN
  17339.           New(result);
  17340.           result^.Next:=r;
  17341.           r:=result;
  17342.      END;
  17343.  
  17344.      result^.res:=p;
  17345. END;
  17346.  
  17347. PROCEDURE AddIconRes(p:POINTER);
  17348. BEGIN
  17349.      AddRes(NamedIcons,p);
  17350. END;
  17351.  
  17352. PROCEDURE AddBitmapRes(p:POINTER);
  17353. BEGIN
  17354.      AddRes(NamedBitmaps,p);
  17355. END;
  17356.  
  17357. PROCEDURE AddStringTableRes(p:POINTER);
  17358. VAR l:^LONGINT;
  17359.     len:LONGINT;
  17360.     b:^BYTE;
  17361.     s:STRING;
  17362.     Count:LONGWORD;
  17363.     Res:PNamedRes;
  17364. BEGIN
  17365.      Res:=AddRes(NamedStrings,p);
  17366.  
  17367.      //provide somw quick access info...
  17368.      //look how many string tables we have...
  17369.      l:=Res^.res;
  17370.      len:=l^;
  17371.      Count:=0;
  17372.      WHILE len<>0 do
  17373.      BEGIN
  17374.           inc(l,4);  //Skip Len
  17375.           b:=Pointer(l);
  17376.           s[0]:=chr(b^);
  17377.           inc(b);
  17378.           IF s[0]<>#0 THEN move(b^,s[1],ord(s[0]));
  17379.           inc(b,ord(s[0]));
  17380.  
  17381.           l:=Pointer(b);
  17382.           inc(l,Len);
  17383.           len:=l^;
  17384.           inc(Count);
  17385.      END;
  17386.  
  17387.      //Allocate the quick access list
  17388.      GetMem(Res^.QuickAccess,Count*sizeof(TQuickAccess));
  17389.      GetMem(Res^.HighestQuickAccess,Count*SizeOf(Byte));
  17390. END;
  17391.  
  17392. FUNCTION FindRes(r:PNamedRes;Name:STRING;VAR DataLen:LONGWORD):Pointer;
  17393. VAR l:^LONGINT;
  17394.     b:^Byte;
  17395.     len:LONGINT;
  17396.     ps:^STRING;
  17397. BEGIN
  17398.      result:=NIL;
  17399.      DataLen:=0;
  17400.      UpcaseStr(Name);
  17401.      WHILE r<>NIL DO
  17402.      BEGIN
  17403.           l:=r^.res;
  17404.           len:=l^;
  17405.           WHILE len<>0 do
  17406.           BEGIN
  17407.                inc(l,4);  //skip Len
  17408.                b:=Pointer(l);
  17409.  
  17410.                ps:=Pointer(b);
  17411.                inc(b,length(ps^)+1);
  17412.  
  17413.                IF ps^=Name THEN
  17414.                BEGIN
  17415.                     result:=b;
  17416.                     DataLen:=len;
  17417.                     exit;
  17418.                END;
  17419.                l:=Pointer(b);
  17420.                inc(l,Len);
  17421.                len:=l^;
  17422.           END;
  17423.           r:=r^.Next;
  17424.      END;
  17425. END;
  17426.  
  17427. FUNCTION FindIconRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  17428. BEGIN
  17429.      result:=FindRes(NamedIcons,Name,DataLen);
  17430. END;
  17431.  
  17432. FUNCTION FindBitmapRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  17433. BEGIN
  17434.      result:=FindRes(NamedBitmaps,Name,DataLen);
  17435. END;
  17436.  
  17437. FUNCTION FindStringTableRes(CONST Name:STRING;VAR DataLen:LONGWORD):Pointer;
  17438. BEGIN
  17439.      //The String Table includes 2 WORDS at offset 0 and 2 that specify the
  17440.      //minimum and maximum index for that table
  17441.      result:=FindRes(NamedStrings,Name,DataLen);
  17442. END;
  17443.  
  17444. FUNCTION GetStringTableEntry(CONST Table:STRING;Ident:WORD):STRING;
  17445. VAR StringTable:^LONGWORD;
  17446.     Len:LONGWORD;
  17447.     TableMax:LONGWORD;
  17448.     Found:BOOLEAN;
  17449.     l:^LONGINT;
  17450.     b:^Byte;
  17451.     r:PNamedRes;
  17452.     Name:STRING;
  17453.     ps:^STRING;
  17454.     MinIndex,MaxIndex:WORD;
  17455.     ModIdent:WORD;
  17456.     Count:LONGWORD;
  17457.     Quick:PQuickAccess;
  17458. LABEL weiter;
  17459. BEGIN
  17460.      //the string table may be present more than once !!!
  17461.      Result:='';
  17462.  
  17463.      ModIdent:=Ident SHR 8;
  17464.      Len:=0;
  17465.      Name:=Table;
  17466.      UpcaseStr(Name);
  17467.      r:=NamedStrings;
  17468.      WHILE r<>NIL DO
  17469.      BEGIN
  17470.           l:=r^.res;
  17471.           len:=l^;
  17472.           Count:=0;
  17473.           WHILE len<>0 do
  17474.           BEGIN
  17475.                inc(l,4);  //skip Len
  17476.                b:=Pointer(l);
  17477.  
  17478.                ps:=Pointer(b);
  17479.                inc(b,length(ps^)+1);
  17480.  
  17481.                IF ps^=Name THEN
  17482.                BEGIN
  17483.                     StringTable:=Pointer(b);
  17484.  
  17485.                     TableMax:=LONGWORD(StringTable);
  17486.                     inc(TableMax,Len-4);
  17487.  
  17488.                     MinIndex:=StringTable^ AND 65535;
  17489.                     inc(StringTable,2);
  17490.                     MaxIndex:=StringTable^ AND 65535;
  17491.                     inc(StringTable,2);
  17492.                     IF ((Ident<MinIndex)OR(Ident>MaxIndex)) THEN goto weiter; //cannot be this table !
  17493.  
  17494.                     //use quick access info !
  17495.                     Quick:=@r^.QuickAccess^[Count];
  17496.                     IF ((Quick^[ModIdent]=0)AND(ModIdent>0)) THEN inc(StringTable,Quick^[r^.HighestQuickAccess^[Count]])
  17497.                     ELSE inc(StringTable,Quick^[ModIdent]);
  17498.                     Found:=FALSE;
  17499.                     ASM
  17500.                        MOV EAX,StringTable
  17501.                        MOV BX,Ident
  17502. !GSL1:
  17503.                        MOV CX,[EAX]
  17504.                        TEST CX,255
  17505.                        JNE !GSL4
  17506.  
  17507.                        //Store this entry into r^.QuickAccess
  17508.                        SHR CX,8
  17509.                        MOVZX ECX,CX
  17510.                        SHL ECX,2
  17511.                        MOV EDI,Quick
  17512.                        ADD EDI,ECX
  17513.                        MOV ECX,EAX
  17514.                        SUB ECX,b
  17515.                        SUB ECX,4
  17516.                        MOV [EDI],ECX
  17517.                        MOV CX,[EAX]
  17518.  
  17519.                        MOV EDI,r
  17520.                        MOV EDI,[EDI].TNamedRes.HighestQuickAccess
  17521.                        ADD EDI,Count
  17522.                        MOV DX,CX
  17523.                        SHR DX,8
  17524.                        MOV DH,[EDI]
  17525.                        DEC DH
  17526.                        CMP DL,DH
  17527.                        JB !GSL4
  17528.                        JE !GSLOk1Fix
  17529.  
  17530.                        //Fill remaining items with value
  17531.                        PUSH EAX
  17532.                        PUSH EBX
  17533.                        PUSH ECX
  17534.                        PUSH EDI
  17535.  
  17536.                        MOVZX ECX,DH
  17537.                        MOVZX EBX,DL
  17538.                        MOV EDI,Quick
  17539.                        ADD EDI,ECX
  17540.                        MOV EAX,[EDI]
  17541. !GSLLoop1:
  17542.                        ADD EDI,4
  17543.                        MOV [EDI],EAX
  17544.                        INC ECX
  17545.                        CMP ECX,EBX
  17546.                        JB !GSLLoop1
  17547.  
  17548.                        POP EDI
  17549.                        POP ECX
  17550.                        POP EBX
  17551.                        POP EAX
  17552. !GSLOk1Fix:
  17553.                        MOV [EDI],DL
  17554. !GSL4:
  17555.                        CMP CX,BX
  17556.                        JNE !GSL2
  17557.  
  17558.                        //found
  17559.                        MOVB Found,1
  17560.                        ADD EAX,2
  17561.                        MOV StringTable,EAX
  17562.                        JMP !GSL3
  17563. !GSL2:
  17564.                        JA !GSL3  //list is sorted !
  17565.                        ADD EAX,2
  17566.                        MOVZXB ECX,[EAX]
  17567.                        INC ECX
  17568.                        ADD EAX,ECX
  17569.  
  17570.                        CMP EAX,TableMax
  17571.                        JB !GSL1
  17572. !GSL3:
  17573.                     END;
  17574.  
  17575.                     IF Found THEN
  17576.                     BEGIN
  17577.                          Move(StringTable^,Result,(StringTable^ AND 255)+1);
  17578.                          exit;
  17579.                     END;
  17580.                END;
  17581. weiter:
  17582.                l:=Pointer(b);
  17583.                inc(l,Len);
  17584.                len:=l^;
  17585.                inc(Count);
  17586.           END;
  17587.           r:=r^.Next;
  17588.      END; //while
  17589. END;
  17590.  
  17591. {$HINTS OFF}
  17592. PROCEDURE SystemEnd{(ReturnCode:Word)};
  17593. BEGIN
  17594.      {$IFDEF WIN95}
  17595.      TlsFree(TlsIndex);
  17596.      {$ENDIF}
  17597.      Halt(0);
  17598. END;
  17599. {$HINTS ON}
  17600.  
  17601. ASSEMBLER
  17602.  
  17603. SYSTEM.!Byte_Bounds4 PROC NEAR32
  17604.     DD 0,255
  17605. SYSTEM.!Byte_Bounds4 ENDP
  17606.  
  17607. SYSTEM.!Word_Bounds4 PROC NEAR32
  17608.     DD 0,65535
  17609. SYSTEM.!Word_Bounds4 ENDP
  17610.  
  17611. SYSTEM.!ShortInt_Bounds4 PROC NEAR32
  17612.     DB $80,$FF,$FF,$FF,$7f,0,0,0
  17613. SYSTEM.!ShortInt_Bounds4 ENDP
  17614.  
  17615. SYSTEM.!Integer_Bounds4 PROC NEAR32
  17616.     DB 0,$80,$FF,$FF,$FF,$7f,0,0
  17617. SYSTEM.!Integer_Bounds4 ENDP
  17618.  
  17619. SYSTEM.!Byte_Bounds2 PROC NEAR32
  17620.     DW 0,255
  17621. SYSTEM.!Byte_Bounds2 ENDP
  17622.  
  17623. SYSTEM.!Word_Bounds2 PROC NEAR32
  17624.     DW 0,65535
  17625. SYSTEM.!Word_Bounds2 ENDP
  17626.  
  17627. SYSTEM.!ShortInt_Bounds2 PROC NEAR32
  17628.     DB $80,$FF,$7f,0
  17629. SYSTEM.!ShortInt_Bounds2 ENDP
  17630.  
  17631. SYSTEM.!Integer_Bounds2 PROC NEAR32
  17632.     DB 0,$80,$FF,$7f
  17633. SYSTEM.!Integer_Bounds2 ENDP
  17634.  
  17635. END;
  17636.  
  17637. //************************************************************************
  17638. //
  17639. //
  17640. // VMT and object handling support
  17641. //
  17642. //
  17643. //************************************************************************
  17644.  
  17645. {$IFDEF WIN32}
  17646. Function DispatchDebuggerException(ExceptionCode,ExcptAddr:LongWord):PExcptInfo;
  17647. VAR Dummy:PExcptInfo;
  17648.     ThreadId:LONGWORD;
  17649. LABEL l,l1;
  17650. Begin
  17651.      ThreadId:=GetCurrentThreadId;
  17652.      Result:=Nil;
  17653.  
  17654.      {Search exception handler}
  17655.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  17656.  
  17657.      If ExcptList=Nil Then
  17658.      BEGIN
  17659. l:
  17660.           Result:=Nil;
  17661.           exit;
  17662.      END;
  17663.  
  17664.      dummy:=ExcptList;
  17665.      WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  17666.      WHILE dummy<>NIL DO
  17667.      BEGIN
  17668.           IF dummy^.ThreadId=ThreadId THEN
  17669.           BEGIN
  17670.                Result:=dummy;
  17671.                goto l1;
  17672.           END;
  17673.  
  17674.           dummy:=dummy^.Last;
  17675.      END;
  17676. l1:
  17677.      IF Result=NIL THEN
  17678.         IF ExcptList<>NIL THEN Result:=ExcptList;
  17679.  
  17680.      ReleaseMutex(ExcptMutex);
  17681.  
  17682.      IF Result=NIL THEN goto l;
  17683.  
  17684.      Registerinfo:= #13#10'at EIP ='+ToHex(LONGWORD(ExcptAddr));
  17685.  
  17686.      //Handle all hardware exceptions
  17687.      //all other exceptions will be notified by an exception class
  17688.      CASE ExceptionCode OF
  17689.          EXCEPTION_BREAKPOINT:
  17690.            Result^.ExcptObject:=EBreakPoint.Create('Breakpoint exception (EBreakPoint) occured'+
  17691.                                              RegisterInfo);
  17692.          EXCEPTION_STACK_OVERFLOW:
  17693.            Result^.ExcptObject:=EStackFault.Create('Stack fault exception (EStackFault) occured'+
  17694.                                              RegisterInfo);
  17695.          EXCEPTION_ACCESS_VIOLATION:
  17696.            Result^.ExcptObject:=EGPFault.Create('Access violation exception (EGPFault) occured'+
  17697.                                           RegisterInfo);
  17698.          EXCEPTION_IN_PAGE_ERROR:
  17699.            Result^.ExcptObject:=EPageFault.Create('Page fault exception (EPageFault) occured'+
  17700.                                             RegisterInfo);
  17701.          EXCEPTION_ILLEGAL_INSTRUCTION,EXCEPTION_PRIV_INSTRUCTION:
  17702.            Result^.ExcptObject:=EInvalidOpCode.Create('Invalid instruction exception (EInvalidOpCode) occured'+
  17703.                                             RegisterInfo);
  17704.          EXCEPTION_SINGLE_STEP:
  17705.            Result^.ExcptObject:=ESingleStep.Create('Single step exception (ESingleStep) occured'+
  17706.                                             RegisterInfo);
  17707.          EXCEPTION_INT_DIVIDE_BY_ZERO:
  17708.            Result^.ExcptObject:=EDivByZero.Create('Integer divide by zero exception (EDivByZero) occured'+
  17709.                                             RegisterInfo);
  17710.          EXCEPTION_INT_OVERFLOW:
  17711.            Result^.ExcptObject:=EIntOverFlow.Create('Integer overflow exception (EIntOverFlow) occured'+
  17712.                                             RegisterInfo);
  17713.          EXCEPTION_FLT_DIVIDE_BY_ZERO:
  17714.            Result^.ExcptObject:=EZeroDivide.Create('Float zero divide exception (EZeroDivide) occured'+
  17715.                                             RegisterInfo);
  17716.          EXCEPTION_FLT_INVALID_OPERATION:
  17717.            Result^.ExcptObject:=EInvalidOp.Create('Float invalid operation exception (EInvalidOp) occured'+
  17718.                                             RegisterInfo);
  17719.          EXCEPTION_FLT_OVERFLOW:
  17720.            Result^.ExcptObject:=EOverFlow.Create('Float overflow exception (EOverFlow) occured'+
  17721.                                             RegisterInfo);
  17722.          EXCEPTION_FLT_UNDERFLOW:
  17723.            Result^.ExcptObject:=EUnderFlow.Create('Float underflow exception (EUnderFlow) occured'+
  17724.                                             RegisterInfo);
  17725.          EXCEPTION_FLT_DENORMAL_OPERAND,EXCEPTION_FLT_INEXACT_RESULT,
  17726.          EXCEPTION_FLT_STACK_CHECK:
  17727.             Result^.ExcptObject:=EMathError.Create('General float exception (EMathError) occured'+
  17728.                                             RegisterInfo);
  17729.          EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
  17730.             Result^.ExcptObject:=ERangeError.Create('Range check error exception (ERangeError) occured'+
  17731.                                             RegisterInfo);
  17732.          EXCEPTION_INTERNAL_RTL:
  17733.          BEGIN
  17734.               //Found^.ExcptObject already set !
  17735.               //result:=EXCEPTION_CONTINUE_EXECUTION;
  17736.               //exit;
  17737.          END;
  17738.          ELSE goto l; {Don't handle}
  17739.      END; {case}
  17740.  
  17741.      {Win95 generated exception}
  17742.      //Found^.ExcptObject.ReportRecord:=ExceptionInfo.ExceptionRecord^;
  17743.      Result^.ExcptObject.ExcptNum:=ExceptionCode;
  17744.      //Found^.ExcptObject.ContextRecord:=ExceptionInfo.ContextRecord^;
  17745.      Result^.ExcptObject.ExcptAddr:=Pointer(ExcptAddr);
  17746. End;
  17747.  
  17748. Var Handler:Pointer;
  17749. {$ENDIF}
  17750.  
  17751. {$D+}
  17752.  
  17753. {$IFDEF WIN32}
  17754. ASSEMBLER
  17755.  
  17756. SYSTEM.!ExceptionList PROC NEAR32
  17757.       PUSH EAX //ExceptionCode
  17758.       PUSH EBX //ExcptAddr
  17759.       CALLN32 SYSTEM.DispatchDebuggerException
  17760.  
  17761.       CMP EAX,0
  17762.       JNE !ExceptionHandlerPresent
  17763.  
  17764.       PUSHL 0
  17765.       CALLN32 SYSTEM.ExcptRunError
  17766.  
  17767. !ExceptionHandlerPresent:
  17768.       MOV EBX,[EAX].TExcptInfo.ExcptAddr
  17769.       MOV Handler,EBX
  17770.       MOV EBX,[EAX].TExcptInfo.OldEBP
  17771.       MOV EBP,EBX
  17772.       MOV EBX,[EAX].TExcptInfo.OldESP
  17773.       MOV ESP,EBX
  17774.       MOV EAX,[EAX].TExcptInfo.ExcptObject
  17775.       MOV EDI,OFFSET(Handler)
  17776.       JMP [EDI] //Run Exception
  17777. SYSTEM.!ExceptionList ENDP
  17778.  
  17779. SYSTEM.!DebugPresent PROC NEAR32
  17780.       DD OFFSET(ProcessDebugged)
  17781. SYSTEM.!DebugPresent ENDP
  17782.  
  17783. END;
  17784. {$ENDIF}
  17785.  
  17786. ASSEMBLER
  17787.  
  17788. SYSTEM.!VMTCall PROC NEAR32
  17789.         MOV EBX,ESP
  17790.         MOV EDI,[EBX+4]
  17791.         MOV EDI,[EDI+0]
  17792.         CMP EDI,0
  17793.         JNE !VmtWeiter
  17794.         MOV EDI,[EBX+4]
  17795.         CMPD [EDI+4],0
  17796.         JNE !VmtConstructor
  17797.         PUSHL 214
  17798.         CALLN32 SYSTEM.RunError
  17799. !VmtConstructor:
  17800.         MOV EDI,[EDI+4]
  17801. !VmtWeiter:
  17802.         LEA EDI,[EDI+EAX*4]
  17803.         JMP [EDI+0]
  17804. SYSTEM.!VMTCall ENDP
  17805.  
  17806. SYSTEM.!VMTENDCALL PROC NEAR32
  17807.         RETN32
  17808. SYSTEM.!VMTENDCALL ENDP
  17809.  
  17810. //VMT call for virtual class functions
  17811. SYSTEM.!VMTCall1 PROC NEAR32
  17812.         MOV ECX,ESP
  17813.         MOV EDI,[ECX+4]
  17814.         CMP EDI,0       //no SELF specified
  17815.         JNE !normal
  17816.         MOV EDI,EBX
  17817.         JMP !weiter
  17818. !normal:
  17819.         MOV EDI,[EDI+0]
  17820. !weiter:
  17821.         CMP EDI,0
  17822.         JNE !VmtWeiter
  17823.         MOV EDI,[ECX+4]
  17824.         CMPD [EDI+4],0
  17825.         JNE !VmtConstructor
  17826.         PUSHL 214
  17827.         CALLN32 SYSTEM.RunError
  17828. !VmtConstructor:
  17829.         MOV EDI,[EDI+4]
  17830. !VmtWeiter:
  17831.         LEA EDI,[EDI+EAX*4]
  17832.         JMP [EDI+0]
  17833. SYSTEM.!VMTCall1 ENDP
  17834.  
  17835. END;
  17836.  
  17837. FUNCTION IsConsole:BOOLEAN;
  17838. BEGIN
  17839.      result:=ApplicationType<>1;
  17840. END;
  17841.  
  17842. FUNCTION IsLibrary:BOOLEAN;
  17843. BEGIN
  17844.      result:=DllModule<>0;
  17845. END;
  17846.  
  17847.  
  17848. ///////////////// TRACE Funktion ////////////////
  17849.  
  17850. CONST
  17851.     CM_TRACE = $8111;
  17852.     SibylHandle:LONGWORD = 0;
  17853.  
  17854.     IMPORTS
  17855.        {$IFDEF OS2}
  17856.        FUNCTION WinSendMsg(ahwnd:LONGWORD;msg:LONGWORD;mp1,mp2:LONGWORD):LONGWORD;
  17857.                            APIENTRY; 'PMWIN' index 920;
  17858.        {$ENDIF}
  17859.        {$IFDEF Win32}
  17860.        FUNCTION SendMessage(ahWnd:LONGWORD;Msg:LONGWORD;awParam:LONGWORD;alParam:LONGINT):LONGINT;
  17861.                            APIENTRY; 'USER32' name 'SendMessageA';
  17862.        {$ENDIF}
  17863.     END;
  17864.  
  17865.  
  17866. PROCEDURE Trace(CONST Value:STRING);
  17867. VAR  psm:PString;
  17868. BEGIN
  17869.      IF SibylHandle = 0 THEN exit;
  17870.  
  17871.      {allocate Shared Memory for the string}
  17872.      GetSharedMem(psm, Length(Value)+1);
  17873.      psm^ := Value;
  17874.  
  17875.      {$IFDEF OS2}
  17876.      WinSendMsg(SibylHandle,CM_TRACE,LONGWORD(psm),0);
  17877.      {$ENDIF}
  17878.      {$IFDEF Win32}
  17879.      SendMessage(SibylHandle,CM_TRACE,LONGWORD(psm),0);
  17880.      {$ENDIF}
  17881.  
  17882.      {deallocate Shared Memory}
  17883.      FreeSharedMem(psm, Length(Value)+1);
  17884. END;
  17885.  
  17886. ///////////////////////////////////////////////////
  17887.  
  17888. (*
  17889. PROCEDURE TraceGetMem(VAR p:POINTER;size:LONGWORD);
  17890. BEGIN
  17891.      IF SibylHandle = 0 THEN exit;
  17892.  
  17893.      {$IFDEF OS2}
  17894.      WinSendMsg(SibylHandle,CM_TRACE+1,LONGWORD(p),size);
  17895.      {$ENDIF}
  17896.      {$IFDEF Win32}
  17897.      SendMessage(SibylHandle,CM_TRACE+1,LONGWORD(p),size);
  17898.      {$ENDIF}
  17899. END;
  17900.  
  17901.  
  17902. PROCEDURE TraceFreeMem(VAR p:POINTER;size:LONGWORD);
  17903. BEGIN
  17904.      IF SibylHandle = 0 THEN exit;
  17905.  
  17906.      {$IFDEF OS2}
  17907.      WinSendMsg(SibylHandle,CM_TRACE+2,LONGWORD(p),size);
  17908.      {$ENDIF}
  17909.      {$IFDEF Win32}
  17910.      SendMessage(SibylHandle,CM_TRACE+2,LONGWORD(p),size);
  17911.      {$ENDIF}
  17912. END;
  17913. *)
  17914.  
  17915. VAR  smfh:^LONGWORD;
  17916.  
  17917. BEGIN
  17918.      {$IFDEF OS2}
  17919.      IF AccessNamedSharedMem('SIBYL_MAINFORM_HANDLE', smfh) THEN
  17920.      BEGIN
  17921.           SibylHandle := smfh^;
  17922.           {Referenz auf das Shared Memory Objekt wieder freigeben}
  17923.           FreeSharedMem(smfh, SizeOf(LONGWORD));
  17924.      END
  17925.      ELSE
  17926.      {$ENDIF}
  17927.      SibylHandle := 0;
  17928. END.
  17929.  
  17930.  
  17931.  
  17932.