home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sp15demo.zip / libsrc.zip / LIBSRC / SYSTEM.PAS < prev    next >
Pascal/Delphi Source File  |  1996-02-23  |  466KB  |  18,767 lines
  1. UNIT System;
  2.  
  3. {$S-,I-,Q-,R-}
  4.  
  5. {$IFDEF OS2}
  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.  
  51.     PDATETIME=^DATETIME;
  52.     DATETIME=RECORD
  53.                   CASE INTEGER OF
  54.                      1: ( hour:BYTE;
  55.                           min:BYTE;
  56.                           sec:BYTE;
  57.                           hundredths:BYTE;
  58.                           day:BYTE;
  59.                           month:BYTE;
  60.                           year:WORD;
  61.                           timezone:INTEGER;
  62.                           weekday:BYTE;
  63.                         );
  64.                      2: ( hours:BYTE;
  65.                           minutes:BYTE;
  66.                           seconds:BYTE;
  67.                         );
  68.              END;
  69.  
  70.     {Generic procedure pointer}
  71.     TProcedure = procedure;
  72.  
  73. // Memory management functions
  74.  
  75. TYPE
  76.     HeapFunc=FUNCTION(size:LONGWORD):Integer;
  77.  
  78. VAR
  79.     HeapOrg:Pointer;           {Bottom of heap}
  80.     HeapEnd:Pointer;           {End of heap}
  81.     HeapPtr:Pointer;           {Actual heap position}
  82.     FreeList:Pointer;          {List of free blocks}
  83.     HeapTop:POINTER;           {Highest heap adress that has been commited}
  84.     HeapSize:LONGWORD;         {Size of heap}
  85.     HeapError:HeapFunc;        {Heap Error Function}
  86.     HeapResult:LONGWORD;       {Result from last heap function}
  87.     {MemAvailBytes:LONGWORD;}
  88. CONST
  89.     FillMemoryWithZero:BOOLEAN=FALSE;
  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. PROCEDURE Mark(VAR p:POINTER);
  96. PROCEDURE Release(VAR p:POINTER);
  97. PROCEDURE FreeMem(p:pointer;size:LongWord);
  98. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  99. PROCEDURE GetAPIMem(VAR p:POINTER;size:LONGWORD);
  100. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  101. PROCEDURE NewSystemHeap;
  102. FUNCTION  CreateSystemHeap(Size:LONGWORD):BOOLEAN;
  103. PROCEDURE DestroySystemHeap;
  104. PROCEDURE DestroyHeap(Heap:POINTER);
  105. {Use this rotines to synchronize heap access when a thread is killed and
  106.  you don't know the state of the thread. This prevents heap corruption}
  107. PROCEDURE RequestHeapMutex;
  108. PROCEDURE ReleaseHeapMutex;
  109.  
  110. // Error functions
  111. VAR
  112.    ExitCode:LONGWORD;
  113.    ErrorAdr:POINTER;
  114.    ExitProc:POINTER;
  115.  
  116. PROCEDURE RunError(Code:LONGWORD);
  117. PROCEDURE Halt(Code:LONGWORD);
  118.  
  119. // Random numbers support
  120. VAR
  121.    RandSeed:LONGWORD;
  122.  
  123. PROCEDURE Randomize;
  124. FUNCTION  Random(value:word):word;
  125.  
  126. //Direct memory access
  127. PROCEDURE MOVE(CONST source;VAR dest;size:LongWord);
  128. PROCEDURE FILLCHAR(VAR dest;size:LongWord;value:byte);
  129.  
  130. //LongJmp support
  131.  
  132. TYPE Jmp_Buf=ARRAY[0..8] OF LONGWORD;
  133.  
  134. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  135. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  136.  
  137.  
  138. //String functions
  139. PROCEDURE UpcaseStr(VAR s:STRING);
  140. FUNCTION POS(CONST item,source:STRING):BYTE;
  141. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  142. PROCEDURE SubStr(VAR source:STRING;start,ende:Byte);
  143. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  144. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  145. FUNCTION ToHex(l:LONGWORD):STRING;
  146.  
  147. //Floating point support
  148. CONST
  149.     rad=1;
  150.     deg=2;
  151.     gra=3;
  152.  
  153. VAR
  154.     IsNotRad:BOOLEAN;
  155.     ToRad,FromRad:EXTENDED;
  156.     FPUResult:WORD;
  157.  
  158. PROCEDURE SetTrigMode(mode:BYTE);
  159.  
  160. CONST
  161.      PI=3.141592653589793240;
  162.  
  163.  
  164. //CLASS support
  165.  
  166. {TYPE
  167.       (* Class structures layout, particulary also valid for objects *)
  168.       PClassInfoLayout=^TClassInfoLayout;
  169.       TClassInfoLayout=RECORD
  170.                              ClassSize:LONGWORD;
  171.                              ParentObjectAddr:POINTER;
  172.                              FieldAdress:POINTER;
  173.                              (*Class Info following here*)
  174.                        END;
  175.  
  176.       PDmtLayout=^TDmtLayout;
  177.       TDmtLayout=RECORD
  178.                        NumDmts:LONGWORD;  (*Number of entries*)
  179.                        (*entries follow here
  180.                          each entry is 8 byte long
  181.                          the first DWord contains the message id,
  182.                          the second DWord contains the VMT index*)
  183.                  END;
  184.  
  185.       PVmtLayOut=^TVmtLayOut;
  186.       TVmtLayOut=RECORD
  187.                        Dmt:PDmtLayout;  (*Pointer to DMT*)
  188.                        ClassInfo:PClassInfoLayout;
  189.                        ClassSize:LONGWORD;
  190.                        VmtSize:LONGWORD; (*Number of entries*)
  191.                        (*entries follow here
  192.                          each entry is 4 byte long and contains
  193.                          the address for that VMT index*)
  194.                  END;
  195.       TClassLayout=RECORD
  196.                          Vmt:PVmtLayout;
  197.                          (*Object variables follow here*)
  198.                    END;}
  199.  
  200. TYPE
  201.     TObject = CLASS;
  202.     TClass  = CLASS OF TObject;
  203.     TObject = CLASS
  204.       CONSTRUCTOR Create;
  205.       DESTRUCTOR Destroy; VIRTUAL;
  206.       PROCEDURE Free;VIRTUAL;
  207.       CLASS FUNCTION NewInstance: TObject; VIRTUAL;
  208.       PROCEDURE FreeInstance; virtual;
  209.       CLASS FUNCTION InitInstance(Instance: Pointer): TObject;
  210.       CLASS FUNCTION ClassType: TClass;
  211.       CLASS FUNCTION ClassName: STRING;
  212.       CLASS FUNCTION ClassUnit: STRING;
  213.       CLASS FUNCTION ClassParent: TClass;
  214.       CLASS FUNCTION GetClassInfo: POINTER; //conflicts with PMWIN CLASSINFO
  215.       CLASS FUNCTION InstanceSize: LONGWORD;
  216.       CLASS FUNCTION InheritsFrom(AClass: TClass): BOOLEAN;
  217.       PROCEDURE DefaultHandler(VAR Message); VIRTUAL;
  218.       PROCEDURE DefaultFrameHandler(VAR Message); VIRTUAL;
  219.       PROCEDURE Dispatch(VAR Message);
  220.       PROCEDURE DispatchCommand(VAR Message;Command:LONGWORD);
  221.       PROCEDURE FrameDispatch(VAR Message);
  222.       CLASS FUNCTION MethodAddress(CONST Name: STRING): POINTER;
  223.       CLASS FUNCTION MethodName(Address: POINTER): STRING;
  224.       FUNCTION FieldAddress(Name: STRING): POINTER;
  225.     END;
  226.  
  227. //TextScreen IO support
  228. VAR
  229.    Input,Output:TEXT;
  230.  
  231. CONST
  232.      { CRT modes }
  233.      BW40          = 0;            { 40x25 B/W on Color Adapter   }
  234.      CO40          = 1;            { 40x25 Color on Color Adapter }
  235.      BW80          = 2;            { 80x25 B/W on Color Adapter   }
  236.      CO80          = 3;            { 80x25 Color on Color Adapter }
  237.      Mono          = 7;            { 80x25 on Monochrome Adapter  }
  238.      Font8x8       = 256;          { Add-in for 8x8 font          }
  239.  
  240. VAR
  241.    WindMin: WORD;    { Window upper left coordinates  }
  242.    WindMax: WORD;    { Window lower right coordinates }
  243.    LastMode: Word;   { Current text mode              }
  244.    TextAttr: BYTE;   { Current text attribute         }
  245.  
  246.    ApplicationType:BYTE;
  247.  
  248. CONST
  249.    DirectVideo: BOOLEAN = False; { Enable direct video addressing }
  250.    CheckSnow: BOOLEAN   = True;  { Enable snow filtering }
  251.  
  252. TYPE TScreenInOutClass=CLASS
  253.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  254.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  255.          PROCEDURE WriteLF;VIRTUAL;
  256.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  257.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  258.      END;
  259.  
  260.      TPMScreenInOutClass=CLASS
  261.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  262.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  263.          PROCEDURE WriteLF;VIRTUAL;
  264.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  265.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  266.          PROCEDURE Error;
  267.      END;
  268.  
  269.      IMPORTS
  270.           FUNCTION WinInitializeAPI(flOptions:LONGWORD):LONGWORD;
  271.                           APIENTRY;             PMWIN index 763;
  272.           FUNCTION WinTerminateAPI(ahab:LONGWORD):BOOLEAN;
  273.                          APIENTRY;             PMWIN index 888;
  274.           FUNCTION WinCreateMsgQueueAPI(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  275.                           APIENTRY;             PMWIN index 716;
  276.           FUNCTION WinDestroyMsgQueueAPI(ahmq:LONGWORD):BOOLEAN;
  277.                           APIENTRY;             PMWIN index 726;
  278.      END;
  279.  
  280. VAR ScreenInOut:TScreenInOutClass;
  281.  
  282. VAR
  283.     VioScrollDnProc:FUNCTION (usTopRow,usLeftCol,usBotRow,usRightCol,
  284.                               cbLines:LONGWORD;VAR pCell;ahvio:LONGWORD):WORD;CDECL;
  285.     VioScrollUpProc:FUNCTION (usTopRow,usLeftCol,usBotRow,usRightCol,
  286.                               cbLines:LONGWORD;VAR pCell;ahvio:LONGWORD):WORD;CDECL;
  287.     VioGetModeProc:FUNCTION (VAR apvioModeInfo;ahvio:LONGWORD):WORD;CDECL;
  288.     VioSetModeProc:FUNCTION (VAR apvioModeInfo;ahvio:LONGWORD):WORD;CDECL;
  289.     VioWhereXProc:FUNCTION:BYTE;CDECL;
  290.     VioWhereYProc:FUNCTION:BYTE;CDECL;
  291.     VioSetCurPosProc:FUNCTION (usRow,usColumn:LONGWORD;ahvio:LONGWORD):WORD;CDECL;
  292.     VioReadCellStrProc:FUNCTION (VAR pchCellStr;VAR pcb:WORD;usRow,
  293.                                  usColumn:LONGWORD;ahvio:LONGWORD):WORD;CDECL;
  294.     VioGetConfigProc:FUNCTION (usConfigId:LONGWORD;VAR pvioin;
  295.                                ahvio:LONGWORD):WORD;CDECL;
  296.     KbdStringInProc: FUNCTION (VAR apch;VAR pchIn;fsWait:LONGWORD;
  297.                                ahkbd:LONGWORD):WORD;CDECL;
  298.     ReadKeyProc:FUNCTION:CHAR;CDECL;
  299.     KeyPressedProc:FUNCTION:BOOLEAN;CDECL;
  300.  
  301. //File I/O support
  302.  
  303. TYPE
  304.       {Extended attributes information returned by GetEAInfo}
  305.       PFEADATA=^TFEADATA;
  306.       TFEADATA=ARRAY[0..65535] OF BYTE;
  307.       PHOLDFEA=^THOLDFEA;
  308.       THOLDFEA=RECORD
  309.                      {oNextEntryOffset:LONGWORD; // new field}
  310.                      fEA:BYTE;                  // Flag byte
  311.                      cbName:BYTE;
  312.                      cbValue:WORD;
  313.                      szName:CSTRING;
  314.                      aValue:PFEADATA;
  315.                      Deleted:BOOLEAN;           //true to delete EA on write
  316.                      next:PHOLDFEA;
  317.       END;
  318.  
  319.       P_FileBuffer=^T_FileBuffer;
  320.       T_FileBuffer=ARRAY[0..MaxLongInt-1] OF BYTE; {handled dynamically}
  321.  
  322.       FileRec = RECORD
  323.                       Handle          : LongWord;     {FileHandle            }
  324.                       RecSize         : LongWord;     {Record size           }
  325.                       Name            : STRING;       {(Long) file name      }
  326.                       EAS             : PHOLDFEA;     {extended attributes   }
  327.                       Mode            : LONGWORD;     {Current file mode     }
  328.                       Reserved        : POINTER;      {for private extensions}
  329.                       Block           : LONGWORD;     {current block in file }
  330.                       LBlock          : LONGWORD;     {Last block in file    }
  331.                       Offset          : LONGWORD;     {Current offset in Block}
  332.                       LOffset         : LONGWORD;     {Last Offset in LBlock }
  333.                       Changed         : LONGBOOL;     {TRUE if Block has changed}
  334.                       Buffer          : P_FileBuffer; {I/O Buffer            }
  335.                       MaxCacheMem     : LONGWORD;     {Size of I/O Buffer    }
  336.                       Flags           : LONGWORD;     {Assign flags $6666    }
  337.                       Reserved1       : WORD;         {dont use              }
  338.                       BufferBytes     : WORD;         {dont use              }
  339.                       {312 byte til here}
  340.                 END;
  341.  
  342. VAR
  343.    IOResult:LONGWORD;
  344.  
  345. CONST
  346.    //Sharing options - use this way: FileMode:=(FileMode AND 15) OR Value;
  347.    fmDenyRead   = $30;   {deny read access by other processes         }
  348.    fmDenyWrite  = $20;   {deny write access by other processes        }
  349.    fmDenyNone   = $40;   {deny neither read nor write                 }
  350.    fmDenyBoth   = $10;   {deny both read and write access (standard)  }
  351.  
  352.    {FileMode values}
  353.    fmClosed     = 0;
  354.    fmInput      = 0 OR fmDenyWrite; {Read only                                   }
  355.    fmOutput     = 1 OR fmDenyRead;  {Write only                                  }
  356.    fmInOut      = 2 OR fmDenyNone;  {allow both read and write access (standard) }
  357.  
  358. CONST
  359.    {Seek Origin Constants}
  360.    Seek_Begin     = 0;   //Seek from beginning of file
  361.    Seek_Current   = 1;   //Seek from current position of file
  362.    Seek_End       = 2;   //Seek from end of file
  363.  
  364. VAR
  365.    FileMode:LONGWORD;   {file mode for both reset and rewrite}
  366.    SeekMode:LONGWORD;   {seek mode for seek                  }
  367.  
  368. PROCEDURE Assign(VAR f:FILE;CONST s:STRING);
  369. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  370. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  371. PROCEDURE Close(VAR f:FILE);
  372. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  373. PROCEDURE BlockWrite(VAR f:file;VAR Buf;Count:LongWord;VAR result:LONGWORD);
  374. PROCEDURE Rename(VAR f:file;NewName:String);
  375. PROCEDURE Truncate(VAR f:FILE);
  376. PROCEDURE Append(VAR f:Text);
  377. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  378. FUNCTION SeekEof(VAR F :Text):Boolean;
  379. FUNCTION SeekEoln(VAR F:Text):Boolean;
  380. FUNCTION FilePos(VAR f:FILE):LONGWORD;
  381. FUNCTION FileSize(VAR f:FILE):LONGWORD;
  382. FUNCTION Eof(VAR f:FILE):BOOLEAN;
  383. FUNCTION Eoln(VAR F:Text):Boolean;
  384. PROCEDURE Erase(VAR f:FILE);
  385. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  386. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  387.  
  388. //Funtions for manipulating EAS
  389. //EAS will be written with a DosClose call, but the file should then
  390. //not be occupied by another process or thread, Close must have
  391. //exclusive access to the file or EA setting will fail ! When using
  392. //the standard filemode with fmdenyBoth this is save
  393. FUNCTION GetEAData(VAR f:FILE):PHOLDFEA;
  394. PROCEDURE SetEAData(VAR f:FILE;EAData:PHOLDFEA);
  395. PROCEDURE DeleteEAData(VAR f:FILE);
  396.  
  397. //Functions for manipulating directories
  398. PROCEDURE ChDir(CONST path:STRING);
  399. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  400. PROCEDURE RmDir(CONST dir:STRING);
  401. PROCEDURE MkDir(CONST dir:STRING);
  402.  
  403. FUNCTION  PARAMSTR(item:Byte):STRING;
  404. FUNCTION  PARAMCOUNT:Byte;
  405.  
  406. //Exception Management
  407.  
  408. TYPE
  409.   {
  410.    * ExceptionReportRecord
  411.    *
  412.    * This structure contains machine independant information about an
  413.    * exception/unwind. No system exception will ever have more than
  414.    * EXCEPTION_MAXIMUM_PARAMETERS parameters. User exceptions are not
  415.    * bound to this limit.
  416.    }
  417.   CONST
  418.     EXCEPTION_MAXIMUM_PARAMETERS =4;  { Enough for all system exceptions. }
  419.  
  420. TYPE
  421.     PEXCEPTIONREPORTRECORD=^EXCEPTIONREPORTRECORD;
  422.     EXCEPTIONREPORTRECORD=RECORD
  423.              ExceptionNum:LONGWORD;     { exception number }
  424.              fHandlerFlags:LONGWORD;
  425.              NestedExceptionReportRecord:PEXCEPTIONREPORTRECORD;
  426.              ExceptionAddress:POINTER;
  427.              cParameters:LONGWORD; { Size of Exception Specific Info }
  428.              ExceptionInfo:ARRAY[0..EXCEPTION_MAXIMUM_PARAMETERS] OF LONGWORD;
  429.     END;
  430.  
  431.     {
  432.      * ExceptionRegistrationRecord
  433.      *
  434.      * These are linked together to form a chain of exception handlers that
  435.      * will be dispatched to upon receipt of an exception.
  436.     }
  437.     _ERR=POINTER; {Exception handler entry address}
  438.  
  439.     Exception=Class;  {forward definition}
  440.  
  441.     PEXCEPTIONREGISTRATIONRECORD=^EXCEPTIONREGISTRATIONRECORD;
  442.     EXCEPTIONREGISTRATIONRECORD=RECORD
  443.               prev_structure:PEXCEPTIONREGISTRATIONRECORD;
  444.               ExceptionHandler:_ERR;
  445.               {this fields are new !!}
  446.               ObjectType:Exception;
  447.               jmpWorker:jmp_buf;
  448.     END;
  449.  
  450.     PFPEG=^FPREG;
  451.     FPREG=RECORD {pack 1}
  452.                losig:LONGWORD;
  453.                hisig:LONGWORD;
  454.                signexp:WORD;
  455.           END;
  456.  
  457.     PCONTEXTRECORD=^CONTEXTRECORD;
  458.     CONTEXTRECORD=RECORD
  459.                   ContextFlags:LONGWORD;
  460.                   ctx_env:ARRAY[0..6] OF LONGWORD;
  461.                   ctx_stack:ARRAY[0..7] OF FPREG;
  462.                   ctx_SegGs:LONGWORD;
  463.                   ctx_SegFs:LONGWORD;
  464.                   ctx_SegEs:LONGWORD;
  465.                   ctx_SegDs:LONGWORD;
  466.                   ctx_RegEdi:LONGWORD;
  467.                   ctx_RegEsi:LONGWORD;
  468.                   ctx_RegEax:LONGWORD;
  469.                   ctx_RegEbx:LONGWORD;
  470.                   ctx_RegEcx:LONGWORD;
  471.                   ctx_RegEdx:LONGWORD;
  472.                   ctx_RegEbp:LONGWORD;
  473.                   ctx_RegEip:LONGWORD;
  474.                   ctx_SegCs:LONGWORD;
  475.                   ctx_EFlags:LONGWORD;
  476.                   ctx_RegEsp:LONGWORD;
  477.                   ctx_SegSs:LONGWORD;
  478.            END;
  479.  
  480.   { Exceptions }
  481.   //base exception record - derive all new exceptions from that !
  482.   Exception = CLASS(TObject)
  483.       PRIVATE
  484.             FMessage: PString;
  485.             FUNCTION GetMessage: STRING;
  486.             PROCEDURE SetMessage(CONST Value: STRING);
  487.       PUBLIC
  488.             ReportRecord:EXCEPTIONREPORTRECORD;
  489.             ExcptNum:LONGWORD;
  490.             CameFromRTL:BOOLEAN;
  491.             Nested:BOOLEAN;
  492.             ExcptAddr:POINTER;
  493.             RTLExcptAddr:POINTER;
  494.             RegistrationRecord:EXCEPTIONREGISTRATIONRECORD;
  495.             ContextRecord:CONTEXTRECORD;
  496.  
  497.             CONSTRUCTOR Create(CONST Msg: STRING);
  498.             DESTRUCTOR Destroy;OVERRIDE;
  499.       PROPERTY
  500.             Message:STRING read GetMessage write SetMessage;
  501.       PROPERTY
  502.             MessagePtr: PString read FMessage;
  503.   END;
  504.  
  505.   //General exception class
  506.   ExceptClass = class OF Exception;
  507.  
  508.   //Software generated excpetions
  509.   EProcessTerm = CLASS(Exception);
  510.  
  511.   //Hardware generated exceptions
  512.   EProcessorException = CLASS(Exception);
  513.   EFault = CLASS(EProcessorException);
  514.   EGPFault = CLASS(EFault);
  515.   EStackFault = CLASS(EFault);
  516.   EPageFault = CLASS(EFault);
  517.   EInvalidOpCode = CLASS(EFault);
  518.   EBreakpoint = CLASS(EProcessorException);
  519.   ESingleStep = CLASS(EProcessorException);
  520.  
  521.   //Memory exceptions
  522.   EOutOfMemory = CLASS(Exception);
  523.   EInvalidPointer = CLASS(Exception);
  524.   EInvalidHeap    = CLASS(Exception);
  525.  
  526.   //Input/Output exceptions
  527.   EInOutError = CLASS(Exception)
  528.      PUBLIC
  529.            ErrorCode: Integer;
  530.   END;
  531.   EFileNotFound=CLASS(EInOutError);
  532.   EInvalidFileName=CLASS(EInOutError);
  533.   ETooManyOpenFiles=CLASS(EInOutError);
  534.   EAccessDenied=CLASS(EInOutError);
  535.   EEndOfFile=CLASS(EInOutError);
  536.   EDiskFull=CLASS(EInOutError);
  537.   EInvalidInput=CLASS(EInOutError);
  538.  
  539.   //Integer math exceptions
  540.   EIntError = CLASS(Exception);
  541.   EDivByZero = CLASS(EIntError);
  542.   ERangeError = CLASS(EIntError);
  543.   EIntOverflow = CLASS(EIntError);
  544.  
  545.   //Floating point math exceptions
  546.   EMathError = CLASS(Exception);
  547.   EInvalidOp = CLASS(EMathError);
  548.   EZeroDivide = CLASS(EMathError);
  549.   EOverflow = CLASS(EMathError);
  550.   EUnderflow = CLASS(EMathError);
  551.  
  552.   //type cast exceptions
  553.   EInvalidCast = CLASS(Exception);
  554.  
  555.   EConvertError = CLASS(Exception);
  556.  
  557. //PM Routines
  558. VAR
  559.     AppHandle:LONGWORD;
  560.     AppQueueHandle:LONGWORD;
  561.     DllModule:LONGWORD;
  562.     DllTerminating:LONGWORD;
  563.     DllInitTermResult:LONGWORD;
  564.     ModuleCount:BYTE;
  565.  
  566.     RaiseIOError:BOOLEAN;
  567.  
  568. FUNCTION WinInitialize(flOptions:LONGWORD):LONGWORD;
  569. FUNCTION WinTerminate(ahab:LONGWORD):BOOLEAN;
  570. FUNCTION WinCreateMsgQueue(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  571. FUNCTION WinDestroyMsgQueue(ahmq:LONGWORD):BOOLEAN;
  572. PROCEDURE MainDispatchLoop;
  573. PROCEDURE SelToFlat(VAR p:POINTER);
  574.  
  575. FUNCTION Assigned(p: Pointer): Boolean;
  576.  
  577. IMPLEMENTATION
  578.  
  579. //General functions
  580.  
  581. FUNCTION Assigned(p: Pointer): Boolean;
  582. BEGIN
  583.   Assigned := p <> Nil;
  584. END;
  585.  
  586. PROCEDURE Check_Is(o:TObject;ClassInfo:TClass);
  587. VAR bo:BOOLEAN;
  588. BEGIN
  589.      IF o=NIL THEN bo:=FALSE
  590.      ELSE bo:=o.InheritsFrom(ClassInfo);
  591.      ASM
  592.         CMPB $bo,1
  593.         LEAVE
  594.         RETN32 8
  595.      END;
  596. END;
  597.  
  598. PROCEDURE Check_Is_Class(c:TClass;ClassInfo:TClass);
  599. VAR bo:BOOLEAN;
  600. BEGIN
  601.      bo:=c.InheritsFrom(ClassInfo);
  602.      ASM
  603.         CMPB $bo,1
  604.         LEAVE
  605.         RETN32 8
  606.      END;
  607. END;
  608.  
  609. PROCEDURE Check_As(o:TObject;ClassInfo:TClass);
  610. VAR Adr:LONGINT;
  611.     e:EInvalidCast;
  612. BEGIN
  613.      ASM
  614.         MOV EAX,[EBP+4]
  615.         SUB EAX,5
  616.         MOV $Adr,EAX
  617.      END;
  618.      IF not o.InheritsFrom(ClassInfo) THEN
  619.      BEGIN
  620.           e.Create('Invalid type cast (EInvalidCast)');
  621.           e.CameFromRTL:=TRUE;
  622.           e.RTLExcptAddr:=POINTER(Adr);
  623.           raise e;
  624.      END;
  625. END;
  626.  
  627.  
  628. PROCEDURE SelToFlat(VAR p:POINTER);
  629. BEGIN
  630.      asm
  631.        mov edi,$p
  632.        mov eax,[edi+0]
  633.        ror eax,16
  634.        shr ax,3
  635.        rol eax,16
  636.        mov [edi+0],eax
  637.     end;
  638. END;
  639.  
  640.  
  641. PROCEDURE OverflowError;
  642. VAR e:EIntOverflow;
  643.     Adr:LONGWORD;
  644. BEGIN
  645.      ASM
  646.         MOV EAX,[EBP+4]
  647.         SUB EAX,5
  648.         MOV $Adr,EAX
  649.      END;
  650.      e.Create('Integer Overflow (EIntOverflow)');
  651.      e.CameFromRTL:=TRUE;
  652.      e.RTLExcptAddr:=POINTER(Adr);
  653.      Raise e;
  654. END;
  655.  
  656. VAR MinStack:LONGWORD;
  657.     StackSize:LONGWORD;
  658.  
  659. PROCEDURE StackError(Adr:LONGWORD);
  660. VAR e:EStackFault;
  661. BEGIN
  662.      e.Create('Stack overflow (EStackFault)');
  663.      e.CameFromRTL:=TRUE;
  664.      e.RTLExcptAddr:=POINTER(Adr);
  665.      Raise e;
  666. END;
  667.  
  668. PROCEDURE CheckStack(Needed:LONGWORD);
  669. VAR ESP:LONGWORD;
  670.     Adr:LONGWORD;
  671. BEGIN
  672.      ASM
  673.         PUSHAD
  674.         MOV $ESP,ESP
  675.         MOV EAX,[EBP+4]
  676.  
  677.         SUB EAX,5
  678.         MOV $Adr,EAX
  679.      END;
  680.      IF ESP>MinStack THEN IF ESP<MinStack+StackSize THEN
  681.      BEGIN
  682.           IF ((ESP-Needed<MinStack)OR(ESP-Needed>MinStack+StackSize))
  683.             THEN StackError(Adr);
  684.      END;
  685.      ASM
  686.         POPAD
  687.      END;
  688. END;
  689.  
  690. PROCEDURE RangeCheckError(Adr:LONGWORD);
  691. VAR e:ERangeError;
  692. BEGIN
  693.      e.Create('Range check error (ERangeError)');
  694.      e.CameFromRTL:=TRUE;
  695.      e.RTLExcptAddr:=POINTER(Adr);
  696.      Raise e;
  697. END;
  698.  
  699. PROCEDURE CheckRange(U,O,V:LONGINT);
  700. VAR Adr:LONGWORD;
  701. BEGIN
  702.      ASM
  703.         PUSH EAX
  704.         MOV EAX,[EBP+4]
  705.         SUB EAX,5
  706.         MOV $Adr,EAX
  707.  
  708.         MOV EAX,$V
  709.         CMP EAX,$U
  710.         JL !err_this_xxx
  711.         MOV EAX,$V
  712.         CMP EAX,$O
  713.         JG !err_this_xxx
  714.  
  715.         POP EAX
  716.         LEAVE
  717.         RETN32 12
  718. !err_this_xxx:
  719.         POP EAX
  720.         PUSHL $Adr
  721.         CALLN32 SYSTEM.RangeCheckError
  722.      END;
  723. END;
  724.  
  725. PROCEDURE CheckRangeUnsigned(U,O,V:LONGWORD);
  726. VAR Adr:LONGWORD;
  727. BEGIN
  728.      ASM
  729.         PUSH EAX
  730.         MOV EAX,[EBP+4]
  731.         SUB EAX,5
  732.         MOV $Adr,EAX
  733.  
  734.         MOV EAX,$V
  735.         CMP EAX,$U
  736.         JB !err_this_xxx1
  737.         MOV EAX,$V
  738.         CMP EAX,$O
  739.         JA !err_this_xxx1
  740.  
  741.         POP EAX
  742.         LEAVE
  743.         RETN32 12
  744. !err_this_xxx1:
  745.         POP EAX
  746.         PUSHL $Adr
  747.         CALLN32 SYSTEM.RangeCheckError
  748.      END;
  749. END;
  750.  
  751. PROCEDURE CheckRange2(Nr,V:LONGINT);
  752. VAR Adr:LONGWORD;
  753. BEGIN
  754.      ASM
  755.          PUSH EAX
  756.          MOV EAX,[EBP+4]
  757.          SUB EAX,5
  758.          MOV $Adr,EAX
  759.  
  760.          MOV EAX,$Nr
  761.          CMP EAX,1
  762.          JNE !my_lab1
  763.  
  764.          MOV EAX,$V
  765.          CMP EAX,MINSHORTINT
  766.          JL !err_this_xxx2
  767.          CMP EAX,MAXSHORTINT
  768.          JG !err_this_xxx2
  769.          jmp !ex_this_xxx
  770. !my_lab1:
  771.          CMP EAX,2
  772.          JNE !my_lab2
  773.  
  774.          MOV EAX,$V
  775.          CMP EAX,MININT
  776.          JL !err_this_xxx2
  777.          CMP EAX,MAXINT
  778.          JG !err_this_xxx2
  779.          jmp !ex_this_xxx
  780. !my_lab2:
  781.          CMP EAX,4
  782.          JNE !ex_this_xxx
  783.  
  784.          MOV EAX,$V
  785.          CMP EAX,MINLONGINT
  786.          JL !err_this_xxx2
  787.          CMP EAX,MAXLONGINT
  788.          JG !err_this_xxx2
  789. !ex_this_xxx:
  790.          POP EAX
  791.          LEAVE
  792.          RETN32 8
  793. !err_this_xxx2:
  794.          POP EAX
  795.          PUSHL $Adr
  796.          CALLN32 SYSTEM.RangeCheckError
  797.      END;
  798. END;
  799.  
  800. PROCEDURE CheckRangeUnsigned2(Nr,V:LONGWORD);
  801. VAR Adr:LONGWORD;
  802. BEGIN
  803.      ASM
  804.          PUSH EAX
  805.          MOV EAX,[EBP+4]
  806.          SUB EAX,5
  807.          MOV $Adr,EAX
  808.  
  809.          MOV EAX,$Nr
  810.          CMP EAX,1
  811.          JNE !my_lab1w
  812.  
  813.          MOV EAX,$V
  814.          CMP EAX,MINBYTE
  815.          JB !err_this_xxx2w
  816.          CMP EAX,MAXBYTE
  817.          JA !err_this_xxx2w
  818.          jmp !ex_this_xxxw
  819. !my_lab1w:
  820.          CMP EAX,2
  821.          JNE !my_lab2w
  822.  
  823.          MOV EAX,$V
  824.          CMP EAX,MINWORD
  825.          JB !err_this_xxx2w
  826.          CMP EAX,MAXWORD
  827.          JA !err_this_xxx2w
  828.          jmp !ex_this_xxxw
  829. !my_lab2w:
  830.          CMP EAX,4
  831.          JNE !ex_this_xxxw
  832.  
  833.          MOV EAX,$V
  834.          CMP EAX,MINLONGWORD
  835.          JB !err_this_xxx2w
  836.          CMP EAX,MAXLONGWORD
  837.          JA !err_this_xxx2w
  838. !ex_this_xxxw:
  839.          POP EAX
  840.          LEAVE
  841.          RETN32 8
  842. !err_this_xxx2w:
  843.          POP EAX
  844.          PUSHL $Adr
  845.          CALLN32 SYSTEM.RangeCheckError
  846.      END;
  847. END;
  848.  
  849. FUNCTION Swap(i:INTEGER):INTEGER;
  850. BEGIN
  851.      Swap:=lo(i)*256+hi(i);
  852. END;
  853.  
  854. VAR
  855.    MaxWindMin: WORD;    { Max Window upper left coordinates  }
  856.    MaxWindMax: WORD;    { Max Window lower right coordinates }
  857.    Redirect,RedirectOut,RedirectIn:BOOLEAN;
  858.  
  859. //PM routines
  860.  
  861. IMPORTS
  862.   FUNCTION WinMessageBox(hwndParent,hwndOwner:LONGWORD;pszText,pszCaption:CSTRING;
  863.                          idWindow,flStyle:LONGWORD):LONGWORD;
  864.                           APIENTRY;             PMWIN index 789;
  865. END;
  866.  
  867. TYPE
  868.     PTIB2=^TIB2;
  869.     TIB2=RECORD
  870.               tib2_ultid:LONGWORD;             { Thread I.D. }
  871.               tib2_ulpri:LONGWORD;             { Thread priority }
  872.               tib2_version:LONGWORD;           { Version number for this structure }
  873.               tib2_usMCCount:WORD;        { Must Complete count }
  874.               tib2_fMCForceFlag:WORD;     { Must Complete force flag }
  875.          END;
  876.  
  877.     PTIB=^TIB;
  878.     TIB=RECORD
  879.               tib_pexchain:POINTER;     { Head of exception handler chain }
  880.               tib_pstack:POINTER;       { Pointer to base of stack }
  881.               tib_pstacklimit:POINTER;  { Pointer to end of stack }
  882.               tib_ptib2:PTIB2;          { Pointer to system specific TIB }
  883.               tib_version:LONGWORD;        { Version number for this TIB structure }
  884.               tib_ordinal:LONGWORD;        { Thread ordinal number        }
  885.         END;
  886.  
  887.  
  888. { Process Information Block (PIB) }
  889.  
  890. TYPE
  891.     PPIB=^PIB;
  892.     PIB=RECORD
  893.              pib_ulpid:LONGWORD;          { Process I.D. }
  894.              pib_ulppid:LONGWORD;         { Parent process I.D. }
  895.              pib_hmte:LONGWORD;           { Program (.EXE) module handle }
  896.              pib_pchcmd:PChar;         { Command line pointer }
  897.              pib_pchenv:PChar;         { Environment pointer }
  898.              pib_flstatus:LONGWORD;       { Process' status bits }
  899.              pib_ultype:LONGWORD;         { Process' type code }
  900.        END;
  901.  
  902. FUNCTION DosGetInfoBlocks(VAR pptib:PTIB;VAR pppib:PPIB):LONGWORD;
  903.                     APIENTRY;    external 'DOSCALLS' index 312;
  904.  
  905. FUNCTION WinInitialize(flOptions:LONGWORD):LONGWORD;
  906. VAR tib:PTIB;
  907.     pib:PPIB;
  908. LABEL l;
  909. BEGIN
  910.      DosGetInfoBlocks(tib,pib);
  911.      IF ((tib<>NIL)AND(tib^.tib_ptib2<>NIL)) THEN
  912.      BEGIN
  913.           IF tib^.tib_ptib2^.tib2_ultid=1 THEN goto l; {1st thread}
  914.           result:=WinInitializeAPI(flOptions);
  915.      END
  916.      ELSE
  917.      BEGIN
  918. l:
  919.           IF AppHandle=0 THEN AppHandle:=WinInitializeAPI(flOptions);
  920.           result:=AppHandle;
  921.      END;
  922. END;
  923.  
  924. FUNCTION WinTerminate(ahab:LONGWORD):BOOLEAN;
  925. BEGIN
  926.      IF ahab=AppHandle THEN
  927.      BEGIN
  928.           WinTerminate:=FALSE;
  929.           exit;
  930.      END;
  931.      WinTerminate:=WinTerminateAPI(ahab);
  932. END;
  933.  
  934. FUNCTION WinCreateMsgQueue(ahab:LONGWORD;cmsg:LONGINT):LONGWORD;
  935. LABEL l;
  936. BEGIN
  937.      IF ahab=AppHandle THEN
  938.      BEGIN
  939.          IF AppQueueHandle<>0 THEN
  940.          BEGIN
  941.               IF cmsg<>0 THEN
  942.               BEGIN
  943.                    WinDestroyMsgQueueAPI(AppQueueHandle);
  944.                    goto l;
  945.               END
  946.               ELSE WinCreateMsgQueue:=AppQueueHandle;
  947.          END
  948.          ELSE
  949.          BEGIN
  950. l:
  951.               AppQueueHandle:=WinCreateMsgQueueAPI(ahab,cmsg);
  952.               result:=AppQueueHandle;
  953.          END;
  954.      END
  955.      ELSE result:=WinCreateMsgQueueAPI(ahab,cmsg);
  956. END;
  957.  
  958. FUNCTION WinDestroyMsgQueue(ahmq:LONGWORD):BOOLEAN;
  959. BEGIN
  960.      IF ahmq=AppQueueHandle THEN result:=FALSE
  961.      ELSE result:=WinDestroyMsgQueueAPI(ahmq);
  962. END;
  963.  
  964. //Exception management
  965.  
  966.  
  967. {The standard exception class}
  968. FUNCTION Exception.GetMessage:STRING;
  969. BEGIN
  970.      GetMessage:=FMessage^;
  971. END;
  972.  
  973. PROCEDURE Exception.SetMessage(CONST Value:STRING);
  974. BEGIN
  975.      IF FMessage<>NIL THEN
  976.        FreeMem(FMessage,length(FMessage^)+1);
  977.      GetMem(FMessage,length(value)+1);
  978.      FMessage^:=value;
  979. END;
  980.  
  981. CONSTRUCTOR Exception.Create(CONST msg:STRING);
  982. BEGIN
  983.      GetMem(FMessage,length(msg)+1);
  984.      FMessage^:=msg;
  985. END;
  986.  
  987. DESTRUCTOR Exception.Destroy;
  988. BEGIN
  989.      IF FMessage<>NIL THEN
  990.        FreeMem(FMessage,length(FMessage^)+1);
  991. END;
  992.  
  993. //OS2 Exception numbers
  994.  
  995. CONST
  996.      XCPT_GUARD_PAGE_VIOLATION       =$80000001;
  997.      XCPT_DATATYPE_MISALIGNMENT      =$C000009E;
  998.      XCPT_BREAKPOINT                 =$C000009F;
  999.      XCPT_SINGLE_STEP                =$C00000A0;
  1000.      XCPT_ACCESS_VIOLATION           =$C0000005;
  1001.      XCPT_ILLEGAL_INSTRUCTION        =$C000001C;
  1002.      XCPT_FLOAT_DENORMAL_OPERAND     =$C0000094;
  1003.      XCPT_FLOAT_DIVIDE_BY_ZERO       =$C0000095;
  1004.      XCPT_FLOAT_INEXACT_RESULT       =$C0000096;
  1005.      XCPT_FLOAT_INVALID_OPERATION    =$C0000097;
  1006.      XCPT_FLOAT_OVERFLOW             =$C0000098;
  1007.      XCPT_FLOAT_STACK_CHECK          =$C0000099;
  1008.      XCPT_FLOAT_UNDERFLOW            =$C000009A;
  1009.      XCPT_INTEGER_DIVIDE_BY_ZERO     =$C000009B;
  1010.      XCPT_INTEGER_OVERFLOW           =$C000009C;
  1011.      XCPT_PRIVILEGED_INSTRUCTION     =$C000009D;
  1012.      XCPT_IN_PAGE_ERROR              =$C0000006;
  1013.      XCPT_PROCESS_TERMINATE          =$C0010001;
  1014.      XCPT_ASYNC_PROCESS_TERMINATE    =$C0010002;
  1015.      XCPT_NONCONTINUABLE_EXCEPTION   =$C0000024;
  1016.      XCPT_INVALID_DISPOSITION        =$C0000025;
  1017.      XCPT_INVALID_LOCK_SEQUENCE      =$C000001D;
  1018.      XCPT_ARRAY_BOUNDS_EXCEEDED      =$C0000093;
  1019.      XCPT_B1NPX_ERRATA_02            =$C0010004;
  1020.      XCPT_UNWIND                     =$C0000026;
  1021.      XCPT_BAD_STACK                  =$C0000027;
  1022.      XCPT_INVALID_UNWIND_TARGET      =$C0000028;
  1023.      XCPT_SIGNAL                     =$C0010003;
  1024.  
  1025.      XCPT_INTERNAL_RTL               =$E0000000;
  1026.  
  1027. {return values}
  1028. CONST
  1029.      XCPT_CONTINUE_SEARCH    =$00000000;     { exception not handled   }
  1030.      XCPT_CONTINUE_EXECUTION =$FFFFFFFF;     { exception handled       }
  1031.      XCPT_CONTINUE_STOP      =$00716668;     { exception handled by    }
  1032.                                              { debugger (VIA DosDebug) }
  1033.  
  1034. VAR
  1035.    RegisterInfo:STRING;
  1036.  
  1037. {The exception handler. Incoming exceptions will come here first}
  1038. FUNCTION ExcptHandler(VAR p1:EXCEPTIONREPORTRECORD;
  1039.                       VAR p2:EXCEPTIONREGISTRATIONRECORD;
  1040.                       VAR p3:CONTEXTRECORD;
  1041.                       pv:POINTER):LONGWORD;CDECL;
  1042. BEGIN
  1043.      {Jump to the label set by setjmp}
  1044.      WITH p3 DO
  1045.        Registerinfo:= #13#10'at CS:EIP  ='+
  1046.                       ToHex(ctx_SegCs )+':'+ToHex(ctx_RegEip);
  1047.  
  1048.  
  1049.      IF POINTER(p2.ObjectType)=NIL THEN {no object associated}
  1050.      BEGIN
  1051.           //Handle all hardware exceptions
  1052.           //all other exceptions will be notified by an exception class
  1053.           CASE p1.ExceptionNum OF
  1054.               XCPT_BREAKPOINT:
  1055.                 p2.ObjectType:=EBreakPoint.Create('Breakpoint exception (EBreakPoint) occured'+
  1056.                                                   RegisterInfo);
  1057.               XCPT_BAD_STACK:
  1058.                 p2.ObjectType:=EStackFault.Create('Stack fault exception (EStackFault) occured'+
  1059.                                                   RegisterInfo);
  1060.               XCPT_ACCESS_VIOLATION:
  1061.                 p2.ObjectType:=EGPFault.Create('Access violation exception (EGPFault) occured'+
  1062.                                                RegisterInfo);
  1063.               XCPT_IN_PAGE_ERROR:
  1064.                 p2.ObjectType:=EPageFault.Create('Page fault exception (EPageFault) occured'+
  1065.                                                  RegisterInfo);
  1066.               XCPT_ILLEGAL_INSTRUCTION,XCPT_PRIVILEGED_INSTRUCTION:
  1067.                 p2.ObjectType:=EInvalidOpCode.Create('Invalid instruction exception (EInvalidOpCode) occured'+
  1068.                                                      RegisterInfo);
  1069.               XCPT_SINGLE_STEP:
  1070.                 p2.ObjectType:=ESingleStep.Create('Single step exception (ESingleStep) occured'+
  1071.                                                   RegisterInfo);
  1072.               XCPT_INTEGER_DIVIDE_BY_ZERO:
  1073.                 p2.ObjectType:=EDivByZero.Create('Integer divide by zero exception (EDivByZero) occured'+
  1074.                                                  RegisterInfo);
  1075.               XCPT_INTEGER_OVERFLOW:
  1076.                 p2.ObjectType:=EIntOverFlow.Create('Integer overflow exception (EIntOverFlow) occured'+
  1077.                                                    RegisterInfo);
  1078.               XCPT_FLOAT_DIVIDE_BY_ZERO:
  1079.                 p2.ObjectType:=EZeroDivide.Create('Float zero divide exception (EZeroDivide) occured'+
  1080.                                                   RegisterInfo);
  1081.               XCPT_FLOAT_INVALID_OPERATION:
  1082.                 p2.ObjectType:=EInvalidOp.Create('Float invalid operation exception (EInvalidOp) occured'+
  1083.                                                  RegisterInfo);
  1084.               XCPT_FLOAT_OVERFLOW:
  1085.                 p2.ObjectType:=EOverFlow.Create('Float overflow exception (EOverFlow) occured'+
  1086.                                                 RegisterInfo);
  1087.               XCPT_FLOAT_UNDERFLOW:
  1088.                 p2.ObjectType:=EUnderFlow.Create('Float underflow exception (EUnderFlow) occured'+
  1089.                                                  RegisterInfo);
  1090.               XCPT_FLOAT_DENORMAL_OPERAND,XCPT_FLOAT_INEXACT_RESULT,
  1091.               XCPT_FLOAT_STACK_CHECK:
  1092.                  p2.ObjectType:=EMathError.Create('General float exception (EMathError) occured'+
  1093.                                                   RegisterInfo);
  1094.               XCPT_PROCESS_TERMINATE: {don't handle}
  1095.               BEGIN
  1096.                    {p2.ObjectType:=EProcessTerm.Create('Process terminated exception (EProcessTerm) occured');}
  1097.                    {}ExcptHandler:=XCPT_CONTINUE_SEARCH;
  1098.                    exit;{}
  1099.               END;
  1100.               XCPT_ASYNC_PROCESS_TERMINATE:  {Don't handle}
  1101.               BEGIN
  1102.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  1103.                    exit;
  1104.               END;
  1105.               XCPT_GUARD_PAGE_VIOLATION: {Don't handle}
  1106.               BEGIN
  1107.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  1108.                    exit;
  1109.               END;
  1110.               XCPT_INTERNAL_RTL:
  1111.               BEGIN
  1112.                    ExcptHandler:=XCPT_CONTINUE_EXECUTION;
  1113.                    exit;
  1114.               END;
  1115.               ELSE  {Don't handle}
  1116.               BEGIN
  1117.                    ExcptHandler:=XCPT_CONTINUE_SEARCH;
  1118.                    exit;
  1119.                    {p2.ObjectType:=EFault.Create('Unknown hardware exception (EFault) occured');}
  1120.               END;
  1121.           END; {case}
  1122.      END;
  1123.      p2.ObjectType.ReportRecord:=p1;
  1124.      p2.ObjectType.RegistrationRecord:=p2;
  1125.      p2.ObjectType.ExcptNum:=p1.ExceptionNum;
  1126.      p2.ObjectType.ExcptAddr:=POINTER(p3.ctx_RegEIP);
  1127.      p2.ObjectType.ContextRecord:=p3;
  1128.      longjmp(p2.jmpWorker,LONGWORD(p2.ObjectType));
  1129. END;
  1130.  
  1131. IMPORTS
  1132.      FUNCTION DosRaiseException(VAR Pexcept:EXCEPTIONREPORTRECORD):LONGWORD;
  1133.                    APIENTRY;             DOSCALLS index 356;
  1134. END;
  1135.  
  1136. PROCEDURE ExcptRunError(e:Exception);
  1137. VAR
  1138.    s:STRING;
  1139.    cs:CSTRING;
  1140.    cTitle:CSTRING;
  1141.    RepRec:EXCEPTIONREPORTRECORD;
  1142. BEGIN
  1143.      try
  1144.         IF e.CameFromRTL THEN IF not e.Nested THEN
  1145.         BEGIN
  1146.              e.Nested:=TRUE;
  1147.              RepRec.ExceptionNum:=XCPT_INTERNAL_RTL;
  1148.              RepRec.fHandlerFlags:=0;
  1149.              RepRec.NestedExceptionReportRecord:=NIL;
  1150.              RepRec.ExceptionAddress:=NIL;
  1151.              RepRec.cParameters:=2;
  1152.              RepRec.ExceptionInfo[0]:=LONGWORD(e.RTLExcptAddr);
  1153.              RepRec.ExceptionInfo[1]:=LONGWORD(e.FMessage);
  1154.              DosRaiseException(RepRec);
  1155.         END;
  1156.      finally
  1157.         e.ExcptAddr:=e.RTLExcptAddr;
  1158.      end;
  1159.  
  1160.      IF POINTER(e.ExcptAddr)<>NIL THEN
  1161.        s:='Exception occured: '+e.Message+' at '+tohex(LONGWORD(e.ExcptAddr))+
  1162.            #13#10'Program is terminated.'
  1163.      ELSE
  1164.        s:='Exception occured: '+e.Message+
  1165.            #13#10'Program is terminated.';
  1166.  
  1167.      IF ApplicationType=1 THEN
  1168.      BEGIN
  1169.           cs:=s;
  1170.           cTitle:='Exception occured';
  1171.           WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  1172.      END
  1173.      ELSE Writeln(s);
  1174.      Halt;
  1175. END;
  1176.  
  1177. PROCEDURE RaiseException(objekt:Exception;adress:LONGWORD);
  1178. VAR
  1179.    PRegisRec:PEXCEPTIONREGISTRATIONRECORD;  {top exception registration record}
  1180.    ReportRec:EXCEPTIONREPORTRECORD;
  1181.    ContextRec:CONTEXTRECORD;
  1182.    RepRec:EXCEPTIONREPORTRECORD;
  1183. BEGIN
  1184.      ASM
  1185.         MOV ESI,0
  1186.         db $64   //SEG FS
  1187.         MOV EAX,[ESI+0]
  1188.         MOV $PRegisRec,EAX
  1189.      END;
  1190.  
  1191.      IF LONGWORD(PRegisRec)=$ffffffff THEN {no handler installed}
  1192.      BEGIN
  1193.           ExcptRunError(objekt);
  1194.      END;
  1195.  
  1196.      PRegisRec^.ObjectType:=objekt;  {set exception type}
  1197.      {set up context record}
  1198.      fillchar(ContextRec,sizeof(CONTEXTRECORD),0);
  1199.      {set up report record}
  1200.      fillchar(ReportRec,sizeof(EXCEPTIONREPORTRECORD),0);
  1201.      IF Adress=0 THEN
  1202.      BEGIN
  1203.           ASM
  1204.              MOV EAX,[EBP+4]
  1205.              MOV $Adress,EAX
  1206.           END;
  1207.      END;
  1208.  
  1209.      {Objekt.Nested:=TRUE;}
  1210.      {Objekt.CameFromRTL:=TRUE;}
  1211.      Objekt.RTLExcptAddr:=POINTER(Adress);
  1212.      RepRec.ExceptionNum:=XCPT_INTERNAL_RTL;
  1213.      RepRec.fHandlerFlags:=0;
  1214.      RepRec.NestedExceptionReportRecord:=NIL;
  1215.      RepRec.ExceptionAddress:=NIL;
  1216.      RepRec.cParameters:=2;
  1217.      RepRec.ExceptionInfo[0]:=LONGWORD(Objekt.RTLExcptAddr);
  1218.      RepRec.ExceptionInfo[1]:=LONGWORD(Objekt.FMessage);
  1219.      DosRaiseException(RepRec);
  1220.  
  1221.      ReportRec.ExceptionAddress:=POINTER(Adress);
  1222.      ExcptHandler(ReportRec,PRegisRec^,ContextRec,NIL);
  1223. END;
  1224.  
  1225. PROCEDURE RaiseExceptionAgain(e:Exception);
  1226. VAR
  1227.    PRegisRec:PEXCEPTIONREGISTRATIONRECORD;  {top exception registration record}
  1228. BEGIN
  1229.      ASM
  1230.         MOV ESI,0
  1231.         db $64   //SEG FS
  1232.         MOV EAX,[ESI+0]
  1233.         MOV $PRegisRec,EAX
  1234.      END;
  1235.      IF LONGWORD(PRegisRec)=$ffffffff THEN {no handler installed}
  1236.      BEGIN
  1237.           ExcptRunError(e);
  1238.      END;
  1239.      PRegisRec^.ObjectType:=e;  {set exception type}
  1240.      ExcptHandler(e.ReportRecord,PRegisRec^,e.ContextRecord,NIL);
  1241. END;
  1242.  
  1243.  
  1244. PROCEDURE Beep(Freq,duration:LONGWORD);
  1245. BEGIN
  1246.      ASM
  1247.          PUSHL $duration
  1248.          PUSHL $freq
  1249.          MOV AL,2
  1250.          CALLDLL DOSCALLS,286  //DosBeep
  1251.          ADD ESP,8
  1252.      END;
  1253. END;
  1254.  
  1255. //File I/O support
  1256.  
  1257. TYPE
  1258.     PFEA2=^FEA2;
  1259.     FEA2=RECORD {pack 1}
  1260.                  oNextEntryOffset:LONGWORD;    { new field }
  1261.                  fEA:BYTE;
  1262.                  cbName:BYTE;
  1263.                  cbValue:WORD;
  1264.                  szName:CSTRING[1];    { new field }
  1265.     END;
  1266.  
  1267.     PFEA2LIST=^FEA2LIST;
  1268.     FEA2LIST=RECORD {pack 1}
  1269.                    cbList:LONGWORD;
  1270.                    list:ARRAY[0..0] OF FEA2;
  1271.     END;
  1272.  
  1273.     PGEA2=^GEA2;
  1274.     GEA2=RECORD {pack 1}
  1275.                  oNextEntryOffset:LONGWORD;  { new field }
  1276.                  cbName:BYTE;
  1277.                  szName:ARRAY[0..0] OF BYTE; { new field }
  1278.     END;
  1279.  
  1280.     PGEA2LIST=^GEA2LIST;
  1281.     GEA2LIST=RECORD      { pack 1 }
  1282.                    cbList:LONGWORD;
  1283.                    list:ARRAY [0..0] OF GEA2;
  1284.     END;
  1285.  
  1286.     PEAOP2=^EAOP2;
  1287.     EAOP2=RECORD  { pack 1 }
  1288.                 fpGEA2List:PGEA2LIST;       { GEA set }
  1289.                 fpFEA2List:PFEA2LIST;       { FEA set }
  1290.                 oError:LONGWORD;            { offset of FEA error }
  1291.     END;
  1292.  
  1293. CONST
  1294.      MAX_GEA         = 500;  // Max size for a GEA List
  1295.  
  1296.  
  1297. IMPORTS
  1298.    FUNCTION DosOpen(pszFileName:CSTRING;VAR pHf:LONGWORD;VAR pulAction:LONGWORD;
  1299.                     cbFile,ulAttribute,fsOpenFlags,fsOpenMode:LONGWORD;
  1300.                     VAR apeaop2{:EAOP2}):LONGWORD;
  1301.                     APIENTRY;             DOSCALLS index 273;
  1302.    FUNCTION DosEnumAttribute(ulRefType:LONGWORD;VAR pvFile;ulEntry:LONGWORD;
  1303.                              VAR pvBuf;cbBuf:LONGWORD;VAR pulCount:LONGWORD;
  1304.                              ulInfoLevel:LONGWORD):LONGWORD;
  1305.                     APIENTRY;             DOSCALLS index 372;
  1306.    FUNCTION DosQueryPathInfo(VAR pszPathName:CSTRING;ulInfoLevel:LONGWORD;
  1307.                              VAR pInfoBuf;cbInfoBuf:LONGWORD):LONGWORD;
  1308.                     APIENTRY;             DOSCALLS index 223;
  1309.    FUNCTION DosQueryFileInfo(hf:LONGWORD;ulInfoLevel:LONGWORD;
  1310.                              VAR pInfo;cbInfoBuf:LONGWORD):LONGWORD;
  1311.                     APIENTRY;             DOSCALLS index 279;
  1312.    FUNCTION DosSetPathInfo(pszPathName:CSTRING;ulInfoLevel:LONGWORD;VAR pInfoBuf;
  1313.                         cbInfoBuf,flOptions:LONGWORD):LONGWORD;
  1314.                     APIENTRY;             DOSCALLS index 219;
  1315.    FUNCTION DosSetFileInfo(hf:LONGWORD;ulInfoLevel:LONGWORD;VAR pInfoBuf;
  1316.                         cbInfoBuf:LONGWORD):LONGWORD;
  1317.                     APIENTRY;             DOSCALLS index 218;
  1318.    FUNCTION DosClose(ahFile:LONGWORD):LONGWORD;
  1319.                     APIENTRY;             DOSCALLS index 257;
  1320.    FUNCTION DosSetFilePtr(ahFile:LONGWORD;ib:LONGINT;method:LONGWORD;
  1321.                        VAR ibActual:LONGWORD):LONGWORD;
  1322.                     APIENTRY;             DOSCALLS index 256;
  1323.    FUNCTION DosCreateDir(pszDirName:CSTRING;VAR apeaop2:EAOP2):LONGWORD;
  1324.                     APIENTRY;             DOSCALLS index 270;
  1325.    FUNCTION DosDeleteDir(pszDir:CSTRING):LONGWORD;
  1326.                     APIENTRY;             DOSCALLS index 226;
  1327.    FUNCTION DosSetDefaultDisk(disknum:LONGWORD):LONGWORD;
  1328.                     APIENTRY;             DOSCALLS index 220;
  1329.    FUNCTION DosQueryCurrentDisk(VAR pdisknum,plogical:LONGWORD):LONGWORD;
  1330.                     APIENTRY;             DOSCALLS index 275;
  1331.    FUNCTION DosSetCurrentDir(pszDir:CSTRING):LONGWORD;
  1332.                     APIENTRY;             DOSCALLS index 255;
  1333.    FUNCTION DosQueryCurrentDir(disknum:LONGWORD;VAR pBuf;
  1334.                             VAR pcbBuf:LONGWORD):LONGWORD;
  1335.                     APIENTRY;             DOSCALLS index 274;
  1336.    FUNCTION DosRead(ahFile:LONGWORD;VAR pBuffer;cbRead:LONGWORD;
  1337.                  VAR pcbActual:LONGWORD):LONGWORD;
  1338.                     APIENTRY;             DOSCALLS index 281;
  1339.    FUNCTION DosWrite(ahFile:LONGWORD;VAR pBuffer;cbWrite:LONGWORD;
  1340.                   VAR pcbActual:LONGWORD):LONGWORD;
  1341.                     APIENTRY;             DOSCALLS index 282;
  1342.    FUNCTION DosMove(VAR pszOld,pszNew:CSTRING):LONGWORD;
  1343.                     APIENTRY;             DOSCALLS index 271;
  1344.    FUNCTION DosSetFileSize(ahFile:LONGWORD;cbSize:LONGWORD):LONGWORD;
  1345.                     APIENTRY;             DOSCALLS index 272;
  1346.    FUNCTION DosDelete(VAR pszFile:CSTRING):LONGWORD;
  1347.                     APIENTRY;             DOSCALLS index 259;
  1348. END;
  1349.  
  1350. VAR
  1351.    FileBufSize:LONGWORD;  {Standard file buffer size (32768 bytes}
  1352.  
  1353. PROCEDURE Assign(VAR f:FILE;CONST s:String);
  1354. VAR ff:^FileRec;
  1355.     SaveIOError:BOOLEAN;
  1356. BEGIN
  1357.      ff:=@f;
  1358.      fillchar(f,sizeof(f),0);
  1359.      ff^.Name:=s;                  {Assign name to file variable}
  1360.      ff^.Flags:=$6666;             {File successfully assigned}
  1361.      ff^.Handle:=$ffffffff;        {No valid handle}
  1362.      ff^.MaxCacheMem:=FileBufSize; {Initial bufsize}
  1363.      ff^.Buffer:=NIL;
  1364.      IF ff^.MaxCacheMem<16 THEN ff^.MaxCacheMem:=16;
  1365.      IOResult:=0;                  {Clear IOResult variable}
  1366. END;
  1367.  
  1368. PROCEDURE InvalidFileNameError(Adr:LONGINT);
  1369. VAR
  1370.    e:EInvalidFileName;
  1371. BEGIN
  1372.      e.Create('Invalid file name (EInvalidFileName)');
  1373.      e.CameFromRTL:=TRUE;
  1374.      e.RTLExcptAddr:=POINTER(Adr);
  1375.      e.ErrorCode:=206; {filename exceeds range}
  1376.      RAISE e;
  1377. END;
  1378.  
  1379. PROCEDURE InOutError(Code:LONGWORD;Adr:LONGWORD);
  1380. VAR
  1381.    e:EInOutError;
  1382. BEGIN
  1383.      e.Create('Input/Output error (EInOutError)');
  1384.      e.ErrorCode:=code;
  1385.      e.CameFromRTL:=TRUE;
  1386.      e.RTLExcptAddr:=POINTER(Adr);
  1387.      RAISE e;
  1388. END;
  1389.  
  1390. CONST
  1391.      {Modes for FileBlockIO}
  1392.      ReadMode        = 1;
  1393.      WriteMode       = 2;
  1394.  
  1395. PROCEDURE FileBlockIO(VAR f:FILE;BlockNr:LONGWORD;Mode:LONGWORD;
  1396.                       VAR result:LONGWORD);
  1397. VAR
  1398.    l:LONGWORD;
  1399.    po:LONGWORD;
  1400.    temp:LONGWORD;
  1401.    ff:^FileRec;
  1402. BEGIN
  1403.      ff:=@f;
  1404.      IOResult:=0;
  1405.      IF ff^.changed THEN
  1406.      BEGIN
  1407.           ff^.changed:=FALSE;
  1408.           FileBlockIO(f,ff^.block,WriteMode,Temp);
  1409.           IF IOResult<>0 THEN exit;
  1410.      END;
  1411.  
  1412.      IF blocknr=ff^.LBlock THEN l:=ff^.LOffset
  1413.      ELSE l:=ff^.MaxCacheMem;
  1414.      po:=ff^.MaxCacheMem*blocknr;
  1415.      IOResult:=DosSetFilePtr(ff^.Handle,po,0,Temp);
  1416.      IF IOResult<>0 THEN exit;
  1417.  
  1418.      IF l>0 THEN
  1419.      BEGIN
  1420.           CASE Mode OF
  1421.               WriteMode:
  1422.               BEGIN
  1423.                    IOResult:=DosWrite(ff^.Handle,ff^.Buffer^,l,result);
  1424.               END;
  1425.               ReadMode:
  1426.               BEGIN
  1427.                    IOResult:=DosRead(ff^.Handle,ff^.Buffer^,l,result);
  1428.               END;
  1429.           END; {case}
  1430.      END;
  1431. END;
  1432.  
  1433. FUNCTION FileFileSize(VAR f:FILE):LONGWORD;
  1434. VAR
  1435.    ff:^FileRec;
  1436.    Temp,Temp1,Temp2:LONGWORD;
  1437. BEGIN
  1438.      ff:=@f;
  1439.  
  1440.      IOResult:=DosSetFilePtr(ff^.Handle,0,1,Temp);
  1441.      IF IOResult<>0 THEN exit;
  1442.  
  1443.      IOResult:=DosSetFilePtr(ff^.Handle,0,2,Temp1);
  1444.      IF IOResult<>0 THEN exit;
  1445.  
  1446.      IOResult:=DosSetFilePtr(ff^.Handle,Temp,0,Temp2);
  1447.      IF IOResult<>0 THEN exit;
  1448.  
  1449.      FileFileSize:=Temp1;
  1450. END;
  1451.  
  1452. FUNCTION FileFilePos(VAR f:FILE):LONGWORD;
  1453. VAR
  1454.    ff:^FileRec;
  1455.    Temp:LONGWORD;
  1456. BEGIN
  1457.      ff:=@f;
  1458.  
  1459.      IOResult:=DosSetFilePtr(ff^.Handle,0,1,Temp);
  1460.      IF IOResult<>0 THEN exit;
  1461.  
  1462.      FileFilePos:=Temp;
  1463. END;
  1464.  
  1465.  
  1466. VAR OpenedFiles:ARRAY[1..51] OF LONGWORD; {Handles for opened files}
  1467.     OpenedFilesCount:BYTE;
  1468.  
  1469. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  1470. VAR
  1471.    action:LONGWORD;
  1472.    ff:^FileRec;
  1473.    c:CSTRING;
  1474.    e:EFileNotFound;
  1475.    Size,Temp:LONGWORD;
  1476.    SaveIOError:BOOLEAN;
  1477.    Adr:LONGWORD;
  1478. BEGIN
  1479.      ASM
  1480.         MOV EAX,[EBP+4]
  1481.         SUB EAX,5
  1482.         MOV $Adr,EAX
  1483.      END;
  1484.      IOResult:=0;
  1485.      ff:=@f;
  1486.      ff^.RecSize:=recsize;
  1487.  
  1488.      IF ff^.flags<>$6666 THEN
  1489.      BEGIN
  1490.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1491.           ELSE
  1492.           BEGIN
  1493.                IOResult:=206;
  1494.                exit;
  1495.           END;
  1496.      END;
  1497.  
  1498.      IF ff^.Handle<>$ffffffff THEN
  1499.      BEGIN
  1500.          {Close file first}
  1501.          SaveIoError:=RaiseIOError;
  1502.          RaiseIOError:=FALSE;
  1503.          Close(f);
  1504.          RaiseIoError:=SaveIoError;
  1505.          (*IOResult:=85; {File already assigned}
  1506.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1507.          ELSE exit;*)
  1508.      END;
  1509.  
  1510.      ff^.Buffer:=NIL;
  1511.      c:=ff^.Name;
  1512.      {for rewrite no extended attributes can be determined - use reset !}
  1513.      IOResult:=DosOpen(c,ff^.Handle,action,0,$20,18,FileMode,NIL{EAOP2});
  1514.      IF IOResult<>0 THEN
  1515.      BEGIN
  1516.           ff^.Handle:=$ffffffff;
  1517.           IF RaiseIOError THEN
  1518.           BEGIN
  1519.                e.Create('File not found (EFileNotFound)');
  1520.                e.CameFromRTL:=TRUE;
  1521.                e.RTLExcptAddr:=POINTER(Adr);
  1522.                e.ErrorCode:=IoResult;
  1523.                RAISE e;
  1524.           END
  1525.           ELSE exit;
  1526.      END;
  1527.  
  1528.      ff^.Mode:=FileMode;
  1529.      ff^.Reserved1:=0;
  1530.      ff^.BufferBytes:=0;
  1531.  
  1532.      {Set the buffer values}
  1533.  
  1534.      size:=FileFileSize(f);
  1535.      IF IOResult<>0 THEN
  1536.      BEGIN
  1537.           ff^.Handle:=$ffffffff;
  1538.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  1539.           ELSE exit;
  1540.      END;
  1541.  
  1542.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  1543.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  1544.  
  1545.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  1546.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  1547.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  1548.      FileBlockIO(f,0,readmode,Temp);
  1549.      IF IOResult<>0 THEN
  1550.      BEGIN
  1551.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  1552.           ELSE exit;
  1553.      END;
  1554.      ff^.Block:=0;
  1555.      ff^.Offset:=0;
  1556. END;
  1557.  
  1558. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  1559. VAR
  1560.    action:LONGWORD;
  1561.    ff:^FileRec;
  1562.    c:CSTRING;
  1563.  
  1564.    p:POINTER;
  1565.    pAllocc:POINTER;
  1566.    pBigAlloc:POINTER;
  1567.    cbBigAlloc:WORD;
  1568.    ulEntryNum:LONGWORD;
  1569.    ulEnumCnt:LONGWORD;
  1570.    pLastIn:PHOLDFEA;
  1571.    pNewFEA:PHOLDFEA;
  1572.    pFEA:PFEA2;
  1573.    pGEAList:PGEA2LIST;
  1574.    eaopGet:EAOP2;
  1575.    apHoldFEA:PHOLDFEA;
  1576.    e:EFileNotFound;
  1577.    size,Temp:LONGWORD;
  1578.    SaveIoError:BOOLEAN;
  1579.    Adr:LONGINT;
  1580. LABEL l;
  1581. BEGIN
  1582.      ASM
  1583.         MOV EAX,[EBP+4]
  1584.         SUB EAX,5
  1585.         MOV $Adr,EAX
  1586.      END;
  1587.      IOResult:=0;
  1588.      ff:=@f;
  1589.      ff^.RecSize:=recsize;
  1590.      IF ff^.flags<>$6666 THEN
  1591.      BEGIN
  1592.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1593.           ELSE
  1594.           BEGIN
  1595.                IOResult:=206;
  1596.                exit;
  1597.           END;
  1598.      END;
  1599.  
  1600.      IF ff^.Handle<>$ffffffff THEN
  1601.      BEGIN
  1602.          {Close file first}
  1603.          SaveIoError:=RaiseIOError;
  1604.          RaiseIOError:=FALSE;
  1605.          Close(f);
  1606.          RaiseIoError:=SaveIoError;
  1607.          (*IOResult:=85; {File already assigned}
  1608.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1609.          ELSE exit;*)
  1610.      END;
  1611.  
  1612.      ff^.Buffer:=NIL;
  1613.      c:=ff^.Name;
  1614.  
  1615.      {open and read extended attributes}
  1616.      IOResult:=DosOpen(c,ff^.Handle,action,0,0,1,FileMode,NIL{EAOP2});
  1617.      IF IOResult<>0 THEN
  1618.      BEGIN
  1619.           ff^.Handle:=$ffffffff;
  1620.           IF RaiseIOError THEN
  1621.           BEGIN
  1622.                e.Create('File not found (EFileNotFound)');
  1623.                e.CameFromRTL:=TRUE;
  1624.                e.RTLExcptAddr:=POINTER(Adr);
  1625.                e.ErrorCode:=IoResult;
  1626.                RAISE e;
  1627.           END
  1628.           ELSE exit;
  1629.      END;
  1630.  
  1631.      {Query extended attributes}
  1632.  
  1633.      pAllocc:=NIL;     // Holds the FEA struct returned by DosEnumAttribute
  1634.                        // used to create the GEA2LIST for DosQueryPathInfo
  1635.      pBigAlloc:=NIL;   // Temp buffer to hold each EA as it is read in
  1636.      cbBigAlloc:=0;    // Size of buffer
  1637.  
  1638.      ulEntryNum := 1;  // count of current EA to read (1-relative)
  1639.  
  1640.      pLastIn:=NIL;     // Points to last EA added, so new EA can link
  1641.      pNewFEA:=NIL;     // Struct to build the new EA in
  1642.  
  1643.      GetMem(pAllocc, MAX_GEA);
  1644.      pFEA := pAllocc;  // pFEA always uses pAlloc buffer
  1645.  
  1646.      apHoldFEA := NIL; // Reset the pointer for the EA linked list
  1647.  
  1648.      WHILE TRUE DO     // Loop continues until there are no more EAs */
  1649.      BEGIN
  1650.           ulEnumCnt := 1;
  1651.           IF DosEnumAttribute(0,ff^.Handle,ulEntryNum,pAllocc^,
  1652.                               MAX_GEA,ulEnumCnt,1) <>0 THEN
  1653.           BEGIN
  1654.                {There was some sort of error}
  1655.                goto l;
  1656.           END;
  1657.  
  1658.           IF ulEnumCnt <> 1 THEN goto l;  // All the EAs have been read
  1659.  
  1660.           inc(ulEntryNum);
  1661.  
  1662.           GetMem(pNewFEA, sizeof(THOLDFEA));
  1663.  
  1664.           pNewFEA^.cbName := pFEA^.cbName;  // Fill in the HoldFEA structure
  1665.           pNewFEA^.cbValue:= pFEA^.cbValue;
  1666.           pNewFEA^.fEA    := pFEA^.fEA;
  1667.           pNewFEA^.next   := NIL;
  1668.  
  1669.           pNewFEA^.szName:=pFEA^.szName;  // Copy in EA Name
  1670.  
  1671.           cbBigAlloc := sizeof(FEA2LIST) + pNewFEA^.cbName+1 +
  1672.                         pNewFEA^.cbValue;
  1673.  
  1674.           GetMem(pBigAlloc, cbBigAlloc);
  1675.  
  1676.           pGEAList := pAllocc;          // Set up GEAList structure
  1677.  
  1678.           pGEAList^.cbList := sizeof(GEA2LIST) +
  1679.                               pNewFEA^.cbName; // +1 for NULL
  1680.           pGEAList^.list[0].oNextEntryOffset := 0;
  1681.           pGEAList^.list[0].cbName := pNewFEA^.cbName;
  1682.  
  1683.           CSTRING(pGEAList^.list[0].szName):=pNewFEA^.szName;
  1684.  
  1685.           eaopGet.fpGEA2List := pAllocc;
  1686.           eaopGet.fpFEA2List := pBigAlloc;
  1687.  
  1688.           eaopGet.fpFEA2List^.cbList := cbBigAlloc;
  1689.  
  1690.           DosQueryFileInfo(ff^.Handle,       // Get the complete EA info
  1691.                            3,
  1692.                            eaopGet,
  1693.                            sizeof(EAOP2));
  1694.  
  1695.           getmem(pNewFEA^.aValue,pNewFEA^.cbValue); //memory for data
  1696.           p:=pBigAlloc;
  1697.           inc(p,sizeof(FEA2LIST)+pNewFEA^.cbName);
  1698.           move(p^,
  1699.                pNewFEA^.aValue^,
  1700.                pNewFEA^.cbValue);
  1701.  
  1702.  
  1703.           FreeMem(pBigAlloc,cbBigAlloc); // Release the temp Enum buffer
  1704.  
  1705.           IF apHoldFEA = NIL THEN         // If first EA, set pHoldFEA
  1706.                apHoldFEA := pNewFEA
  1707.           ELSE
  1708.              pLastIn^.next := pNewFEA;
  1709.  
  1710.           pLastIn := pNewFEA;            // Update the end of the list
  1711.           pLastIn^.Deleted:=FALSE;       //EA is valid
  1712.      END;  {While}
  1713. l:
  1714.  
  1715.      IF pLastIn<>NIL THEN pLastIn^.Next:=NIL;
  1716.      FreeMem(pAllocc,MAX_GEA);           // Free up the GEA buf for DosEnum
  1717.  
  1718.      ff^.EAS:=apHoldFEA;
  1719.      ff^.Mode:=FileMode;
  1720.      ff^.Reserved1:=0;
  1721.      ff^.BufferBytes:=0;
  1722.  
  1723.      {Set the buffer values}
  1724.  
  1725.      size:=FileFileSize(f);
  1726.      IF IOResult<>0 THEN
  1727.      BEGIN
  1728.           ff^.Handle:=$ffffffff;
  1729.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  1730.           ELSE exit;
  1731.      END;
  1732.  
  1733.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  1734.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  1735.  
  1736.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  1737.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  1738.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  1739.      FileBlockIO(f,0,readmode,Temp);
  1740.      IF IOResult<>0 THEN
  1741.      BEGIN
  1742.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  1743.           ELSE exit;
  1744.      END;
  1745.      ff^.Block:=0;
  1746.      ff^.Offset:=0;
  1747. END;
  1748.  
  1749. {Get extended attributes from a file}
  1750. FUNCTION GetEAData(VAR f:FILE):PHOLDFEA;
  1751. VAR
  1752.    ff:^FileRec;
  1753.    Adr:LONGINT;
  1754. BEGIN
  1755.      ASM
  1756.         MOV EAX,[EBP+4]
  1757.         SUB EAX,5
  1758.         MOV $Adr,EAX
  1759.      END;
  1760.      ff:=@f;
  1761.      IOResult:=0;
  1762.      IF ff^.flags<>$6666 THEN
  1763.      BEGIN
  1764.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1765.           ELSE
  1766.           BEGIN
  1767.                GetEAData:=NIL;
  1768.                IOResult:=206;
  1769.                exit;
  1770.           END;
  1771.      END;
  1772.  
  1773.      IF ff^.Handle=$ffffffff THEN
  1774.      BEGIN
  1775.          IOResult:=6; {Invalid handle}
  1776.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1777.          ELSE exit;
  1778.      END;
  1779.  
  1780.      GetEAData:=ff^.EAS;
  1781. END;
  1782.  
  1783. {use with care !}
  1784. PROCEDURE EraseEAData(VAR f:FILE);
  1785. VAR
  1786.    ff:^FileRec;
  1787.    pFEA,next:PHOLDFEA;
  1788.    Adr:LONGINT;
  1789. BEGIN
  1790.      ASM
  1791.         MOV EAX,[EBP+4]
  1792.         SUB EAX,5
  1793.         MOV $Adr,EAX
  1794.      END;
  1795.      ff:=@f;
  1796.      IOResult:=0;
  1797.      IF ff^.flags<>$6666 THEN
  1798.      BEGIN
  1799.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1800.           ELSE
  1801.           BEGIN
  1802.                IOResult:=206;
  1803.                exit;
  1804.           END;
  1805.      END;
  1806.  
  1807.      IF ff^.Handle=$ffffffff THEN
  1808.      BEGIN
  1809.          IOResult:=6; {Invalid handle}
  1810.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1811.          ELSE exit;
  1812.      END;
  1813.  
  1814.      pFEA:=ff^.EAS;
  1815.      WHILE pFEA<>NIL DO
  1816.      BEGIN
  1817.           freemem(pFEA^.aValue,pFEA^.cbValue);
  1818.           next:=pFEA^.next;
  1819.           dispose(pFEA);
  1820.           pFEA:=next;
  1821.      END;
  1822.      ff^.EAS:=NIL;
  1823. END;
  1824.  
  1825. {use with care}
  1826. PROCEDURE SetEAData(VAR f:FILE;EAData:PHOLDFEA);
  1827. VAR
  1828.    ff:^FileRec;
  1829.    dummy:PHOLDFEA;
  1830.    Adr:LONGINT;
  1831. BEGIN
  1832.      ASM
  1833.         MOV EAX,[EBP+4]
  1834.         SUB EAX,5
  1835.         MOV $Adr,EAX
  1836.      END;
  1837.      ff:=@f;
  1838.      IOResult:=0;
  1839.      IF ff^.flags<>$6666 THEN
  1840.      BEGIN
  1841.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1842.           ELSE
  1843.           BEGIN
  1844.                IOResult:=206;
  1845.                exit;
  1846.           END;
  1847.      END;
  1848.  
  1849.      IF ff^.Handle=$ffffffff THEN
  1850.      BEGIN
  1851.          IOResult:=6; {Invalid handle}
  1852.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1853.          ELSE exit;
  1854.      END;
  1855.  
  1856.      {Erase old EA Data}
  1857.      EraseEAData(f);
  1858.      ff^.EAS:=NIL;
  1859.  
  1860.      {copy the EA Data}
  1861.      WHILE EAData<>NIL DO
  1862.      BEGIN
  1863.           IF ff^.EAS=NIL THEN
  1864.           BEGIN
  1865.                new(ff^.EAS);
  1866.                dummy:=ff^.EAS;
  1867.           END
  1868.           ELSE
  1869.           BEGIN
  1870.                dummy:=ff^.EAS;
  1871.                WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  1872.                new(dummy^.next);
  1873.                dummy:=dummy^.next;
  1874.           END;
  1875.  
  1876.           move(EAData^,dummy^,sizeof(THOLDFEA));
  1877.           getmem(dummy^.aValue,dummy^.cbValue);
  1878.           move(EAData^.aValue^,dummy^.avalue^,dummy^.cbValue);
  1879.           dummy^.Next:=NIL;
  1880.  
  1881.           EAData:=EAData^.Next;
  1882.      END;
  1883. END;
  1884.  
  1885. {use with care !}
  1886. PROCEDURE DeleteEAData(VAR f:FILE);
  1887. VAR
  1888.    ff:^FileRec;
  1889.    pFEA,next:PHOLDFEA;
  1890.    Adr:LONGINT;
  1891. BEGIN
  1892.      ASM
  1893.         MOV EAX,[EBP+4]
  1894.         SUB EAX,5
  1895.         MOV $Adr,EAX
  1896.      END;
  1897.      ff:=@f;
  1898.      IOResult:=0;
  1899.      IF ff^.flags<>$6666 THEN
  1900.      BEGIN
  1901.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  1902.           ELSE
  1903.           BEGIN
  1904.                IOResult:=206;
  1905.                exit;
  1906.           END;
  1907.      END;
  1908.  
  1909.      IF ff^.Handle=$ffffffff THEN
  1910.      BEGIN
  1911.          IOResult:=6; {Invalid handle}
  1912.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  1913.          ELSE exit;
  1914.      END;
  1915.  
  1916.      pFEA:=ff^.EAS;
  1917.      WHILE pFEA<>NIL DO
  1918.      BEGIN
  1919.           pFEA^.Deleted:=TRUE;
  1920.  
  1921.           pFEA:=pFEA^.Next;
  1922.      END;
  1923. END;
  1924.  
  1925.  
  1926.  
  1927.  
  1928. {Write extended attributes to an open file
  1929.  The file need not to be opened but assigned
  1930.  and the EA data must have been set using SetEAData
  1931.  If the file is opened its sharing rights should not
  1932.  conflict with exclusive write access}
  1933. PROCEDURE WriteEAData(VAR f:FILE);
  1934. VAR
  1935.    ff:^FileRec;
  1936.    pDL:PHOLDFEA;
  1937.    pHFEA:PHOLDFEA;
  1938.    eaopWrite:EAOP2;
  1939.    aBuf:ARRAY[0..MAX_GEA] OF CHAR;
  1940.    aPtr:^CSTRING;
  1941.    pFEA:PFEA2;
  1942.    usMemNeeded,usRet:LONGWORD;
  1943.    pulPtr:^LONGWORD;
  1944.    c:CSTRING;
  1945.    p:POINTER;
  1946.    Adr:LONGINT;
  1947. BEGIN
  1948.    ASM
  1949.       MOV EAX,[EBP+4]
  1950.       SUB EAX,5
  1951.       MOV $Adr,EAX
  1952.    END;
  1953.    ff:=@f;
  1954.    pHFEA:=ff^.EAS;
  1955.    aPtr:=NIL;
  1956.    pFEA:=@aBuf[4];
  1957.    pulPtr:=@aBuf;
  1958.    c:=ff^.Name;
  1959.    IOResult:=0;
  1960.  
  1961.    IF ff^.flags<>$6666 THEN
  1962.    BEGIN
  1963.         IF RaiseIOError THEN InvalidFileNameError(Adr)
  1964.         ELSE
  1965.         BEGIN
  1966.              IOResult:=206;
  1967.              exit;
  1968.         END;
  1969.    END;
  1970.  
  1971.    IF ff^.Handle=$ffffffff THEN
  1972.    BEGIN
  1973.         IOResult:=6; {Invalid handle}
  1974.         IF RaiseIOError THEN InOutError(IOResult,Adr)
  1975.         ELSE exit;
  1976.    END;
  1977.  
  1978.    eaopWrite.fpFEA2List := @aBuf;
  1979.    pFEA^.fEA     := 0;
  1980.    pFEA^.cbValue := 0;
  1981.  
  1982.    pDL:=ff^.EAS;
  1983.    WHILE pDL<>NIL DO      // Clean out all the deleted EA names
  1984.    BEGIN
  1985.       IF pDL^.Deleted THEN
  1986.       BEGIN
  1987.            pFEA^.cbName := pDL^.cbName;
  1988.            pulPtr^:= sizeof(FEA2LIST) + pFEA^.cbName;
  1989.            pFEA^.szName:=pDL^.szName;
  1990.            pFEA^.oNextEntryOffset := 0; {last entry}
  1991.                                      // Delete EA's by saying cbValue=0
  1992.            {DosSetPathInfo(c,2,eaopWrite,sizeof(EAOP2),$10);}
  1993.            DosSetFileInfo(ff^.Handle,2,eaopWrite,sizeof(EAOP2));
  1994.       END;
  1995.       pDL := pDL^.next;
  1996.    END;
  1997.  
  1998.    WHILE pHFEA<>NIL DO      // Go through each HoldFEA
  1999.    BEGIN
  2000.       IF not pHFEA^.Deleted THEN
  2001.       BEGIN
  2002.            usMemNeeded := sizeof(FEA2LIST) + pHFEA^.cbName+1 +
  2003.                                  pHFEA^.cbValue;
  2004.            GetMem(aPtr, usMemNeeded);
  2005.  
  2006.            eaopWrite.fpFEA2List := POINTER(aPtr);  // Fill in eaop struct
  2007.            eaopWrite.fpFEA2List^.cbList := usMemNeeded;
  2008.  
  2009.            eaopWrite.fpFEA2List^.list[0].fEA     := pHFEA^.fEA;
  2010.            eaopWrite.fpFEA2List^.list[0].cbName  := pHFEA^.cbName;
  2011.            eaopWrite.fpFEA2List^.list[0].cbValue := pHFEA^.cbValue;
  2012.            eaopWrite.fpFEA2List^.list[0].oNextEntryOffset := 0; {last entry}
  2013.  
  2014.            CSTRING(eaopWrite.fpFEA2List^.list[0].szName):=pHFEA^.szName;
  2015.            p:=@eaopWrite.fpFEA2List^.list[0].szName;
  2016.            inc(p,pHFEA^.cbName+1);
  2017.            move(pHFEA^.aValue^,p^,pHFEA^.cbValue);
  2018.  
  2019.            {IOResult := DosSetPathInfo(c,2,eaopWrite,sizeof(EAOP2),$10);}
  2020.            IOResult:=DosSetFileInfo(ff^.Handle,2,eaopWrite,sizeof(EAOP2));
  2021.  
  2022.            IF IOResult<>0 THEN
  2023.            BEGIN
  2024.                  IF RaiseIOError THEN InOutError(IOResult,Adr)
  2025.                  ELSE exit;
  2026.            END;
  2027.  
  2028.            FreeMem(aPtr,usMemNeeded); // Free up the FEALIST struct
  2029.       END;
  2030.  
  2031.       pHFEA := pHFEA^.next;
  2032.    END;
  2033. END;
  2034.  
  2035. PROCEDURE Close(VAR f:FILE);
  2036. VAR
  2037.    ff:^FileRec;
  2038.    Temp:LONGWORD;
  2039.    t:BYTE;
  2040.    Adr:LONGINT;
  2041. LABEL l;
  2042. BEGIN
  2043.      ASM
  2044.         MOV EAX,[EBP+4]
  2045.         SUB EAX,5
  2046.         MOV $Adr,EAX
  2047.      END;
  2048.      ff:=@f;
  2049.      IF ff^.flags<>$6666 THEN
  2050.      BEGIN
  2051.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2052.           ELSE
  2053.           BEGIN
  2054.                IOResult:=206;
  2055.                exit;
  2056.           END;
  2057.      END;
  2058.  
  2059.      IF ff^.Handle=$ffffffff THEN
  2060.      BEGIN
  2061.           IOResult:=6; {Invalid handle}
  2062.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2063.           ELSE exit;
  2064.      END;
  2065.  
  2066.      IF ff^.Buffer=NIL THEN
  2067.      BEGIN
  2068.           IOResult:=DosClose(ff^.Handle);
  2069.           IF IOResult<>0 THEN
  2070.           BEGIN
  2071.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  2072.               ELSE exit;
  2073.           END;
  2074.           ff^.Mode:=0;            {closed}
  2075.           ff^.Flags:=$6666;       {File successfully assigned}
  2076.           ff^.Handle:=$ffffffff;  {No valid handle}
  2077.           exit;
  2078.      END;
  2079.  
  2080.      IOResult:=0;
  2081.      {Write buffer to file}
  2082.      IF ff^.changed THEN
  2083.      BEGIN
  2084.           ff^.changed:=FALSE;
  2085.           FileBlockIO(F,ff^.block,WriteMode,Temp);
  2086.           IF IOResult<>0 THEN
  2087.           BEGIN
  2088.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  2089.               ELSE exit;
  2090.           END;
  2091.      END;
  2092.  
  2093.      {Write EA's to the file}
  2094.      WriteEAData(f);
  2095.  
  2096.      FOR t:=1 TO OpenedFilesCount DO
  2097.      BEGIN
  2098.           IF OpenedFiles[t]=ff^.Handle THEN
  2099.           BEGIN
  2100.                move(OpenedFiles[t+1],OpenedFiles[t],(50-t)*4);
  2101.                dec(OpenedFilesCount);
  2102.                goto l;
  2103.           END;
  2104.      END;
  2105. l:
  2106.      IOResult:=DosClose(ff^.Handle);
  2107.      IF IOResult<>0 THEN
  2108.      BEGIN
  2109.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2110.           ELSE exit;
  2111.      END;
  2112.  
  2113.      EraseEAData(f);
  2114.      ff^.Mode:=0;            {closed}
  2115.      ff^.Flags:=$6666;       {File successfully assigned}
  2116.      ff^.Handle:=$ffffffff;  {No valid handle}
  2117.  
  2118.      {free file buffers}
  2119.      IF ff^.Buffer<>NIL THEN FreeMem(ff^.Buffer,ff^.MaxCacheMem);
  2120.      ff^.Buffer:=NIL;
  2121. END;
  2122.  
  2123. PROCEDURE CloseAllOpenedFiles;
  2124. VAR t:BYTE;
  2125. BEGIN
  2126.      FOR t:=1 TO OpenedFilesCount DO DosClose(OpenedFiles[t]);
  2127.      OpenedFilesCount:=0;
  2128. END;
  2129.  
  2130. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  2131. VAR
  2132.    ff:^FileRec;
  2133.    result:LONGWORD;
  2134.    pBlock:LONGWORD;
  2135.    POffset:LONGWORD;
  2136.    Temp:LONGWORD;
  2137.    Adr:LONGINT;
  2138. BEGIN
  2139.      ASM
  2140.         MOV EAX,[EBP+4]
  2141.         SUB EAX,5
  2142.         MOV $Adr,EAX
  2143.      END;
  2144.      ff:=@f;
  2145.      IF ff^.flags<>$6666 THEN
  2146.      BEGIN
  2147.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2148.           ELSE
  2149.           BEGIN
  2150.                IOResult:=206;
  2151.                exit;
  2152.           END;
  2153.      END;
  2154.  
  2155.      IF ff^.Handle=$ffffffff THEN
  2156.      BEGIN
  2157.           IOResult:=6; {Invalid handle}
  2158.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2159.           ELSE exit;
  2160.      END;
  2161.  
  2162.      n:=n*ff^.RecSize;
  2163.  
  2164.      CASE SeekMode OF
  2165.         Seek_Current:inc(n,FilePos(f)*ff^.RecSize);   //Seek_Current
  2166.         Seek_End:inc(n,FileSize(f)*ff^.RecSize);      //Seek_End
  2167.      END;
  2168.  
  2169.      IOResult:=0;
  2170.      pblock:=n DIV ff^.maxcachemem;
  2171.      poffset:=n MOD ff^.maxcachemem;
  2172.      IF n>ff^.loffset+ff^.maxcachemem*ff^.lblock THEN
  2173.      BEGIN
  2174.           IF ff^.Mode AND (fmOutput OR fmInOut)<>0 THEN
  2175.           BEGIN
  2176.                ff^.loffset:=poffset;
  2177.                ff^.lblock:=pblock;
  2178.           END
  2179.           ELSE
  2180.           BEGIN
  2181.                IOResult:=38;  {Illegal pos}
  2182.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2183.                ELSE exit;
  2184.           END;
  2185.      END;
  2186.      IF pblock<>ff^.block THEN
  2187.      BEGIN
  2188.           FileBlockIO(f,pblock,ReadMode,Temp);
  2189.           IF IOResult<>0 THEN
  2190.           BEGIN
  2191.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  2192.               ELSE exit;
  2193.           END;
  2194.      END;
  2195.      ff^.offset:=poffset;
  2196.      ff^.block:=pblock;
  2197. END;
  2198.  
  2199. FUNCTION FilePos(var f:file):LongWord;
  2200. VAR
  2201.    ff:^FileRec;
  2202.    result:LONGWORD;
  2203.    Adr:LONGINT;
  2204. BEGIN
  2205.      ASM
  2206.         MOV EAX,[EBP+4]
  2207.         SUB EAX,5
  2208.         MOV $Adr,EAX
  2209.      END;
  2210.      ff:=@f;
  2211.      IF ff^.flags<>$6666 THEN
  2212.      BEGIN
  2213.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2214.           ELSE
  2215.           BEGIN
  2216.                IOResult:=206;
  2217.                exit;
  2218.           END;
  2219.      END;
  2220.  
  2221.      IF ff^.Handle=$ffffffff THEN
  2222.      BEGIN
  2223.           IOResult:=6; {Invalid handle}
  2224.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2225.           ELSE exit;
  2226.      END;
  2227.  
  2228.      IOResult:=0;
  2229.      result:=ff^.block*ff^.maxcachemem+ff^.offset;
  2230.      FilePos:=result DIV ff^.RecSize;
  2231. END;
  2232.  
  2233. FUNCTION Eof(var f:file):Boolean;
  2234. VAR
  2235.    old,size:LONGWORD;
  2236.    ff:^FIleRec;
  2237.    SaveIO:BOOLEAN;
  2238.    Adr:LONGINT;
  2239. BEGIN
  2240.      ASM
  2241.         MOV EAX,[EBP+4]
  2242.         SUB EAX,5
  2243.         MOV $Adr,EAX
  2244.      END;
  2245.      ff:=@f;
  2246.  
  2247.      IF ff^.flags<>$6666 THEN
  2248.      BEGIN
  2249.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2250.           ELSE
  2251.           BEGIN
  2252.                IOResult:=206;
  2253.                exit;
  2254.           END;
  2255.      END;
  2256.  
  2257.      IF ff^.Handle=$ffffffff THEN
  2258.      BEGIN
  2259.           IOResult:=6; {Invalid handle}
  2260.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2261.           ELSE exit;
  2262.      END;
  2263.  
  2264.      IF ff^.Reserved1 AND 1=1 THEN
  2265.      BEGIN
  2266.           eof:=TRUE;
  2267.           exit;
  2268.      END;
  2269.  
  2270.      IF ff^.Buffer=NIL THEN
  2271.      BEGIN
  2272.           IOResult:=0;
  2273.           SaveIO:=RaiseIOError;
  2274.           RaiseIOError:=FALSE;
  2275.           size:=FileFileSize(f);
  2276.           RaiseIOError:=SaveIO;
  2277.           IF IOResult<>0 THEN
  2278.           BEGIN
  2279.                IF ((f=Input)OR(f=Output)) THEN
  2280.                BEGIN
  2281.                     Eof:=FALSE;
  2282.                     exit;
  2283.                END
  2284.                ELSE
  2285.                BEGIN
  2286.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2287.                     ELSE exit;
  2288.                END;
  2289.           END
  2290.           ELSE
  2291.           BEGIN
  2292.                Eof:=Size=FileFilePos(f);
  2293.                IF IOResult<>0 THEN
  2294.                BEGIN
  2295.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2296.                     ELSE exit;
  2297.                END;
  2298.           END;
  2299.           exit;
  2300.      END;
  2301.  
  2302.      IOResult:=0;
  2303.      Eof:=(ff^.offset=ff^.loffset)AND(ff^.block=ff^.lblock);
  2304. END;
  2305.  
  2306. FUNCTION Eoln(VAR F:Text):Boolean;
  2307. VAR
  2308.     Adr:LONGINT;
  2309.     fi:^FileRec;
  2310.     Offset:LONGINT;
  2311.     Value:BYTE;
  2312.     SaveIoError:BOOLEAN;
  2313.     Res:LONGWORD;
  2314.     t:BYTE;
  2315.     s:STRING;
  2316. BEGIN
  2317.      ASM
  2318.         MOV EAX,[EBP+4]
  2319.         SUB EAX,5
  2320.         MOV $Adr,EAX
  2321.      END;
  2322.  
  2323.      fi:=@f;
  2324.  
  2325.      IF fi^.flags<>$6666 THEN
  2326.      BEGIN
  2327.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2328.           ELSE
  2329.           BEGIN
  2330.                IOResult:=206;
  2331.                exit;
  2332.           END;
  2333.      END;
  2334.  
  2335.      IF fi^.Handle=$ffffffff THEN
  2336.      BEGIN
  2337.          IOResult:=6; {Invalid handle}
  2338.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  2339.          ELSE exit;
  2340.      END;
  2341.  
  2342.      IF eof(f) THEN
  2343.      BEGIN
  2344.           result:=TRUE;
  2345.           exit;
  2346.      END;
  2347.  
  2348.      Offset:=fi^.Offset;
  2349.  
  2350.      IF fi^.Buffer=NIL THEN
  2351.      BEGIN
  2352.           IF lo(fi^.BufferBytes)=1 THEN
  2353.           BEGIN
  2354.                Value:=Hi(fi^.BufferBytes);
  2355.           END
  2356.           ELSE
  2357.           BEGIN
  2358.                SaveIOError:=RaiseIOError;
  2359.                RaiseIOError:=FALSE;
  2360.                BlockRead(f,Value,1,Res);
  2361.                Seek(f,FilePos(f)-1);
  2362.                RaiseIOError:=SaveIOError;
  2363.                IF Res=0 THEN Value:=26; {EOF}
  2364.           END;
  2365.      END
  2366.      ELSE value:=fi^.Buffer^[Offset];
  2367.  
  2368.      IF value IN [13,10,26] THEN result:=TRUE
  2369.      ELSE result:=FALSE;
  2370. END;
  2371.  
  2372.  
  2373. FUNCTION FileSize(var f:file):LongWord;
  2374. VAR
  2375.    old,old1,result:LONGWORD;
  2376.    ff:^FileRec;
  2377.    Adr:LONGINT;
  2378. BEGIN
  2379.      ASM
  2380.         MOV EAX,[EBP+4]
  2381.         SUB EAX,5
  2382.         MOV $Adr,EAX
  2383.      END;
  2384.      ff:=@f;
  2385.      IF ff^.flags<>$6666 THEN
  2386.      BEGIN
  2387.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2388.           ELSE
  2389.           BEGIN
  2390.                IOResult:=206;
  2391.                exit;
  2392.           END;
  2393.      END;
  2394.  
  2395.      IF ff^.Handle=$ffffffff THEN
  2396.      BEGIN
  2397.           IOResult:=6; {Invalid handle}
  2398.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2399.           ELSE exit;
  2400.      END;
  2401.  
  2402.      IOResult:=0;
  2403.      result:=ff^.lblock*ff^.maxcachemem+ff^.loffset;
  2404.      FileSize:=result DIV ff^.RecSize;
  2405. END;
  2406.  
  2407. PROCEDURE Truncate(VAR f:FILE);
  2408. VAR
  2409.    l:LONGWORD;
  2410.    ff:^FileRec;
  2411.    Adr:LONGINT;
  2412. BEGIN
  2413.      ASM
  2414.         MOV EAX,[EBP+4]
  2415.         SUB EAX,5
  2416.         MOV $Adr,EAX
  2417.      END;
  2418.      ff:=@f;
  2419.      IF ff^.flags<>$6666 THEN
  2420.      BEGIN
  2421.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2422.           ELSE
  2423.           BEGIN
  2424.                IOResult:=206;
  2425.                exit;
  2426.           END;
  2427.      END;
  2428.      IOResult:=DosSetFileSize(ff^.Handle,FilePos(f));
  2429.      IF IOResult<>0 THEN
  2430.      BEGIN
  2431.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2432.           ELSE exit;
  2433.      END;
  2434.      ff^.lOffset:=ff^.Offset;
  2435.      ff^.lBlock:=ff^.Block;
  2436. END;
  2437.  
  2438. PROCEDURE Append(VAR f:Text);
  2439. VAR
  2440.    l:LONGWORD;
  2441.    saveseek:LONGWORD;
  2442.    Adr:LONGINT;
  2443. BEGIN
  2444.      ASM
  2445.         MOV EAX,[EBP+4]
  2446.         SUB EAX,5
  2447.         MOV $Adr,EAX
  2448.      END;
  2449.      Reset(f,1);
  2450.      IF IOResult<>0 THEN
  2451.      BEGIN
  2452.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2453.           ELSE exit;
  2454.      END;
  2455.  
  2456.      l:=Filesize(f);
  2457.      IF ioresult=0 THEN
  2458.      BEGIN
  2459.           SaveSeek:=seekmode;
  2460.           seekmode:=0; {from file begin}
  2461.           Seek(f,l);
  2462.           seekmode:=saveseek;
  2463.      END
  2464.      ELSE
  2465.      BEGIN
  2466.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2467.           ELSE exit;
  2468.      END;
  2469. END;
  2470.  
  2471.  
  2472. PROCEDURE ChDir(CONST path:STRING);
  2473. VAR c:CSTRING;
  2474.     Adr:LONGINT;
  2475.     s:STRING;
  2476. BEGIN
  2477.      ASM
  2478.         MOV EAX,[EBP+4]
  2479.         SUB EAX,5
  2480.         MOV $Adr,EAX
  2481.      END;
  2482.  
  2483.      IF length(Path)=2 THEN IF Path[2]=':' THEN
  2484.      BEGIN
  2485.           IOResult:=DosSetDefaultDisk(ord(upcase(path[1]))-64);
  2486.           IF IOResult<>0 THEN
  2487.           BEGIN
  2488.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2489.                ELSE exit;
  2490.           END;
  2491.           exit;
  2492.      END;
  2493.  
  2494.      IF POS(':\',path)=2 THEN {drive letter preceding}
  2495.      BEGIN
  2496.           IOResult:=DosSetDefaultDisk(ord(upcase(path[1]))-64);
  2497.           IF IOResult<>0 THEN
  2498.           BEGIN
  2499.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2500.                ELSE exit;
  2501.           END;
  2502.           c:=upcase(path[1])+':\';
  2503.           IOResult:=DosSetCurrentDir(c);  {move to root directory}
  2504.           IF IOResult<>0 THEN
  2505.           BEGIN
  2506.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2507.                ELSE exit;
  2508.           END;
  2509.      END;
  2510.  
  2511.      IF path[length(Path)]='\' THEN
  2512.      BEGIN
  2513.           s:=Path;
  2514.           dec(s[0]);
  2515.           c:=s;
  2516.      END
  2517.      ELSE c:=path;
  2518.      IOResult:=DosSetCurrentDir(c);
  2519.      IF IOResult<>0 THEN
  2520.      BEGIN
  2521.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2522.           ELSE exit;
  2523.      END;
  2524. END;
  2525.  
  2526. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  2527. VAR
  2528.    c:CSTRING;
  2529.    drivemap,curdrive,MaxLen:LONGWORD;
  2530.    Adr:LONGINT;
  2531. BEGIN
  2532.      ASM
  2533.         MOV EAX,[EBP+4]
  2534.         SUB EAX,5
  2535.         MOV $Adr,EAX
  2536.      END;
  2537.      IF Drive=0 THEN
  2538.      BEGIN
  2539.           {query current drive}
  2540.           IOResult:=DosQueryCurrentDisk(curdrive,drivemap);
  2541.           IF IOResult<>0 THEN
  2542.           BEGIN
  2543.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2544.                ELSE exit;
  2545.           END;
  2546.      END
  2547.      ELSE curdrive:=drive;
  2548.  
  2549.      MaxLen:=250;
  2550.      IOResult:=DosQueryCurrentDir(curdrive,c,MaxLen);
  2551.      IF IOResult<>0 THEN
  2552.      BEGIN
  2553.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2554.           ELSE exit;
  2555.      END;
  2556.  
  2557.      path:=chr(curDrive+64)+':\'+c;
  2558. END;
  2559.  
  2560. PROCEDURE RmDir(CONST dir:STRING);
  2561. VAR
  2562.    c:CSTRING;
  2563.    Adr:LONGINT;
  2564. BEGIN
  2565.      ASM
  2566.         MOV EAX,[EBP+4]
  2567.         SUB EAX,5
  2568.         MOV $Adr,EAX
  2569.      END;
  2570.      c:=Dir;
  2571.      IOResult:=DosDeleteDir(c);
  2572.      IF IOResult<>0 THEN
  2573.      BEGIN
  2574.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2575.           ELSE exit;
  2576.      END;
  2577. END;
  2578.  
  2579. PROCEDURE MkDir(CONST dir:STRING);
  2580. VAR
  2581.    c:CSTRING;
  2582.    Adr:LONGINT;
  2583. BEGIN
  2584.      c:=dir;
  2585.      IOResult:=DosCreateDir(c,NIL);
  2586.      IF IOResult<>0 THEN
  2587.      BEGIN
  2588.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  2589.           ELSE exit;
  2590.      END;
  2591. END;
  2592.  
  2593. PROCEDURE FileExpand(VAR f:FILE);
  2594. VAR
  2595.    ff:^FileRec;
  2596. BEGIN
  2597.      ff:=@f;
  2598.      inc(ff^.LOffset);
  2599.      IF ff^.LOffset=ff^.MaxCacheMem THEN
  2600.      BEGIN
  2601.           inc(ff^.LBlock);
  2602.           ff^.LOffset:=0;
  2603.      END;
  2604. END;
  2605.  
  2606. VAR
  2607.    BlockReadResult,BlockWriteResult:LONGWORD;
  2608.  
  2609. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  2610. VAR
  2611.    ff:^FileRec;
  2612.    pp:P_FileBuffer;
  2613.    t,t1:LONGWORD;
  2614.    Temp:LONGWORD;
  2615.    Offset,Size:LONGWORD;
  2616.    OldBlock,OldOfs:LONGINT;
  2617.    MaxCacheMem:LONGWORD;
  2618.    Adr:LONGINT;
  2619. BEGIN
  2620.      IF Count=0 THEN
  2621.      BEGIN
  2622.           result:=0;
  2623.           exit;
  2624.      END;
  2625.  
  2626.      ASM
  2627.         MOV EAX,[EBP+4]
  2628.         SUB EAX,5
  2629.         MOV $Adr,EAX
  2630.      END;
  2631.      ff:=@f;
  2632.      pp:=@Buf;
  2633.      IOResult:=0;
  2634.  
  2635.      IF ff^.flags<>$6666 THEN
  2636.      BEGIN
  2637.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2638.           ELSE
  2639.           BEGIN
  2640.                IOResult:=206;
  2641.                exit;
  2642.           END;
  2643.      END;
  2644.  
  2645.      IF ff^.Handle=$ffffffff THEN
  2646.      BEGIN
  2647.          IOResult:=6; {Invalid handle}
  2648.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  2649.          ELSE exit;
  2650.      END;
  2651.  
  2652.      IF ff^.Buffer=NIL THEN
  2653.      BEGIN
  2654.           IOResult:=DosRead(ff^.Handle,pp^,Count*ff^.RecSize,result);
  2655.           IF IOResult<>0 THEN
  2656.           BEGIN
  2657.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2658.                ELSE exit;
  2659.           END;
  2660.           exit;
  2661.      END;
  2662.  
  2663.      result:=0;
  2664.      Offset:=ff^.Offset;
  2665.      Size:=Count*ff^.RecSize;
  2666.      MaxCacheMem:=ff^.MaxCacheMem;
  2667.  
  2668.      IF Size>MaxCacheMem THEN
  2669.      BEGIN
  2670.           {Block ist größer als Cache}
  2671.           IF (ff^.Block*MaxCacheMem)+Offset+Size>(ff^.LBlock*MaxCacheMem)+ff^.LOffset THEN
  2672.             Size:=((ff^.LBlock*MaxCacheMem)+ff^.LOffset)-
  2673.                   ((ff^.Block*MaxCacheMem)+Offset);
  2674.  
  2675.           IF ff^.Changed THEN
  2676.           BEGIN
  2677.                ff^.Changed:=FALSE;
  2678.                OldBlock:=ff^.LBlock;    {temporaray save}
  2679.                OldOfs:=ff^.LOffset;
  2680.                ff^.LBlock:=ff^.Block;
  2681.                ff^.LOffset:=Offset;
  2682.                {alten Block Schreiben}
  2683.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  2684.                IF IOResult<>0 THEN
  2685.                BEGIN
  2686.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2687.                     ELSE exit;
  2688.                END;
  2689.                ff^.LBlock:=OldBlock;
  2690.                ff^.LOffset:=OldOfs;
  2691.           END
  2692.           ELSE
  2693.           BEGIN
  2694.                IOResult:=DosSetFilePtr(ff^.Handle,
  2695.                          (ff^.Block*MaxCacheMem)+Offset,0,Temp);
  2696.                IF IOResult<>0 THEN
  2697.                BEGIN
  2698.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2699.                     ELSE exit;
  2700.                END;
  2701.           END;
  2702.  
  2703.           IOResult:=DosRead(ff^.Handle,Buf,size,result);
  2704.           IF IOResult<>0 THEN
  2705.           BEGIN
  2706.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2707.                ELSE exit;
  2708.           END;
  2709.           size:=result; {tatsächlich gelesen}
  2710.  
  2711.           {set file buffer}
  2712.           Temp:=Offset+size;
  2713.           t:=Temp MOD MaxCacheMem;
  2714.  
  2715.           IF size<MaxCacheMem THEN
  2716.           BEGIN
  2717.                move(pp^[size-t],ff^.Buffer^,t);
  2718.                inc(ff^.Block,Temp DIV MaxCacheMem);
  2719.                ff^.Offset:=t;
  2720.                ff^.LBlock:=ff^.Block;
  2721.                ff^.LOffset:=ff^.Offset;
  2722.           END
  2723.           ELSE
  2724.           BEGIN
  2725.                {nächsten Block lesen}
  2726.                ff^.Changed:=FALSE;
  2727.                inc(ff^.Block,Temp DIV MaxCacheMem);
  2728.  
  2729.                FileBlockIO(f,ff^.block,ReadMode,Temp);
  2730.                IF IOResult<>0 THEN
  2731.                BEGIN
  2732.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2733.                     ELSE exit;
  2734.                END;
  2735.                ff^.offset:=t;
  2736.           END;
  2737.  
  2738.           IF ff^.Block>ff^.LBlock THEN
  2739.           BEGIN
  2740.                ff^.LBlock:=ff^.Block;
  2741.                ff^.LOffset:=ff^.Offset;
  2742.           END;
  2743.  
  2744.           result:=result DIV ff^.RecSize;
  2745.           exit;
  2746.      END;
  2747.  
  2748.      IF ff^.block=ff^.LBlock THEN
  2749.      BEGIN
  2750.           IF Offset+size<ff^.LOffset THEN
  2751.           BEGIN
  2752.                {im letzten Block}
  2753.                move(ff^.Buffer^[Offset],pp^,size);
  2754.                inc(ff^.Offset,size);
  2755.                inc(result,size);
  2756.                result:=result DIV ff^.RecSize;
  2757.                exit;
  2758.           END;
  2759.      END
  2760.      ELSE
  2761.      BEGIN
  2762.           {irgendwo vor dem letzten Block}
  2763.           IF Offset+Size<MaxCacheMem THEN
  2764.           BEGIN
  2765.                move(ff^.Buffer^[Offset],pp^,size);
  2766.                inc(ff^.Offset,size);
  2767.                inc(result,size);
  2768.                result:=result DIV ff^.RecSize;
  2769.                exit;
  2770.           END;
  2771.      END;
  2772.  
  2773.      ff^.reserved1:=ff^.reserved1 and not 1;
  2774.  
  2775.      FOR t:=1 TO Size DO
  2776.      BEGIN
  2777.           IF eof(f) THEN
  2778.           BEGIN
  2779.                result:=result DIV ff^.RecSize;
  2780.                exit;
  2781.           END;
  2782.  
  2783.           pp^[t-1]:=ff^.Buffer^[ff^.offset];
  2784.           inc(ff^.offset);
  2785.           inc(result);
  2786.           IF ff^.offset=maxcachemem THEN
  2787.           BEGIN
  2788.                FileBlockIO(f,ff^.block+1,ReadMode,Temp);
  2789.                IF IOResult<>0 THEN
  2790.                BEGIN
  2791.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2792.                     ELSE exit;
  2793.                END;
  2794.                ff^.offset:=0;
  2795.                inc(ff^.block);
  2796.           END;
  2797.      END;
  2798.      result:=result DIV ff^.RecSize;
  2799. END;
  2800.  
  2801. PROCEDURE BlockWrite(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  2802. VAR
  2803.    ff:^FileRec;
  2804.    pp:P_FileBuffer;
  2805.    t,t1,Temp:LONGWORD;
  2806.    value:BYTE;
  2807.    size:LONGWORD;
  2808.    Offset:LONGWORD;
  2809.    OldBlock,OldOfs:LONGINT;
  2810.    Adr:LONGINT;
  2811. LABEL l,l1;
  2812. BEGIN
  2813.      IF Count=0 THEN
  2814.      BEGIN
  2815.           result:=0;
  2816.           exit;
  2817.      END;
  2818.  
  2819.      ASM
  2820.         MOV EAX,[EBP+4]
  2821.         SUB EAX,5
  2822.         MOV $Adr,EAX
  2823.      END;
  2824.      ff:=@f;
  2825.      pp:=@Buf;
  2826.      IOResult:=0;
  2827.  
  2828.      IF ff^.flags<>$6666 THEN
  2829.      BEGIN
  2830.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  2831.           ELSE
  2832.           BEGIN
  2833.                IOResult:=206;
  2834.                exit;
  2835.           END;
  2836.      END;
  2837.  
  2838.      IF ff^.Handle=$ffffffff THEN
  2839.      BEGIN
  2840.          IOResult:=6; {Invalid handle}
  2841.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  2842.          ELSE exit;
  2843.      END;
  2844.  
  2845.      IF ff^.Buffer=NIL THEN
  2846.      BEGIN
  2847.           IOResult:=DosWrite(ff^.Handle,pp^,Count*ff^.RecSize,result);
  2848.           IF IOResult<>0 THEN
  2849.           BEGIN
  2850.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2851.                ELSE exit;
  2852.           END;
  2853.           exit;
  2854.      END;
  2855.  
  2856.      result:=0;
  2857.      IOResult:=0;
  2858.      size:=Count*ff^.RecSize;
  2859.      Offset:=ff^.Offset;
  2860.  
  2861.      IF ff^.block=ff^.LBlock THEN
  2862.      BEGIN
  2863.           IF Offset=ff^.LOffset THEN
  2864.           BEGIN
  2865.                {am ende der Datei (im letzten Block und an LOffset)}
  2866.                IF Offset+size<ff^.MaxCacheMem THEN
  2867.                BEGIN
  2868.                     move(pp^,ff^.Buffer^[Offset],size);
  2869.                     inc(ff^.Offset,size);
  2870.                     inc(ff^.LOffset,size);
  2871.                     inc(result,size);
  2872.                     ff^.Changed:=TRUE;
  2873.                     result:=result DIV ff^.RecSize;
  2874.                     exit;
  2875.                END
  2876.                ELSE
  2877.                BEGIN
  2878.                     {Groesse geht über alten Block hinaus}
  2879. l:
  2880.                     ff^.Changed:=FALSE;
  2881.                     {alten Block Schreiben}
  2882.                     FileBlockIO(f,ff^.Block,WriteMode,Temp);
  2883.                     IF IOResult<>0 THEN
  2884.                     BEGIN
  2885.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  2886.                          ELSE exit;
  2887.                     END;
  2888. l1:
  2889.                     IOResult:=DosWrite(ff^.Handle,Buf,size,result);
  2890.                     IF IOResult<>0 THEN
  2891.                     BEGIN
  2892.                         IF RaiseIOError THEN InOutError(IOResult,Adr)
  2893.                         ELSE exit;
  2894.                     END;
  2895.                     size:=result; {Tatsächlich geschrieben}
  2896.  
  2897.                     {set file buffer}
  2898.                     Temp:=Offset+size;
  2899.                     t:=Temp MOD ff^.MaxCacheMem;
  2900.                     move(pp^[size-t],ff^.Buffer^,t);
  2901.  
  2902.                     inc(ff^.Block,Temp DIV ff^.MaxCacheMem);
  2903.                     ff^.Offset:=t;
  2904.  
  2905.                     {we are at the end of the file}
  2906.                     ff^.LBlock:=ff^.Block;
  2907.                     ff^.LOffset:=ff^.Offset;
  2908.                     result:=result DIV ff^.RecSize;
  2909.                     exit;
  2910.                END;
  2911.           END
  2912.           ELSE
  2913.           BEGIN
  2914.                {im letzten Block aber nicht an LOffset}
  2915.                IF Offset+size<ff^.LOffset THEN
  2916.                BEGIN
  2917.                     move(pp^,ff^.Buffer^[Offset],size);
  2918.                     inc(ff^.Offset,size);
  2919.                     inc(result,size);
  2920.                     ff^.Changed:=TRUE;
  2921.                     result:=result DIV ff^.RecSize;
  2922.                     exit;
  2923.                END;
  2924.                {ELSE goto l;}
  2925.           END;
  2926.      END
  2927.      ELSE
  2928.      BEGIN
  2929.           {irgendwo vor dem letzten Block}
  2930.           IF Offset+Size<ff^.MaxCacheMem THEN
  2931.           BEGIN
  2932.                move(pp^,ff^.Buffer^[Offset],size);
  2933.                inc(ff^.Offset,size);
  2934.                inc(result,size);
  2935.                ff^.Changed:=TRUE;
  2936.                result:=result DIV ff^.RecSize;
  2937.                exit;
  2938.           END;
  2939.      END;
  2940.  
  2941. (*   IF Offset+Size>(ff^.LBlock*ff^.MaxCacheMem)+ff^.LOffset THEN
  2942.      BEGIN
  2943.           ff^.Changed:=FALSE;
  2944.           OldBlock:=ff^.LBlock;    {temporaray save}
  2945.           OldOfs:=ff^.LOffset;
  2946.           ff^.LBlock:=ff^.Block;
  2947.           ff^.LOffset:=Offset;
  2948.           {alten Block Schreiben}
  2949.           FileBlockIO(f,ff^.Block,WriteMode,Temp);
  2950.           IF IOResult<>0 THEN
  2951.           BEGIN
  2952.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  2953.                ELSE exit;
  2954.           END;
  2955.           ff^.LBlock:=OldBlock;
  2956.           ff^.LOffset:=OldOfs;
  2957.           goto l1;
  2958.      END;*)
  2959.  
  2960.      ff^.reserved1:=ff^.reserved1 and not 1;
  2961.  
  2962.      FOR t:=1 TO size DO
  2963.      BEGIN
  2964.           value:=pp^[t-1];
  2965.           IF value<>ff^.Buffer^[ff^.offset] THEN
  2966.           BEGIN
  2967.                ff^.Buffer^[ff^.offset]:=value;
  2968.                ff^.Changed:=TRUE;
  2969.           END;
  2970.           IF EOF(f) THEN
  2971.           BEGIN
  2972.                ff^.changed:=TRUE;
  2973.                FileExpand(f);
  2974.           END;
  2975.           inc(ff^.Offset);
  2976.           inc(Result);
  2977.  
  2978.           IF ff^.Offset=ff^.MaxCacheMem THEN
  2979.           BEGIN
  2980.                ff^.Changed:=FALSE;
  2981.                {alten Block Schreiben}
  2982.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  2983.                IF IOResult<>0 THEN
  2984.                BEGIN
  2985.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  2986.                     ELSE exit;
  2987.                END;
  2988.                {neuen Block lesen}
  2989.                ff^.Offset:=0;
  2990.                inc(ff^.Block);
  2991.                FileBlockIO(f,ff^.Block,ReadMode,Temp);
  2992.                IF IOResult<>0 THEN
  2993.                BEGIN
  2994.                    IF RaiseIOError THEN InOutError(IOResult,Adr)
  2995.                    ELSE exit;
  2996.                END;
  2997.           END;
  2998.      END;
  2999.      result:=result DIV ff^.RecSize;
  3000. END;
  3001.  
  3002. PROCEDURE Rename(VAR f:file;NewName:String);
  3003. VAR
  3004.    c,c1:CSTRING;
  3005.    ff:^FileRec;
  3006.    Adr:LONGINT;
  3007. BEGIN
  3008.      ASM
  3009.         MOV EAX,[EBP+4]
  3010.         SUB EAX,5
  3011.         MOV $Adr,EAX
  3012.      END;
  3013.      ff:=@f;
  3014.      c:=NewName;
  3015.      c1:=ff^.Name;
  3016.      IOResult:=DosMove(c1,c);
  3017.      IF IOResult<>0 THEN
  3018.      BEGIN
  3019.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3020.           ELSE exit;
  3021.      END;
  3022. END;
  3023.  
  3024. PROCEDURE Erase(VAR f:file);
  3025. VAR
  3026.    ff:^FileRec;
  3027.    c:CSTRING;
  3028.    Adr:LONGINT;
  3029. BEGIN
  3030.      ASM
  3031.         MOV EAX,[EBP+4]
  3032.         SUB EAX,5
  3033.         MOV $Adr,EAX
  3034.      END;
  3035.      ff:=@f;
  3036.      IF ff^.flags<>$6666 THEN
  3037.      BEGIN
  3038.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  3039.           ELSE
  3040.           BEGIN
  3041.                IOResult:=206;
  3042.                exit;
  3043.           END;
  3044.      END;
  3045.      c:=ff^.name;
  3046.      IoResult:=DosDelete(c);
  3047.      IF IOResult<>0 THEN
  3048.      BEGIN
  3049.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3050.           ELSE exit;
  3051.      END;
  3052. END;
  3053.  
  3054. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  3055. BEGIN
  3056.      IF BufSize<4096 THEN BufSize:=4096;
  3057. END;
  3058.  
  3059. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  3060. BEGIN
  3061.      if BufSize>16*1024 then SetFileBuf(F,Buf,BufSize);
  3062. END;
  3063.  
  3064. PROCEDURE StrWriteText({VAR f:FILE}CONST s:STRING;format:LONGWORD);
  3065. VAR
  3066.     fi:^FILE;
  3067.     ss:STRING;
  3068.     fillup:BYTE;
  3069.     Adr:LONGINT;
  3070.     SaveIO:BOOLEAN;
  3071. BEGIN
  3072.      ASM
  3073.         MOV EAX,[EBP+16]  //VAR f:FILE
  3074.         MOV $fi,EAX
  3075.      END;
  3076.      ASM
  3077.         MOV EAX,[EBP+4]
  3078.         SUB EAX,5
  3079.         MOV $Adr,EAX
  3080.      END;
  3081.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  3082.      IF format>length(s) THEN
  3083.      BEGIN
  3084.           fillup:=format-length(s);  {erst soviele Leerzeichen}
  3085.           fillchar(ss[0],fillup,32);
  3086.           SaveIO:=RaiseIOError;
  3087.           RaiseIOError:=FALSE;
  3088.           BlockWrite(fi^,ss[0],fillup);
  3089.           RaiseIOError:=SaveIO;
  3090.           IF IOResult<>0 THEN
  3091.           BEGIN
  3092.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  3093.                ELSE exit;
  3094.           END;
  3095.      END;
  3096.      SaveIO:=RaiseIOError;
  3097.      RaiseIOError:=FALSE;
  3098.      {must do this in ASM because s is constant parameter}
  3099.      ASM
  3100.         PUSHL $fi
  3101.         MOV EDI,$s
  3102.         INC EDI
  3103.         PUSH EDI
  3104.         DEC EDI
  3105.         MOVZXB EAX,[EDI+0]
  3106.         PUSH EAX
  3107.         PUSHL OFFSET(SYSTEM.BlockWriteResult)
  3108.         CALLN32 SYSTEM.BlockWrite
  3109.      END;
  3110.      RaiseIOError:=SaveIO;
  3111.      IF IOResult<>0 THEN
  3112.      BEGIN
  3113.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3114.           ELSE exit;
  3115.      END;
  3116. END;
  3117.  
  3118. PROCEDURE CStrWriteText({VAR f:FILE}CONST s:CSTRING;format:LONGWORD);
  3119. VAR
  3120.     ss:STRING;
  3121.     l:LONGWORD;
  3122.     fi:^FILE;
  3123.     fillup:BYTE;
  3124.     Adr:LONGINT;
  3125.     SaveIO:BOOLEAN;
  3126. BEGIN
  3127.      ASM
  3128.         MOV EAX,[EBP+16]  //VAR f:FILE
  3129.         MOV $fi,EAX
  3130.      END;
  3131.      ASM
  3132.         MOV EAX,[EBP+4]
  3133.         SUB EAX,5
  3134.         MOV $Adr,EAX
  3135.      END;
  3136.      l:=length(s);
  3137.      IF Format+l>255 THEN Format:=255-l;
  3138.      IF format>l THEN
  3139.      BEGIN
  3140.           fillup:=format-l;
  3141.           fillchar(ss[0],fillup,32);
  3142.           SaveIO:=RaiseIOError;
  3143.           RaiseIOError:=FALSE;
  3144.           BlockWrite(fi^,ss[0],fillup);
  3145.           RaiseIOError:=SaveIO;
  3146.           IF IOResult<>0 THEN
  3147.           BEGIN
  3148.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  3149.                ELSE exit;
  3150.           END;
  3151.      END;
  3152.      SaveIO:=RaiseIOError;
  3153.      RaiseIOError:=FALSE;
  3154.      {must do this in ASM because s is constant parameter}
  3155.      ASM
  3156.         PUSHL $fi
  3157.         PUSHL $s
  3158.         PUSHL $l
  3159.         PUSHL OFFSET(SYSTEM.BlockWriteResult)
  3160.         CALLN32 SYSTEM.BlockWrite
  3161.      END;
  3162.      RaiseIOError:=SaveIO;
  3163.      IF IOResult<>0 THEN
  3164.      BEGIN
  3165.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3166.           ELSE exit;
  3167.      END;
  3168. END;
  3169.  
  3170. {Float value is in ST(0) !}
  3171. PROCEDURE WriteExtendedText({VAR f:FILE}Format1,Format2:LONGWORD);
  3172. VAR
  3173.    float:EXTENDED;
  3174.    fi:^FILE;
  3175.    s:STRING;
  3176.    Adr:LONGINT;
  3177.    SaveIO:BOOLEAN;
  3178. BEGIN
  3179.      ASM
  3180.         MOV EAX,[EBP+4]
  3181.         SUB EAX,5
  3182.         MOV $Adr,EAX
  3183.      END;
  3184.      ASM
  3185.         MOV EAX,[EBP+16]  //VAR f:FILE
  3186.         MOV $fi,EAX
  3187.         FSTPT $float
  3188.  
  3189.         PUSHL $Format1
  3190.         PUSHL $Format2     //Nachkommas
  3191.         LEA EAX,$float
  3192.         PUSH EAX
  3193.         LEA EAX,$s
  3194.         PUSH EAX
  3195.         CALLN32 SYSTEM.!Extended2Str
  3196.       END;
  3197.       SaveIO:=RaiseIOError;
  3198.       RaiseIOError:=FALSE;
  3199.       BlockWrite(fi^,s[1],length(s));
  3200.       RaiseIOError:=SaveIO;
  3201.       IF IOResult<>0 THEN
  3202.       BEGIN
  3203.            IF RaiseIOError THEN InOutError(IOResult,Adr)
  3204.            ELSE exit;
  3205.       END;
  3206. END;
  3207.  
  3208. PROCEDURE WritelnText(VAR f:FILE);
  3209. VAR
  3210.    w:WORD;
  3211.    Adr:LONGINT;
  3212.    SaveIO:BOOLEAN;
  3213. BEGIN
  3214.      ASM
  3215.         MOV EAX,[EBP+4]
  3216.         SUB EAX,5
  3217.         MOV $Adr,EAX
  3218.      END;
  3219.      {Write #13#10}
  3220.      w:=$0a0d;
  3221.      SaveIO:=RaiseIOError;
  3222.      RaiseIOError:=FALSE;
  3223.      BlockWrite(f,w,2);
  3224.      RaiseIOError:=SaveIO;
  3225.      IF IOResult<>0 THEN
  3226.      BEGIN
  3227.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3228.           ELSE exit;
  3229.      END;
  3230. END;
  3231.  
  3232. PROCEDURE WriteText(VAR f:FILE);
  3233. BEGIN
  3234.      {do nothing here - just pop f}
  3235. END;
  3236.  
  3237. PROCEDURE FileWrite({VAR f:FILE)}VAR Buf;size:LONGWORD);
  3238. VAR
  3239.    fi:^FILE;
  3240.    fr:^FileRec;
  3241.    Adr:LONGINT;
  3242.    SaveIO:BOOLEAN;
  3243. BEGIN
  3244.      ASM
  3245.         MOV EAX,[EBP+16]  //VAR f:FILE
  3246.         MOV $fi,EAX
  3247.         MOV $fr,EAX
  3248.      END;
  3249.      ASM
  3250.         MOV EAX,[EBP+4]
  3251.         SUB EAX,5
  3252.         MOV $Adr,EAX
  3253.      END;
  3254.      SaveIO:=RaiseIOError;
  3255.      RaiseIOError:=FALSE;
  3256.      BlockWrite(fi^,Buf,size DIV fr^.RecSize);
  3257.      RaiseIOError:=SaveIO;
  3258.      IF IOResult<>0 THEN
  3259.      BEGIN
  3260.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3261.           ELSE exit;
  3262.      END;
  3263. END;
  3264.  
  3265. PROCEDURE FileRead({VAR f:FILE}VAR Buf;size:LONGWORD);
  3266. VAR
  3267.    fi:^FILE;
  3268.    fr:^FileRec;
  3269.    Adr:LONGINT;
  3270.    SaveIO:BOOLEAN;
  3271. BEGIN
  3272.      ASM
  3273.         MOV EAX,[EBP+4]
  3274.         SUB EAX,5
  3275.         MOV $Adr,EAX
  3276.      END;
  3277.      ASM
  3278.         MOV EAX,[EBP+16]  //VAR f:FILE
  3279.         MOV $fi,EAX
  3280.         MOV $fr,EAX
  3281.      END;
  3282.  
  3283.      SaveIO:=RaiseIOError;
  3284.      RaiseIOError:=FALSE;
  3285.      BlockRead(fi^,Buf,size DIV fr^.RecSize);
  3286.      RaiseIOError:=SaveIO;
  3287.      IF IOResult<>0 THEN
  3288.      BEGIN
  3289.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3290.           ELSE exit;
  3291.      END;
  3292. END;
  3293.  
  3294. FUNCTION SeekEoln(VAR F:Text):Boolean;
  3295. VAR
  3296.     Adr:LONGINT;
  3297.     fi:^FileRec;
  3298.     Offset:LONGINT;
  3299.     Value:BYTE;
  3300.     SaveIoError:BOOLEAN;
  3301.     Res:LONGWORD;
  3302.     t:BYTE;
  3303.     s:STRING;
  3304. BEGIN
  3305.      ASM
  3306.         MOV EAX,[EBP+4]
  3307.         SUB EAX,5
  3308.         MOV $Adr,EAX
  3309.      END;
  3310.  
  3311.      fi:=@f;
  3312.  
  3313.      IF fi^.flags<>$6666 THEN
  3314.      BEGIN
  3315.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  3316.           ELSE
  3317.           BEGIN
  3318.                IOResult:=206;
  3319.                exit;
  3320.           END;
  3321.      END;
  3322.  
  3323.      IF fi^.Handle=$ffffffff THEN
  3324.      BEGIN
  3325.          IOResult:=6; {Invalid handle}
  3326.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3327.          ELSE exit;
  3328.      END;
  3329.  
  3330.      IF eof(f) THEN
  3331.      BEGIN
  3332.           result:=TRUE;
  3333.           exit;
  3334.      END;
  3335.  
  3336.      Offset:=fi^.Offset;
  3337.  
  3338.      IF fi^.Buffer=NIL THEN
  3339.      BEGIN
  3340.           IF lo(fi^.BufferBytes)=1 THEN
  3341.           BEGIN
  3342.                Value:=Hi(fi^.BufferBytes);
  3343.           END
  3344.           ELSE
  3345.           BEGIN
  3346.                SaveIOError:=RaiseIOError;
  3347.                RaiseIOError:=FALSE;
  3348.                BlockRead(f,Value,1,Res);
  3349.                Seek(f,FilePos(f)-1);
  3350.                RaiseIOError:=SaveIOError;
  3351.                IF Res=0 THEN Value:=26; {EOF}
  3352.           END;
  3353.      END
  3354.      ELSE value:=fi^.Buffer^[Offset];
  3355.  
  3356.      IF value IN [13,10,26] THEN result:=TRUE
  3357.      ELSE
  3358.      BEGIN
  3359.           IF not (value IN [9,32]) THEN result:=FALSE
  3360.           ELSE  {must read the line}
  3361.           BEGIN
  3362.                SaveIOError:=RaiseIOError;
  3363.                RaiseIOError:=FALSE;
  3364.  
  3365.                Offset:=FilePos(f);
  3366.                Readln(f,s);
  3367.                Seek(f,Offset);
  3368.  
  3369.                RaiseIOError:=SaveIOError;
  3370.                result:=TRUE;
  3371.                FOR t:=1 TO length(s) DO
  3372.                  IF not (s[t] IN [#9,#32]) THEN result:=FALSE;
  3373.           END;
  3374.      END;
  3375. END;
  3376.  
  3377. FUNCTION SeekEof(Var F :Text):Boolean;
  3378. VAR
  3379.     Adr:LONGINT;
  3380.     fi:^FileRec;
  3381.     OldFP:LONGWORD;
  3382.     ch:Char;
  3383. BEGIN
  3384.      ASM
  3385.         MOV EAX,[EBP+4]
  3386.         SUB EAX,5
  3387.         MOV $Adr,EAX
  3388.      END;
  3389.  
  3390.      fi:=@f;
  3391.  
  3392.      IF fi^.flags<>$6666 THEN
  3393.      BEGIN
  3394.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  3395.           ELSE
  3396.           BEGIN
  3397.                IOResult:=206;
  3398.                exit;
  3399.           END;
  3400.      END;
  3401.  
  3402.      IF fi^.Handle=$ffffffff THEN
  3403.      BEGIN
  3404.          IOResult:=6; {Invalid handle}
  3405.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3406.          ELSE exit;
  3407.      END;
  3408.  
  3409.      OldFP := FilePos(F);
  3410.  
  3411.      WHILE not Eof(F) DO
  3412.      BEGIN
  3413.           Read(F,ch);
  3414.           IF not (ch IN [#32,#9,#13,#10]) THEN break;
  3415.      END;
  3416.  
  3417.      Result := Eof(f);
  3418.      Seek(F,OldFP);
  3419. END;
  3420.  
  3421. PROCEDURE TextRead({VAR f:TEXT;VAR Ziel;}VAR s:STRING;Typ,MaxLen:LONGWORD);
  3422. VAR
  3423.    fi:^FileRec;
  3424.    fi2:^TEXT;
  3425.    Offset,Ende,t,Temp,Res,Res1:LONGWORD;
  3426.    Count:WORD;
  3427.    Value:BYTE;
  3428.    SaveIoError:BOOLEAN;
  3429.    Adr:LONGINT;
  3430. LABEL l,skip;
  3431. BEGIN
  3432.      ASM
  3433.         MOV EAX,[EBP+4]
  3434.         SUB EAX,5
  3435.         MOV $Adr,EAX
  3436.      END;
  3437.      ASM
  3438.         MOV EAX,[EBP+24]  //VAR f:TEXT
  3439.         MOV $fi,EAX
  3440.         MOV $fi2,EAX
  3441.      END;
  3442.  
  3443.      IF fi^.flags<>$6666 THEN
  3444.      BEGIN
  3445.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  3446.           ELSE
  3447.           BEGIN
  3448.                IOResult:=206;
  3449.                exit;
  3450.           END;
  3451.      END;
  3452.  
  3453.      IF fi^.Handle=$ffffffff THEN
  3454.      BEGIN
  3455.          IOResult:=6; {Invalid handle}
  3456.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3457.          ELSE exit;
  3458.      END;
  3459.  
  3460.      fi^.reserved1:=fi^.reserved1 and not 1;
  3461.  
  3462.      IF eof(fi2^) THEN
  3463.      BEGIN
  3464.           (*IOResult:=38;  {Handle EOF}
  3465.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3466.           ELSE exit;*)
  3467.           CASE Typ OF
  3468.             1:s:=''; {String}
  3469.             2:s:=chr(26); {Char}
  3470.             3:s:=''; {Number}
  3471.             ELSE s:='';
  3472.           END; {case}
  3473.           exit;
  3474.      END;
  3475.  
  3476.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  3477.      ELSE Ende:=fi^.LOffset;
  3478.  
  3479.      Count:=0;
  3480.      s:='';
  3481.  
  3482.      Offset:=fi^.Offset;
  3483.  
  3484.      IF fi^.Buffer=NIL THEN
  3485.      BEGIN
  3486.           Offset:=0;
  3487.           Ende:=256;
  3488.      END;
  3489.  
  3490.      fi^.reserved1:=fi^.reserved1 and not 1;
  3491. l:
  3492.      FOR t:=Offset TO Ende-1 DO
  3493.      BEGIN
  3494.           IF fi^.Buffer=NIL THEN
  3495.           BEGIN
  3496.                IF lo(fi^.BufferBytes)=1 THEN
  3497.                BEGIN
  3498.                     Value:=Hi(fi^.BufferBytes);
  3499.                     fi^.BufferBytes:=0;
  3500.                END
  3501.                ELSE
  3502.                BEGIN
  3503.                     SaveIOError:=RaiseIOError;
  3504.                     RaiseIOError:=FALSE;
  3505.                     BlockRead(fi2^,Value,1,Res);
  3506.                     RaiseIOError:=SaveIOError;
  3507.                     IF IOResult<>0 THEN
  3508.                     BEGIN
  3509.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3510.                          ELSE exit;
  3511.                     END;
  3512.                     IF Res=0 THEN Value:=26; {EOF}
  3513.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  3514.                END;
  3515.           END
  3516.           ELSE value:=fi^.Buffer^[t];
  3517.  
  3518.           IF value=26 {EOF} THEN
  3519.           BEGIN
  3520.                {SaveIoError:=RaiseIoError;
  3521.                RaiseIOError:=FALSE;
  3522.                Seek(fi2^,FileSize(fi2^));
  3523.                RaiseIOError:=SaveIoError;}
  3524.                fi^.Reserved1:=fi^.Reserved1 OR 1;  {mark EOF}
  3525.                IF Count>255 THEN Count:=255;
  3526.                s[0]:=chr(Count);
  3527.                IF s='' THEN s:=#26;
  3528.                inc(fi^.Offset);
  3529.                fi^.BufferBytes:=0;
  3530.                exit;
  3531.           END;
  3532.  
  3533.           CASE Typ OF
  3534.             1:  {String}
  3535.             BEGIN
  3536.                  CASE value OF
  3537.                    13,10:
  3538.                    BEGIN
  3539.                         IF Count>255 THEN Count:=255;
  3540.                         IF Count>255 THEN Count:=255;
  3541.                         s[0]:=chr(Count);
  3542.                         exit;
  3543.                    END;
  3544.                  END; {case}
  3545.             END;
  3546.             2:  {Char}
  3547.             BEGIN
  3548.                  s[1]:=chr(Value);
  3549.                  s[0]:=#1;
  3550.  
  3551.                  IF fi^.Buffer<>NIL THEN inc(fi^.Offset)
  3552.                  ELSE fi^.BufferBytes:=0;
  3553.                  IF fi^.Offset=Ende THEN
  3554.                  BEGIN
  3555.                       IF Eof(fi2^) THEN exit;
  3556.  
  3557.                       {Ende erreicht --> erweitern}
  3558.                       IF fi^.Buffer=NIL THEN exit;
  3559.                       FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  3560.                       IF IOResult<>0 THEN
  3561.                       BEGIN
  3562.                           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3563.                           ELSE exit;
  3564.                       END;
  3565.                       fi^.offset:=0;
  3566.                       inc(fi^.block);
  3567.                  END;
  3568.                  exit;
  3569.             END;
  3570.             3:  {Number}
  3571.             BEGIN
  3572.                  CASE value OF
  3573.                    13,10,32,9:
  3574.                    BEGIN
  3575.                         IF Count=0 THEN goto skip; {skip preceding chars}
  3576.                         IF Count>255 THEN Count:=255;
  3577.                         s[0]:=chr(Count);
  3578.                         exit;
  3579.                    END;
  3580.                  END; {case}
  3581.             END;
  3582.           END; {case}
  3583.  
  3584.           inc(Count);
  3585.           IF Count<256 THEN IF Count<=MaxLen THEN s[Count]:=chr(value);
  3586. skip:
  3587.           inc(fi^.Offset);
  3588.           fi^.BufferBytes:=0;
  3589.           IF Count>=MaxLen THEN
  3590.           BEGIN
  3591.                IF Count>255 THEN Count:=255;
  3592.                s[0]:=chr(Count);
  3593.                exit;
  3594.           END;
  3595.      END;
  3596.  
  3597.      IF eof(fi2^) THEN
  3598.      BEGIN
  3599.           (*IOResult:=38;  {Handle EOF}
  3600.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3601.           ELSE exit;*)
  3602.           IF Count>255 THEN Count:=255;
  3603.           s[0]:=chr(Count);
  3604.           exit;
  3605.      END;
  3606.  
  3607.      {Ende erreicht --> erweitern}
  3608.      IF fi^.Buffer<>NIL THEN
  3609.      BEGIN
  3610.           FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  3611.           IF IOResult<>0 THEN
  3612.           BEGIN
  3613.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  3614.               ELSE exit;
  3615.           END;
  3616.  
  3617.           fi^.offset:=0;
  3618.           inc(fi^.block);
  3619.      END;
  3620.  
  3621.      IF eof(fi2^) THEN
  3622.      BEGIN
  3623.           IOResult:=38;  {Handle EOF}
  3624.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  3625.           ELSE exit;
  3626.      END;
  3627.  
  3628.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  3629.      ELSE Ende:=fi^.LOffset;
  3630.      Offset:=fi^.Offset;
  3631.      IF fi^.Buffer=NIL THEN
  3632.      BEGIN
  3633.           Offset:=0;
  3634.           Ende:=256;
  3635.      END;
  3636.      goto l;
  3637. END;
  3638.  
  3639. PROCEDURE TextReadLF(VAR f:TEXT);
  3640. VAR
  3641.    fi:^FileRec;
  3642.    Offset,Ende,t,Temp,Res:LONGWORD;
  3643.    Value:BYTE;
  3644.    Read13,Read10:BOOLEAN;
  3645.    Adr:LONGINT;
  3646.    SaveIO:BOOLEAN;
  3647. LABEL l;
  3648. BEGIN
  3649.      ASM
  3650.         MOV EAX,[EBP+4]
  3651.         SUB EAX,5
  3652.         MOV $Adr,EAX
  3653.      END;
  3654.      fi:=@f;
  3655.  
  3656.      IF fi^.flags<>$6666 THEN
  3657.      BEGIN
  3658.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  3659.           ELSE
  3660.           BEGIN
  3661.                IOResult:=206;
  3662.                exit;
  3663.           END;
  3664.      END;
  3665.  
  3666.      IF fi^.Handle=$ffffffff THEN
  3667.      BEGIN
  3668.          IOResult:=6; {Invalid handle}
  3669.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3670.          ELSE exit;
  3671.      END;
  3672.  
  3673.      fi^.reserved1:=fi^.reserved1 and not 1;
  3674.  
  3675.      IF Eof(f) THEN exit;
  3676.  
  3677.      Offset:=fi^.Offset;
  3678.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  3679.      ELSE Ende:=fi^.LOffset;
  3680.  
  3681.      IF fi^.Buffer=NIL THEN
  3682.      BEGIN
  3683.           Offset:=0;
  3684.           Ende:=256;
  3685.      END;
  3686.  
  3687.      Read13:=FALSE;
  3688.      Read10:=FALSE;
  3689. l:
  3690.      FOR t:=Offset TO Ende-1 DO
  3691.      BEGIN
  3692.           IF fi^.Buffer=NIL THEN
  3693.           BEGIN
  3694.                IF lo(fi^.BufferBytes)=1 THEN
  3695.                BEGIN
  3696.                     Value:=Hi(fi^.BufferBytes);
  3697.                     fi^.BufferBytes:=0;
  3698.                END
  3699.                ELSE
  3700.                BEGIN
  3701.                     SaveIO:=RaiseIOError;
  3702.                     RaiseIOError:=FALSE;
  3703.                     BlockRead(f,Value,1,Res);
  3704.                     RaiseIOError:=SaveIO;
  3705.                     IF IOResult<>0 THEN
  3706.                     BEGIN
  3707.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  3708.                          ELSE exit;
  3709.                     END;
  3710.                     IF Res=0 THEN Value:=26; {EOF}
  3711.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  3712.                END;
  3713.           END
  3714.           ELSE value:=fi^.Buffer^[t];
  3715.           CASE value OF
  3716.             26: {EOF}
  3717.             BEGIN
  3718.                fi^.Reserved1:=fi^.Reserved1 OR 1; {mark EOF}
  3719.                exit;
  3720.             END;
  3721.             13:
  3722.             BEGIN
  3723.                  IF ((Read13)OR(Read10)) THEN
  3724.                  BEGIN
  3725.                       fi^.BufferBytes:=0;
  3726.                       exit;
  3727.                  END;
  3728.                  Read13:=TRUE;
  3729.             END;
  3730.             10:
  3731.             BEGIN
  3732.                  IF Read10 THEN
  3733.                  BEGIN
  3734.                       fi^.BufferBytes:=0;
  3735.                       exit;
  3736.                  END;
  3737.                  IF f=Input THEN IF Read13 THEN
  3738.                  BEGIN
  3739.                       fi^.BufferBytes:=0;
  3740.                       exit;
  3741.                  END;
  3742.                  Read10:=TRUE;
  3743.             END;
  3744.             ELSE
  3745.             BEGIN
  3746.                  IF Read13 THEN
  3747.                  BEGIN
  3748.                       fi^.BufferBytes:=0;
  3749.                       exit;
  3750.                  END;
  3751.                  IF Read10 THEN
  3752.                  BEGIN
  3753.                       fi^.BufferBytes:=0;
  3754.                       exit;
  3755.                  END;
  3756.             END;
  3757.           END; {case}
  3758.           inc(fi^.Offset);
  3759.           fi^.BufferBytes:=0;
  3760.      END;
  3761.  
  3762.      IF Eof(f) THEN exit;
  3763.  
  3764.      {Ende erreicht --> erweitern}
  3765.      IF fi^.Buffer<>NIL THEN
  3766.      BEGIN
  3767.          FileBlockIO(f,fi^.block+1,ReadMode,Temp);
  3768.          IF IOResult<>0 THEN
  3769.          BEGIN
  3770.              IF RaiseIOError THEN InOutError(IOResult,Adr)
  3771.              ELSE exit;
  3772.          END;
  3773.          fi^.offset:=0;
  3774.          inc(fi^.block);
  3775.      END;
  3776.  
  3777.      IF eof(f) THEN exit;
  3778.  
  3779.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  3780.      ELSE Ende:=fi^.LOffset;
  3781.      Offset:=fi^.Offset;
  3782.      IF fi^.Buffer=NIL THEN
  3783.      BEGIN
  3784.           Offset:=0;
  3785.           Ende:=256;
  3786.      END;
  3787.      goto l;
  3788. END;
  3789.  
  3790. PROCEDURE ReadLnText(VAR source:TEXT);
  3791. BEGIN
  3792.      TextReadLF(source);
  3793. END;
  3794.  
  3795. //TextScreen IO support
  3796.  
  3797. TYPE ProcVar=PROCEDURE;
  3798.  
  3799. PROCEDURE TScreenInOutClass.WriteStr(CONST s:STRING);
  3800. VAR
  3801.    actual:LONGWORD;
  3802.    by,by1:LONGWORD;
  3803.    Handle:LONGWORD;
  3804.    b:BYTE;
  3805.    ff:^FileRec;
  3806.    s1,s2:STRING;
  3807.    y:LONGINT;
  3808.    Fill:WORD;
  3809. LABEL l,l1;
  3810. BEGIN
  3811.      ff:=@Output;
  3812.      Handle:=ff^.Handle;
  3813.  
  3814.      IF RedirectOut THEN goto l1;
  3815.  
  3816.      s1:=s;
  3817.      b:=Pos(#13#10,s1);
  3818.      WHILE b<>0 DO
  3819.      BEGIN
  3820.           s2:=s1;
  3821.           s1:=copy(s1,1,b-1);
  3822.           WriteStr(s1);
  3823.           s1:=#13#10;
  3824.           ASM
  3825.             LEA EAX,$actual
  3826.             PUSH EAX                //pcbActual
  3827.             LEA EDI,$s1
  3828.             MOVZXB EAX,[EDI]
  3829.             PUSH EAX               //cbWrite
  3830.             INC EDI
  3831.             PUSH EDI               //pBuffer
  3832.             PUSHL $Handle          //FileHandle
  3833.             MOV AL,4
  3834.             CALLDLL DosCalls,282   //DosWrite
  3835.             ADD ESP,16
  3836.           END;
  3837.           y:=VioWhereYProc;
  3838.           IF y-1>Hi(WindMax) THEN
  3839.           BEGIN
  3840.               {Scroll window}
  3841.               Fill:= 32 + WORD(TextAttr) SHL 8;
  3842.               VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  3843.                               Hi(WindMax),Lo(WindMax),
  3844.                               1,Fill,0);
  3845.               dec(y);
  3846.           END;
  3847.           GotoXY(1,y-Hi(WindMin));
  3848.           s1:=copy(s2,b+2,length(s2)-(b+1));
  3849.           b:=Pos(#13#10,s1);
  3850.      END;
  3851.  
  3852.      IF length(s1)>(Lo(WindMax)-Lo(WindMin)-
  3853.               (VioWhereXProc-lo(WindMin)))+1 THEN
  3854.      BEGIN
  3855.           by:=(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+2;
  3856.           by1:=length(s1)-by;
  3857. l:
  3858.           ASM
  3859.              LEA EAX,$actual
  3860.              PUSH EAX               //pcbActual
  3861.              LEA EDI,$s1
  3862.              INC EDI
  3863.              PUSHL $by              //cbWrite
  3864.              PUSH EDI               //pBuffer
  3865.              PUSHL $Handle          //FileHandle
  3866.              MOV AL,4
  3867.              CALLDLL DosCalls,282   //DosWrite
  3868.              ADD ESP,16
  3869.           END;
  3870.           s1:=copy(s1,by+1,length(s1)-by);
  3871.  
  3872.           IF ((WindMin<>MaxWindMin)OR(WindMax<>MaxWindMax)) THEN WriteLF;
  3873.  
  3874.           IF length(s1)>(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+1 THEN
  3875.           BEGIN
  3876.                by:=(Lo(WindMax)-Lo(WindMin)-(VioWhereXProc-lo(WindMin)))+2;
  3877.                by1:=length(s1)-by;
  3878.                goto l;
  3879.           END;
  3880.  
  3881.           ASM
  3882.              LEA EAX,$actual
  3883.              PUSH EAX               //pcbActual
  3884.              LEA EDI,$s1
  3885.              INC EDI
  3886.              PUSHL $by1             //cbWrite
  3887.              PUSH EDI               //pBuffer
  3888.              PUSHL $Handle          //FileHandle
  3889.              MOV AL,4
  3890.              CALLDLL DosCalls,282   //DosWrite
  3891.              ADD ESP,16
  3892.           END;
  3893.  
  3894.           exit;
  3895.      END;
  3896. l1:
  3897.      ASM
  3898.         LEA EAX,$actual
  3899.         PUSH EAX                //pcbActual
  3900.         LEA EDI,$s1
  3901.         MOVZXB EAX,[EDI]
  3902.         PUSH EAX               //cbWrite
  3903.         INC EDI
  3904.         PUSH EDI               //pBuffer
  3905.         PUSHL $Handle          //FileHandle
  3906.         MOV AL,4
  3907.         CALLDLL DosCalls,282   //DosWrite
  3908.         ADD ESP,16
  3909.      END;
  3910. END;
  3911.  
  3912. PROCEDURE TScreenInOutClass.WriteCStr(CONST s:CSTRING);
  3913. VAR
  3914.    c:STRING;
  3915.    b:LONGWORD;
  3916.    pc:^CSTRING;
  3917. LABEL l;
  3918. BEGIN
  3919.      pc:=@s;
  3920. l:
  3921.      b:=Length(pc^);
  3922.      IF b<255 THEN
  3923.      BEGIN
  3924.           c:=pc^;
  3925.           WriteStr(c);
  3926.      END
  3927.      ELSE
  3928.      BEGIN
  3929.           move(pc^,c[1],255);
  3930.           c[0]:=#255;
  3931.           inc(pc,255);
  3932.           WriteStr(c);
  3933.           goto l;
  3934.      END;
  3935. END;
  3936.  
  3937. PROCEDURE TScreenInOutClass.WriteLF;
  3938. VAR y:BYTE;
  3939.     Fill:WORD;
  3940.     s:STRING[3];
  3941.     actual:LONGWORD;
  3942.     ff:^FileRec;
  3943.     Handle:LONGWORD;
  3944. BEGIN
  3945.      s:=#13#10;
  3946.      ff:=@Output;
  3947.      Handle:=ff^.Handle;
  3948.  
  3949.      ASM
  3950.         LEA EAX,$actual
  3951.         PUSH EAX                //pcbActual
  3952.         LEA EDI,$s
  3953.         MOVZXB EAX,[EDI]
  3954.         PUSH EAX               //cbWrite
  3955.         INC EDI
  3956.         PUSH EDI               //pBuffer
  3957.         PUSHL $Handle          //FileHandle
  3958.         MOV AL,4
  3959.         CALLDLL DosCalls,282   //DosWrite
  3960.         ADD ESP,16
  3961.      END;
  3962.  
  3963.      y:=VioWhereYProc;
  3964.      IF y-1>Hi(WindMax) THEN
  3965.      BEGIN
  3966.           {Scroll window}
  3967.           Fill:= 32 + WORD(TextAttr) SHL 8;
  3968.           VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  3969.                           Hi(WindMax),Lo(WindMax),
  3970.                           1,Fill,0);
  3971.           dec(y);
  3972.      END;
  3973.      GOTOXY(1,y-Hi(WindMin));
  3974. END;
  3975.  
  3976. PROCEDURE TScreenInOutClass.ReadLF(VAR s:STRING);
  3977. TYPE
  3978.     STRINGINBUF=RECORD
  3979.                      cb:WORD;
  3980.                      cchIn:WORD;
  3981.                 END;
  3982. VAR si:STRINGINBUF;
  3983.     t:BYTE;
  3984.     ff:^FileRec;
  3985.     y:LONGINT;
  3986.     Fill:WORD;
  3987. BEGIN
  3988.      {si.cb:=255;
  3989.      si.cchin:=0;
  3990.      KbdStringInProc(s[1],si,0,0);
  3991.      s[0]:=chr(si.cchIn);}
  3992.      ASM
  3993.         PUSHD OFFSET(SYSTEM.Input)
  3994.         PUSHL 0
  3995.         MOV EAX,$s
  3996.         PUSH EAX
  3997.         PUSHL 1
  3998.         PUSHL 255
  3999.         CALLN32 SYSTEM.TextRead
  4000.         ADD ESP,8
  4001.         PUSHD OFFSET(SYSTEM.Input)
  4002.         CALLN32 SYSTEM.TextReadLF
  4003.      END;
  4004.      t:=Pos(#26,s);
  4005.      IF t<>0 THEN
  4006.      BEGIN
  4007.           ff:=@Input;
  4008.           ff^.Reserved1:=ff^.Reserved1 OR 1; {mark EOF}
  4009.           s[0]:=chr(t-1);
  4010.      END;
  4011.      y:=VioWhereYProc;
  4012.      IF y-1>Hi(WindMax) THEN
  4013.      BEGIN
  4014.           {Scroll window}
  4015.           Fill:= 32 + WORD(TextAttr) SHL 8;
  4016.           VioScrollUpProc(Hi(WindMin),Lo(WindMin),
  4017.                           Hi(WindMax),Lo(WindMax),
  4018.                           1,Fill,0);
  4019.           dec(y);
  4020.      END;
  4021.      ScreenInOut.GotoXY(1,y-Hi(WindMin));
  4022. END;
  4023.  
  4024. PROCEDURE TScreenInOutClass.GotoXY(x,y:BYTE);
  4025. BEGIN
  4026.      X:=X-1+Lo(WindMin);
  4027.      Y:=Y-1+Hi(WindMin);
  4028.      IF (X<=Lo(WindMax))and(Y<=Hi(WindMax)) THEN VioSetCurPosProc(Y,X,0);
  4029. END;
  4030.  
  4031. PROCEDURE TPMScreenInOutClass.Error;
  4032. VAR
  4033.    cs:CSTRING;
  4034.    cTitle:CSTRING;
  4035. BEGIN
  4036.      ctitle:='Wrong linker target';
  4037.      cs:='PM Linker mode does not support text screen IO.'+#13+
  4038.          'Use the unit WinCrt if you wish to use text'+#13+
  4039.          'screen IO inside PM applications.';
  4040.      WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  4041.      Halt(0);
  4042. END;
  4043.  
  4044. PROCEDURE TPMScreenInOutClass.WriteStr(CONST s:STRING);
  4045. BEGIN
  4046.      Error;
  4047. END;
  4048.  
  4049. PROCEDURE TPMScreenInOutClass.WriteCStr(CONST s:CSTRING);
  4050. BEGIN
  4051.      Error;
  4052. END;
  4053.  
  4054. PROCEDURE TPMScreenInOutClass.WriteLF;
  4055. BEGIN
  4056.      Error;
  4057. END;
  4058.  
  4059. PROCEDURE TPMScreenInOutClass.ReadLF(VAR s:STRING);
  4060. BEGIN
  4061.      Error;
  4062. END;
  4063.  
  4064. PROCEDURE TPMScreenInOutClass.GotoXY(x,y:BYTE);
  4065. BEGIN
  4066.      Error;
  4067. END;
  4068.  
  4069. IMPORTS
  4070.       FUNCTION DosLoadModule(pszName:CSTRING;cbName:LONGWORD;pszModname:CSTRING;
  4071.                              VAR phmod:LONGWORD):LONGWORD;
  4072.                     APIENTRY;             DOSCALLS index 318;
  4073.       FUNCTION DosQueryProcAddr(hmod:LONGWORD;ordinal:LONGWORD;
  4074.                                 VAR pszName:CSTRING;
  4075.                                 VAR ppfn:ProcVar):LONGWORD;
  4076.                     APIENTRY;             DOSCALLS index 321;
  4077. END;
  4078.  
  4079. TYPE
  4080.     VIOMODEINFO=RECORD {pack 1}
  4081.                      cb:WORD;
  4082.                      fbType:BYTE;
  4083.                      color:BYTE;
  4084.                      col:WORD;
  4085.                      row:WORD;
  4086.                      hres:WORD;
  4087.                      vres:WORD;
  4088.                      fmt_ID:BYTE;
  4089.                      attrib:BYTE;
  4090.                      buf_addr:LONGWORD;
  4091.                      buf_length:LONGWORD;
  4092.                      full_length:LONGWORD;
  4093.                      partial_length:LONGWORD;
  4094.                      ext_data_addr:POINTER;
  4095.                 END;
  4096.  
  4097. PROCEDURE InitScreenInOutPM;
  4098. VAR
  4099.    c:TPMScreenInOutClass;
  4100. BEGIN
  4101.      c.Create;
  4102.      ScreenInOut:=TScreenInOutClass(c);
  4103. END;
  4104.  
  4105. PROCEDURE InitScreenInOut;
  4106. VAR VioModule:LONGWORD;
  4107.     s:CSTRING;
  4108.     VioMode:VioModeInfo;
  4109.     Size,Value:WORD;
  4110. LABEL l;
  4111. BEGIN
  4112.      ScreenInOut.Create;
  4113.  
  4114.      IF DosLoadModule(s,255,'KBDVIO32',VioModule)<>0 THEN
  4115.      BEGIN
  4116. l:
  4117.           {ScreenInOut.WriteStr('RunError 217');}
  4118.           RunError(217);  {could not load KBDVIO32}
  4119.      END;
  4120.  
  4121.      IF DosQueryProcAddr(VioModule,40,NIL,ProcVar(VioScrollDnProc))<>0 THEN goto l;
  4122.      IF DosQueryProcAddr(VioModule,41,NIL,ProcVar(VioScrollUpProc))<>0 THEN goto l;
  4123.      IF DosQueryProcAddr(VioModule,33,NIL,ProcVar(VioGetModeProc))<>0 THEN goto l;
  4124.      IF DosQueryProcAddr(VioModule,34,NIL,ProcVar(VioSetModeProc))<>0 THEN goto l;
  4125.      IF DosQueryProcAddr(VioModule,3,NIL,ProcVar(VioWhereXProc))<>0 THEN goto l;
  4126.      IF DosQueryProcAddr(VioModule,4,NIL,ProcVar(VioWhereYProc))<>0 THEN goto l;
  4127.      IF DosQueryProcAddr(VioModule,30,NIL,ProcVar(VioSetCurPosProc))<>0 THEN goto l;
  4128.      IF DosQueryProcAddr(VioModule,36,NIL,ProcVar(VioReadCellStrProc))<>0 THEN goto l;
  4129.      IF DosQueryProcAddr(VioModule,64,NIL,ProcVar(VioGetConfigProc))<>0 THEN goto l;
  4130.  
  4131.      IF DosQueryProcAddr(VioModule,9,NIL,ProcVar(KbdStringInProc))<>0 THEN goto l;
  4132.      IF DosQueryProcAddr(VioModule,1,NIL,ProcVar(ReadKeyProc))<>0 THEN goto l;
  4133.      IF DosQueryProcAddr(VioModule,2,NIL,ProcVar(KeyPressedProc))<>0 THEN goto l;
  4134.  
  4135.      VioMode.cb := SizeOf(VioModeInfo);
  4136.      VioGetModeProc(VioMode, 0);
  4137.  
  4138.      WITH VioMode DO
  4139.      BEGIN
  4140.           IF Col = 40 THEN LastMode := BW40
  4141.           ELSE LastMode := BW80;
  4142.           IF (fbType AND 4) = 0 THEN
  4143.              IF LastMode = BW40 THEN LastMode := CO40
  4144.           ELSE LastMode := CO80;
  4145.           IF Color = 0 THEN LastMode := Mono;
  4146.           IF Row > 25 THEN Inc(LastMode,Font8x8);
  4147.      END;
  4148.  
  4149.      WindMin := 0;
  4150.      WindMax := VioMode.Col - 1 + (VioMode.Row - 1) SHL 8;
  4151.      MaxWindMin :=WindMin;
  4152.      MaxWindMax :=WindMax;
  4153.  
  4154.      Size := 2;
  4155.      VioReadCellStrProc(Value, Size, VioWhereYProc-1, VioWhereXProc-1, 0);
  4156.      TextAttr := Hi(Value) AND $7F;
  4157. END;
  4158.  
  4159. PROCEDURE StrWrite(CONST s:STRING;format:LONGWORD);
  4160. VAR ss:STRING;
  4161.     p:^STRING;
  4162. BEGIN
  4163.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  4164.      IF format>length(s) THEN
  4165.      BEGIN
  4166.           format:=format-length(s);
  4167.           ss[0]:=chr(format+length(s));
  4168.           fillchar(ss[1],format,32);
  4169.           p:=@s;
  4170.           move(p^[1],ss[format+1],length(s));
  4171.           ScreenInOut.WriteStr(ss);
  4172.      END
  4173.      ELSE ScreenInOut.WriteStr(s);
  4174. END;
  4175.  
  4176. PROCEDURE CStrWrite(CONST s:CSTRING;format:LONGWORD);
  4177. VAR ss:CSTRING;
  4178.     p:^CSTRING;
  4179.     l:LONGWORD;
  4180. BEGIN
  4181.      l:=length(s);
  4182.      IF ((format>l)AND(l+format<255)) THEN
  4183.      BEGIN
  4184.           format:=format-l;
  4185.           fillchar(ss[0],format,32);
  4186.           p:=@s;
  4187.           move(p^[0],ss[format],l+1);
  4188.           ScreenInOut.WriteCStr(ss);
  4189.      END
  4190.      ELSE ScreenInOut.WriteCStr(s);
  4191. END;
  4192.  
  4193. PROCEDURE WriteLine;
  4194. BEGIN
  4195.      ScreenInOut.WriteLF;
  4196. END;
  4197.  
  4198. PROCEDURE ReadLine;
  4199. VAR
  4200.    s:STRING;
  4201. BEGIN
  4202.      ScreenInOut.ReadLF(s);
  4203. END;
  4204.  
  4205. PROCEDURE StrRead(VAR s:STRING);
  4206. BEGIN
  4207.      ScreenInOut.ReadLF(s);
  4208. END;
  4209.  
  4210. CONST
  4211.      Typ_String   = 1;
  4212.      Typ_Char     = 2;
  4213.      Typ_Number   = 3;
  4214.  
  4215. PROCEDURE GetNextStr(VAR s,Ziel:STRING;Typ:LONGWORD);
  4216. VAR t:BYTE;
  4217. LABEL l;
  4218. BEGIN
  4219.      IF s='' THEN
  4220.      BEGIN
  4221.           StrRead(s);
  4222.           s:=s+#13#10;
  4223.      END;
  4224.  
  4225.      Ziel:='';
  4226.      CASE Typ OF
  4227.         Typ_String:
  4228.         BEGIN
  4229.              {copy whole}
  4230.              IF s=#13#10 THEN Ziel:=''
  4231.              ELSE
  4232.              BEGIN
  4233.                   Ziel:=Copy(s,1,length(s)-2);
  4234.                   s:=#13#10;
  4235.              END;
  4236.         END;
  4237.         Typ_Char:
  4238.         BEGIN
  4239.              Ziel:=s[1];
  4240.              Delete(s,1,1);
  4241.         END;
  4242.         Typ_Number:
  4243.         BEGIN
  4244. l:
  4245.              IF length(s)<3 THEN  {am Zeilenende ??}
  4246.              BEGIN
  4247.                   StrRead(s);
  4248.                   s:=s+#13#10;
  4249.              END;
  4250.  
  4251.              {Skip spaces}
  4252.              IF s[1]=#32 THEN
  4253.              BEGIN
  4254.                   Delete(s,1,1);
  4255.                   goto l;
  4256.              END;
  4257.  
  4258.              FOR t:=1 TO length(s) DO
  4259.              BEGIN
  4260.                  CASE s[t] OF
  4261.                     #9,#13,#10,#32:  {Trennzeichen}
  4262.                     BEGIN
  4263.                          Ziel:=Copy(s,1,t-1);
  4264.                          Delete(s,1,t-1); {Trenner nicht mit löschen}
  4265.                          exit;
  4266.                     END;
  4267.                  END; {case}
  4268.              END;
  4269.         END;
  4270.      END; {case}
  4271. END;
  4272.  
  4273.  
  4274. //************************************************************************
  4275. // CLASS support
  4276. //************************************************************************
  4277.  
  4278. {Constructor for all classes}
  4279. CONSTRUCTOR TObject.Create;
  4280. BEGIN
  4281.      InitInstance(POINTER(SELF));
  4282. END;
  4283.  
  4284. {Destructor for all classes}
  4285. DESTRUCTOR TObject.Destroy;
  4286. BEGIN
  4287. END;
  4288.  
  4289. {Frees an instance of a class}
  4290. PROCEDURE TObject.Free;
  4291. BEGIN
  4292.      IF POINTER(SELF)<>NIL THEN Self.Destroy;
  4293. END;
  4294.  
  4295. {frees an Instance of a class}
  4296. PROCEDURE TObject.FreeInstance;
  4297. BEGIN
  4298.      {FreeInstance is normally called by the Destructor to
  4299.       deallocate memory for the object. In Speed-Pascal the
  4300.       memory deallocation is done by the compiler thus
  4301.       overriding this method has no effect}
  4302. END;
  4303.  
  4304. {Gets class information from the ClassInfo structure}
  4305. CLASS FUNCTION TObject.GetClassInfo: Pointer;
  4306. BEGIN
  4307.      ASM
  4308.         MOV EAX,$!ClassInfo
  4309.         MOV EAX,[EAX+4]
  4310.         MOV $!FUNCRESULT,EAX
  4311.      END;
  4312. END;
  4313.  
  4314. {Returns size of an instance of a class of TObject or a class derived
  4315.  from TObject from the ClassInfo structure}
  4316. CLASS FUNCTION TObject.InstanceSize:LONGWORD;
  4317. BEGIN
  4318.      ASM
  4319.         MOV EAX,0
  4320.         MOV EDI,$!ClassInfo //Get Object pointer
  4321.         CMP EDI,0
  4322.         JE !InstanceSize_NoInfo
  4323.         MOV EDI,[EDI+4]     //Get class info pointer
  4324.         CMP EDI,0
  4325.         JE !InstanceSize_NoInfo
  4326.         MOV EAX,[EDI+0]     //Get class size
  4327. !InstanceSize_NoInfo:
  4328.         MOV $!FUNCRESULT,EAX
  4329.      END;
  4330. END;
  4331.  
  4332. {Generates a new instance of a class from the ClassInfo structure
  4333.  and calls the constructor for that class}
  4334. CLASS FUNCTION TObject.NewInstance: TObject;
  4335. BEGIN
  4336.      {NewInstance is normally called by the Constructor to
  4337.       allocate memory for the object. In Speed-Pascal the
  4338.       memory allocation is done by the compiler thus
  4339.       overriding this method has no effect}
  4340. END;
  4341.  
  4342. {Initializes an Instance from the ClassInfo structure given by Instance}
  4343. CLASS FUNCTION TObject.InitInstance(Instance: Pointer): TObject;
  4344. BEGIN
  4345.      {Fill the object with zeros. Object must be initialized with Create !}
  4346.      inc(Instance,4);
  4347.      FillChar(Instance^,InstanceSize-4,0);
  4348.      dec(Instance,4);
  4349.      InitInstance:=TObject(Instance);
  4350. END;
  4351.  
  4352. CLASS FUNCTION TObject.ClassName: STRING;
  4353. VAR ps:^STRING;
  4354. BEGIN
  4355.      ASM
  4356.         MOV EAX,0
  4357.         MOV EDI,$!ClassInfo //Get Object pointer
  4358.         CMP EDI,0
  4359.         JE !ClassName_NoInfo
  4360.         MOV EDI,[EDI+4]     //Get class info pointer
  4361.         CMP EDI,0
  4362.         JE !ClassName_NoInfo
  4363.         LEA EDI,[EDI+16]    //points to class name
  4364.         MOV EAX,EDI
  4365. !ClassName_NoInfo:
  4366.         MOV $ps,EAX
  4367.      END;
  4368.      IF ps<>NIL THEN ClassName:=ps^
  4369.      ELSE ClassName:='';
  4370. END;
  4371.  
  4372. CLASS FUNCTION TObject.ClassUnit:STRING;
  4373. VAR ps:^STRING;
  4374. BEGIN
  4375.      ASM
  4376.         MOV EAX,0
  4377.         MOV EDI,$!ClassInfo //Get Object pointer
  4378.         CMP EDI,0
  4379.         JE !ClassUnit_NoInfo
  4380.         MOV EDI,[EDI+4]     //Get class info pointer
  4381.         CMP EDI,0
  4382.         JE !ClassUnit_NoInfo
  4383.         LEA EDI,[EDI+16]    //points to class name
  4384.         MOVZXB EAX,[EDI+0]  //overreas class name
  4385.         ADD EDI,EAX
  4386.         INC EDI
  4387.         MOV EAX,EDI
  4388. !ClassUnit_NoInfo:
  4389.         MOV $ps,EAX
  4390.      END;
  4391.      IF ps<>NIL THEN ClassUnit:=ps^
  4392.      ELSE ClassUnit:='';
  4393. END;
  4394.  
  4395. {Default handler for messages}
  4396. PROCEDURE TObject.DefaultHandler(VAR Message);
  4397. BEGIN
  4398.      {Do nothing here !}
  4399. END;
  4400.  
  4401. {Default frame handler for messages}
  4402. PROCEDURE TObject.DefaultFrameHandler(VAR Message);
  4403. BEGIN
  4404.      {Do nothing here !}
  4405. END;
  4406.  
  4407. {Dispatches dynamic methods}
  4408. PROCEDURE TObject.Dispatch(VAR Message);
  4409. BEGIN
  4410.      {Check if there's a DMT entry for the message
  4411.       The message ID MUST be the first DWORD of Message !!
  4412.       If an entry is found call the message handler}
  4413.      ASM
  4414.         MOV EDI,$Message
  4415.         MOV EAX,[EDI+0]  //Get message index
  4416.         MOV EDI,$SELF    //Get Object
  4417.         MOV EDI,[EDI+0]  //Get VMT pointer
  4418.         MOV ESI,[EDI+0]  //Get DMT pointer
  4419.         MOV ECX,[ESI+0]  //Get number of DMT entries
  4420.         ADD ESI,4
  4421.         CMP ECX,0
  4422.         JE !EndeDispatch
  4423. !DLoop:
  4424.         CMP [ESI+0],EAX
  4425.         JNE !ELoop
  4426.  
  4427.         //Message found
  4428.         PUSHD $Message   //Message Parameter
  4429.         PUSHD $SELF      //SELF Pointer to object
  4430.         MOV EAX,[ESI+4]  //get VMT index
  4431.         CALLN32 [EDI+EAX*4]  //call VMT method
  4432.         LEAVE
  4433.         RETN32 8
  4434. !ELoop:
  4435.         ADD ESI,8        //Next DMT entry
  4436.         LOOP !DLoop      //try to find next
  4437. !EndeDispatch:
  4438.      END; {case}
  4439.  
  4440.      {other case call the Default handler}
  4441.      DefaultHandler(Message);
  4442. END;
  4443.  
  4444. {Dispatches dynamic methods}
  4445. PROCEDURE TObject.DispatchCommand(VAR Message;Command:LONGWORD);
  4446. BEGIN
  4447.      {Check if there's a DMT entry for the WM_COMMAND message}
  4448.      ASM
  4449.         MOV EDI,$Message
  4450.         MOV EAX,$Command //Get message index
  4451.         MOV EDI,$SELF    //Get Object
  4452.         MOV EDI,[EDI+0]  //Get VMT pointer
  4453.         MOV ESI,[EDI+0]  //Get DMT pointer
  4454.         MOV ECX,[ESI+0]  //Get number of DMT entries
  4455.         ADD ESI,4
  4456.         CMP ECX,0
  4457.         JE !EndeDispatch_2
  4458. !DLoop_2:
  4459.         CMP [ESI+0],EAX
  4460.         JNE !ELoop_2
  4461.  
  4462.         //Message found
  4463.         PUSHD $Message   //Message Parameter
  4464.         PUSHD $SELF      //SELF Pointer to object
  4465.         MOV EAX,[ESI+4]  //get VMT index
  4466.         CALLN32 [EDI+EAX*4]  //call VMT method
  4467.         LEAVE
  4468.         RETN32 8
  4469. !ELoop_2:
  4470.         ADD ESI,8        //Next DMT entry
  4471.         LOOP !DLoop_2    //try to find next
  4472. !EndeDispatch_2:
  4473.      END; {case}
  4474.  
  4475.      {other case call the Default handler}
  4476.      DefaultHandler(Message);
  4477. END;
  4478.  
  4479. {Dispatches dynamic methods}
  4480. PROCEDURE TObject.FrameDispatch(VAR Message);
  4481. BEGIN
  4482.      {Check if there's a DMT entry for the message
  4483.       The message ID MUST be the first DWORD of Message !!
  4484.       If an entry is found call the message handler}
  4485.      ASM
  4486.         MOV EDI,$Message
  4487.         MOV EAX,[EDI+0]  //Get message index
  4488.         MOV EDI,$SELF    //Get Object
  4489.         MOV EDI,[EDI+0]  //Get VMT pointer
  4490.         MOV ESI,[EDI+0]  //Get DMT pointer
  4491.         MOV ECX,[ESI+0]  //Get number of DMT entries
  4492.         ADD ESI,4
  4493.         CMP ECX,0
  4494.         JE !EndeDispatch_1
  4495. !DLoop_1:
  4496.         CMP [ESI+0],EAX
  4497.         JNE !ELoop_1
  4498.  
  4499.         //Message found
  4500.         PUSHD $Message   //Message Parameter
  4501.         PUSHD $SELF      //SELF Pointer to object
  4502.         MOV EAX,[ESI+4]  //get VMT index
  4503.         CALLN32 [EDI+EAX*4]  //call VMT method
  4504.         LEAVE
  4505.         RETN32 8
  4506. !ELoop_1:
  4507.         ADD ESI,8        //Next DMT entry
  4508.         LOOP !DLoop_1    //try to find next
  4509. !EndeDispatch_1:
  4510.      END; {case}
  4511.  
  4512.      {other case call the Default handler}
  4513.      DefaultFrameHandler(Message);
  4514. END;
  4515.  
  4516. ASSEMBLER
  4517.  
  4518. !GetMethodName PROC NEAR32
  4519.         //INPUT : EAX adress to find
  4520.         //        EDI VMT pointer
  4521.         //OUTPUT: String adress or NIL in EAX
  4522.  
  4523.         MOV EDI,[EDI+4]     //Get class info pointer
  4524.         LEA EDI,[EDI+16]    //points to class name
  4525.         MOVZXB EBX,[EDI+0]  //get Class name length
  4526.         INC EDI
  4527.         ADD EDI,EBX
  4528.         MOVZXB EBX,[EDI+0]  //get Unit name length
  4529.         INC EDI
  4530.         ADD EDI,EBX         //points on first method adress
  4531. !MLoop:
  4532.         CMPD [EDI+0],0      //end of list ??
  4533.         JE !MELoop
  4534.  
  4535.         CMP [EDI+0],EAX     //Method found
  4536.         JNE !MWLoop
  4537.  
  4538.         //Method found
  4539.         LEA EAX,[EDI+4]     //points to Method name
  4540.         JMP !MEFLoop
  4541. !MWLoop:
  4542.         ADD EDI,4
  4543.         MOVZXB EBX,[EDI+0]  //get method name length
  4544.         INC EDI
  4545.         ADD EDI,EBX         //points to next method address
  4546.         JMP !MLoop          //try next
  4547. !MELoop:
  4548.         MOV EAX,0           //not found
  4549. !MEFLoop:
  4550.         RETN32
  4551. !GetMethodName ENDP
  4552.  
  4553. END;
  4554.  
  4555. {returns the Method Name for an adress or an empty string}
  4556. CLASS FUNCTION TObject.MethodName(Address: POINTER): STRING;
  4557. VAR ps:^STRING;
  4558.     Class_Info:POINTER;
  4559. BEGIN
  4560.      ps:=NIL;  {Default}
  4561.      ASM
  4562.         MOV EDI,$!ClassInfo    //get Class info pointer
  4563.         MOV $Class_Info,EDI    //get address to find
  4564. !MAgain:
  4565.         MOV EDI,$Class_Info
  4566.         MOV EAX,$Address
  4567.         CALLN32 !GetMethodName //search for method
  4568.         CMP EAX,0
  4569.         JE !Nfound
  4570.  
  4571.         //Method was found
  4572.         MOV $ps,EAX
  4573.         JMP !Mfound
  4574. !Nfound:
  4575.         //Method not found, check parent
  4576.         MOV EDI,$Class_Info   //Actual class
  4577.         MOV EDI,[EDI+4]       //Get class info pointer
  4578.         MOV EAX,[EDI+4]       //Get parent class adress info
  4579.         MOV $Class_Info,EAX
  4580.         CMP EAX,0
  4581.         JNE !MAgain           //Try again if parents exist
  4582. !Mfound:
  4583.      END;
  4584.  
  4585.      IF ps=NIL THEN MethodName:=''
  4586.      ELSE MethodName:=ps^;
  4587. END;
  4588.  
  4589. ASSEMBLER
  4590.  
  4591. !GetMethodAddress PROC NEAR32
  4592.         //INPUT : ESI pointer to string to find
  4593.         //        EDI VMT pointer
  4594.         //OUTPUT: method pointer or NIL in EAX
  4595.  
  4596.         MOV EDI,[EDI+4]     //Get class info pointer
  4597.         LEA EDI,[EDI+16]    //points to class name
  4598.         MOVZXB EBX,[EDI+0]  //get Class name length
  4599.         INC EDI
  4600.         ADD EDI,EBX
  4601.         MOVZXB EBX,[EDI+0]  //get Unit name length
  4602.         INC EDI
  4603.         ADD EDI,EBX         //points on first method adress
  4604.         MOV CL,[ESI+0]      //get method string length
  4605. !ALoop:
  4606.         MOV EDX,EDI         //save pointer
  4607.         MOV EBX,ESI         //save pointer
  4608.         CMPD [EDI+0],0      //end of list ??
  4609.         JE !AELoop
  4610.         ADD EDI,4           //onto name
  4611.  
  4612.         CMP CL,[EDI+0]      //length correct
  4613.         JNE !AWLoop
  4614.  
  4615.         //length was correct
  4616.         MOVZX ECX,CL        //String length
  4617.         INC EDI
  4618.         INC ESI
  4619.         CLD
  4620.         REP
  4621.         CMPSB               //Compare strings
  4622.         JNE !AWLoop
  4623.  
  4624.         //Method was found
  4625.         MOV EAX,[EDX+0]     //get method adress
  4626.         JMP !AEFLoop
  4627. !AWLoop:
  4628.         MOV EDI,EDX         //get old pointer
  4629.         MOV ESI,EBX         //get old pointer
  4630.         ADD EDI,4
  4631.         MOVZXB EAX,[EDI+0]  //get method name length
  4632.         INC EDI
  4633.         ADD EDI,EAX         //points to next method address
  4634.         MOV CL,[ESI+0]
  4635.         JMP !ALoop          //try next
  4636. !AELoop:
  4637.         MOV EAX,0           //not found
  4638. !AEFLoop:
  4639.         RETN32
  4640. !GetMethodAddress ENDP
  4641.  
  4642. END;
  4643.  
  4644. {returns the adress of a method or NIL}
  4645. CLASS FUNCTION TObject.MethodAddress(CONST Name: STRING): POINTER;
  4646. VAR
  4647.    Adr:POINTER;
  4648.    Class_Info:POINTER;
  4649. BEGIN
  4650.      Adr:=NIL;  {Default}
  4651.  
  4652.      ASM
  4653.         MOV EDI,$!ClassInfo    //get Class info pointer
  4654.         MOV $Class_Info,EDI    //get address to find
  4655. !AAgain_1:
  4656.         MOV EDI,$Class_Info
  4657.         MOV ESI,$Name
  4658.         CALLN32 !GetMethodAddress //search for method
  4659.         CMP EAX,0
  4660.         JE !ANfound
  4661.  
  4662.         //Method was found
  4663.         MOV $Adr,EAX
  4664.         JMP !AMfound
  4665. !ANfound:
  4666.         //Method not found, check parent
  4667.         MOV EDI,$Class_Info   //Actual class
  4668.         MOV EDI,[EDI+4]       //Get class info pointer
  4669.         MOV EAX,[EDI+4]       //Get parent class adress info
  4670.         MOV $Class_Info,EAX
  4671.         CMP EAX,0
  4672.         JNE !AAgain_1         //Try again if parents exist
  4673. !AMfound:
  4674.      END;
  4675.  
  4676.      MethodAddress:=Adr;
  4677. END;
  4678.  
  4679. ASSEMBLER
  4680.  
  4681. !GetFieldOffset PROC NEAR32
  4682.                //INPUT : ESI pointer to string to find
  4683.                //        EDI VMT pointer
  4684.                //OUTPUT: field offset or 0 in EAX
  4685.  
  4686.                MOV EDI,[EDI+8]     //Field info start
  4687.                MOV AL,[ESI+0]      //get method string length
  4688.                INC ESI
  4689. !FLoop:
  4690.                MOV EDX,EDI         //save pointer
  4691.                MOV EBX,ESI         //save pointer
  4692.                CMPD [EDI+0],0      //end of list ??
  4693.                JE !FELoop
  4694.  
  4695.                CMP AL,[EDI+4]      //length correct
  4696.                JNE !FWLoop
  4697.  
  4698.                //length was correct
  4699.                MOVZX ECX,AL        //String length
  4700.                ADD EDI,5           //onto first char
  4701.                CLD
  4702.                REP
  4703.                CMPSB               //Compare strings
  4704.                JNE !FWLoop
  4705.  
  4706.                //Method was found
  4707.                MOV EAX,[EDX+0]     //get method adress
  4708.                JMP !FEFLoop
  4709. !FWLoop:
  4710.                MOV EDI,EDX         //get old pointer
  4711.                MOV ESI,EBX         //get old pointer
  4712.                ADD EDI,4
  4713.                MOVZXB EBX,[EDI+0]  //get method name length
  4714.                INC EDI
  4715.                ADD EDI,EBX         //points to next method address
  4716.                JMP !FLoop          //try next
  4717. !FELoop:
  4718.                MOV EAX,0           //not found
  4719. !FEFLoop:
  4720.                RETN32
  4721. !GetFieldOffset ENDP
  4722.  
  4723. END;
  4724.  
  4725. FUNCTION TObject.FieldAddress(Name: STRING): POINTER;
  4726. VAR
  4727.    Adr:POINTER;
  4728.    Class_Info:POINTER;
  4729. BEGIN
  4730.      Adr:=NIL;  {Default}
  4731.      UpcaseStr(Name);
  4732.  
  4733.      ASM
  4734.         MOV EDI,$SELF           //get object pointer
  4735.         MOV EDI,[EDI+0]         //get VMT Pointer
  4736.         MOV EDI,[EDI+4]         //get Class info pointer
  4737.         MOV $Class_Info,EDI     //get address to find
  4738. !FAgain:
  4739.         MOV EDI,$Class_Info
  4740.         LEA ESI,$Name
  4741.         CALLN32 !GetFieldOffset //search for method
  4742.         CMP EAX,0
  4743.         JE !FNfound
  4744.  
  4745.         //Method was found
  4746.         MOV EBX,$SELF
  4747.         MOV $Adr,EBX
  4748.         ADD $Adr,EAX
  4749.         JMP !FMfound
  4750. !FNfound:
  4751.         //Method not found, check parent
  4752.         MOV EDI,$Class_Info     //Actual class
  4753.         MOV EDI,[EDI+4]         //Get class info pointer
  4754.         CMP EDI,0
  4755.         JE !FMfound             //not found
  4756.         MOV EAX,[EDI+4]         //Get parent class adress info
  4757.         MOV $Class_Info,EAX
  4758.         CMP EAX,0
  4759.         JNE !FAgain             //Try again if parents exist
  4760. !FMfound:
  4761.      END;
  4762.  
  4763.      FieldAddress:=Adr;
  4764. END;
  4765.  
  4766. {returns type of a class}
  4767. CLASS FUNCTION TObject.ClassType: TClass;
  4768. BEGIN
  4769.      ASM
  4770.         MOV EAX,$!ClassInfo
  4771.         MOV $!FUNCRESULT,EAX
  4772.      END;
  4773. END;
  4774.  
  4775. {Returns Parent Class pointer of the Object or NIL}
  4776. CLASS FUNCTION TObject.ClassParent: TClass;
  4777. BEGIN
  4778.      ASM
  4779.         MOV EAX,0
  4780.         MOV EDI,$!ClassInfo    //get Class info pointer
  4781.         CMP EDI,0
  4782.         JE !ClassParent_NoInfo
  4783.         MOV EDI,[EDI+4]        //points to Class information
  4784.         CMP EDI,0
  4785.         JE !ClassParent_NoInfo
  4786.         MOV EAX,[EDI+4]        //Get Parent Class pointer
  4787. !ClassParent_NoInfo:
  4788.         MOV $!FUNCRESULT,EAX
  4789.      END;
  4790. END;
  4791.  
  4792. {returns true if the Class is derived from AClass, otherwise FALSE}
  4793. CLASS FUNCTION TObject.InheritsFrom(AClass: TClass): BOOLEAN;
  4794. BEGIN
  4795.      ASM
  4796.         MOV EDI,$!ClassInfo    //get Class info pointer
  4797.         MOV EAX,$AClass        //class to check
  4798.         MOVD $!FUNCRESULT,0    //Default
  4799. !ILoop:
  4800.         CMP EDI,EAX            //is it this class ?
  4801.         JNE !IWLoop
  4802.  
  4803.         //The Class was found
  4804.         MOVD $!FUNCRESULT,1
  4805.         JMP !IELoop
  4806. !IWLoop:
  4807.         //try parent class
  4808.         MOV EDI,[EDI+4]       //points to class info
  4809.         MOV EDI,[EDI+4]       //get parent info
  4810.         CMP EDI,0
  4811.         JNE !ILoop
  4812. !IELoop:
  4813.      END;
  4814. END;
  4815.  
  4816. {internally: returns true if the Class1 is derived from Class2 otherwise FALSE}
  4817. FUNCTION CheckDerived(Class1,Class2: TClass): BOOLEAN;
  4818. BEGIN
  4819.      ASM
  4820.         MOV EDI,$Class1        //get Class info pointer
  4821.         MOV EAX,$Class2        //class to check
  4822.         MOVD $!FUNCRESULT,0    //Default
  4823. !ILoop11:
  4824.         CMP EDI,EAX            //is it this class ?
  4825.         JNE !IWLoop11
  4826.  
  4827.         //The Class was found
  4828.         MOVD $!FUNCRESULT,1
  4829.         JMP !IELoop11
  4830. !IWLoop11:
  4831.         //try parent class
  4832.         MOV EDI,[EDI+4]       //points to class info
  4833.         MOV EDI,[EDI+4]       //get parent info
  4834.         CMP EDI,0
  4835.         JNE !ILoop11
  4836. !IELoop11:
  4837.      END;
  4838. END;
  4839.  
  4840. ASSEMBLER
  4841.  
  4842. //Abstract method (causes Runtime Error 210)
  4843. SYSTEM.!Abstract PROC NEAR32
  4844.              PUSHL 210
  4845.              CALLN32 SYSTEM.RunError
  4846. SYSTEM.!Abstract ENDP
  4847.  
  4848. END;
  4849.  
  4850. //************************************************************************
  4851. // LongJmp support
  4852. //************************************************************************
  4853.  
  4854.  
  4855. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  4856. BEGIN
  4857.      ASM
  4858.         MOV EDI,$JmpBuf
  4859.         MOV EAX,[EBP+0]
  4860.         MOV [EDI+0],EAX
  4861.         MOV EAX,[EBP+4]
  4862.         MOV [EDI+4],EAX
  4863.         MOV EAX,EBP
  4864.         ADD EAX,12
  4865.         MOV [EDI+8],EAX
  4866.         MOV ESI,0
  4867.         db $64   //SEG FS
  4868.         MOV EAX,[ESI+0]
  4869.         MOV [EDI+$18],EAX
  4870.         FSTCW [EDI+$1C]
  4871.         XOR EAX,EAX
  4872.         MOV $!FUNCRESULT,EAX
  4873.      END;
  4874. END;
  4875.  
  4876. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  4877. BEGIN
  4878.      ASM
  4879.         MOV EDI,$JmpBuf
  4880.         PUSHL 0
  4881.         MOV EAX,*ljmpret
  4882.         PUSH EAX
  4883.         PUSHL [EDI+$18]
  4884.         MOV AL,3
  4885.         CALLDLL DosCalls,357  //DosUnwindException
  4886. ljmpret:
  4887.         MOV EDI,$JmpBuf
  4888.         db $db,$e3              //FINIT Init FPU
  4889.         FWAIT
  4890.         FLDCW [EDI+$1C]
  4891.         MOV EAX,$RetVal
  4892.         AND EAX,EAX
  4893.         JNZ !rtv0
  4894.         MOV EAX,1
  4895. !rtv0:
  4896.         PUSHL [EDI+0]
  4897.         POP EBP
  4898.         MOV ESP,[EDI+8]
  4899.         ADD EDI,4
  4900.         db $0ff,$27       //JMP NEAR32 [EDI+0] --> jump into proc
  4901.      END;
  4902. END;
  4903.  
  4904. //***************************************************
  4905. // String Support routines
  4906. //***************************************************
  4907.  
  4908. PROCEDURE UpcaseStr(VAR s:STRING);
  4909. BEGIN
  4910.      ASM
  4911.         MOV EDI,$s
  4912.         XOR ECX,ECX
  4913.         MOV CL,[EDI+0]
  4914.         OR CL,CL
  4915.         JE !usend
  4916.         INC EDI
  4917.         MOV EBX,*ustab
  4918.         CLD
  4919. !usfilter:
  4920.         MOV AL,[EDI+0]
  4921.         XLAT
  4922.         STOSB
  4923.         DEC ECX
  4924.         JNZ !usfilter
  4925. !usend:
  4926.         LEAVE
  4927.         RETN32 4
  4928. ustab:
  4929.        db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20
  4930.        db 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38
  4931.        db 39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57
  4932.        db 58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76
  4933.        db 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96
  4934.        db 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83
  4935.        db 84,85,86,87,88,89,90
  4936.        db 123,124,125,126,127,128,129,130,131,132,133,134,135,136,137
  4937.        db 138,139,140,141,142,143,144,145,146,147,148,149,150,151,152
  4938.        db 153,154,155,156,157,158,159,160,161,162,163,164,165,166,167
  4939.        db 168,169,170,171,172,173,174,175,176,177,178,179,180,181,182
  4940.        db 183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198
  4941.        db 199,200,201,202,203,204,205,206,207,208,209,210,211,212,213
  4942.        db 214,215,216,217,218,219,220,221,222,223,224,225,226,227,228
  4943.        db 229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244
  4944.        db 245,246,247,248,249,250,251,252,253,254,255
  4945.      END;
  4946. END;
  4947.  
  4948.  
  4949. PROCEDURE LongWord2Str(l:LONGWORD;Format:LONGWORD;VAR result:STRING);
  4950. BEGIN
  4951.      ASM
  4952.         PUSH EAX
  4953.         PUSH EBX
  4954.         PUSH ECX
  4955.         PUSH EDX
  4956.         PUSH EDI
  4957.         PUSH ESI
  4958.  
  4959.         MOV EAX,$l
  4960.         MOV EBX,10
  4961.         XOR ECX,ECX
  4962. Lw46_1nn:
  4963.         XOR EDX,EDX
  4964.         DIV EBX
  4965.         PUSH DX
  4966.         INC CX
  4967.         OR EAX,EAX
  4968.         JNE Lw46_1nn
  4969.  
  4970.         MOV ESI,$RESULT
  4971.         MOVB [ESI+0],0
  4972.         MOV EDI,ESI
  4973.  
  4974.         CMP ECX,$Format
  4975.         JAE Lw47nn
  4976.  
  4977.         //format the string
  4978.         MOV EAX,$Format
  4979.         SUB EAX,ECX
  4980.         MOV [ESI+0],AL
  4981.         INC EDI
  4982.         PUSH ECX
  4983.  
  4984.         MOV ECX,EAX
  4985.         MOV AL,32
  4986.         CLD
  4987.         REP STOSB       //fill up with space
  4988.  
  4989.         DEC EDI
  4990.         POP ECX
  4991. Lw47nn:
  4992.         POP AX
  4993.         ADD AL,48
  4994.         INCB [ESI+0]
  4995.         INC EDI
  4996.         MOV [EDI+0],AL
  4997.         LOOP Lw47nn
  4998.      END;
  4999.  
  5000.      ASM
  5001.         POP ESI
  5002.         POP EDI
  5003.         POP EDX
  5004.         POP ECX
  5005.         POP EBX
  5006.         POP EAX
  5007.      END;
  5008. END;
  5009.  
  5010. FUNCTION GetBoolValue(b:BOOLEAN):STRING;
  5011. BEGIN
  5012.      ASM
  5013.         PUSH EAX
  5014.         PUSH EBX
  5015.         PUSH ECX
  5016.         PUSH EDX
  5017.         PUSH EDI
  5018.         PUSH ESI
  5019.      END;
  5020.      IF b THEN GetBoolValue:='TRUE'
  5021.      ELSE GetBoolValue:='FALSE';
  5022.      ASM
  5023.         POP ESI
  5024.         POP EDI
  5025.         POP EDX
  5026.         POP ECX
  5027.         POP EBX
  5028.         POP EAX
  5029.      END;
  5030. END;
  5031.  
  5032. PROCEDURE LongInt2Str(l:LONGINT;Format:LONGWORD;VAR result:STRING);
  5033. VAR
  5034.    IsNeg:BOOLEAN;
  5035. BEGIN
  5036.      ASM
  5037.         PUSH EAX
  5038.         PUSH EBX
  5039.         PUSH ECX
  5040.         PUSH EDX
  5041.         PUSH EDI
  5042.         PUSH ESI
  5043.  
  5044.         MOVB $IsNeg,0
  5045.         MOV EAX,$l
  5046.         MOV EBX,10
  5047.         XOR ECX,ECX
  5048.         CMP EAX,0
  5049.         JNL Lw46_1
  5050.         NEG EAX
  5051.         MOVB $IsNeg,1
  5052. Lw46_1:
  5053.         XOR EDX,EDX
  5054.         DIV EBX
  5055.         PUSH DX
  5056.         INC CX
  5057.         OR EAX,EAX
  5058.         JNE Lw46_1
  5059.  
  5060.         MOV ESI,$RESULT
  5061.         MOVB [ESI+0],0
  5062.         MOV EDI,ESI
  5063.  
  5064.         MOV EBX,ECX
  5065.  
  5066.         CMPB $IsNeg,1
  5067.         JNE !nin1
  5068.         INC EBX
  5069. !nin1:
  5070.         CMP EBX,$Format
  5071.         JAE Lw47_1n
  5072.  
  5073.         //format the string
  5074.         MOV EAX,$Format
  5075.         SUB EAX,EBX
  5076.         MOV [ESI+0],AL
  5077.         INC EDI
  5078.         PUSH ECX
  5079.  
  5080.         MOV ECX,EAX
  5081.         MOV AL,32
  5082.         CLD
  5083.         REP STOSB        //fill up with space
  5084.  
  5085.         DEC EDI
  5086.         POP ECX
  5087. Lw47_1n:
  5088.         CMPB $IsNeg,1
  5089.         JNE Lw47
  5090.         INC EDI
  5091.         INCB [ESI+0]
  5092.         MOVB [EDI+0],45  //'-'
  5093. Lw47:
  5094.         POP AX
  5095.         ADD AL,48
  5096.         INCB [ESI+0]
  5097.         INC EDI
  5098.         MOV [EDI+0],AL
  5099.         LOOP Lw47
  5100.      END;
  5101.  
  5102.      ASM
  5103.         POP ESI
  5104.         POP EDI
  5105.         POP EDX
  5106.         POP ECX
  5107.         POP EBX
  5108.         POP EAX
  5109.      END;
  5110. END;
  5111.  
  5112. FUNCTION POS(CONST item,source:STRING):BYTE;
  5113. VAR
  5114.    result:BYTE;
  5115. BEGIN
  5116.      ASM
  5117.          MOV ESI,$item          //item
  5118.          CLD
  5119.          LODSB
  5120.          OR AL,AL
  5121.          JE lab2
  5122.          MOVZX EAX,AL
  5123.          MOV EDX,EAX
  5124.          MOV EDI,$source        //source
  5125.          MOVZXB ECX,[EDI+0]
  5126.          SUB ECX,EDX
  5127.          JB lab2
  5128.          INC ECX
  5129.          INC EDI
  5130. lab1:
  5131.          LODSB
  5132.          REPNE
  5133.          SCASB
  5134.          JNE lab2
  5135.          MOV EAX,EDI
  5136.          MOV EBX,ECX
  5137.          MOV ECX,EDX
  5138.          DEC ECX
  5139.          REPE
  5140.          CMPSB
  5141.          JE lab3
  5142.          MOV EDI,EAX
  5143.          MOV ECX,EBX
  5144.          MOV ESI,$item     //item
  5145.          INC ESI
  5146.          JMP lab1
  5147. Lab2:
  5148.          XOR EAX,EAX
  5149.          JMP Lab4
  5150. lab3:
  5151.          DEC EAX
  5152.          SUB EAX,$source   //source
  5153. Lab4:
  5154.          MOV $result,AL
  5155.      END;
  5156.      POS:=result;
  5157. END;
  5158.  
  5159. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  5160. BEGIN
  5161.      ASM
  5162.         MOV ESI,$source              //Source string
  5163.         MOV EDI,$!FuncResult         //Destination string
  5164.         MOVW [EDI+0],0               //Empty String
  5165.  
  5166.         MOVSXW ECX,$Count            //Count
  5167.         CMP ECX,1
  5168.         JL !_CopyE
  5169.  
  5170.         MOVSXW EAX,$Index            //Index
  5171.         CMP EAX,1
  5172.         JNL !_Copy1
  5173.         MOV EAX,1                    //Index:=1
  5174. !_Copy1:
  5175.         MOVZXB EBX,[ESI+0]           //Length of Source
  5176.         CMP EAX,EBX
  5177.         JA !_CopyE
  5178.  
  5179.         MOV EDX,EAX
  5180.         ADD EDX,ECX                  //Index+Count
  5181.         CMP EDX,EBX
  5182.         JNA !_Copy2
  5183.         MOV ECX,EBX
  5184.         SUB ECX,EAX
  5185.         INC ECX                      //Count := Length(S)-Index+1
  5186. !_Copy2:
  5187.         MOV [EDI+0],CL
  5188.         INC EDI
  5189.  
  5190.         ADD ESI,EAX                  //first char
  5191.         CLD
  5192.         MOV EDX,ECX
  5193.         SHR ECX,2
  5194.         REP
  5195.         MOVSD
  5196.         MOV ECX,EDX
  5197.         AND ECX,3
  5198.         REP
  5199.         MOVSB
  5200. !_CopyE:
  5201.      END;
  5202. END;
  5203.  
  5204. FUNCTION ToHex(l:LONGWORD):STRING;
  5205. VAR
  5206.     HexNum:STRING;
  5207.     result:STRING;
  5208.     r:LONGWORD;
  5209. BEGIN
  5210.      HexNum:='0123456789ABCDEF';
  5211.      result:='';
  5212.      WHILE l>=16 DO
  5213.      BEGIN
  5214.           r:=l MOD 16;
  5215.           l:=l DIV 16;
  5216.           result:=HexNum[r+1]+result;
  5217.      END;
  5218.      result:=HexNum[l+1]+result;
  5219.      WHILE length(result)<8 DO result:='0'+result;
  5220.      ToHex:='$'+Result;
  5221. END;
  5222.  
  5223. PROCEDURE SUBSTR(VAR source:STRING;start,ende:Byte);
  5224. BEGIN
  5225.       ASM
  5226.         CLD
  5227.         MOV ESI,$source              //Source string
  5228.         MOV EDI,ESI                  //Destination string
  5229.  
  5230.         MOVZXB AX,[ESI+0]            //Length of source
  5231.         MOVZXB ECX,$Start            //Index
  5232.         OR ECX,ECX
  5233.         JG !_Lab1_1
  5234.         MOV ECX,1
  5235. !_Lab1_1:
  5236.         ADD ESI,ECX
  5237.         SUB AX,CX
  5238.         JB !_Lab3_1
  5239.         INC AX
  5240.         MOVZXB CX,$Ende             //Count
  5241.         OR CX,CX
  5242.         JGE !_Lab2_1
  5243.         XOR CX,CX
  5244. !_Lab2_1:
  5245.         CMP AX,CX
  5246.         JBE !_Lab4_1
  5247.         MOV AX,CX
  5248.         JMP !_Lab4_1
  5249. !_Lab3_1:
  5250.         XOR AX,AX
  5251. !_Lab4_1:
  5252.         CLD
  5253.         STOSB
  5254.         MOVZX ECX,AX
  5255.  
  5256.         MOV EDX,ECX
  5257.         SHR ECX,2
  5258.         REP
  5259.         MOVSD
  5260.         MOV ECX,EDX
  5261.         AND ECX,3
  5262.         REP
  5263.         MOVSB
  5264.      END;
  5265. END;
  5266.  
  5267. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  5268. BEGIN
  5269.      IF Length(Source) = 0 THEN exit;
  5270.      IF Length(S) = 0 THEN
  5271.      BEGIN
  5272.           S := Source;
  5273.           exit;
  5274.      END;
  5275.      IF Index < 1 THEN Index := 1;
  5276.      IF Index > Length(S) THEN Index := Length(S)+1;
  5277.      S := copy(S,1,Index-1) + Source + copy(S,Index,Length(S)-Index+1);
  5278. END;
  5279. {$H+}
  5280.  
  5281. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  5282. BEGIN
  5283.      IF Index < 1 THEN exit;
  5284.      IF Index > Length(S) THEN exit;
  5285.      IF Count < 1 THEN exit;
  5286.      IF Index+Count > Length(S) THEN Count := Length(S)-Index+1;
  5287.      S := copy(S,1,Index-1) + copy(S,Index+Count,Length(S)-Index-Count+1);
  5288. END;
  5289.  
  5290. FUNCTION ConvertStr2Long(VAR s:STRING):LONGINT;
  5291. VAR
  5292.    c:Integer;
  5293.    result:LONGINT;
  5294. BEGIN
  5295.      VAL(s,result,c);
  5296.      IF c<>0 THEN
  5297.      BEGIN
  5298.      END;
  5299.      ConvertStr2Long:=result;
  5300. END;
  5301.  
  5302. {Liefert Extended in ST(0) !!}
  5303. PROCEDURE ConvertStr2Extended(VAR s:STRING);
  5304. VAR
  5305.    c:Integer;
  5306.    result:Extended;
  5307. BEGIN
  5308.      VAL(s,result,c);
  5309.      IF c<>0 THEN
  5310.      BEGIN
  5311.      END;
  5312.      ASM
  5313.         FLDT $result
  5314.      END;
  5315. END;
  5316.  
  5317.  
  5318. FUNCTION GetStrErrorPos(VAR s:STRING):LONGINT;
  5319. VAR t,t1:BYTE;
  5320. BEGIN
  5321.      result:=1;
  5322.      t:=1;
  5323.      IF t<=length(s) THEN IF s[t] IN ['+','-'] THEN inc(t);
  5324.      IF t<=length(s) THEN IF s[t]='$' THEN inc(t);
  5325.      FOR t1:=t TO length(s) DO
  5326.      BEGIN
  5327.           CASE s[t1] OF
  5328.             '0'..'9':;
  5329.             ELSE
  5330.             BEGIN
  5331.                  result:=t1;
  5332.                  exit;
  5333.             END;
  5334.           END;
  5335.      END;
  5336. END;
  5337.  
  5338. ASSEMBLER
  5339.  
  5340. SYSTEM.!Str2Long PROC NEAR32
  5341.         PUSH EBP
  5342.         MOV EBP,ESP
  5343.         SUB ESP,10
  5344.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  5345.  
  5346.         MOV EDI,[EBP+16]   //s
  5347.         MOV CL,[EDI+0]     //Länge
  5348.         MOVZX ECX,CL
  5349.  
  5350. !ndo_11:
  5351.         MOV AL,[EDI+1]
  5352.         CMP AL,32
  5353.         JNE !do_11
  5354.         CMP ECX,0
  5355.         JE !do_11
  5356.         DEC ECX
  5357.         INC EDI
  5358.         JMP !ndo_11       //skip spaces
  5359. !do_11:
  5360.         PUSH EDI
  5361.         ADD EDI,ECX
  5362.         CMPB [EDI+0],32
  5363.         JNE !do_11_1
  5364.         DEC ECX
  5365.         POP EDI
  5366.         JMP !do_11
  5367. !do_11_1:
  5368.         POP EDI
  5369.  
  5370.         MOVB [EBP-6],0
  5371.  
  5372.         MOVD [EBP-10],10   //Base
  5373.         MOV AL,[EDI+1]
  5374.         ADD EDI,ECX
  5375.         CMP AL,'$'         //Hexadecimal ??
  5376.         JNE !nohex
  5377.         MOVD [EBP-10],16   //Base
  5378.         CMP ECX,1
  5379.         JE !qerr
  5380.         DEC ECX
  5381. !nohex:
  5382.         CMP AL,'-'
  5383.         JNE !q2
  5384.         CMP ECX,1
  5385.         JE !qerr
  5386.         DEC ECX
  5387.         MOVB [EBP-6],1
  5388. !q2:
  5389.         MOV EBX,1
  5390.         MOV EAX,0
  5391.         MOV [EBP-4],EAX
  5392. !q1:
  5393.         MOV AL,[EDI+0]
  5394.         DEC EDI
  5395.         CMP AL,48
  5396.         JB !qerr
  5397.         CMP AL,57
  5398.         JNA !noqerr
  5399.  
  5400.         CMP AL,102
  5401.         JA !qerr
  5402.         CMP AL,65
  5403.         JB !qerr
  5404.         CMP AL,70
  5405.         JBE !hexnum
  5406.         CMP AL,97
  5407.         JB !qerr
  5408.         SUB AL,32       //To upper
  5409. !hexnum:
  5410.         CMPD [EBP-10],16
  5411.         JNE !qerr
  5412.         SUB AL,7
  5413. !noqerr:
  5414.         SUB AL,48
  5415.         MOVZX EAX,AL
  5416.         MUL EBX
  5417.         MOV EDX,[EBP-4]
  5418.         ADD EDX,EAX
  5419.         MOV [EBP-4],EDX
  5420.         MOV EAX,EBX
  5421.         MOV EBX,[EBP-10]  //Base
  5422.         MUL EBX
  5423.         MOV EBX,EAX
  5424.         LOOP !q1
  5425. !qerr:
  5426.         MOV EDI,[EBP+8]   //result
  5427.         XOR CH,CH
  5428.         MOV [EDI+0],CX
  5429.  
  5430.         // failure ??
  5431.         CMP CX,0
  5432.         JE !qqqq    //no error
  5433.         PUSHL [EBP+16]  //s
  5434.         CALLN32 SYSTEM.GetStrErrorPos
  5435.         MOV EDI,[EBP+8]
  5436.         MOV [EDI+0],EAX
  5437.         MOV EAX,0
  5438.         JMP !q3
  5439. !qqqq:
  5440.         MOV EAX,[EBP-4]
  5441.         CMPB [EBP-6],1
  5442.         JNE !q3
  5443.         NEG EAX
  5444. !q3:
  5445.         MOV EDI,[EBP+12]  //l
  5446.         MOV [EDI+0],EAX
  5447.         LEAVE
  5448.         RETN32 12
  5449. SYSTEM.!Str2Long ENDP
  5450.  
  5451. SYSTEM.!Str2Word PROC NEAR32
  5452.         PUSH EBP
  5453.         MOV EBP,ESP
  5454.         SUB ESP,10
  5455.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  5456.  
  5457.         MOV EDI,[EBP+16]   //s
  5458.         MOV CL,[EDI+0]     //Länge
  5459.         MOVZX ECX,CL
  5460.  
  5461. !ndo_22:
  5462.         MOV AL,[EDI+1]
  5463.         CMP AL,32
  5464.         JNE !do_22
  5465.         CMP ECX,0
  5466.         JE !do_22
  5467.         DEC ECX
  5468.         INC EDI
  5469.         JMP !ndo_22
  5470. !do_22:
  5471.         PUSH EDI
  5472.         ADD EDI,ECX
  5473.         CMPB [EDI+0],32
  5474.         JNE !do_22_1
  5475.         DEC ECX
  5476.         POP EDI
  5477.         JMP !do_22
  5478. !do_22_1:
  5479.         POP EDI
  5480.  
  5481.         MOVB [EBP-6],0
  5482.  
  5483.         MOVD [EBP-10],10   //Base
  5484.         MOV AL,[EDI+1]
  5485.         ADD EDI,ECX
  5486.         CMP AL,'$'         //Hexadecimal ??
  5487.         JNE !__nohex
  5488.         MOVD [EBP-10],16   //Base
  5489.         CMP ECX,1
  5490.         JE !__qerr
  5491.         DEC ECX
  5492. !__nohex:
  5493.         CMP AL,'-'
  5494.         JNE !__q2
  5495.         CMP ECX,1
  5496.         JE !__qerr
  5497.         DEC ECX
  5498.         MOVB [EBP-6],1
  5499. !__q2:
  5500.         MOV EBX,1
  5501.         MOV EAX,0
  5502.         MOV [EBP-4],EAX
  5503. !__q1:
  5504.         MOV AL,[EDI+0]
  5505.         DEC EDI
  5506.         CMP AL,48
  5507.         JB !__qerr
  5508.         CMP AL,57
  5509.         JNA !__noqerr
  5510.  
  5511.         CMP AL,102
  5512.         JA !__qerr
  5513.         CMP AL,65
  5514.         JB !__qerr
  5515.         CMP AL,70
  5516.         JBE !__hexnum
  5517.         CMP AL,97
  5518.         JB !__qerr
  5519.         SUB AL,32         //To upper
  5520. !__hexnum:
  5521.         CMPD [EBP-10],16
  5522.         JNE !__qerr
  5523.         SUB AL,7
  5524. !__noqerr:
  5525.         SUB AL,48
  5526.         MOVZX EAX,AL
  5527.         MUL EBX
  5528.         MOV EDX,[EBP-4]
  5529.         ADD EDX,EAX
  5530.         MOV [EBP-4],EDX
  5531.         MOV EAX,EBX
  5532.         MOV EBX,[EBP-10]    //Base
  5533.         MUL EBX
  5534.         MOV EBX,EAX
  5535.         LOOP !__q1
  5536. !__qerr:
  5537.         MOV EDI,[EBP+8]     //result
  5538.         XOR CH,CH
  5539.         MOV [EDI+0],CX
  5540.  
  5541.         // failure ??
  5542.         CMP CX,0
  5543.         JE !qqqq1    //no error
  5544.         PUSHL [EBP+16]  //s
  5545.         CALLN32 SYSTEM.GetStrErrorPos
  5546.         MOV EDI,[EBP+8]
  5547.         MOV [EDI+0],EAX
  5548.         MOV EAX,0
  5549.         JMP !__q3
  5550. !qqqq1:
  5551.         MOV EAX,[EBP-4]
  5552.         CMPB [EBP-6],1
  5553.         JNE !__q3
  5554.         NEG EAX
  5555. !__q3:
  5556.         MOV EDI,[EBP+12]    //l
  5557.         MOV [EDI+0],AX
  5558.         LEAVE
  5559.         RETN32 12
  5560. SYSTEM.!Str2Word ENDP
  5561.  
  5562. SYSTEM.!Str2Byte PROC NEAR32
  5563.         PUSH EBP
  5564.         MOV EBP,ESP
  5565.         SUB ESP,10
  5566.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  5567.  
  5568.         MOV EDI,[EBP+16]   //s
  5569.         MOV CL,[EDI+0]     //Länge
  5570.         MOVZX ECX,CL
  5571.  
  5572. !ndo_33:
  5573.         MOV AL,[EDI+1]
  5574.         CMP AL,32
  5575.         JNE !do_33
  5576.         CMP ECX,0
  5577.         JE !do_33
  5578.         DEC ECX
  5579.         INC EDI
  5580.         JMP !ndo_33
  5581. !do_33:
  5582.         PUSH EDI
  5583.         ADD EDI,ECX
  5584.         CMPB [EDI+0],32
  5585.         JNE !do_33_1
  5586.         DEC ECX
  5587.         POP EDI
  5588.         JMP !do_33
  5589. !do_33_1:
  5590.         POP EDI
  5591.  
  5592.         MOVB [EBP-6],0
  5593.  
  5594.         MOVD [EBP-10],10   //Base
  5595.         MOV AL,[EDI+1]
  5596.         ADD EDI,ECX
  5597.         CMP AL,'$'         //Hexadecimal ??
  5598.         JNE !___nohex
  5599.         CMP ECX,1
  5600.         JE !___qerr
  5601.         MOVD [EBP-10],16   //Base
  5602.         DEC ECX
  5603. !___nohex:
  5604.         CMP AL,'-'
  5605.         JNE !___q2
  5606.         CMP ECX,1
  5607.         JE !___qerr
  5608.         DEC ECX
  5609.         MOVB [EBP-6],1
  5610. !___q2:
  5611.         MOV EBX,1
  5612.         MOV EAX,0
  5613.         MOV [EBP-4],EAX
  5614. !___q1:
  5615.         MOV AL,[EDI+0]
  5616.         DEC EDI
  5617.         CMP AL,48
  5618.         JB !___qerr
  5619.         CMP AL,57
  5620.         JNA !___noqerr
  5621.  
  5622.         CMP AL,102
  5623.         JA !___qerr
  5624.         CMP AL,65
  5625.         JB !___qerr
  5626.         CMP AL,70
  5627.         JBE !___hexnum
  5628.         CMP AL,97
  5629.         JB !___qerr
  5630.         SUB AL,32       //To upper
  5631. !___hexnum:
  5632.         CMPD [EBP-10],16
  5633.         JNE !___qerr
  5634.         SUB AL,7
  5635. !___noqerr:
  5636.         SUB AL,48
  5637.         MOVZX EAX,AL
  5638.         MUL EBX
  5639.         MOV EDX,[EBP-4]
  5640.         ADD EDX,EAX
  5641.         MOV [EBP-4],EDX
  5642.         MOV EAX,EBX
  5643.         MOV EBX,[EBP-10]    //Base
  5644.         MUL EBX
  5645.         MOV EBX,EAX
  5646.         LOOP !___q1
  5647. !___qerr:
  5648.         MOV EDI,[EBP+8]     //result
  5649.         XOR CH,CH
  5650.         MOV [EDI+0],CX
  5651.  
  5652.         // failure ??
  5653.         CMP CX,0
  5654.         JE !qqqq2    //no error
  5655.         PUSHL [EBP+16]  //s
  5656.         CALLN32 SYSTEM.GetStrErrorPos
  5657.         MOV EDI,[EBP+8]
  5658.         MOV [EDI+0],EAX
  5659.         MOV EAX,0
  5660.         JMP !___q3
  5661. !qqqq2:
  5662.         MOV EAX,[EBP-4]
  5663.         CMPB [EBP-6],1
  5664.         JNE !___q3
  5665.         NEG EAX
  5666. !___q3:
  5667.         MOV EDI,[EBP+12]    //l
  5668.         MOV [EDI+0],AL
  5669.         LEAVE
  5670.         RETN32 12
  5671. SYSTEM.!Str2Byte ENDP
  5672.  
  5673. END;
  5674.  
  5675.  
  5676. ASSEMBLER
  5677.  
  5678. SYSTEM.!AssignStr2Array PROC NEAR32
  5679.                 CLD
  5680.                 PUSH EBP
  5681.                 MOV EBP,ESP
  5682.  
  5683.                 PUSH EAX
  5684.                 PUSH EBX
  5685.                 PUSH ECX
  5686.                 PUSH EDX
  5687.                 PUSH EDI
  5688.                 PUSH ESI
  5689.  
  5690.                 MOV EDI,[EBP+8]    //Destination Array
  5691.                 MOV ESI,[EBP+12]   //Source String
  5692.  
  5693.                 MOVZXB ECX,[ESI+0]
  5694.                 INC ESI
  5695.  
  5696.                 MOV EDX,ECX
  5697.                 SHR ECX,2
  5698.                 REP
  5699.                 MOVSD
  5700.                 MOV ECX,EDX
  5701.                 AND ECX,3
  5702.                 REP
  5703.                 MOVSB
  5704.  
  5705.                 POP ESI
  5706.                 POP EDI
  5707.                 POP EDX
  5708.                 POP ECX
  5709.                 POP EBX
  5710.                 POP EAX
  5711.  
  5712.                 LEAVE
  5713.                 RETN32 8
  5714. SYSTEM.!AssignStr2Array ENDP
  5715.  
  5716. SYSTEM.!AssignCStr2Array PROC NEAR32
  5717.                 CLD
  5718.                 PUSH EBP
  5719.                 MOV EBP,ESP
  5720.  
  5721.                 PUSH EAX
  5722.                 PUSH EBX
  5723.                 PUSH ECX
  5724.                 PUSH EDX
  5725.                 PUSH EDI
  5726.                 PUSH ESI
  5727.  
  5728.                 MOV ESI,[EBP+12]   //Source CString
  5729.                 MOV EDI,ESI
  5730.                 MOV ECX,$0FFFFFFFF
  5731.                 XOR AL,AL
  5732.                 REPNE
  5733.                 SCASB
  5734.                 NOT ECX
  5735.  
  5736.                 MOV EDI,[EBP+8]    //Destination Array
  5737.  
  5738.                 MOV EDX,ECX
  5739.                 SHR ECX,2
  5740.                 REP
  5741.                 MOVSD
  5742.                 MOV ECX,EDX
  5743.                 AND ECX,3
  5744.                 REP
  5745.                 MOVSB
  5746.  
  5747.                 POP ESI
  5748.                 POP EDI
  5749.                 POP EDX
  5750.                 POP ECX
  5751.                 POP EBX
  5752.                 POP EAX
  5753.  
  5754.                 LEAVE
  5755.                 RETN32 8
  5756. SYSTEM.!AssignCStr2Array ENDP
  5757.  
  5758. SYSTEM.!StrCopy PROC NEAR32
  5759.                 CLD
  5760.                 PUSH EBP
  5761.                 MOV EBP,ESP
  5762.  
  5763.                 PUSH EAX
  5764.                 PUSH ECX
  5765.                 PUSH EDI
  5766.                 PUSH ESI
  5767.  
  5768.                 MOV EDI,[EBP+12]    //Destination String
  5769.                 MOV ESI,[EBP+16]    //Source String
  5770.                 MOV ECX,[EBP+8]     //Maximum length
  5771.                 LODSB
  5772.                 CMP AL,CL
  5773.                 JBE _L1
  5774.                 MOV AL,CL
  5775. _L1:
  5776.                 STOSB
  5777.                 MOVZX ECX,AL
  5778.  
  5779.                 MOV EAX,ECX
  5780.                 SHR ECX,2
  5781.                 REP
  5782.                 MOVSD
  5783.                 MOV ECX,EAX
  5784.                 AND ECX,3
  5785.                 REP
  5786.                 MOVSB
  5787.  
  5788.                 POP ESI
  5789.                 POP EDI
  5790.                 POP ECX
  5791.                 POP EAX
  5792.  
  5793.                 LEAVE
  5794.                 RETN32 12
  5795. SYSTEM.!StrCopy ENDP
  5796.  
  5797. SYSTEM.!AssignStr2PChar PROC NEAR32
  5798.                 CLD
  5799.  
  5800.                 PUSH EBP
  5801.                 MOV EBP,ESP
  5802.  
  5803.                 PUSH EAX
  5804.                 PUSH ECX
  5805.                 PUSH EDX
  5806.                 PUSH EDI
  5807.                 PUSH ESI
  5808.  
  5809.                 MOV EDI,[EBP+12]    //Destination CString
  5810.                 MOV ESI,[EBP+16]    //Source String
  5811.                 MOV ECX,[EBP+8]     //Maximum length
  5812.  
  5813.                 LODSB               //get length of source string
  5814.                 MOVZX EAX,AL
  5815.                 CMP EAX,ECX
  5816.                 JB _L1_1
  5817.                 MOV EAX,ECX
  5818. _L1_1:
  5819.                 MOV ECX,EAX
  5820.                 MOV EDX,EAX
  5821.                 SHR ECX,2
  5822.                 REP
  5823.                 MOVSD
  5824.                 MOV ECX,EDX
  5825.                 AND ECX,3
  5826.                 REP
  5827.                 MOVSB
  5828.  
  5829.                 MOV AL,0
  5830.                 STOSB            //terminate PChar
  5831.  
  5832.                 POP ESI
  5833.                 POP EDI
  5834.                 POP EDX
  5835.                 POP ECX
  5836.                 POP EAX
  5837.  
  5838.                 LEAVE
  5839.                 RETN32 12
  5840. SYSTEM.!AssignStr2PChar ENDP
  5841.  
  5842. SYSTEM.!AssignPChar2Str PROC NEAR32
  5843.                 CLD
  5844.                 PUSH EBP
  5845.                 MOV EBP,ESP
  5846.  
  5847.                 PUSH EAX
  5848.                 PUSH EBX
  5849.                 PUSH ECX
  5850.                 PUSH EDX
  5851.                 PUSH EDI
  5852.                 PUSH ESI
  5853.  
  5854.                 MOV ESI,[EBP+16]   //Source CString
  5855.                 MOV EDX,[EBP+8]    //Maximum length
  5856.  
  5857.                 MOV EDI,ESI        //Source CString
  5858.                 MOV ECX,$0FFFFFFFF
  5859.                 XOR AL,AL
  5860.                 REPNE
  5861.                 SCASB
  5862.                 NOT ECX
  5863.                 MOV EAX,ECX        //length of source string
  5864.                 DEC EAX            //without #0
  5865.  
  5866.                 MOV EDI,[EBP+12]   //Destination String
  5867.  
  5868.                 CMP EAX,EDX
  5869.                 JB _L1_2
  5870.                 MOV EAX,EDX        //set to maximum length
  5871. _L1_2:
  5872.                 MOV ECX,EAX
  5873.                 STOSB              //set string length
  5874.  
  5875.                 MOV EDX,ECX
  5876.                 SHR ECX,2
  5877.                 REP
  5878.                 MOVSD
  5879.                 MOV ECX,EDX
  5880.                 AND ECX,3
  5881.                 REP
  5882.                 MOVSB
  5883.  
  5884.                 POP ESI
  5885.                 POP EDI
  5886.                 POP EDX
  5887.                 POP ECX
  5888.                 POP EBX
  5889.                 POP EAX
  5890.  
  5891.                 LEAVE
  5892.                 RETN32 12
  5893. SYSTEM.!AssignPChar2Str ENDP
  5894.  
  5895. SYSTEM.!CopyArrayStr PROC NEAR32
  5896.                 CLD
  5897.                 MOV EBX,ESP
  5898.                 MOV EDI,[EBX+12]    //Destination String
  5899.                 MOV ESI,[EBX+16]    //Source Array
  5900.                 MOV ECX,[EBX+8]     //Maximum string length
  5901.                 DEC ECX             //minus length byte
  5902.                 MOV EAX,[EBX+4]     //Array length
  5903.  
  5904.                 CMP AL,CL
  5905.                 JBE _L11
  5906.                 MOV AL,CL
  5907. _L11:
  5908.                 STOSB               //String length
  5909.                 MOV CL,AL
  5910.                 MOVZX ECX,CL
  5911.  
  5912.                 MOV EDX,ECX
  5913.                 SHR ECX,2
  5914.                 REP
  5915.                 MOVSD
  5916.                 MOV ECX,EDX
  5917.                 AND ECX,3
  5918.                 REP
  5919.                 MOVSB
  5920.  
  5921.                 RETN32 16
  5922. SYSTEM.!CopyArrayStr ENDP
  5923.  
  5924. SYSTEM.!PCharCopy PROC NEAR32
  5925.          CLD
  5926.          MOV EBX,ESP
  5927.          MOV EDI,[EBX+12]  //Source
  5928.          MOV ECX,$0FFFFFFFF
  5929.          XOR AL,AL
  5930.          REPNE
  5931.          SCASB
  5932.          NOT ECX
  5933.          MOV EDX,[EBX+4]   //Maximum length
  5934.          CMP EDX,ECX
  5935.          JAE _re
  5936.          MOV ECX,EDX
  5937. _re:
  5938.          MOV ESI,[EBX+12]  //Source
  5939.          MOV EDI,[EBX+8]   //Destination
  5940.  
  5941.          MOV EDX,ECX
  5942.          SHR ECX,2
  5943.          REP
  5944.          MOVSD
  5945.          MOV ECX,EDX
  5946.          AND ECX,3
  5947.          REP
  5948.          MOVSB
  5949.  
  5950.          RETN32 12
  5951. SYSTEM.!PCharCopy ENDP
  5952.  
  5953. SYSTEM.!PCharLength PROC NEAR32
  5954.          MOV EBX,ESP
  5955.  
  5956.          PUSH EBX
  5957.          PUSH EDI
  5958.          PUSH ECX
  5959.  
  5960.          MOV EDI,[EBX+4]   //Source
  5961.          MOV ECX,$0FFFFFFFF
  5962.          XOR AL,AL
  5963.          CLD
  5964.          REPNE
  5965.          SCASB
  5966.          NOT ECX
  5967.          MOV EAX,ECX
  5968.          DEC EAX           //without #0
  5969.  
  5970.          POP ECX
  5971.          POP EDI
  5972.          POP EBX
  5973.          RETN32 4
  5974. SYSTEM.!PCharLength ENDP
  5975.  
  5976.  
  5977. SYSTEM.!StrAdd PROC NEAR32
  5978.         PUSH EBP
  5979.         MOV EBP,ESP
  5980.  
  5981.         PUSH EAX
  5982.         PUSH EBX
  5983.         PUSH ECX
  5984.         PUSH EDX
  5985.         PUSH EDI
  5986.         PUSH ESI
  5987.  
  5988.         MOV EDI,[EBP+12]    //Destination
  5989.         MOV ESI,[EBP+8]     //String to add
  5990.         MOVZXB ECX,[EDI+0]  //length of destination
  5991.         CLD
  5992.         LODSB               //length of string to add
  5993.         ADD [EDI+0],AL
  5994.         JNC _lll1
  5995.         MOVB [EDI+0],255
  5996.         MOV AL,CL
  5997.         NOT AL
  5998. _lll1:
  5999.         ADD EDI,ECX
  6000.         INC EDI
  6001.         MOV CL,AL
  6002.  
  6003.         MOV EDX,ECX
  6004.         SHR ECX,2
  6005.         REP
  6006.         MOVSD
  6007.         MOV ECX,EDX
  6008.         AND ECX,3
  6009.         REP
  6010.         MOVSB
  6011.  
  6012.         POP ESI
  6013.         POP EDI
  6014.         POP EDX
  6015.         POP ECX
  6016.         POP EBX
  6017.         POP EAX
  6018.  
  6019.         LEAVE
  6020.         RETN32 8
  6021. SYSTEM.!StrAdd ENDP
  6022.  
  6023. SYSTEM.!PCharAdd PROC NEAR32
  6024.         PUSH EBP
  6025.         MOV EBP,ESP
  6026.  
  6027.         PUSH EAX
  6028.         PUSH EBX
  6029.         PUSH ECX
  6030.         PUSH EDX
  6031.         PUSH EDI
  6032.         PUSH ESI
  6033.  
  6034.         CLD
  6035.  
  6036.         MOV ESI,[EBP+8]    //String to add
  6037.         MOV EDI,[EBP+8]    //String to add
  6038.         MOV ECX,$0FFFFFFFF
  6039.         XOR AL,AL
  6040.         REPNE
  6041.         SCASB
  6042.         NOT ECX            //length of string to add
  6043.         DEC ECX            //without #0
  6044.         MOV EBX,ECX
  6045.  
  6046.         MOV EDI,[EBP+12]   //Destination
  6047.         MOV ECX,$0FFFFFFFF
  6048.         XOR AL,AL
  6049.         REPNE
  6050.         SCASB
  6051.         NOT ECX            //length of destination
  6052.         DEC ECX            //without #0
  6053.  
  6054.         MOV EDI,[EBP+12]   //Destination
  6055.         ADD EDI,ECX        //add length to destination
  6056.  
  6057.         MOV ECX,EBX        //length of string to add
  6058.  
  6059.         MOV EDX,ECX
  6060.         SHR ECX,2
  6061.         REP
  6062.         MOVSD
  6063.         MOV ECX,EDX
  6064.         AND ECX,3
  6065.         REP
  6066.         MOVSB
  6067.  
  6068.         MOV AL,0
  6069.         STOSB              //terminate PChar
  6070.  
  6071.         POP ESI
  6072.         POP EDI
  6073.         POP EDX
  6074.         POP ECX
  6075.         POP EBX
  6076.         POP EAX
  6077.  
  6078.         LEAVE
  6079.         RETN32 8
  6080. SYSTEM.!PCharAdd ENDP
  6081.  
  6082. SYSTEM.!Str2PChar PROC NEAR32
  6083.                PUSH EBP
  6084.                MOV EBP,ESP
  6085.  
  6086.                PUSH EAX
  6087.                PUSH EBX
  6088.                PUSH ECX
  6089.                PUSH EDX
  6090.                PUSH EDI
  6091.                PUSH ESI
  6092.  
  6093.                MOV ESI,[EBP+8]     //String to convert
  6094.                MOV EDI,ESI
  6095.                MOVZXB ECX,[ESI+0]
  6096.                INC ESI
  6097.  
  6098.                CLD
  6099.                MOV EDX,ECX
  6100.                SHR ECX,2
  6101.                REP
  6102.                MOVSD
  6103.                MOV ECX,EDX
  6104.                AND ECX,3
  6105.                REP
  6106.                MOVSB
  6107.  
  6108.                MOV AL,0   //terminate PChar
  6109.                STOSB
  6110.  
  6111.                POP ESI
  6112.                POP EDI
  6113.                POP EDX
  6114.                POP ECX
  6115.                POP EBX
  6116.                POP EAX
  6117.  
  6118.                LEAVE
  6119.                RETN32 4
  6120. SYSTEM.!Str2PChar ENDP
  6121.  
  6122. SYSTEM.!PChar2Str PROC NEAR32
  6123.                PUSH EBP
  6124.                MOV EBP,ESP
  6125.  
  6126.                PUSH EAX
  6127.                PUSH EBX
  6128.                PUSH ECX
  6129.                PUSH EDX
  6130.                PUSH EDI
  6131.                PUSH ESI
  6132.  
  6133.                MOV EDI,[EBP+8]   //string to convert
  6134.  
  6135.                CLD
  6136.                MOV ECX,$0FFFFFFFF
  6137.                XOR AL,AL
  6138.                REPNE
  6139.                SCASB
  6140.                NOT ECX            //length of string
  6141.                DEC ECX            //without #0
  6142.                MOV EDX,ECX        //used to set len
  6143.  
  6144.                MOV ESI,[EBP+8]
  6145.                ADD ESI,ECX        //to last character of source
  6146.                DEC ESI
  6147.                MOV EDI,ESI
  6148.                INC EDI            //destination is 1 up
  6149.  
  6150.                STD                //move the bytes 1 up
  6151.                REP
  6152.                MOVSB
  6153.  
  6154.                MOV AL,DL          //set string length
  6155.                STOSB
  6156.                CLD
  6157.  
  6158.                POP ESI
  6159.                POP EDI
  6160.                POP EDX
  6161.                POP ECX
  6162.                POP EBX
  6163.                POP EAX
  6164.  
  6165.                LEAVE
  6166.                RETN32
  6167. SYSTEM.!PChar2Str ENDP
  6168.  
  6169. SYSTEM.!StringCmp PROC NEAR32
  6170.               CLD
  6171.               PUSH EBP
  6172.               MOV EBP,ESP
  6173.  
  6174.               PUSH EAX
  6175.               PUSH ECX
  6176.               PUSH EDI
  6177.               PUSH ESI
  6178.  
  6179.               MOV EDI,[EBP+12]
  6180.               MOV ESI,[EBP+8]
  6181.               LODSB
  6182.               MOV AH,[EDI+0]
  6183.               INC EDI
  6184.               MOV CL,AL
  6185.               CMP CL,AH
  6186.               JBE _nl1
  6187.               MOV CL,AH
  6188. _nl1:
  6189.               OR CL,CL
  6190.               JE _nl2
  6191.               MOVZX ECX,CL
  6192.               CLD
  6193.               REP
  6194.               CMPSB
  6195.               JNE _nl3
  6196. _nl2:
  6197.               CMP AL,AH
  6198. _nl3:
  6199.               POP ESI
  6200.               POP EDI
  6201.               POP ECX
  6202.               POP EAX
  6203.  
  6204.               LEAVE
  6205.               RETN32 8
  6206. SYSTEM.!StringCmp ENDP
  6207.  
  6208. SYSTEM.!PCharCmp PROC NEAR32
  6209.               CLD
  6210.               PUSH EBP
  6211.               MOV EBP,ESP
  6212.  
  6213.               PUSH EAX
  6214.               PUSH EBX
  6215.               PUSH ECX
  6216.               PUSH EDX
  6217.               PUSH EDI
  6218.               PUSH ESI
  6219.  
  6220.               MOV EDI,[EBP+8]
  6221.               CLD
  6222.               MOV ECX,$0FFFFFFFF
  6223.               XOR AL,AL
  6224.               REPNE
  6225.               SCASB
  6226.               NOT ECX            //length of string
  6227.               DEC ECX            //without #0
  6228.               MOV EBX,ECX        //used to set len
  6229.  
  6230.               MOV EDI,[EBP+12]
  6231.               CLD
  6232.               MOV ECX,$0FFFFFFFF
  6233.               XOR AL,AL
  6234.               REPNE
  6235.               SCASB
  6236.               NOT ECX            //length of string
  6237.               DEC ECX            //without #0
  6238.               MOV EDX,ECX
  6239.  
  6240.               MOV EDI,[EBP+12]
  6241.               MOV ESI,[EBP+8]
  6242.  
  6243.               CMP EBX,ECX
  6244.               JNE _nl3_1
  6245. _nl1_1:
  6246.               OR ECX,ECX
  6247.               JE _nl2_1
  6248.  
  6249.               CLD
  6250.               REP
  6251.               CMPSB
  6252.               JNE _nl3_1
  6253. _nl2_1:
  6254.               CMP EBX,EDX
  6255. _nl3_1:
  6256.               POP ESI
  6257.               POP EDI
  6258.               POP EDX
  6259.               POP ECX
  6260.               POP EBX
  6261.               POP EAX
  6262.  
  6263.               LEAVE
  6264.               RETN32 8
  6265. SYSTEM.!PCharCmp ENDP
  6266.  
  6267. SYSTEM.!StrPCharCmp PROC NEAR32
  6268.               CLD
  6269.               PUSH EBP
  6270.               MOV EBP,ESP
  6271.  
  6272.               PUSH EAX
  6273.               PUSH EBX
  6274.               PUSH ECX
  6275.               PUSH EDX
  6276.               PUSH EDI
  6277.               PUSH ESI
  6278.  
  6279.               MOV EDI,[EBP+8]    //PChar
  6280.               CLD
  6281.               MOV ECX,$0FFFFFFFF
  6282.               XOR AL,AL
  6283.               REPNE
  6284.               SCASB
  6285.               NOT ECX            //length of string
  6286.               DEC ECX            //without #0
  6287.               MOV EBX,ECX        //used to set len
  6288.  
  6289.               MOV EDI,[EBP+12]   //Str
  6290.               MOVZXB ECX,[EDI]
  6291.               MOV EDX,ECX
  6292.  
  6293.               MOV EDI,[EBP+12]   //Str
  6294.               INC EDI
  6295.               MOV ESI,[EBP+8]    //PChar
  6296.  
  6297.               CMP EBX,ECX
  6298.               JNE _nl3_1_r1
  6299. _nl1_1_r1:
  6300.               OR ECX,ECX
  6301.               JE _nl2_1_r1
  6302.  
  6303.               CLD
  6304.               REP
  6305.               CMPSB
  6306.               JNE _nl3_1_r1
  6307. _nl2_1_r1:
  6308.               CMP EBX,EDX
  6309. _nl3_1_r1:
  6310.               POP ESI
  6311.               POP EDI
  6312.               POP EDX
  6313.               POP ECX
  6314.               POP EBX
  6315.               POP EAX
  6316.  
  6317.               LEAVE
  6318.               RETN32 8
  6319. SYSTEM.!StrPCharCmp ENDP
  6320.  
  6321. SYSTEM.!PCharStrCmp PROC NEAR32
  6322.               CLD
  6323.               PUSH EBP
  6324.               MOV EBP,ESP
  6325.  
  6326.               PUSH EAX
  6327.               PUSH EBX
  6328.               PUSH ECX
  6329.               PUSH EDX
  6330.               PUSH EDI
  6331.               PUSH ESI
  6332.  
  6333.               MOV EDI,[EBP+8]    //Str
  6334.               MOVZXB ECX,[EDI]
  6335.               MOV EBX,ECX        //used to set len
  6336.  
  6337.               MOV EDI,[EBP+12]   //PChar
  6338.               CLD
  6339.               MOV ECX,$0FFFFFFFF
  6340.               XOR AL,AL
  6341.               REPNE
  6342.               SCASB
  6343.               NOT ECX            //length of string
  6344.               DEC ECX            //without #0
  6345.               MOV EDX,ECX
  6346.  
  6347.               MOV EDI,[EBP+12]   //PChar
  6348.               MOV ESI,[EBP+8]    //Str
  6349.               INC ESI
  6350.  
  6351.               CMP EBX,ECX
  6352.               JNE _nl3_1_r2
  6353. _nl1_1_r2:
  6354.               OR ECX,ECX
  6355.               JE _nl2_1_r2
  6356.  
  6357.               CLD
  6358.               REP
  6359.               CMPSB
  6360.               JNE _nl3_1_r2
  6361. _nl2_1_r2:
  6362.               CMP EBX,EDX
  6363. _nl3_1_r2:
  6364.               POP ESI
  6365.               POP EDI
  6366.               POP EDX
  6367.               POP ECX
  6368.               POP EBX
  6369.               POP EAX
  6370.  
  6371.               LEAVE
  6372.               RETN32 8
  6373. SYSTEM.!PCharStrCmp ENDP
  6374.  
  6375. END;
  6376.  
  6377. //************************************************************************
  6378. // Error support functions
  6379. //************************************************************************
  6380.  
  6381. IMPORTS
  6382.        FUNCTION DosExit(action,result:LONGWORD):LONGWORD;
  6383.                     APIENTRY;             DOSCALLS index 234;
  6384. END;
  6385.  
  6386. PROCEDURE ExitAll;
  6387. BEGIN
  6388.      DosExit(1,ExitCode);
  6389. END;
  6390.  
  6391. PROCEDURE Halt(Code:LONGWORD);
  6392. VAR
  6393.    cs:CSTRING;
  6394.    cTitle:CSTRING;
  6395. BEGIN
  6396.      ExitCode:=Code;
  6397.  
  6398.      ASM
  6399. !exloop:
  6400.         PUSHL *!raddr            //Return adress for ExitProc
  6401.         PUSHL SYSTEM.ExitProc    //ExitProc on Stack
  6402.         RETN32
  6403. !raddr:
  6404.         JMP !exloop              //until termination
  6405.      END;
  6406. END;
  6407.  
  6408. PROCEDURE HaltIntern(Code:LONGWORD);
  6409. VAR
  6410.    cs:CSTRING;
  6411.    cTitle:CSTRING;
  6412. BEGIN
  6413.      ExitCode:=Code;
  6414.  
  6415.      IF ExitCode<>0 THEN
  6416.      BEGIN
  6417.           IF ApplicationType=1 THEN
  6418.           BEGIN
  6419.                cs:='Speed Pascal/2 Runtime error '+tostr(ExitCode);
  6420.                cTitle:='Runtime error';
  6421.                WinMessageBox(1,1,cs,ctitle,0,$4000 OR $0010);
  6422.           END
  6423.           ELSE Writeln('Speed Pascal/2 Runtime error ',ExitCode);
  6424.      END;
  6425.  
  6426.      ASM
  6427. !exloop_11:
  6428.         PUSHL *!raddr_11         //Return adress for ExitProc
  6429.         PUSHL SYSTEM.ExitProc    //ExitProc on Stack
  6430.         RETN32
  6431. !raddr_11:
  6432.         JMP !exloop_11           //until termination
  6433.      END;
  6434. END;
  6435.  
  6436. PROCEDURE RunError(Code:LONGWORD);
  6437. BEGIN
  6438.      HaltIntern(Code);
  6439. END;
  6440.  
  6441.  
  6442. //************************************************************************
  6443. //
  6444. //
  6445. // Memory support management functions
  6446. //
  6447. //
  6448. //************************************************************************
  6449.  
  6450. IMPORTS
  6451.        FUNCTION DosAllocMem(VAR ppb:POINTER;cb,flag:LONGWORD):LONGWORD;
  6452.                     APIENTRY;             DOSCALLS index 299;
  6453.        FUNCTION DosFreeMem(pb:POINTER):LONGWORD;
  6454.                     APIENTRY;             DOSCALLS index 304;
  6455.        FUNCTION DosSubAllocMem(pbBase:POINTER;VAR ppb:POINTER;
  6456.                         cb:LONGWORD):LONGWORD;
  6457.                     APIENTRY;             DOSCALLS index 345;
  6458.        FUNCTION DosSubFreeMem(pbBase:POINTER;pb:POINTER;
  6459.                               cb:LONGWORD):LONGWORD;
  6460.                     APIENTRY;             DOSCALLS index 346;
  6461.        FUNCTION DosSubSetMem(pbBase:POINTER;flag,cb:LONGWORD):LONGWORD;
  6462.                     APIENTRY;             DOSCALLS index 344;
  6463.        FUNCTION DosSubUnsetMem(pbBase:POINTER):LONGWORD;
  6464.                     APIENTRY;             DOSCALLS index 347;
  6465. END;
  6466.  
  6467. CONST
  6468.      PAG_READ          =$00000001;      { read access                }
  6469.      PAG_WRITE         =$00000002;      { write access               }
  6470.      PAG_COMMIT        =$00000010;      { commit storage             }
  6471.  
  6472.      DOSSUB_INIT       =$01;            { initialize pages           }
  6473.      DOSSUB_SPARSE_OBJ =$04;            { handle commitment          }
  6474.  
  6475.      DC_SEM_SHARED     =$01;            { heap Semaphore flag        }
  6476.  
  6477. PROCEDURE ErrorInvalidPointer(Adr:LONGINT);
  6478. VAR
  6479.     e:EInvalidPointer;
  6480. BEGIN
  6481.      e.Create('Invalid pointer operation (EInvalidPointer)');
  6482.      e.CameFromRTL:=TRUE;
  6483.      e.RTLExcptAddr:=POINTER(Adr);
  6484.      raise e;
  6485. END;
  6486.  
  6487. PROCEDURE ErrorOutOfMemory(Adr:LONGINT);
  6488. VAR
  6489.    e:EOutOfMemory;
  6490. BEGIN
  6491.      e.Create('Out of memory (EOutOfMemory)');
  6492.      e.CameFromRTL:=TRUE;
  6493.      e.RTLExcptAddr:=POINTER(Adr);
  6494.      raise e;
  6495. END;
  6496.  
  6497. PROCEDURE ErrorInvalidHeap(Adr:LONGINT);
  6498. VAR
  6499.     e:EInvalidHeap;
  6500. BEGIN
  6501.      e.Create('Heap corrupted or destroyed (EInvalidHeap)');
  6502.      e.CameFromRTL:=TRUE;
  6503.      e.RTLExcptAddr:=POINTER(Adr);
  6504.      raise e;
  6505. END;
  6506.  
  6507. PROCEDURE GetAPIMem(VAR p:POINTER;Size:LONGWORD);
  6508. VAR Adr:LONGINT;
  6509. BEGIN
  6510.      IF DosAllocMem(p,Size,PAG_READ OR PAG_WRITE OR PAG_COMMIT)<>0 THEN
  6511.      BEGIN
  6512.           ASM
  6513.              MOV EAX,[EBP+4]
  6514.              SUB EAX,5
  6515.              MOV $Adr,EAX
  6516.           END;
  6517.           ErrorOutOfMemory(Adr);
  6518.      END;
  6519. END;
  6520.  
  6521. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  6522. VAR Adr:LONGINT;
  6523. BEGIN
  6524.      IF DosFreeMem(p)<>0 THEN
  6525.      BEGIN
  6526.           ASM
  6527.              MOV EAX,[EBP+4]
  6528.              SUB EAX,5
  6529.              MOV $Adr,EAX
  6530.           END;
  6531.           ErrorInvalidPointer(Adr);
  6532.      END;
  6533. END;
  6534.  
  6535. PROCEDURE Mark(VAR p:POINTER);
  6536. BEGIN
  6537. END;
  6538.  
  6539. PROCEDURE Release(VAR p:POINTER);
  6540. BEGIN
  6541. END;
  6542.  
  6543. FUNCTION StdHeapError(size:LONGWORD):INTEGER;
  6544. BEGIN
  6545.      StdHeapError:=0;  {Raise Runtime error}
  6546. END;
  6547.  
  6548.  
  6549. IMPORTS
  6550. FUNCTION DosCreateMutexSem(pszName:CSTRING;VAR aphmtx:LONGWORD;flAttr:LONGWORD;
  6551.                            fState:LONGBOOL):LONGWORD;
  6552.                     APIENTRY;             DOSCALLS index 331;
  6553. FUNCTION DosRequestMutexSem(ahmtx:LONGWORD;ulTimeout:LONGWORD):LONGWORD;
  6554.                     APIENTRY;             DOSCALLS index 334;
  6555. FUNCTION DosReleaseMutexSem(ahmtx:LONGWORD):LONGWORD;
  6556.                     APIENTRY;             DOSCALLS index 335;
  6557. END;
  6558.  
  6559. CONST HeapFlag=$524E544C;
  6560.  
  6561. VAR HeapMutex:LONGWORD;
  6562.  
  6563. type
  6564.     PHeapList=^THeapList;
  6565.     THeapList=RECORD
  6566.                     Flag:LONGWORD;   {RNTM}
  6567.                     Size:LONGWORD;
  6568.                     LastLeak:PHeapList;
  6569.                     NextLeak:PHeapList;
  6570.     END;
  6571.  
  6572. type
  6573.     PHeapPages=^THeapPages;
  6574.     THeapPages=ARRAY[0..2047] OF PHeapList;  {Pointers to heap handles}
  6575.  
  6576. VAR LastHeapPage:PHeapList;
  6577.     LastHeapPageAdr:PHeapList;
  6578.     HeapStrategyBestFit:BOOLEAN;
  6579.  
  6580. PROCEDURE RequestHeapMutex;
  6581. BEGIN
  6582.      {$IFDEF OS2}
  6583.      DosRequestMutexSem(HeapMutex,-1);
  6584.      {$ENDIF}
  6585.      {$IFDEF Win95}
  6586.      WaitForSingleObject(HeapMutex,$FFFFFFFF);
  6587.      {$ENDIF}
  6588. END;
  6589.  
  6590. PROCEDURE ReleaseHeapMutex;
  6591. BEGIN
  6592.      {$IFDEF Win95}
  6593.      ReleaseMutex(HeapMutex);
  6594.      {$ENDIF}
  6595.      {$IFDEF OS2}
  6596.      DosReleaseMutexSem(HeapMutex);
  6597.      {$ENDIF}
  6598. END;
  6599.  
  6600. PROCEDURE HeapErrorIntern(Code:LONGINT;Adr:LONGWORD);
  6601. BEGIN
  6602.      ReleaseHeapMutex; {!!}
  6603.      CASE Code OF
  6604.          1:
  6605.          BEGIN
  6606.               NewSystemHeap; {!!}
  6607.               ErrorOutOfMemory(Adr);
  6608.               Halt;
  6609.          END;
  6610.          2:
  6611.          BEGIN
  6612.               ErrorInvalidPointer(Adr);
  6613.               Halt;
  6614.          END;
  6615.          3:
  6616.          BEGIN
  6617.               NewSystemHeap; {!!}
  6618.               ErrorInvalidHeap(Adr);
  6619.               Halt;
  6620.          END;
  6621.          ELSE
  6622.          BEGIN
  6623.               ErrorInvalidPointer(Adr);
  6624.               Halt;
  6625.          END;
  6626.      END; {case}
  6627. END;
  6628.  
  6629. VAR MemPageSize:LONGWORD;
  6630.  
  6631. PROCEDURE AllocNewPage(Size:LONGWORD);ASSEMBLER;
  6632. VAR Adr:LONGWORD;
  6633. ASM
  6634.    MOV EAX,[EBP+4]
  6635.    SUB EAX,5
  6636.    MOV $Adr,EAX
  6637.  
  6638.    MOV ECX,$Size
  6639.    MOV EBX,SYSTEM.MemPageSize
  6640.    SUB EBX,40
  6641.    CMP ECX,EBX    //32730
  6642.    JBE !AllocSizeOk
  6643.  
  6644.    {ensure that we can write HeapList with at least 2 entries}
  6645.    ADD ECX,32
  6646.  
  6647. !AllocSizeOk:
  6648.    {round page up to multiple of 128K}
  6649.    MOV EBX,SYSTEM.MemPageSize
  6650.    SUB EBX,1
  6651.    MOV EDX,$FFFFFFFF
  6652.    SUB EDX,EBX
  6653.    ADD ECX,EBX    //32767
  6654.    AND ECX,EDX    //$FFFF8000
  6655.  
  6656.    {Allocate Page}
  6657.    MOV $Size,ECX
  6658.  
  6659.    {IF DosAllocMem(LastHeapPage,size,PAG_READ OR PAG_WRITE OR PAG_COMMIT)<>0 THEN}
  6660.    PUSHL $13       {PAG_READ OR PAG_WRITE OR PAG_COMMIT}
  6661.    PUSH ECX
  6662.    PUSHL OFFSET(SYSTEM.LastHeapPage)
  6663.    MOV AL,3
  6664.    CALLDLL DosCalls,299    {DosAllocMem}
  6665.    ADD ESP,12
  6666.    CMP EAX,0
  6667.    JE !AllocNoError
  6668.  
  6669.    PUSHL 1   {Out of memory error}
  6670.    PUSHL $Adr
  6671.    CALLN32 SYSTEM.HeapErrorIntern
  6672.  
  6673. !AllocNoError:
  6674.    MOV EDI,SYSTEM.HeapOrg
  6675.    MOV ECX,2047
  6676.  
  6677.    MOV EAX,0
  6678.    CLD
  6679.    REPNE
  6680.    SCASD
  6681.    CMP ECX,0
  6682.    JNE !AllocPageFound
  6683.  
  6684.    PUSHL 1  {Out of memory error}
  6685.    PUSHL $Adr
  6686.    CALLN32 SYSTEM.HeapErrorIntern
  6687.  
  6688. !AllocPageFound:
  6689.    SUB EDI,4
  6690.    MOV EAX,SYSTEM.LastHeapPage      {dummy^[t]:=LastHeapPage}
  6691.    MOV [EDI],EAX
  6692.    MOV SYSTEM.LastHeapPageAdr,EDI   {LastHeapPageAdr:=@dummy^[t];}
  6693.  
  6694.    {First leak node - never changed}
  6695.    MOV EDI,SYSTEM.LastHeapPage
  6696.    MOV ECX,$Size
  6697.  
  6698.    MOV [EDI].THeapList.Size,ECX        {LastHeapPage^.size:=Initial size;}
  6699.    MOVD [EDI].THeapList.Flag,HeapFlag  {LastHeapPage^.Flag:=HeapFlag;}
  6700.    MOVD [EDI].THeapList.LastLeak,0     {LastHeapPage^.LastLeak:=NIL;}
  6701.    MOV EAX,EDI
  6702.    ADD EAX,16                          {LastHeapPage^.NextLeak:=LastHeapPage+16;}
  6703.    MOV [EDI].THeapList.NextLeak,EAX
  6704.  
  6705.    {second leak node contains size of first leak (whole page-32 here}
  6706.    {This ensures that we have at least 2 page entries free}
  6707.    {EAX=LastHeapPage^.NextLeak}
  6708.    SUB ECX,32                          {LastHeapPage^.NextLeak^.size:=size-32;}
  6709.    MOV [EAX].THeapList.size,ECX
  6710.    MOV [EAX].THeapList.LastLeak,EDI    {LastHeapPage^.NextLeak^.LastLeak:=LastHeapPage;}
  6711.    MOVD [EAX].THeapList.NextLeak,0     {LastHeapPage^.NextLeak^.NextLeak:=NIL;}
  6712.    MOVD [EAX].THeapList.Flag,HeapFlag  {LastHeapPage^.NextLeak^.Flag:=HeapFlag;}
  6713. END;
  6714.  
  6715. PROCEDURE GetMem(VAR p:POINTER;size:LONGWORD);ASSEMBLER;
  6716. VAR OldEDI,OldECX,Adr:LONGWORD;
  6717. ASM
  6718.    MOV EAX,[EBP+4]
  6719.    SUB EAX,5
  6720.    MOV $Adr,EAX
  6721.  
  6722.    CALLN32 SYSTEM.RequestHeapMutex
  6723.  
  6724.    MOVD $OldEDI,0
  6725.  
  6726.    {IF LastHeapPage=NIL THEN}
  6727.    CMPD SYSTEM.LastHeapPage,0
  6728.    JNE !GetMemLastPageSet
  6729.  
  6730.    {Search for first page node allocated}
  6731. !GetMemScanMapStart:
  6732.    MOV EDI,SYSTEM.HeapOrg
  6733.    MOV ECX,2047
  6734. !GetMemScanMapAgain:
  6735.    {Scan for first Page<>NIL}
  6736.    MOV EAX,0
  6737.    CLD
  6738.    REPE
  6739.    SCASD
  6740.    CMP ECX,0
  6741.    JNE !GetMemPageFound
  6742.  
  6743.    {no previously allocated Page found --> new page}
  6744.    MOVD $OldEDI,$FFFFFFFF     {dont loop again to scan map}
  6745.    MOV ECX,$Size
  6746.    ADD ECX,4
  6747.    PUSH ECX
  6748.    CALLN32 SYSTEM.AllocNewPage
  6749.    JMP !GetMemLastPageSet
  6750.  
  6751. !GetMemPageFound:
  6752.    MOV $OldEDI,EDI
  6753.    MOV $OldECX,ECX
  6754.  
  6755.    {Calculate index for that item}
  6756.    MOV EAX,EDI
  6757.    SUB EAX,4
  6758.    MOV SYSTEM.LastHeapPageAdr,EAX
  6759.  
  6760.    MOV EAX,[EAX]     {get pointer to start of page}
  6761.    MOV SYSTEM.LastHeapPage,EAX
  6762.  
  6763. !GetMemLastPageSet:
  6764.  
  6765.    {Try to find the memory in LastHeapPage}
  6766.    MOV ECX,$Size
  6767.    TEST ECX,ECX
  6768.    JNE !GetMemSizeOk
  6769.  
  6770.    MOV EDI,$p
  6771.    MOVD [EDI],0
  6772.    CALLN32 SYSTEM.ReleaseHeapMutex
  6773.    LEAVE
  6774.    RETN32 8
  6775.  
  6776. !GetMemSizeOk:
  6777.    {Round up requested size to multiples of 16 and add 4 byte for page item}
  6778.    ADD ECX,4
  6779.    ADD ECX,15
  6780.    AND ECX,$FFFFFFF0
  6781.  
  6782.    MOV EDI,SYSTEM.LastHeapPage        {dummy:=LastHeapPage;}
  6783.    MOV ESI,EDI                         {Last:=LastHeapPage;}
  6784.    MOV EBX,0                           {Found:=NIL;}
  6785.    MOV EDX,$FFFFFFFF                   {FoundLen:=$FFFFFFFF;}
  6786.    JMP !GetMemLoop2
  6787.  
  6788. !GetMemLoop1:
  6789.    MOV ESI,EDI                         {Last:=dummy}
  6790.    MOV EDI,[EDI].THeapList.NextLeak    {dummy:=dummy^.NextLeak}
  6791.  
  6792. !GetMemLoop2:
  6793.    {WHILE dummy<>NIL DO}
  6794.    TEST EDI,EDI
  6795.    JE !GetMemLoopEnd
  6796.  
  6797.    CMPD [EDI].THeapList.Flag,HeapFlag  {IF dummy^.Flag<>HeapFlag}
  6798.    JE !GetMemFlagOk
  6799.  
  6800.    PUSHL 3           {HeapList Corrupted}
  6801.    PUSHL $Adr
  6802.    CALLN32 SYSTEM.HeapErrorIntern
  6803.  
  6804. !GetMemFlagOk:
  6805.    {dont use first entry (contains overall size of page}
  6806.    CMP EDI,SYSTEM.LastHeapPage
  6807.    JE !GetMemLoop1
  6808.  
  6809.    {IF dummy^.Size>=len THEN}
  6810.    CMP [EDI].THeapList.Size,ECX
  6811.    JB !GetMemLoop1
  6812.  
  6813.    {IF dummy^.Size<>Len THEN}
  6814.    JNE !GetMemLenGreater
  6815.  
  6816. !GetMemFit:
  6817.    {Requested memory fits the leak}
  6818.    MOV EBX,EDI                         {Found:=dummy;}
  6819.    MOV EDX,ECX                         {FoundLen:=dummy^.size;}
  6820.    JMP !GetMemFoundOk
  6821.  
  6822. !GetMemLenGreater:
  6823.    {If Heap strategy is not "Best Fit" - use the first leak}
  6824.    CMPB SYSTEM.HeapStrategyBestFit,1          {Best fit ??}
  6825.    JNE !GetMemFit
  6826.  
  6827.    {IF dummy^.size<FoundLen THEN}
  6828.    CMP [EDI].THeapList.Size,EDX
  6829.    JA !GetMemLoop1
  6830.  
  6831.    MOV EBX,EDI                         {Found:=dummy;}
  6832.    MOV EDX,[EDI].THeapList.Size        {FoundLen:=dummy^.Size;}
  6833.    JMP !GetMemLoop1
  6834.  
  6835. !GetMemLoopEnd:
  6836.    {IF Found=NIL THEN}
  6837.    CMP EBX,0
  6838.    JNE !GetMemFoundOk
  6839.  
  6840.    {No leak found that fulfilles the request - try scan map again}
  6841.    MOV EDI,$OldEDI
  6842.    CMP EDI,$FFFFFFFF
  6843.    JNE !GetMemScanMapPossible
  6844.  
  6845.    PUSHL 1               {Out of Memory}
  6846.    PUSHL $Adr
  6847.    CALLN32 SYSTEM.HeapErrorIntern
  6848.  
  6849. !GetMemScanMapPossible:
  6850.    CMP EDI,0             {No previous scan}
  6851.    JE !GetMemScanMapStart
  6852.  
  6853.    MOV ECX,$OldECX
  6854.    CMP ECX,0
  6855.    JA !GetMemScanMapAgain
  6856.  
  6857.    PUSHL 1               {Out of Memory}
  6858.    PUSHL $Adr
  6859.    CALLN32 SYSTEM.HeapErrorIntern
  6860.  
  6861. !GetMemFoundOk:
  6862.    {Leak found}
  6863.  
  6864.    {IF Leak fits exactly use the next entry for NextLeak}
  6865.    MOV EAX,[EBX].THeapList.Size
  6866.    CMP EAX,ECX
  6867.    JNE !LeakIsGreater
  6868.  
  6869.    MOV ESI,[EBX].THeapList.NextLeak
  6870.    {Dont use last leak - in extreme case the size of LastLeak is 0 !}
  6871.    CMP ESI,0
  6872.    JE !LeakIsGreater
  6873.  
  6874.    {Leak fits exactly - delete leak and update leak list}
  6875.    MOV EAX,[EBX].THeapList.LastLeak
  6876.    MOV [EAX].THeapList.NextLeak,ESI
  6877.    MOV [ESI].THeapList.LastLeak,EAX
  6878.    JMP !GetMemEnd
  6879.  
  6880. !LeakIsGreater:
  6881.    {Leak is greater - shrink the leak}
  6882.    MOV ESI,EBX                         {Found^.LastLeak^.NextLeak:=Found+len;}
  6883.    ADD ESI,ECX
  6884.    MOV EAX,[EBX].THeapList.LastLeak
  6885.    MOV [EAX].THeapList.NextLeak,ESI
  6886.  
  6887.    {EBX=Found, ESI=Found^.NextLeak New, ECX=Len}
  6888.    MOV EAX,[EBX].THeapList.Size        {Found^.NextLeak New^.size:=Found^.size-Len;}
  6889.    SUB EAX,ECX
  6890.    MOV [ESI].THeapList.Size,EAX
  6891.    MOV EAX,[EBX].THeapList.NextLeak    {Found^.NextLeak New^.NextLeak:=Found^.NextLeak;}
  6892.    MOV [ESI].THeapList.NextLeak,EAX
  6893.    MOVD [ESI].THeapList.Flag,HeapFlag  {Found^.NextLeak New^.Flag:=HeapFlag;}
  6894.    MOV EAX,[EBX].THeapList.LastLeak    {Found^.NextLeak New^.LastLeak:=Found^.LastLeak;}
  6895.    MOV [ESI].THeapList.LastLeak,EAX
  6896.    MOV EAX,[ESI].THeapList.NextLeak    {Found^.NextLeak New^.NextLeak^.LastLeak:=Found;}
  6897.    CMP EAX,0
  6898.    JE !GetMemEnd
  6899.    MOV [EAX].THeapList.LastLeak,ESI
  6900. !GetMemEnd:
  6901.  
  6902.    {Set the page for which this item was allocated}
  6903.    MOV EAX,SYSTEM.LastHeapPageAdr
  6904.    MOV [EBX+0],EAX
  6905.    ADD EBX,4
  6906.  
  6907.    MOV EDI,$p             {p:=Found}
  6908.    MOV [EDI+0],EBX
  6909.    PUSH EBX  //for FillMem
  6910.  
  6911.    CALLN32 SYSTEM.ReleaseHeapMutex
  6912.  
  6913.    POP EDI   //for FillMem
  6914.    CMPB SYSTEM.FillMemoryWithZero,0
  6915.    JE !DoNotFillMem
  6916.  
  6917.    CLD
  6918.    MOV ECX,$size
  6919.    MOV EAX,0
  6920.    MOV EDX,ECX
  6921.    SHR ECX,2
  6922.    REP
  6923.    STOSD
  6924.    MOV ECX,EDX
  6925.    AND ECX,3
  6926.    REP
  6927.    STOSB
  6928.  
  6929. !DoNotFillMem:
  6930.    LEAVE
  6931.    RETN32 8
  6932. END;
  6933.  
  6934. PROCEDURE SAVEGETMEM(var pp:Pointer;size:LongWord);
  6935. BEGIN
  6936.      ASM {!!}
  6937.         PUSH EAX
  6938.         PUSH EBX
  6939.         PUSH ECX
  6940.         PUSH EDX
  6941.         PUSH EDI
  6942.         PUSH ESI
  6943.      END;
  6944.  
  6945.      GetMem(pp,size);
  6946.  
  6947.      ASM {!!}
  6948.         POP ESI
  6949.         POP EDI
  6950.         POP EDX
  6951.         POP ECX
  6952.         POP EBX
  6953.         POP EAX
  6954.      END;
  6955. END;
  6956.  
  6957. IMPORTS
  6958.      FUNCTION DosAllocSharedMem(VAR ppb:POINTER;VAR pszName:CSTRING;
  6959.                                 cb,flag:LONGWORD):LONGWORD;
  6960.                     APIENTRY;             DOSCALLS index 300;
  6961. END;
  6962.  
  6963. PROCEDURE GETSHAREDMEM(var pp:Pointer;size:LongWord);
  6964. VAR Adr:LONGINT;
  6965. BEGIN
  6966.      IF DosAllocSharedMem(pp,NIL,size,$313) <> 0 THEN
  6967.      BEGIN
  6968.           ASM
  6969.             MOV EAX,[EBP+4]
  6970.             SUB EAX,5
  6971.             MOV $Adr,EAX
  6972.           END;
  6973.           ErrorOutOfMemory(Adr);
  6974.      END;
  6975. END;
  6976.  
  6977. PROCEDURE FREESHAREDMEM(p:pointer;size:LongWord);
  6978. BEGIN
  6979.      DosFreeMem(p);
  6980. END;
  6981.  
  6982. PROCEDURE FreeMem(p:POINTER;size:LONGWORD);ASSEMBLER;
  6983. VAR Page:PHeapPages;
  6984.     PageOrg:PHeapList;
  6985.     Adr:LONGWORD;
  6986. ASM
  6987.    MOV EAX,[EBP+4]
  6988.    SUB EAX,5
  6989.    MOV $Adr,EAX
  6990.  
  6991.    CALLN32 SYSTEM.RequestHeapMutex
  6992.  
  6993.    MOV ECX,$Size
  6994.    TEST ECX,ECX
  6995.    JNE !FreeMemSizeOk
  6996.  
  6997.    CALLN32 SYSTEM.ReleaseHeapMutex
  6998.    LEAVE
  6999.    RETN32 8
  7000.  
  7001. !FreeMemSizeOk:
  7002.    MOV EDI,$p
  7003.    JNE !FreeMemPointerOk
  7004.  
  7005.    PUSHL 2   {Illegal pointer operation}
  7006.    PUSHL $Adr
  7007.    CALLN32 SYSTEM.HeapErrorIntern
  7008.  
  7009. !FreeMemPointerOk:
  7010.    SUB EDI,4
  7011.    MOV EDI,[EDI]
  7012.    MOV $Page,EDI    {Page record pointer}
  7013.    MOV EDI,[EDI]    {Page Pointer}
  7014.    MOV $PageOrg,EDI
  7015.  
  7016.    ADD ECX,4
  7017.    ADD ECX,15
  7018.    AND ECX,$FFFFFFF0
  7019.  
  7020.    {EDI=Page Pointer, ECX=Size}
  7021.    MOV ESI,$p
  7022.    MOV EDI,$PageOrg
  7023.    SUB ESI,4
  7024.    JMP !FreeMemStartLoop
  7025.  
  7026. !FreeMemLoop1:
  7027.    MOV EDI,[EDI].THeapList.NextLeak
  7028.  
  7029. !FreeMemStartLoop:
  7030.    TEST EDI,EDI
  7031.    JNE !FreeMemPOk   {invalid pointer operation}
  7032.  
  7033.    PUSHL 2   {Illegal pointer operation}
  7034.    PUSHL $Adr
  7035.    CALLN32 SYSTEM.HeapErrorIntern
  7036.  
  7037. !FreeMemPOk:
  7038.    CMP EDI,ESI
  7039.    JAE !FreeMemLabErr1
  7040.  
  7041.    CMPD [EDI].THeapList.Flag,HeapFlag
  7042.    JE !FreeMemLab1
  7043.  
  7044.    PUSHL 3         {Heap corrupted}
  7045.    PUSHL $Adr
  7046.    CALLN32 SYSTEM.HeapErrorIntern
  7047.  
  7048. !FreeMemLab1:
  7049.    CMP [EDI].THeapList.NextLeak,ESI
  7050.    JB !FreeMemLoop1
  7051.  
  7052.    JMP !Proceed    {entry found}
  7053.  
  7054. !FreeMemLabErr1:
  7055.    PUSHL 2         {illegal pointer operation}
  7056.    PUSHL $Adr
  7057.    CALLN32 SYSTEM.HeapErrorIntern
  7058.  
  7059. !Proceed:
  7060.    {The memory is between dummy and dummy^.NextLeak}
  7061.  
  7062.    {ESI=p-4, EDI=dummy (LastLeak), ECX=Len}
  7063.    MOV EAX,ESI
  7064.    ADD EAX,ECX
  7065.    CMP EAX,[EDI].THeapList.NextLeak
  7066.    JA !FreeMemLabErr1   {illegal pointer operation}
  7067.  
  7068.    MOV EAX,EDI          {EAX=LastLeak}
  7069.    ADD EAX,16
  7070.    {IF LastLeak<>PageOrg THEN Add Size}
  7071.    CMP EDI,$PageOrg
  7072.    JE !FreeMemIsPageOrg
  7073.  
  7074.    SUB EAX,16           {Subtract 16 bytes because the size includes it}
  7075.    ADD EAX,[EDI].THeapList.Size
  7076.  
  7077. !FreeMemIsPageOrg:
  7078.    CMP ESI,EAX
  7079.    JAE !LeakOk
  7080.  
  7081.    PUSHL 2            {Illegal pointer operation}
  7082.    PUSHL $Adr
  7083.    CALLN32 SYSTEM.HeapErrorIntern
  7084.  
  7085. !LeakOk:
  7086.    {dummy=EDI, Len=ECX, ESI=p-4}
  7087.  
  7088.    {erstes Loch erhalten !}
  7089.    {IF ((dummy<>PageOrg)AND(dummy+dummy^.size=p)) THEN}
  7090.    CMP EDI,$PageOrg
  7091.    JE !FreeMemElseLab
  7092.  
  7093.    MOV EAX,EDI
  7094.    ADD EAX,[EDI].THeapList.size
  7095.    CMP EAX,ESI
  7096.    JNE !FreeMemElseLab
  7097.  
  7098.    {Speicher grenzt an Vorgängerloch - verschmelzen}
  7099.    MOV ESI,EDI                     {FreeP:=dummy;}
  7100.    ADD [ESI].THeapList.size,ECX    {inc(FreeP^.size,Len);}
  7101.    JMP !FreeMemElseEnd
  7102.  
  7103.    {ELSE}
  7104. !FreeMemElseLab:
  7105.  
  7106.    {FreeP=ESI=p}
  7107.    MOV [ESI].THeapList.Size,ECX              {FreeP^.size:=len;}
  7108.    MOV [ESI].THeapList.LastLeak,EDI          {FreeP^.LastLeak:=dummy;}
  7109.    MOV [ESI].THeapList.Flag,HeapFlag         {FreeP^.Flag:=HeapFlag;}
  7110.    MOV EDX,[EDI].THeapList.NextLeak          {FreeP^.NextLeak:=dummy^.NextLeak;}
  7111.    MOV [ESI].THeapList.NextLeak,EDX
  7112.    MOV [EDI].THeapList.NextLeak,ESI          {dummy^.NextLeak:=FreeP;}
  7113.    MOV [EDX].THeapList.LastLeak,ESI          {FreeP^.NextLeak^.LastLeak:=FreeP;}
  7114.  
  7115. !FreeMemElseEnd:
  7116.  
  7117.    {IF FreeP+FreeP^.size>=FreeP^.NextLeak THEN}
  7118.    MOV EAX,ESI
  7119.    ADD EAX,[ESI].THeapList.Size
  7120.    CMP EAX,[ESI].THeapList.NextLeak
  7121.    JB !FreeMemDone
  7122.  
  7123.    JE !LeaksAreOk
  7124.  
  7125.    PUSHL 2  {Illegal pointer operation}
  7126.    PUSHL $Adr
  7127.    CALLN32 SYSTEM.HeapErrorIntern
  7128.  
  7129. !LeaksAreOk:
  7130.    {Speicher grenzt an Nachfolgelock - verschmelzen}
  7131.    MOV EDI,[ESI].THeapList.NextLeak     {inc(FreeP^.size,FreeP^.NextLeak^.size);}
  7132.    {EDI=FreeP^.NextLeak}
  7133.    MOV EAX,[EDI].THeapList.Size
  7134.    ADD [ESI].THeapList.Size,EAX
  7135.    {Clear Flag of next leak}
  7136.    MOVD [EDI].THeapList.Flag,0
  7137.  
  7138.    MOV EAX,[EDI].THeapList.NextLeak      {FreeP^.NextLeak:=FreeP^.NextLeak^.NextLeak;}
  7139.    MOV [ESI].THeapList.NextLeak,EAX
  7140.    CMP EAX,0                             {FreeP^.NextLeak can be NIL !}
  7141.    JE !FreeMemDone
  7142.    MOV [EAX].THeapList.LastLeak,ESI      {FreeP^.NextLeak^.LastLeak:=FreeP;}
  7143.  
  7144. !FreeMemDone:
  7145.  
  7146.    {Check if this is the last entry and LastLeak=Page Pointer}
  7147.    CMPD [ESI].THeapList.NextLeak,0       {IF FreeP^.NextLeak=NIL THEN}
  7148.    JNE !FreeMemExit
  7149.  
  7150.    MOV EBX,$PageOrg                      {Page Pointer}
  7151.    CMP [ESI].THeapList.LastLeak,EBX      {IF FreeP^.LastLeak=Start of Page THEN}
  7152.    JNE !FreeMemExit
  7153.  
  7154.    {ensure that last entry starts immediately after Page start}
  7155.    {this ensures that no more memory is allocated bewteen these entries}
  7156.    {IF FreeP=Start OF Page+16 THEN}
  7157.    MOV EAX,EBX
  7158.    ADD EAX,16
  7159.    CMP ESI,EAX
  7160.    JNE !FreeMemExit
  7161.  
  7162.    {All storage was freed from the page > Free Page itself}
  7163.    PUSH EBX
  7164.    MOV AL,1
  7165.    CALLDLL DosCalls,304                  {DosFreeMem}
  7166.    ADD ESP,4
  7167.    CMP EAX,0
  7168.    JE !DosFreeMemOk
  7169.  
  7170.    PUSHL 2
  7171.    PUSHL $Adr
  7172.    CALLN32 SYSTEM.HeapErrorIntern
  7173.  
  7174. !DosFreeMemOk:
  7175.    {dont use that page anymore}
  7176.    MOV EDI,$Page
  7177.    MOV ESI,$PageOrg
  7178.    MOVD $Page,0
  7179.    MOVD $PageOrg,0
  7180.  
  7181.    {EDI=Page, ESI=PageOrg
  7182.    {Clear the entry in the page table and clear LastHeapPage if not valid}
  7183.    MOVD [EDI],0
  7184.  
  7185.    {If this page was the active page - clear it}
  7186.    {IF LastHeapPage=PageOrg THEN}
  7187.    CMP SYSTEM.LastHeapPage,ESI
  7188.    JNE !FreeMemExit1   {Leave LastHeapPage and LastHeapPageAddr as they are}
  7189.  
  7190. !FreeMemExit:
  7191.    {Set LastHeapPage and LastHeapPageAdr to the current page}
  7192.    MOV EAX,$PageOrg
  7193.    MOV SYSTEM.LastHeapPage,EAX
  7194.    MOV EAX,$Page
  7195.    MOV SYSTEM.LastHeapPageAdr,EAX
  7196.  
  7197. !FreeMemExit1:
  7198.    CALLN32 SYSTEM.ReleaseHeapMutex
  7199.  
  7200.    LEAVE
  7201.    RETN32 8
  7202. END;
  7203.  
  7204. PROCEDURE SAVEFREEMEM(pp:pointer;size:LongWord);
  7205. BEGIN
  7206.      ASM {!!}
  7207.         PUSH EAX
  7208.         PUSH EBX
  7209.         PUSH ECX
  7210.         PUSH EDX
  7211.         PUSH EDI
  7212.         PUSH ESI
  7213.      END;
  7214.  
  7215.      FreeMem(pp,size);
  7216.  
  7217.      ASM {!!}
  7218.         POP ESI
  7219.         POP EDI
  7220.         POP EDX
  7221.         POP ECX
  7222.         POP EBX
  7223.         POP EAX
  7224.      END;
  7225. END;
  7226.  
  7227.  
  7228. FUNCTION  MaxAvail:LongWord;
  7229. VAR Page:PHeapPages;
  7230.     dummy:PHeapList;
  7231.     t,temp:LONGINT;
  7232. BEGIN
  7233.      RequestHeapMutex;
  7234.  
  7235.      {MaxAvail is APIAvail or biggest leak if greater}
  7236.      result:=HeapSize;
  7237.      Page:=HeapOrg;
  7238.      temp:=0;
  7239.      FOR t:=0 TO 2047 DO
  7240.      BEGIN
  7241.           dummy:=Page^[t];
  7242.  
  7243.           {sub page size from MaxAvail}
  7244.           IF dummy<>NIL THEN dec(result,dummy^.Size);
  7245.  
  7246.           {don't use first entry since it contains page size}
  7247.           IF dummy<>NIL THEN dummy:=dummy^.NextLeak;
  7248.           WHILE dummy<>NIL DO
  7249.           BEGIN
  7250.                IF dummy^.size>temp THEN temp:=dummy^.size;
  7251.                dummy:=dummy^.NextLeak;
  7252.           END;
  7253.      END;
  7254.  
  7255.      IF temp>result THEN result:=temp;
  7256.  
  7257.      ReleaseHeapMutex;
  7258. END;
  7259.  
  7260. FUNCTION  MemAvail:LongWord;
  7261. VAR Page:PHeapPages;
  7262.     dummy:PHeapList;
  7263.     t:LONGINT;
  7264. BEGIN
  7265.      RequestHeapMutex;
  7266.  
  7267.      {MemAvail is APIAvail plus all free leaks}
  7268.      result:=HeapSize;
  7269.      Page:=HeapOrg;
  7270.      FOR t:=0 TO 2047 DO
  7271.      BEGIN
  7272.           dummy:=Page^[t];
  7273.  
  7274.           {Sub Page size from MemAvail}
  7275.           IF dummy<>NIL THEN dec(result,dummy^.Size);
  7276.  
  7277.           {don't use first entry since it contains page size}
  7278.           IF dummy<>NIL THEN dummy:=dummy^.NextLeak;
  7279.           WHILE dummy<>NIL DO
  7280.           BEGIN
  7281.                inc(result,dummy^.size);
  7282.                dummy:=dummy^.NextLeak;
  7283.           END;
  7284.      END;
  7285.  
  7286.      ReleaseHeapMutex;
  7287. END;
  7288.  
  7289.  
  7290. FUNCTION CreateSystemHeap(Size:LONGWORD):BOOLEAN;
  7291. VAR p:POINTER;
  7292.     r:LONGWORD;
  7293. BEGIN
  7294.      IF size>32768*2048 THEN size:=32768*2048;  {can only handle 64MB}
  7295.  
  7296.      {Allocate Heap Pages Record}
  7297.      r:=DosAllocMem(HeapOrg,8192,PAG_READ OR PAG_WRITE OR PAG_COMMIT);
  7298.      IF r=0 THEN
  7299.      BEGIN
  7300.           FillChar(HeapOrg^,8192,0);
  7301.           HeapEnd:=HeapOrg;
  7302.           HeapPtr:=HeapOrg;
  7303.           LastHeapPage:=NIL;
  7304.           LastHeapPageAdr:=NIL;
  7305.           HeapSize:=Size;
  7306.      END
  7307.      ELSE
  7308.      BEGIN
  7309.           HeapOrg:=NIL;
  7310.           HeapEnd:=NIL;
  7311.           HeapPtr:=NIL;
  7312.           LastHeapPage:=NIL;
  7313.           LastHeapPageAdr:=NIL;
  7314.      END;
  7315.  
  7316.      result:=r=0;
  7317. END;
  7318.  
  7319. PROCEDURE DestroyHeap(Heap:POINTER);
  7320. VAR t:LONGINT;
  7321.     dummy:PHeapPages;
  7322.     Adr:LONGWORD;
  7323. BEGIN
  7324.      ASM
  7325.         MOV EAX,[EBP+4]
  7326.         SUB EAX,5
  7327.         MOV $Adr,EAX
  7328.      END;
  7329.      dummy:=Heap;
  7330.      {Deallocate all allocated pages}
  7331.      FOR t:=0 TO 2047 DO IF dummy^[t]<>NIL THEN
  7332.      BEGIN
  7333.           IF DosFreeMem(dummy^[t])<>0 THEN HeapErrorIntern(2,Adr);
  7334.      END;
  7335.  
  7336.      {Deallocate Heap pages record}
  7337.      IF DosFreeMem(Heap)<>0 THEN HeapErrorIntern(2,Adr);
  7338. END;
  7339.  
  7340.  
  7341. PROCEDURE NewSystemHeap;  {delete old system heap and create new one}
  7342. VAR OldSize:LONGWORD;
  7343.     Adr:LONGWORD;
  7344. BEGIN
  7345.     RequestHeapMutex;
  7346.  
  7347.     ASM
  7348.         MOV EAX,[EBP+4]
  7349.         SUB EAX,5
  7350.         MOV $Adr,EAX
  7351.     END;
  7352.  
  7353.     {Free old system heap and generate new}
  7354.     OldSize:=HeapSize;
  7355.     DestroySystemHeap;
  7356.     IF not CreateSystemHeap(OldSize) THEN
  7357.     BEGIN
  7358.          ReleaseHeapMutex;
  7359.          HeapErrorIntern(3,Adr);
  7360.     END
  7361.     ELSE ReleaseHeapMutex;
  7362. END;
  7363.  
  7364. PROCEDURE DestroySystemHeap;
  7365. BEGIN
  7366.      DestroyHeap(HeapOrg);
  7367.      HeapOrg:=NIL;
  7368.      HeapPtr:=NIL;
  7369.      HeapEnd:=NIL;
  7370.      FreeList:=NIL;
  7371.      HeapTop:=NIL;
  7372.      LastHeapPage:=NIL;
  7373.      LastHeapPageAdr:=NIL;
  7374. END;
  7375.  
  7376. //**************************************************************************
  7377. //
  7378. //    Random support
  7379. //
  7380. //**************************************************************************}
  7381.  
  7382.  
  7383. CONST
  7384.    Factor:WORD=$8405;
  7385.  
  7386. IMPORTS
  7387.        FUNCTION DosGetDateTime(VAR pdt:DATETIME):LONGWORD;
  7388.                     APIENTRY;             DOSCALLS index 230;
  7389. END;
  7390.  
  7391. PROCEDURE Randomize;
  7392. VAR
  7393.    d:DateTime;
  7394. BEGIN
  7395.      DosGetDateTime(d);
  7396.      RandSeed:=(((d.Hour SHL 8)+d.Min) SHL 16)+
  7397.                 ((d.Sec SHL 8)+d.Hundredths);
  7398. END;
  7399.  
  7400. PROCEDURE NextRandom;
  7401. BEGIN
  7402.      ASM
  7403.         MOV AX,SYSTEM.RandSeed
  7404.         MOV BX,SYSTEM.RandSeed+2
  7405.         MOV CX,AX
  7406.         MULW SYSTEM.Factor
  7407.         SHL CX,3
  7408.         ADD CH,CL
  7409.         ADD DX,CX
  7410.         ADD DX,BX
  7411.         SHL BX,2
  7412.         ADD DX,BX
  7413.         ADD DH,BL
  7414.         MOV CL,5
  7415.         SHL BX,CL
  7416.         ADD DH,BL
  7417.         ADD AX,1
  7418.         ADC DX,0
  7419.         MOV SYSTEM.RandSeed,AX
  7420.         MOV SYSTEM.RandSeed+2,DX
  7421.      END;
  7422. END;
  7423.  
  7424. FUNCTION  RANDOM(value:word):word;
  7425. BEGIN
  7426.      ASM
  7427.         CALLN32 SYSTEM.NextRandom
  7428.         MOV CX,DX
  7429.         MOV BX,$value
  7430.         MUL BX
  7431.         MOV AX,CX
  7432.         MOV CX,DX
  7433.         MUL BX
  7434.         ADD AX,CX
  7435.         ADC DX,0
  7436.         MOV AX,DX
  7437.         MOV $!FUNCRESULT,AX
  7438.     END;
  7439. END;
  7440.  
  7441. FUNCTION FloatRandom:EXTENDED;
  7442. BEGIN
  7443.      result:=Random(8192)/8192;
  7444. END;
  7445.  
  7446. //************************************************************************
  7447. //
  7448. //
  7449. // Direct Memory access support
  7450. //
  7451. //
  7452. //************************************************************************
  7453.  
  7454. PROCEDURE Move(CONST source; VAR dest; size:LONGWORD);ASSEMBLER;
  7455. ASM
  7456.         MOV ESI,$Source
  7457.         MOV EDI,$Dest
  7458.         MOV ECX,$Size
  7459.         CMP ESI,EDI
  7460.         JE !MoveEnd
  7461.         JA !MoveForw
  7462.         MOV EBX,ESI
  7463.         ADD EBX,ECX
  7464.         CMP EBX,EDI               // test overlapping
  7465.         JBE !MoveForw
  7466.  
  7467.         STD
  7468.         ADD ESI,ECX
  7469.         DEC ESI
  7470.         ADD EDI,ECX
  7471.         DEC EDI
  7472.         REP
  7473.         MOVSB
  7474.         CLD
  7475.         JMP !MoveEnd
  7476.  
  7477. !MoveForw:
  7478.         CLD
  7479.         MOV EDX,ECX
  7480.         SHR ECX,2
  7481.         REP
  7482.         MOVSD
  7483.         MOV ECX,EDX
  7484.         AND ECX,3
  7485.         REP
  7486.         MOVSB
  7487.  
  7488. !MoveEnd:
  7489. END;
  7490.  
  7491. PROCEDURE SaveMove(VAR source; VAR dest; size:LONGWORD);ASSEMBLER;
  7492. ASM
  7493.         PUSH EAX
  7494.         PUSH EBX
  7495.         PUSH ECX
  7496.         PUSH EDX
  7497.         PUSH EDI
  7498.         PUSH ESI
  7499.  
  7500.         MOV ESI,$Source
  7501.         MOV EDI,$Dest
  7502.         MOV ECX,$Size
  7503.         CMP ESI,EDI
  7504.         JE !MoveEnd_1
  7505.         JA !MoveForw_1
  7506.         MOV EBX,ESI
  7507.         ADD EBX,ECX
  7508.         CMP EBX,EDI               // test overlapping
  7509.         JBE !MoveForw_1
  7510.  
  7511.         STD
  7512.         ADD ESI,ECX
  7513.         DEC ESI
  7514.         ADD EDI,ECX
  7515.         DEC EDI
  7516.         REP
  7517.         MOVSB
  7518.         CLD
  7519.         JMP !MoveEnd_1
  7520.  
  7521. !MoveForw_1:
  7522.         CLD
  7523.         MOV EDX,ECX
  7524.         SHR ECX,2
  7525.         REP
  7526.         MOVSD
  7527.         MOV ECX,EDX
  7528.         AND ECX,3
  7529.         REP
  7530.         MOVSB
  7531.  
  7532. !MoveEnd_1:
  7533.         POP ESI
  7534.         POP EDI
  7535.         POP EDX
  7536.         POP ECX
  7537.         POP EBX
  7538.         POP EAX
  7539. END;
  7540.  
  7541. PROCEDURE CompareMem(VAR Buf1,Buf2;Size:LONGWORD);
  7542. BEGIN
  7543.      ASM
  7544.         CLD
  7545.         MOV ESI,$Buf1
  7546.         MOV EDI,$Buf2
  7547.         MOV ECX,$Size
  7548.         CLD
  7549.         REP
  7550.         CMPSB
  7551.      END;
  7552. END;
  7553.  
  7554. PROCEDURE FILLCHAR(VAR dest;size:LongWord;value:byte);ASSEMBLER;
  7555.     ASM
  7556.         CLD
  7557.         //Note: Stack is dword aligned !
  7558.         MOV EDI,$Dest      //Destination pointer
  7559.         MOV ECX,$Size      //count
  7560.         CMP ECX,0
  7561.         JE !ex_fillc
  7562.         MOV AL,$Value      //Value
  7563.         MOV AH,AL
  7564.         PUSH AX
  7565.         PUSH AX
  7566.         POP EAX
  7567.  
  7568.         MOV EDX,ECX
  7569.         SHR ECX,2
  7570.         REP
  7571.         STOSD
  7572.         MOV ECX,EDX
  7573.         AND ECX,3
  7574.         REP
  7575.         STOSB
  7576. !ex_fillc:
  7577.      END;
  7578.  
  7579. //Set Support
  7580. ASSEMBLER
  7581.  
  7582. SYSTEM.TestInSet32 PROC NEAR32
  7583.            PUSH EBP
  7584.            MOV EBP,ESP
  7585.  
  7586.            PUSH EAX
  7587.            PUSH EBX
  7588.            PUSH ECX
  7589.            PUSH EDX
  7590.            PUSH ESI
  7591.            PUSH EDI
  7592.  
  7593.            MOV EDI,[EBP+8]   //Set (32 Byte)
  7594.            MOV AX,[EBP+12]   //Byte or char value
  7595.  
  7596.            MOV BX,16
  7597.            XOR EDX,EDX
  7598.            DIV BX            //Calculate Word position
  7599.            SHL AX,1
  7600.            MOVZX EAX,AX
  7601.            ADD EDI,EAX
  7602.            MOV AX,DX         //Bit Position [0..15]
  7603.            SHL AX,1
  7604.            MOVZX EAX,AX
  7605.            MOV EBX,*SetTab_11
  7606.            ADD EBX,EAX
  7607.            MOV AX,[EBX+0]    //Bit value
  7608.            MOV BX,[EDI+0]    //Old Value
  7609.            AND AX,BX
  7610.            CMP AX,0
  7611.            JE !tis1          //not found
  7612.  
  7613.            MOV AX,0          //test successful
  7614.            CMP AX,0
  7615.  
  7616.            POP EDI
  7617.            POP ESI
  7618.            POP EDX
  7619.            POP ECX
  7620.            POP EBX
  7621.            POP EAX
  7622.  
  7623.            LEAVE
  7624.            RETN32 8
  7625. !tis1:
  7626.            MOV AX,1          //item not found
  7627.            CMP AX,0
  7628.  
  7629.            POP EDI
  7630.            POP ESI
  7631.            POP EDX
  7632.            POP ECX
  7633.            POP EBX
  7634.            POP EAX
  7635.  
  7636.            LEAVE
  7637.            RETN32 8
  7638. SetTab_11 dw 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768
  7639. SYSTEM.TestInSet32 ENDP
  7640.  
  7641. SYSTEM.SetAssign32 PROC NEAR32
  7642.           PUSH EBP
  7643.           MOV EBP,ESP
  7644.  
  7645.           PUSH EAX
  7646.           PUSH EBX
  7647.           PUSH ECX
  7648.           PUSH EDX
  7649.           PUSH ESI
  7650.           PUSH EDI
  7651.  
  7652.           MOV EDI,[EBP+8]    //Ziel
  7653.           MOV ECX,8
  7654.           MOV EAX,0
  7655.           CLD
  7656.           REP
  7657.           STOSD
  7658.  
  7659.           MOV EDI,[EBP+8]    //Ziel
  7660.           MOV ECX,[EBP+12]   //Parameter count
  7661.           CMP CX,0
  7662.           JE !NSAs           //only clear set
  7663.           MOVZX ECX,CX
  7664.           LEA ESI,[EBP+16]   //Points to first parameter
  7665. !plo:
  7666.           PUSH ECX
  7667.  
  7668.           MOV ECX,[ESI+0]    //Get parameter repeat
  7669.           CMP ECX,0
  7670.           JG !rr4
  7671.           JE !NSAs
  7672.           MOVSX ECX,CX
  7673.           INC ECX
  7674.           SUB ECX,[ESI+4]
  7675.           JLE !NSAs
  7676. !rr4:
  7677.           MOV EAX,[ESI+4]    //Get value of parameter
  7678.           ADD ESI,8          //to next parameter for next loop
  7679. !plo_rep:
  7680.           XOR AH,AH
  7681.           PUSH AX            //store parameter value
  7682.           MOV BX,16
  7683.           XOR EDX,EDX
  7684.           DIV BX             //Calculate Word position
  7685.           SHL AX,1
  7686.           MOVZX EAX,AX
  7687.           ADD EDI,EAX
  7688.           MOV AX,DX          //Bit Position [0..15]
  7689.           SHL AX,1
  7690.           MOVZX EAX,AX
  7691.           MOV EBX,*SetTab
  7692.           ADD EBX,EAX
  7693.           MOV AX,[EBX+0]
  7694.           MOVZX EAX,AX
  7695.           MOV BX,[EDI+0]    //Old Value
  7696.           OR AX,BX
  7697.           MOV [EDI+0],AX    //Store new value
  7698.  
  7699.           MOV EDI,[EBP+8]   //Ziel
  7700.  
  7701.           POP AX            //get parameter repeat
  7702.           INC AX            //next parameter if it is parameter..parameter
  7703.           LOOP !plo_rep
  7704.  
  7705.           POP ECX
  7706.           LOOP !plo         //until all parameters processed
  7707. !NSAs:
  7708.           POP EDI
  7709.           POP ESI
  7710.           POP EDX
  7711.           POP ECX
  7712.           POP EBX
  7713.           POP EAX
  7714.  
  7715.           LEAVE
  7716.           RETN32 8          //Return to caller
  7717. SetTab dw 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768
  7718. SYSTEM.SetAssign32 ENDP
  7719.  
  7720. SYSTEM.SetOr32 PROC NEAR32
  7721.           PUSH EBP
  7722.           MOV EBP,ESP
  7723.  
  7724.           PUSH EAX
  7725.           PUSH EBX
  7726.           PUSH ECX
  7727.           PUSH EDX
  7728.           PUSH ESI
  7729.           PUSH EDI
  7730.  
  7731.           MOV EDI,[EBP+8]   //Ziel
  7732.           MOV ESI,[EBP+12]
  7733.           MOV ECX,8
  7734. !SAndl_1:
  7735.           MOV EAX,[ESI+0]
  7736.           OR EAX,[EDI+0]
  7737.           MOV [EDI+0],EAX
  7738.           ADD ESI,4
  7739.           ADD EDI,4
  7740.           LOOP !SAndl_1
  7741.  
  7742.           POP EDI
  7743.           POP ESI
  7744.           POP EDX
  7745.           POP ECX
  7746.           POP EBX
  7747.           POP EAX
  7748.  
  7749.           LEAVE
  7750.           RETN32 8
  7751. SYSTEM.SetOr32 ENDP
  7752.  
  7753. SYSTEM.TempSetOr32 PROC NEAR32
  7754.            PUSH EBP
  7755.            MOV EBP,ESP
  7756.            SUB ESP,36
  7757.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  7758.  
  7759.            PUSH EAX
  7760.            PUSH EBX
  7761.            PUSH ECX
  7762.            PUSH EDX
  7763.            PUSH ESI
  7764.            PUSH EDI
  7765.  
  7766.            MOV [EBP-36],ESP
  7767.  
  7768.            MOV EDI,[EBP+8]   //Ziel
  7769.            MOV CL,[EBP+12]   //Count
  7770.            MOVZX ECX,CL
  7771.            CMP ECX,0
  7772.            JE !EndSetOr
  7773.            LEA ESI,[EBP+16]  //First Parameter
  7774. !TSAl_1:
  7775.            PUSHL [ESI+4]     //Value
  7776.            MOV EAX,[ESI+0]   //repeat count
  7777.            //CMP EAX,0
  7778.            //JG !rr1
  7779.            //JE !EndSetOr2     //Error
  7780.            //MOVSX EAX,AX
  7781.            //INC EAX
  7782.            //SUB EAX,[ESI+4]
  7783.            //JLE !EndSetOr2     //Error
  7784. !rr1:
  7785.            PUSH EAX          //repeat count
  7786.            ADD ESI,8
  7787.            LOOP !TSAl_1
  7788.  
  7789.            MOV CL,[EBP+12]   //Count
  7790.            MOVZX ECX,CL
  7791.            PUSH ECX
  7792.            LEA EAX,[EBP-32]
  7793.            PUSH EAX
  7794.            CALLN32 SYSTEM.SetAssign32
  7795. !EndSetOr2:
  7796.            MOV EAX,[EBP-36]  //Old ESP
  7797.            MOV ESP,EAX
  7798.  
  7799.            LEA EAX,[EBP-32]
  7800.            PUSH EAX
  7801.            MOV EAX,[EBP+8]   //Ziel
  7802.            PUSH EAX
  7803.            CALLN32 SYSTEM.SetOr32
  7804. !EndSetOr:
  7805.            POP EDI
  7806.            POP ESI
  7807.            POP EDX
  7808.            POP ECX
  7809.            POP EBX
  7810.            POP EAX
  7811.  
  7812.            LEAVE
  7813.            RETN32 8
  7814. SYSTEM.TempSetOr32 ENDP
  7815.  
  7816. SYSTEM.SetAnd32 PROC NEAR32
  7817.           PUSH EBP
  7818.           MOV EBP,ESP
  7819.  
  7820.           PUSH EAX
  7821.           PUSH EBX
  7822.           PUSH ECX
  7823.           PUSH EDX
  7824.           PUSH ESI
  7825.           PUSH EDI
  7826.  
  7827.           MOV EDI,[EBP+8]   //Ziel
  7828.           MOV ESI,[EBP+12]
  7829.           MOV ECX,8
  7830. !SAndl:
  7831.           MOV EAX,[ESI+0]
  7832.           AND EAX,[EDI+0]
  7833.           MOV [EDI+0],EAX
  7834.           ADD ESI,4
  7835.           ADD EDI,4
  7836.           LOOP !SAndl
  7837.  
  7838.           POP EDI
  7839.           POP ESI
  7840.           POP EDX
  7841.           POP ECX
  7842.           POP EBX
  7843.           POP EAX
  7844.  
  7845.           LEAVE
  7846.           RETN32 8
  7847. SYSTEM.SetAnd32 ENDP
  7848.  
  7849. SYSTEM.TempSetAnd32 PROC NEAR32
  7850.            PUSH EBP
  7851.            MOV EBP,ESP
  7852.            SUB ESP,36
  7853.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  7854.  
  7855.            PUSH EAX
  7856.            PUSH EBX
  7857.            PUSH ECX
  7858.            PUSH EDX
  7859.            PUSH ESI
  7860.            PUSH EDI
  7861.  
  7862.            MOV [EBP-36],ESP
  7863.  
  7864.            MOV EDI,[EBP+8]   //Ziel
  7865.            MOV CL,[EBP+12]   //Count
  7866.            MOVZX ECX,CL
  7867.            CMP ECX,0
  7868.            JNE !TSAW
  7869.            MOV EDI,[EBP+8]    //Ziel
  7870.            MOV ECX,8
  7871.            MOV EAX,0
  7872.            CLD
  7873.            REP
  7874.            STOSD
  7875.            JMP !TempSetAndE
  7876. !TSAW:
  7877.            LEA ESI,[EBP+16]  //First Parameter
  7878. !TSAl:
  7879.            PUSHL [ESI+4]     //value
  7880.            MOV EAX,[ESI+0]   //repeat count
  7881.            //CMP EAX,0
  7882.            //JG !rr2
  7883.            //JE !TempSetAndE2  //Error
  7884.            //MOVSX EAX,AX
  7885.            //INC EAX
  7886.            //SUB EAX,[ESI+4]
  7887.            //JLE !TempSetAndE2  //Error
  7888. !rr2:
  7889.            PUSH EAX          //repeat count
  7890.            ADD ESI,8
  7891.            LOOP !TSAl
  7892.  
  7893.            MOV CL,[EBP+12]   //Count
  7894.            MOVZX ECX,CL
  7895.            PUSH ECX
  7896.            LEA EAX,[EBP-32]
  7897.            PUSH EAX
  7898.            CALLN32 SYSTEM.SetAssign32
  7899. !TempSetAndE2:
  7900.            MOV EAX,[EBP-36]  //old ESP
  7901.            MOV ESP,EAX
  7902.  
  7903.            LEA EAX,[EBP-32]
  7904.            PUSH EAX
  7905.            MOV EAX,[EBP+8]   //Ziel
  7906.            PUSH EAX
  7907.            CALLN32 SYSTEM.SetAnd32
  7908. !TempSetAndE:
  7909.            POP EDI
  7910.            POP ESI
  7911.            POP EDX
  7912.            POP ECX
  7913.            POP EBX
  7914.            POP EAX
  7915.  
  7916.            LEAVE
  7917.            RETN32 8
  7918. SYSTEM.TempSetAnd32 ENDP
  7919.  
  7920. SYSTEM.TempSetCompare32 PROC NEAR32
  7921.            PUSH EBP
  7922.            MOV EBP,ESP
  7923.            SUB ESP,36
  7924.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  7925.  
  7926.            PUSH EAX
  7927.            PUSH EBX
  7928.            PUSH ECX
  7929.            PUSH EDX
  7930.            PUSH ESI
  7931.            PUSH EDI
  7932.  
  7933.            MOV [EBP-36],ESP
  7934.  
  7935.            MOV EDI,[EBP+8]   //Ziel
  7936.            MOV ECX,[EBP+12]  //Count
  7937.            LEA ESI,[EBP+16]  //First Parameter
  7938.            CMP ECX,0         //empty set
  7939.            JNE !TCSAl_2
  7940.  
  7941.            //test empty set
  7942.            MOV EAX,0
  7943.            MOV ECX,8
  7944.            CLD
  7945.            REPE
  7946.            SCASD
  7947.            CMP ECX,0
  7948.            JMP !ex_comp
  7949. !TCSAl_2:
  7950.            PUSHL [ESI+4]     //Value
  7951.            MOV EAX,[ESI+0]
  7952.            //CMP EAX,0
  7953.            //JG !rr3
  7954.            //JE !ex_comp2     //Error
  7955.            //MOVSX EAX,AX
  7956.            //SUB EAX,[ESI+4]
  7957.            //JLE !ex_comp2     //Error
  7958. !rr3:
  7959.            PUSH EAX         //Repeat count
  7960.            ADD ESI,8
  7961.            LOOP !TCSAl_2
  7962.            PUSHL [EBP+12]    //Count
  7963.            LEA EAX,[EBP-32]
  7964.            PUSH EAX
  7965.            CALLN32 SYSTEM.SetAssign32
  7966. !ex_comp2:
  7967.            MOV EAX,[EBP-36]  //old ESP
  7968.            MOV ESP,EAX
  7969.  
  7970.            CLD
  7971.            LEA ESI,[EBP-32]
  7972.            MOV EDI,[EBP+8]
  7973.            MOV ECX,32
  7974.            CLD
  7975.            REP
  7976.            CMPSB
  7977. !ex_comp:
  7978.            POP EDI
  7979.            POP ESI
  7980.            POP EDX
  7981.            POP ECX
  7982.            POP EBX
  7983.            POP EAX
  7984.  
  7985.            LEAVE
  7986.            RETN32 8
  7987. SYSTEM.TempSetCompare32 ENDP
  7988.  
  7989. SYSTEM.NegateSet32 PROC NEAR32
  7990.           PUSH EBP
  7991.           MOV EBP,ESP
  7992.  
  7993.           PUSH EAX
  7994.           PUSH EBX
  7995.           PUSH ECX
  7996.           PUSH EDX
  7997.           PUSH ESI
  7998.           PUSH EDI
  7999.  
  8000.           MOV EDI,[EBP+8]
  8001.           MOV ECX,8
  8002. !NS_l:
  8003.           MOV EAX,[EDI+0]
  8004.           NOT EAX
  8005.           MOV [EDI+0],EAX
  8006.           ADD EDI,4
  8007.           LOOP !NS_l
  8008.  
  8009.           POP EDI
  8010.           POP ESI
  8011.           POP EDX
  8012.           POP ECX
  8013.           POP EBX
  8014.           POP EAX
  8015.  
  8016.           LEAVE
  8017.           RETN32 4
  8018. SYSTEM.NegateSet32 ENDP
  8019.  
  8020. END;
  8021.  
  8022. //************************************************************************
  8023. //
  8024. //
  8025. // VMT and object handling support
  8026. //
  8027. //
  8028. //************************************************************************
  8029.  
  8030. {$IFOPT D-}
  8031. {$D+}
  8032. {$ELSE}
  8033. {$DEFINE WASDEBUG}
  8034. {$ENDIF}
  8035.  
  8036. ASSEMBLER
  8037.  
  8038. SYSTEM.!VMTCall PROC NEAR32
  8039.         MOV EBX,ESP
  8040.         MOV EDI,[EBX+4]
  8041.         MOV EDI,[EDI+0]
  8042.         CMP EDI,0
  8043.         JNE !VmtWeiter
  8044.         MOV EDI,[EBX+4]
  8045.         CMPD [EDI+4],0
  8046.         JNE !VmtConstructor
  8047.         PUSHL 214
  8048.         CALLN32 SYSTEM.RunError
  8049. !VmtConstructor:
  8050.         MOV EDI,[EDI+4]
  8051. !VmtWeiter:
  8052.         LEA EDI,[EDI+EAX*4]
  8053.         JMP [EDI+0]
  8054. SYSTEM.!VMTCall ENDP
  8055.  
  8056. END;
  8057.  
  8058. {$IFNDEF WASDEBUG}
  8059. {$D-}
  8060. {$ENDIF}
  8061.  
  8062. {$UNDEF WASDEBUG}
  8063.  
  8064. //************************************************************************
  8065. //
  8066. //
  8067. // Floating point support
  8068. //
  8069. //
  8070. //************************************************************************
  8071.  
  8072. PROCEDURE SetTrigMode(mode:BYTE);
  8073. BEGIN
  8074.      CASE Mode OF
  8075.         Rad:IsNotRad:=FALSE;
  8076.         Deg:
  8077.         BEGIN
  8078.              ToRad:=0.01745329262;
  8079.              FromRad:=57.29577951;
  8080.              IsNotRad:=TRUE;
  8081.         END;
  8082.         Gra:
  8083.         BEGIN
  8084.              ToRad:=0.01570796327;
  8085.              FromRad:=63.66197724;
  8086.              IsNotRad:=TRUE;
  8087.         END;
  8088.      END; {case}
  8089. END;
  8090.  
  8091.  
  8092. ASSEMBLER
  8093.  
  8094. SYSTEM.!FormatStr PROC NEAR32  //Format in AL, String in EDI
  8095.         //Format the string
  8096.         CMP AL,0
  8097.         JE !LLw47_1
  8098.  
  8099.         MOV AH,[EDI+0]  //Length of string
  8100.         CMP AH,AL
  8101.         JAE !LLw47_1    //No format to do
  8102.  
  8103.         SUB AL,AH       //Calculate spaces to add
  8104.         ADD [EDI+0],AL  //Set length to new value
  8105.         PUSH EDI
  8106.  
  8107.         MOVZX EBX,AH    //old length of string
  8108.         ADD EDI,EBX     //End of string
  8109.  
  8110.         MOVZX EBX,AL    //Count of spaces to add
  8111.         MOV ESI,EDI
  8112.         ADD EDI,EBX     //add count of spaces
  8113.  
  8114.         MOVZX ECX,AH    //Count (Length of string) to ECX
  8115.         INC ECX         //and #0
  8116.  
  8117.         STD             //From backwards
  8118.         REP
  8119.         MOVSB
  8120.  
  8121.         MOV ECX,EBX
  8122.         MOV AL,32       //Space
  8123.  
  8124.         POP EDI         //Pop it
  8125.         PUSH EDI
  8126.         INC EDI
  8127.         CLD
  8128.         REP
  8129.         STOSB
  8130.  
  8131.         POP EDI
  8132.         MOVZXB EAX,[EDI+0]
  8133.         INC EDI
  8134.         ADD EDI,EAX
  8135.         CLD
  8136. !LLw47_1:
  8137.         RETN32
  8138. SYSTEM.!FormatStr ENDP
  8139.  
  8140. SYSTEM.!RadArc PROC NEAR32      //Converts ST(0) to Rad
  8141.        CMPB SYSTEM.IsNotRad,1
  8142.        JNE !!!_l80
  8143.        FLDT SYSTEM.ToRad
  8144.        FMULP ST(1),ST
  8145. !!!_l80:
  8146.        RETN32
  8147. SYSTEM.!RadArc ENDP
  8148.  
  8149. SYSTEM.!NormRad PROC NEAR32     //Converts ST(0) to actual TrigMode
  8150.        CMPB SYSTEM.IsNotRad,1
  8151.        JNE !!!_l81
  8152.        FLDT SYSTEM.FromRad
  8153.        FMULP ST(1),ST
  8154. !!!_l81:
  8155.        RETN32
  8156. SYSTEM.!NormRad ENDP
  8157.  
  8158.  
  8159. SYSTEM.!Calculate PROC NEAR32
  8160. //Input EDI String
  8161. //CX Count
  8162. //Output Value in ST(0)
  8163.          PUSH EBP
  8164.          MOV EBP,ESP
  8165.          SUB ESP,4
  8166.          DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  8167. !!!weiter1:
  8168.          MOV AL,[EDI+0]
  8169.          SUB AL,$3a
  8170.          ADD AL,$0a
  8171.          JNB !!!ex
  8172.          XOR AH,AH
  8173.          MOV [EBP-2],AX
  8174.          FILDD SYSTEM.C10
  8175.          FMULP ST(1),ST
  8176.          FILDW [EBP-2]
  8177.          FADDP ST(1),ST
  8178.          FWAIT
  8179.          INC EDI
  8180.          DEC CX
  8181.          CMP CX,0
  8182.          JE !!!ex
  8183.          JMP !!!weiter1
  8184. !!!ex:
  8185.          LEAVE
  8186.          RETN32
  8187. SYSTEM.!Calculate ENDP
  8188.  
  8189. SYSTEM.!DivTab PROC NEAR32
  8190.         dw 0,0,0,32768,16383,0,0,0             //1
  8191.         dw 0,0,0,40960,16386,0,0,0             //10
  8192.         dw 0,0,0,51200,16389,0,0,0             //100
  8193.         dw 0,0,0,64000,16392,0,0,0             //1000
  8194.         dw 0,0,0,40000,16396,0,0,0             //10^4
  8195.         dw 0,0,0,50000,16399,0,0,0             //10^5
  8196.         dw 0,0,0,62500,16402,0,0,0             //10^6
  8197.         dw 0,0,32768,39062,16406,0,0,0         //10^7
  8198.         dw 0,0,8192,48828,16409,0,0,0          //10^8
  8199. SYSTEM.!DivTab ENDP
  8200.  
  8201. SYSTEM.!Power10Tab PROC NEAR32
  8202.            db 0,0,0,0,0,$20,$bc,$be,$19,$40                  //1.0E+8
  8203.            db 0,0,0,4,$bf,$c9,$1b,$8e,$34,$40                //1.0E+16
  8204.            db $9e,$b5,$70,$2b,$a8,$ad,$c5,$9d,$69,$40        //1.0E+32
  8205.            db $d5,$a6,$cf,$0ff,$49,$1f,$78,$c2,$d3,$40       //1.0E+64
  8206.            db $e0,$8c,$e9,$80,$c9,$47,$ba,$93,$a8,$41        //1.0E+128
  8207.            db $8e,$de,$0f9,$9d,$fb,$eb,$7e,$aa,$51,$43       //1.0E+256
  8208.            db $c7,$91,$0e,$a6,$ae,$a0,$19,$e3,$a3,$46        //1.0E+512
  8209.            db $17,$0c,$75,$81,$86,$75,$76,$c9,$48,$4d        //1.0E+1024
  8210.            db $e5,$5d,$3d,$c5,$5d,$3b,$8b,$9e,$92,$5a        //1.0E+2048
  8211.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  8212. SYSTEM.!Power10Tab ENDP
  8213.  
  8214. SYSTEM.!MaxMulTab PROC NEAR32
  8215.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  8216. SYSTEM.!MaxMulTab ENDP
  8217.  
  8218. SYSTEM.!DivMul10 PROC NEAR32
  8219. //Input: BX Count of divides/mult by 10
  8220. //       AL 0-mult 1-divide
  8221.         MOV CX,BX
  8222.         AND CX,7  //31 only values 0..31
  8223.         MOV ESI,@SYSTEM.!DivTab
  8224.         MOVZX ECX,CX
  8225.         SHL ECX,1
  8226.         SHL ECX,1
  8227.         SHL ECX,1
  8228.         SHL ECX,1
  8229.         ADD ESI,ECX
  8230.         FLDT [ESI+0]   //1..10^32 laden
  8231.         SHR BX,1
  8232.         SHR BX,1
  8233.         SHR BX,1                //divide numbers by 8
  8234.         MOV ESI,@SYSTEM.!Power10Tab
  8235.         CMP BX,0
  8236.         JE !!!process
  8237. !!!Power10:
  8238.         SHR BX,1
  8239.         JNB !!!mm            //until a bit is set
  8240.         FLDT [ESI+0]
  8241.         FMULP ST(1),ST
  8242. !!!mm:
  8243.         ADD ESI,10
  8244.         CMP BX,0
  8245.         JNE !!!Power10
  8246. !!!process:
  8247.         CMP AL,1
  8248.         JNE !!!_mul
  8249.         FDIVP ST(1),ST
  8250.         RETN32
  8251. !!!_mul:
  8252.         FMULP ST(1),ST
  8253.         RETN32
  8254. SYSTEM.!DivMul10 ENDP
  8255.  
  8256. SYSTEM.!Str2Float PROC NEAR32
  8257. //Input EDI  String to convert
  8258. //      CX     Length of this string
  8259. //Output Floating point value in ST(0)
  8260.         PUSH EBP
  8261.         MOV EBP,ESP
  8262.         SUB ESP,6                //for Control word and sign
  8263.         DB $89,$04,$24           //Perform stack probe MOV [ESP],EAX
  8264.  
  8265.         FSTCW [EBP-2]            //Store control word
  8266.         FWAIT
  8267.         FCLEX                    //Clear exceptions
  8268.         FLDCW SYSTEM.FPUControl  //Load control word
  8269.         FWAIT
  8270.         FLDZ                     //Load +0.0
  8271.         MOVB [EBP-4],0           //sign is positive
  8272.         MOVW [EBP-6],0           //count of numbers after point
  8273. !!!again:
  8274.         CMP CX,0                 //String has zero length ?
  8275.         JE !!!Error
  8276.  
  8277.         MOV AL,[EDI+0]        //load character
  8278.         CMP AL,43  //'+'
  8279.         JNE !!!not_plus
  8280.         //Sign '+' was detected
  8281.         INC EDI
  8282.         DEC CX
  8283.         CMP CX,0
  8284.         JE !!!Error
  8285.         JMP !!!weiter
  8286. !!!not_plus:
  8287.         CMP AL,45   //'-'
  8288.         JNE !!!not_minus
  8289.         //Sign '-' was detected
  8290.         MOVB [EBP-4],1 //Sign is negative
  8291.         INC EDI
  8292.         DEC CX
  8293.         CMP CX,0
  8294.         JE !!!Error
  8295.         JMP !!!weiter
  8296. !!!not_minus:
  8297.         CMP AL,32
  8298.         JNE !!!weiter
  8299.         INC EDI
  8300.         DEC CX
  8301.         JMP !!!again
  8302. !!!weiter:
  8303.         CALLN32 SYSTEM.!Calculate   //Calculate numbers before point
  8304.         CMP CX,0
  8305.         JNE !!!a_exp
  8306.         CMPB [EBP-4],1
  8307.         JNE !!!no_exp
  8308.         FCHS
  8309.         FWAIT         //change sign
  8310.         JMP !!!no_exp
  8311. !!!a_exp:
  8312.         //Look for .
  8313.         MOV AL,[EDI+0]
  8314.         CMP AL,'.'
  8315.         JNE !!!Change
  8316.         DEC CX
  8317.         CMP CX,0
  8318.         JE !!!Change
  8319.         INC EDI
  8320.         PUSH CX
  8321.         CALLN32 SYSTEM.!Calculate    //Calculate numbers after point
  8322.         POP BX
  8323.         SUB BX,CX
  8324.         MOV [EBP-6],BX               //Count of numbers after point
  8325. !!!Change:
  8326.         //in ST(0) is now an integer value
  8327.         //[EBP-6] contains the current numbers after the point
  8328.         CMPB [EBP-4],1
  8329.         JNE !!!not_neg
  8330.         FCHS
  8331.         FWAIT         //change sign
  8332. !!!not_neg:
  8333.         //Check for exponent
  8334.         CMP CX,0
  8335.         JE !!!no_exp
  8336.         MOV AL,[EDI+0]
  8337.         CMP AL,'e'
  8338.         JE !!!exp
  8339.         CMP AL,'E'
  8340.         JNE !!!no_exp
  8341. !!!exp:
  8342.         //an exponent was detected
  8343.         INC EDI
  8344.         DEC CX
  8345.         CMP CX,0
  8346.         JE !!!Error
  8347.         FLDZ          //Load +0.0
  8348.         MOVB [EBP-4],0    //sign is positive
  8349.         MOV AL,[EDI+0]
  8350.         CMP AL,'-'
  8351.         JNE !!!no_minus
  8352.         MOVB [EBP-4],1   //sign is negative
  8353.         INC EDI
  8354.         DEC CX
  8355.         CMP CX,0
  8356.         JE !!!Error
  8357.         JMP !!!Calc
  8358. !!!no_minus:
  8359.         CMP AL,43   //'+'
  8360.         JNE !!!calc
  8361.         INC EDI
  8362.         DEC CX
  8363.         CMP CX,0
  8364.         JE !!!Error
  8365. !!!calc:
  8366.         CALLN32 SYSTEM.!Calculate
  8367.         FISTPW SYSTEM.Exponent      //Store integer value and pop
  8368.         MOV BX,SYSTEM.Exponent
  8369.         MOV AL,0                    //Mult
  8370.         CMPB [EBP-4],1
  8371.         JNE !!!make
  8372.         MOV AL,1                    //Divide if Exponent negative
  8373. !!!make:
  8374.         PUSH CX
  8375.         CALLN32 SYSTEM.!DivMul10
  8376.         POP CX
  8377. !!!no_exp:
  8378.         CMP CX,0
  8379.         JNE !!!Error                //invalid chars
  8380.         MOV BX,[EBP-6]
  8381.         MOV AL,1                    //Divide
  8382.         CALLN32 SYSTEM.!DivMul10
  8383.         JMP !!!ok
  8384. !!!Error:
  8385.         MOVW SYSTEM.IoResult,1      //FPU error
  8386. !!!ok:
  8387.         LEAVE
  8388.         RETN32
  8389. SYSTEM.!Str2Float ENDP
  8390.  
  8391. SYSTEM.!Str2Real PROC NEAR32
  8392.        PUSH EBP
  8393.        MOV EBP,ESP
  8394.  
  8395.        MOV EDI,[EBP+16]
  8396.        MOV CL,[EDI+0]
  8397.        INC EDI
  8398.        XOR CH,CH
  8399.        CALLN32 SYSTEM.!Str2Float
  8400.        MOV EDI,[EBP+12]
  8401.        FSTPD [EDI+0]
  8402.  
  8403.        MOV EDI,[EBP+8]      //Result
  8404.        MOVW [EDI+0],0
  8405.        CMPW SYSTEM.FPUResult,0
  8406.        JE !!__fex1
  8407.        MOVW [EDI+0],1
  8408. !!__fex1:
  8409.        LEAVE
  8410.        RETN32 12
  8411. SYSTEM.!Str2Real ENDP
  8412.  
  8413. SYSTEM.!Str2Double PROC NEAR32
  8414.        PUSH EBP
  8415.        MOV EBP,ESP
  8416.  
  8417.        MOV EDI,[EBP+16]
  8418.        MOV CL,[EDI+0]
  8419.        INC EDI
  8420.        XOR CH,CH
  8421.        CALLN32 SYSTEM.!Str2Float
  8422.        MOV EDI,[EBP+12]
  8423.        FSTPQ [EDI+0]
  8424.  
  8425.        MOV EDI,[EBP+8]     //Result
  8426.        MOVW [EDI+0],0
  8427.        CMPW SYSTEM.FPUResult,0
  8428.        JE !!__fex11
  8429.        MOVW [EDI+0],1
  8430. !!__fex11:
  8431.        LEAVE
  8432.        RETN32 12
  8433. SYSTEM.!Str2Double ENDP
  8434.  
  8435. SYSTEM.!Str2Extended PROC NEAR32
  8436.        PUSH EBP
  8437.        MOV EBP,ESP
  8438.  
  8439.        MOV EDI,[EBP+16]
  8440.        MOV CL,[EDI+0]
  8441.        INC EDI
  8442.        XOR CH,CH
  8443.        CALLN32 SYSTEM.!Str2FLoat
  8444.        MOV EDI,[EBP+12]
  8445.        FSTPT [EDI+0]
  8446.  
  8447.        MOV EDI,[EBP+8]   //Result
  8448.        MOVW [EDI+0],0
  8449.        CMPW SYSTEM.FPUResult,0
  8450.        JE !!__fex111
  8451.        MOVW [EDI+0],1
  8452. !!__fex111:
  8453.        LEAVE
  8454.        RETN32 12
  8455. SYSTEM.!Str2Extended ENDP
  8456.  
  8457. SYSTEM.!ValReal PROC NEAR32
  8458.         //Input EDI : Destination String
  8459.         //AX Kommastellen
  8460.         //BX Len oder 17h
  8461.         //Floatvalue in ST(0)
  8462.         PUSH EBP
  8463.         MOV EBP,ESP
  8464.         SUB ESP,264
  8465.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  8466. $result EQU [EBP-256]
  8467. $len    EQU [EBP-258]
  8468. $comma  EQU [EBP-260]
  8469. $s      EQU [EBP-264]
  8470.  
  8471.         MOV $comma,AX
  8472.         CMP BX,0
  8473.         JA !!6666
  8474.         MOV BX,1
  8475. !!6666:
  8476.         CMP BX,254    //$17
  8477.         JB !!6666_1
  8478.         MOV BX,$17
  8479. !!6666_1:
  8480.         MOV $len,BX
  8481.         MOV $s,EDI
  8482.  
  8483.         MOV CX,$comma
  8484.         OR CX,CX
  8485.         JNS !!37ea
  8486.         MOV CX,8
  8487.         SUB CX,$len
  8488.         CMP CX,$0FFFE
  8489.         JLE !!37ea
  8490.         MOV CX,$0FFFE
  8491. !!37ea:
  8492.         LEA EDI,$result
  8493.         CALLN32 SYSTEM.!Real2Str1  //Get string in EDI and length in CX
  8494.  
  8495.         MOV ESI,EDI
  8496.         MOV EDI,$s
  8497.         MOV DX,255
  8498.         MOV AX,$len
  8499.         CMP AX,CX
  8500.         JNL !!3812
  8501.         MOV AX,CX
  8502. !!3812:
  8503.         CLD
  8504.         STOSB
  8505.         SUB AX,CX
  8506.         JE !!3820
  8507.         PUSH CX
  8508.         MOVZX ECX,AX
  8509.         MOV AL,$20
  8510.         REP
  8511.         STOSB
  8512.         POP CX
  8513. !!3820:
  8514.         MOVZX ECX,CX
  8515.         REP
  8516.         MOVSB
  8517.  
  8518.         LEAVE
  8519.         RETN32
  8520. SYSTEM.!ValReal ENDP
  8521.  
  8522. SYSTEM.!!!!!Help1 PROC NEAR32
  8523.         FWAIT
  8524.         FSTCW [EBP-2]
  8525.         FWAIT
  8526.         FCLEX
  8527.         FLDCW SYSTEM.FpuControl
  8528.         FWAIT
  8529.         FSTPT [EBP-$14]
  8530.  
  8531.         XOR EDX,EDX
  8532.         CMP CX,$12
  8533.         JLE !!311a
  8534.         MOV CX,$12
  8535. !!311a:
  8536.         CMP CX,$0FFEE
  8537.         JNL !!3122
  8538.         MOV CX,$0FFEE
  8539. !!3122:
  8540.         RETN32
  8541. SYSTEM.!!!!!Help1 ENDP
  8542.  
  8543. SYSTEM.!!!!!Help2 PROC NEAR32
  8544.         MOV [EBP-$0c],AX
  8545.         FLDT [EBP-$14]
  8546.         SUB AX,$3FFF
  8547.         XOR EDX,EDX
  8548.         MOV DX,$4D10
  8549.         IMUL DX
  8550.         MOV [EBP-8],DX
  8551.         MOV AX,$11
  8552.         SUB AX,DX
  8553.         CALLN32 SYSTEM.!Div_Mul10
  8554.         FRNDINT
  8555.         MOV ESI,*Tabx1
  8556.         FLDT [ESI+0]
  8557.         FCOMP ST(1)
  8558.         FSTSW [EBP-4]
  8559.         FWAIT
  8560.         RETN32
  8561. Tabx1:
  8562.      db 0,0,$40,$76,$3a,$6b,$0b,$de,$3a,$40
  8563. SYSTEM.!!!!!Help2 ENDP
  8564.  
  8565. SYSTEM.!!!!!Help3 PROC NEAR32
  8566.         MOV AL,$45
  8567.         STOSB
  8568.         MOV AL,$2b
  8569.         MOV DX,[EBP-8]
  8570.         OR DX,DX
  8571.         JNS !!3280
  8572.         MOV AL,$2d
  8573.         NEG DX
  8574. !!3280:
  8575.         STOSB
  8576.         MOV EAX,$640a
  8577.         XCHG DX,AX
  8578.         DIV DH
  8579.         MOV DH,AH
  8580.         DB $66
  8581.         CBW
  8582.         DIV DL
  8583.         ADD AX,$3030
  8584.         STOSW
  8585.         MOV AL,DH
  8586.         DB $66
  8587.         CBW
  8588.         DIV DL
  8589.         ADD AX,$3030
  8590.         STOSW
  8591.         RETN32
  8592. SYSTEM.!!!!!Help3 ENDP
  8593.  
  8594. SYSTEM.!Real2Str1 PROC NEAR32
  8595.         PUSH EBP
  8596.         MOV EBP,ESP
  8597.         SUB ESP,$28
  8598.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  8599.  
  8600.         PUSH EDI
  8601.         CALLN32 SYSTEM.!!!!!Help1
  8602.  
  8603.         CLD
  8604.         NOP
  8605.         FWAIT
  8606.         MOV [EBP-6],CX
  8607.         MOV AX,[EBP-$0c]
  8608.         MOV [EBP-$0a],AX
  8609.         AND AX,$7FFF
  8610.         JE !!315c
  8611.         CMP AX,$7FFF
  8612.         JNE !!3165
  8613.         CMPW [EBP-$0e],$8000
  8614.         JE !!3149
  8615.         MOV AX,$414e
  8616.         STOSW
  8617.         MOV AL,$4e
  8618.         STOSB
  8619.         JMP !!3299
  8620. !!3149:
  8621.         CMPW [EBP-$0a],0
  8622.         JNS !!3152
  8623.         MOV AL,$2d
  8624.         STOSB
  8625. !!3152:
  8626.         MOV AX,$4e49
  8627.         STOSW
  8628.         MOV AL,$46
  8629.         STOSB
  8630.         JMP !!3299
  8631. !!315c:
  8632.         MOV [EBP-8],AX
  8633.         MOV [EBP-$28],AL
  8634.         JMP !!3216
  8635. !!3165:
  8636.         CALLN32 SYSTEM.!!!!!Help2
  8637.         TESTW [EBP-4],$4100
  8638.         JE !!31a1
  8639.         INCW [EBP-8]
  8640.         FILDD SYSTEM.C10
  8641.         FDIVP ST(1),ST
  8642. !!31a1:
  8643.         PUSH EBP
  8644.         POP ESI
  8645.         FBSTPT [ESI-$14]
  8646.         MOV ESI,9
  8647.         LEA EBX,[EBP-$28]
  8648.         MOV CL,4
  8649.         FWAIT
  8650. !!31af:
  8651.         PUSH EDI
  8652.         LEA EDI,[EBP-$15]
  8653.         ADD EDI,ESI
  8654.         MOV AL,[EDI+0]
  8655.         POP EDI
  8656.         MOV AH,AL
  8657.         SHR AL,CL
  8658.         AND AH,$0F
  8659.         ADD AX,$3030
  8660.         MOV [EBX+0],AX
  8661.         ADD EBX,2
  8662.         DEC ESI
  8663.         JNE !!31af
  8664.  
  8665.         MOV [EBX+0],SI
  8666.         CMPW [EBP-6],0
  8667.         JL !!31d8
  8668.         CMPW [EBP-8],$24
  8669.         JL !!31d8
  8670.         MOVW [EBP-6],$0FFEE
  8671. !!31d8:
  8672.         MOV SI,[EBP-6]
  8673.         OR SI,SI
  8674.         JS !!31eb
  8675.         ADD SI,[EBP-8]
  8676.         INC SI
  8677.         JNS !!31ed
  8678.         MOVB [EBP-$28],0
  8679.         JMP !!3216
  8680. !!31eb:
  8681.         NEG SI
  8682. !!31ed:
  8683.         CMP SI,$12
  8684.         JNB !!3216
  8685.  
  8686.         MOVZX ESI,SI
  8687.         PUSH EDI
  8688.         LEA EDI,[EBP-$28]
  8689.         ADD EDI,ESI
  8690.         CMPB [EDI+0],$35
  8691.         MOVB [EDI+0],0
  8692.         POP EDI
  8693.         JB !!3216
  8694. !!31fc:
  8695.         DEC SI
  8696.         JS !!320e
  8697.         MOVZX ESI,SI
  8698.         PUSH EDI
  8699.         LEA EDI,[EBP-$28]
  8700.         ADD EDI,ESI
  8701.         INCB [EDI+0]
  8702.         CMPB [EDI+0],$39
  8703.         POP EDI
  8704.         JBE !!3216
  8705.  
  8706.         PUSH EDI
  8707.         LEA EDI,[EBP-$28]
  8708.         ADD EDI,ESI
  8709.         MOVB [EDI+0],0
  8710.         POP EDI
  8711.         JMP !!31fc
  8712. !!320e:
  8713.         INCW [EBP-8]
  8714.         MOVW [EBP-$28],$31
  8715. !!3216:
  8716.         XOR ESI,ESI
  8717.         MOV DX,[EBP-6]
  8718.         OR DX,DX
  8719.         JS !!3254
  8720.         CMPW [EBP-$0a],0
  8721.         JNS !!3228
  8722.         MOV AL,$2d
  8723.         STOSB
  8724. !!3228:
  8725.         MOV CX,[EBP-8]
  8726.         OR CX,CX
  8727.         JNS !!3234
  8728.         MOV AL,$30
  8729.         STOSB
  8730.         JMP !!323b
  8731. !!3234:
  8732.         PUSH EDI
  8733.         MOVZX ESI,SI
  8734.         LEA EDI,[EBP-$28]
  8735.         ADD EDI,ESI
  8736.         MOV AL,[EDI+0]
  8737.         INC SI
  8738.         POP EDI
  8739.         OR AL,AL
  8740.         JNE !!32b6
  8741.         MOV AL,$30
  8742.         DEC SI
  8743. !!32b6:
  8744.         STOSB
  8745.         DEC CX
  8746.         JNS !!3234
  8747. !!323b:
  8748.         OR DX,DX
  8749.         JE !!3299
  8750.         MOV AL,$2e
  8751.         STOSB
  8752. !!3242:
  8753.         INC CX
  8754.         JE !!324b
  8755. !!3245:
  8756.         MOV AL,$30
  8757.         STOSB
  8758.         DEC DX
  8759.         JNE !!3242
  8760. !!324b:
  8761.         DEC DX
  8762.         JS !!3299
  8763.         PUSH EDI
  8764.         MOVZX ESI,SI
  8765.         LEA EDI,[EBP-$28]
  8766.         ADD EDI,ESI
  8767.         MOV AL,[EDI+0]
  8768.         INC SI
  8769.         POP EDI
  8770.         OR AL,AL
  8771.         JNE !!32b6_1a
  8772.         MOV AL,$30
  8773.         DEC SI
  8774. !!32b6_1a:
  8775.         STOSB
  8776.         JMP !!324b
  8777. !!3254:
  8778.         MOV AL,$20
  8779.         CMPW [EBP-$0a],0
  8780.         JNS !!325e
  8781.         MOV AL,$2d
  8782. !!325e:
  8783.         STOSB
  8784.         PUSH EDI
  8785.         MOVZX ESI,SI
  8786.         LEA EDI,[EBP-$28]
  8787.         ADD EDI,ESI
  8788.         INC SI
  8789.         MOV AL,[EDI+0]
  8790.         POP EDI
  8791.         OR AL,AL
  8792.         JNE !!32b6_1b
  8793.         MOV AL,$30
  8794.         DEC SI
  8795. !!32b6_1b:
  8796.         STOSB
  8797.         INC DX
  8798.         JE !!3270
  8799.         MOV AL,$2e
  8800.         STOSB
  8801. !!3269:
  8802.         PUSH EDI
  8803.         MOVZX ESI,SI
  8804.         LEA EDI,[EBP-$28]
  8805.         ADD EDI,ESI
  8806.         INC SI
  8807.         MOV AL,[EDI+0]
  8808.         POP EDI
  8809.         OR AL,AL
  8810.         JNE !!32b6_1c
  8811.         MOV AL,$30
  8812.         DEC SI
  8813. !!32b6_1c:
  8814.         STOSB
  8815.         INC DX
  8816.         JNE !!3269
  8817. !!3270:
  8818.         CALLN32 SYSTEM.!!!!!Help3
  8819. !!3299:
  8820.         MOV ECX,EDI
  8821.         POP EDI
  8822.         SUB ECX,EDI
  8823.         FCLEX            //Clear Exceptions
  8824.         FLDCW [EBP-2]
  8825.         FWAIT
  8826.  
  8827.         LEAVE
  8828.         RETN32
  8829. {*Tab1:
  8830.      db 0,0,40h,76h,3ah,6bh,0bh,deh,3ah,40h}
  8831. SYSTEM.!Real2Str1 ENDP
  8832.  
  8833.  
  8834. SYSTEM.!Div_Mul10 PROC NEAR32
  8835.         CMP AX,$1000
  8836.         JLE !!3382
  8837.         PUSH ESI
  8838.         MOV ESI,@SYSTEM.!MaxMulTab
  8839.         FLDT [ESI+0]
  8840.         POP ESI
  8841.         FMULP ST(1),ST
  8842.         SUB AX,$1000
  8843. !!3382:
  8844.         CMP AX,$0F000
  8845.         JNL !!3393
  8846.         PUSH ESI
  8847.         MOV ESI,@SYSTEM.!MaxMulTab
  8848.         FLDT [ESI+0]
  8849.         POP ESI
  8850.         FDIVP ST(1),ST
  8851.         ADD AX,$1000
  8852. !!3393:
  8853.         MOV BX,AX
  8854.         OR AX,AX
  8855.         JE !!33d4
  8856.         JNS !!339d
  8857.         NEG AX
  8858. !!339d:
  8859.         MOV SI,AX
  8860.         AND SI,7
  8861.         MOVZX ESI,SI
  8862.         SHL ESI,1
  8863.         SHL ESI,1
  8864.         SHL ESI,1
  8865.         SHL ESI,1
  8866.         PUSH EDI
  8867.         MOV EDI,@SYSTEM.!DivTab
  8868.         ADD EDI,ESI
  8869.         FLDT [EDI+0]
  8870.         POP EDI
  8871.         SHR AX,1
  8872.         SHR AX,1
  8873.         SHR AX,1
  8874.         MOV ESI,@SYSTEM.!Power10Tab
  8875.         JMP !!33c5
  8876. !!33b7:
  8877.         SHR AX,1
  8878.         JNB !!33c2
  8879.         FLDT [ESI+0]
  8880.         FMULP ST(1),ST
  8881. !!33c2:
  8882.         ADD ESI,10
  8883. !!33c5:
  8884.         OR AX,AX
  8885.         JNE !!33b7
  8886.         OR BX,BX
  8887.         JS !!33d1
  8888.         FMULP ST(1),ST
  8889. !!33d0:
  8890.         RETN32
  8891. !!33d1:
  8892.         FDIVP ST(1),ST
  8893. !!33d4:
  8894.         RETN32
  8895. SYSTEM.!Div_Mul10 ENDP
  8896.  
  8897.  
  8898. SYSTEM.!Real2Str PROC NEAR32  //Format in [EBP+16]
  8899.         PUSH EBP
  8900.         MOV EBP,ESP
  8901.  
  8902.         PUSH EDI
  8903.         PUSH ESI
  8904.  
  8905.         MOV EDI,[EBP+12]
  8906.         FLDD [EDI+0]        //Load real value
  8907.         MOV EDI,[EBP+8]
  8908.         MOV EAX,[EBP+16]    //Nachkommastellen  (FFFFh alle)
  8909.         MOVZXB EBX,[EBP+20] //Format value
  8910.         CALLN32 SYSTEM.!ValReal
  8911.  
  8912.         MOV AL,[EBP+20]    //Format value
  8913.         MOV EDI,[EBP+8]
  8914.         CALLN32 SYSTEM.!FormatStr
  8915.  
  8916.         POP ESI
  8917.         POP EDI
  8918.  
  8919.         LEAVE
  8920.         RETN32 12
  8921. SYSTEM.!Real2Str ENDP
  8922.  
  8923. SYSTEM.!Double2Str PROC NEAR32  //Format in [EBP+16]
  8924.         PUSH EBP
  8925.         MOV EBP,ESP
  8926.  
  8927.         PUSH EDI
  8928.         PUSH ESI
  8929.  
  8930.         MOV EDI,[EBP+12]
  8931.         FLDQ [EDI+0]        //Load double value
  8932.         MOV EDI,[EBP+8]
  8933.         MOV EAX,[EBP+16]    //Nachkommastellen (FFFFh alle)
  8934.         MOV EBX,[EBP+20]    //Format value
  8935.         CALLN32 SYSTEM.!ValReal
  8936.  
  8937.         MOV AL,[EBP+20]     //Format value
  8938.         MOV EDI,[EBP+8]
  8939.         CALLN32 SYSTEM.!FormatStr
  8940.  
  8941.         POP ESI
  8942.         POP EDI
  8943.  
  8944.         LEAVE
  8945.         RETN32 12
  8946. SYSTEM.!Double2Str ENDP
  8947.  
  8948. SYSTEM.!Extended2Str PROC NEAR32  //Format in [EBP+16]
  8949.         PUSH EBP
  8950.         MOV EBP,ESP
  8951.  
  8952.         PUSH EDI
  8953.         PUSH ESI
  8954.  
  8955.         MOV EDI,[EBP+12]
  8956.         FLDT [EDI+0]       //Load extended value
  8957.         MOV EDI,[EBP+8]
  8958.         MOV EAX,[EBP+16]   //Nachkommastellen (FFFFh alle)
  8959.         MOV EBX,[EBP+20]   //Format value
  8960.         CALLN32 SYSTEM.!ValReal
  8961.  
  8962.         MOV AL,[EBP+20]    //Format value
  8963.         MOV EDI,[EBP+8]
  8964.         CALLN32 SYSTEM.!FormatStr
  8965.  
  8966.         POP ESI
  8967.         POP EDI
  8968.  
  8969.         LEAVE
  8970.         RETN32 16
  8971. SYSTEM.!Extended2Str ENDP
  8972.  
  8973. SYSTEM.!WriteExtended PROC NEAR32   //Writes extended in ST
  8974.           PUSH EBP
  8975.           MOV EBP,ESP
  8976.           SUB ESP,260
  8977.           DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  8978.           FSTPT [EBP-260]
  8979.  
  8980.           PUSHL [EBP+12]     //Format
  8981.           PUSHL [EBP+8]      //Nachkommas
  8982.           LEA EAX,[EBP-260]
  8983.           PUSH EAX
  8984.           LEA EAX,[EBP-250]
  8985.           PUSH EAX
  8986.           CALLN32 SYSTEM.!Extended2Str
  8987.  
  8988.           LEA EAX,[EBP-250]
  8989.           PUSH EAX
  8990.           PUSHL 0                //[EBP+8]  ???     //Format value
  8991.           CALLN32 SYSTEM.StrWrite
  8992.  
  8993.           LEAVE
  8994.           RETN32 8
  8995. SYSTEM.!WriteExtended ENDP
  8996.  
  8997. SYSTEM.!FPULoadLong PROC NEAR32
  8998.             PUSH EBP
  8999.             MOV EBP,ESP
  9000.             FILDD [EBP+8]
  9001.             LEAVE
  9002.             RETN32 4
  9003. SYSTEM.!FPULoadLong ENDP
  9004.  
  9005.  
  9006. SYSTEM.!Sin PROC NEAR32   //calculate SIN in ST(0)
  9007.     CALLN32 SYSTEM.!RadArc
  9008.     FSIN
  9009.     RETN32
  9010. SYSTEM.!Sin ENDP
  9011.  
  9012. SYSTEM.!Cos PROC NEAR32   //calculate COS in ST(0)
  9013.     CALLN32 SYSTEM.!RadArc
  9014.     FCOS
  9015.     RETN32
  9016. SYSTEM.!Cos ENDP
  9017.  
  9018. SYSTEM.!Tan PROC NEAR32
  9019.        PUSH EBP
  9020.        MOV EBP,ESP
  9021.        SUB ESP,12
  9022.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9023.        PUSH EAX
  9024.  
  9025.        MOVW SYSTEM.FPUResult,0
  9026.        FSTPT [EBP-10]
  9027.        FLDT [EBP-10]
  9028.        CALLN32 SYSTEM.!Sin
  9029.        FLDT [EBP-10]
  9030.        CALLN32 SYSTEM.!Cos
  9031.        FTST
  9032.        FSTSW [EBP-12]
  9033.        FWAIT
  9034.        MOV AH,[EBP-11]
  9035.        SAHF
  9036.        JNE !!!_l50
  9037.        FSTP ST(0)
  9038.        FSTP ST(0)
  9039.        FLDZ
  9040.        MOVW SYSTEM.FPUResult,2
  9041.        JMP !!!_l51
  9042. !!!_l50:
  9043.        FDIVP ST(1),ST
  9044. !!!_l51:
  9045.        POP EAX
  9046.        LEAVE
  9047.        RETN32
  9048. SYSTEM.!Tan ENDP
  9049.  
  9050. SYSTEM.!Cot PROC NEAR32
  9051.        PUSH EBP
  9052.        MOV EBP,ESP
  9053.        SUB ESP,12
  9054.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9055.        PUSH EAX
  9056.  
  9057.        MOVW SYSTEM.FPUResult,0
  9058.        FSTPT [EBP-10]
  9059.        FLDT [EBP-10]
  9060.        CALLN32 SYSTEM.!Cos
  9061.        FLDT [EBP-10]
  9062.        CALLN32 SYSTEM.!Sin
  9063.        FTST
  9064.        FSTSW [EBP-12]
  9065.        FWAIT
  9066.        MOV AH,[EBP-11]
  9067.        SAHF
  9068.        JNE !!!_l53
  9069.        FSTP ST(0)
  9070.        FSTP ST(0)
  9071.        FLDZ
  9072.        MOVW SYSTEM.FPUResult,2
  9073.        JMP !!!_l54
  9074. !!!_l53:
  9075.        FDIVP ST(1),ST
  9076. !!!_l54:
  9077.        POP EAX
  9078.        LEAVE
  9079.        RETN32
  9080. SYSTEM.!Cot ENDP
  9081.  
  9082. SYSTEM.!ArcTan PROC NEAR32
  9083.        PUSH EBP
  9084.        MOV EBP,ESP
  9085.        SUB ESP,4
  9086.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9087.        PUSH EAX
  9088.        PUSH ECX
  9089.  
  9090.        MOVW SYSTEM.FPUResult,0
  9091.        FXAM             //Type of ST(0)
  9092.        FWAIT
  9093.        FSTSW [EBP-2]
  9094.        MOV AH,[EBP-1]
  9095.        SAHF
  9096.        XCHG CX,AX
  9097.        JB !!!_l30
  9098.        JNE !!!_l31
  9099.        JMP !!!_l32
  9100. !!!_l30:
  9101.        JE !!!_l32
  9102.        JNP !!!_l32
  9103.        FSTP ST(0)
  9104.        FLDT SYSTEM.fl3
  9105.        JMP !!!_l33
  9106. !!!_l31:
  9107.        FABS
  9108.        FLD1
  9109.        FCOM ST(1)
  9110.        FWAIT
  9111.        FSTSW [EBP-2]
  9112.        MOV AH,[EBP-1]
  9113.        SAHF
  9114.        JNE !!!_l34
  9115.        FCOMPP
  9116.        FLDT SYSTEM.fl2
  9117.        JMP !!!_l33
  9118. !!!_l34:
  9119.        JNB !!!_l35
  9120.        FXCH ST(1)
  9121. !!!_l35:
  9122.        FPATAN
  9123.        JNB !!!_l33
  9124.        FLDT SYSTEM.fl3
  9125.        FSUBP ST(1),ST
  9126.        XOR CH,2
  9127. !!!_l33:
  9128.        TEST CH,2
  9129.        JE !!!_l32
  9130.        FCHS
  9131.        FWAIT
  9132. !!!_l32:
  9133.        CALLN32 SYSTEM.!NormRad
  9134.        POP ECX
  9135.        POP EAX
  9136.        LEAVE
  9137.        RETN32
  9138. SYSTEM.!ArcTan ENDP
  9139.  
  9140. SYSTEM.!Sqrt PROC NEAR32
  9141.        FSQRT
  9142.        RETN32
  9143. SYSTEM.!Sqrt ENDP
  9144.  
  9145. SYSTEM.!ln PROC NEAR32
  9146.       PUSH EBP
  9147.       MOV EBP,ESP
  9148.       SUB ESP,10
  9149.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9150.       PUSH EAX
  9151.  
  9152.       MOVW SYSTEM.FPUResult,0
  9153.       FLDLN2
  9154.       FXCH ST(1)
  9155.       FXAM
  9156.       FWAIT
  9157.       FSTSW [EBP-10]
  9158.       MOV AH,[EBP-9]
  9159.       SAHF
  9160.       JB !!!_l20
  9161.       JE !!!_l21
  9162.       TEST AH,2
  9163.       JE !!!_l22
  9164. !!!_l21:
  9165.       FSTP ST(0)
  9166.       JMP !!!_l23
  9167. !!!_l20:
  9168.       FSTP ST(0)
  9169.       JE !!!_l24
  9170.       JNP !!!_l24
  9171. !!!_l23:
  9172.       FSTP ST(0)
  9173.       FLDD SYSTEM.fl1
  9174. !!!_l24:
  9175.       FTST
  9176.       JMP !!!_l29
  9177. !!!_l22:
  9178.       FLD ST(0)
  9179.       FSTPT [EBP-10]
  9180.       CMPW [EBP-2],$3fff
  9181.       JNE !!!_l25
  9182.       CMPW [EBP-4],$8000
  9183.       JNE !!!_l25
  9184.       FLD1
  9185.       FSUBP ST(1),ST
  9186.       FYL2XP1
  9187.       JMP !!!_l29
  9188. !!!_l25:
  9189.       FYL2X
  9190. !!!_l29:
  9191.       POP EAX
  9192.       LEAVE
  9193.       RETN32
  9194. SYSTEM.!ln ENDP
  9195.  
  9196. SYSTEM.!Exp PROC NEAR32
  9197.       PUSH EBP
  9198.       MOV EBP,ESP
  9199.       SUB ESP,16
  9200.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9201.       PUSH EAX
  9202.       PUSH EBX
  9203.       PUSH ECX
  9204.  
  9205.       MOVW SYSTEM.FPUResult,0
  9206.       FLDL2E
  9207.       FXCH ST(1)
  9208.       FXAM
  9209.       FWAIT
  9210.       FSTSW [EBP-6]
  9211.       FXCH ST(1)
  9212.       MOV AH,[EBP-5]
  9213.       SAHF
  9214.       XCHG BX,AX
  9215.       JB !!!_l40
  9216.       JNE !!!_l41
  9217.       FSTP ST(0)
  9218.       FSTP ST(0)
  9219.       FLD1
  9220.       JMP !!!_l43
  9221. !!!_l40:
  9222.       FSTP ST(0)
  9223.       JE !!!_l44
  9224.       JNP !!!_l44
  9225. !!!_l48:
  9226.       FSTP ST(0)
  9227.       FLDD SYSTEM.fl4
  9228. !!!_l44:
  9229.       FTST
  9230.       JMP !!!_l43
  9231. !!!_l41:
  9232.       FMULP ST(1),ST
  9233.       FABS
  9234.       FLDD SYSTEM.fl5
  9235.       FXCH ST(1)
  9236.       FSTPT [EBP-16]
  9237.       FLDT [EBP-16]
  9238.       FCOMPP
  9239.       FWAIT
  9240.       FSTSW [EBP-6]
  9241.       FLDT [EBP-16]
  9242.       TESTB [EBP-5],$41
  9243.       JE !!!_l46
  9244.       F2XM1
  9245.       FLD1
  9246.       FADDP ST(1),ST
  9247.       FWAIT
  9248.       JMP !!!_l47
  9249. !!!_l46:
  9250.       FLD1
  9251.       FLD ST(1)
  9252.       FWAIT
  9253.       FSTCW [EBP-6]
  9254.       FSCALE
  9255.       ORB [EBP-5],$0f
  9256.       FLDCW [EBP-6]
  9257.       FWAIT
  9258.       FRNDINT
  9259.       ANDB [EBP-5],$0f3
  9260.       FLDCW [EBP-6]
  9261.       FWAIT
  9262.       FISTD [EBP-4]
  9263.       FXCH ST(1)
  9264.       FCHS
  9265.       FXCH ST(1)
  9266.       FSCALE
  9267.       FSTP ST(1)
  9268.       FSUBP ST(1),ST
  9269.       CMPW [EBP-2],0
  9270.       JG !!!_l48
  9271.       F2XM1
  9272.       FLD1
  9273.       FADDP ST(1),ST
  9274.       FWAIT
  9275.       MOV CX,[EBP-4]
  9276.       SHR CX,1
  9277.       MOV [EBP-4],CX
  9278.       JNB !!!_l49
  9279.       FLDT SYSTEM.fl6
  9280.       FMULP ST(1),ST
  9281. !!!_l49:
  9282.       FILDW [EBP-4]
  9283.       FXCH ST(1)
  9284.       FSCALE
  9285.       FSTP ST(1)
  9286. !!!_l47:
  9287.       TEST BH,2
  9288.       JE !!!_l43
  9289.       FLD1
  9290.       FDIVRP ST(1),ST
  9291. !!!_l43:
  9292.       POP ECX
  9293.       POP EBX
  9294.       POP EAX
  9295.       LEAVE
  9296.       RETN32
  9297. SYSTEM.!Exp ENDP
  9298.  
  9299. SYSTEM.!Frac PROC NEAR32
  9300.       PUSH EBP
  9301.       MOV EBP,ESP
  9302.       SUB ESP,12
  9303.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9304.       FSTPT [EBP-10]
  9305.       FLDT [EBP-10]
  9306.       FCLEX
  9307.       FLDCW SYSTEM.FPURound  //Load control word
  9308.       FWAIT
  9309.       FRNDINT
  9310.       FCLEX
  9311.       FLDCW SYSTEM.FPUControl //Load control word
  9312.       FWAIT
  9313.       FLDT [EBP-10]
  9314.       FXCH ST(1)
  9315.       FSUBP ST(1),ST
  9316.       LEAVE
  9317.       RETN32
  9318. SYSTEM.!Frac ENDP
  9319.  
  9320. SYSTEM.!Int PROC NEAR32
  9321.       FCLEX
  9322.       FLDCW SYSTEM.FPURound  //Load control word
  9323.       FWAIT
  9324.       FRNDINT
  9325.       FCLEX
  9326.       FLDCW SYSTEM.FPUControl //Load control word
  9327.       FWAIT
  9328.       RETN32
  9329. SYSTEM.!Int ENDP
  9330.  
  9331. SYSTEM.!Round PROC NEAR32
  9332.       PUSH EBP
  9333.       MOV EBP,ESP
  9334.       SUB ESP,10
  9335.       DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  9336.  
  9337.       FSTPT [EBP-10]
  9338.       FLDT [EBP-10]
  9339.       CALLN32 SYSTEM.!Frac
  9340.       FLDT [EBP-10]
  9341.       FADDP ST(1),ST
  9342.       CALLN32 SYSTEM.!Trunc
  9343.  
  9344.       LEAVE
  9345.       RETN32
  9346. SYSTEM.!Round ENDP
  9347.  
  9348. SYSTEM.!Trunc PROC NEAR32
  9349.       PUSH EBP
  9350.       MOV EBP,ESP
  9351.       SUB ESP,10
  9352.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9353.       FCLEX
  9354.       FLDCW SYSTEM.FPURound  //Load control word
  9355.       FWAIT
  9356.       FRNDINT
  9357.       FCLEX
  9358.       FLDCW SYSTEM.FPUControl //Load control word
  9359.       FWAIT
  9360.       FISTPD [EBP-10]
  9361.       MOV EAX,[EBP-10]
  9362.       LEAVE
  9363.       RETN32
  9364. SYSTEM.!Trunc ENDP
  9365.  
  9366. SYSTEM.!Sqr PROC NEAR32
  9367.       FLD St(0)
  9368.       FMULP ST(1),ST
  9369.       RETN32
  9370. SYSTEM.!Sqr ENDP
  9371.  
  9372. SYSTEM.!ArcSin PROC NEAR32
  9373.        PUSH EBP
  9374.        MOV EBP,ESP
  9375.        SUB ESP,12
  9376.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9377.        PUSH EAX
  9378.  
  9379.        MOVW SYSTEM.FPUResult,0
  9380.        FLD St(0)
  9381.        FABS
  9382.        FLD1
  9383.        FCOMPP
  9384.        FWAIT
  9385.        FSTSW [EBP-12]
  9386.        MOV AH,[EBP-11]
  9387.        SAHF
  9388.        JB !!!_l60
  9389.        JNE !!!_l62
  9390.        //ArcSin(1.0)=w*pi/2
  9391.        FLDT SYSTEM.fl7    //1.5707...
  9392.        FMULP ST(1),ST
  9393.        JMP !!!_l61
  9394. !!!_l62:
  9395.        FLD St(0)
  9396.        FSTPT [EBP-10]
  9397.        FLD St(0)
  9398.        FMULP ST(1),ST
  9399.        FLD1
  9400.        FSUBP ST(1),ST
  9401.        FSQRT
  9402.        FLDT [EBP-10]
  9403.        FXCH ST(1)
  9404.        FDIVP ST(1),ST
  9405.        CALLN32 SYSTEM.!ArcTan
  9406.        JMP !!!_l61
  9407. !!!_l60:
  9408.        MOVW SYSTEM.FPUResult,3
  9409. !!!_l61:
  9410.        CALLN32 SYSTEM.!NormRad
  9411.        POP EAX
  9412.        LEAVE
  9413.        RETN32
  9414. SYSTEM.!ArcSin ENDP
  9415.  
  9416. SYSTEM.!ArcCos PROC NEAR32
  9417.        MOVW SYSTEM.FPUResult,0
  9418.        CALLN32 SYSTEM.!ArcSin
  9419.        FLDT SYSTEM.fl7   //PI/2
  9420.        FXCH ST(1)
  9421.        FSUBP ST(1),ST
  9422.        CALLN32 SYSTEM.!NormRad
  9423.        RETN32
  9424. SYSTEM.!ArcCos ENDP
  9425.  
  9426. SYSTEM.!ArcCot PROC NEAR32
  9427.        MOVW SYSTEM.FPUResult,0
  9428.        CALLN32 SYSTEM.!ArcTan
  9429.        FLDT SYSTEM.fl7   //PI/2
  9430.        FXCH ST(1)
  9431.        FSUBP ST(1),ST
  9432.        CALLN32 SYSTEM.!NormRad
  9433.        RETN32
  9434. SYSTEM.!ArcCot ENDP
  9435.  
  9436. SYSTEM.!Sinh PROC NEAR32
  9437.        MOVW SYSTEM.FPUResult,0
  9438.        CALLN32 SYSTEM.!Exp
  9439.        FLD St(0)
  9440.        FLD1
  9441.        FXCH ST(1)
  9442.        FDIVP ST(1),ST
  9443.        FXCH ST(1)
  9444.        FSUBP ST(1),ST
  9445.        FLDT SYSTEM.fl8
  9446.        FMULP ST(1),ST
  9447.        RETN32
  9448. SYSTEM.!Sinh ENDP
  9449.  
  9450. SYSTEM.!Cosh PROC NEAR32
  9451.        MOVW SYSTEM.FPUResult,0
  9452.        CALLN32 SYSTEM.!Exp
  9453.        FLD St(0)
  9454.        FLD1
  9455.        FXCH ST(1)
  9456.        FDIVP ST(1),ST
  9457.        FADDP ST(1),ST
  9458.        FWAIT
  9459.        FLDT SYSTEM.fl8
  9460.        FMULP ST(1),ST
  9461.        RETN32
  9462. SYSTEM.!Cosh ENDP
  9463.  
  9464. SYSTEM.!Tanh PROC NEAR32
  9465.        MOVW SYSTEM.FPUResult,0
  9466.        FLDT SYSTEM.fl9   //2.0
  9467.        FMULP ST(1),ST
  9468.        CALLN32 SYSTEM.!Exp
  9469.        FLD1
  9470.        FADDP ST(1),ST
  9471.        FWAIT
  9472.        FLDT SYSTEM.fl9   //2.0
  9473.        FXCH ST(1)
  9474.        FDIVP ST(1),ST
  9475.        FLD1
  9476.        FSUBP ST(1),ST
  9477.        RETN32
  9478. SYSTEM.!Tanh ENDP
  9479.  
  9480. SYSTEM.!Coth PROC NEAR32
  9481.        PUSH EBP
  9482.        MOV EBP,ESP
  9483.        SUB ESP,12
  9484.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9485.        PUSH EAX
  9486.  
  9487.        MOVW SYSTEM.FPUResult,0
  9488.        FLD St(0)
  9489.        FSTPT [EBP-10]
  9490.        CALLN32 SYSTEM.!Sinh
  9491.        FTST
  9492.        FWAIT
  9493.        FSTSW [EBP-12]
  9494.        MOV AH,[EBP-11]
  9495.        SAHF
  9496.        JE !!!_l70
  9497.        FLDT [EBP-10]
  9498.        CALLN32 SYSTEM.!Cosh
  9499.        FXCH ST(1)
  9500.        FDIVP ST(1),ST
  9501.        JMP !!!_l71
  9502. !!!_l70:
  9503.        MOVW SYSTEM.FPUResult,4
  9504. !!!_l71:
  9505.        POP EAX
  9506.        LEAVE
  9507.        RETN32
  9508. SYSTEM.!Coth ENDP
  9509.  
  9510. SYSTEM.!lg PROC NEAR32
  9511.        MOVW SYSTEM.FPUResult,0
  9512.        CALLN32 SYSTEM.!ln
  9513.        FLDT SYSTEM.fl10
  9514.        FDIVP ST(1),ST
  9515.        RETN32
  9516. SYSTEM.!lg ENDP
  9517.  
  9518. SYSTEM.!lb PROC NEAR32
  9519.        MOVW SYSTEM.FPUResult,0
  9520.        CALLN32 SYSTEM.!ln
  9521.        FLDT SYSTEM.fl11
  9522.        FDIVP ST(1),ST
  9523.        RETN32
  9524. SYSTEM.!lb ENDP
  9525.  
  9526. SYSTEM.!ReadReal PROC NEAR32
  9527.        PUSH EBP
  9528.        MOV EBP,ESP
  9529.        SUB ESP,262
  9530.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9531.        LEA EAX,[EBP-260]
  9532.        PUSH EAX
  9533.        CALLN32 SYSTEM.StrRead
  9534.        LEA EAX,[EBP-260]
  9535.        PUSH EAX
  9536.        PUSHL [EBP+8]
  9537.        LEA EAX,[EBP-262]
  9538.        PUSH EAX
  9539.        CALLN32 SYSTEM.!Str2Real
  9540.        LEAVE
  9541.        RETN32 4
  9542. SYSTEM.!ReadReal ENDP
  9543.  
  9544. SYSTEM.!ReadDouble PROC NEAR32
  9545.        PUSH EBP
  9546.        MOV EBP,ESP
  9547.        SUB ESP,262
  9548.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9549.        LEA EAX,[EBP-260]
  9550.        PUSH EAX
  9551.        CALLN32 SYSTEM.StrRead
  9552.        LEA EAX,[EBP-260]
  9553.        PUSH EAX
  9554.        PUSHL [EBP+8]
  9555.        LEA EAX,[EBP-262]
  9556.        PUSH EAX
  9557.        CALLN32 SYSTEM.!Str2Double
  9558.        LEAVE
  9559.        RETN32 4
  9560. SYSTEM.!ReadDouble ENDP
  9561.  
  9562. SYSTEM.!ReadExtended PROC NEAR32
  9563.        PUSH EBP
  9564.        MOV EBP,ESP
  9565.        SUB ESP,262
  9566.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  9567.        LEA EAX,[EBP-260]
  9568.        PUSH EAX
  9569.        CALLN32 SYSTEM.StrRead
  9570.        LEA EAX,[EBP-260]
  9571.        PUSH EAX
  9572.        PUSHL [EBP+8]
  9573.        LEA EAX,[EBP-262]
  9574.        PUSH EAX
  9575.        CALLN32 SYSTEM.!Str2Extended
  9576.        LEAVE
  9577.        RETN32 4
  9578. SYSTEM.!ReadExtended ENDP
  9579.  
  9580. END;
  9581.  
  9582. ASSEMBLER
  9583.  
  9584. SYSTEM.!ParaInfo PROC NEAR32  //(AL=Function - 1 count of parameters to CL
  9585.                               //               2 Pointer to parameter CL to ESI
  9586.                               //Input:argument start in ESI
  9587.          MOV BX,0      //we start with parameter 0
  9588.          CMP AL,2      //get parameter name ?
  9589.          JNE !no_name
  9590.          PUSH ESI
  9591.          CMP CL,0      //parameter 0 required ?
  9592.          JE !no_args
  9593.          POP ESI
  9594. !no_name:
  9595.          //Overread the EXE file name
  9596.          CLD
  9597.          PUSH AX
  9598. !rrloop:
  9599.          LODSB
  9600.          CMP AL,0
  9601.          JNE !rrloop
  9602.          POP AX
  9603.  
  9604.          CMP AL,2   //get parameter name ?
  9605.          JE !get_argname
  9606.          MOV CL,255 //impossible parameter
  9607. !get_argname:
  9608.          XOR CH,CH
  9609.          MOV BX,1      //now finally we start with parameter 1
  9610.  
  9611.          LODSB
  9612.          //check whether the first character is a separator
  9613.          CMP AL,' '
  9614.          JE !aagain
  9615.          CMP AL,0   //is this already the end -->Urrgh !
  9616.          JNE !al2
  9617.          PUSHL 0    //The (nonexistent) parameters -->Throw it away guy !
  9618.          MOV BL,0   //No parameters
  9619.          JMP !no_args
  9620. !al2:
  9621.          DEC ESI    //restore old position
  9622. !aagain:
  9623.          PUSH ESI   //save last adress
  9624.          CMP CL,BL  //is the parameter reached ??
  9625.          JE !no_args
  9626. !readloop:
  9627.          LODSB
  9628.          CMP AL,0
  9629.          JE !no_args1  //No more arguments detected
  9630.          //check all separators possible
  9631.          CMP AL,' '
  9632.          JE !separator
  9633.          //No separator --> normal character
  9634.          JMP !readloop
  9635. !separator:
  9636.          //Check whether more separators follow
  9637.          LODSB
  9638.          CMP AL,' '
  9639.          JE !one_more
  9640.          CMP AL,0      //A zero parameter is stupid
  9641.          JNE !no_more
  9642.          POP EAX       //Clear stack
  9643.          PUSHL 0       //The (nonexistent) parameter -->Throw it away guy !
  9644.          JMP !no_args
  9645. !one_more:
  9646.          JMP !separator
  9647. !no_more:
  9648.          DEC ESI
  9649.          INC BX        //Increment parameter count
  9650.          POP EAX       //clear stack
  9651.          JMP !aagain
  9652. !no_args1:
  9653.          //Argument index was invalid
  9654.          POP ESI   //Clear Stack
  9655.          PUSHL 0   //Pointer to parameter is NIL
  9656. !no_args:
  9657.          MOV CL,BL     //Parameter count
  9658.          POP ESI       //Adress of last parameter
  9659.          RETN32
  9660. SYSTEM.!ParaInfo ENDP
  9661.  
  9662. END;
  9663.  
  9664. FUNCTION  PARAMSTR(item:Byte):STRING;
  9665. VAR s,s1:STRING;
  9666. BEGIN
  9667.      ParamStr:='';  {Clear}
  9668.      ASM
  9669.          MOV CL,$item                //index to CL
  9670.          MOV AL,2                    //Get Parameter name
  9671.          MOV ESI,SYSTEM.ArgStart
  9672.          CALLN32 SYSTEM.!ParaInfo
  9673.          MOV EDI,[EBP+8]             //Result string
  9674.          MOVB [EDI+0],0              //Result string is empty
  9675.          LEA EDI,$s                  //result string
  9676.          XOR AL,AL                   //Stringlen to 0
  9677.          STOSB
  9678.          CMP ESI,0                   //Parameter invalid ?
  9679.          JE _Lpe
  9680.  
  9681.          CLD
  9682.          LEA EDI,$s   //result string
  9683.          XOR AL,AL    //Stringlen to 0
  9684.          STOSB
  9685.          MOV CL,0     //Len is 0
  9686. __lp1:
  9687.          LODSB
  9688.          //Check all separators
  9689.          CMP AL,' '
  9690.          JE __Lps
  9691.          CMP AL,0    //Last parameter
  9692.          JE __Lps
  9693.          INC CL
  9694.          //No separator --> save
  9695.          STOSB
  9696.          JMP __lp1
  9697. __Lps:
  9698.          LEA EDI,$s            //Result string
  9699.          MOV [EDI+0],CL        //set Stringlen
  9700. _lpe:
  9701.     END;
  9702.     IF item=0 THEN
  9703.     BEGIN
  9704.          IF pos('.',s)=0 THEN s:=s+'.EXE';
  9705.          IF pos('\',s)=0 THEN
  9706.          BEGIN
  9707.               getdir(0,s1);
  9708.               IF s1[length(s1)]='\' THEN dec(s1[0]);
  9709.               s:=s1+'\'+s;
  9710.          END;
  9711.     END;
  9712.     ParamStr:=s;
  9713. END;
  9714.  
  9715.  
  9716.  
  9717. FUNCTION PARAMCOUNT:Byte;
  9718. BEGIN
  9719.      ASM
  9720.         MOV AL,1  //get parametercount
  9721.         MOV ESI,SYSTEM.ArgStart
  9722.         CALLN32 SYSTEM.!ParaInfo
  9723.         MOV AL,CL
  9724.         XOR AH,AH
  9725.         MOV $!FUNCRESULT,AX
  9726.      END;
  9727. END;
  9728.  
  9729.  
  9730. //************************************************************************
  9731. //
  9732. //
  9733. // System initialization code
  9734. //
  9735. //
  9736. //************************************************************************
  9737.  
  9738. ASSEMBLER
  9739.  
  9740. SYSTEM.!CorrectArgList PROC NEAR32
  9741.                CLD
  9742.                MOVB SYSTEM.Redirect,0
  9743.                MOV ESI,SYSTEM.ArgStart
  9744.                CMP ESI,0
  9745.                JNE !cal1_rrloop
  9746.                RETN32
  9747.  
  9748. !cal1_rrloop:
  9749.                //Overread EXE file name
  9750.                LODSB
  9751.                CMP AL,0
  9752.                JNE !cal1_rrloop
  9753. !cal1_1:
  9754.                MOV AL,[ESI+0]
  9755.  
  9756.                CMP AL,32
  9757.                JNE !cal1_3
  9758.  
  9759.                CMPB [ESI+1],0
  9760.                JNE !cal1_3
  9761.                MOV AL,0
  9762. !cal1_3:
  9763.                CMP AL,'|'
  9764.                JE !cal1_51x
  9765.  
  9766.                CMP AL,'>'
  9767.                JE !cal1_5!
  9768.  
  9769.                CMP AL,'<'
  9770.                JNE !cal1_4
  9771.                MOVB SYSTEM.RedirectIn,1
  9772.                JMP !cal1_51x
  9773. !cal1_5!:
  9774.                MOVB SYSTEM.RedirectOut,1
  9775. !cal1_51x:
  9776.                pushl 1000
  9777.                pushl 1000
  9778.                calln32 system.beep
  9779.                //redirect symbol found
  9780.                //Set REDIRECT on TRUE
  9781.                MOVB SYSTEM.Redirect,1
  9782.                MOV EDI,ESI
  9783.                MOV AL,0
  9784. !cal1_51!:
  9785.                DEC EDI
  9786.                CMP EDI,SYSTEM.ArgStart
  9787.                JB !cal1_4
  9788.                CMPB [EDI+0],32
  9789.                JNE !cal1_4
  9790.                MOVB [EDI+0],0
  9791.                JMP !cal1_51!
  9792. !cal1_4:
  9793.                MOV [ESI+0],AL
  9794.                INC ESI
  9795.                CMP AL,0
  9796.                JNE !cal1_1
  9797.                RETN32
  9798. SYSTEM.!CorrectArgList ENDP
  9799.  
  9800. END;
  9801.  
  9802. TYPE
  9803.     PSCUFileFormat=^TSCUFileFormat;
  9804.     TSCUFileFormat=RECORD
  9805.                          Version:STRING[5];
  9806.                          ObjectOffset,ObjectLen:LONGINT;
  9807.                          NameTableOffset,NameTableLen:LONGINT;
  9808.                          ResourceOffset,ResourceLen:LONGINT;
  9809.                          ObjectCount:LONGINT;
  9810.                          UseEntry:LONGINT; {used by project management}
  9811.                          NextEntry:POINTER;
  9812.                    END;
  9813.  
  9814. PROCEDURE AddSCUData(Data:PSCUFileFormat);
  9815. BEGIN
  9816.      Data^.NextEntry:=SCUPointer;
  9817.      SCUPointer:=Data;
  9818. END;
  9819.  
  9820. VAR ArgStart:POINTER;
  9821.     EnvStart:POINTER;
  9822.  
  9823. CONST
  9824.     C10:LONGWORD=10;
  9825.     FPUControl:WORD=$133f;
  9826.     FPURound:WORD=$1f3f;
  9827.     FPURoundUp:WORD=$1b3f;
  9828.     Exponent:WORD=0;
  9829.     fl1:ARRAY[0..3] OF BYTE=(0,$42,$c0,$ff);
  9830.     fl2:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$fe,$3f); //0.7853...
  9831.     fl3:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$ff,$3f);
  9832.     fl4:ARRAY[0..3] OF BYTE=(0,$4a,$c0,$ff);
  9833.     fl5:ARRAY[0..3] OF BYTE=(0,0,0,$3f);
  9834.     fl6:ARRAY[0..9] OF BYTE=($85,$64,$de,$f9,$33,$f3,4,$b5,$ff,$3f);
  9835.     fl7:ARRAY[0..9] OF BYTE=($48,$7e,$2a,$92,$a2,$da,$0f,$c9,$ff,$3f); //PI/2
  9836.     fl8:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,$fe,$3f);  //0.5
  9837.     fl9:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,0,$40);    //2.0
  9838.     fl10:ARRAY[0..9] OF BYTE=($83,$ab,$4b,$ac,$dd,$8d,$5d,$93,0,$40); //ln(10)
  9839.     fl11:ARRAY[0..9] OF BYTE=($7e,$c0,$68,$77,$0d,$18,$72,$b1,$fe,$3f); //ln(2)
  9840.  
  9841. PROCEDURE SystemInit(HeapSize,TheStackSize:LONGWORD);
  9842. VAR
  9843.    ff:^FileRec;
  9844.    ESP:LONGWORD;
  9845. BEGIN
  9846.      ASM
  9847.         MOV $ESP,ESP
  9848.         MOVD SYSTEM.MemPageSize,131072
  9849.      END;
  9850.      StackSize:=TheStackSize;
  9851.      MinStack:=(ESP-StackSize)+16384;
  9852.      ExitProc:=@ExitAll;
  9853.      RedirectIn:=FALSE;
  9854.      RedirectOut:=FALSE;
  9855.      Redirect:=FALSE;
  9856.      ASM
  9857.         //Initialize FPU
  9858.         FINIT
  9859.         FCLEX
  9860.         FLDCW SYSTEM.FPUControl
  9861.         FWAIT
  9862.  
  9863.         //correct arguments
  9864.         CALLN32 SYSTEM.!CorrectArgList
  9865.      END;
  9866.  
  9867.      FileBufSize:=32760;   {Standard file buffer size}
  9868.  
  9869.      ff:=@Input;
  9870.      ff^.Handle:=0; {Handle to standard input}
  9871.      ff^.RecSize:=1;
  9872.      ff^.Name:='';
  9873.      ff^.EAS:=NIL;
  9874.      ff^.Flags:=$6666;
  9875.      ff^.Mode:=0;
  9876.      ff^.Buffer:=NIL;
  9877.      ff^.MaxCacheMem:=0;
  9878.      ff^.Offset:=0;
  9879.      ff^.LOffset:=0;
  9880.      ff^.Block:=0;
  9881.      ff^.LBlock:=0;
  9882.      ff^.Reserved1:=0;
  9883.      ff^.BufferBytes:=0;
  9884.  
  9885.      ff:=@Output;
  9886.      ff^.Handle:=1; {Handle to standard output}
  9887.      ff^.RecSize:=1;
  9888.      ff^.Name:='';
  9889.      ff^.EAS:=NIL;
  9890.      ff^.Flags:=$6666;
  9891.      ff^.Mode:=0;
  9892.      ff^.Buffer:=NIL;
  9893.      ff^.MaxCacheMem:=0;
  9894.      ff^.Offset:=0;
  9895.      ff^.LOffset:=0;
  9896.      ff^.Block:=0;
  9897.      ff^.LBlock:=0;
  9898.      ff^.Reserved1:=0;
  9899.      ff^.BufferBytes:=0;
  9900.  
  9901.      HeapError:=StdHeapError;
  9902.      IF DosCreateMutexSem(NIL,HeapMutex,DC_SEM_SHARED,FALSE)<>0
  9903.        THEN RunError(218);
  9904.      HeapStrategyBestFit:=FALSE;
  9905.      LastHeapPage:=NIL;
  9906.      LastHeapPageAdr:=NIL;
  9907.      IF not CreateSystemHeap(HeapSize*1024) THEN RunError(218);
  9908.  
  9909.      {Initialize system variables}
  9910.      OpenedFilesCount:=0;
  9911.      IOResult:=0;
  9912.      FileMode:=fmInOut;
  9913.      SeekMode:=0; {File begin}
  9914.      SetTrigMode(rad);
  9915.  
  9916.      IF ApplicationType=1 THEN {initialize PM}
  9917.      BEGIN
  9918.           AppHandle:=WinInitialize(0);
  9919.           AppQueueHandle:=WinCreateMsgQueue(AppHandle,0);
  9920.      END;
  9921. END;
  9922.  
  9923. TYPE
  9924.             POINTL=RECORD
  9925.                   x:LONGINT;
  9926.                   y:LONGINT;
  9927.             END;
  9928.  
  9929.             QMSG=RECORD
  9930.                hwnd:LONGWORD;
  9931.                msg:LONGWORD;
  9932.                mp1:LONGWORD;
  9933.                mp2:LONGWORD;
  9934.                time:LONGWORD;
  9935.                ptl:POINTL;
  9936.                reserved:LONGWORD;
  9937.             END;
  9938.  
  9939. PROCEDURE MainDispatchLoop;
  9940. VAR _qmsg:QMSG;
  9941. BEGIN
  9942.      ASM
  9943. !ndis:
  9944.         PUSHL 0
  9945.         PUSHL 0
  9946.         PUSHL 0
  9947.         LEA EAX,$_qmsg
  9948.         PUSH EAX
  9949.         PUSHL SYSTEM.AppHandle
  9950.         MOV AL,5
  9951.         CALLDLL PMWIN,915  //WinGetMsg
  9952.         ADD ESP,20
  9953.         CMP EAX,0
  9954.         JE !exdis
  9955.  
  9956.         LEA EAX,$_qmsg
  9957.         PUSH EAX
  9958.         PUSHL SYSTEM.AppHandle
  9959.         MOV AL,2
  9960.         CALLDLL PMWIN,912  //WinDispatchMsg
  9961.         ADD ESP,8
  9962.         JMP !ndis
  9963. !exdis:
  9964.      END;
  9965. END;
  9966.  
  9967. PROCEDURE SystemEnd(ReturnCode:WORD);
  9968. BEGIN
  9969.      Halt(0);
  9970. END;
  9971.  
  9972. {$D+}
  9973. BEGIN
  9974. END.
  9975.  
  9976. {$ENDIF OS2}
  9977.  
  9978. {$IFDEF WIN95}
  9979.  
  9980. {***************************************************************************
  9981.  *                                                                         *
  9982.  * SPEED PASCAL for Windows95                                              *
  9983.  * (C) 1992..95 SpeedSoft Software                                         *
  9984.  *                                                                         *
  9985.  * Unit SYSTEM : Low level basic functions                                 *
  9986.  *                                                                         *
  9987.  * Note: Compile with DWORD align !!                                       *
  9988.  *                                                                         *
  9989.  ***************************************************************************}
  9990.  
  9991. INTERFACE
  9992.  
  9993. //General functions
  9994. FUNCTION Swap(i:INTEGER):INTEGER;
  9995.  
  9996. //general constants
  9997. CONST
  9998.      MINSHORTINT  = -128;
  9999.      MAXSHORTINT  = 127;
  10000.      MAXINT       = 32767;
  10001.      MININT       =-32768;
  10002.      MAXLONGINT   = 2147483647;
  10003.      {$IFDEF DOSOS2}    //BP doesn't accept this
  10004.      MINLONGINT   =-2147483647;
  10005.      {$ELSE}
  10006.      MINLONGINT   =-2147483648;
  10007.      {$ENDIF}
  10008.      MINBYTE      = 0;
  10009.      MAXBYTE      = 255;
  10010.      MINWORD      = 0;
  10011.      MAXWORD      = 65535;
  10012.      MAXLONGWORD  = $ffffffff;
  10013.      MINLONGWORD  = 0;
  10014.      NULLHANDLE   = 0;
  10015.      SCUPointer:POINTER=NIL;
  10016.  
  10017. //General types
  10018. //General types
  10019. TYPE
  10020.     PChar    =^CSTRING;
  10021.     PString  =^STRING;
  10022.  
  10023.     PDATETIME=^DATETIME;
  10024.     DATETIME=RECORD
  10025.                   CASE INTEGER OF
  10026.                      1: ( hour:BYTE;
  10027.                           min:BYTE;
  10028.                           sec:BYTE;
  10029.                           hundredths:BYTE;
  10030.                           day:BYTE;
  10031.                           month:BYTE;
  10032.                           year:WORD;
  10033.                           timezone:INTEGER;
  10034.                           weekday:BYTE;
  10035.                         );
  10036.                      2: ( hours:BYTE;
  10037.                           minutes:BYTE;
  10038.                           seconds:BYTE;
  10039.                         );
  10040.              END;
  10041.  
  10042.     {Generic procedure pointer}
  10043.     TProcedure = procedure;
  10044.  
  10045. // Memory management functions
  10046.  
  10047. TYPE
  10048.     HeapFunc=FUNCTION(size:LONGWORD):Integer;
  10049.  
  10050. VAR
  10051.     HeapOrg:Pointer;           {Bottom of heap}
  10052.     HeapEnd:Pointer;           {End of heap}
  10053.     HeapPtr:Pointer;           {Actual heap position}
  10054.     FreeList:Pointer;          {List of free blocks}
  10055.     HeapTop:POINTER;           {Highest heap adress that has been commited}
  10056.     HeapSize:LONGWORD;         {Size of heap}
  10057.     HeapError:HeapFunc;        {Heap Error Function}
  10058.     HeapResult:LONGWORD;       {Result from last heap function}
  10059.     MemAvailBytes:LONGWORD;
  10060.  
  10061. FUNCTION  MaxAvail:LongWord;
  10062. FUNCTION  MemAvail:LongWord;
  10063. PROCEDURE GetMem(VAR pp:Pointer;size:LongWord);
  10064. PROCEDURE GetSharedMem(VAR pp:Pointer;size:LongWord);
  10065. PROCEDURE Mark(VAR p:POINTER);
  10066. PROCEDURE Release(VAR p:POINTER);
  10067. PROCEDURE FreeMem(pp:pointer;size:LongWord);
  10068. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  10069. PROCEDURE GetAPIMem(VAR p:POINTER;size:LONGWORD);
  10070. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  10071. PROCEDURE NewSystemHeap;
  10072. FUNCTION  CreateSystemHeap(Size:LONGWORD):BOOLEAN;
  10073. PROCEDURE DestroySystemHeap;
  10074. PROCEDURE DestroyHeap(Heap:POINTER);
  10075.  
  10076. // Random numbers support
  10077. VAR
  10078.    RandSeed:LONGWORD;
  10079.  
  10080. PROCEDURE Randomize;
  10081. FUNCTION  Random(value:word):word;
  10082.  
  10083. //Direct memory access
  10084. PROCEDURE MOVE(CONST source;VAR dest;size:LongWord);
  10085. PROCEDURE FILLCHAR(VAR dest;size:LongWord;value:byte);
  10086.  
  10087. //LongJmp support
  10088.  
  10089. TYPE Jmp_Buf=ARRAY[0..8] OF LONGWORD;
  10090.  
  10091. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  10092. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  10093.  
  10094.  
  10095. //String functions
  10096. PROCEDURE UpcaseStr(VAR s:STRING);
  10097. FUNCTION POS(CONST item,source:STRING):BYTE;
  10098. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  10099. PROCEDURE SubStr(VAR source:STRING;start,ende:Byte);
  10100. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  10101. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  10102. FUNCTION ToHex(l:LONGWORD):STRING;
  10103.  
  10104. //Floating point support
  10105. CONST
  10106.     rad=1;
  10107.     deg=2;
  10108.     gra=3;
  10109.  
  10110. VAR
  10111.     IsNotRad:BOOLEAN;
  10112.     ToRad,FromRad:EXTENDED;
  10113.     FPUResult:WORD;
  10114.  
  10115. PROCEDURE SetTrigMode(mode:BYTE);
  10116.  
  10117. CONST
  10118.      PI=3.141592653589793240;
  10119.  
  10120. {TYPE
  10121.       (* Class structures layout, particulary also valid for objects *)
  10122.       PClassInfoLayout=^TClassInfoLayout;
  10123.       TClassInfoLayout=RECORD
  10124.                              ClassSize:LONGWORD;
  10125.                              ParentObjectAddr:POINTER;
  10126.                              FieldAdress:POINTER;
  10127.                              (*Class Info following here*)
  10128.                        END;
  10129.  
  10130.       PDmtLayout=^TDmtLayout;
  10131.       TDmtLayout=RECORD
  10132.                        NumDmts:LONGWORD;  (*Number of entries*)
  10133.                        (*entries follow here
  10134.                          each entry is 8 byte long
  10135.                          the first DWord contains the message id,
  10136.                          the second DWord contains the VMT index*)
  10137.                  END;
  10138.  
  10139.       PVmtLayOut=^TVmtLayOut;
  10140.       TVmtLayOut=RECORD
  10141.                        Dmt:PDmtLayout;  (*Pointer to DMT*)
  10142.                        ClassInfo:PClassInfoLayout;
  10143.                        ClassSize:LONGWORD;
  10144.                        VmtSize:LONGWORD; (*Number of entries*)
  10145.                        (*entries follow here
  10146.                          each entry is 4 byte long and contains
  10147.                          the address for that VMT index*)
  10148.                  END;
  10149.       TClassLayout=RECORD
  10150.                          Vmt:PVmtLayout;
  10151.                          (*Object variables follow here*)
  10152.                    END;}
  10153.  
  10154. TYPE
  10155.     TObject = CLASS;
  10156.     TClass  = CLASS OF TObject;
  10157.     TObject = CLASS
  10158.       CONSTRUCTOR Create;
  10159.       DESTRUCTOR Destroy; VIRTUAL;
  10160.       PROCEDURE Free;VIRTUAL;
  10161.       CLASS FUNCTION NewInstance: TObject; VIRTUAL;
  10162.       PROCEDURE FreeInstance; virtual;
  10163.       CLASS FUNCTION InitInstance(Instance: Pointer): TObject;
  10164.       CLASS FUNCTION ClassType: TClass;
  10165.       CLASS FUNCTION ClassName: STRING;
  10166.       CLASS FUNCTION ClassUnit: STRING;
  10167.       CLASS FUNCTION ClassParent: TClass;
  10168.       CLASS FUNCTION GetClassInfo: POINTER; //conflicts with PMWIN CLASSINFO
  10169.       CLASS FUNCTION InstanceSize: LONGWORD;
  10170.       CLASS FUNCTION InheritsFrom(AClass: TClass): BOOLEAN;
  10171.       PROCEDURE DefaultHandler(VAR Message); VIRTUAL;
  10172.       PROCEDURE DefaultFrameHandler(VAR Message); VIRTUAL;
  10173.       PROCEDURE Dispatch(VAR Message);
  10174.       PROCEDURE DispatchCommand(VAR Message;Command:LONGWORD);
  10175.       PROCEDURE FrameDispatch(VAR Message);
  10176.       CLASS FUNCTION MethodAddress(CONST Name: STRING): POINTER;
  10177.       CLASS FUNCTION MethodName(Address: POINTER): STRING;
  10178.       FUNCTION FieldAddress(Name: STRING): POINTER;
  10179.     END;
  10180.  
  10181.     TYPE TScreenInOutClass=CLASS
  10182.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  10183.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  10184.          PROCEDURE WriteLF;VIRTUAL;
  10185.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  10186.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  10187.      END;
  10188.  
  10189.      TPMScreenInOutClass=CLASS
  10190.          PROCEDURE WriteStr(CONST s:STRING);VIRTUAL;
  10191.          PROCEDURE WriteCStr(CONST s:CSTRING);VIRTUAL;
  10192.          PROCEDURE WriteLF;VIRTUAL;
  10193.          PROCEDURE ReadLF(VAR s:STRING);VIRTUAL;
  10194.          PROCEDURE GotoXY(x,y:BYTE);VIRTUAL;
  10195.          PROCEDURE Error;
  10196.      END;
  10197.  
  10198. VAR ScreenInOut:TScreenInOutClass;
  10199.  
  10200. VAR
  10201.    IOResult:LONGWORD;
  10202.  
  10203. CONST
  10204.    {FileMode values}
  10205.    fmDenyRead   = $00000002; {deny read access by other processes         }
  10206.    fmDenyWrite  = $00000001; {deny write access by other processes        }
  10207.    fmDenyNone   = $00000003; {deny neither read nor write                 }
  10208.    fmDenyBoth   = $0;        {deny both read and write access (standard)  }
  10209.  
  10210.    fmClosed     = 0;
  10211.    fmInput      = $80000000 or fmDenyWrite; {Read only                                   }
  10212.    fmOutput     = $40000000 or fmDenyRead;  {Write only                                  }
  10213.    fmInOut      = $C0000000 or fmDenyNone;  {allow both read and write access (standard) }
  10214.  
  10215. CONST
  10216.    {Seek Origin Constants}
  10217.    Seek_Begin     = 0;   //Seek from beginning of file
  10218.    Seek_Current   = 1;   //Seek from current position of file
  10219.    Seek_End       = 2;   //Seek from end of file
  10220.  
  10221. VAR
  10222.    FileMode:LONGWORD;   {file mode for both reset and rewrite}
  10223.    SeekMode:LONGWORD;   {seek mode for seek                  }
  10224.  
  10225. TYPE
  10226.       P_FileBuffer=^T_FileBuffer;
  10227.       T_FileBuffer=ARRAY[0..MaxLongInt-1] OF BYTE; {handled dynamically}
  10228.  
  10229.       FileRec = RECORD
  10230.                       Handle          : LongWord;     {FileHandle            }
  10231.                       RecSize         : LongWord;     {Record size           }
  10232.                       Name            : STRING;       {(Long) file name      }
  10233.                       EAS             : POINTER;      {extended attributes   }
  10234.                       Mode            : LONGWORD;     {Current file mode     }
  10235.                       Reserved        : POINTER;      {for private extensions}
  10236.                       Block           : LONGWORD;     {current block in file }
  10237.                       LBlock          : LONGWORD;     {Last block in file    }
  10238.                       Offset          : LONGWORD;     {Current offset in Block}
  10239.                       LOffset         : LONGWORD;     {Last Offset in LBlock }
  10240.                       Changed         : LONGBOOL;     {TRUE if Block has changed}
  10241.                       Buffer          : P_FileBuffer; {I/O Buffer            }
  10242.                       MaxCacheMem     : LONGWORD;     {Size of I/O Buffer    }
  10243.                       Flags           : LONGWORD;     {Assign flags $6666    }
  10244.                       Reserved1       : WORD;         {dont use              }
  10245.                       BufferBytes     : WORD;         {dont use              }
  10246.                       {312 byte til here}
  10247.                 END;
  10248.  
  10249.  
  10250. PROCEDURE Assign(VAR f:FILE;CONST s:STRING);
  10251. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  10252. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  10253. PROCEDURE Close(VAR f:FILE);
  10254. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  10255. PROCEDURE BlockWrite(VAR f:file;VAR Buf;Count:LongWord;VAR result:LONGWORD);
  10256. PROCEDURE Rename(VAR f:file;NewName:String);
  10257. PROCEDURE Truncate(VAR f:FILE);
  10258. PROCEDURE Append(VAR f:Text);
  10259. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  10260. FUNCTION SeekEof(Var F :Text):Boolean;
  10261. FUNCTION SeekEoln(Var F :Text):Boolean;
  10262. FUNCTION FilePos(VAR f:FILE):LONGWORD;
  10263. FUNCTION FileSize(VAR f:FILE):LONGWORD;
  10264. FUNCTION Eof(VAR f:FILE):BOOLEAN;
  10265. FUNCTION Eoln(VAR f:FILE):BOOLEAN;
  10266. PROCEDURE Erase(VAR f:FILE);
  10267. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  10268. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  10269.  
  10270. //Functions for manipulating directories
  10271. PROCEDURE ChDir(CONST path:STRING);
  10272. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  10273. PROCEDURE RmDir(CONST dir:STRING);
  10274. PROCEDURE MkDir(CONST dir:STRING);
  10275.  
  10276. FUNCTION  PARAMSTR(item:Byte):STRING;
  10277. FUNCTION  PARAMCOUNT:Byte;
  10278.  
  10279. //Exception Management
  10280.  
  10281. TYPE
  10282.   { Exceptions }
  10283. CONST
  10284.      SIZE_OF_80387_REGISTERS      = 80;
  10285.  
  10286. TYPE
  10287.     PFLOATING_SAVE_AREA=^FLOATING_SAVE_AREA;
  10288.     FLOATING_SAVE_AREA=RECORD
  10289.                              ControlWord:LONGWORD;
  10290.                              StatusWord:LONGWORD;
  10291.                              TagWord:LONGWORD;
  10292.                              ErrorOffset:LONGWORD;
  10293.                              ErrorSelector:LONGWORD;
  10294.                              DataOffset:LONGWORD;
  10295.                              DataSelector:LONGWORD;
  10296.                              RegisterArea:ARRAY[0..SIZE_OF_80387_REGISTERS-1] OF BYTE;
  10297.                              Cr0NpxState:LONGWORD;
  10298.     END;
  10299.  
  10300. TYPE
  10301.     PCONTEXT=^CONTEXT;
  10302.     CONTEXT=RECORD
  10303.                   ContextFlags:LONGWORD;
  10304.                   Dr0:LONGWORD;
  10305.                   Dr1:LONGWORD;
  10306.                   Dr2:LONGWORD;
  10307.                   Dr3:LONGWORD;
  10308.                   Dr6:LONGWORD;
  10309.                   Dr7:LONGWORD;
  10310.  
  10311.                   FloatSave:FLOATING_SAVE_AREA;
  10312.  
  10313.                   SegGs:LONGWORD;
  10314.                   SegFs:LONGWORD;
  10315.                   SegEs:LONGWORD;
  10316.                   SegDs:LONGWORD;
  10317.  
  10318.                   Edi:LONGWORD;
  10319.                   Esi:LONGWORD;
  10320.                   Ebx:LONGWORD;
  10321.                   Edx:LONGWORD;
  10322.                   Ecx:LONGWORD;
  10323.                   Eax:LONGWORD;
  10324.  
  10325.                   Ebp:LONGWORD;
  10326.                   Eip:LONGWORD;
  10327.                   SegCs:LONGWORD;
  10328.                   EFlags:LONGWORD;
  10329.                   Esp:LONGWORD;
  10330.                   SegSs:LONGWORD;
  10331.     END;
  10332.  
  10333. CONST
  10334.      EXCEPTION_CONTINUABLE         = 0; // Continuable exception
  10335.      EXCEPTION_NONCONTINUABLE      = 1; // Noncontinuable exception
  10336.      EXCEPTION_MAXIMUM_PARAMETERS  =15; // maximum number of exception parameters
  10337.  
  10338. TYPE
  10339.     PEXCEPTION_RECORD=^EXCEPTION_RECORD;
  10340.     EXCEPTION_RECORD=RECORD
  10341.                            ExceptionCode:LONGWORD;
  10342.                            ExceptionFlags:LONGWORD;
  10343.                            ExceptionRecord:PEXCEPTION_RECORD;
  10344.                            ExceptionAddress:POINTER;
  10345.                            NumberParameters:LONGWORD;
  10346.                            ExceptionInformation:ARRAY[0..EXCEPTION_MAXIMUM_PARAMETERS-1] OF LONGWORD;
  10347.     END;
  10348.  
  10349. TYPE
  10350.     PEXCEPTION_POINTERS=^EXCEPTION_POINTERS;
  10351.     EXCEPTION_POINTERS=RECORD
  10352.                              ExceptionRecord:PEXCEPTION_RECORD;
  10353.                              ContextRecord:PCONTEXT;
  10354.     END;
  10355.  
  10356. TYPE
  10357.   Exception=CLASS;
  10358.  
  10359.   PExcptInfo=^TExcptInfo;
  10360.   TExcptInfo=RECORD
  10361.                      TryAddr:POINTER;
  10362.                      ExcptAddr:POINTER;
  10363.                      OldEBP,OldESP:LONGWORD;
  10364.                      OldFPUControl:LONGWORD;
  10365.                      ExcptObject:Exception;
  10366.                      ThreadId:LONGWORD;
  10367.                      Next:PExcptInfo;
  10368.                      Last:PExcptInfo;
  10369.   END;
  10370.  
  10371.   //base exception record - derive all new exceptions from that !
  10372.   Exception = CLASS(TObject)
  10373.       PRIVATE
  10374.             FMessage: PString;
  10375.             FUNCTION GetMessage: STRING;
  10376.             PROCEDURE SetMessage(CONST Value: STRING);
  10377.       PUBLIC
  10378.             ReportRecord:EXCEPTION_RECORD;
  10379.             ExcptNum:LONGWORD;
  10380.             CameFromRTL:BOOLEAN;
  10381.             Nested:BOOLEAN;
  10382.             ExcptAddr:POINTER;
  10383.             RTLExcptAddr:POINTER;
  10384.             ContextRecord:CONTEXT;
  10385.  
  10386.             CONSTRUCTOR Create(CONST Msg: STRING);
  10387.             DESTRUCTOR Destroy;OVERRIDE;
  10388.       PROPERTY
  10389.             Message:STRING read GetMessage write SetMessage;
  10390.       PROPERTY
  10391.             MessagePtr: PString read FMessage;
  10392.   END;
  10393.  
  10394. TYPE
  10395.   //General exception class
  10396.   ExceptClass = class OF Exception;
  10397.  
  10398.   //Software generated excpetions
  10399.   EProcessTerm = CLASS(Exception);
  10400.  
  10401.   //Hardware generated exceptions
  10402.   EProcessorException = CLASS(Exception);
  10403.   EFault = CLASS(EProcessorException);
  10404.   EGPFault = CLASS(EFault);
  10405.   EStackFault = CLASS(EFault);
  10406.   EPageFault = CLASS(EFault);
  10407.   EInvalidOpCode = CLASS(EFault);
  10408.   EBreakpoint = CLASS(EProcessorException);
  10409.   ESingleStep = CLASS(EProcessorException);
  10410.  
  10411.   //Memory exceptions
  10412.   EOutOfMemory = CLASS(Exception);
  10413.   EInvalidPointer = CLASS(Exception);
  10414.   EInvalidHeap    = CLASS(Exception);
  10415.  
  10416.   //Input/Output exceptions
  10417.   EInOutError = CLASS(Exception)
  10418.      PUBLIC
  10419.            ErrorCode: Integer;
  10420.   END;
  10421.   EFileNotFound=CLASS(EInOutError);
  10422.   EInvalidFileName=CLASS(EInOutError);
  10423.   ETooManyOpenFiles=CLASS(EInOutError);
  10424.   EAccessDenied=CLASS(EInOutError);
  10425.   EEndOfFile=CLASS(EInOutError);
  10426.   EDiskFull=CLASS(EInOutError);
  10427.   EInvalidInput=CLASS(EInOutError);
  10428.  
  10429.   //Integer math exceptions
  10430.   EIntError = CLASS(Exception);
  10431.   EDivByZero = CLASS(EIntError);
  10432.   ERangeError = CLASS(EIntError);
  10433.   EIntOverflow = CLASS(EIntError);
  10434.  
  10435.   //Floating point math exceptions
  10436.   EMathError = CLASS(Exception);
  10437.   EInvalidOp = CLASS(EMathError);
  10438.   EZeroDivide = CLASS(EMathError);
  10439.   EOverflow = CLASS(EMathError);
  10440.   EUnderflow = CLASS(EMathError);
  10441.  
  10442.   //type cast exceptions
  10443.   EInvalidCast = CLASS(Exception);
  10444.  
  10445.   EConvertError = CLASS(Exception);
  10446.  
  10447.  
  10448. // Error functions
  10449. VAR
  10450.    ExitCode:LONGWORD;
  10451.    ErrorAdr:POINTER;
  10452.    ExitProc:POINTER;
  10453.  
  10454. PROCEDURE RunError(Code:LONGWORD);
  10455. PROCEDURE Halt(Code:LONGWORD);
  10456.  
  10457.  
  10458. VAR
  10459.    ApplicationType:BYTE;
  10460.  
  10461. //PM Routines
  10462. VAR
  10463.     AppHandle:LONGWORD;
  10464.     AppQueueHandle:LONGWORD;
  10465.     DllModule:LONGWORD;
  10466.     DllTerminating:LONGWORD;
  10467.     DllInitTermResult:LONGWORD;
  10468.     ModuleCount:BYTE;
  10469.  
  10470.     RaiseIOError:BOOLEAN;
  10471.  
  10472. PROCEDURE MainDispatchLoop;
  10473. PROCEDURE Beep(Freq,duration:LONGWORD);
  10474.  
  10475. //TextScreen IO support
  10476. VAR
  10477.    Input,Output:TEXT;
  10478.  
  10479. VAR
  10480.    WindMin: WORD;    { Window upper left coordinates  }
  10481.    WindMax: WORD;    { Window lower right coordinates }
  10482.    LastMode: Word;   { Current text mode              }
  10483.    TextAttr: BYTE;   { Current text attribute         }
  10484.  
  10485. CONST
  10486.      { CRT modes }
  10487.      BW40          = 0;            { 40x25 B/W on Color Adapter   }
  10488.      CO40          = 1;            { 40x25 Color on Color Adapter }
  10489.      BW80          = 2;            { 80x25 B/W on Color Adapter   }
  10490.      CO80          = 3;            { 80x25 Color on Color Adapter }
  10491.      Mono          = 7;            { 80x25 on Monochrome Adapter  }
  10492.      Font8x8       = 256;          { Add-in for 8x8 font          }
  10493.  
  10494. FUNCTION Assigned(p: Pointer): Boolean;
  10495.  
  10496. IMPLEMENTATION
  10497.  
  10498. VAR
  10499.    ExcptList:PExcptInfo;
  10500.    ExcptMutex:LONGWORD;
  10501.  
  10502. VAR
  10503.    MaxWindMin: WORD;    { Max Window upper left coordinates  }
  10504.    MaxWindMax: WORD;    { Max Window lower right coordinates }
  10505.  
  10506.  
  10507.  
  10508. TYPE
  10509.     PCOORD=^COORD;
  10510.     COORD=RECORD
  10511.                 X:INTEGER;
  10512.                 Y:INTEGER;
  10513.     END;
  10514.  
  10515.     PSMALL_RECT=^SMALL_RECT;
  10516.     SMALL_RECT=RECORD
  10517.                      Left:INTEGER;
  10518.                      Top:INTEGER;
  10519.                      Right:INTEGER;
  10520.                      Bottom:INTEGER;
  10521.     END;
  10522.  
  10523.     PCONSOLE_SCREEN_BUFFER_INFO=^CONSOLE_SCREEN_BUFFER_INFO;
  10524.     CONSOLE_SCREEN_BUFFER_INFO=RECORD
  10525.                                      dwSize:COORD;
  10526.                                      dwCursorPosition:COORD;
  10527.                                      wAttributes:WORD;
  10528.                                      srWindow:SMALL_RECT;
  10529.                                      dwMaximumWindowSize:COORD;
  10530.     END;
  10531.  
  10532.     PCHAR_INFO=^CHAR_INFO;
  10533.     CHAR_INFO=RECORD
  10534.                     Char:RECORD
  10535.                        CASE Integer OF
  10536.                            1:(UniCodeChar:WORD);
  10537.                            2:(AsciiChar:CHAR);
  10538.                     END;
  10539.                     Attributes:WORD;
  10540.     END;
  10541.  
  10542. CONST
  10543.      ENABLE_PROCESSED_INPUT =$0001;
  10544.      ENABLE_LINE_INPUT      =$0002;
  10545.      ENABLE_ECHO_INPUT      =$0004;
  10546.      ENABLE_WINDOW_INPUT    =$0008;
  10547.      ENABLE_MOUSE_INPUT     =$0010;
  10548.  
  10549.      ENABLE_PROCESSED_OUTPUT    =$0001;
  10550.      ENABLE_WRAP_AT_EOL_OUTPUT  =$0002;
  10551.  
  10552. IMPORTS
  10553.        FUNCTION SetFilePointer(hFile:LONGWORD;lDistanceToMove:LONGINT;
  10554.                                VAR lpDistanceToMoveHigh:LONGINT;
  10555.                                dwMoveMethod:LONGWORD):LONGWORD;
  10556.                   APIENTRY;  'KERNEL32' name 'SetFilePointer';
  10557.        FUNCTION WriteFile(hFile:LONGWORD;CONST lpBuffer;nNumberOfBytesToWrite:LONGWORD;
  10558.                           VAR lpNumberOfBytesWritten:LONGWORD;
  10559.                           VAR lpOverlapped):LONGBOOL;
  10560.                   APIENTRY;  'KERNEL32' name 'WriteFile';
  10561.        FUNCTION ReadFile(hFile:LONGWORD;VAR lpBuffer;nNumberOfBytesToRead:LONGWORD;
  10562.                          VAR lpNumberOfBytesRead:LONGWORD;
  10563.                          VAR lpOverlapped):LONGBOOL;
  10564.                   APIENTRY;  'KERNEL32' name 'ReadFile';
  10565.        FUNCTION CreateFile(CONST lpFileName:CSTRING;dwDesiredAccess:LONGWORD;
  10566.                            dwShareMode:LONGWORD;VAR lpSecurityAttributes;
  10567.                            deCreationDisposition,dwFlagsAndAttributes:LONGWORD;
  10568.                            hTemplateFile:LONGWORD):LONGWORD;
  10569.                   APIENTRY;  'KERNEL32' name 'CreateFileA';
  10570.        FUNCTION CloseHandle(hObject:LONGWORD):LONGBOOL;
  10571.                   APIENTRY;  'KERNEL32' name 'CloseHandle';
  10572.        FUNCTION SetCurrentDirectory(CONST lpPathName:CSTRING):LONGBOOL;
  10573.                   APIENTRY;  'KERNEL32' name 'SetCurrentDirectoryA';
  10574.        FUNCTION GetCurrentDirectory(nBufferLength:LONGWORD;VAR lpBuffer:CSTRING):LONGWORD;
  10575.                   APIENTRY;  'KERNEL32' name 'GetCurrentDirectoryA';
  10576.        FUNCTION RemoveDirectory(CONST lpPathName:CSTRING):LONGBOOL;
  10577.                   APIENTRY;  'KERNEL32' name 'RemoveDirectoryA';
  10578.        FUNCTION CreateDirectory(CONST lpPathName:CSTRING;
  10579.                                 VAR lpSecurityAttributes):LONGBOOL;
  10580.                   APIENTRY;  'KERNEL32' name 'CreateDirectoryA';
  10581.        FUNCTION MoveFile(CONST lpExistingFileName,lpNewFileName:CSTRING):LONGBOOL;
  10582.                   APIENTRY;  'KERNEL32' name 'MoveFileA';
  10583.        FUNCTION DeleteFile(CONST lpFileName:CSTRING):LONGBOOL;
  10584.                   APIENTRY;  'KERNEL32' name 'DeleteFileA';
  10585.        FUNCTION SetEndOfFile(hFile:LONGWORD):LONGBOOL;
  10586.                   APIENTRY;  'KERNEL32' name 'SetEndOfFile';
  10587.        FUNCTION GetConsoleScreenBufferInfo(hConsoleOutput:LONGWORD;
  10588.                                     VAR lpConsoleScreenBufferInfo:CONSOLE_SCREEN_BUFFER_INFO):LONGBOOL;
  10589.              APIENTRY;  'KERNEL32' name 'GetConsoleScreenBufferInfo';
  10590.        FUNCTION FillConsoleOutputAttribute(hConsoleOutput:LONGWORD;wAttribute:WORD;
  10591.                                     nLength:LONGWORD;dwWriteCoord:LONGWORD;
  10592.                                     VAR lpNumberOfAttrsWritten:LONGWORD):LONGBOOL;
  10593.              APIENTRY;  'KERNEL32' name 'FillConsoleOutputAttribute';
  10594.        FUNCTION SetConsoleCursorPosition(hConsoleOutput:LONGWORD;dwCursorPosition:LONGWORD):LONGBOOL;
  10595.              APIENTRY;  'KERNEL32' name 'SetConsoleCursorPosition';
  10596.        FUNCTION GetStdHandle(nStdHandle:LONGWORD):LONGWORD;
  10597.                   APIENTRY;  'KERNEL32' name 'GetStdHandle';
  10598.        FUNCTION ReadConsoleOutputAttribute(hConsoleOutput:LONGWORD;VAR lpAttribute:WORD;
  10599.                                     nLength:LONGWORD;dwReadCoord:LONGWORD;
  10600.                                     VAR lpNumberOfAttrsRead:LONGWORD):LONGBOOL;
  10601.              APIENTRY;  'KERNEL32' name 'ReadConsoleOutputAttribute';
  10602.        FUNCTION SetConsoleMode(hConsoleHandle:LONGWORD;dwMode:LONGWORD):LONGBOOL;
  10603.              APIENTRY;  'KERNEL32' name 'SetConsoleMode';
  10604.        FUNCTION ScrollConsoleScreenBuffer(hConsoleOutput:LONGWORD;
  10605.                                    VAR lpScrollRectangle:SMALL_RECT;
  10606.                                    VAR lpClipRectangle:SMALL_RECT;
  10607.                                    dwDestinationOrigin:LONGWORD{COORD};
  10608.                                    CONST lpFill:CHAR_INFO):LONGBOOL;
  10609.              APIENTRY;  'KERNEL32' name 'ScrollConsoleScreenBufferA';
  10610.        FUNCTION WaitForSingleObject(hHandle:LONGWORD;dwMilliseconds:LONGWORD):LONGWORD;
  10611.                   APIENTRY;  'KERNEL32' name 'WaitForSingleObject';
  10612.        FUNCTION ReleaseMutex(hMutex:LONGWORD):LONGBOOL;
  10613.                   APIENTRY;  'KERNEL32' name 'ReleaseMutex';
  10614.        FUNCTION CreateMutex(VAR lpMutexAttributes;
  10615.                             bInitialOwner:LONGBOOL;CONST lpName:CSTRING):LONGWORD;
  10616.                   APIENTRY;  'KERNEL32' name 'CreateMutexA';
  10617.        FUNCTION SetUnhandledExceptionFilter(lpTopLevelFilter:POINTER):POINTER;
  10618.                   APIENTRY;  'KERNEL32' name 'SetUnhandledExceptionFilter';
  10619.        FUNCTION GetCurrentThreadId:LONGWORD;
  10620.                   APIENTRY;  'KERNEL32' name 'GetCurrentThreadId';
  10621. END;
  10622.  
  10623.  
  10624. //General functions
  10625.  
  10626. FUNCTION Assigned(p: Pointer): Boolean;
  10627. BEGIN
  10628.   Assigned := p <> Nil;
  10629. END;
  10630.  
  10631. PROCEDURE Check_Is(o:TObject;ClassInfo:TClass);
  10632. VAR bo:BOOLEAN;
  10633. BEGIN
  10634.      bo:=o.InheritsFrom(ClassInfo);
  10635.      ASM
  10636.         CMPB $bo,1
  10637.         LEAVE
  10638.         RETN32 8
  10639.      END;
  10640. END;
  10641.  
  10642. PROCEDURE Check_Is_Class(c:TClass;ClassInfo:TClass);
  10643. VAR bo:BOOLEAN;
  10644. BEGIN
  10645.      bo:=c.InheritsFrom(ClassInfo);
  10646.      ASM
  10647.         CMPB $bo,1
  10648.         LEAVE
  10649.         RETN32 8
  10650.      END;
  10651. END;
  10652.  
  10653. PROCEDURE Check_As(o:TObject;ClassInfo:TClass);
  10654. VAR e:EInvalidCast;
  10655.     Adr:LONGINT;
  10656. BEGIN
  10657.      ASM
  10658.         MOV EAX,[EBP+4]
  10659.         SUB EAX,5
  10660.         MOV $Adr,EAX
  10661.      END;
  10662.      IF not o.InheritsFrom(ClassInfo) THEN
  10663.      BEGIN
  10664.           e.Create('Invalid type cast (EInvalidCast)');
  10665.           e.CameFromRTL:=TRUE;
  10666.           e.RTLExcptAddr:=POINTER(Adr);
  10667.           raise e;
  10668.      END;
  10669. END;
  10670.  
  10671. PROCEDURE OverflowError;
  10672. VAR e:EIntOverflow;
  10673.     Adr:LONGWORD;
  10674. BEGIN
  10675.      ASM
  10676.         MOV EAX,[EBP+4]
  10677.         SUB EAX,5
  10678.         MOV $Adr,EAX
  10679.      END;
  10680.      e.Create('Integer Overflow (EIntOverflow)');
  10681.      e.CameFromRTL:=TRUE;
  10682.      e.RTLExcptAddr:=POINTER(Adr);
  10683.      Raise e;
  10684. END;
  10685.  
  10686. VAR MinStack:LONGWORD;
  10687.     StackSize:LONGWORD;
  10688.  
  10689. PROCEDURE StackError(Adr:LONGWORD);
  10690. VAR e:EStackFault;
  10691. BEGIN
  10692.      e.Create('Stack overflow (EStackFault)');
  10693.      e.CameFromRTL:=TRUE;
  10694.      e.RTLExcptAddr:=POINTER(Adr);
  10695.      Raise e;
  10696. END;
  10697.  
  10698. PROCEDURE CheckStack(Needed:LONGWORD);
  10699. VAR ESP:LONGWORD;
  10700.     Adr:LONGWORD;
  10701. BEGIN
  10702.      ASM
  10703.         PUSHAD
  10704.         MOV $ESP,ESP
  10705.         MOV EAX,[EBP+4]
  10706.         SUB EAX,5
  10707.         MOV $Adr,EAX
  10708.      END;
  10709.      IF ESP>MinStack THEN IF ESP<MinStack+StackSize THEN
  10710.      BEGIN
  10711.           IF ((ESP-Needed<MinStack)OR(ESP-Needed>MinStack+StackSize))
  10712.             THEN StackError(Adr);
  10713.      END;
  10714.      ASM
  10715.         POPAD
  10716.      END;
  10717. END;
  10718.  
  10719. PROCEDURE RangeCheckError(Adr:LONGWORD);
  10720. VAR e:ERangeError;
  10721. BEGIN
  10722.      e.Create('Range check error (ERangeError)');
  10723.      e.CameFromRTL:=TRUE;
  10724.      e.RTLExcptAddr:=POINTER(Adr);
  10725.      Raise e;
  10726. END;
  10727.  
  10728. PROCEDURE CheckRange(U,O,V:LONGINT);
  10729. VAR Adr:LONGWORD;
  10730. BEGIN
  10731.      ASM
  10732.         PUSH EAX
  10733.         MOV EAX,[EBP+4]
  10734.         SUB EAX,5
  10735.         MOV $Adr,EAX
  10736.  
  10737.         MOV EAX,$V
  10738.         CMP EAX,$U
  10739.         JL !err_this_xxx
  10740.         MOV EAX,$V
  10741.         CMP EAX,$O
  10742.         JG !err_this_xxx
  10743.  
  10744.         POP EAX
  10745.         LEAVE
  10746.         RETN32 12
  10747. !err_this_xxx:
  10748.         POP EAX
  10749.         PUSHL $Adr
  10750.         CALLN32 SYSTEM.RangeCheckError
  10751.      END;
  10752. END;
  10753.  
  10754. PROCEDURE CheckRangeUnsigned(U,O,V:LONGWORD);
  10755. VAR Adr:LONGWORD;
  10756. BEGIN
  10757.      ASM
  10758.         PUSH EAX
  10759.         MOV EAX,[EBP+4]
  10760.         SUB EAX,5
  10761.         MOV $Adr,EAX
  10762.  
  10763.         MOV EAX,$V
  10764.         CMP EAX,$U
  10765.         JB !err_this_xxx1
  10766.         MOV EAX,$V
  10767.         CMP EAX,$O
  10768.         JA !err_this_xxx1
  10769.  
  10770.         POP EAX
  10771.         LEAVE
  10772.         RETN32 12
  10773. !err_this_xxx1:
  10774.         POP EAX
  10775.         PUSHL $Adr
  10776.         CALLN32 SYSTEM.RangeCheckError
  10777.      END;
  10778. END;
  10779.  
  10780. PROCEDURE CheckRange2(Nr,V:LONGINT);
  10781. VAR Adr:LONGWORD;
  10782. BEGIN
  10783.      ASM
  10784.          PUSH EAX
  10785.          MOV EAX,[EBP+4]
  10786.          SUB EAX,5
  10787.          MOV $Adr,EAX
  10788.  
  10789.          MOV EAX,$Nr
  10790.          CMP EAX,1
  10791.          JNE !my_lab1
  10792.  
  10793.          MOV EAX,$V
  10794.          CMP EAX,MINSHORTINT
  10795.          JL !err_this_xxx2
  10796.          CMP EAX,MAXSHORTINT
  10797.          JG !err_this_xxx2
  10798.          jmp !ex_this_xxx
  10799. !my_lab1:
  10800.          CMP EAX,2
  10801.          JNE !my_lab2
  10802.  
  10803.          MOV EAX,$V
  10804.          CMP EAX,MININT
  10805.          JL !err_this_xxx2
  10806.          CMP EAX,MAXINT
  10807.          JG !err_this_xxx2
  10808.          jmp !ex_this_xxx
  10809. !my_lab2:
  10810.          CMP EAX,4
  10811.          JNE !ex_this_xxx
  10812.  
  10813.          MOV EAX,$V
  10814.          CMP EAX,MINLONGINT
  10815.          JL !err_this_xxx2
  10816.          CMP EAX,MAXLONGINT
  10817.          JG !err_this_xxx2
  10818. !ex_this_xxx:
  10819.          POP EAX
  10820.          LEAVE
  10821.          RETN32 8
  10822. !err_this_xxx2:
  10823.          POP EAX
  10824.          PUSHL $Adr
  10825.          CALLN32 SYSTEM.RangeCheckError
  10826.      END;
  10827. END;
  10828.  
  10829. PROCEDURE CheckRangeUnsigned2(Nr,V:LONGWORD);
  10830. VAR Adr:LONGWORD;
  10831. BEGIN
  10832.      ASM
  10833.          PUSH EAX
  10834.          MOV EAX,[EBP+4]
  10835.          SUB EAX,5
  10836.          MOV $Adr,EAX
  10837.  
  10838.          MOV EAX,$Nr
  10839.          CMP EAX,1
  10840.          JNE !my_lab1w
  10841.  
  10842.          MOV EAX,$V
  10843.          CMP EAX,MINBYTE
  10844.          JB !err_this_xxx2w
  10845.          CMP EAX,MAXBYTE
  10846.          JA !err_this_xxx2w
  10847.          jmp !ex_this_xxxw
  10848. !my_lab1w:
  10849.          CMP EAX,2
  10850.          JNE !my_lab2w
  10851.  
  10852.          MOV EAX,$V
  10853.          CMP EAX,MINWORD
  10854.          JB !err_this_xxx2w
  10855.          CMP EAX,MAXWORD
  10856.          JA !err_this_xxx2w
  10857.          jmp !ex_this_xxxw
  10858. !my_lab2w:
  10859.          CMP EAX,4
  10860.          JNE !ex_this_xxxw
  10861.  
  10862.          MOV EAX,$V
  10863.          CMP EAX,MINLONGWORD
  10864.          JB !err_this_xxx2w
  10865.          CMP EAX,MAXLONGWORD
  10866.          JA !err_this_xxx2w
  10867. !ex_this_xxxw:
  10868.          POP EAX
  10869.          LEAVE
  10870.          RETN32 8
  10871. !err_this_xxx2w:
  10872.          POP EAX
  10873.          PUSHL $Adr
  10874.          CALLN32 SYSTEM.RangeCheckError
  10875.      END;
  10876. END;
  10877.  
  10878.  
  10879. FUNCTION Swap(i:INTEGER):INTEGER;
  10880. BEGIN
  10881.      Swap:=lo(i)*256+hi(i);
  10882. END;
  10883.  
  10884. VAR
  10885.    Redirect,RedirectOut,RedirectIn:BOOLEAN;
  10886.  
  10887.  
  10888. IMPORTS
  10889.      PROCEDURE ExitProcess(RetCode:LONGWORD);
  10890.                    'KERNEL32' name 'ExitProcess';
  10891. END;
  10892.  
  10893. //************************************************************************
  10894. //
  10895. //
  10896. // Memory support management functions
  10897. //
  10898. //
  10899. //************************************************************************
  10900.  
  10901. IMPORTS
  10902.        FUNCTION GetLastError:LONGWORD;
  10903.                   APIENTRY;  'KERNEL32' name 'GetLastError';
  10904.        FUNCTION HeapCreate(flOptions:LONGWORD;dwInitialSize:LONGWORD;
  10905.                            dwMaximumSize:LONGWORD):POINTER;
  10906.                   APIENTRY;  'KERNEL32' name 'HeapCreate';
  10907.        FUNCTION HeapDestroy(hHeap:POINTER):LONGBOOL;
  10908.                   APIENTRY;  'KERNEL32' name 'HeapDestroy';
  10909.        FUNCTION GlobalAlloc(uFlags:LONGWORD;dwBytes:LONGWORD):POINTER;
  10910.                   APIENTRY;  'KERNEL32' name 'GlobalAlloc';
  10911.        FUNCTION GlobalFree(hMem:POINTER):POINTER;
  10912.                   APIENTRY;  'KERNEL32' name 'GlobalFree';
  10913.        FUNCTION HeapAlloc(hHeap:POINTER;dwFlags,dwBytes:LONGWORD):POINTER;
  10914.                   APIENTRY;  'KERNEL32' name 'HeapAlloc';
  10915.        FUNCTION HeapFree(hHeap:POINTER;dwFlags:LONGWORD;lpMem:POINTER):LONGBOOL;
  10916.                   APIENTRY;  'KERNEL32' name 'HeapFree';
  10917.        PROCEDURE GetSystemTime(VAR lpSystemTime);
  10918.                   APIENTRY;  'KERNEL32' name 'GetSystemTime';
  10919.        FUNCTION GetMessage(VAR lpMsg;ahwnd,wMsgFilterMin,wMsgFilterMax:LONGWORD):LONGBOOL;
  10920.                 APIENTRY; 'USER32' name 'GetMessageA';
  10921.        FUNCTION DispatchMessage(VAR lpMsg):LONGINT;
  10922.                 APIENTRY; 'USER32' name 'DispatchMessageA';
  10923. END;
  10924.  
  10925. PROCEDURE MainDispatchLoop;
  10926. VAR msg:RECORD
  10927.               hwnd:LONGWORD;
  10928.               message:LONGWORD;
  10929.               wParam:LONGWORD;
  10930.               lParam:LONGWORD;
  10931.               time:LONGWORD;
  10932.               pt:RECORD x,y:LONGINT; END;
  10933.          END;
  10934.  
  10935. BEGIN
  10936.      while GetMessage (msg,0, 0, 0) DO DispatchMessage (msg);
  10937. END;
  10938.  
  10939. PROCEDURE ErrorInvalidPointer(Adr:LONGINT);
  10940. VAR e:EInvalidPointer;
  10941. BEGIN
  10942.      e.Create('Invalid pointer operation (EInvalidPointer)');
  10943.      e.CameFromRTL:=TRUE;
  10944.      e.RTLExcptAddr:=POINTER(Adr);
  10945.      raise e;
  10946. END;
  10947.  
  10948. PROCEDURE ErrorOutOfMemory(Adr:LONGINT);
  10949. VAR e:EOutOfMemory;
  10950. BEGIN
  10951.      e.Create('Out of memory (EOutOfMemory)');
  10952.      e.CameFromRTL:=TRUE;
  10953.      e.RTLExcptAddr:=POINTER(Adr);
  10954.      raise e;
  10955. END;
  10956.  
  10957. PROCEDURE ErrorInvalidHeap(Adr:LONGINT);
  10958. VAR
  10959.     e:EInvalidHeap;
  10960. BEGIN
  10961.      e.Create('Heap corrupted or destroyed (EInvalidHeap)');
  10962.      e.CameFromRTL:=TRUE;
  10963.      e.RTLExcptAddr:=POINTER(Adr);
  10964.      raise e;
  10965. END;
  10966.  
  10967. PROCEDURE GetAPIMem(VAR p:POINTER;Size:LONGWORD);
  10968. VAR Adr:LONGINT;
  10969. BEGIN
  10970.      p:=GlobalAlloc(0,Size);  {Allocate fixed memory}
  10971.      IF p=NIL THEN
  10972.      BEGIN
  10973.           ASM
  10974.              MOV EAX,[EBP+4]
  10975.              SUB EAX,5
  10976.              MOV $Adr,EAX
  10977.           END;
  10978.           ErrorOutOfMemory(Adr);
  10979.      END;
  10980. END;
  10981.  
  10982. PROCEDURE FreeAPIMem(p:POINTER;size:LONGWORD);
  10983. VAR Adr:LONGINT;
  10984. BEGIN
  10985.      IF GlobalFree(p)<>NIL THEN
  10986.      BEGIN
  10987.           ASM
  10988.             MOV EAX,[EBP+4]
  10989.             SUB EAX,5
  10990.             MOV $Adr,EAX
  10991.           END;
  10992.           ErrorInvalidPointer(Adr);
  10993.      END;
  10994. END;
  10995.  
  10996.  
  10997. FUNCTION CreateHeap(size:LONGWORD):POINTER;
  10998. VAR
  10999.    p:POINTER;
  11000. BEGIN
  11001.      p:=HeapCreate(0,8192,0);  {Heap growable and serialize}
  11002.      CreateHeap:=p;
  11003. END;
  11004.  
  11005. PROCEDURE DestroyHeap(Heap:POINTER);
  11006. VAR Adr:LONGINT;
  11007. BEGIN
  11008.      IF not HeapDestroy(Heap) THEN
  11009.      BEGIN
  11010.           ASM
  11011.             MOV EAX,[EBP+4]
  11012.             SUB EAX,5
  11013.             MOV $Adr,EAX
  11014.           END;
  11015.           ErrorInvalidPointer(Adr);
  11016.      END;
  11017. END;
  11018.  
  11019. FUNCTION CreateSystemHeap(size:LONGWORD):BOOLEAN;
  11020. BEGIN
  11021.      HeapSize:=Size;
  11022.      MemAvailBytes:=Size;
  11023.      HeapOrg:=CreateHeap(size);
  11024.      HeapPtr:=HeapOrg;
  11025.      HeapEnd:=HeapOrg;
  11026.      inc(HeapEnd,size);
  11027.      FreeList:=NIL;
  11028.      HeapTop:=HeapPtr;
  11029.      CreateSystemHeap:=HeapOrg<>NIL;
  11030. END;
  11031.  
  11032. PROCEDURE DestroySystemHeap;
  11033. BEGIN
  11034.      DestroyHeap(HeapOrg);
  11035.      HeapOrg:=NIL;
  11036.      HeapPtr:=NIL;
  11037.      HeapEnd:=NIL;
  11038.      FreeList:=NIL;
  11039.      HeapTop:=NIL;
  11040.      HeapSize:=0;
  11041. END;
  11042.  
  11043.  
  11044. PROCEDURE NewSystemHeap;  {delete old system heap and create new one}
  11045. VAR OldSize:LONGWORD;
  11046. BEGIN
  11047.     {Free old system heap and generate new}
  11048.     OldSize:=HeapSize;
  11049.     DestroySystemHeap;
  11050.     CreateSystemHeap(OldSize);
  11051. END;
  11052.  
  11053. FUNCTION StdHeapError(size:LONGWORD):INTEGER;
  11054. BEGIN
  11055.      StdHeapError:=0;  {Raise Runtime error}
  11056. END;
  11057.  
  11058. PROCEDURE GETMEM(var pp:Pointer;size:LongWord);
  11059. VAR
  11060.    i:INTEGER;
  11061.    Adr:LONGINT;
  11062. LABEL l;
  11063. BEGIN
  11064.      IF size=0 THEN
  11065.      BEGIN
  11066.           pp:=NIL;
  11067.           exit;
  11068.      END;
  11069. l:
  11070.      pp:=HeapAlloc(HeapOrg,0,(size+7) AND $FFFFFFF8);
  11071.      IF pp=NIL THEN
  11072.      BEGIN
  11073.           i:=HeapError(size);
  11074.           CASE i OF
  11075.              1: pp:=NIL;
  11076.              2: goto l;
  11077.              ELSE
  11078.              BEGIN
  11079.                   ASM
  11080.                      MOV EAX,[EBP+4]
  11081.                      SUB EAX,5
  11082.                      MOV $Adr,EAX
  11083.                   END;
  11084.                   ErrorOutOfMemory(Adr);
  11085.              END;
  11086.           END;
  11087.           exit;
  11088.      END;
  11089.  
  11090.      IF LONGWORD(pp)>LONGWORD(HeapPtr) THEN HeapPtr:=pp;
  11091.      dec(MemAvailBytes,(size+7) AND $FFFFFFF8);
  11092. END;
  11093.  
  11094. PROCEDURE SAVEGETMEM(var pp:Pointer;size:LongWord);
  11095. VAR
  11096.    i:INTEGER;
  11097.    Adr:LONGINT;
  11098. LABEL l;
  11099. BEGIN
  11100.      ASM {!!}
  11101.         PUSH EAX
  11102.         PUSH EBX
  11103.         PUSH ECX
  11104.         PUSH EDX
  11105.         PUSH EDI
  11106.         PUSH ESI
  11107.      END;
  11108. l:
  11109.      pp:=HeapAlloc(HeapOrg,0,(size+7) AND $FFFFFFF8);
  11110.      IF pp=NIL THEN
  11111.      BEGIN
  11112.           i:=HeapError(size);
  11113.           CASE i OF
  11114.              1: pp:=NIL;
  11115.              2: goto l;
  11116.              ELSE
  11117.              BEGIN
  11118.                   ASM
  11119.                      MOV EAX,[EBP+4]
  11120.                      SUB EAX,5
  11121.                      MOV $Adr,EAX
  11122.                   END;
  11123.                   ErrorOutOfMemory(Adr);
  11124.              END;
  11125.           END;
  11126.           exit;
  11127.      END;
  11128.  
  11129.      IF LONGWORD(pp)>LONGWORD(HeapPtr) THEN HeapPtr:=pp;
  11130.      dec(MemAvailBytes,(size+7) AND $FFFFFFF8);
  11131.  
  11132.      ASM {!!}
  11133.         POP ESI
  11134.         POP EDI
  11135.         POP EDX
  11136.         POP ECX
  11137.         POP EBX
  11138.         POP EAX
  11139.      END;
  11140. END;
  11141.  
  11142. PROCEDURE FREEMEM(pp:pointer;size:LongWord);
  11143. VAR
  11144.    i:INTEGER;
  11145.    Adr:LONGINT;
  11146. LABEL l;
  11147. BEGIN
  11148.      IF size=0 THEN exit;
  11149. l:
  11150.      IF not HeapFree(HeapOrg,0,pp) THEN
  11151.      BEGIN
  11152.           i:=HeapError(size);
  11153.           CASE i OF
  11154.              1: pp:=NIL;
  11155.              2: goto l;
  11156.              ELSE
  11157.              BEGIN
  11158.                   ASM
  11159.                      MOV EAX,[EBP+4]
  11160.                      SUB EAX,5
  11161.                      MOV $Adr,EAX
  11162.                   END;
  11163.                   ErrorInvalidPointer(Adr);
  11164.              END;
  11165.           END;
  11166.           exit;
  11167.      END;
  11168.      inc(MemAvailBytes,(size+7) AND $FFFFFFF8);
  11169.      pp:=NIL;
  11170. END;
  11171.  
  11172. PROCEDURE SAVEFREEMEM(pp:pointer;size:LongWord);
  11173. VAR
  11174.    i:INTEGER;
  11175.    Adr:LONGINT;
  11176. LABEL l;
  11177. BEGIN
  11178.      ASM {!!}
  11179.         PUSH EAX
  11180.         PUSH EBX
  11181.         PUSH ECX
  11182.         PUSH EDX
  11183.         PUSH EDI
  11184.         PUSH ESI
  11185.      END;
  11186. l:
  11187.      IF not HeapFree(HeapOrg,0,pp) THEN
  11188.      BEGIN
  11189.           i:=HeapError(size);
  11190.           CASE i OF
  11191.              1: pp:=NIL;
  11192.              2: goto l;
  11193.              ELSE
  11194.              BEGIN
  11195.                   ASM
  11196.                      MOV EAX,[EBP+4]
  11197.                      SUB EAX,5
  11198.                      MOV $Adr,EAX
  11199.                   END;
  11200.                   ErrorInvalidPointer(Adr);
  11201.              END;
  11202.           END;
  11203.           exit;
  11204.      END;
  11205.      inc(MemAvailBytes,(size+7) AND $FFFFFFF8);
  11206.      pp:=NIL;
  11207.  
  11208.      ASM {!!}
  11209.         POP ESI
  11210.         POP EDI
  11211.         POP EDX
  11212.         POP ECX
  11213.         POP EBX
  11214.         POP EAX
  11215.      END;
  11216. END;
  11217.  
  11218. FUNCTION  MaxAvail:LongWord;
  11219. BEGIN
  11220.      MaxAvail:=LONGWORD(HeapEnd)-LONGWORD(HeapPtr);
  11221. END;
  11222.  
  11223.  
  11224. FUNCTION  MemAvail:LongWord;
  11225. BEGIN
  11226.      MemAvail:=MemAvailBytes;
  11227. END;
  11228.  
  11229. PROCEDURE GetSharedMem(VAR pp:Pointer;size:LongWord);
  11230. VAR Adr:LONGINT;
  11231. BEGIN
  11232.      pp:=GlobalAlloc($2000,Size);  {Allocate fixed shared memory}
  11233.      IF pp=NIL THEN
  11234.      BEGIN
  11235.           ASM
  11236.              MOV EAX,[EBP+4]
  11237.              SUB EAX,5
  11238.              MOV $Adr,EAX
  11239.           END;
  11240.           ErrorOutOfMemory(Adr);
  11241.      END;
  11242. END;
  11243.  
  11244. PROCEDURE FreeSharedMem(p:pointer;size:LongWord);
  11245. VAR Adr:LONGINT;
  11246. BEGIN
  11247.      IF GlobalFree(p)<>NIL THEN
  11248.      BEGIN
  11249.           ASM
  11250.              MOV EAX,[EBP+4]
  11251.              SUB EAX,5
  11252.              MOV $Adr,EAX
  11253.           END;
  11254.           ErrorInvalidPointer(Adr);
  11255.      END;
  11256. END;
  11257.  
  11258. PROCEDURE Mark(VAR p:POINTER);
  11259. BEGIN
  11260. END;
  11261.  
  11262. PROCEDURE Release(VAR p:POINTER);
  11263. BEGIN
  11264. END;
  11265.  
  11266. //************************************************************************
  11267. //
  11268. //
  11269. // Error functions
  11270. //
  11271. //
  11272. //************************************************************************
  11273.  
  11274. IMPORTS
  11275.     FUNCTION MessageBox(ahwnd:LONGWORD;CONST lpText,lpCaption:CSTRING;
  11276.                         uType:LONGWORD):LONGWORD;
  11277.                APIENTRY; 'USER32' name 'MessageBoxA';
  11278. END;
  11279.  
  11280. PROCEDURE Halt(Code:LONGWORD);
  11281. VAR
  11282.    cs:CSTRING;
  11283.    cTitle:CSTRING;
  11284. BEGIN
  11285.      ExitCode:=Code;
  11286.  
  11287.      IF ExitCode<>0 THEN
  11288.      BEGIN
  11289.           IF ApplicationType=1 THEN
  11290.           BEGIN
  11291.                cs:='Speed Pascal/2 Runtime error '+tostr(ExitCode);
  11292.                cTitle:='Runtime error';
  11293.                MessageBox(0,cs,ctitle,0);
  11294.           END
  11295.           ELSE Writeln('Speed Pascal/2 Runtime error ',ExitCode);
  11296.      END;
  11297.  
  11298.      ASM
  11299. !exloop:
  11300.         PUSHL *!raddr            //Return adress for ExitProc
  11301.         PUSHL SYSTEM.ExitProc    //ExitProc on Stack
  11302.         RETN32
  11303. !raddr:
  11304.         JMP !exloop              //until termination
  11305.      END;
  11306. END;
  11307.  
  11308. PROCEDURE HaltIntern(Code:LONGWORD);
  11309. VAR
  11310.    cs:CSTRING;
  11311.    cTitle:CSTRING;
  11312. BEGIN
  11313.      ExitCode:=Code;
  11314.  
  11315.      ASM
  11316. !exloop_11:
  11317.         PUSHL *!raddr_11         //Return adress for ExitProc
  11318.         PUSHL SYSTEM.ExitProc    //ExitProc on Stack
  11319.         RETN32
  11320. !raddr_11:
  11321.         JMP !exloop_11           //until termination
  11322.      END;
  11323. END;
  11324.  
  11325. PROCEDURE RunError(Code:LONGWORD);
  11326. BEGIN
  11327.      HaltIntern(Code);
  11328. END;
  11329.  
  11330. //Exception management
  11331.  
  11332.  
  11333. {The standard exception class}
  11334. FUNCTION Exception.GetMessage:STRING;
  11335. BEGIN
  11336.      GetMessage:=FMessage^;
  11337. END;
  11338.  
  11339. PROCEDURE Exception.SetMessage(CONST Value:STRING);
  11340. BEGIN
  11341.      IF FMessage<>NIL THEN
  11342.        FreeMem(FMessage,length(FMessage^)+1);
  11343.      GetMem(FMessage,length(value)+1);
  11344.      FMessage^:=value;
  11345. END;
  11346.  
  11347. CONSTRUCTOR Exception.Create(CONST msg:STRING);
  11348. BEGIN
  11349.      GetMem(FMessage,length(msg)+1);
  11350.      FMessage^:=msg;
  11351. END;
  11352.  
  11353. DESTRUCTOR Exception.Destroy;
  11354. BEGIN
  11355.      IF FMessage<>NIL THEN
  11356.        FreeMem(FMessage,length(FMessage^)+1);
  11357. END;
  11358.  
  11359. //Win95 Exception numbers
  11360.  
  11361. CONST
  11362.      STATUS_WAIT_0                    =$00000000;
  11363.      STATUS_ABANDONED_WAIT_0          =$00000080;
  11364.      STATUS_USER_APC                  =$000000C0;
  11365.      STATUS_TIMEOUT                   =$00000102;
  11366.      STATUS_PENDING                   =$00000103;
  11367.      STATUS_GUARD_PAGE_VIOLATION      =$80000001;
  11368.      STATUS_DATATYPE_MISALIGNMENT     =$80000002;
  11369.      STATUS_BREAKPOINT                =$80000003;
  11370.      STATUS_SINGLE_STEP               =$80000004;
  11371.      STATUS_ACCESS_VIOLATION          =$C0000005;
  11372.      STATUS_IN_PAGE_ERROR             =$C0000006;
  11373.      STATUS_NO_MEMORY                 =$C0000017;
  11374.      STATUS_ILLEGAL_INSTRUCTION       =$C000001D;
  11375.      STATUS_NONCONTINUABLE_EXCEPTION  =$C0000025;
  11376.      STATUS_INVALID_DISPOSITION       =$C0000026;
  11377.      STATUS_ARRAY_BOUNDS_EXCEEDED     =$C000008C;
  11378.      STATUS_FLOAT_DENORMAL_OPERAND    =$C000008D;
  11379.      STATUS_FLOAT_DIVIDE_BY_ZERO      =$C000008E;
  11380.      STATUS_FLOAT_INEXACT_RESULT      =$C000008F;
  11381.      STATUS_FLOAT_INVALID_OPERATION   =$C0000090;
  11382.      STATUS_FLOAT_OVERFLOW            =$C0000091;
  11383.      STATUS_FLOAT_STACK_CHECK         =$C0000092;
  11384.      STATUS_FLOAT_UNDERFLOW           =$C0000093;
  11385.      STATUS_INTEGER_DIVIDE_BY_ZERO    =$C0000094;
  11386.      STATUS_INTEGER_OVERFLOW          =$C0000095;
  11387.      STATUS_PRIVILEGED_INSTRUCTION    =$C0000096;
  11388.      STATUS_STACK_OVERFLOW            =$C00000FD;
  11389.      STATUS_CONTROL_C_EXIT            =$C000013A;
  11390.  
  11391. CONST
  11392.      EXCEPTION_ACCESS_VIOLATION     =STATUS_ACCESS_VIOLATION;
  11393.      EXCEPTION_DATATYPE_MISALIGNMENT=STATUS_DATATYPE_MISALIGNMENT;
  11394.      EXCEPTION_BREAKPOINT           =STATUS_BREAKPOINT;
  11395.      EXCEPTION_SINGLE_STEP          =STATUS_SINGLE_STEP;
  11396.      EXCEPTION_ARRAY_BOUNDS_EXCEEDED=STATUS_ARRAY_BOUNDS_EXCEEDED;
  11397.      EXCEPTION_FLT_DENORMAL_OPERAND =STATUS_FLOAT_DENORMAL_OPERAND;
  11398.      EXCEPTION_FLT_DIVIDE_BY_ZERO   =STATUS_FLOAT_DIVIDE_BY_ZERO;
  11399.      EXCEPTION_FLT_INEXACT_RESULT   =STATUS_FLOAT_INEXACT_RESULT;
  11400.      EXCEPTION_FLT_INVALID_OPERATION=STATUS_FLOAT_INVALID_OPERATION;
  11401.      EXCEPTION_FLT_OVERFLOW         =STATUS_FLOAT_OVERFLOW;
  11402.      EXCEPTION_FLT_STACK_CHECK      =STATUS_FLOAT_STACK_CHECK;
  11403.      EXCEPTION_FLT_UNDERFLOW        =STATUS_FLOAT_UNDERFLOW;
  11404.      EXCEPTION_INT_DIVIDE_BY_ZERO   =STATUS_INTEGER_DIVIDE_BY_ZERO;
  11405.      EXCEPTION_INT_OVERFLOW         =STATUS_INTEGER_OVERFLOW;
  11406.      EXCEPTION_PRIV_INSTRUCTION     =STATUS_PRIVILEGED_INSTRUCTION;
  11407.      EXCEPTION_IN_PAGE_ERROR        =STATUS_IN_PAGE_ERROR;
  11408.      EXCEPTION_ILLEGAL_INSTRUCTION  =STATUS_ILLEGAL_INSTRUCTION;
  11409.      EXCEPTION_NONCONTINUABLE_EXCEPTION=STATUS_NONCONTINUABLE_EXCEPTION;
  11410.      EXCEPTION_STACK_OVERFLOW       =STATUS_STACK_OVERFLOW;
  11411.      EXCEPTION_INVALID_DISPOSITION  =STATUS_INVALID_DISPOSITION;
  11412.      EXCEPTION_GUARD_PAGE           =STATUS_GUARD_PAGE_VIOLATION;
  11413.      CONTROL_C_EXIT                 =STATUS_CONTROL_C_EXIT;
  11414.                                              { debugger (VIA DosDebug) }
  11415.  
  11416.      EXCEPTION_INTERNAL_RTL         =$E0000000;
  11417.  
  11418. {return values}
  11419. CONST
  11420.      EXCEPTION_EXECUTE_HANDLER       = 1;
  11421.      EXCEPTION_CONTINUE_SEARCH       = 0;
  11422.      EXCEPTION_CONTINUE_EXECUTION    =-1;
  11423.  
  11424. VAR
  11425.    RegisterInfo:STRING;
  11426.  
  11427.  
  11428.  
  11429. PROCEDURE NewExceptionFilter(ExcptInfo:PExcptInfo);
  11430. VAR Dummy:PExcptInfo;
  11431. BEGIN
  11432.      ExcptInfo^.Next:=NIL;
  11433.      ExcptInfo^.ExcptObject:=NIL;
  11434.      ASM
  11435.         MOV EDI,$ExcptInfo
  11436.         ADD EDI,8
  11437.         MOV EAX,[EBP+0]     //old EBP
  11438.         MOV [EDI+0],EAX
  11439.         MOV EAX,EBP
  11440.         ADD EAX,12         //Old ESP
  11441.         MOV [EDI+4],EAX
  11442.         FSTCW [EDI+8]      //Old FPU Control
  11443.      END;
  11444.  
  11445.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  11446.  
  11447.      IF ExcptList=NIL THEN
  11448.      BEGIN
  11449.           ExcptList:=ExcptInfo;
  11450.           ExcptList^.Last:=NIL;
  11451.      END
  11452.      ELSE
  11453.      BEGIN
  11454.           dummy:=ExcptList;
  11455.           WHILE dummy^.next<>NIL DO dummy:=dummy^.Next;
  11456.           dummy^.Next:=ExcptInfo;
  11457.           dummy^.Next^.Last:=Dummy;
  11458.      END;
  11459.  
  11460.      ReleaseMutex(ExcptMutex);
  11461. END;
  11462.  
  11463. PROCEDURE ReleaseExceptionFilter(ExcptInfo:PExcptInfo);
  11464. VAR Dummy:PExcptInfo;
  11465. LABEL l;
  11466. BEGIN
  11467.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  11468.  
  11469.      dummy:=ExcptList;
  11470.      WHILE dummy<>NIL DO
  11471.      BEGIN
  11472.           IF dummy=ExcptInfo THEN
  11473.           BEGIN
  11474.                IF dummy^.Last=NIL THEN
  11475.                BEGIN
  11476.                     ExcptList:=dummy^.Next;
  11477.                     IF ExcptList<>NIL THEN ExcptList^.Last:=NIL;
  11478.                END
  11479.                ELSE
  11480.                BEGIN
  11481.                     IF dummy^.Next<>NIL THEN
  11482.                         dummy^.Next^.Last:=dummy^.Last;
  11483.                     dummy^.Last^.Next:=dummy^.Next;
  11484.                END;
  11485.                goto l;
  11486.           END;
  11487.           dummy:=dummy^.Next;
  11488.      END;
  11489. l:
  11490.      ReleaseMutex(ExcptMutex);
  11491. END;
  11492.  
  11493. {The exception handler. Incoming exceptions will come here first}
  11494. FUNCTION ExcptHandler(VAR ExceptionInfo:EXCEPTION_POINTERS):LONGINT;APIENTRY;
  11495. VAR Dummy:PExcptInfo;
  11496.     ExcptAddr:POINTER;
  11497.     Found:PExcptInfo;
  11498.     Objekt:Exception;
  11499.     OldESP,OldEBP,OldFPUControl:LONGWORD;
  11500.     ThreadId:LONGWORD;
  11501. LABEL l,l1;
  11502. BEGIN
  11503.      IF ExcptList=NIL THEN
  11504.      BEGIN
  11505. l:
  11506.           result:=EXCEPTION_CONTINUE_SEARCH;  //terminate process
  11507.           exit;
  11508.      END
  11509.      ElSE
  11510.      BEGIN
  11511.           IF ExceptionInfo.ExceptionRecord^.ExceptionFlags=EXCEPTION_NONCONTINUABLE
  11512.             THEN goto l; {dont handle}
  11513.  
  11514.           ThreadId:=GetCurrentThreadId;
  11515.  
  11516.           {Search exception handler}
  11517.           WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  11518.  
  11519.           ExcptAddr:=ExceptionInfo.ExceptionRecord^.ExceptionAddress;
  11520.  
  11521.           dummy:=ExcptList;
  11522.           WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  11523.           Found:=NIL;
  11524.           WHILE dummy<>NIL DO
  11525.           BEGIN
  11526.                {IF LONGWORD(ExcptAddr)>=LONGWORD(dummy^.TryAddr) THEN
  11527.                  IF LONGWORD(ExcptAddr)<=LONGWORD(dummy^.ExcptAddr) THEN
  11528.                    Found:=dummy;}
  11529.                IF dummy^.ThreadId=ThreadId THEN
  11530.                BEGIN
  11531.                     Found:=dummy;
  11532.                     goto l1;
  11533.                END;
  11534.  
  11535.                dummy:=dummy^.Last;
  11536.           END;
  11537. l1:
  11538.           IF Found=NIL THEN
  11539.             IF ExcptList<>NIL THEN Found:=ExcptList;
  11540.  
  11541.           ReleaseMutex(ExcptMutex);
  11542.  
  11543.           IF Found=NIL THEN goto l;
  11544.  
  11545.           Registerinfo:= #13#10'at CS:EIP  ='+
  11546.                     ToHex(LONGWORD(ExceptionInfo.ContextRecord^.SegCS))+':'
  11547.                     +ToHex(LONGWORD(ExcptAddr));
  11548.      END;
  11549.  
  11550.      //Handle all hardware exceptions
  11551.      //all other exceptions will be notified by an exception class
  11552.      CASE ExceptionInfo.ExceptionRecord^.ExceptionCode OF
  11553.               EXCEPTION_BREAKPOINT:
  11554.                 Found^.ExcptObject:=EBreakPoint.Create('Breakpoint exception (EBreakPoint) occured'+
  11555.                                                   RegisterInfo);
  11556.               EXCEPTION_STACK_OVERFLOW:
  11557.                 Found^.ExcptObject:=EStackFault.Create('Stack fault exception (EStackFault) occured'+
  11558.                                                   RegisterInfo);
  11559.               EXCEPTION_ACCESS_VIOLATION:
  11560.                 Found^.ExcptObject:=EGPFault.Create('Access violation exception (EGPFault) occured'+
  11561.                                                RegisterInfo);
  11562.               EXCEPTION_IN_PAGE_ERROR:
  11563.                 Found^.ExcptObject:=EPageFault.Create('Page fault exception (EPageFault) occured'+
  11564.                                                  RegisterInfo);
  11565.               EXCEPTION_ILLEGAL_INSTRUCTION,EXCEPTION_PRIV_INSTRUCTION:
  11566.                 Found^.ExcptObject:=EInvalidOpCode.Create('Invalid instruction exception (EInvalidOpCode) occured'+
  11567.                                                  RegisterInfo);
  11568.               EXCEPTION_SINGLE_STEP:
  11569.                 Found^.ExcptObject:=ESingleStep.Create('Single step exception (ESingleStep) occured'+
  11570.                                                  RegisterInfo);
  11571.               EXCEPTION_INT_DIVIDE_BY_ZERO:
  11572.                 Found^.ExcptObject:=EDivByZero.Create('Integer divide by zero exception (EDivByZero) occured'+
  11573.                                                  RegisterInfo);
  11574.               EXCEPTION_INT_OVERFLOW:
  11575.                 Found^.ExcptObject:=EIntOverFlow.Create('Integer overflow exception (EIntOverFlow) occured'+
  11576.                                                  RegisterInfo);
  11577.               EXCEPTION_FLT_DIVIDE_BY_ZERO:
  11578.                 Found^.ExcptObject:=EZeroDivide.Create('Float zero divide exception (EZeroDivide) occured'+
  11579.                                                  RegisterInfo);
  11580.               EXCEPTION_FLT_INVALID_OPERATION:
  11581.                 Found^.ExcptObject:=EInvalidOp.Create('Float invalid operation exception (EInvalidOp) occured'+
  11582.                                                  RegisterInfo);
  11583.               EXCEPTION_FLT_OVERFLOW:
  11584.                 Found^.ExcptObject:=EOverFlow.Create('Float overflow exception (EOverFlow) occured'+
  11585.                                                  RegisterInfo);
  11586.               EXCEPTION_FLT_UNDERFLOW:
  11587.                 Found^.ExcptObject:=EUnderFlow.Create('Float underflow exception (EUnderFlow) occured'+
  11588.                                                  RegisterInfo);
  11589.               EXCEPTION_FLT_DENORMAL_OPERAND,EXCEPTION_FLT_INEXACT_RESULT,
  11590.               EXCEPTION_FLT_STACK_CHECK:
  11591.                  Found^.ExcptObject:=EMathError.Create('General float exception (EMathError) occured'+
  11592.                                                  RegisterInfo);
  11593.               EXCEPTION_INTERNAL_RTL:
  11594.               BEGIN
  11595.                    result:=EXCEPTION_CONTINUE_EXECUTION;
  11596.                    exit;
  11597.               END;
  11598.               ELSE goto l; {Don't handle}
  11599.      END; {case}
  11600.  
  11601.      {Win95 generated exception}
  11602.      Found^.ExcptObject.ReportRecord:=ExceptionInfo.ExceptionRecord^;
  11603.      Found^.ExcptObject.ExcptNum:=ExceptionInfo.ExceptionRecord^.ExceptionCode;
  11604.      Found^.ExcptObject.ContextRecord:=ExceptionInfo.ContextRecord^;
  11605.      Found^.ExcptObject.ExcptAddr:=ExcptAddr;
  11606.  
  11607.      {Jump to the label set by try}
  11608.      ExceptionInfo.ContextRecord^.EAX:=LONGWORD(Found^.ExcptObject);
  11609.      ExceptionInfo.ContextRecord^.EIP:=LONGWORD(Found^.ExcptAddr);
  11610.      ExceptionInfo.ContextRecord^.EBP:=Found^.OldEBP;
  11611.      ExceptionInfo.ContextRecord^.ESP:=Found^.OldESP;
  11612.      ExceptionInfo.ContextRecord^.FloatSave.ControlWord:=Found^.OldFPUControl;
  11613.      result:=EXCEPTION_CONTINUE_EXECUTION;  //run except handling
  11614. END;
  11615.  
  11616. IMPORTS
  11617.      PROCEDURE RaiseExceptionAPI(dwExceptionCode,dwExceptionFlags:LONGWORD;
  11618.                               nNumberOfArguments:LONGWORD;VAR lpArguments);
  11619.                   APIENTRY;  'KERNEL32' name 'RaiseException';
  11620. END;
  11621.  
  11622. PROCEDURE ExcptRunError(e:Exception);
  11623. VAR
  11624.    s:STRING;
  11625.    cs:CSTRING;
  11626.    cTitle:CSTRING;
  11627.    Arguments:ARRAY[0..1] OF LONGWORD;
  11628. BEGIN
  11629.      try
  11630.         IF e.CameFromRTL THEN IF not e.Nested THEN
  11631.         BEGIN
  11632.              e.Nested:=TRUE;
  11633.              Arguments[0]:=LONGWORD(e.RTLExcptAddr);
  11634.              Arguments[1]:=LONGWORD(e.FMessage);
  11635.              RaiseExceptionAPI(EXCEPTION_INTERNAL_RTL,0,2,Arguments);
  11636.         END;
  11637.      finally
  11638.         e.ExcptAddr:=e.RTLExcptAddr;
  11639.      end;
  11640.  
  11641.      IF POINTER(e.ExcptAddr)<>NIL THEN
  11642.        s:='Exception occured: '+e.Message+' at '+tohex(LONGWORD(e.ExcptAddr))+
  11643.            #13#10'Program is terminated.'
  11644.      ELSE
  11645.        s:='Exception occured: '+e.Message+
  11646.            #13#10'Program is terminated.';
  11647.  
  11648.      IF ApplicationType=1 THEN
  11649.      BEGIN
  11650.           cs:=s;
  11651.           cTitle:='Exception occured';
  11652.           MessageBox(0,cs,ctitle,0);
  11653.      END
  11654.      ELSE Writeln(s);
  11655.      Halt;
  11656. END;
  11657.  
  11658. PROCEDURE RaiseException(objekt:Exception;adress:LONGWORD);
  11659. VAR ExcptAddr:POINTER;
  11660.     dummy,Found:PExcptInfo;
  11661.     ThreadId:LONGWORD;
  11662. LABEL l1;
  11663. BEGIN
  11664.      IF Adress=0 THEN
  11665.      BEGIN
  11666.           ASM
  11667.              MOV EAX,[EBP+4]
  11668.              MOV $Adress,EAX
  11669.           END;
  11670.      END;
  11671.  
  11672.      ThreadId:=GetCurrentThreadId;
  11673.  
  11674.      {Search exception handler}
  11675.      WaitForSingleObject(ExcptMutex,$FFFFFFFF);
  11676.  
  11677.      ExcptAddr:=POINTER(Adress);
  11678.  
  11679.      dummy:=ExcptList;
  11680.      WHILE dummy^.Next<>NIL DO dummy:=dummy^.Next;
  11681.      Found:=NIL;
  11682.      WHILE dummy<>NIL DO
  11683.      BEGIN
  11684.           {IF LONGWORD(ExcptAddr)>=LONGWORD(dummy^.TryAddr) THEN
  11685.             IF LONGWORD(ExcptAddr)<=LONGWORD(dummy^.ExcptAddr) THEN
  11686.                Found:=dummy;}
  11687.           IF dummy^.ThreadId=ThreadId THEN
  11688.           BEGIN
  11689.                Found:=dummy;
  11690.                goto l1;
  11691.           END;
  11692.  
  11693.           dummy:=dummy^.Last;
  11694.      END;
  11695. l1:
  11696.      IF Found=NIL THEN
  11697.         IF ExcptList<>NIL THEN Found:=ExcptList;
  11698.  
  11699.      ReleaseMutex(ExcptMutex);
  11700.  
  11701.      IF Found=NIL THEN ExcptRunError(Objekt);
  11702.  
  11703.      Found^.ExcptObject:=Objekt;
  11704.      ASM
  11705.         MOV EAX,$Objekt
  11706.         MOV EDI,$Found
  11707.         PUSHL [EDI+8]    //old EBP
  11708.         POP EBP
  11709.         MOV ESP,[EDI+12] //old ESP
  11710.         FLDCW [EDI+16]   //old FPU Control Word
  11711.  
  11712.         JMP [EDI+4]        //jump into exception handler
  11713.      END;
  11714. END;
  11715.  
  11716. PROCEDURE RaiseExceptionAgain(e:Exception);
  11717. BEGIN
  11718.      RaiseException(e,LONGWORD(e.ExcptAddr));
  11719. END;
  11720.  
  11721. PROCEDURE Beep(Freq,duration:LONGWORD);
  11722. BEGIN
  11723.      ASM
  11724.          PUSHL $duration
  11725.          PUSHL $freq
  11726.          CALLDLL KERNEL32,'Beep'
  11727.      END;
  11728. END;
  11729.  
  11730. //************************************************************************
  11731. // CLASS support
  11732. //************************************************************************
  11733.  
  11734. {Constructor for all classes}
  11735. CONSTRUCTOR TObject.Create;
  11736. BEGIN
  11737.      InitInstance(POINTER(SELF));
  11738. END;
  11739.  
  11740. {Destructor for all classes}
  11741. DESTRUCTOR TObject.Destroy;
  11742. BEGIN
  11743. END;
  11744.  
  11745. {Frees an instance of a class}
  11746. PROCEDURE TObject.Free;
  11747. BEGIN
  11748.      IF POINTER(SELF)<>NIL THEN Self.Destroy;
  11749. END;
  11750.  
  11751. {frees an Instance of a class}
  11752. PROCEDURE TObject.FreeInstance;
  11753. BEGIN
  11754.      {FreeInstance is normally called by the Destructor to
  11755.       deallocate memory for the object. In Speed-Pascal the
  11756.       memory deallocation is done by the compiler thus
  11757.       overriding this method has no effect}
  11758. END;
  11759.  
  11760. {Gets class information from the ClassInfo structure}
  11761. CLASS FUNCTION TObject.GetClassInfo: Pointer;
  11762. BEGIN
  11763.      ASM
  11764.         MOV EAX,$!ClassInfo
  11765.         MOV EAX,[EAX+4]
  11766.         MOV $!FUNCRESULT,EAX
  11767.      END;
  11768. END;
  11769.  
  11770. {Returns size of an instance of a class of TObject or a class derived
  11771.  from TObject from the ClassInfo structure}
  11772. CLASS FUNCTION TObject.InstanceSize:LONGWORD;
  11773. BEGIN
  11774.      ASM
  11775.         MOV EAX,0
  11776.         MOV EDI,$!ClassInfo //Get Object pointer
  11777.         CMP EDI,0
  11778.         JE !InstanceSize_NoInfo
  11779.         MOV EDI,[EDI+4]     //Get class info pointer
  11780.         CMP EDI,0
  11781.         JE !InstanceSize_NoInfo
  11782.         MOV EAX,[EDI+0]     //Get class size
  11783. !InstanceSize_NoInfo:
  11784.         MOV $!FUNCRESULT,EAX
  11785.      END;
  11786. END;
  11787.  
  11788. {Generates a new instance of a class from the ClassInfo structure
  11789.  and calls the constructor for that class}
  11790. CLASS FUNCTION TObject.NewInstance: TObject;
  11791. BEGIN
  11792.      {NewInstance is normally called by the Constructor to
  11793.       allocate memory for the object. In Speed-Pascal the
  11794.       memory allocation is done by the compiler thus
  11795.       overriding this method has no effect}
  11796. END;
  11797.  
  11798. {Initializes an Instance from the ClassInfo structure given by Instance}
  11799. CLASS FUNCTION TObject.InitInstance(Instance: Pointer): TObject;
  11800. BEGIN
  11801.      {Fill the object with zeros. Object must be initialized with Create !}
  11802.      inc(Instance,4);
  11803.      FillChar(Instance^,InstanceSize-4,0);
  11804.      dec(Instance,4);
  11805.      InitInstance:=TObject(Instance);
  11806. END;
  11807.  
  11808. CLASS FUNCTION TObject.ClassName: STRING;
  11809. VAR ps:^STRING;
  11810. BEGIN
  11811.      ASM
  11812.         MOV EAX,0
  11813.         MOV EDI,$!ClassInfo //Get Object pointer
  11814.         CMP EDI,0
  11815.         JE !ClassName_NoInfo
  11816.         MOV EDI,[EDI+4]     //Get class info pointer
  11817.         CMP EDI,0
  11818.         JE !ClassName_NoInfo
  11819.         LEA EDI,[EDI+16]    //points to class name
  11820.         MOV EAX,EDI
  11821. !ClassName_NoInfo:
  11822.         MOV $ps,EAX
  11823.      END;
  11824.      IF ps<>NIL THEN ClassName:=ps^
  11825.      ELSE ClassName:='';
  11826. END;
  11827.  
  11828. CLASS FUNCTION TObject.ClassUnit:STRING;
  11829. VAR ps:^STRING;
  11830. BEGIN
  11831.      ASM
  11832.         MOV EAX,0
  11833.         MOV EDI,$!ClassInfo //Get Object pointer
  11834.         CMP EDI,0
  11835.         JE !ClassUnit_NoInfo
  11836.         MOV EDI,[EDI+4]     //Get class info pointer
  11837.         CMP EDI,0
  11838.         JE !ClassUnit_NoInfo
  11839.         LEA EDI,[EDI+16]    //points to class name
  11840.         MOVZXB EAX,[EDI+0]  //overreas class name
  11841.         ADD EDI,EAX
  11842.         INC EDI
  11843.         MOV EAX,EDI
  11844. !ClassUnit_NoInfo:
  11845.         MOV $ps,EAX
  11846.      END;
  11847.      IF ps<>NIL THEN ClassUnit:=ps^
  11848.      ELSE ClassUnit:='';
  11849. END;
  11850.  
  11851. {Default handler for messages}
  11852. PROCEDURE TObject.DefaultHandler(VAR Message);
  11853. BEGIN
  11854.      {Do nothing here !}
  11855. END;
  11856.  
  11857. {Default frame handler for messages}
  11858. PROCEDURE TObject.DefaultFrameHandler(VAR Message);
  11859. BEGIN
  11860.      {Do nothing here !}
  11861. END;
  11862.  
  11863. {Dispatches dynamic methods}
  11864. PROCEDURE TObject.Dispatch(VAR Message);
  11865. BEGIN
  11866.      {Check if there's a DMT entry for the message
  11867.       The message ID MUST be the first DWORD of Message !!
  11868.       If an entry is found call the message handler}
  11869.      ASM
  11870.         MOV EDI,$Message
  11871.         MOV EAX,[EDI+0]  //Get message index
  11872.         MOV EDI,$SELF    //Get Object
  11873.         MOV EDI,[EDI+0]  //Get VMT pointer
  11874.         MOV ESI,[EDI+0]  //Get DMT pointer
  11875.         MOV ECX,[ESI+0]  //Get number of DMT entries
  11876.         ADD ESI,4
  11877.         CMP ECX,0
  11878.         JE !EndeDispatch
  11879. !DLoop:
  11880.         CMP [ESI+0],EAX
  11881.         JNE !ELoop
  11882.  
  11883.         //Message found
  11884.         PUSHD $Message   //Message Parameter
  11885.         PUSHD $SELF      //SELF Pointer to object
  11886.         MOV EAX,[ESI+4]  //get VMT index
  11887.         CALLN32 [EDI+EAX*4]  //call VMT method
  11888.         LEAVE
  11889.         RETN32 8
  11890. !ELoop:
  11891.         ADD ESI,8        //Next DMT entry
  11892.         LOOP !DLoop      //try to find next
  11893. !EndeDispatch:
  11894.      END; {case}
  11895.  
  11896.      {other case call the Default handler}
  11897.      DefaultHandler(Message);
  11898. END;
  11899.  
  11900. {Dispatches dynamic methods}
  11901. PROCEDURE TObject.DispatchCommand(VAR Message;Command:LONGWORD);
  11902. BEGIN
  11903.      {Check if there's a DMT entry for the WM_COMMAND message}
  11904.      ASM
  11905.         MOV EDI,$Message
  11906.         MOV EAX,$Command //Get message index
  11907.         MOV EDI,$SELF    //Get Object
  11908.         MOV EDI,[EDI+0]  //Get VMT pointer
  11909.         MOV ESI,[EDI+0]  //Get DMT pointer
  11910.         MOV ECX,[ESI+0]  //Get number of DMT entries
  11911.         ADD ESI,4
  11912.         CMP ECX,0
  11913.         JE !EndeDispatch_2
  11914. !DLoop_2:
  11915.         CMP [ESI+0],EAX
  11916.         JNE !ELoop_2
  11917.  
  11918.         //Message found
  11919.         PUSHD $Message   //Message Parameter
  11920.         PUSHD $SELF      //SELF Pointer to object
  11921.         MOV EAX,[ESI+4]  //get VMT index
  11922.         CALLN32 [EDI+EAX*4]  //call VMT method
  11923.         LEAVE
  11924.         RETN32 8
  11925. !ELoop_2:
  11926.         ADD ESI,8        //Next DMT entry
  11927.         LOOP !DLoop_2    //try to find next
  11928. !EndeDispatch_2:
  11929.      END; {case}
  11930.  
  11931.      {other case call the Default handler}
  11932.      DefaultHandler(Message);
  11933. END;
  11934.  
  11935. {Dispatches dynamic methods}
  11936. PROCEDURE TObject.FrameDispatch(VAR Message);
  11937. BEGIN
  11938.      {Check if there's a DMT entry for the message
  11939.       The message ID MUST be the first DWORD of Message !!
  11940.       If an entry is found call the message handler}
  11941.      ASM
  11942.         MOV EDI,$Message
  11943.         MOV EAX,[EDI+0]  //Get message index
  11944.         MOV EDI,$SELF    //Get Object
  11945.         MOV EDI,[EDI+0]  //Get VMT pointer
  11946.         MOV ESI,[EDI+0]  //Get DMT pointer
  11947.         MOV ECX,[ESI+0]  //Get number of DMT entries
  11948.         ADD ESI,4
  11949.         CMP ECX,0
  11950.         JE !EndeDispatch_1
  11951. !DLoop_1:
  11952.         CMP [ESI+0],EAX
  11953.         JNE !ELoop_1
  11954.  
  11955.         //Message found
  11956.         PUSHD $Message   //Message Parameter
  11957.         PUSHD $SELF      //SELF Pointer to object
  11958.         MOV EAX,[ESI+4]  //get VMT index
  11959.         CALLN32 [EDI+EAX*4]  //call VMT method
  11960.         LEAVE
  11961.         RETN32 8
  11962. !ELoop_1:
  11963.         ADD ESI,8        //Next DMT entry
  11964.         LOOP !DLoop_1    //try to find next
  11965. !EndeDispatch_1:
  11966.      END; {case}
  11967.  
  11968.      {other case call the Default handler}
  11969.      DefaultFrameHandler(Message);
  11970. END;
  11971.  
  11972. ASSEMBLER
  11973.  
  11974. !GetMethodName PROC NEAR32
  11975.         //INPUT : EAX adress to find
  11976.         //        EDI VMT pointer
  11977.         //OUTPUT: String adress or NIL in EAX
  11978.  
  11979.         MOV EDI,[EDI+4]     //Get class info pointer
  11980.         LEA EDI,[EDI+16]    //points to class name
  11981.         MOVZXB EBX,[EDI+0]  //get Class name length
  11982.         INC EDI
  11983.         ADD EDI,EBX
  11984.         MOVZXB EBX,[EDI+0]  //get Unit name length
  11985.         INC EDI
  11986.         ADD EDI,EBX         //points on first method adress
  11987. !MLoop:
  11988.         CMPD [EDI+0],0      //end of list ??
  11989.         JE !MELoop
  11990.  
  11991.         CMP [EDI+0],EAX     //Method found
  11992.         JNE !MWLoop
  11993.  
  11994.         //Method found
  11995.         LEA EAX,[EDI+4]     //points to Method name
  11996.         JMP !MEFLoop
  11997. !MWLoop:
  11998.         ADD EDI,4
  11999.         MOVZXB EBX,[EDI+0]  //get method name length
  12000.         INC EDI
  12001.         ADD EDI,EBX         //points to next method address
  12002.         JMP !MLoop          //try next
  12003. !MELoop:
  12004.         MOV EAX,0           //not found
  12005. !MEFLoop:
  12006.         RETN32
  12007. !GetMethodName ENDP
  12008.  
  12009. END;
  12010.  
  12011. {returns the Method Name for an adress or an empty string}
  12012. CLASS FUNCTION TObject.MethodName(Address: POINTER): STRING;
  12013. VAR ps:^STRING;
  12014.     Class_Info:POINTER;
  12015. BEGIN
  12016.      ps:=NIL;  {Default}
  12017.      ASM
  12018.         MOV EDI,$!ClassInfo    //get Class info pointer
  12019.         MOV $Class_Info,EDI    //get address to find
  12020. !MAgain:
  12021.         MOV EDI,$Class_Info
  12022.         MOV EAX,$Address
  12023.         CALLN32 !GetMethodName //search for method
  12024.         CMP EAX,0
  12025.         JE !Nfound
  12026.  
  12027.         //Method was found
  12028.         MOV $ps,EAX
  12029.         JMP !Mfound
  12030. !Nfound:
  12031.         //Method not found, check parent
  12032.         MOV EDI,$Class_Info   //Actual class
  12033.         MOV EDI,[EDI+4]       //Get class info pointer
  12034.         MOV EAX,[EDI+4]       //Get parent class adress info
  12035.         MOV $Class_Info,EAX
  12036.         CMP EAX,0
  12037.         JNE !MAgain           //Try again if parents exist
  12038. !Mfound:
  12039.      END;
  12040.  
  12041.      IF ps=NIL THEN MethodName:=''
  12042.      ELSE MethodName:=ps^;
  12043. END;
  12044.  
  12045. ASSEMBLER
  12046.  
  12047. !GetMethodAddress PROC NEAR32
  12048.         //INPUT : ESI pointer to string to find
  12049.         //        EDI VMT pointer
  12050.         //OUTPUT: method pointer or NIL in EAX
  12051.  
  12052.         MOV EDI,[EDI+4]     //Get class info pointer
  12053.         LEA EDI,[EDI+16]    //points to class name
  12054.         MOVZXB EBX,[EDI+0]  //get Class name length
  12055.         INC EDI
  12056.         ADD EDI,EBX
  12057.         MOVZXB EBX,[EDI+0]  //get Unit name length
  12058.         INC EDI
  12059.         ADD EDI,EBX         //points on first method adress
  12060.         MOV CL,[ESI+0]      //get method string length
  12061. !ALoop:
  12062.         MOV EDX,EDI         //save pointer
  12063.         MOV EBX,ESI         //save pointer
  12064.         CMPD [EDI+0],0      //end of list ??
  12065.         JE !AELoop
  12066.         ADD EDI,4           //onto name
  12067.  
  12068.         CMP CL,[EDI+0]      //length correct
  12069.         JNE !AWLoop
  12070.  
  12071.         //length was correct
  12072.         MOVZX ECX,CL        //String length
  12073.         INC EDI
  12074.         INC ESI
  12075.         CLD
  12076.         REP
  12077.         CMPSB               //Compare strings
  12078.         JNE !AWLoop
  12079.  
  12080.         //Method was found
  12081.         MOV EAX,[EDX+0]     //get method adress
  12082.         JMP !AEFLoop
  12083. !AWLoop:
  12084.         MOV EDI,EDX         //get old pointer
  12085.         MOV ESI,EBX         //get old pointer
  12086.         ADD EDI,4
  12087.         MOVZXB EAX,[EDI+0]  //get method name length
  12088.         INC EDI
  12089.         ADD EDI,EAX         //points to next method address
  12090.         MOV CL,[ESI+0]
  12091.         JMP !ALoop          //try next
  12092. !AELoop:
  12093.         MOV EAX,0           //not found
  12094. !AEFLoop:
  12095.         RETN32
  12096. !GetMethodAddress ENDP
  12097.  
  12098.  
  12099. END;
  12100.  
  12101. {returns the adress of a method or NIL}
  12102. CLASS FUNCTION TObject.MethodAddress(CONST Name: STRING): POINTER;
  12103. VAR
  12104.    Adr:POINTER;
  12105.    Class_Info:POINTER;
  12106. BEGIN
  12107.      Adr:=NIL;  {Default}
  12108.  
  12109.      ASM
  12110.         MOV EDI,$!ClassInfo    //get Class info pointer
  12111.         MOV $Class_Info,EDI    //get address to find
  12112. !AAgain_1:
  12113.         MOV EDI,$Class_Info
  12114.         MOV ESI,$Name
  12115.         CALLN32 !GetMethodAddress //search for method
  12116.         CMP EAX,0
  12117.         JE !ANfound
  12118.  
  12119.         //Method was found
  12120.         MOV $Adr,EAX
  12121.         JMP !AMfound
  12122. !ANfound:
  12123.         //Method not found, check parent
  12124.         MOV EDI,$Class_Info   //Actual class
  12125.         MOV EDI,[EDI+4]       //Get class info pointer
  12126.         MOV EAX,[EDI+4]       //Get parent class adress info
  12127.         MOV $Class_Info,EAX
  12128.         CMP EAX,0
  12129.         JNE !AAgain_1         //Try again if parents exist
  12130. !AMfound:
  12131.      END;
  12132.  
  12133.      MethodAddress:=Adr;
  12134. END;
  12135.  
  12136. ASSEMBLER
  12137.  
  12138. !GetFieldOffset PROC NEAR32
  12139.                //INPUT : ESI pointer to string to find
  12140.                //        EDI VMT pointer
  12141.                //OUTPUT: field offset or 0 in EAX
  12142.  
  12143.                MOV EDI,[EDI+8]     //Field info start
  12144.                MOV AL,[ESI+0]      //get method string length
  12145.                INC ESI
  12146. !FLoop:
  12147.                MOV EDX,EDI         //save pointer
  12148.                MOV EBX,ESI         //save pointer
  12149.                CMPD [EDI+0],0      //end of list ??
  12150.                JE !FELoop
  12151.  
  12152.                CMP AL,[EDI+4]      //length correct
  12153.                JNE !FWLoop
  12154.  
  12155.                //length was correct
  12156.                MOVZX ECX,AL        //String length
  12157.                ADD EDI,5           //onto first char
  12158.                CLD
  12159.                REP
  12160.                CMPSB               //Compare strings
  12161.                JNE !FWLoop
  12162.  
  12163.                //Method was found
  12164.                MOV EAX,[EDX+0]     //get method adress
  12165.                JMP !FEFLoop
  12166. !FWLoop:
  12167.                MOV EDI,EDX         //get old pointer
  12168.                MOV ESI,EBX         //get old pointer
  12169.                ADD EDI,4
  12170.                MOVZXB EBX,[EDI+0]  //get method name length
  12171.                INC EDI
  12172.                ADD EDI,EBX         //points to next method address
  12173.                JMP !FLoop          //try next
  12174. !FELoop:
  12175.                MOV EAX,0           //not found
  12176. !FEFLoop:
  12177.                RETN32
  12178. !GetFieldOffset ENDP
  12179.  
  12180. END;
  12181.  
  12182.  
  12183. FUNCTION TObject.FieldAddress(Name: STRING): POINTER;
  12184. VAR
  12185.    Adr:POINTER;
  12186.    Class_Info:POINTER;
  12187. BEGIN
  12188.      Adr:=NIL;  {Default}
  12189.      UpcaseStr(Name);
  12190.  
  12191.      ASM
  12192.         MOV EDI,$SELF           //get object pointer
  12193.         MOV EDI,[EDI+0]         //get VMT Pointer
  12194.         MOV EDI,[EDI+4]         //get Class info pointer
  12195.         MOV $Class_Info,EDI     //get address to find
  12196. !FAgain:
  12197.         MOV EDI,$Class_Info
  12198.         LEA ESI,$Name
  12199.         CALLN32 !GetFieldOffset //search for method
  12200.         CMP EAX,0
  12201.         JE !FNfound
  12202.  
  12203.         //Method was found
  12204.         MOV EBX,$SELF
  12205.         MOV $Adr,EBX
  12206.         ADD $Adr,EAX
  12207.         JMP !FMfound
  12208. !FNfound:
  12209.         //Method not found, check parent
  12210.         MOV EDI,$Class_Info     //Actual class
  12211.         MOV EDI,[EDI+4]         //Get class info pointer
  12212.         CMP EDI,0
  12213.         JE !FMfound             //not found
  12214.         MOV EAX,[EDI+4]         //Get parent class adress info
  12215.         MOV $Class_Info,EAX
  12216.         CMP EAX,0
  12217.         JNE !FAgain             //Try again if parents exist
  12218. !FMfound:
  12219.      END;
  12220.  
  12221.      FieldAddress:=Adr;
  12222. END;
  12223.  
  12224. {returns type of a class}
  12225. CLASS FUNCTION TObject.ClassType: TClass;
  12226. BEGIN
  12227.      ASM
  12228.         MOV EAX,$!ClassInfo
  12229.         MOV $!FUNCRESULT,EAX
  12230.      END;
  12231. END;
  12232.  
  12233. {Returns Parent Class pointer of the Object or NIL}
  12234. CLASS FUNCTION TObject.ClassParent: TClass;
  12235. BEGIN
  12236.      ASM
  12237.         MOV EAX,0
  12238.         MOV EDI,$!ClassInfo    //get Class info pointer
  12239.         CMP EDI,0
  12240.         JE !ClassParent_NoInfo
  12241.         MOV EDI,[EDI+4]        //points to Class information
  12242.         CMP EDI,0
  12243.         JE !ClassParent_NoInfo
  12244.         MOV EAX,[EDI+4]        //Get Parent Class pointer
  12245. !ClassParent_NoInfo:
  12246.         MOV $!FUNCRESULT,EAX
  12247.      END;
  12248. END;
  12249.  
  12250. {returns true if the Class is derived from AClass, otherwise FALSE}
  12251. CLASS FUNCTION TObject.InheritsFrom(AClass: TClass): BOOLEAN;
  12252. BEGIN
  12253.      ASM
  12254.         MOV EDI,$!ClassInfo    //get Class info pointer
  12255.         MOV EAX,$AClass        //class to check
  12256.         MOVD $!FUNCRESULT,0    //Default
  12257. !ILoop:
  12258.         CMP EDI,EAX            //is it this class ?
  12259.         JNE !IWLoop
  12260.  
  12261.         //The Class was found
  12262.         MOVD $!FUNCRESULT,1
  12263.         JMP !IELoop
  12264. !IWLoop:
  12265.         //try parent class
  12266.         MOV EDI,[EDI+4]       //points to class info
  12267.         MOV EDI,[EDI+4]       //get parent info
  12268.         CMP EDI,0
  12269.         JNE !ILoop
  12270. !IELoop:
  12271.      END;
  12272. END;
  12273.  
  12274. {internally: returns true if the Class1 is derived from Class2 otherwise FALSE}
  12275. FUNCTION CheckDerived(Class1,Class2: TClass): BOOLEAN;
  12276. BEGIN
  12277.      ASM
  12278.         MOV EDI,$Class1        //get Class info pointer
  12279.         MOV EAX,$Class2        //class to check
  12280.         MOVD $!FUNCRESULT,0    //Default
  12281. !ILoop11:
  12282.         CMP EDI,EAX            //is it this class ?
  12283.         JNE !IWLoop11
  12284.  
  12285.         //The Class was found
  12286.         MOVD $!FUNCRESULT,1
  12287.         JMP !IELoop11
  12288. !IWLoop11:
  12289.         //try parent class
  12290.         MOV EDI,[EDI+4]       //points to class info
  12291.         MOV EDI,[EDI+4]       //get parent info
  12292.         CMP EDI,0
  12293.         JNE !ILoop11
  12294. !IELoop11:
  12295.      END;
  12296. END;
  12297.  
  12298. ASSEMBLER
  12299.  
  12300. //Abstract method (causes Runtime Error 210)
  12301. SYSTEM.!Abstract PROC NEAR32
  12302.              PUSHL 210
  12303.              CALLN32 SYSTEM.RunError
  12304. SYSTEM.!Abstract ENDP
  12305.  
  12306. END;
  12307.  
  12308. //************************************************************************
  12309. // LongJmp support
  12310. //************************************************************************
  12311.  
  12312.  
  12313. FUNCTION SetJmp(VAR JmpBuf:Jmp_Buf):LONGWORD;
  12314. BEGIN
  12315.      ASM
  12316.         MOV EDI,$JmpBuf
  12317.         MOV EAX,[EBP+0]
  12318.         MOV [EDI+0],EAX
  12319.         MOV EAX,[EBP+4]
  12320.         MOV [EDI+4],EAX
  12321.         MOV EAX,EBP
  12322.         ADD EAX,12
  12323.         MOV [EDI+8],EAX
  12324.         MOV ESI,0
  12325.         db $64   //SEG FS
  12326.         MOV EAX,[ESI+0]
  12327.         MOV [EDI+$18],EAX
  12328.         FSTCW [EDI+$1C]
  12329.         XOR EAX,EAX
  12330.         MOV $!FUNCRESULT,EAX
  12331.      END;
  12332. END;
  12333.  
  12334. PROCEDURE LongJmp(VAR JmpBuf:Jmp_Buf;RetVal:LONGWORD);
  12335. BEGIN
  12336.      ASM
  12337.         //MOV EDI,$JmpBuf
  12338.         //PUSHL 0
  12339.         //MOV EAX,*ljmpret
  12340.         //PUSH EAX
  12341.         //PUSHL [EDI+$18]
  12342.         //MOV AL,3
  12343.         //CALLDLL DosCalls,357  //DosUnwindException
  12344. ljmpret:
  12345.         MOV EDI,$JmpBuf
  12346.         db $db,$e3              //FINIT Init FPU
  12347.         FWAIT
  12348.         FLDCW [EDI+$1C]
  12349.         MOV EAX,$RetVal
  12350.         AND EAX,EAX
  12351.         JNZ !rtv0
  12352.         MOV EAX,1
  12353. !rtv0:
  12354.         PUSHL [EDI+0]
  12355.         POP EBP
  12356.         MOV ESP,[EDI+8]
  12357.         ADD EDI,4
  12358.         db $0ff,$27       //JMP NEAR32 [EDI+0] --> jump into proc
  12359.      END;
  12360. END;
  12361.  
  12362. //***************************************************
  12363. // String Support routines
  12364. //***************************************************
  12365.  
  12366. PROCEDURE UpcaseStr(VAR s:STRING);
  12367. BEGIN
  12368.      ASM
  12369.         MOV EDI,$s
  12370.         XOR ECX,ECX
  12371.         MOV CL,[EDI+0]
  12372.         OR CL,CL
  12373.         JE !usend
  12374.         INC EDI
  12375.         MOV EBX,*ustab
  12376.         CLD
  12377. !usfilter:
  12378.         MOV AL,[EDI+0]
  12379.         XLAT
  12380.         STOSB
  12381.         DEC ECX
  12382.         JNZ !usfilter
  12383. !usend:
  12384.         LEAVE
  12385.         RETN32 4
  12386. ustab:
  12387.        db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20
  12388.        db 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38
  12389.        db 39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57
  12390.        db 58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76
  12391.        db 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96
  12392.        db 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83
  12393.        db 84,85,86,87,88,89,90
  12394.        db 123,124,125,126,127,128,129,130,131,132,133,134,135,136,137
  12395.        db 138,139,140,141,142,143,144,145,146,147,148,149,150,151,152
  12396.        db 153,154,155,156,157,158,159,160,161,162,163,164,165,166,167
  12397.        db 168,169,170,171,172,173,174,175,176,177,178,179,180,181,182
  12398.        db 183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198
  12399.        db 199,200,201,202,203,204,205,206,207,208,209,210,211,212,213
  12400.        db 214,215,216,217,218,219,220,221,222,223,224,225,226,227,228
  12401.        db 229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244
  12402.        db 245,246,247,248,249,250,251,252,253,254,255
  12403.      END;
  12404. END;
  12405.  
  12406.  
  12407. PROCEDURE LongWord2Str(l:LONGWORD;Format:LONGWORD;VAR result:STRING);
  12408. BEGIN
  12409.      ASM
  12410.         PUSH EAX
  12411.         PUSH EBX
  12412.         PUSH ECX
  12413.         PUSH EDX
  12414.         PUSH EDI
  12415.         PUSH ESI
  12416.  
  12417.         MOV EAX,$l
  12418.         MOV EBX,10
  12419.         XOR ECX,ECX
  12420. Lw46_1nn:
  12421.         XOR EDX,EDX
  12422.         DIV EBX
  12423.         PUSH DX
  12424.         INC CX
  12425.         OR EAX,EAX
  12426.         JNE Lw46_1nn
  12427.  
  12428.         MOV ESI,$RESULT
  12429.         MOVB [ESI+0],0
  12430.         MOV EDI,ESI
  12431.  
  12432.         CMP ECX,$Format
  12433.         JAE Lw47nn
  12434.  
  12435.         //format the string
  12436.         MOV EAX,$Format
  12437.         SUB EAX,ECX
  12438.         MOV [ESI+0],AL
  12439.         INC EDI
  12440.         PUSH ECX
  12441.  
  12442.         MOV ECX,EAX
  12443.         MOV AL,32
  12444.         CLD
  12445.         REP STOSB       //fill up with space
  12446.  
  12447.         DEC EDI
  12448.         POP ECX
  12449. Lw47nn:
  12450.         POP AX
  12451.         ADD AL,48
  12452.         INCB [ESI+0]
  12453.         INC EDI
  12454.         MOV [EDI+0],AL
  12455.         LOOP Lw47nn
  12456.      END;
  12457.  
  12458.      ASM
  12459.         POP ESI
  12460.         POP EDI
  12461.         POP EDX
  12462.         POP ECX
  12463.         POP EBX
  12464.         POP EAX
  12465.      END;
  12466. END;
  12467.  
  12468. FUNCTION GetBoolValue(b:BOOLEAN):STRING;
  12469. BEGIN
  12470.      ASM
  12471.         PUSH EAX
  12472.         PUSH EBX
  12473.         PUSH ECX
  12474.         PUSH EDX
  12475.         PUSH EDI
  12476.         PUSH ESI
  12477.      END;
  12478.      IF b THEN GetBoolValue:='TRUE'
  12479.      ELSE GetBoolValue:='FALSE';
  12480.      ASM
  12481.         POP ESI
  12482.         POP EDI
  12483.         POP EDX
  12484.         POP ECX
  12485.         POP EBX
  12486.         POP EAX
  12487.      END;
  12488. END;
  12489.  
  12490. PROCEDURE LongInt2Str(l:LONGINT;Format:LONGWORD;VAR result:STRING);
  12491. VAR
  12492.    IsNeg:BOOLEAN;
  12493. BEGIN
  12494.      ASM
  12495.         PUSH EAX
  12496.         PUSH EBX
  12497.         PUSH ECX
  12498.         PUSH EDX
  12499.         PUSH EDI
  12500.         PUSH ESI
  12501.  
  12502.         MOVB $IsNeg,0
  12503.         MOV EAX,$l
  12504.         MOV EBX,10
  12505.         XOR ECX,ECX
  12506.         CMP EAX,0
  12507.         JNL Lw46_1
  12508.         NEG EAX
  12509.         MOVB $IsNeg,1
  12510. Lw46_1:
  12511.         XOR EDX,EDX
  12512.         DIV EBX
  12513.         PUSH DX
  12514.         INC CX
  12515.         OR EAX,EAX
  12516.         JNE Lw46_1
  12517.  
  12518.         MOV ESI,$RESULT
  12519.         MOVB [ESI+0],0
  12520.         MOV EDI,ESI
  12521.  
  12522.         MOV EBX,ECX
  12523.  
  12524.         CMPB $IsNeg,1
  12525.         JNE !nin1
  12526.         INC EBX
  12527. !nin1:
  12528.         CMP EBX,$Format
  12529.         JAE Lw47_1n
  12530.  
  12531.         //format the string
  12532.         MOV EAX,$Format
  12533.         SUB EAX,EBX
  12534.         MOV [ESI+0],AL
  12535.         INC EDI
  12536.         PUSH ECX
  12537.  
  12538.         MOV ECX,EAX
  12539.         MOV AL,32
  12540.         CLD
  12541.         REP STOSB        //fill up with space
  12542.  
  12543.         DEC EDI
  12544.         POP ECX
  12545. Lw47_1n:
  12546.         CMPB $IsNeg,1
  12547.         JNE Lw47
  12548.         INC EDI
  12549.         INCB [ESI+0]
  12550.         MOVB [EDI+0],45  //'-'
  12551. Lw47:
  12552.         POP AX
  12553.         ADD AL,48
  12554.         INCB [ESI+0]
  12555.         INC EDI
  12556.         MOV [EDI+0],AL
  12557.         LOOP Lw47
  12558.      END;
  12559.  
  12560.      ASM
  12561.         POP ESI
  12562.         POP EDI
  12563.         POP EDX
  12564.         POP ECX
  12565.         POP EBX
  12566.         POP EAX
  12567.      END;
  12568. END;
  12569.  
  12570. FUNCTION POS(CONST item,source:STRING):BYTE;
  12571. VAR
  12572.    result:BYTE;
  12573. BEGIN
  12574.      ASM
  12575.          MOV ESI,$item          //item
  12576.          CLD
  12577.          LODSB
  12578.          OR AL,AL
  12579.          JE lab2
  12580.          MOVZX EAX,AL
  12581.          MOV EDX,EAX
  12582.          MOV EDI,$source        //source
  12583.          MOVZXB ECX,[EDI+0]
  12584.          SUB ECX,EDX
  12585.          JB lab2
  12586.          INC ECX
  12587.          INC EDI
  12588. lab1:
  12589.          LODSB
  12590.          REPNE
  12591.          SCASB
  12592.          JNE lab2
  12593.          MOV EAX,EDI
  12594.          MOV EBX,ECX
  12595.          MOV ECX,EDX
  12596.          DEC ECX
  12597.          REPE
  12598.          CMPSB
  12599.          JE lab3
  12600.          MOV EDI,EAX
  12601.          MOV ECX,EBX
  12602.          MOV ESI,$item     //item
  12603.          INC ESI
  12604.          JMP lab1
  12605. Lab2:
  12606.          XOR EAX,EAX
  12607.          JMP Lab4
  12608. lab3:
  12609.          DEC EAX
  12610.          SUB EAX,$source   //source
  12611. Lab4:
  12612.          MOV $result,AL
  12613.      END;
  12614.      POS:=result;
  12615. END;
  12616.  
  12617. FUNCTION Copy(CONST Source:STRING; Index,Count:INTEGER):STRING;
  12618. BEGIN
  12619.      ASM
  12620.         MOV ESI,$source              //Source string
  12621.         MOV EDI,$!FuncResult         //Destination string
  12622.         MOVW [EDI+0],0               //Empty String
  12623.  
  12624.         MOVSXW ECX,$Count            //Count
  12625.         CMP ECX,1
  12626.         JL !_CopyE
  12627.  
  12628.         MOVSXW EAX,$Index            //Index
  12629.         CMP EAX,1
  12630.         JNL !_Copy1
  12631.         MOV EAX,1                    //Index:=1
  12632. !_Copy1:
  12633.         MOVZXB EBX,[ESI+0]           //Length of Source
  12634.         CMP EAX,EBX
  12635.         JA !_CopyE
  12636.  
  12637.         MOV EDX,EAX
  12638.         ADD EDX,ECX                  //Index+Count
  12639.         CMP EDX,EBX
  12640.         JNA !_Copy2
  12641.         MOV ECX,EBX
  12642.         SUB ECX,EAX
  12643.         INC ECX                      //Count := Length(S)-Index+1
  12644. !_Copy2:
  12645.         MOV [EDI+0],CL
  12646.         INC EDI
  12647.  
  12648.         ADD ESI,EAX                  //first char
  12649.         CLD
  12650.         MOV EDX,ECX
  12651.         SHR ECX,2
  12652.         REP
  12653.         MOVSD
  12654.         MOV ECX,EDX
  12655.         AND ECX,3
  12656.         REP
  12657.         MOVSB
  12658. !_CopyE:
  12659.      END;
  12660. END;
  12661.  
  12662. FUNCTION ToHex(l:LONGWORD):STRING;
  12663. VAR
  12664.     HexNum:STRING;
  12665.     result:STRING;
  12666.     r:LONGWORD;
  12667. BEGIN
  12668.      HexNum:='0123456789ABCDEF';
  12669.      result:='';
  12670.      WHILE l>=16 DO
  12671.      BEGIN
  12672.           r:=l MOD 16;
  12673.           l:=l DIV 16;
  12674.           result:=HexNum[r+1]+result;
  12675.      END;
  12676.      result:=HexNum[l+1]+result;
  12677.      WHILE length(result)<8 DO result:='0'+result;
  12678.      ToHex:='$'+Result;
  12679. END;
  12680.  
  12681. PROCEDURE SUBSTR(VAR source:STRING;start,ende:Byte);
  12682. BEGIN
  12683.       ASM
  12684.         CLD
  12685.         MOV ESI,$source              //Source string
  12686.         MOV EDI,ESI                  //Destination string
  12687.  
  12688.         MOVZXB AX,[ESI+0]            //Length of source
  12689.         MOVZXB ECX,$Start            //Index
  12690.         OR ECX,ECX
  12691.         JG !_Lab1_1
  12692.         MOV ECX,1
  12693. !_Lab1_1:
  12694.         ADD ESI,ECX
  12695.         SUB AX,CX
  12696.         JB !_Lab3_1
  12697.         INC AX
  12698.         MOVZXB CX,$Ende             //Count
  12699.         OR CX,CX
  12700.         JGE !_Lab2_1
  12701.         XOR CX,CX
  12702. !_Lab2_1:
  12703.         CMP AX,CX
  12704.         JBE !_Lab4_1
  12705.         MOV AX,CX
  12706.         JMP !_Lab4_1
  12707. !_Lab3_1:
  12708.         XOR AX,AX
  12709. !_Lab4_1:
  12710.         CLD
  12711.         STOSB
  12712.         MOVZX ECX,AX
  12713.  
  12714.         MOV EDX,ECX
  12715.         SHR ECX,2
  12716.         REP
  12717.         MOVSD
  12718.         MOV ECX,EDX
  12719.         AND ECX,3
  12720.         REP
  12721.         MOVSB
  12722.      END;
  12723. END;
  12724.  
  12725. PROCEDURE Insert(CONST Source:STRING; VAR S:STRING; Index:INTEGER);
  12726. BEGIN
  12727.      IF Length(Source) = 0 THEN exit;
  12728.      IF Length(S) = 0 THEN
  12729.      BEGIN
  12730.           S := Source;
  12731.           exit;
  12732.      END;
  12733.      IF Index < 1 THEN Index := 1;
  12734.      IF Index > Length(S) THEN Index := Length(S)+1;
  12735.      S := copy(S,1,Index-1) + Source + copy(S,Index,Length(S)-Index+1);
  12736. END;
  12737. {$H+}
  12738.  
  12739. PROCEDURE Delete(VAR S:STRING; Index,Count:INTEGER);
  12740. BEGIN
  12741.      IF Index < 1 THEN exit;
  12742.      IF Index > Length(S) THEN exit;
  12743.      IF Count < 1 THEN exit;
  12744.      IF Index+Count > Length(S) THEN Count := Length(S)-Index+1;
  12745.      S := copy(S,1,Index-1) + copy(S,Index+Count,Length(S)-Index-Count+1);
  12746. END;
  12747.  
  12748. FUNCTION ConvertStr2Long(VAR s:STRING):LONGINT;
  12749. VAR
  12750.    c:Integer;
  12751.    result:LONGINT;
  12752. BEGIN
  12753.      VAL(s,result,c);
  12754.      IF c<>0 THEN
  12755.      BEGIN
  12756.      END;
  12757.      ConvertStr2Long:=result;
  12758. END;
  12759.  
  12760. {Liefert Extended in ST(0) !!}
  12761. PROCEDURE ConvertStr2Extended(VAR s:STRING);
  12762. VAR
  12763.    c:Integer;
  12764.    result:Extended;
  12765. BEGIN
  12766.      VAL(s,result,c);
  12767.      IF c<>0 THEN
  12768.      BEGIN
  12769.      END;
  12770.      ASM
  12771.         FLDT $result
  12772.      END;
  12773. END;
  12774.  
  12775. FUNCTION GetStrErrorPos(VAR s:STRING):LONGINT;
  12776. VAR t,t1:BYTE;
  12777. BEGIN
  12778.      result:=1;
  12779.      t:=1;
  12780.      IF t<=length(s) THEN IF s[t] IN ['+','-'] THEN inc(t);
  12781.      IF t<=length(s) THEN IF s[t]='$' THEN inc(t);
  12782.      FOR t1:=t TO length(s) DO
  12783.      BEGIN
  12784.           CASE s[t1] OF
  12785.             '0'..'9':;
  12786.             ELSE
  12787.             BEGIN
  12788.                  result:=t1;
  12789.                  exit;
  12790.             END;
  12791.           END;
  12792.      END;
  12793. END;
  12794.  
  12795. ASSEMBLER
  12796.  
  12797. SYSTEM.!Str2Long PROC NEAR32
  12798.         PUSH EBP
  12799.         MOV EBP,ESP
  12800.         SUB ESP,10
  12801.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  12802.  
  12803.         MOV EDI,[EBP+16]   //s
  12804.         MOV CL,[EDI+0]     //Länge
  12805.         MOVZX ECX,CL
  12806.  
  12807. !ndo_11:
  12808.         MOV AL,[EDI+1]
  12809.         CMP AL,32
  12810.         JNE !do_11
  12811.         CMP ECX,0
  12812.         JE !do_11
  12813.         DEC ECX
  12814.         INC EDI
  12815.         JMP !ndo_11       //skip spaces
  12816. !do_11:
  12817.         PUSH EDI
  12818.         ADD EDI,ECX
  12819.         CMPB [EDI+0],32
  12820.         JNE !do_11_1
  12821.         DEC ECX
  12822.         POP EDI
  12823.         JMP !do_11
  12824. !do_11_1:
  12825.         POP EDI
  12826.  
  12827.         MOVB [EBP-6],0
  12828.  
  12829.         MOVD [EBP-10],10   //Base
  12830.         MOV AL,[EDI+1]
  12831.         ADD EDI,ECX
  12832.         CMP AL,'$'         //Hexadecimal ??
  12833.         JNE !nohex
  12834.         MOVD [EBP-10],16   //Base
  12835.         CMP ECX,1
  12836.         JE !qerr
  12837.         DEC ECX
  12838. !nohex:
  12839.         CMP AL,'-'
  12840.         JNE !q2
  12841.         CMP ECX,1
  12842.         JE !qerr
  12843.         DEC ECX
  12844.         MOVB [EBP-6],1
  12845. !q2:
  12846.         MOV EBX,1
  12847.         MOV EAX,0
  12848.         MOV [EBP-4],EAX
  12849. !q1:
  12850.         MOV AL,[EDI+0]
  12851.         DEC EDI
  12852.         CMP AL,48
  12853.         JB !qerr
  12854.         CMP AL,57
  12855.         JNA !noqerr
  12856.  
  12857.         CMP AL,102
  12858.         JA !qerr
  12859.         CMP AL,65
  12860.         JB !qerr
  12861.         CMP AL,70
  12862.         JBE !hexnum
  12863.         CMP AL,97
  12864.         JB !qerr
  12865.         SUB AL,32       //To upper
  12866. !hexnum:
  12867.         CMPD [EBP-10],16
  12868.         JNE !qerr
  12869.         SUB AL,7
  12870. !noqerr:
  12871.         SUB AL,48
  12872.         MOVZX EAX,AL
  12873.         MUL EBX
  12874.         MOV EDX,[EBP-4]
  12875.         ADD EDX,EAX
  12876.         MOV [EBP-4],EDX
  12877.         MOV EAX,EBX
  12878.         MOV EBX,[EBP-10]  //Base
  12879.         MUL EBX
  12880.         MOV EBX,EAX
  12881.         LOOP !q1
  12882. !qerr:
  12883.         MOV EDI,[EBP+8]   //result
  12884.         XOR CH,CH
  12885.         MOV [EDI+0],CX
  12886.  
  12887.         // failure ??
  12888.         CMP CX,0
  12889.         JE !qqqq    //no error
  12890.         PUSHL [EBP+16]  //s
  12891.         CALLN32 SYSTEM.GetStrErrorPos
  12892.         MOV EDI,[EBP+8]
  12893.         MOV [EDI+0],EAX
  12894.         MOV EAX,0
  12895.         JMP !q3
  12896. !qqqq:
  12897.         MOV EAX,[EBP-4]
  12898.         CMPB [EBP-6],1
  12899.         JNE !q3
  12900.         NEG EAX
  12901. !q3:
  12902.         MOV EDI,[EBP+12]  //l
  12903.         MOV [EDI+0],EAX
  12904.         LEAVE
  12905.         RETN32 12
  12906. SYSTEM.!Str2Long ENDP
  12907.  
  12908. SYSTEM.!Str2Word PROC NEAR32
  12909.         PUSH EBP
  12910.         MOV EBP,ESP
  12911.         SUB ESP,10
  12912.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  12913.  
  12914.         MOV EDI,[EBP+16]   //s
  12915.         MOV CL,[EDI+0]     //Länge
  12916.         MOVZX ECX,CL
  12917.  
  12918. !ndo_22:
  12919.         MOV AL,[EDI+1]
  12920.         CMP AL,32
  12921.         JNE !do_22
  12922.         CMP ECX,0
  12923.         JE !do_22
  12924.         DEC ECX
  12925.         INC EDI
  12926.         JMP !ndo_22
  12927. !do_22:
  12928.         PUSH EDI
  12929.         ADD EDI,ECX
  12930.         CMPB [EDI+0],32
  12931.         JNE !do_22_1
  12932.         DEC ECX
  12933.         POP EDI
  12934.         JMP !do_22
  12935. !do_22_1:
  12936.         POP EDI
  12937.  
  12938.         MOVB [EBP-6],0
  12939.  
  12940.         MOVD [EBP-10],10   //Base
  12941.         MOV AL,[EDI+1]
  12942.         ADD EDI,ECX
  12943.         CMP AL,'$'         //Hexadecimal ??
  12944.         JNE !__nohex
  12945.         MOVD [EBP-10],16   //Base
  12946.         CMP ECX,1
  12947.         JE !__qerr
  12948.         DEC ECX
  12949. !__nohex:
  12950.         CMP AL,'-'
  12951.         JNE !__q2
  12952.         CMP ECX,1
  12953.         JE !__qerr
  12954.         DEC ECX
  12955.         MOVB [EBP-6],1
  12956. !__q2:
  12957.         MOV EBX,1
  12958.         MOV EAX,0
  12959.         MOV [EBP-4],EAX
  12960. !__q1:
  12961.         MOV AL,[EDI+0]
  12962.         DEC EDI
  12963.         CMP AL,48
  12964.         JB !__qerr
  12965.         CMP AL,57
  12966.         JNA !__noqerr
  12967.  
  12968.         CMP AL,102
  12969.         JA !__qerr
  12970.         CMP AL,65
  12971.         JB !__qerr
  12972.         CMP AL,70
  12973.         JBE !__hexnum
  12974.         CMP AL,97
  12975.         JB !__qerr
  12976.         SUB AL,32         //To upper
  12977. !__hexnum:
  12978.         CMPD [EBP-10],16
  12979.         JNE !__qerr
  12980.         SUB AL,7
  12981. !__noqerr:
  12982.         SUB AL,48
  12983.         MOVZX EAX,AL
  12984.         MUL EBX
  12985.         MOV EDX,[EBP-4]
  12986.         ADD EDX,EAX
  12987.         MOV [EBP-4],EDX
  12988.         MOV EAX,EBX
  12989.         MOV EBX,[EBP-10]    //Base
  12990.         MUL EBX
  12991.         MOV EBX,EAX
  12992.         LOOP !__q1
  12993. !__qerr:
  12994.         MOV EDI,[EBP+8]     //result
  12995.         XOR CH,CH
  12996.         MOV [EDI+0],CX
  12997.  
  12998.         // failure ??
  12999.         CMP CX,0
  13000.         JE !qqqq1    //no error
  13001.         PUSHL [EBP+16]  //s
  13002.         CALLN32 SYSTEM.GetStrErrorPos
  13003.         MOV EDI,[EBP+8]
  13004.         MOV [EDI+0],EAX
  13005.         MOV EAX,0
  13006.         JMP !__q3
  13007. !qqqq1:
  13008.         MOV EAX,[EBP-4]
  13009.         CMPB [EBP-6],1
  13010.         JNE !__q3
  13011.         NEG EAX
  13012. !__q3:
  13013.         MOV EDI,[EBP+12]    //l
  13014.         MOV [EDI+0],AX
  13015.         LEAVE
  13016.         RETN32 12
  13017. SYSTEM.!Str2Word ENDP
  13018.  
  13019. SYSTEM.!Str2Byte PROC NEAR32
  13020.         PUSH EBP
  13021.         MOV EBP,ESP
  13022.         SUB ESP,10
  13023.         DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  13024.  
  13025.         MOV EDI,[EBP+16]   //s
  13026.         MOV CL,[EDI+0]     //Länge
  13027.         MOVZX ECX,CL
  13028.  
  13029. !ndo_33:
  13030.         MOV AL,[EDI+1]
  13031.         CMP AL,32
  13032.         JNE !do_33
  13033.         CMP ECX,0
  13034.         JE !do_33
  13035.         DEC ECX
  13036.         INC EDI
  13037.         JMP !ndo_33
  13038. !do_33:
  13039.         PUSH EDI
  13040.         ADD EDI,ECX
  13041.         CMPB [EDI+0],32
  13042.         JNE !do_33_1
  13043.         DEC ECX
  13044.         POP EDI
  13045.         JMP !do_33
  13046. !do_33_1:
  13047.         POP EDI
  13048.  
  13049.         MOVB [EBP-6],0
  13050.  
  13051.         MOVD [EBP-10],10   //Base
  13052.         MOV AL,[EDI+1]
  13053.         ADD EDI,ECX
  13054.         CMP AL,'$'         //Hexadecimal ??
  13055.         JNE !___nohex
  13056.         CMP ECX,1
  13057.         JE !___qerr
  13058.         MOVD [EBP-10],16   //Base
  13059.         DEC ECX
  13060. !___nohex:
  13061.         CMP AL,'-'
  13062.         JNE !___q2
  13063.         CMP ECX,1
  13064.         JE !___qerr
  13065.         DEC ECX
  13066.         MOVB [EBP-6],1
  13067. !___q2:
  13068.         MOV EBX,1
  13069.         MOV EAX,0
  13070.         MOV [EBP-4],EAX
  13071. !___q1:
  13072.         MOV AL,[EDI+0]
  13073.         DEC EDI
  13074.         CMP AL,48
  13075.         JB !___qerr
  13076.         CMP AL,57
  13077.         JNA !___noqerr
  13078.  
  13079.         CMP AL,102
  13080.         JA !___qerr
  13081.         CMP AL,65
  13082.         JB !___qerr
  13083.         CMP AL,70
  13084.         JBE !___hexnum
  13085.         CMP AL,97
  13086.         JB !___qerr
  13087.         SUB AL,32       //To upper
  13088. !___hexnum:
  13089.         CMPD [EBP-10],16
  13090.         JNE !___qerr
  13091.         SUB AL,7
  13092. !___noqerr:
  13093.         SUB AL,48
  13094.         MOVZX EAX,AL
  13095.         MUL EBX
  13096.         MOV EDX,[EBP-4]
  13097.         ADD EDX,EAX
  13098.         MOV [EBP-4],EDX
  13099.         MOV EAX,EBX
  13100.         MOV EBX,[EBP-10]    //Base
  13101.         MUL EBX
  13102.         MOV EBX,EAX
  13103.         LOOP !___q1
  13104. !___qerr:
  13105.         MOV EDI,[EBP+8]     //result
  13106.         XOR CH,CH
  13107.         MOV [EDI+0],CX
  13108.  
  13109.         // failure ??
  13110.         CMP CX,0
  13111.         JE !qqqq2    //no error
  13112.         PUSHL [EBP+16]  //s
  13113.         CALLN32 SYSTEM.GetStrErrorPos
  13114.         MOV EDI,[EBP+8]
  13115.         MOV [EDI+0],EAX
  13116.         MOV EAX,0
  13117.         JMP !___q3
  13118. !qqqq2:
  13119.         MOV EAX,[EBP-4]
  13120.         CMPB [EBP-6],1
  13121.         JNE !___q3
  13122.         NEG EAX
  13123. !___q3:
  13124.         MOV EDI,[EBP+12]    //l
  13125.         MOV [EDI+0],AL
  13126.         LEAVE
  13127.         RETN32 12
  13128. SYSTEM.!Str2Byte ENDP
  13129.  
  13130. END;
  13131.  
  13132.  
  13133. ASSEMBLER
  13134.  
  13135. SYSTEM.!AssignStr2Array PROC NEAR32
  13136.                 CLD
  13137.                 PUSH EBP
  13138.                 MOV EBP,ESP
  13139.  
  13140.                 PUSH EAX
  13141.                 PUSH EBX
  13142.                 PUSH ECX
  13143.                 PUSH EDX
  13144.                 PUSH EDI
  13145.                 PUSH ESI
  13146.  
  13147.                 MOV EDI,[EBP+8]    //Destination Array
  13148.                 MOV ESI,[EBP+12]   //Source String
  13149.  
  13150.                 MOVZXB ECX,[ESI+0]
  13151.                 INC ESI
  13152.  
  13153.                 MOV EDX,ECX
  13154.                 SHR ECX,2
  13155.                 REP
  13156.                 MOVSD
  13157.                 MOV ECX,EDX
  13158.                 AND ECX,3
  13159.                 REP
  13160.                 MOVSB
  13161.  
  13162.                 POP ESI
  13163.                 POP EDI
  13164.                 POP EDX
  13165.                 POP ECX
  13166.                 POP EBX
  13167.                 POP EAX
  13168.  
  13169.                 LEAVE
  13170.                 RETN32 8
  13171. SYSTEM.!AssignStr2Array ENDP
  13172.  
  13173. SYSTEM.!AssignCStr2Array PROC NEAR32
  13174.                 CLD
  13175.                 PUSH EBP
  13176.                 MOV EBP,ESP
  13177.  
  13178.                 PUSH EAX
  13179.                 PUSH EBX
  13180.                 PUSH ECX
  13181.                 PUSH EDX
  13182.                 PUSH EDI
  13183.                 PUSH ESI
  13184.  
  13185.                 MOV ESI,[EBP+12]   //Source CString
  13186.                 MOV EDI,ESI
  13187.                 MOV ECX,$0FFFFFFFF
  13188.                 XOR AL,AL
  13189.                 REPNE
  13190.                 SCASB
  13191.                 NOT ECX
  13192.  
  13193.                 MOV EDI,[EBP+8]    //Destination Array
  13194.  
  13195.                 MOV EDX,ECX
  13196.                 SHR ECX,2
  13197.                 REP
  13198.                 MOVSD
  13199.                 MOV ECX,EDX
  13200.                 AND ECX,3
  13201.                 REP
  13202.                 MOVSB
  13203.  
  13204.                 POP ESI
  13205.                 POP EDI
  13206.                 POP EDX
  13207.                 POP ECX
  13208.                 POP EBX
  13209.                 POP EAX
  13210.  
  13211.                 LEAVE
  13212.                 RETN32 8
  13213. SYSTEM.!AssignCStr2Array ENDP
  13214.  
  13215.  
  13216.  
  13217. SYSTEM.!StrCopy PROC NEAR32
  13218.                 CLD
  13219.                 PUSH EBP
  13220.                 MOV EBP,ESP
  13221.  
  13222.                 PUSH EAX
  13223.                 PUSH ECX
  13224.                 PUSH EDI
  13225.                 PUSH ESI
  13226.  
  13227.                 MOV EDI,[EBP+12]    //Destination String
  13228.                 MOV ESI,[EBP+16]    //Source String
  13229.                 MOV ECX,[EBP+8]     //Maximum length
  13230.                 LODSB
  13231.                 CMP AL,CL
  13232.                 JBE _L1
  13233.                 MOV AL,CL
  13234. _L1:
  13235.                 STOSB
  13236.                 MOVZX ECX,AL
  13237.  
  13238.                 MOV EAX,ECX
  13239.                 SHR ECX,2
  13240.                 REP
  13241.                 MOVSD
  13242.                 MOV ECX,EAX
  13243.                 AND ECX,3
  13244.                 REP
  13245.                 MOVSB
  13246.  
  13247.                 POP ESI
  13248.                 POP EDI
  13249.                 POP ECX
  13250.                 POP EAX
  13251.  
  13252.                 LEAVE
  13253.                 RETN32 12
  13254. SYSTEM.!StrCopy ENDP
  13255.  
  13256. SYSTEM.!AssignStr2PChar PROC NEAR32
  13257.                 CLD
  13258.  
  13259.                 PUSH EBP
  13260.                 MOV EBP,ESP
  13261.  
  13262.                 PUSH EAX
  13263.                 PUSH ECX
  13264.                 PUSH EDX
  13265.                 PUSH EDI
  13266.                 PUSH ESI
  13267.  
  13268.                 MOV EDI,[EBP+12]    //Destination CString
  13269.                 MOV ESI,[EBP+16]    //Source String
  13270.                 MOV ECX,[EBP+8]     //Maximum length
  13271.  
  13272.                 LODSB               //get length of source string
  13273.                 MOVZX EAX,AL
  13274.                 CMP EAX,ECX
  13275.                 JB _L1_1
  13276.                 MOV EAX,ECX
  13277. _L1_1:
  13278.                 MOV ECX,EAX
  13279.                 MOV EDX,EAX
  13280.                 SHR ECX,2
  13281.                 REP
  13282.                 MOVSD
  13283.                 MOV ECX,EDX
  13284.                 AND ECX,3
  13285.                 REP
  13286.                 MOVSB
  13287.  
  13288.                 MOV AL,0
  13289.                 STOSB            //terminate PChar
  13290.  
  13291.                 POP ESI
  13292.                 POP EDI
  13293.                 POP EDX
  13294.                 POP ECX
  13295.                 POP EAX
  13296.  
  13297.                 LEAVE
  13298.                 RETN32 12
  13299. SYSTEM.!AssignStr2PChar ENDP
  13300.  
  13301.  
  13302. SYSTEM.!AssignPChar2Str PROC NEAR32
  13303.                 CLD
  13304.                 PUSH EBP
  13305.                 MOV EBP,ESP
  13306.  
  13307.                 PUSH EAX
  13308.                 PUSH EBX
  13309.                 PUSH ECX
  13310.                 PUSH EDX
  13311.                 PUSH EDI
  13312.                 PUSH ESI
  13313.  
  13314.                 MOV ESI,[EBP+16]   //Source CString
  13315.                 MOV EDX,[EBP+8]    //Maximum length
  13316.  
  13317.                 MOV EDI,ESI        //Source CString
  13318.                 MOV ECX,$0FFFFFFFF
  13319.                 XOR AL,AL
  13320.                 REPNE
  13321.                 SCASB
  13322.                 NOT ECX
  13323.                 MOV EAX,ECX        //length of source string
  13324.                 DEC EAX            //without #0
  13325.  
  13326.                 MOV EDI,[EBP+12]   //Destination String
  13327.  
  13328.                 CMP EAX,EDX
  13329.                 JB _L1_2
  13330.                 MOV EAX,EDX        //set to maximum length
  13331. _L1_2:
  13332.                 MOV ECX,EAX
  13333.                 STOSB              //set string length
  13334.  
  13335.                 MOV EDX,ECX
  13336.                 SHR ECX,2
  13337.                 REP
  13338.                 MOVSD
  13339.                 MOV ECX,EDX
  13340.                 AND ECX,3
  13341.                 REP
  13342.                 MOVSB
  13343.  
  13344.                 POP ESI
  13345.                 POP EDI
  13346.                 POP EDX
  13347.                 POP ECX
  13348.                 POP EBX
  13349.                 POP EAX
  13350.  
  13351.                 LEAVE
  13352.                 RETN32 12
  13353. SYSTEM.!AssignPChar2Str ENDP
  13354.  
  13355. SYSTEM.!CopyArrayStr PROC NEAR32
  13356.                 CLD
  13357.                 MOV EBX,ESP
  13358.                 MOV EDI,[EBX+12]    //Destination String
  13359.                 MOV ESI,[EBX+16]    //Source Array
  13360.                 MOV ECX,[EBX+8]     //Maximum string length
  13361.                 DEC ECX             //minus length byte
  13362.                 MOV EAX,[EBX+4]     //Array length
  13363.  
  13364.                 CMP AL,CL
  13365.                 JBE _L11
  13366.                 MOV AL,CL
  13367. _L11:
  13368.                 STOSB               //String length
  13369.                 MOV CL,AL
  13370.                 MOVZX ECX,CL
  13371.  
  13372.                 MOV EDX,ECX
  13373.                 SHR ECX,2
  13374.                 REP
  13375.                 MOVSD
  13376.                 MOV ECX,EDX
  13377.                 AND ECX,3
  13378.                 REP
  13379.                 MOVSB
  13380.  
  13381.                 RETN32 16
  13382. SYSTEM.!CopyArrayStr ENDP
  13383.  
  13384. SYSTEM.!PCharCopy PROC NEAR32
  13385.          CLD
  13386.          MOV EBX,ESP
  13387.          MOV EDI,[EBX+12]  //Source
  13388.          MOV ECX,$0FFFFFFFF
  13389.          XOR AL,AL
  13390.          REPNE
  13391.          SCASB
  13392.          NOT ECX
  13393.          MOV EDX,[EBX+4]   //Maximum length
  13394.          CMP EDX,ECX
  13395.          JAE _re
  13396.          MOV ECX,EDX
  13397. _re:
  13398.          MOV ESI,[EBX+12]  //Source
  13399.          MOV EDI,[EBX+8]   //Destination
  13400.  
  13401.          MOV EDX,ECX
  13402.          SHR ECX,2
  13403.          REP
  13404.          MOVSD
  13405.          MOV ECX,EDX
  13406.          AND ECX,3
  13407.          REP
  13408.          MOVSB
  13409.  
  13410.          RETN32 12
  13411. SYSTEM.!PCharCopy ENDP
  13412.  
  13413. SYSTEM.!PCharLength PROC NEAR32
  13414.          MOV EBX,ESP
  13415.  
  13416.          PUSH EBX
  13417.          PUSH EDI
  13418.          PUSH ECX
  13419.  
  13420.          MOV EDI,[EBX+4]   //Source
  13421.          MOV ECX,$0FFFFFFFF
  13422.          XOR AL,AL
  13423.          CLD
  13424.          REPNE
  13425.          SCASB
  13426.          NOT ECX
  13427.          MOV EAX,ECX
  13428.          DEC EAX           //without #0
  13429.  
  13430.          POP ECX
  13431.          POP EDI
  13432.          POP EBX
  13433.          RETN32 4
  13434. SYSTEM.!PCharLength ENDP
  13435.  
  13436.  
  13437. SYSTEM.!StrAdd PROC NEAR32
  13438.         PUSH EBP
  13439.         MOV EBP,ESP
  13440.  
  13441.         PUSH EAX
  13442.         PUSH EBX
  13443.         PUSH ECX
  13444.         PUSH EDX
  13445.         PUSH EDI
  13446.         PUSH ESI
  13447.  
  13448.         MOV EDI,[EBP+12]    //Destination
  13449.         MOV ESI,[EBP+8]     //String to add
  13450.         MOVZXB ECX,[EDI+0]  //length of destination
  13451.         CLD
  13452.         LODSB               //length of string to add
  13453.         ADD [EDI+0],AL
  13454.         JNC _lll1
  13455.         MOVB [EDI+0],255
  13456.         MOV AL,CL
  13457.         NOT AL
  13458. _lll1:
  13459.         ADD EDI,ECX
  13460.         INC EDI
  13461.         MOV CL,AL
  13462.  
  13463.         MOV EDX,ECX
  13464.         SHR ECX,2
  13465.         REP
  13466.         MOVSD
  13467.         MOV ECX,EDX
  13468.         AND ECX,3
  13469.         REP
  13470.         MOVSB
  13471.  
  13472.         POP ESI
  13473.         POP EDI
  13474.         POP EDX
  13475.         POP ECX
  13476.         POP EBX
  13477.         POP EAX
  13478.  
  13479.         LEAVE
  13480.         RETN32 8
  13481. SYSTEM.!StrAdd ENDP
  13482.  
  13483. SYSTEM.!PCharAdd PROC NEAR32
  13484.         PUSH EBP
  13485.         MOV EBP,ESP
  13486.  
  13487.         PUSH EAX
  13488.         PUSH EBX
  13489.         PUSH ECX
  13490.         PUSH EDX
  13491.         PUSH EDI
  13492.         PUSH ESI
  13493.  
  13494.         CLD
  13495.  
  13496.         MOV ESI,[EBP+8]    //String to add
  13497.         MOV EDI,[EBP+8]    //String to add
  13498.         MOV ECX,$0FFFFFFFF
  13499.         XOR AL,AL
  13500.         REPNE
  13501.         SCASB
  13502.         NOT ECX            //length of string to add
  13503.         DEC ECX            //without #0
  13504.         MOV EBX,ECX
  13505.  
  13506.         MOV EDI,[EBP+12]   //Destination
  13507.         MOV ECX,$0FFFFFFFF
  13508.         XOR AL,AL
  13509.         REPNE
  13510.         SCASB
  13511.         NOT ECX            //length of destination
  13512.         DEC ECX            //without #0
  13513.  
  13514.         MOV EDI,[EBP+12]   //Destination
  13515.         ADD EDI,ECX        //add length to destination
  13516.  
  13517.         MOV ECX,EBX        //length of string to add
  13518.  
  13519.         MOV EDX,ECX
  13520.         SHR ECX,2
  13521.         REP
  13522.         MOVSD
  13523.         MOV ECX,EDX
  13524.         AND ECX,3
  13525.         REP
  13526.         MOVSB
  13527.  
  13528.         MOV AL,0
  13529.         STOSB              //terminate PChar
  13530.  
  13531.         POP ESI
  13532.         POP EDI
  13533.         POP EDX
  13534.         POP ECX
  13535.         POP EBX
  13536.         POP EAX
  13537.  
  13538.         LEAVE
  13539.         RETN32 8
  13540. SYSTEM.!PCharAdd ENDP
  13541.  
  13542. SYSTEM.!Str2PChar PROC NEAR32
  13543.                PUSH EBP
  13544.                MOV EBP,ESP
  13545.  
  13546.                PUSH EAX
  13547.                PUSH EBX
  13548.                PUSH ECX
  13549.                PUSH EDX
  13550.                PUSH EDI
  13551.                PUSH ESI
  13552.  
  13553.                MOV ESI,[EBP+8]     //String to convert
  13554.                MOV EDI,ESI
  13555.                MOVZXB ECX,[ESI+0]
  13556.                INC ESI
  13557.  
  13558.                CLD
  13559.                MOV EDX,ECX
  13560.                SHR ECX,2
  13561.                REP
  13562.                MOVSD
  13563.                MOV ECX,EDX
  13564.                AND ECX,3
  13565.                REP
  13566.                MOVSB
  13567.  
  13568.                MOV AL,0   //terminate PChar
  13569.                STOSB
  13570.  
  13571.                POP ESI
  13572.                POP EDI
  13573.                POP EDX
  13574.                POP ECX
  13575.                POP EBX
  13576.                POP EAX
  13577.  
  13578.                LEAVE
  13579.                RETN32 4
  13580. SYSTEM.!Str2PChar ENDP
  13581.  
  13582. SYSTEM.!PChar2Str PROC NEAR32
  13583.                PUSH EBP
  13584.                MOV EBP,ESP
  13585.  
  13586.                PUSH EAX
  13587.                PUSH EBX
  13588.                PUSH ECX
  13589.                PUSH EDX
  13590.                PUSH EDI
  13591.                PUSH ESI
  13592.  
  13593.                MOV EDI,[EBP+8]   //string to convert
  13594.  
  13595.                CLD
  13596.                MOV ECX,$0FFFFFFFF
  13597.                XOR AL,AL
  13598.                REPNE
  13599.                SCASB
  13600.                NOT ECX            //length of string
  13601.                DEC ECX            //without #0
  13602.                MOV EDX,ECX        //used to set len
  13603.  
  13604.                MOV ESI,[EBP+8]
  13605.                ADD ESI,ECX        //to last character of source
  13606.                DEC ESI
  13607.                MOV EDI,ESI
  13608.                INC EDI            //destination is 1 up
  13609.  
  13610.                STD                //move the bytes 1 up
  13611.                REP
  13612.                MOVSB
  13613.  
  13614.                MOV AL,DL          //set string length
  13615.                STOSB
  13616.                CLD
  13617.  
  13618.                POP ESI
  13619.                POP EDI
  13620.                POP EDX
  13621.                POP ECX
  13622.                POP EBX
  13623.                POP EAX
  13624.  
  13625.                LEAVE
  13626.                RETN32
  13627. SYSTEM.!PChar2Str ENDP
  13628.  
  13629. SYSTEM.!StringCmp PROC NEAR32
  13630.               CLD
  13631.               PUSH EBP
  13632.               MOV EBP,ESP
  13633.  
  13634.               PUSH EAX
  13635.               PUSH ECX
  13636.               PUSH EDI
  13637.               PUSH ESI
  13638.  
  13639.               MOV EDI,[EBP+12]
  13640.               MOV ESI,[EBP+8]
  13641.               LODSB
  13642.               MOV AH,[EDI+0]
  13643.               INC EDI
  13644.               MOV CL,AL
  13645.               CMP CL,AH
  13646.               JBE _nl1
  13647.               MOV CL,AH
  13648. _nl1:
  13649.               OR CL,CL
  13650.               JE _nl2
  13651.               MOVZX ECX,CL
  13652.               CLD
  13653.               REP
  13654.               CMPSB
  13655.               JNE _nl3
  13656. _nl2:
  13657.               CMP AL,AH
  13658. _nl3:
  13659.               POP ESI
  13660.               POP EDI
  13661.               POP ECX
  13662.               POP EAX
  13663.  
  13664.               LEAVE
  13665.               RETN32 8
  13666. SYSTEM.!StringCmp ENDP
  13667.  
  13668. SYSTEM.!PCharCmp PROC NEAR32
  13669.               CLD
  13670.               PUSH EBP
  13671.               MOV EBP,ESP
  13672.  
  13673.               PUSH EAX
  13674.               PUSH EBX
  13675.               PUSH ECX
  13676.               PUSH EDX
  13677.               PUSH EDI
  13678.               PUSH ESI
  13679.  
  13680.               MOV EDI,[EBP+8]
  13681.               CLD
  13682.               MOV ECX,$0FFFFFFFF
  13683.               XOR AL,AL
  13684.               REPNE
  13685.               SCASB
  13686.               NOT ECX            //length of string
  13687.               DEC ECX            //without #0
  13688.               MOV EBX,ECX        //used to set len
  13689.  
  13690.               MOV EDI,[EBP+12]
  13691.               CLD
  13692.               MOV ECX,$0FFFFFFFF
  13693.               XOR AL,AL
  13694.               REPNE
  13695.               SCASB
  13696.               NOT ECX            //length of string
  13697.               DEC ECX            //without #0
  13698.               MOV EDX,ECX
  13699.  
  13700.               MOV EDI,[EBP+12]
  13701.               MOV ESI,[EBP+8]
  13702.  
  13703.               CMP EBX,ECX
  13704.               JNE _nl3_1
  13705. _nl1_1:
  13706.               OR ECX,ECX
  13707.               JE _nl2_1
  13708.  
  13709.               CLD
  13710.               REP
  13711.               CMPSB
  13712.               JNE _nl3_1
  13713. _nl2_1:
  13714.               CMP EBX,EDX
  13715. _nl3_1:
  13716.               POP ESI
  13717.               POP EDI
  13718.               POP EDX
  13719.               POP ECX
  13720.               POP EBX
  13721.               POP EAX
  13722.  
  13723.               LEAVE
  13724.               RETN32 8
  13725. SYSTEM.!PCharCmp ENDP
  13726.  
  13727. SYSTEM.!StrPCharCmp PROC NEAR32
  13728.               CLD
  13729.               PUSH EBP
  13730.               MOV EBP,ESP
  13731.  
  13732.               PUSH EAX
  13733.               PUSH EBX
  13734.               PUSH ECX
  13735.               PUSH EDX
  13736.               PUSH EDI
  13737.               PUSH ESI
  13738.  
  13739.               MOV EDI,[EBP+8]    //PChar
  13740.               CLD
  13741.               MOV ECX,$0FFFFFFFF
  13742.               XOR AL,AL
  13743.               REPNE
  13744.               SCASB
  13745.               NOT ECX            //length of string
  13746.               DEC ECX            //without #0
  13747.               MOV EBX,ECX        //used to set len
  13748.  
  13749.               MOV EDI,[EBP+12]   //Str
  13750.               MOVZXB ECX,[EDI]
  13751.               MOV EDX,ECX
  13752.  
  13753.               MOV EDI,[EBP+12]   //Str
  13754.               INC EDI
  13755.               MOV ESI,[EBP+8]    //PChar
  13756.  
  13757.               CMP EBX,ECX
  13758.               JNE _nl3_1_r1
  13759. _nl1_1_r1:
  13760.               OR ECX,ECX
  13761.               JE _nl2_1_r1
  13762.  
  13763.               CLD
  13764.               REP
  13765.               CMPSB
  13766.               JNE _nl3_1_r1
  13767. _nl2_1_r1:
  13768.               CMP EBX,EDX
  13769. _nl3_1_r1:
  13770.               POP ESI
  13771.               POP EDI
  13772.               POP EDX
  13773.               POP ECX
  13774.               POP EBX
  13775.               POP EAX
  13776.  
  13777.               LEAVE
  13778.               RETN32 8
  13779. SYSTEM.!StrPCharCmp ENDP
  13780.  
  13781. SYSTEM.!PCharStrCmp PROC NEAR32
  13782.               CLD
  13783.               PUSH EBP
  13784.               MOV EBP,ESP
  13785.  
  13786.               PUSH EAX
  13787.               PUSH EBX
  13788.               PUSH ECX
  13789.               PUSH EDX
  13790.               PUSH EDI
  13791.               PUSH ESI
  13792.  
  13793.               MOV EDI,[EBP+8]    //Str
  13794.               MOVZXB ECX,[EDI]
  13795.               MOV EBX,ECX        //used to set len
  13796.  
  13797.               MOV EDI,[EBP+12]   //PChar
  13798.               CLD
  13799.               MOV ECX,$0FFFFFFFF
  13800.               XOR AL,AL
  13801.               REPNE
  13802.               SCASB
  13803.               NOT ECX            //length of string
  13804.               DEC ECX            //without #0
  13805.               MOV EDX,ECX
  13806.  
  13807.               MOV EDI,[EBP+12]   //PChar
  13808.               MOV ESI,[EBP+8]    //Str
  13809.               INC ESI
  13810.  
  13811.               CMP EBX,ECX
  13812.               JNE _nl3_1_r2
  13813. _nl1_1_r2:
  13814.               OR ECX,ECX
  13815.               JE _nl2_1_r2
  13816.  
  13817.               CLD
  13818.               REP
  13819.               CMPSB
  13820.               JNE _nl3_1_r2
  13821. _nl2_1_r2:
  13822.               CMP EBX,EDX
  13823. _nl3_1_r2:
  13824.               POP ESI
  13825.               POP EDI
  13826.               POP EDX
  13827.               POP ECX
  13828.               POP EBX
  13829.               POP EAX
  13830.  
  13831.               LEAVE
  13832.               RETN32 8
  13833. SYSTEM.!PCharStrCmp ENDP
  13834.  
  13835.  
  13836. END;
  13837.  
  13838. //**************************************************************************
  13839. //
  13840. //    Random support
  13841. //
  13842. //**************************************************************************}
  13843.  
  13844. CONST
  13845.    Factor:WORD=$8405;
  13846.  
  13847. PROCEDURE Randomize;
  13848. VAR
  13849.    d:RECORD
  13850.            wYear:WORD;
  13851.            wMonth:WORD;
  13852.            wDayOfWeek:WORD;
  13853.            wDay:WORD;
  13854.            wHour:WORD;
  13855.            wMinute:WORD;
  13856.            wSecond:WORD;
  13857.            wMilliseconds:WORD;
  13858.      END;
  13859. BEGIN
  13860.      GetSystemTime(d);
  13861.      RandSeed:=(((d.wHour SHL 8)+d.wMinute) SHL 16)+
  13862.                 ((d.wSecond SHL 8)+d.wMilliseconds);
  13863. END;
  13864.  
  13865. PROCEDURE NextRandom;
  13866. BEGIN
  13867.      ASM
  13868.         MOV AX,SYSTEM.RandSeed
  13869.         MOV BX,SYSTEM.RandSeed+2
  13870.         MOV CX,AX
  13871.         MULW SYSTEM.Factor
  13872.         SHL CX,3
  13873.         ADD CH,CL
  13874.         ADD DX,CX
  13875.         ADD DX,BX
  13876.         SHL BX,2
  13877.         ADD DX,BX
  13878.         ADD DH,BL
  13879.         MOV CL,5
  13880.         SHL BX,CL
  13881.         ADD DH,BL
  13882.         ADD AX,1
  13883.         ADC DX,0
  13884.         MOV SYSTEM.RandSeed,AX
  13885.         MOV SYSTEM.RandSeed+2,DX
  13886.      END;
  13887. END;
  13888.  
  13889. FUNCTION  RANDOM(value:word):word;
  13890. BEGIN
  13891.      ASM
  13892.         CALLN32 SYSTEM.NextRandom
  13893.         MOV CX,DX
  13894.         MOV BX,$value
  13895.         MUL BX
  13896.         MOV AX,CX
  13897.         MOV CX,DX
  13898.         MUL BX
  13899.         ADD AX,CX
  13900.         ADC DX,0
  13901.         MOV AX,DX
  13902.         MOV $!FUNCRESULT,AX
  13903.     END;
  13904. END;
  13905.  
  13906. FUNCTION FloatRandom:EXTENDED;
  13907. BEGIN
  13908.      result:=Random(8192)/8192;
  13909. END;
  13910.  
  13911. //************************************************************************
  13912. //
  13913. //
  13914. // Direct Memory access support
  13915. //
  13916. //
  13917. //************************************************************************
  13918.  
  13919. PROCEDURE Move(CONST source; VAR dest; size:LONGWORD);ASSEMBLER;
  13920. ASM
  13921.         MOV ESI,$Source
  13922.         MOV EDI,$Dest
  13923.         MOV ECX,$Size
  13924.         CMP ESI,EDI
  13925.         JE !MoveEnd
  13926.         JA !MoveForw
  13927.         MOV EBX,ESI
  13928.         ADD EBX,ECX
  13929.         CMP EBX,EDI               // test overlapping
  13930.         JBE !MoveForw
  13931.  
  13932.         STD
  13933.         ADD ESI,ECX
  13934.         DEC ESI
  13935.         ADD EDI,ECX
  13936.         DEC EDI
  13937.         REP
  13938.         MOVSB
  13939.         CLD
  13940.         JMP !MoveEnd
  13941.  
  13942. !MoveForw:
  13943.         CLD
  13944.         MOV EDX,ECX
  13945.         SHR ECX,2
  13946.         REP
  13947.         MOVSD
  13948.         MOV ECX,EDX
  13949.         AND ECX,3
  13950.         REP
  13951.         MOVSB
  13952.  
  13953. !MoveEnd:
  13954. END;
  13955.  
  13956. PROCEDURE SaveMove(VAR source; VAR dest; size:LONGWORD);ASSEMBLER;
  13957. ASM
  13958.         PUSH EAX
  13959.         PUSH EBX
  13960.         PUSH ECX
  13961.         PUSH EDX
  13962.         PUSH EDI
  13963.         PUSH ESI
  13964.  
  13965.         MOV ESI,$Source
  13966.         MOV EDI,$Dest
  13967.         MOV ECX,$Size
  13968.         CMP ESI,EDI
  13969.         JE !MoveEnd_1
  13970.         JA !MoveForw_1
  13971.         MOV EBX,ESI
  13972.         ADD EBX,ECX
  13973.         CMP EBX,EDI               // test overlapping
  13974.         JBE !MoveForw_1
  13975.  
  13976.         STD
  13977.         ADD ESI,ECX
  13978.         DEC ESI
  13979.         ADD EDI,ECX
  13980.         DEC EDI
  13981.         REP
  13982.         MOVSB
  13983.         CLD
  13984.         JMP !MoveEnd_1
  13985.  
  13986. !MoveForw_1:
  13987.         CLD
  13988.         MOV EDX,ECX
  13989.         SHR ECX,2
  13990.         REP
  13991.         MOVSD
  13992.         MOV ECX,EDX
  13993.         AND ECX,3
  13994.         REP
  13995.         MOVSB
  13996.  
  13997. !MoveEnd_1:
  13998.         POP ESI
  13999.         POP EDI
  14000.         POP EDX
  14001.         POP ECX
  14002.         POP EBX
  14003.         POP EAX
  14004. END;
  14005.  
  14006. PROCEDURE CompareMem(VAR Buf1,Buf2;Size:LONGWORD);
  14007. BEGIN
  14008.      ASM
  14009.         CLD
  14010.         MOV ESI,$Buf1
  14011.         MOV EDI,$Buf2
  14012.         MOV ECX,$Size
  14013.         CLD
  14014.         REP
  14015.         CMPSB
  14016.      END;
  14017. END;
  14018.  
  14019. PROCEDURE FILLCHAR(VAR dest;size:LongWord;value:byte);ASSEMBLER;
  14020.     ASM
  14021.         CLD
  14022.         //Note: Stack is dword aligned !
  14023.         MOV EDI,$Dest      //Destination pointer
  14024.         MOV ECX,$Size      //count
  14025.         CMP ECX,0
  14026.         JE !ex_fillc
  14027.         MOV AL,$Value      //Value
  14028.         MOV AH,AL
  14029.         PUSH AX
  14030.         PUSH AX
  14031.         POP EAX
  14032.  
  14033.         MOV EDX,ECX
  14034.         SHR ECX,2
  14035.         REP
  14036.         STOSD
  14037.         MOV ECX,EDX
  14038.         AND ECX,3
  14039.         REP
  14040.         STOSB
  14041. !ex_fillc:
  14042.      END;
  14043.  
  14044. //Set Support
  14045. ASSEMBLER
  14046.  
  14047. SYSTEM.TestInSet32 PROC NEAR32
  14048.            PUSH EBP
  14049.            MOV EBP,ESP
  14050.  
  14051.            PUSH EAX
  14052.            PUSH EBX
  14053.            PUSH ECX
  14054.            PUSH EDX
  14055.            PUSH ESI
  14056.            PUSH EDI
  14057.  
  14058.            MOV EDI,[EBP+8]   //Set (32 Byte)
  14059.            MOV AX,[EBP+12]   //Byte or char value
  14060.  
  14061.            MOV BX,16
  14062.            XOR EDX,EDX
  14063.            DIV BX            //Calculate Word position
  14064.            SHL AX,1
  14065.            MOVZX EAX,AX
  14066.            ADD EDI,EAX
  14067.            MOV AX,DX         //Bit Position [0..15]
  14068.            SHL AX,1
  14069.            MOVZX EAX,AX
  14070.            MOV EBX,*SetTab_11
  14071.            ADD EBX,EAX
  14072.            MOV AX,[EBX+0]    //Bit value
  14073.            MOV BX,[EDI+0]    //Old Value
  14074.            AND AX,BX
  14075.            CMP AX,0
  14076.            JE !tis1          //not found
  14077.  
  14078.            MOV AX,0          //test successful
  14079.            CMP AX,0
  14080.  
  14081.            POP EDI
  14082.            POP ESI
  14083.            POP EDX
  14084.            POP ECX
  14085.            POP EBX
  14086.            POP EAX
  14087.  
  14088.            LEAVE
  14089.            RETN32 8
  14090. !tis1:
  14091.            MOV AX,1          //item not found
  14092.            CMP AX,0
  14093.  
  14094.            POP EDI
  14095.            POP ESI
  14096.            POP EDX
  14097.            POP ECX
  14098.            POP EBX
  14099.            POP EAX
  14100.  
  14101.            LEAVE
  14102.            RETN32 8
  14103. SetTab_11 dw 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768
  14104. SYSTEM.TestInSet32 ENDP
  14105.  
  14106. SYSTEM.SetAssign32 PROC NEAR32
  14107.           PUSH EBP
  14108.           MOV EBP,ESP
  14109.  
  14110.           PUSH EAX
  14111.           PUSH EBX
  14112.           PUSH ECX
  14113.           PUSH EDX
  14114.           PUSH ESI
  14115.           PUSH EDI
  14116.  
  14117.           MOV EDI,[EBP+8]    //Ziel
  14118.           MOV ECX,8
  14119.           MOV EAX,0
  14120.           CLD
  14121.           REP
  14122.           STOSD
  14123.  
  14124.           MOV EDI,[EBP+8]    //Ziel
  14125.           MOV ECX,[EBP+12]   //Parameter count
  14126.           CMP CX,0
  14127.           JE !NSAs           //only clear set
  14128.           MOVZX ECX,CX
  14129.           LEA ESI,[EBP+16]   //Points to first parameter
  14130. !plo:
  14131.           PUSH ECX
  14132.  
  14133.           MOV ECX,[ESI+0]    //Get parameter repeat
  14134.           CMP ECX,0
  14135.           JG !rr4
  14136.           JE !NSAs
  14137.           MOVSX ECX,CX
  14138.           INC ECX
  14139.           SUB ECX,[ESI+4]
  14140.           JLE !NSAs
  14141. !rr4:
  14142.           MOV EAX,[ESI+4]    //Get value of parameter
  14143.           ADD ESI,8          //to next parameter for next loop
  14144. !plo_rep:
  14145.           XOR AH,AH
  14146.           PUSH AX            //store parameter value
  14147.           MOV BX,16
  14148.           XOR EDX,EDX
  14149.           DIV BX             //Calculate Word position
  14150.           SHL AX,1
  14151.           MOVZX EAX,AX
  14152.           ADD EDI,EAX
  14153.           MOV AX,DX          //Bit Position [0..15]
  14154.           SHL AX,1
  14155.           MOVZX EAX,AX
  14156.           MOV EBX,*SetTab
  14157.           ADD EBX,EAX
  14158.           MOV AX,[EBX+0]
  14159.           MOVZX EAX,AX
  14160.           MOV BX,[EDI+0]    //Old Value
  14161.           OR AX,BX
  14162.           MOV [EDI+0],AX    //Store new value
  14163.  
  14164.           MOV EDI,[EBP+8]   //Ziel
  14165.  
  14166.           POP AX            //get parameter repeat
  14167.           INC AX            //next parameter if it is parameter..parameter
  14168.           LOOP !plo_rep
  14169.  
  14170.           POP ECX
  14171.           LOOP !plo         //until all parameters processed
  14172. !NSAs:
  14173.           POP EDI
  14174.           POP ESI
  14175.           POP EDX
  14176.           POP ECX
  14177.           POP EBX
  14178.           POP EAX
  14179.  
  14180.           LEAVE
  14181.           RETN32 8          //Return to caller
  14182. SetTab dw 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768
  14183. SYSTEM.SetAssign32 ENDP
  14184.  
  14185. SYSTEM.SetOr32 PROC NEAR32
  14186.           PUSH EBP
  14187.           MOV EBP,ESP
  14188.  
  14189.           PUSH EAX
  14190.           PUSH EBX
  14191.           PUSH ECX
  14192.           PUSH EDX
  14193.           PUSH ESI
  14194.           PUSH EDI
  14195.  
  14196.           MOV EDI,[EBP+8]   //Ziel
  14197.           MOV ESI,[EBP+12]
  14198.           MOV ECX,8
  14199. !SAndl_1:
  14200.           MOV EAX,[ESI+0]
  14201.           OR EAX,[EDI+0]
  14202.           MOV [EDI+0],EAX
  14203.           ADD ESI,4
  14204.           ADD EDI,4
  14205.           LOOP !SAndl_1
  14206.  
  14207.           POP EDI
  14208.           POP ESI
  14209.           POP EDX
  14210.           POP ECX
  14211.           POP EBX
  14212.           POP EAX
  14213.  
  14214.           LEAVE
  14215.           RETN32 8
  14216. SYSTEM.SetOr32 ENDP
  14217.  
  14218. SYSTEM.TempSetOr32 PROC NEAR32
  14219.            PUSH EBP
  14220.            MOV EBP,ESP
  14221.            SUB ESP,36
  14222.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  14223.  
  14224.            PUSH EAX
  14225.            PUSH EBX
  14226.            PUSH ECX
  14227.            PUSH EDX
  14228.            PUSH ESI
  14229.            PUSH EDI
  14230.  
  14231.            MOV [EBP-36],ESP
  14232.  
  14233.            MOV EDI,[EBP+8]   //Ziel
  14234.            MOV CL,[EBP+12]   //Count
  14235.            MOVZX ECX,CL
  14236.            CMP ECX,0
  14237.            JE !EndSetOr
  14238.            LEA ESI,[EBP+16]  //First Parameter
  14239. !TSAl_1:
  14240.            PUSHL [ESI+4]     //Value
  14241.            MOV EAX,[ESI+0]   //repeat count
  14242.            //CMP EAX,0
  14243.            //JG !rr1
  14244.            //JE !EndSetOr2     //Error
  14245.            //MOVSX EAX,AX
  14246.            //INC EAX
  14247.            //SUB EAX,[ESI+4]
  14248.            //JLE !EndSetOr2     //Error
  14249. !rr1:
  14250.            PUSH EAX          //repeat count
  14251.            ADD ESI,8
  14252.            LOOP !TSAl_1
  14253.  
  14254.            MOV CL,[EBP+12]   //Count
  14255.            MOVZX ECX,CL
  14256.            PUSH ECX
  14257.            LEA EAX,[EBP-32]
  14258.            PUSH EAX
  14259.            CALLN32 SYSTEM.SetAssign32
  14260. !EndSetOr2:
  14261.            MOV EAX,[EBP-36]  //Old ESP
  14262.            MOV ESP,EAX
  14263.  
  14264.            LEA EAX,[EBP-32]
  14265.            PUSH EAX
  14266.            MOV EAX,[EBP+8]   //Ziel
  14267.            PUSH EAX
  14268.            CALLN32 SYSTEM.SetOr32
  14269. !EndSetOr:
  14270.            POP EDI
  14271.            POP ESI
  14272.            POP EDX
  14273.            POP ECX
  14274.            POP EBX
  14275.            POP EAX
  14276.  
  14277.            LEAVE
  14278.            RETN32 8
  14279. SYSTEM.TempSetOr32 ENDP
  14280.  
  14281. SYSTEM.SetAnd32 PROC NEAR32
  14282.           PUSH EBP
  14283.           MOV EBP,ESP
  14284.  
  14285.           PUSH EAX
  14286.           PUSH EBX
  14287.           PUSH ECX
  14288.           PUSH EDX
  14289.           PUSH ESI
  14290.           PUSH EDI
  14291.  
  14292.           MOV EDI,[EBP+8]   //Ziel
  14293.           MOV ESI,[EBP+12]
  14294.           MOV ECX,8
  14295. !SAndl:
  14296.           MOV EAX,[ESI+0]
  14297.           AND EAX,[EDI+0]
  14298.           MOV [EDI+0],EAX
  14299.           ADD ESI,4
  14300.           ADD EDI,4
  14301.           LOOP !SAndl
  14302.  
  14303.           POP EDI
  14304.           POP ESI
  14305.           POP EDX
  14306.           POP ECX
  14307.           POP EBX
  14308.           POP EAX
  14309.  
  14310.           LEAVE
  14311.           RETN32 8
  14312. SYSTEM.SetAnd32 ENDP
  14313.  
  14314. SYSTEM.TempSetAnd32 PROC NEAR32
  14315.            PUSH EBP
  14316.            MOV EBP,ESP
  14317.            SUB ESP,36
  14318.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  14319.  
  14320.            PUSH EAX
  14321.            PUSH EBX
  14322.            PUSH ECX
  14323.            PUSH EDX
  14324.            PUSH ESI
  14325.            PUSH EDI
  14326.  
  14327.            MOV [EBP-36],ESP
  14328.  
  14329.            MOV EDI,[EBP+8]   //Ziel
  14330.            MOV CL,[EBP+12]   //Count
  14331.            MOVZX ECX,CL
  14332.            CMP ECX,0
  14333.            JNE !TSAW
  14334.            MOV EDI,[EBP+8]    //Ziel
  14335.            MOV ECX,8
  14336.            MOV EAX,0
  14337.            CLD
  14338.            REP
  14339.            STOSD
  14340.            JMP !TempSetAndE
  14341. !TSAW:
  14342.            LEA ESI,[EBP+16]  //First Parameter
  14343. !TSAl:
  14344.            PUSHL [ESI+4]     //value
  14345.            MOV EAX,[ESI+0]   //repeat count
  14346.            //CMP EAX,0
  14347.            //JG !rr2
  14348.            //JE !TempSetAndE2  //Error
  14349.            //MOVSX EAX,AX
  14350.            //INC EAX
  14351.            //SUB EAX,[ESI+4]
  14352.            //JLE !TempSetAndE2  //Error
  14353. !rr2:
  14354.            PUSH EAX          //repeat count
  14355.            ADD ESI,8
  14356.            LOOP !TSAl
  14357.  
  14358.            MOV CL,[EBP+12]   //Count
  14359.            MOVZX ECX,CL
  14360.            PUSH ECX
  14361.            LEA EAX,[EBP-32]
  14362.            PUSH EAX
  14363.            CALLN32 SYSTEM.SetAssign32
  14364. !TempSetAndE2:
  14365.            MOV EAX,[EBP-36]  //old ESP
  14366.            MOV ESP,EAX
  14367.  
  14368.            LEA EAX,[EBP-32]
  14369.            PUSH EAX
  14370.            MOV EAX,[EBP+8]   //Ziel
  14371.            PUSH EAX
  14372.            CALLN32 SYSTEM.SetAnd32
  14373. !TempSetAndE:
  14374.            POP EDI
  14375.            POP ESI
  14376.            POP EDX
  14377.            POP ECX
  14378.            POP EBX
  14379.            POP EAX
  14380.  
  14381.            LEAVE
  14382.            RETN32 8
  14383. SYSTEM.TempSetAnd32 ENDP
  14384.  
  14385. SYSTEM.TempSetCompare32 PROC NEAR32
  14386.            PUSH EBP
  14387.            MOV EBP,ESP
  14388.            SUB ESP,36
  14389.            DB $89,$04,$24    //Perform stack probe MOV [ESP],EAX
  14390.  
  14391.            PUSH EAX
  14392.            PUSH EBX
  14393.            PUSH ECX
  14394.            PUSH EDX
  14395.            PUSH ESI
  14396.            PUSH EDI
  14397.  
  14398.            MOV [EBP-36],ESP
  14399.  
  14400.            MOV EDI,[EBP+8]   //Ziel
  14401.            MOV ECX,[EBP+12]  //Count
  14402.            LEA ESI,[EBP+16]  //First Parameter
  14403.            CMP ECX,0         //empty set
  14404.            JNE !TCSAl_2
  14405.  
  14406.            //test empty set
  14407.            MOV EAX,0
  14408.            MOV ECX,8
  14409.            CLD
  14410.            REPE
  14411.            SCASD
  14412.            CMP ECX,0
  14413.            JMP !ex_comp
  14414. !TCSAl_2:
  14415.            PUSHL [ESI+4]     //Value
  14416.            MOV EAX,[ESI+0]
  14417.            //CMP EAX,0
  14418.            //JG !rr3
  14419.            //JE !ex_comp2     //Error
  14420.            //MOVSX EAX,AX
  14421.            //SUB EAX,[ESI+4]
  14422.            //JLE !ex_comp2     //Error
  14423. !rr3:
  14424.            PUSH EAX         //Repeat count
  14425.            ADD ESI,8
  14426.            LOOP !TCSAl_2
  14427.            PUSHL [EBP+12]    //Count
  14428.            LEA EAX,[EBP-32]
  14429.            PUSH EAX
  14430.            CALLN32 SYSTEM.SetAssign32
  14431. !ex_comp2:
  14432.            MOV EAX,[EBP-36]  //old ESP
  14433.            MOV ESP,EAX
  14434.  
  14435.            CLD
  14436.            LEA ESI,[EBP-32]
  14437.            MOV EDI,[EBP+8]
  14438.            MOV ECX,32
  14439.            CLD
  14440.            REP
  14441.            CMPSB
  14442. !ex_comp:
  14443.            POP EDI
  14444.            POP ESI
  14445.            POP EDX
  14446.            POP ECX
  14447.            POP EBX
  14448.            POP EAX
  14449.  
  14450.            LEAVE
  14451.            RETN32 8
  14452. SYSTEM.TempSetCompare32 ENDP
  14453.  
  14454. SYSTEM.NegateSet32 PROC NEAR32
  14455.           PUSH EBP
  14456.           MOV EBP,ESP
  14457.  
  14458.           PUSH EAX
  14459.           PUSH EBX
  14460.           PUSH ECX
  14461.           PUSH EDX
  14462.           PUSH ESI
  14463.           PUSH EDI
  14464.  
  14465.           MOV EDI,[EBP+8]
  14466.           MOV ECX,8
  14467. !NS_l:
  14468.           MOV EAX,[EDI+0]
  14469.           NOT EAX
  14470.           MOV [EDI+0],EAX
  14471.           ADD EDI,4
  14472.           LOOP !NS_l
  14473.  
  14474.           POP EDI
  14475.           POP ESI
  14476.           POP EDX
  14477.           POP ECX
  14478.           POP EBX
  14479.           POP EAX
  14480.  
  14481.           LEAVE
  14482.           RETN32 4
  14483. SYSTEM.NegateSet32 ENDP
  14484.  
  14485. END;
  14486.  
  14487. //************************************************************************
  14488. //
  14489. //
  14490. // VMT and object handling support
  14491. //
  14492. //
  14493. //************************************************************************
  14494.  
  14495. {$IFOPT D-}
  14496. {$D+}
  14497. {$ELSE}
  14498. {$DEFINE WASDEBUG}
  14499. {$ENDIF}
  14500.  
  14501. ASSEMBLER
  14502.  
  14503. SYSTEM.!VMTCall PROC NEAR32
  14504.         MOV EBX,ESP
  14505.         MOV EDI,[EBX+4]
  14506.         MOV EDI,[EDI+0]
  14507.         CMP EDI,0
  14508.         JNE !VmtWeiter
  14509.         MOV EDI,[EBX+4]
  14510.         CMPD [EDI+4],0
  14511.         JNE !VmtConstructor
  14512.         PUSHL 214
  14513.         CALLN32 SYSTEM.RunError
  14514. !VmtConstructor:
  14515.         MOV EDI,[EDI+4]
  14516. !VmtWeiter:
  14517.         LEA EDI,[EDI+EAX*4]
  14518.         JMP [EDI+0]
  14519. SYSTEM.!VMTCall ENDP
  14520.  
  14521. END;
  14522.  
  14523. {$IFNDEF WASDEBUG}
  14524. {$D-}
  14525. {$ENDIF}
  14526.  
  14527. {$UNDEF WASDEBUG}
  14528.  
  14529.  
  14530. //************************************************************************
  14531. //
  14532. //
  14533. // Floating point support
  14534. //
  14535. //
  14536. //************************************************************************
  14537.  
  14538. PROCEDURE SetTrigMode(mode:BYTE);
  14539. BEGIN
  14540.      CASE Mode OF
  14541.         Rad:IsNotRad:=FALSE;
  14542.         Deg:
  14543.         BEGIN
  14544.              ToRad:=0.01745329262;
  14545.              FromRad:=57.29577951;
  14546.              IsNotRad:=TRUE;
  14547.         END;
  14548.         Gra:
  14549.         BEGIN
  14550.              ToRad:=0.01570796327;
  14551.              FromRad:=63.66197724;
  14552.              IsNotRad:=TRUE;
  14553.         END;
  14554.      END; {case}
  14555. END;
  14556.  
  14557. ASSEMBLER
  14558.  
  14559. SYSTEM.!FormatStr PROC NEAR32  //Format in AL, String in EDI
  14560.         //Format the string
  14561.         CMP AL,0
  14562.         JE !LLw47_1
  14563.  
  14564.         MOV AH,[EDI+0]  //Length of string
  14565.         CMP AH,AL
  14566.         JAE !LLw47_1    //No format to do
  14567.  
  14568.         SUB AL,AH       //Calculate spaces to add
  14569.         ADD [EDI+0],AL  //Set length to new value
  14570.         PUSH EDI
  14571.  
  14572.         MOVZX EBX,AH    //old length of string
  14573.         ADD EDI,EBX     //End of string
  14574.  
  14575.         MOVZX EBX,AL    //Count of spaces to add
  14576.         MOV ESI,EDI
  14577.         ADD EDI,EBX     //add count of spaces
  14578.  
  14579.         MOVZX ECX,AH    //Count (Length of string) to ECX
  14580.         INC ECX         //and #0
  14581.  
  14582.         STD             //From backwards
  14583.         REP
  14584.         MOVSB
  14585.  
  14586.         MOV ECX,EBX
  14587.         MOV AL,32       //Space
  14588.  
  14589.         POP EDI         //Pop it
  14590.         PUSH EDI
  14591.         INC EDI
  14592.         CLD
  14593.         REP
  14594.         STOSB
  14595.  
  14596.         POP EDI
  14597.         MOVZXB EAX,[EDI+0]
  14598.         INC EDI
  14599.         ADD EDI,EAX
  14600.         CLD
  14601. !LLw47_1:
  14602.         RETN32
  14603. SYSTEM.!FormatStr ENDP
  14604.  
  14605. SYSTEM.!RadArc PROC NEAR32      //Converts ST(0) to Rad
  14606.        CMPB SYSTEM.IsNotRad,1
  14607.        JNE !!!_l80
  14608.        FLDT SYSTEM.ToRad
  14609.        FMULP ST(1),ST
  14610. !!!_l80:
  14611.        RETN32
  14612. SYSTEM.!RadArc ENDP
  14613.  
  14614. SYSTEM.!NormRad PROC NEAR32     //Converts ST(0) to actual TrigMode
  14615.        CMPB SYSTEM.IsNotRad,1
  14616.        JNE !!!_l81
  14617.        FLDT SYSTEM.FromRad
  14618.        FMULP ST(1),ST
  14619. !!!_l81:
  14620.        RETN32
  14621. SYSTEM.!NormRad ENDP
  14622.  
  14623.  
  14624. SYSTEM.!Calculate PROC NEAR32
  14625. //Input EDI String
  14626. //CX Count
  14627. //Output Value in ST(0)
  14628.          PUSH EBP
  14629.          MOV EBP,ESP
  14630.          SUB ESP,4
  14631.          DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  14632. !!!weiter1:
  14633.          MOV AL,[EDI+0]
  14634.          SUB AL,$3a
  14635.          ADD AL,$0a
  14636.          JNB !!!ex
  14637.          XOR AH,AH
  14638.          MOV [EBP-2],AX
  14639.          FILDD SYSTEM.C10
  14640.          FMULP ST(1),ST
  14641.          FILDW [EBP-2]
  14642.          FADDP ST(1),ST
  14643.          FWAIT
  14644.          INC EDI
  14645.          DEC CX
  14646.          CMP CX,0
  14647.          JE !!!ex
  14648.          JMP !!!weiter1
  14649. !!!ex:
  14650.          LEAVE
  14651.          RETN32
  14652. SYSTEM.!Calculate ENDP
  14653.  
  14654. SYSTEM.!DivTab PROC NEAR32
  14655.         dw 0,0,0,32768,16383,0,0,0             //1
  14656.         dw 0,0,0,40960,16386,0,0,0             //10
  14657.         dw 0,0,0,51200,16389,0,0,0             //100
  14658.         dw 0,0,0,64000,16392,0,0,0             //1000
  14659.         dw 0,0,0,40000,16396,0,0,0             //10^4
  14660.         dw 0,0,0,50000,16399,0,0,0             //10^5
  14661.         dw 0,0,0,62500,16402,0,0,0             //10^6
  14662.         dw 0,0,32768,39062,16406,0,0,0         //10^7
  14663.         dw 0,0,8192,48828,16409,0,0,0          //10^8
  14664. SYSTEM.!DivTab ENDP
  14665.  
  14666. SYSTEM.!Power10Tab PROC NEAR32
  14667.            db 0,0,0,0,0,$20,$bc,$be,$19,$40                  //1.0E+8
  14668.            db 0,0,0,4,$bf,$c9,$1b,$8e,$34,$40                //1.0E+16
  14669.            db $9e,$b5,$70,$2b,$a8,$ad,$c5,$9d,$69,$40        //1.0E+32
  14670.            db $d5,$a6,$cf,$0ff,$49,$1f,$78,$c2,$d3,$40        //1.0E+64
  14671.            db $e0,$8c,$e9,$80,$c9,$47,$ba,$93,$a8,$41        //1.0E+128
  14672.            db $8e,$de,$0f9,$9d,$0fb,$eb,$7e,$aa,$51,$43        //1.0E+256
  14673.            db $c7,$91,$0e,$a6,$ae,$a0,$19,$e3,$a3,$46        //1.0E+512
  14674.            db $17,$0c,$75,$81,$86,$75,$76,$c9,$48,$4d        //1.0E+1024
  14675.            db $e5,$5d,$3d,$c5,$5d,$3b,$8b,$9e,$92,$5a        //1.0E+2048
  14676.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  14677. SYSTEM.!Power10Tab ENDP
  14678.  
  14679. SYSTEM.!MaxMulTab PROC NEAR32
  14680.            db $9b,$97,$20,$8a,2,$52,$60,$c4,$25,$75          //1.0E+4096
  14681. SYSTEM.!MaxMulTab ENDP
  14682.  
  14683. SYSTEM.!DivMul10 PROC NEAR32
  14684. //Input: BX Count of divides/mult by 10
  14685. //       AL 0-mult 1-divide
  14686.         MOV CX,BX
  14687.         AND CX,7  //31 only values 0..31
  14688.         MOV ESI,@SYSTEM.!DivTab
  14689.         MOVZX ECX,CX
  14690.         SHL ECX,1
  14691.         SHL ECX,1
  14692.         SHL ECX,1
  14693.         SHL ECX,1
  14694.         ADD ESI,ECX
  14695.         FLDT [ESI+0]   //1..10^32 laden
  14696.         SHR BX,1
  14697.         SHR BX,1
  14698.         SHR BX,1                //divide numbers by 8
  14699.         MOV ESI,@SYSTEM.!Power10Tab
  14700.         CMP BX,0
  14701.         JE !!!process
  14702. !!!Power10:
  14703.         SHR BX,1
  14704.         JNB !!!mm            //until a bit is set
  14705.         FLDT [ESI+0]
  14706.         FMULP ST(1),ST
  14707. !!!mm:
  14708.         ADD ESI,10
  14709.         CMP BX,0
  14710.         JNE !!!Power10
  14711. !!!process:
  14712.         CMP AL,1
  14713.         JNE !!!_mul
  14714.         FDIVP ST(1),ST
  14715.         RETN32
  14716. !!!_mul:
  14717.         FMULP ST(1),ST
  14718.         RETN32
  14719. SYSTEM.!DivMul10 ENDP
  14720.  
  14721. SYSTEM.!Str2Float PROC NEAR32
  14722. //Input EDI  String to convert
  14723. //      CX     Length of this string
  14724. //Output Floating point value in ST(0)
  14725.         PUSH EBP
  14726.         MOV EBP,ESP
  14727.         SUB ESP,6                //for Control word and sign
  14728.         DB $89,$04,$24           //Perform stack probe MOV [ESP],EAX
  14729.  
  14730.         FSTCW [EBP-2]            //Store control word
  14731.         FWAIT
  14732.         FCLEX                    //Clear exceptions
  14733.         FLDCW SYSTEM.FPUControl  //Load control word
  14734.         FWAIT
  14735.         FLDZ                     //Load +0.0
  14736.         MOVB [EBP-4],0           //sign is positive
  14737.         MOVW [EBP-6],0           //count of numbers after point
  14738. !!!again:
  14739.         CMP CX,0                 //String has zero length ?
  14740.         JE !!!Error
  14741.  
  14742.         MOV AL,[EDI+0]        //load character
  14743.         CMP AL,43  //'+'
  14744.         JNE !!!not_plus
  14745.         //Sign '+' was detected
  14746.         INC EDI
  14747.         DEC CX
  14748.         CMP CX,0
  14749.         JE !!!Error
  14750.         JMP !!!weiter
  14751. !!!not_plus:
  14752.         CMP AL,45   //'-'
  14753.         JNE !!!not_minus
  14754.         //Sign '-' was detected
  14755.         MOVB [EBP-4],1 //Sign is negative
  14756.         INC EDI
  14757.         DEC CX
  14758.         CMP CX,0
  14759.         JE !!!Error
  14760.         JMP !!!weiter
  14761. !!!not_minus:
  14762.         CMP AL,32
  14763.         JNE !!!weiter
  14764.         INC EDI
  14765.         DEC CX
  14766.         JMP !!!again
  14767. !!!weiter:
  14768.         CALLN32 SYSTEM.!Calculate   //Calculate numbers before point
  14769.         CMP CX,0
  14770.         JNE !!!a_exp
  14771.         CMPB [EBP-4],1
  14772.         JNE !!!no_exp
  14773.         FCHS
  14774.         FWAIT         //change sign
  14775.         JMP !!!no_exp
  14776. !!!a_exp:
  14777.         //Look for .
  14778.         MOV AL,[EDI+0]
  14779.         CMP AL,'.'
  14780.         JNE !!!Change
  14781.         DEC CX
  14782.         INC EDI
  14783.         PUSH CX
  14784.         CALLN32 SYSTEM.!Calculate    //Calculate numbers after point
  14785.         POP BX
  14786.         SUB BX,CX
  14787.         MOV [EBP-6],BX               //Count of numbers after point
  14788. !!!Change:
  14789.         //in ST(0) is now an integer value
  14790.         //[EBP-6] contains the current numbers after the point
  14791.         CMPB [EBP-4],1
  14792.         JNE !!!not_neg
  14793.         FCHS
  14794.         FWAIT         //change sign
  14795. !!!not_neg:
  14796.         //Check for exponent
  14797.         CMP CX,0
  14798.         JE !!!no_exp
  14799.         MOV AL,[EDI+0]
  14800.         CMP AL,'e'
  14801.         JE !!!exp
  14802.         CMP AL,'E'
  14803.         JNE !!!no_exp
  14804. !!!exp:
  14805.         //an exponent was detected
  14806.         INC EDI
  14807.         DEC CX
  14808.         CMP CX,0
  14809.         JE !!!Error
  14810.         FLDZ          //Load +0.0
  14811.         MOVB [EBP-4],0    //sign is positive
  14812.         MOV AL,[EDI+0]
  14813.         CMP AL,'-'
  14814.         JNE !!!no_minus
  14815.         MOVB [EBP-4],1   //sign is negative
  14816.         INC EDI
  14817.         DEC CX
  14818.         CMP CX,0
  14819.         JE !!!Error
  14820.         JMP !!!Calc
  14821. !!!no_minus:
  14822.         CMP AL,43   //'+'
  14823.         JNE !!!calc
  14824.         INC EDI
  14825.         DEC CX
  14826.         CMP CX,0
  14827.         JE !!!Error
  14828. !!!calc:
  14829.         CALLN32 SYSTEM.!Calculate
  14830.         FISTPW SYSTEM.Exponent      //Store integer value and pop
  14831.         MOV BX,SYSTEM.Exponent
  14832.         MOV AL,0                    //Mult
  14833.         CMPB [EBP-4],1
  14834.         JNE !!!make
  14835.         MOV AL,1                    //Divide if Exponent negative
  14836. !!!make:
  14837.         PUSH CX
  14838.         CALLN32 SYSTEM.!DivMul10
  14839.         POP CX
  14840. !!!no_exp:
  14841.         CMP CX,0
  14842.         JNE !!!Error                //invalid chars
  14843.         MOV BX,[EBP-6]
  14844.         MOV AL,1                    //Divide
  14845.         CALLN32 SYSTEM.!DivMul10
  14846.         JMP !!!ok
  14847. !!!Error:
  14848.         MOVW SYSTEM.IoResult,1      //FPU error
  14849. !!!ok:
  14850.         LEAVE
  14851.         RETN32
  14852. SYSTEM.!Str2Float ENDP
  14853.  
  14854. SYSTEM.!Str2Real PROC NEAR32
  14855.        PUSH EBP
  14856.        MOV EBP,ESP
  14857.  
  14858.        MOV EDI,[EBP+16]
  14859.        MOV CL,[EDI+0]
  14860.        INC EDI
  14861.        XOR CH,CH
  14862.        CALLN32 SYSTEM.!Str2Float
  14863.        MOV EDI,[EBP+12]
  14864.        FSTPD [EDI+0]
  14865.  
  14866.        MOV EDI,[EBP+8]      //Result
  14867.        MOVW [EDI+0],0
  14868.        CMPW SYSTEM.FPUResult,0
  14869.        JE !!__fex1
  14870.        MOVW [EDI+0],1
  14871. !!__fex1:
  14872.        LEAVE
  14873.        RETN32 12
  14874. SYSTEM.!Str2Real ENDP
  14875.  
  14876. SYSTEM.!Str2Double PROC NEAR32
  14877.        PUSH EBP
  14878.        MOV EBP,ESP
  14879.  
  14880.        MOV EDI,[EBP+16]
  14881.        MOV CL,[EDI+0]
  14882.        INC EDI
  14883.        XOR CH,CH
  14884.        CALLN32 SYSTEM.!Str2Float
  14885.        MOV EDI,[EBP+12]
  14886.        FSTPQ [EDI+0]
  14887.  
  14888.        MOV EDI,[EBP+8]     //Result
  14889.        MOVW [EDI+0],0
  14890.        CMPW SYSTEM.FPUResult,0
  14891.        JE !!__fex11
  14892.        MOVW [EDI+0],1
  14893. !!__fex11:
  14894.        LEAVE
  14895.        RETN32 12
  14896. SYSTEM.!Str2Double ENDP
  14897.  
  14898. SYSTEM.!Str2Extended PROC NEAR32
  14899.        PUSH EBP
  14900.        MOV EBP,ESP
  14901.  
  14902.        MOV EDI,[EBP+16]
  14903.        MOV CL,[EDI+0]
  14904.        INC EDI
  14905.        XOR CH,CH
  14906.        CALLN32 SYSTEM.!Str2FLoat
  14907.        MOV EDI,[EBP+12]
  14908.        FSTPT [EDI+0]
  14909.  
  14910.        MOV EDI,[EBP+8]   //Result
  14911.        MOVW [EDI+0],0
  14912.        CMPW SYSTEM.FPUResult,0
  14913.        JE !!__fex111
  14914.        MOVW [EDI+0],1
  14915. !!__fex111:
  14916.        LEAVE
  14917.        RETN32 12
  14918. SYSTEM.!Str2Extended ENDP
  14919.  
  14920. SYSTEM.!ValReal PROC NEAR32
  14921.         //Input EDI : Destination String
  14922.         //AX Kommastellen
  14923.         //BX Len oder 17h
  14924.         //Floatvalue in ST(0)
  14925.         PUSH EBP
  14926.         MOV EBP,ESP
  14927.         SUB ESP,264
  14928.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  14929. $result EQU [EBP-256]
  14930. $len    EQU [EBP-258]
  14931. $comma  EQU [EBP-260]
  14932. $s      EQU [EBP-264]
  14933.  
  14934.         MOV $comma,AX
  14935.         CMP BX,0
  14936.         JA !!6666
  14937.         MOV BX,1
  14938. !!6666:
  14939.         CMP BX,254   //$17
  14940.         JB !!6666_1
  14941.         MOV BX,$17
  14942. !!6666_1:
  14943.         MOV $len,BX
  14944.         MOV $s,EDI
  14945.  
  14946.         MOV CX,$comma
  14947.         OR CX,CX
  14948.         JNS !!37ea
  14949.         MOV CX,8
  14950.         SUB CX,$len
  14951.         CMP CX,$0FFFE
  14952.         JLE !!37ea
  14953.         MOV CX,$0FFFE
  14954. !!37ea:
  14955.         LEA EDI,$result
  14956.         CALLN32 SYSTEM.!Real2Str1  //Get string in EDI and length in CX
  14957.  
  14958.         MOV ESI,EDI
  14959.         MOV EDI,$s
  14960.         MOV DX,255
  14961.         MOV AX,$len
  14962.         CMP AX,CX
  14963.         JNL !!3812
  14964.         MOV AX,CX
  14965. !!3812:
  14966.         CLD
  14967.         STOSB
  14968.         SUB AX,CX
  14969.         JE !!3820
  14970.         PUSH CX
  14971.         MOVZX ECX,AX
  14972.         MOV AL,$20
  14973.         REP
  14974.         STOSB
  14975.         POP CX
  14976. !!3820:
  14977.         MOVZX ECX,CX
  14978.         REP
  14979.         MOVSB
  14980.  
  14981.         LEAVE
  14982.         RETN32
  14983. SYSTEM.!ValReal ENDP
  14984.  
  14985. SYSTEM.!!!!!Help1 PROC NEAR32
  14986.         FWAIT
  14987.         FSTCW [EBP-2]
  14988.         FWAIT
  14989.         FCLEX
  14990.         FLDCW SYSTEM.FpuControl
  14991.         FWAIT
  14992.         FSTPT [EBP-$14]
  14993.  
  14994.         XOR EDX,EDX
  14995.         CMP CX,$12
  14996.         JLE !!311a
  14997.         MOV CX,$12
  14998. !!311a:
  14999.         CMP CX,$0FFEE
  15000.         JNL !!3122
  15001.         MOV CX,$0FFEE
  15002. !!3122:
  15003.         RETN32
  15004. SYSTEM.!!!!!Help1 ENDP
  15005.  
  15006. SYSTEM.!!!!!Help2 PROC NEAR32
  15007.         MOV [EBP-$0c],AX
  15008.         FLDT [EBP-$14]
  15009.         SUB AX,$3FFF
  15010.         XOR EDX,EDX
  15011.         MOV DX,$4D10
  15012.         IMUL DX
  15013.         MOV [EBP-8],DX
  15014.         MOV AX,$11
  15015.         SUB AX,DX
  15016.         CALLN32 SYSTEM.!Div_Mul10
  15017.         FRNDINT
  15018.         MOV ESI,*Tabx1
  15019.         FLDT [ESI+0]
  15020.         FCOMP ST(1)
  15021.         FSTSW [EBP-4]
  15022.         FWAIT
  15023.         RETN32
  15024. Tabx1:
  15025.      db 0,0,$40,$76,$3a,$6b,$0b,$de,$3a,$40
  15026. SYSTEM.!!!!!Help2 ENDP
  15027.  
  15028. SYSTEM.!!!!!Help3 PROC NEAR32
  15029.         MOV AL,$45
  15030.         STOSB
  15031.         MOV AL,$2b
  15032.         MOV DX,[EBP-8]
  15033.         OR DX,DX
  15034.         JNS !!3280
  15035.         MOV AL,$2d
  15036.         NEG DX
  15037. !!3280:
  15038.         STOSB
  15039.         MOV EAX,$640a
  15040.         XCHG DX,AX
  15041.         DIV DH
  15042.         MOV DH,AH
  15043.         DB $66
  15044.         CBW
  15045.         DIV DL
  15046.         ADD AX,$3030
  15047.         STOSW
  15048.         MOV AL,DH
  15049.         DB $66
  15050.         CBW
  15051.         DIV DL
  15052.         ADD AX,$3030
  15053.         STOSW
  15054.         RETN32
  15055. SYSTEM.!!!!!Help3 ENDP
  15056.  
  15057. SYSTEM.!Real2Str1 PROC NEAR32
  15058.         PUSH EBP
  15059.         MOV EBP,ESP
  15060.         SUB ESP,$28
  15061.         DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15062.  
  15063.         PUSH EDI
  15064.         CALLN32 SYSTEM.!!!!!Help1
  15065.  
  15066.         CLD
  15067.         NOP
  15068.         FWAIT
  15069.         MOV [EBP-6],CX
  15070.         MOV AX,[EBP-$0c]
  15071.         MOV [EBP-$0a],AX
  15072.         AND AX,$7FFF
  15073.         JE !!315c
  15074.         CMP AX,$7FFF
  15075.         JNE !!3165
  15076.         CMPW [EBP-$0e],$8000
  15077.         JE !!3149
  15078.         MOV AX,$414e
  15079.         STOSW
  15080.         MOV AL,$4e
  15081.         STOSB
  15082.         JMP !!3299
  15083. !!3149:
  15084.         CMPW [EBP-$0a],0
  15085.         JNS !!3152
  15086.         MOV AL,$2d
  15087.         STOSB
  15088. !!3152:
  15089.         MOV AX,$4e49
  15090.         STOSW
  15091.         MOV AL,$46
  15092.         STOSB
  15093.         JMP !!3299
  15094. !!315c:
  15095.         MOV [EBP-8],AX
  15096.         MOV [EBP-$28],AL
  15097.         JMP !!3216
  15098. !!3165:
  15099.         CALLN32 SYSTEM.!!!!!Help2
  15100.         TESTW [EBP-4],$4100
  15101.         JE !!31a1
  15102.         INCW [EBP-8]
  15103.         FILDD SYSTEM.C10
  15104.         FDIVP ST(1),ST
  15105. !!31a1:
  15106.         PUSH EBP
  15107.         POP ESI
  15108.         FBSTPT [ESI-$14]
  15109.         MOV ESI,9
  15110.         LEA EBX,[EBP-$28]
  15111.         MOV CL,4
  15112.         FWAIT
  15113. !!31af:
  15114.         PUSH EDI
  15115.         LEA EDI,[EBP-$15]
  15116.         ADD EDI,ESI
  15117.         MOV AL,[EDI+0]
  15118.         POP EDI
  15119.         MOV AH,AL
  15120.         SHR AL,CL
  15121.         AND AH,$0F
  15122.         ADD AX,$3030
  15123.         MOV [EBX+0],AX
  15124.         ADD EBX,2
  15125.         DEC ESI
  15126.         JNE !!31af
  15127.  
  15128.         MOV [EBX+0],SI
  15129.         CMPW [EBP-6],0
  15130.         JL !!31d8
  15131.         CMPW [EBP-8],$24
  15132.         JL !!31d8
  15133.         MOVW [EBP-6],$0FFEE
  15134. !!31d8:
  15135.         MOV SI,[EBP-6]
  15136.         OR SI,SI
  15137.         JS !!31eb
  15138.         ADD SI,[EBP-8]
  15139.         INC SI
  15140.         JNS !!31ed
  15141.         MOVB [EBP-$28],0
  15142.         JMP !!3216
  15143. !!31eb:
  15144.         NEG SI
  15145. !!31ed:
  15146.         CMP SI,$12
  15147.         JNB !!3216
  15148.  
  15149.         MOVZX ESI,SI
  15150.         PUSH EDI
  15151.         LEA EDI,[EBP-$28]
  15152.         ADD EDI,ESI
  15153.         CMPB [EDI+0],$35
  15154.         MOVB [EDI+0],0
  15155.         POP EDI
  15156.         JB !!3216
  15157. !!31fc:
  15158.         DEC SI
  15159.         JS !!320e
  15160.         MOVZX ESI,SI
  15161.         PUSH EDI
  15162.         LEA EDI,[EBP-$28]
  15163.         ADD EDI,ESI
  15164.         INCB [EDI+0]
  15165.         CMPB [EDI+0],$39
  15166.         POP EDI
  15167.         JBE !!3216
  15168.  
  15169.         PUSH EDI
  15170.         LEA EDI,[EBP-$28]
  15171.         ADD EDI,ESI
  15172.         MOVB [EDI+0],0
  15173.         POP EDI
  15174.         JMP !!31fc
  15175. !!320e:
  15176.         INCW [EBP-8]
  15177.         MOVW [EBP-$28],$31
  15178. !!3216:
  15179.         XOR ESI,ESI
  15180.         MOV DX,[EBP-6]
  15181.         OR DX,DX
  15182.         JS !!3254
  15183.         CMPW [EBP-$0a],0
  15184.         JNS !!3228
  15185.         MOV AL,$2d
  15186.         STOSB
  15187. !!3228:
  15188.         MOV CX,[EBP-8]
  15189.         OR CX,CX
  15190.         JNS !!3234
  15191.         MOV AL,$30
  15192.         STOSB
  15193.         JMP !!323b
  15194. !!3234:
  15195.         PUSH EDI
  15196.         MOVZX ESI,SI
  15197.         LEA EDI,[EBP-$28]
  15198.         ADD EDI,ESI
  15199.         MOV AL,[EDI+0]
  15200.         INC SI
  15201.         POP EDI
  15202.         OR AL,AL
  15203.         JNE !!32b6
  15204.         MOV AL,$30
  15205.         DEC SI
  15206. !!32b6:
  15207.         STOSB
  15208.         DEC CX
  15209.         JNS !!3234
  15210. !!323b:
  15211.         OR DX,DX
  15212.         JE !!3299
  15213.         MOV AL,$2e
  15214.         STOSB
  15215. !!3242:
  15216.         INC CX
  15217.         JE !!324b
  15218. !!3245:
  15219.         MOV AL,$30
  15220.         STOSB
  15221.         DEC DX
  15222.         JNE !!3242
  15223. !!324b:
  15224.         DEC DX
  15225.         JS !!3299
  15226.         PUSH EDI
  15227.         MOVZX ESI,SI
  15228.         LEA EDI,[EBP-$28]
  15229.         ADD EDI,ESI
  15230.         MOV AL,[EDI+0]
  15231.         INC SI
  15232.         POP EDI
  15233.         OR AL,AL
  15234.         JNE !!32b6_1a
  15235.         MOV AL,$30
  15236.         DEC SI
  15237. !!32b6_1a:
  15238.         STOSB
  15239.         JMP !!324b
  15240. !!3254:
  15241.         MOV AL,$20
  15242.         CMPW [EBP-$0a],0
  15243.         JNS !!325e
  15244.         MOV AL,$2d
  15245. !!325e:
  15246.         STOSB
  15247.         PUSH EDI
  15248.         MOVZX ESI,SI
  15249.         LEA EDI,[EBP-$28]
  15250.         ADD EDI,ESI
  15251.         INC SI
  15252.         MOV AL,[EDI+0]
  15253.         POP EDI
  15254.         OR AL,AL
  15255.         JNE !!32b6_1b
  15256.         MOV AL,$30
  15257.         DEC SI
  15258. !!32b6_1b:
  15259.         STOSB
  15260.         INC DX
  15261.         JE !!3270
  15262.         MOV AL,$2e
  15263.         STOSB
  15264. !!3269:
  15265.         PUSH EDI
  15266.         MOVZX ESI,SI
  15267.         LEA EDI,[EBP-$28]
  15268.         ADD EDI,ESI
  15269.         INC SI
  15270.         MOV AL,[EDI+0]
  15271.         POP EDI
  15272.         OR AL,AL
  15273.         JNE !!32b6_1c
  15274.         MOV AL,$30
  15275.         DEC SI
  15276. !!32b6_1c:
  15277.         STOSB
  15278.         INC DX
  15279.         JNE !!3269
  15280. !!3270:
  15281.         CALLN32 SYSTEM.!!!!!Help3
  15282. !!3299:
  15283.         MOV ECX,EDI
  15284.         POP EDI
  15285.         SUB ECX,EDI
  15286.         FCLEX            //Clear Exceptions
  15287.         FLDCW [EBP-2]
  15288.         FWAIT
  15289.  
  15290.         LEAVE
  15291.         RETN32
  15292. {*Tab1:
  15293.      db 0,0,40h,76h,3ah,6bh,0bh,deh,3ah,40h}
  15294. SYSTEM.!Real2Str1 ENDP
  15295.  
  15296.  
  15297. SYSTEM.!Div_Mul10 PROC NEAR32
  15298.         CMP AX,$1000
  15299.         JLE !!3382
  15300.         PUSH ESI
  15301.         MOV ESI,@SYSTEM.!MaxMulTab
  15302.         FLDT [ESI+0]
  15303.         POP ESI
  15304.         FMULP ST(1),ST
  15305.         SUB AX,$1000
  15306. !!3382:
  15307.         CMP AX,$0F000
  15308.         JNL !!3393
  15309.         PUSH ESI
  15310.         MOV ESI,@SYSTEM.!MaxMulTab
  15311.         FLDT [ESI+0]
  15312.         POP ESI
  15313.         FDIVP ST(1),ST
  15314.         ADD AX,$1000
  15315. !!3393:
  15316.         MOV BX,AX
  15317.         OR AX,AX
  15318.         JE !!33d4
  15319.         JNS !!339d
  15320.         NEG AX
  15321. !!339d:
  15322.         MOV SI,AX
  15323.         AND SI,7
  15324.         MOVZX ESI,SI
  15325.         SHL ESI,1
  15326.         SHL ESI,1
  15327.         SHL ESI,1
  15328.         SHL ESI,1
  15329.         PUSH EDI
  15330.         MOV EDI,@SYSTEM.!DivTab
  15331.         ADD EDI,ESI
  15332.         FLDT [EDI+0]
  15333.         POP EDI
  15334.         SHR AX,1
  15335.         SHR AX,1
  15336.         SHR AX,1
  15337.         MOV ESI,@SYSTEM.!Power10Tab
  15338.         JMP !!33c5
  15339. !!33b7:
  15340.         SHR AX,1
  15341.         JNB !!33c2
  15342.         FLDT [ESI+0]
  15343.         FMULP ST(1),ST
  15344. !!33c2:
  15345.         ADD ESI,10
  15346. !!33c5:
  15347.         OR AX,AX
  15348.         JNE !!33b7
  15349.         OR BX,BX
  15350.         JS !!33d1
  15351.         FMULP ST(1),ST
  15352. !!33d0:
  15353.         RETN32
  15354. !!33d1:
  15355.         FDIVP ST(1),ST
  15356. !!33d4:
  15357.         RETN32
  15358. SYSTEM.!Div_Mul10 ENDP
  15359.  
  15360.  
  15361. SYSTEM.!Real2Str PROC NEAR32  //Format in [EBP+16]
  15362.         PUSH EBP
  15363.         MOV EBP,ESP
  15364.  
  15365.         PUSH EDI
  15366.         PUSH ESI
  15367.  
  15368.         MOV EDI,[EBP+12]
  15369.         FLDD [EDI+0]        //Load real value
  15370.         MOV EDI,[EBP+8]
  15371.         MOV EAX,[EBP+16]    //Nachkommastellen  (FFFFh alle)
  15372.         MOVZXB EBX,[EBP+20] //Format value
  15373.         CALLN32 SYSTEM.!ValReal
  15374.  
  15375.         MOV AL,[EBP+20]     //Format value
  15376.         MOV EDI,[EBP+8]
  15377.         CALLN32 SYSTEM.!FormatStr
  15378.  
  15379.         POP ESI
  15380.         POP EDI
  15381.  
  15382.         LEAVE
  15383.         RETN32 12
  15384. SYSTEM.!Real2Str ENDP
  15385.  
  15386. SYSTEM.!Double2Str PROC NEAR32  //Format in [EBP+16]
  15387.         PUSH EBP
  15388.         MOV EBP,ESP
  15389.  
  15390.         PUSH EDI
  15391.         PUSH ESI
  15392.  
  15393.         MOV EDI,[EBP+12]
  15394.         FLDQ [EDI+0]        //Load double value
  15395.         MOV EDI,[EBP+8]
  15396.         MOV EAX,[EBP+16]    //Nachkommastellen (FFFFh alle)
  15397.         MOV EBX,[EBP+20]    //Format value
  15398.         CALLN32 SYSTEM.!ValReal
  15399.  
  15400.         MOV AL,[EBP+20]     //Format value
  15401.         MOV EDI,[EBP+8]
  15402.         CALLN32 SYSTEM.!FormatStr
  15403.  
  15404.         POP ESI
  15405.         POP EDI
  15406.  
  15407.         LEAVE
  15408.         RETN32 12
  15409. SYSTEM.!Double2Str ENDP
  15410.  
  15411. SYSTEM.!Extended2Str PROC NEAR32  //Format in [EBP+16]
  15412.         PUSH EBP
  15413.         MOV EBP,ESP
  15414.  
  15415.         PUSH EDI
  15416.         PUSH ESI
  15417.  
  15418.         MOV EDI,[EBP+12]
  15419.         FLDT [EDI+0]       //Load extended value
  15420.         MOV EDI,[EBP+8]
  15421.         MOV EAX,[EBP+16]   //Nachkommastellen (FFFFh alle)
  15422.         MOV EBX,[EBP+20]   //Format value
  15423.         CALLN32 SYSTEM.!ValReal
  15424.  
  15425.         MOV AL,[EBP+20]    //Format value
  15426.         MOV EDI,[EBP+8]
  15427.         CALLN32 SYSTEM.!FormatStr
  15428.  
  15429.         POP ESI
  15430.         POP EDI
  15431.  
  15432.         LEAVE
  15433.         RETN32 16
  15434. SYSTEM.!Extended2Str ENDP
  15435.  
  15436. SYSTEM.!WriteExtended PROC NEAR32   //Writes extended in ST
  15437.           PUSH EBP
  15438.           MOV EBP,ESP
  15439.           SUB ESP,260
  15440.           DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15441.           FSTPT [EBP-260]
  15442.  
  15443.           PUSHL [EBP+12]     //Format
  15444.           PUSHL [EBP+8]      //Nachkommas
  15445.           LEA EAX,[EBP-260]
  15446.           PUSH EAX
  15447.           LEA EAX,[EBP-250]
  15448.           PUSH EAX
  15449.           CALLN32 SYSTEM.!Extended2Str
  15450.  
  15451.           LEA EAX,[EBP-250]
  15452.           PUSH EAX
  15453.           PUSHL 0                //[EBP+8]  ???     //Format value
  15454.           CALLN32 SYSTEM.StrWrite
  15455.  
  15456.           LEAVE
  15457.           RETN32 8
  15458. SYSTEM.!WriteExtended ENDP
  15459.  
  15460. SYSTEM.!FPULoadLong PROC NEAR32
  15461.             PUSH EBP
  15462.             MOV EBP,ESP
  15463.             FILDD [EBP+8]
  15464.             LEAVE
  15465.             RETN32 4
  15466. SYSTEM.!FPULoadLong ENDP
  15467.  
  15468.  
  15469. SYSTEM.!Sin PROC NEAR32   //calculate SIN in ST(0)
  15470.     CALLN32 SYSTEM.!RadArc
  15471.     FSIN
  15472.     RETN32
  15473. SYSTEM.!Sin ENDP
  15474.  
  15475. SYSTEM.!Cos PROC NEAR32   //calculate COS in ST(0)
  15476.     CALLN32 SYSTEM.!RadArc
  15477.     FCOS
  15478.     RETN32
  15479. SYSTEM.!Cos ENDP
  15480.  
  15481. SYSTEM.!Tan PROC NEAR32
  15482.        PUSH EBP
  15483.        MOV EBP,ESP
  15484.        SUB ESP,12
  15485.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15486.        PUSH EAX
  15487.  
  15488.        MOVW SYSTEM.FPUResult,0
  15489.        FSTPT [EBP-10]
  15490.        FLDT [EBP-10]
  15491.        CALLN32 SYSTEM.!Sin
  15492.        FLDT [EBP-10]
  15493.        CALLN32 SYSTEM.!Cos
  15494.        FTST
  15495.        FSTSW [EBP-12]
  15496.        FWAIT
  15497.        MOV AH,[EBP-11]
  15498.        SAHF
  15499.        JNE !!!_l50
  15500.        FSTP ST(0)
  15501.        FSTP ST(0)
  15502.        FLDZ
  15503.        MOVW SYSTEM.FPUResult,2
  15504.        JMP !!!_l51
  15505. !!!_l50:
  15506.        FDIVP ST(1),ST
  15507. !!!_l51:
  15508.        POP EAX
  15509.        LEAVE
  15510.        RETN32
  15511. SYSTEM.!Tan ENDP
  15512.  
  15513. SYSTEM.!Cot PROC NEAR32
  15514.        PUSH EBP
  15515.        MOV EBP,ESP
  15516.        SUB ESP,12
  15517.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15518.        PUSH EAX
  15519.  
  15520.        MOVW SYSTEM.FPUResult,0
  15521.        FSTPT [EBP-10]
  15522.        FLDT [EBP-10]
  15523.        CALLN32 SYSTEM.!Cos
  15524.        FLDT [EBP-10]
  15525.        CALLN32 SYSTEM.!Sin
  15526.        FTST
  15527.        FSTSW [EBP-12]
  15528.        FWAIT
  15529.        MOV AH,[EBP-11]
  15530.        SAHF
  15531.        JNE !!!_l53
  15532.        FSTP ST(0)
  15533.        FSTP ST(0)
  15534.        FLDZ
  15535.        MOVW SYSTEM.FPUResult,2
  15536.        JMP !!!_l54
  15537. !!!_l53:
  15538.        FDIVP ST(1),ST
  15539. !!!_l54:
  15540.        POP EAX
  15541.        LEAVE
  15542.        RETN32
  15543. SYSTEM.!Cot ENDP
  15544.  
  15545. SYSTEM.!ArcTan PROC NEAR32
  15546.        PUSH EBP
  15547.        MOV EBP,ESP
  15548.        SUB ESP,4
  15549.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15550.        PUSH EAX
  15551.        PUSH ECX
  15552.  
  15553.        MOVW SYSTEM.FPUResult,0
  15554.        FXAM             //Type of ST(0)
  15555.        FWAIT
  15556.        FSTSW [EBP-2]
  15557.        MOV AH,[EBP-1]
  15558.        SAHF
  15559.        XCHG CX,AX
  15560.        JB !!!_l30
  15561.        JNE !!!_l31
  15562.        JMP !!!_l32
  15563. !!!_l30:
  15564.        JE !!!_l32
  15565.        JNP !!!_l32
  15566.        FSTP ST(0)
  15567.        FLDT SYSTEM.fl3
  15568.        JMP !!!_l33
  15569. !!!_l31:
  15570.        FABS
  15571.        FLD1
  15572.        FCOM ST(1)
  15573.        FWAIT
  15574.        FSTSW [EBP-2]
  15575.        MOV AH,[EBP-1]
  15576.        SAHF
  15577.        JNE !!!_l34
  15578.        FCOMPP
  15579.        FLDT SYSTEM.fl2
  15580.        JMP !!!_l33
  15581. !!!_l34:
  15582.        JNB !!!_l35
  15583.        FXCH ST(1)
  15584. !!!_l35:
  15585.        FPATAN
  15586.        JNB !!!_l33
  15587.        FLDT SYSTEM.fl3
  15588.        FSUBP ST(1),ST
  15589.        XOR CH,2
  15590. !!!_l33:
  15591.        TEST CH,2
  15592.        JE !!!_l32
  15593.        FCHS
  15594.        FWAIT
  15595. !!!_l32:
  15596.        CALLN32 SYSTEM.!NormRad
  15597.        POP ECX
  15598.        POP EAX
  15599.        LEAVE
  15600.        RETN32
  15601. SYSTEM.!ArcTan ENDP
  15602.  
  15603. SYSTEM.!Sqrt PROC NEAR32
  15604.        FSQRT
  15605.        RETN32
  15606. SYSTEM.!Sqrt ENDP
  15607.  
  15608. SYSTEM.!ln PROC NEAR32
  15609.       PUSH EBP
  15610.       MOV EBP,ESP
  15611.       SUB ESP,10
  15612.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15613.       PUSH EAX
  15614.  
  15615.       MOVW SYSTEM.FPUResult,0
  15616.       FLDLN2
  15617.       FXCH ST(1)
  15618.       FXAM
  15619.       FWAIT
  15620.       FSTSW [EBP-10]
  15621.       MOV AH,[EBP-9]
  15622.       SAHF
  15623.       JB !!!_l20
  15624.       JE !!!_l21
  15625.       TEST AH,2
  15626.       JE !!!_l22
  15627. !!!_l21:
  15628.       FSTP ST(0)
  15629.       JMP !!!_l23
  15630. !!!_l20:
  15631.       FSTP ST(0)
  15632.       JE !!!_l24
  15633.       JNP !!!_l24
  15634. !!!_l23:
  15635.       FSTP ST(0)
  15636.       FLDD SYSTEM.fl1
  15637. !!!_l24:
  15638.       FTST
  15639.       JMP !!!_l29
  15640. !!!_l22:
  15641.       FLD ST(0)
  15642.       FSTPT [EBP-10]
  15643.       CMPW [EBP-2],$3fff
  15644.       JNE !!!_l25
  15645.       CMPW [EBP-4],$8000
  15646.       JNE !!!_l25
  15647.       FLD1
  15648.       FSUBP ST(1),ST
  15649.       FYL2XP1
  15650.       JMP !!!_l29
  15651. !!!_l25:
  15652.       FYL2X
  15653. !!!_l29:
  15654.       POP EAX
  15655.       LEAVE
  15656.       RETN32
  15657. SYSTEM.!ln ENDP
  15658.  
  15659. SYSTEM.!Exp PROC NEAR32
  15660.       PUSH EBP
  15661.       MOV EBP,ESP
  15662.       SUB ESP,16
  15663.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15664.       PUSH EAX
  15665.       PUSH EBX
  15666.       PUSH ECX
  15667.  
  15668.       MOVW SYSTEM.FPUResult,0
  15669.       FLDL2E
  15670.       FXCH ST(1)
  15671.       FXAM
  15672.       FWAIT
  15673.       FSTSW [EBP-6]
  15674.       FXCH ST(1)
  15675.       MOV AH,[EBP-5]
  15676.       SAHF
  15677.       XCHG BX,AX
  15678.       JB !!!_l40
  15679.       JNE !!!_l41
  15680.       FSTP ST(0)
  15681.       FSTP ST(0)
  15682.       FLD1
  15683.       JMP !!!_l43
  15684. !!!_l40:
  15685.       FSTP ST(0)
  15686.       JE !!!_l44
  15687.       JNP !!!_l44
  15688. !!!_l48:
  15689.       FSTP ST(0)
  15690.       FLDD SYSTEM.fl4
  15691. !!!_l44:
  15692.       FTST
  15693.       JMP !!!_l43
  15694. !!!_l41:
  15695.       FMULP ST(1),ST
  15696.       FABS
  15697.       FLDD SYSTEM.fl5
  15698.       FXCH ST(1)
  15699.       FSTPT [EBP-16]
  15700.       FLDT [EBP-16]
  15701.       FCOMPP
  15702.       FWAIT
  15703.       FSTSW [EBP-6]
  15704.       FLDT [EBP-16]
  15705.       TESTB [EBP-5],$41
  15706.       JE !!!_l46
  15707.       F2XM1
  15708.       FLD1
  15709.       FADDP ST(1),ST
  15710.       FWAIT
  15711.       JMP !!!_l47
  15712. !!!_l46:
  15713.       FLD1
  15714.       FLD ST(1)
  15715.       FWAIT
  15716.       FSTCW [EBP-6]
  15717.       FSCALE
  15718.       ORB [EBP-5],$0f
  15719.       FLDCW [EBP-6]
  15720.       FWAIT
  15721.       FRNDINT
  15722.       ANDB [EBP-5],$0f3
  15723.       FLDCW [EBP-6]
  15724.       FWAIT
  15725.       FISTD [EBP-4]
  15726.       FXCH ST(1)
  15727.       FCHS
  15728.       FXCH ST(1)
  15729.       FSCALE
  15730.       FSTP ST(1)
  15731.       FSUBP ST(1),ST
  15732.       CMPW [EBP-2],0
  15733.       JG !!!_l48
  15734.       F2XM1
  15735.       FLD1
  15736.       FADDP ST(1),ST
  15737.       FWAIT
  15738.       MOV CX,[EBP-4]
  15739.       SHR CX,1
  15740.       MOV [EBP-4],CX
  15741.       JNB !!!_l49
  15742.       FLDT SYSTEM.fl6
  15743.       FMULP ST(1),ST
  15744. !!!_l49:
  15745.       FILDW [EBP-4]
  15746.       FXCH ST(1)
  15747.       FSCALE
  15748.       FSTP ST(1)
  15749. !!!_l47:
  15750.       TEST BH,2
  15751.       JE !!!_l43
  15752.       FLD1
  15753.       FDIVRP ST(1),ST
  15754. !!!_l43:
  15755.       POP ECX
  15756.       POP EBX
  15757.       POP EAX
  15758.       LEAVE
  15759.       RETN32
  15760. SYSTEM.!Exp ENDP
  15761.  
  15762. SYSTEM.!Frac PROC NEAR32
  15763.       PUSH EBP
  15764.       MOV EBP,ESP
  15765.       SUB ESP,12
  15766.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15767.       FSTPT [EBP-10]
  15768.       FLDT [EBP-10]
  15769.       FCLEX
  15770.       FLDCW SYSTEM.FPURound  //Load control word
  15771.       FWAIT
  15772.       FRNDINT
  15773.       FCLEX
  15774.       FLDCW SYSTEM.FPUControl //Load control word
  15775.       FWAIT
  15776.       FLDT [EBP-10]
  15777.       FXCH ST(1)
  15778.       FSUBP ST(1),ST
  15779.       LEAVE
  15780.       RETN32
  15781. SYSTEM.!Frac ENDP
  15782.  
  15783. SYSTEM.!Int PROC NEAR32
  15784.       FCLEX
  15785.       FLDCW SYSTEM.FPURound  //Load control word
  15786.       FWAIT
  15787.       FRNDINT
  15788.       FCLEX
  15789.       FLDCW SYSTEM.FPUControl //Load control word
  15790.       FWAIT
  15791.       RETN32
  15792. SYSTEM.!Int ENDP
  15793.  
  15794. SYSTEM.!Round PROC NEAR32
  15795.       PUSH EBP
  15796.       MOV EBP,ESP
  15797.       SUB ESP,10
  15798.       DB $89,$04,$24     //Perform stack probe MOV [ESP],EAX
  15799.  
  15800.       FSTPT [EBP-10]
  15801.       FLDT [EBP-10]
  15802.       CALLN32 SYSTEM.!Frac
  15803.       FLDT [EBP-10]
  15804.       FADDP ST(1),ST
  15805.       CALLN32 SYSTEM.!Trunc
  15806.  
  15807.       LEAVE
  15808.       RETN32
  15809. SYSTEM.!Round ENDP
  15810.  
  15811.  
  15812. SYSTEM.!Trunc PROC NEAR32
  15813.       PUSH EBP
  15814.       MOV EBP,ESP
  15815.       SUB ESP,10
  15816.       DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15817.       FCLEX
  15818.       FLDCW SYSTEM.FPURound  //Load control word
  15819.       FWAIT
  15820.       FRNDINT
  15821.       FCLEX
  15822.       FLDCW SYSTEM.FPUControl //Load control word
  15823.       FWAIT
  15824.       FISTPD [EBP-10]
  15825.       MOV EAX,[EBP-10]
  15826.       LEAVE
  15827.       RETN32
  15828. SYSTEM.!Trunc ENDP
  15829.  
  15830. SYSTEM.!Sqr PROC NEAR32
  15831.       FLD St(0)
  15832.       FMULP ST(1),ST
  15833.       RETN32
  15834. SYSTEM.!Sqr ENDP
  15835.  
  15836. SYSTEM.!ArcSin PROC NEAR32
  15837.        PUSH EBP
  15838.        MOV EBP,ESP
  15839.        SUB ESP,12
  15840.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15841.        PUSH EAX
  15842.  
  15843.        MOVW SYSTEM.FPUResult,0
  15844.        FLD St(0)
  15845.        FABS
  15846.        FLD1
  15847.        FCOMPP
  15848.        FWAIT
  15849.        FSTSW [EBP-12]
  15850.        MOV AH,[EBP-11]
  15851.        SAHF
  15852.        JB !!!_l60
  15853.        JNE !!!_l62
  15854.        //ArcSin(1.0)=w*pi/2
  15855.        FLDT SYSTEM.fl7    //1.5707...
  15856.        FMULP ST(1),ST
  15857.        JMP !!!_l61
  15858. !!!_l62:
  15859.        FLD St(0)
  15860.        FSTPT [EBP-10]
  15861.        FLD St(0)
  15862.        FMULP ST(1),ST
  15863.        FLD1
  15864.        FSUBP ST(1),ST
  15865.        FSQRT
  15866.        FLDT [EBP-10]
  15867.        FXCH ST(1)
  15868.        FDIVP ST(1),ST
  15869.        CALLN32 SYSTEM.!ArcTan
  15870.        JMP !!!_l61
  15871. !!!_l60:
  15872.        MOVW SYSTEM.FPUResult,3
  15873. !!!_l61:
  15874.        CALLN32 SYSTEM.!NormRad
  15875.        POP EAX
  15876.        LEAVE
  15877.        RETN32
  15878. SYSTEM.!ArcSin ENDP
  15879.  
  15880. SYSTEM.!ArcCos PROC NEAR32
  15881.        MOVW SYSTEM.FPUResult,0
  15882.        CALLN32 SYSTEM.!ArcSin
  15883.        FLDT SYSTEM.fl7   //PI/2
  15884.        FXCH ST(1)
  15885.        FSUBP ST(1),ST
  15886.        CALLN32 SYSTEM.!NormRad
  15887.        RETN32
  15888. SYSTEM.!ArcCos ENDP
  15889.  
  15890. SYSTEM.!ArcCot PROC NEAR32
  15891.        MOVW SYSTEM.FPUResult,0
  15892.        CALLN32 SYSTEM.!ArcTan
  15893.        FLDT SYSTEM.fl7   //PI/2
  15894.        FXCH ST(1)
  15895.        FSUBP ST(1),ST
  15896.        CALLN32 SYSTEM.!NormRad
  15897.        RETN32
  15898. SYSTEM.!ArcCot ENDP
  15899.  
  15900. SYSTEM.!Sinh PROC NEAR32
  15901.        MOVW SYSTEM.FPUResult,0
  15902.        CALLN32 SYSTEM.!Exp
  15903.        FLD St(0)
  15904.        FLD1
  15905.        FXCH ST(1)
  15906.        FDIVP ST(1),ST
  15907.        FXCH ST(1)
  15908.        FSUBP ST(1),ST
  15909.        FLDT SYSTEM.fl8
  15910.        FMULP ST(1),ST
  15911.        RETN32
  15912. SYSTEM.!Sinh ENDP
  15913.  
  15914. SYSTEM.!Cosh PROC NEAR32
  15915.        MOVW SYSTEM.FPUResult,0
  15916.        CALLN32 SYSTEM.!Exp
  15917.        FLD St(0)
  15918.        FLD1
  15919.        FXCH ST(1)
  15920.        FDIVP ST(1),ST
  15921.        FADDP ST(1),ST
  15922.        FWAIT
  15923.        FLDT SYSTEM.fl8
  15924.        FMULP ST(1),ST
  15925.        RETN32
  15926. SYSTEM.!Cosh ENDP
  15927.  
  15928. SYSTEM.!Tanh PROC NEAR32
  15929.        MOVW SYSTEM.FPUResult,0
  15930.        FLDT SYSTEM.fl9   //2.0
  15931.        FMULP ST(1),ST
  15932.        CALLN32 SYSTEM.!Exp
  15933.        FLD1
  15934.        FADDP ST(1),ST
  15935.        FWAIT
  15936.        FLDT SYSTEM.fl9   //2.0
  15937.        FXCH ST(1)
  15938.        FDIVP ST(1),ST
  15939.        FLD1
  15940.        FSUBP ST(1),ST
  15941.        RETN32
  15942. SYSTEM.!Tanh ENDP
  15943.  
  15944. SYSTEM.!Coth PROC NEAR32
  15945.        PUSH EBP
  15946.        MOV EBP,ESP
  15947.        SUB ESP,12
  15948.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15949.        PUSH EAX
  15950.  
  15951.        MOVW SYSTEM.FPUResult,0
  15952.        FLD St(0)
  15953.        FSTPT [EBP-10]
  15954.        CALLN32 SYSTEM.!Sinh
  15955.        FTST
  15956.        FWAIT
  15957.        FSTSW [EBP-12]
  15958.        MOV AH,[EBP-11]
  15959.        SAHF
  15960.        JE !!!_l70
  15961.        FLDT [EBP-10]
  15962.        CALLN32 SYSTEM.!Cosh
  15963.        FXCH ST(1)
  15964.        FDIVP ST(1),ST
  15965.        JMP !!!_l71
  15966. !!!_l70:
  15967.        MOVW SYSTEM.FPUResult,4
  15968. !!!_l71:
  15969.        POP EAX
  15970.        LEAVE
  15971.        RETN32
  15972. SYSTEM.!Coth ENDP
  15973.  
  15974. SYSTEM.!lg PROC NEAR32
  15975.        MOVW SYSTEM.FPUResult,0
  15976.        CALLN32 SYSTEM.!ln
  15977.        FLDT SYSTEM.fl10
  15978.        FDIVP ST(1),ST
  15979.        RETN32
  15980. SYSTEM.!lg ENDP
  15981.  
  15982. SYSTEM.!lb PROC NEAR32
  15983.        MOVW SYSTEM.FPUResult,0
  15984.        CALLN32 SYSTEM.!ln
  15985.        FLDT SYSTEM.fl11
  15986.        FDIVP ST(1),ST
  15987.        RETN32
  15988. SYSTEM.!lb ENDP
  15989.  
  15990. SYSTEM.!ReadReal PROC NEAR32
  15991.        PUSH EBP
  15992.        MOV EBP,ESP
  15993.        SUB ESP,262
  15994.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  15995.        LEA EAX,[EBP-260]
  15996.        PUSH EAX
  15997.        CALLN32 SYSTEM.StrRead
  15998.        LEA EAX,[EBP-260]
  15999.        PUSH EAX
  16000.        PUSHL [EBP+8]
  16001.        LEA EAX,[EBP-262]
  16002.        PUSH EAX
  16003.        CALLN32 SYSTEM.!Str2Real
  16004.        LEAVE
  16005.        RETN32 4
  16006. SYSTEM.!ReadReal ENDP
  16007.  
  16008. SYSTEM.!ReadDouble PROC NEAR32
  16009.        PUSH EBP
  16010.        MOV EBP,ESP
  16011.        SUB ESP,262
  16012.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16013.        LEA EAX,[EBP-260]
  16014.        PUSH EAX
  16015.        CALLN32 SYSTEM.StrRead
  16016.        LEA EAX,[EBP-260]
  16017.        PUSH EAX
  16018.        PUSHL [EBP+8]
  16019.        LEA EAX,[EBP-262]
  16020.        PUSH EAX
  16021.        CALLN32 SYSTEM.!Str2Double
  16022.        LEAVE
  16023.        RETN32 4
  16024. SYSTEM.!ReadDouble ENDP
  16025.  
  16026. SYSTEM.!ReadExtended PROC NEAR32
  16027.        PUSH EBP
  16028.        MOV EBP,ESP
  16029.        SUB ESP,262
  16030.        DB $89,$04,$24   //Perform stack probe MOV [ESP],EAX
  16031.        LEA EAX,[EBP-260]
  16032.        PUSH EAX
  16033.        CALLN32 SYSTEM.StrRead
  16034.        LEA EAX,[EBP-260]
  16035.        PUSH EAX
  16036.        PUSHL [EBP+8]
  16037.        LEA EAX,[EBP-262]
  16038.        PUSH EAX
  16039.        CALLN32 SYSTEM.!Str2Extended
  16040.        LEAVE
  16041.        RETN32 4
  16042. SYSTEM.!ReadExtended ENDP
  16043.  
  16044. END;
  16045.  
  16046. {**************************************************************************
  16047.  *
  16048.  * Screen IO
  16049.  *
  16050.  **************************************************************************}
  16051. //TextScreen IO support
  16052.  
  16053. TYPE ProcVar=PROCEDURE;
  16054.  
  16055. PROCEDURE TPMScreenInOutClass.Error;
  16056. BEGIN
  16057.      MessageBox(0,'Win95 GUI linker target does not support textscreen I/O'#13+
  16058.                   'Use the Unit WINCRT if you wish to use'#13
  16059.                   'textscreen I/O within GUI applications','Error',0);
  16060.      Halt(0);
  16061. END;
  16062.  
  16063. PROCEDURE TPMScreenInOutClass.WriteStr(CONST s:STRING);
  16064. BEGIN
  16065.      Error;
  16066. END;
  16067.  
  16068. PROCEDURE TPMScreenInOutClass.WriteCStr(CONST s:CSTRING);
  16069. BEGIN
  16070.      Error;
  16071. END;
  16072.  
  16073. PROCEDURE TPMScreenInOutClass.WriteLF;
  16074. BEGIN
  16075.      Error;
  16076. END;
  16077.  
  16078. PROCEDURE TPMScreenInOutClass.ReadLF(VAR s:STRING);
  16079. BEGIN
  16080.      Error;
  16081. END;
  16082.  
  16083. PROCEDURE TPMScreenInOutClass.GotoXY(x,y:BYTE);
  16084. BEGIN
  16085.      Error;
  16086. END;
  16087.  
  16088.  
  16089. PROCEDURE TScreenInOutClass.WriteStr(CONST s:STRING);
  16090. VAR
  16091.    actual:LONGWORD;
  16092.    by,by1:LONGWORD;
  16093.    Handle:LONGWORD;
  16094.    b:BYTE;
  16095.    ff:^FileRec;
  16096.    s1,s2:STRING;
  16097.    x,y:LONGINT;
  16098.    Fill:WORD;
  16099.    csbi:CONSOLE_SCREEN_BUFFER_INFO;
  16100.    coPos:COORD;
  16101.    sr:SMALL_RECT;
  16102.    ci:CHAR_INFO;
  16103. LABEL l,l1;
  16104. BEGIN
  16105.      ff:=@Output;
  16106.      Handle:=ff^.Handle;
  16107.  
  16108.      IF RedirectOut THEN goto l1;
  16109.  
  16110.      s1:=s;
  16111.      b:=Pos(#13#10,s1);
  16112.      WHILE b<>0 DO
  16113.      BEGIN
  16114.           s2:=s1;
  16115.           s1:=copy(s1,1,b-1);
  16116.           WriteStr(s1);
  16117.           s1:=#13#10;
  16118.           WriteFile(ff^.Handle,s1[1],length(s1),actual,NIL);
  16119.           GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  16120.           y:=csbi.dwCursorPosition.Y+1;
  16121.           IF y-1>Hi(WindMax) THEN
  16122.           BEGIN
  16123.               {Scroll window}
  16124.               Fill:= TextAttr;
  16125.               sr.Left:=lo(WindMin);
  16126.               sr.Right:=lo(WindMax)+1;
  16127.               sr.Top:=hi(WindMin)+1;
  16128.               sr.Bottom:=hi(WindMax);
  16129.               coPos.X:=lo(WindMin);
  16130.               coPos.Y:=hi(WindMin);
  16131.               ci.Char.AsciiChar:=#32;
  16132.               ci.Attributes:=Fill;
  16133.               ScrollConsoleScreenBuffer(ff^.Handle,sr,NIL,LONGWORD(coPos),ci);
  16134.               dec(y);
  16135.           END;
  16136.           GotoXY(1,y-Hi(WindMin));
  16137.           s1:=copy(s2,b+2,length(s2)-(b+1));
  16138.           b:=Pos(#13#10,s1);
  16139.      END;
  16140.  
  16141.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  16142.      x:=csbi.dwCursorPosition.X+1;
  16143.      IF length(s1)>(Lo(WindMax)-Lo(WindMin)-
  16144.               (x-lo(WindMin)))+1 THEN
  16145.      BEGIN
  16146.           by:=(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+2;
  16147.           by1:=length(s1)-by;
  16148. l:
  16149.           WriteFile(ff^.Handle,s1[1],by,actual,NIL);
  16150.           s1:=copy(s1,by+1,length(s1)-by);
  16151.  
  16152.           IF ((WindMin<>MaxWindMin)OR(WindMax<>MaxWindMax)) THEN WriteLF;
  16153.  
  16154.           GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  16155.           x:=csbi.dwCursorPosition.X+1;
  16156.           IF length(s1)>(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+1 THEN
  16157.           BEGIN
  16158.                by:=(Lo(WindMax)-Lo(WindMin)-(x-lo(WindMin)))+2;
  16159.                by1:=length(s1)-by;
  16160.                goto l;
  16161.           END;
  16162.  
  16163.           WriteFile(ff^.Handle,s1[1],by1,actual,NIL);
  16164.  
  16165.           exit;
  16166.      END;
  16167. l1:
  16168.      WriteFile(ff^.Handle,s1[1],length(s1),actual,NIL);
  16169. END;
  16170.  
  16171. PROCEDURE TScreenInOutClass.WriteCStr(CONST s:CSTRING);
  16172. VAR
  16173.    c:STRING;
  16174.    b:LONGWORD;
  16175.    pc:^CSTRING;
  16176. LABEL l;
  16177. BEGIN
  16178.      pc:=@s;
  16179. l:
  16180.      b:=Length(pc^);
  16181.      IF b<255 THEN
  16182.      BEGIN
  16183.           c:=pc^;
  16184.           WriteStr(c);
  16185.      END
  16186.      ELSE
  16187.      BEGIN
  16188.           move(pc^,c[1],255);
  16189.           c[0]:=#255;
  16190.           inc(pc,255);
  16191.           WriteStr(c);
  16192.           goto l;
  16193.      END;
  16194. END;
  16195.  
  16196.  
  16197. PROCEDURE TScreenInOutClass.WriteLF;
  16198. VAR y:BYTE;
  16199.     Fill:WORD;
  16200.     coPos:COORD;
  16201.     csbi:CONSOLE_SCREEN_BUFFER_INFO;
  16202.     ff:^FileRec;
  16203.     Actual:LONGWORD;
  16204.     sr:SMALL_RECT;
  16205.     ci:CHAR_INFO;
  16206.     s:STRING;
  16207. BEGIN
  16208.      s:=#13#10;
  16209.      ff:=@Output;
  16210.      WriteFile(ff^.Handle,s[1],length(s),actual,NIL);
  16211.  
  16212.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  16213.      y:=csbi.dwCursorPosition.Y+1;
  16214.      IF y-1>Hi(WindMax) THEN
  16215.      BEGIN
  16216.           {Scroll window}
  16217.           Fill:= TextAttr;
  16218.           {Scroll window}
  16219.           sr.Left:=lo(WindMin);
  16220.           sr.Right:=lo(WindMax);
  16221.           sr.Top:=hi(WindMin)+1;
  16222.           sr.Bottom:=hi(WindMax);
  16223.           coPos.X:=lo(WindMin);
  16224.           coPos.Y:=hi(WindMin);
  16225.           ci.Char.AsciiChar:=#32;
  16226.           ci.Attributes:=Fill;
  16227.           ScrollConsoleScreenBuffer(ff^.Handle,sr,NIL,LONGWORD(coPos),ci);
  16228.           dec(y);
  16229.      END;
  16230.      GOTOXY(1,y-Hi(WindMin));
  16231. END;
  16232.  
  16233. PROCEDURE TScreenInOutClass.ReadLF(VAR s:STRING);
  16234. VAR ff:^FileRec;
  16235.     Actual:LONGWORD;
  16236. BEGIN
  16237.      ff:=@Input;
  16238.      ReadFile(ff^.Handle,s[1],255,Actual,NIL);
  16239.      s[0]:=chr(Actual);
  16240.      IF s[length(s)]=#10 THEN dec(s[0]);
  16241.      IF s[length(s)]=#13 THEN dec(s[0]);
  16242. END;
  16243.  
  16244. PROCEDURE TScreenInOutClass.GotoXY(x,y:BYTE);
  16245. VAR coPos:COORD;
  16246.     ff:^FileRec;
  16247. BEGIN
  16248.      X:=X-1+Lo(WindMin);
  16249.      Y:=Y-1+Hi(WindMin);
  16250.      IF (X<=Lo(WindMax))and(Y<=Hi(WindMax)) THEN
  16251.      BEGIN
  16252.           ff:=@Output;
  16253.           coPos.X:=X;
  16254.           coPos.Y:=Y;
  16255.           SetConsoleCursorPosition(ff^.Handle,LONGWORD(coPos));
  16256.      END;
  16257. END;
  16258.  
  16259.  
  16260. PROCEDURE StrWrite(CONST s:STRING;format:LONGWORD);
  16261. VAR ss:STRING;
  16262.     p:^STRING;
  16263. BEGIN
  16264.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  16265.      IF format>length(s) THEN
  16266.      BEGIN
  16267.           format:=format-length(s);
  16268.           ss[0]:=chr(format+length(s));
  16269.           fillchar(ss[1],format,32);
  16270.           p:=@s;
  16271.           move(p^[1],ss[format+1],length(s));
  16272.           ScreenInOut.WriteStr(ss);
  16273.      END
  16274.      ELSE ScreenInOut.WriteStr(s);
  16275. END;
  16276.  
  16277. PROCEDURE CStrWrite(CONST s:CSTRING;format:LONGWORD);
  16278. VAR ss:CSTRING;
  16279.     p:^CSTRING;
  16280.     l:LONGWORD;
  16281. BEGIN
  16282.      l:=length(s);
  16283.      IF ((format>l)AND(l+format<255)) THEN
  16284.      BEGIN
  16285.           format:=format-l;
  16286.           fillchar(ss[0],format,32);
  16287.           p:=@s;
  16288.           move(p^[0],ss[format],l+1);
  16289.           ScreenInOut.WriteCStr(ss);
  16290.      END
  16291.      ELSE ScreenInOut.WriteCStr(s);
  16292. END;
  16293.  
  16294. PROCEDURE WriteLine;
  16295. BEGIN
  16296.      ScreenInOut.WriteLF;
  16297. END;
  16298.  
  16299. PROCEDURE ReadLine;
  16300. VAR
  16301.    s:STRING;
  16302. BEGIN
  16303.      ScreenInOut.ReadLF(s);
  16304. END;
  16305.  
  16306. PROCEDURE StrRead(VAR s:STRING);
  16307. BEGIN
  16308.      ScreenInOut.ReadLF(s);
  16309. END;
  16310.  
  16311. CONST
  16312.      Typ_String   = 1;
  16313.      Typ_Char     = 2;
  16314.      Typ_Number   = 3;
  16315.  
  16316. PROCEDURE GetNextStr(VAR s,Ziel:STRING;Typ:LONGWORD);
  16317. VAR t:BYTE;
  16318. LABEL l;
  16319. BEGIN
  16320.      IF s='' THEN
  16321.      BEGIN
  16322.           StrRead(s);
  16323.           s:=s+#13#10;
  16324.      END;
  16325.  
  16326.      Ziel:='';
  16327.      CASE Typ OF
  16328.         Typ_String:
  16329.         BEGIN
  16330.              {copy whole}
  16331.              IF s=#13#10 THEN Ziel:=''
  16332.              ELSE
  16333.              BEGIN
  16334.                   Ziel:=Copy(s,1,length(s)-2);
  16335.                   s:=#13#10;
  16336.              END;
  16337.         END;
  16338.         Typ_Char:
  16339.         BEGIN
  16340.              Ziel:=s[1];
  16341.              Delete(s,1,1);
  16342.         END;
  16343.         Typ_Number:
  16344.         BEGIN
  16345. l:
  16346.              IF length(s)<3 THEN  {am Zeilenende ??}
  16347.              BEGIN
  16348.                   StrRead(s);
  16349.                   s:=s+#13#10;
  16350.              END;
  16351.  
  16352.              {Skip spaces}
  16353.              IF s[1]=#32 THEN
  16354.              BEGIN
  16355.                   Delete(s,1,1);
  16356.                   goto l;
  16357.              END;
  16358.  
  16359.              FOR t:=1 TO length(s) DO
  16360.              BEGIN
  16361.                  CASE s[t] OF
  16362.                     #9,#13,#10,#32:  {Trennzeichen}
  16363.                     BEGIN
  16364.                          Ziel:=Copy(s,1,t-1);
  16365.                          Delete(s,1,t-1); {Trenner nicht mit löschen}
  16366.                          exit;
  16367.                     END;
  16368.                  END; {case}
  16369.              END;
  16370.         END;
  16371.      END; {case}
  16372. END;
  16373.  
  16374. //************************************************************************
  16375. //
  16376. // File IO
  16377. //
  16378. //
  16379. //************************************************************************
  16380.  
  16381.  
  16382. VAR
  16383.    FileBufSize:LONGWORD;  {Standard file buffer size (32768 bytes}
  16384.  
  16385. PROCEDURE Assign(VAR f:FILE;CONST s:String);
  16386. VAR ff:^FileRec;
  16387. BEGIN
  16388.      ff:=@f;
  16389.      fillchar(f,sizeof(f),0);
  16390.      ff^.Name:=s;                  {Assign name to file variable}
  16391.      ff^.Flags:=$6666;             {File successfully assigned}
  16392.      ff^.Handle:=$ffffffff;        {No valid handle}
  16393.      ff^.MaxCacheMem:=FileBufSize; {Initial bufsize}
  16394.      ff^.Buffer:=NIL;
  16395.      IF ff^.MaxCacheMem<16 THEN ff^.MaxCacheMem:=16;
  16396.      IOResult:=0;                  {Clear IOResult variable}
  16397. END;
  16398.  
  16399. PROCEDURE InvalidFileNameError(Adr:LONGINT);
  16400. VAR
  16401.    e:EInvalidFileName;
  16402. BEGIN
  16403.      e.Create('Invalid file name (EInvalidFileName)');
  16404.      e.CameFromRTL:=TRUE;
  16405.      e.RTLExcptAddr:=POINTER(Adr);
  16406.      e.ErrorCode:=206; {filename exceeds range}
  16407.      RAISE e;
  16408. END;
  16409.  
  16410. PROCEDURE InOutError(Code,Adr:LONGWORD);
  16411. VAR
  16412.    e:EInOutError;
  16413. BEGIN
  16414.      e.Create('Input/Output error (EInOutError)');
  16415.      e.ErrorCode:=code;
  16416.      e.CameFromRTL:=TRUE;
  16417.      e.RTLExcptAddr:=POINTER(Adr);
  16418.      RAISE e;
  16419. END;
  16420.  
  16421. CONST
  16422.      {Modes for FileBlockIO}
  16423.      ReadMode        = 1;
  16424.      WriteMode       = 2;
  16425.  
  16426. PROCEDURE FileBlockIO(VAR f:FILE;BlockNr:LONGWORD;Mode:LONGWORD;
  16427.                       VAR result:LONGWORD);
  16428. VAR
  16429.    l:LONGWORD;
  16430.    po:LONGWORD;
  16431.    temp:LONGWORD;
  16432.    ff:^FileRec;
  16433. BEGIN
  16434.      ff:=@f;
  16435.      IOResult:=0;
  16436.      IF ff^.changed THEN
  16437.      BEGIN
  16438.           ff^.changed:=FALSE;
  16439.           FileBlockIO(f,ff^.block,WriteMode,Temp);
  16440.           IF IOResult<>0 THEN exit;
  16441.      END;
  16442.  
  16443.      IF blocknr=ff^.LBlock THEN l:=ff^.LOffset
  16444.      ELSE l:=ff^.MaxCacheMem;
  16445.      po:=ff^.MaxCacheMem*blocknr;
  16446.      Temp:=SetFilePointer(ff^.Handle,po,NIL,0);  //Seek from file begin
  16447.      IF Temp=$ffffffff THEN
  16448.      BEGIN
  16449.           IoResult:=GetLastError;
  16450.           exit;
  16451.      END;
  16452.  
  16453.      IF l>0 THEN
  16454.      BEGIN
  16455.           CASE Mode OF
  16456.               WriteMode:
  16457.               BEGIN
  16458.                    IF not WriteFile(ff^.Handle,ff^.Buffer^,l,result,NIL) THEN
  16459.                    BEGIN
  16460.                        IOResult:=GetLastError;
  16461.                    END;
  16462.               END;
  16463.               ReadMode:
  16464.               BEGIN
  16465.                    IF not ReadFile(ff^.Handle,ff^.Buffer^,l,result,NIL) THEN
  16466.                    BEGIN
  16467.                         IOResult:=GetLastError;
  16468.                    END;
  16469.               END;
  16470.           END; {case}
  16471.      END;
  16472. END;
  16473.  
  16474. FUNCTION FileFileSize(VAR f:FILE):LONGWORD;
  16475. VAR
  16476.    ff:^FileRec;
  16477.    Temp,Temp1,Temp2:LONGWORD;
  16478. BEGIN
  16479.      ff:=@f;
  16480.  
  16481.      IOResult:=0;
  16482.      Temp:=SetFilePointer(ff^.Handle,0,NIL,1); //get current pos
  16483.      IF Temp=$ffffffff THEN
  16484.      BEGIN
  16485.           IOResult:=GetLastError;
  16486.           exit;
  16487.      END;
  16488.  
  16489.      Temp1:=SetFilePointer(ff^.Handle,0,NIL,2); //get length
  16490.      IF Temp1=$ffffffff THEN
  16491.      BEGIN
  16492.           IOResult:=GetLastError;
  16493.           exit;
  16494.      END;
  16495.  
  16496.      Temp2:=SetFilePointer(ff^.Handle,Temp2,NIL,0);  //restore position
  16497.      IF Temp2=$ffffffff THEN
  16498.      BEGIN
  16499.           IOResult:=GetLastError;
  16500.           exit;
  16501.      END;
  16502.  
  16503.      FileFileSize:=Temp1;
  16504. END;
  16505.  
  16506. FUNCTION FileFilePos(VAR f:FILE):LONGWORD;
  16507. VAR
  16508.    ff:^FileRec;
  16509.    Temp:LONGWORD;
  16510. BEGIN
  16511.      ff:=@f;
  16512.  
  16513.      IOResult:=0;
  16514.      Temp:=SetFilePointer(ff^.Handle,0,NIL,1);
  16515.      IF Temp=$ffffffff THEN
  16516.      BEGIN
  16517.           IOResult:=GetLastError;
  16518.           exit;
  16519.      END;
  16520.  
  16521.      FileFilePos:=Temp;
  16522. END;
  16523.  
  16524.  
  16525. VAR OpenedFiles:ARRAY[1..51] OF LONGWORD; {Handles for opened files}
  16526.     OpenedFilesCount:BYTE;
  16527.  
  16528. PROCEDURE Rewrite(VAR f:FILE;recsize:LONGWORD);
  16529. VAR
  16530.    action:LONGWORD;
  16531.    ff:^FileRec;
  16532.    c:CSTRING;
  16533.    e:EFileNotFound;
  16534.    Size,Temp:LONGWORD;
  16535.    SaveIOError:BOOLEAN;
  16536.    Adr:LONGINT;
  16537. BEGIN
  16538.      ASM
  16539.         MOV EAX,[EBP+4]
  16540.         SUB EAX,5
  16541.         MOV $Adr,EAX
  16542.      END;
  16543.      IOResult:=0;
  16544.      ff:=@f;
  16545.      ff^.RecSize:=recsize;
  16546.  
  16547.      IF ff^.flags<>$6666 THEN
  16548.      BEGIN
  16549.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16550.           ELSE
  16551.           BEGIN
  16552.                IOResult:=206;
  16553.                exit;
  16554.           END;
  16555.      END;
  16556.  
  16557.      IF ff^.Handle<>$ffffffff THEN
  16558.      BEGIN
  16559.          {Close file first}
  16560.          SaveIoError:=RaiseIOError;
  16561.          RaiseIOError:=FALSE;
  16562.          Close(f);
  16563.          RaiseIoError:=SaveIoError;
  16564.          (*IOResult:=85; {File already assigned}
  16565.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  16566.          ELSE exit;*)
  16567.      END;
  16568.  
  16569.      ff^.Buffer:=NIL;
  16570.      c:=ff^.Name;
  16571.      {for rewrite no extended attributes can be determined - use reset !}
  16572.      ff^.Handle:=CreateFile(c,FileMode AND not 3,FileMode AND 3,NIL,2,$00000080,0);
  16573.      IF ff^.Handle=-1 THEN
  16574.      BEGIN
  16575.           IOResult:=GetLastError;
  16576.           ff^.Handle:=$ffffffff;
  16577.           IF RaiseIOError THEN
  16578.           BEGIN
  16579.                e.Create('File not found (EFileNotFound)');
  16580.                e.ErrorCode:=IoResult;
  16581.                e.CameFromRTL:=TRUE;
  16582.                e.RTLExcptAddr:=POINTER(Adr);
  16583.                RAISE e;
  16584.           END
  16585.           ELSE exit;
  16586.      END;
  16587.  
  16588.      ff^.Mode:=FileMode;
  16589.      ff^.Reserved1:=0;
  16590.  
  16591.      {Set the buffer values}
  16592.  
  16593.      size:=FileFileSize(f);
  16594.      IF IOResult<>0 THEN
  16595.      BEGIN
  16596.           ff^.Handle:=$ffffffff;
  16597.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16598.           ELSE exit;
  16599.      END;
  16600.  
  16601.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  16602.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  16603.  
  16604.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  16605.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  16606.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  16607.      FileBlockIO(f,0,readmode,Temp);
  16608.      IF IOResult<>0 THEN
  16609.      BEGIN
  16610.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16611.           ELSE exit;
  16612.      END;
  16613.      ff^.Block:=0;
  16614.      ff^.Offset:=0;
  16615. END;
  16616.  
  16617. PROCEDURE Reset(VAR f:FILE;recsize:LONGWORD);
  16618. VAR
  16619.    action:LONGWORD;
  16620.    ff:^FileRec;
  16621.    c:CSTRING;
  16622.  
  16623.    p:POINTER;
  16624.    e:EFileNotFound;
  16625.    size,Temp:LONGWORD;
  16626.    SaveIoError:BOOLEAN;
  16627.    Adr:LONGINT;
  16628. LABEL l;
  16629. BEGIN
  16630.      ASM
  16631.         MOV EAX,[EBP+4]
  16632.         SUB EAX,5
  16633.         MOV $Adr,EAX
  16634.      END;
  16635.      IOResult:=0;
  16636.      ff:=@f;
  16637.      ff^.RecSize:=recsize;
  16638.      IF ff^.flags<>$6666 THEN
  16639.      BEGIN
  16640.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16641.           ELSE
  16642.           BEGIN
  16643.                IOResult:=206;
  16644.                exit;
  16645.           END;
  16646.      END;
  16647.  
  16648.      IF ff^.Handle<>$ffffffff THEN
  16649.      BEGIN
  16650.          {Close file first}
  16651.          SaveIoError:=RaiseIOError;
  16652.          RaiseIOError:=FALSE;
  16653.          Close(f);
  16654.          RaiseIoError:=SaveIoError;
  16655.          (*IOResult:=85; {File already assigned}
  16656.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  16657.          ELSE exit;*)
  16658.      END;
  16659.  
  16660.      ff^.Buffer:=NIL;
  16661.      c:=ff^.Name;
  16662.  
  16663.      {open and read extended attributes}
  16664.      ff^.Handle:=CreateFile(c,FileMode AND not 3,FileMode AND 3,NIL,3,$00000080,0);
  16665.      IF ff^.Handle=-1 THEN
  16666.      BEGIN
  16667.           IOResult:=GetLastError;
  16668.           ff^.Handle:=$ffffffff;
  16669.           IF RaiseIOError THEN
  16670.           BEGIN
  16671.                e.Create('File not found (EFileNotFound)');
  16672.                e.CameFromRTL:=TRUE;
  16673.                e.RTLExcptAddr:=POINTER(Adr);
  16674.                e.ErrorCode:=IoResult;
  16675.                RAISE e;
  16676.           END
  16677.           ELSE exit;
  16678.      END;
  16679.  
  16680.      ff^.EAS:=NIL;
  16681.      ff^.Mode:=FileMode;
  16682.      ff^.Reserved1:=0;
  16683.  
  16684.      {Set the buffer values}
  16685.  
  16686.      size:=FileFileSize(f);
  16687.      IF IOResult<>0 THEN
  16688.      BEGIN
  16689.           ff^.Handle:=$ffffffff;
  16690.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16691.           ELSE exit;
  16692.      END;
  16693.  
  16694.      IF OpenedFilesCount<50 THEN inc(OpenedFilesCount);
  16695.      OpenedFiles[OpenedFilesCount]:=ff^.Handle;
  16696.  
  16697.      getmem(ff^.Buffer,ff^.MaxCacheMem);
  16698.      ff^.LBlock:=size DIV ff^.MaxCacheMem;
  16699.      ff^.LOffset:=size MOD ff^.MaxCacheMem;
  16700.      FileBlockIO(f,0,readmode,Temp);
  16701.      IF IOResult<>0 THEN
  16702.      BEGIN
  16703.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16704.           ELSE exit;
  16705.      END;
  16706.      ff^.Block:=0;
  16707.      ff^.Offset:=0;
  16708. END;
  16709.  
  16710. PROCEDURE Close(VAR f:FILE);
  16711. VAR
  16712.    ff:^FileRec;
  16713.    Temp:LONGWORD;
  16714.    t:BYTE;
  16715.    Adr:LONGINT;
  16716. LABEL l;
  16717. BEGIN
  16718.      ASM
  16719.         MOV EAX,[EBP+4]
  16720.         SUB EAX,5
  16721.         MOV $Adr,EAX
  16722.      END;
  16723.      ff:=@f;
  16724.      IF ff^.flags<>$6666 THEN
  16725.      BEGIN
  16726.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16727.           ELSE
  16728.           BEGIN
  16729.                IOResult:=206;
  16730.                exit;
  16731.           END;
  16732.      END;
  16733.  
  16734.      IF ff^.Handle=$ffffffff THEN
  16735.      BEGIN
  16736.           IOResult:=6; {Invalid handle}
  16737.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16738.           ELSE exit;
  16739.      END;
  16740.  
  16741.      IF ff^.Buffer=NIL THEN
  16742.      BEGIN
  16743.           IF not CloseHandle(ff^.Handle) THEN
  16744.           BEGIN
  16745.               IOResult:=GetLastError;
  16746.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  16747.               ELSE exit;
  16748.           END;
  16749.           ff^.Mode:=0;            {closed}
  16750.           ff^.Flags:=$6666;       {File successfully assigned}
  16751.           ff^.Handle:=$ffffffff;  {No valid handle}
  16752.           exit;
  16753.      END;
  16754.  
  16755.      IOResult:=0;
  16756.      {Write buffer to file}
  16757.      IF ff^.changed THEN
  16758.      BEGIN
  16759.           ff^.changed:=FALSE;
  16760.           FileBlockIO(F,ff^.block,WriteMode,Temp);
  16761.           IF IOResult<>0 THEN
  16762.           BEGIN
  16763.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  16764.               ELSE exit;
  16765.           END;
  16766.      END;
  16767.  
  16768.      FOR t:=1 TO OpenedFilesCount DO
  16769.      BEGIN
  16770.           IF OpenedFiles[t]=ff^.Handle THEN
  16771.           BEGIN
  16772.                move(OpenedFiles[t+1],OpenedFiles[t],(50-t)*4);
  16773.                dec(OpenedFilesCount);
  16774.                goto l;
  16775.           END;
  16776.      END;
  16777. l:
  16778.      IF not CloseHandle(ff^.Handle) THEN
  16779.      BEGIN
  16780.           IOResult:=GetLastError;
  16781.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16782.           ELSE exit;
  16783.      END;
  16784.  
  16785.      ff^.Mode:=0;            {closed}
  16786.      ff^.Flags:=$6666;       {File successfully assigned}
  16787.      ff^.Handle:=$ffffffff;  {No valid handle}
  16788.  
  16789.      {free file buffers}
  16790.      IF ff^.Buffer<>NIL THEN FreeMem(ff^.Buffer,ff^.MaxCacheMem);
  16791.      ff^.Buffer:=NIL;
  16792. END;
  16793.  
  16794. PROCEDURE CloseAllOpenedFiles;
  16795. VAR t:BYTE;
  16796. BEGIN
  16797.      FOR t:=1 TO OpenedFilesCount DO CloseHandle(OpenedFiles[t]);
  16798.      OpenedFilesCount:=0;
  16799. END;
  16800.  
  16801. PROCEDURE Seek(VAR f:FILE;n:LONGINT);
  16802. VAR
  16803.    ff:^FileRec;
  16804.    result:LONGWORD;
  16805.    pBlock:LONGWORD;
  16806.    POffset:LONGWORD;
  16807.    Temp:LONGWORD;
  16808.    Adr:LONGINT;
  16809. BEGIN
  16810.      ASM
  16811.         MOV EAX,[EBP+4]
  16812.         SUB EAX,5
  16813.         MOV $Adr,EAX
  16814.      END;
  16815.      ff:=@f;
  16816.      IF ff^.flags<>$6666 THEN
  16817.      BEGIN
  16818.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16819.           ELSE
  16820.           BEGIN
  16821.                IOResult:=206;
  16822.                exit;
  16823.           END;
  16824.      END;
  16825.  
  16826.      IF ff^.Handle=$ffffffff THEN
  16827.      BEGIN
  16828.           IOResult:=6; {Invalid handle}
  16829.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16830.           ELSE exit;
  16831.      END;
  16832.  
  16833.      n:=n*ff^.RecSize;
  16834.  
  16835.      CASE SeekMode OF
  16836.         Seek_Current:inc(n,FilePos(f)*ff^.RecSize);   //Seek_Current
  16837.         Seek_End:inc(n,FileSize(f)*ff^.RecSize);      //Seek_End
  16838.      END;
  16839.  
  16840.      IOResult:=0;
  16841.      pblock:=n DIV ff^.maxcachemem;
  16842.      poffset:=n MOD ff^.maxcachemem;
  16843.      IF n>ff^.loffset+ff^.maxcachemem*ff^.lblock THEN
  16844.      BEGIN
  16845.           IF ff^.Mode AND (fmOutput OR fmInOut)<>0 THEN
  16846.           BEGIN
  16847.                ff^.loffset:=poffset;
  16848.                ff^.lblock:=pblock;
  16849.           END
  16850.           ELSE
  16851.           BEGIN
  16852.                IOResult:=38;  {Illegal pos}
  16853.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  16854.                ELSE exit;
  16855.           END;
  16856.      END;
  16857.      IF pblock<>ff^.block THEN
  16858.      BEGIN
  16859.           FileBlockIO(f,pblock,ReadMode,Temp);
  16860.           IF IOResult<>0 THEN
  16861.           BEGIN
  16862.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  16863.               ELSE exit;
  16864.           END;
  16865.      END;
  16866.      ff^.offset:=poffset;
  16867.      ff^.block:=pblock;
  16868. END;
  16869.  
  16870. FUNCTION FilePos(var f:file):LongWord;
  16871. VAR
  16872.    ff:^FileRec;
  16873.    result:LONGWORD;
  16874.    Adr:LONGINT;
  16875. BEGIN
  16876.      ASM
  16877.         MOV EAX,[EBP+4]
  16878.         SUB EAX,5
  16879.         MOV $Adr,EAX
  16880.      END;
  16881.      ff:=@f;
  16882.      IF ff^.flags<>$6666 THEN
  16883.      BEGIN
  16884.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16885.           ELSE
  16886.           BEGIN
  16887.                IOResult:=206;
  16888.                exit;
  16889.           END;
  16890.      END;
  16891.  
  16892.      IF ff^.Handle=$ffffffff THEN
  16893.      BEGIN
  16894.           IOResult:=6; {Invalid handle}
  16895.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16896.           ELSE exit;
  16897.      END;
  16898.  
  16899.      IOResult:=0;
  16900.      result:=ff^.block*ff^.maxcachemem+ff^.offset;
  16901.      FilePos:=result DIV ff^.RecSize;
  16902. END;
  16903.  
  16904. FUNCTION Eof(var f:file):Boolean;
  16905. VAR
  16906.    old,size:LONGWORD;
  16907.    ff:^FIleRec;
  16908.    Adr:LONGINT;
  16909.    SaveIO:BOOLEAN;
  16910. BEGIN
  16911.      ASM
  16912.         MOV EAX,[EBP+4]
  16913.         SUB EAX,5
  16914.         MOV $Adr,EAX
  16915.      END;
  16916.      ff:=@f;
  16917.      IF ff^.flags<>$6666 THEN
  16918.      BEGIN
  16919.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16920.           ELSE
  16921.           BEGIN
  16922.                IOResult:=206;
  16923.                exit;
  16924.           END;
  16925.      END;
  16926.  
  16927.      IF ff^.Handle=$ffffffff THEN
  16928.      BEGIN
  16929.           IOResult:=6; {Invalid handle}
  16930.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  16931.           ELSE exit;
  16932.      END;
  16933.  
  16934.      IF ff^.Reserved1 AND 1=1 THEN
  16935.      BEGIN
  16936.           eof:=TRUE;
  16937.           exit;
  16938.      END;
  16939.  
  16940.      IF ff^.Buffer=NIL THEN
  16941.      BEGIN
  16942.           IOResult:=0;
  16943.           SaveIO:=RaiseIOError;
  16944.           RaiseIOError:=FALSE;
  16945.           size:=FileFileSize(f);
  16946.           RaiseIOError:=SaveIO;
  16947.           IF IOResult<>0 THEN
  16948.           BEGIN
  16949.                IF ((f=Input)OR(f=Output)) THEN
  16950.                BEGIN
  16951.                     Eof:=FALSE;
  16952.                     exit;
  16953.                END
  16954.                ELSE
  16955.                BEGIN
  16956.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  16957.                     ELSE exit;
  16958.                END;
  16959.           END
  16960.           ELSE
  16961.           BEGIN
  16962.                Eof:=Size=FileFilePos(f);
  16963.                IF IOResult<>0 THEN
  16964.                BEGIN
  16965.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  16966.                     ELSE exit;
  16967.                END;
  16968.           END;
  16969.           exit;
  16970.      END;
  16971.  
  16972.      IOResult:=0;
  16973.      Eof:=(ff^.offset=ff^.loffset)AND(ff^.block=ff^.lblock);
  16974. END;
  16975.  
  16976. FUNCTION Eoln(VAR F:Text):Boolean;
  16977. VAR
  16978.     Adr:LONGINT;
  16979.     fi:^FileRec;
  16980.     Offset:LONGINT;
  16981.     Value:BYTE;
  16982.     SaveIoError:BOOLEAN;
  16983.     Res:LONGWORD;
  16984.     t:BYTE;
  16985.     s:STRING;
  16986. BEGIN
  16987.      ASM
  16988.         MOV EAX,[EBP+4]
  16989.         SUB EAX,5
  16990.         MOV $Adr,EAX
  16991.      END;
  16992.  
  16993.      fi:=@f;
  16994.  
  16995.      IF fi^.flags<>$6666 THEN
  16996.      BEGIN
  16997.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  16998.           ELSE
  16999.           BEGIN
  17000.                IOResult:=206;
  17001.                exit;
  17002.           END;
  17003.      END;
  17004.  
  17005.      IF fi^.Handle=$ffffffff THEN
  17006.      BEGIN
  17007.          IOResult:=6; {Invalid handle}
  17008.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  17009.          ELSE exit;
  17010.      END;
  17011.  
  17012.      IF eof(f) THEN
  17013.      BEGIN
  17014.           result:=TRUE;
  17015.           exit;
  17016.      END;
  17017.  
  17018.      Offset:=fi^.Offset;
  17019.  
  17020.      IF fi^.Buffer=NIL THEN
  17021.      BEGIN
  17022.           IF lo(fi^.BufferBytes)=1 THEN
  17023.           BEGIN
  17024.                Value:=Hi(fi^.BufferBytes);
  17025.           END
  17026.           ELSE
  17027.           BEGIN
  17028.                SaveIOError:=RaiseIOError;
  17029.                RaiseIOError:=FALSE;
  17030.                BlockRead(f,Value,1,Res);
  17031.                Seek(f,FilePos(f)-1);
  17032.                RaiseIOError:=SaveIOError;
  17033.                IF Res=0 THEN Value:=26; {EOF}
  17034.           END;
  17035.      END
  17036.      ELSE value:=fi^.Buffer^[Offset];
  17037.  
  17038.      IF value IN [13,10,26] THEN result:=TRUE
  17039.      ELSE result:=FALSE;
  17040. END;
  17041.  
  17042.  
  17043. FUNCTION FileSize(var f:file):LongWord;
  17044. VAR
  17045.    old,old1,result:LONGWORD;
  17046.    ff:^FileRec;
  17047.    Adr:LONGINT;
  17048. BEGIN
  17049.      ASM
  17050.         MOV EAX,[EBP+4]
  17051.         SUB EAX,5
  17052.         MOV $Adr,EAX
  17053.      END;
  17054.      ff:=@f;
  17055.      IF ff^.flags<>$6666 THEN
  17056.      BEGIN
  17057.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17058.           ELSE
  17059.           BEGIN
  17060.                IOResult:=206;
  17061.                exit;
  17062.           END;
  17063.      END;
  17064.  
  17065.      IF ff^.Handle=$ffffffff THEN
  17066.      BEGIN
  17067.           IOResult:=6; {Invalid handle}
  17068.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17069.           ELSE exit;
  17070.      END;
  17071.  
  17072.      IOResult:=0;
  17073.      result:=ff^.lblock*ff^.maxcachemem+ff^.loffset;
  17074.      FileSize:=result DIV ff^.RecSize;
  17075. END;
  17076.  
  17077. PROCEDURE Truncate(VAR f:FILE);
  17078. VAR
  17079.    l:LONGWORD;
  17080.    ff:^FileRec;
  17081.    Adr:LONGINT;
  17082. BEGIN
  17083.      ASM
  17084.         MOV EAX,[EBP+4]
  17085.         SUB EAX,5
  17086.         MOV $Adr,EAX
  17087.      END;
  17088.      ff:=@f;
  17089.      IF ff^.flags<>$6666 THEN
  17090.      BEGIN
  17091.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17092.           ELSE
  17093.           BEGIN
  17094.                IOResult:=206;
  17095.                exit;
  17096.           END;
  17097.      END;
  17098.      IF not SetEndOfFile(ff^.Handle) THEN
  17099.      BEGIN
  17100.           IOResult:=GetLastError;
  17101.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17102.           ELSE exit;
  17103.      END;
  17104.      ff^.lOffset:=ff^.Offset;
  17105.      ff^.lBlock:=ff^.Block;
  17106. END;
  17107.  
  17108. PROCEDURE Append(VAR f:Text);
  17109. VAR
  17110.    l:LONGWORD;
  17111.    saveseek:LONGWORD;
  17112.    Adr:LONGINT;
  17113. BEGIN
  17114.      ASM
  17115.         MOV EAX,[EBP+4]
  17116.         SUB EAX,5
  17117.         MOV $Adr,EAX
  17118.      END;
  17119.      Reset(f,1);
  17120.      IF IOResult<>0 THEN
  17121.      BEGIN
  17122.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17123.           ELSE exit;
  17124.      END;
  17125.  
  17126.      l:=Filesize(f);
  17127.      IF ioresult=0 THEN
  17128.      BEGIN
  17129.           SaveSeek:=seekmode;
  17130.           seekmode:=0; {from file begin}
  17131.           Seek(f,l);
  17132.           seekmode:=saveseek;
  17133.      END
  17134.      ELSE
  17135.      BEGIN
  17136.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17137.           ELSE exit;
  17138.      END;
  17139. END;
  17140.  
  17141.  
  17142. PROCEDURE ChDir(CONST path:STRING);
  17143. VAR c:CSTRING;
  17144.     Adr:LONGINT;
  17145. BEGIN
  17146.      ASM
  17147.         MOV EAX,[EBP+4]
  17148.         SUB EAX,5
  17149.         MOV $Adr,EAX
  17150.      END;
  17151.      c:=path;
  17152.      IF not SetCurrentDirectory(c) THEN
  17153.      BEGIN
  17154.           IoResult:=GetLastError;
  17155.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17156.           ELSE exit;
  17157.      END;
  17158. END;
  17159.  
  17160. PROCEDURE GetDir(drive:byte;VAR path:STRING);
  17161. VAR
  17162.    c:CSTRING;
  17163.    Adr:LONGINT;
  17164. BEGIN
  17165.      ASM
  17166.         MOV EAX,[EBP+4]
  17167.         SUB EAX,5
  17168.         MOV $Adr,EAX
  17169.      END;
  17170.      IF Drive<>0 THEN
  17171.      BEGIN
  17172.           IOresult:=1; //not supported yet
  17173.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17174.           ELSE exit;
  17175.      END;
  17176.  
  17177.      GetCurrentDirectory(255,c);
  17178.      path:=c;
  17179. END;
  17180.  
  17181. PROCEDURE RmDir(CONST dir:STRING);
  17182. VAR
  17183.    c:CSTRING;
  17184.    Adr:LONGINT;
  17185. BEGIN
  17186.      ASM
  17187.         MOV EAX,[EBP+4]
  17188.         SUB EAX,5
  17189.         MOV $Adr,EAX
  17190.      END;
  17191.      c:=Dir;
  17192.      IF not RemoveDirectory(c) THEN
  17193.      BEGIN
  17194.           IOResult:=GetLastError;
  17195.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17196.           ELSE exit;
  17197.      END;
  17198. END;
  17199.  
  17200. PROCEDURE MkDir(CONST dir:STRING);
  17201. VAR
  17202.    c:CSTRING;
  17203.    Adr:LONGINT;
  17204. BEGIN
  17205.      ASM
  17206.         MOV EAX,[EBP+4]
  17207.         SUB EAX,5
  17208.         MOV $Adr,EAX
  17209.      END;
  17210.      c:=dir;
  17211.      IF not CreateDirectory(c,NIL) THEN
  17212.      BEGIN
  17213.           IOResult:=GetLastError;
  17214.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17215.           ELSE exit;
  17216.      END;
  17217. END;
  17218.  
  17219. PROCEDURE FileExpand(VAR f:FILE);
  17220. VAR
  17221.    ff:^FileRec;
  17222. BEGIN
  17223.      ff:=@f;
  17224.      inc(ff^.LOffset);
  17225.      IF ff^.LOffset=ff^.MaxCacheMem THEN
  17226.      BEGIN
  17227.           inc(ff^.LBlock);
  17228.           ff^.LOffset:=0;
  17229.      END;
  17230. END;
  17231.  
  17232. VAR
  17233.    BlockReadResult,BlockWriteResult:LONGWORD;
  17234.  
  17235. PROCEDURE BlockRead(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  17236. VAR
  17237.    ff:^FileRec;
  17238.    pp:P_FileBuffer;
  17239.    t,t1:LONGWORD;
  17240.    Temp:LONGWORD;
  17241.    Offset,Size:LONGWORD;
  17242.    OldBlock,OldOfs:LONGINT;
  17243.    MaxCacheMem:LONGWORD;
  17244.    Adr:LONGINT;
  17245. BEGIN
  17246.      IF Count=0 THEN
  17247.      BEGIN
  17248.           result:=0;
  17249.           exit;
  17250.      END;
  17251.  
  17252.      ASM
  17253.         MOV EAX,[EBP+4]
  17254.         SUB EAX,5
  17255.         MOV $Adr,EAX
  17256.      END;
  17257.      ff:=@f;
  17258.      pp:=@Buf;
  17259.      IOResult:=0;
  17260.  
  17261.      IF ff^.flags<>$6666 THEN
  17262.      BEGIN
  17263.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17264.           ELSE
  17265.           BEGIN
  17266.                IOResult:=206;
  17267.                exit;
  17268.           END;
  17269.      END;
  17270.  
  17271.      IF ff^.Handle=$ffffffff THEN
  17272.      BEGIN
  17273.          IOResult:=6; {Invalid handle}
  17274.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  17275.          ELSE exit;
  17276.      END;
  17277.  
  17278.      IF ff^.Buffer=NIL THEN
  17279.      BEGIN
  17280.           IF not ReadFile(ff^.Handle,pp^,Count*ff^.RecSize,result,NIL) THEN
  17281.           BEGIN
  17282.                IOResult:=GetLastError;
  17283.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  17284.                ELSE exit;
  17285.           END;
  17286.           exit;
  17287.      END;
  17288.  
  17289.      result:=0;
  17290.      Offset:=ff^.Offset;
  17291.      Size:=Count*ff^.RecSize;
  17292.      MaxCacheMem:=ff^.MaxCacheMem;
  17293.  
  17294.      IF Size>MaxCacheMem THEN
  17295.      BEGIN
  17296.           {Block ist größer als Cache}
  17297.           IF (ff^.Block*MaxCacheMem)+Offset+Size>(ff^.LBlock*MaxCacheMem)+ff^.LOffset THEN
  17298.             Size:=((ff^.LBlock*MaxCacheMem)+ff^.LOffset)-
  17299.                   ((ff^.Block*MaxCacheMem)+Offset);
  17300.  
  17301.           IF ff^.Changed THEN
  17302.           BEGIN
  17303.                ff^.Changed:=FALSE;
  17304.                OldBlock:=ff^.LBlock;    {temporaray save}
  17305.                OldOfs:=ff^.LOffset;
  17306.                ff^.LBlock:=ff^.Block;
  17307.                ff^.LOffset:=Offset;
  17308.                {alten Block Schreiben}
  17309.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  17310.                IF IOResult<>0 THEN
  17311.                BEGIN
  17312.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  17313.                     ELSE exit;
  17314.                END;
  17315.                ff^.LBlock:=OldBlock;
  17316.                ff^.LOffset:=OldOfs;
  17317.           END
  17318.           ELSE
  17319.           BEGIN
  17320.                Temp:=SetFilePointer(ff^.Handle,
  17321.                          (ff^.Block*MaxCacheMem)+Offset,NIL,0);
  17322.                IF Temp=$ffffffff THEN
  17323.                BEGIN
  17324.                     IOResult:=GetLastError;
  17325.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  17326.                     ELSE exit;
  17327.                END;
  17328.           END;
  17329.  
  17330.           IF not ReadFile(ff^.Handle,Buf,Size,result,NIL) THEN
  17331.           BEGIN
  17332.                IOResult:=GetLastError;
  17333.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  17334.                ELSE exit;
  17335.           END;
  17336.           size:=result; {tatsächlich gelesen}
  17337.  
  17338.           {set file buffer}
  17339.           Temp:=Offset+size;
  17340.           t:=Temp MOD MaxCacheMem;
  17341.  
  17342.           IF size<MaxCacheMem THEN
  17343.           BEGIN
  17344.                move(pp^[size-t],ff^.Buffer^,t);
  17345.                inc(ff^.Block,Temp DIV MaxCacheMem);
  17346.                ff^.Offset:=t;
  17347.                ff^.LBlock:=ff^.Block;
  17348.                ff^.LOffset:=ff^.Offset;
  17349.           END
  17350.           ELSE
  17351.           BEGIN
  17352.                {nächsten Block lesen}
  17353.                ff^.Changed:=FALSE;
  17354.                inc(ff^.Block,Temp DIV MaxCacheMem);
  17355.  
  17356.                FileBlockIO(f,ff^.block,ReadMode,Temp);
  17357.                IF IOResult<>0 THEN
  17358.                BEGIN
  17359.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  17360.                     ELSE exit;
  17361.                END;
  17362.                ff^.offset:=t;
  17363.           END;
  17364.  
  17365.           IF ff^.Block>ff^.LBlock THEN
  17366.           BEGIN
  17367.                ff^.LBlock:=ff^.Block;
  17368.                ff^.LOffset:=ff^.Offset;
  17369.           END;
  17370.  
  17371.           result:=result DIV ff^.RecSize;
  17372.           exit;
  17373.      END;
  17374.  
  17375.      IF ff^.block=ff^.LBlock THEN
  17376.      BEGIN
  17377.           IF Offset+size<ff^.LOffset THEN
  17378.           BEGIN
  17379.                {im letzten Block}
  17380.                move(ff^.Buffer^[Offset],pp^,size);
  17381.                inc(ff^.Offset,size);
  17382.                inc(result,size);
  17383.                result:=result DIV ff^.RecSize;
  17384.                exit;
  17385.           END;
  17386.      END
  17387.      ELSE
  17388.      BEGIN
  17389.           {irgendwo vor dem letzten Block}
  17390.           IF Offset+Size<MaxCacheMem THEN
  17391.           BEGIN
  17392.                move(ff^.Buffer^[Offset],pp^,size);
  17393.                inc(ff^.Offset,size);
  17394.                inc(result,size);
  17395.                result:=result DIV ff^.RecSize;
  17396.                exit;
  17397.           END;
  17398.      END;
  17399.  
  17400.      ff^.reserved1:=ff^.reserved1 and not 1;
  17401.  
  17402.      FOR t:=1 TO Size DO
  17403.      BEGIN
  17404.           IF eof(f) THEN
  17405.           BEGIN
  17406.                result:=result DIV ff^.RecSize;
  17407.                exit;
  17408.           END;
  17409.  
  17410.           pp^[t-1]:=ff^.Buffer^[ff^.offset];
  17411.           inc(ff^.offset);
  17412.           inc(result);
  17413.           IF ff^.offset=maxcachemem THEN
  17414.           BEGIN
  17415.                FileBlockIO(f,ff^.block+1,ReadMode,Temp);
  17416.                IF IOResult<>0 THEN
  17417.                BEGIN
  17418.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  17419.                     ELSE exit;
  17420.                END;
  17421.                ff^.offset:=0;
  17422.                inc(ff^.block);
  17423.           END;
  17424.      END;
  17425.      result:=result DIV ff^.RecSize;
  17426. END;
  17427.  
  17428. PROCEDURE BlockWrite(VAR f:file;var Buf;Count:LongWord;VAR result:LONGWORD);
  17429. VAR
  17430.    ff:^FileRec;
  17431.    pp:P_FileBuffer;
  17432.    t,t1,Temp:LONGWORD;
  17433.    value:BYTE;
  17434.    size:LONGWORD;
  17435.    Offset:LONGWORD;
  17436.    OldBlock,OldOfs:LONGINT;
  17437.    Adr:LONGINT;
  17438. LABEL l,l1;
  17439. BEGIN
  17440.      IF Count=0 THEN
  17441.      BEGIN
  17442.           result:=0;
  17443.           exit;
  17444.      END;
  17445.  
  17446.      ASM
  17447.         MOV EAX,[EBP+4]
  17448.         SUB EAX,5
  17449.         MOV $Adr,EAX
  17450.      END;
  17451.      ff:=@f;
  17452.      pp:=@Buf;
  17453.      IOResult:=0;
  17454.  
  17455.      IF ff^.flags<>$6666 THEN
  17456.      BEGIN
  17457.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17458.           ELSE
  17459.           BEGIN
  17460.                IOResult:=206;
  17461.                exit;
  17462.           END;
  17463.      END;
  17464.  
  17465.      IF ff^.Handle=$ffffffff THEN
  17466.      BEGIN
  17467.          IOResult:=6; {Invalid handle}
  17468.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  17469.          ELSE exit;
  17470.      END;
  17471.  
  17472.      IF ff^.Buffer=NIL THEN
  17473.      BEGIN
  17474.           IF not WriteFile(ff^.Handle,pp^,Count*ff^.RecSize,result,NIL) THEN
  17475.           BEGIN
  17476.                IOResult:=GetLastError;
  17477.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  17478.                ELSE exit;
  17479.           END;
  17480.           exit;
  17481.      END;
  17482.  
  17483.      result:=0;
  17484.      IOResult:=0;
  17485.      size:=Count*ff^.RecSize;
  17486.      Offset:=ff^.Offset;
  17487.  
  17488.      IF ff^.block=ff^.LBlock THEN
  17489.      BEGIN
  17490.           IF Offset=ff^.LOffset THEN
  17491.           BEGIN
  17492.                {am ende der Datei (im letzten Block und an LOffset)}
  17493.                IF Offset+size<ff^.MaxCacheMem THEN
  17494.                BEGIN
  17495.                     move(pp^,ff^.Buffer^[Offset],size);
  17496.                     inc(ff^.Offset,size);
  17497.                     inc(ff^.LOffset,size);
  17498.                     inc(result,size);
  17499.                     ff^.Changed:=TRUE;
  17500.                     result:=result DIV ff^.RecSize;
  17501.                     exit;
  17502.                END
  17503.                ELSE
  17504.                BEGIN
  17505.                     {Groesse geht über alten Block hinaus}
  17506. l:
  17507.                     ff^.Changed:=FALSE;
  17508.                     {alten Block Schreiben}
  17509.                     FileBlockIO(f,ff^.Block,WriteMode,Temp);
  17510.                     IF IOResult<>0 THEN
  17511.                     BEGIN
  17512.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  17513.                          ELSE exit;
  17514.                     END;
  17515. l1:
  17516.                     IF not WriteFile(ff^.Handle,Buf,Size,result,NIL) THEN
  17517.                     BEGIN
  17518.                         IOResult:=GetLastError;
  17519.                         IF RaiseIOError THEN InOutError(IOResult,Adr)
  17520.                         ELSE exit;
  17521.                     END;
  17522.                     size:=result; {Tatsächlich geschrieben}
  17523.  
  17524.                     {set file buffer}
  17525.                     Temp:=Offset+size;
  17526.                     t:=Temp MOD ff^.MaxCacheMem;
  17527.                     move(pp^[size-t],ff^.Buffer^,t);
  17528.  
  17529.                     inc(ff^.Block,Temp DIV ff^.MaxCacheMem);
  17530.                     ff^.Offset:=t;
  17531.  
  17532.                     {we are at the end of the file}
  17533.                     ff^.LBlock:=ff^.Block;
  17534.                     ff^.LOffset:=ff^.Offset;
  17535.                     result:=result DIV ff^.RecSize;
  17536.                     exit;
  17537.                END;
  17538.           END
  17539.           ELSE
  17540.           BEGIN
  17541.                {im letzten Block aber nicht an LOffset}
  17542.                IF Offset+size<ff^.LOffset THEN
  17543.                BEGIN
  17544.                     move(pp^,ff^.Buffer^[Offset],size);
  17545.                     inc(ff^.Offset,size);
  17546.                     inc(result,size);
  17547.                     ff^.Changed:=TRUE;
  17548.                     result:=result DIV ff^.RecSize;
  17549.                     exit;
  17550.                END;
  17551.                {ELSE goto l;}
  17552.           END;
  17553.      END
  17554.      ELSE
  17555.      BEGIN
  17556.           {irgendwo vor dem letzten Block}
  17557.           IF Offset+Size<ff^.MaxCacheMem THEN
  17558.           BEGIN
  17559.                move(pp^,ff^.Buffer^[Offset],size);
  17560.                inc(ff^.Offset,size);
  17561.                inc(result,size);
  17562.                ff^.Changed:=TRUE;
  17563.                result:=result DIV ff^.RecSize;
  17564.                exit;
  17565.           END;
  17566.      END;
  17567.  
  17568. (*   IF Offset+Size>(ff^.LBlock*ff^.MaxCacheMem)+ff^.LOffset THEN
  17569.      BEGIN
  17570.           ff^.Changed:=FALSE;
  17571.           OldBlock:=ff^.LBlock;    {temporaray save}
  17572.           OldOfs:=ff^.LOffset;
  17573.           ff^.LBlock:=ff^.Block;
  17574.           ff^.LOffset:=Offset;
  17575.           {alten Block Schreiben}
  17576.           FileBlockIO(f,ff^.Block,WriteMode,Temp);
  17577.           IF IOResult<>0 THEN
  17578.           BEGIN
  17579.                IF RaiseIOError THEN InOutError(IOResult)
  17580.                ELSE exit;
  17581.           END;
  17582.           ff^.LBlock:=OldBlock;
  17583.           ff^.LOffset:=OldOfs;
  17584.           goto l1;
  17585.      END;*)
  17586.  
  17587.      ff^.reserved1:=ff^.reserved1 and not 1;
  17588.  
  17589.      FOR t:=1 TO size DO
  17590.      BEGIN
  17591.           value:=pp^[t-1];
  17592.           IF value<>ff^.Buffer^[ff^.offset] THEN
  17593.           BEGIN
  17594.                ff^.Buffer^[ff^.offset]:=value;
  17595.                ff^.Changed:=TRUE;
  17596.           END;
  17597.           IF EOF(f) THEN
  17598.           BEGIN
  17599.                ff^.changed:=TRUE;
  17600.                FileExpand(f);
  17601.           END;
  17602.           inc(ff^.Offset);
  17603.           inc(Result);
  17604.  
  17605.           IF ff^.Offset=ff^.MaxCacheMem THEN
  17606.           BEGIN
  17607.                ff^.Changed:=FALSE;
  17608.                {alten Block Schreiben}
  17609.                FileBlockIO(f,ff^.Block,WriteMode,Temp);
  17610.                IF IOResult<>0 THEN
  17611.                BEGIN
  17612.                     IF RaiseIOError THEN InOutError(IOResult,Adr)
  17613.                     ELSE exit;
  17614.                END;
  17615.                {neuen Block lesen}
  17616.                ff^.Offset:=0;
  17617.                inc(ff^.Block);
  17618.                FileBlockIO(f,ff^.Block,ReadMode,Temp);
  17619.                IF IOResult<>0 THEN
  17620.                BEGIN
  17621.                    IF RaiseIOError THEN InOutError(IOResult,Adr)
  17622.                    ELSE exit;
  17623.                END;
  17624.           END;
  17625.      END;
  17626.      result:=result DIV ff^.RecSize;
  17627. END;
  17628.  
  17629. PROCEDURE Rename(VAR f:file;NewName:String);
  17630. VAR
  17631.    c,c1:CSTRING;
  17632.    ff:^FileRec;
  17633.    Adr:LONGINT;
  17634. BEGIN
  17635.      ASM
  17636.         MOV EAX,[EBP+4]
  17637.         SUB EAX,5
  17638.         MOV $Adr,EAX
  17639.      END;
  17640.      ff:=@f;
  17641.      c:=NewName;
  17642.      c1:=ff^.Name;
  17643.      IF not MoveFile(c1,c) THEN
  17644.      BEGIN
  17645.           IOResult:=GetLastError;
  17646.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17647.           ELSE exit;
  17648.      END;
  17649. END;
  17650.  
  17651. PROCEDURE Erase(VAR f:file);
  17652. VAR
  17653.    ff:^FileRec;
  17654.    c:CSTRING;
  17655.    Adr:LONGINT;
  17656. BEGIN
  17657.      ASM
  17658.         MOV EAX,[EBP+4]
  17659.         SUB EAX,5
  17660.         MOV $Adr,EAX
  17661.      END;
  17662.      ff:=@f;
  17663.      IF ff^.flags<>$6666 THEN
  17664.      BEGIN
  17665.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17666.           ELSE
  17667.           BEGIN
  17668.                IOResult:=206;
  17669.                exit;
  17670.           END;
  17671.      END;
  17672.      c:=ff^.name;
  17673.      IF not DeleteFile(c) THEN
  17674.      BEGIN
  17675.           IOResult:=GetLastError;
  17676.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17677.           ELSE exit;
  17678.      END;
  17679. END;
  17680.  
  17681. PROCEDURE SetFileBuf(VAR f:FILE;VAR Buf;BufSize:LONGWORD);
  17682. BEGIN
  17683.      IF BufSize<4096 THEN BufSize:=4096;
  17684. END;
  17685.  
  17686. PROCEDURE SetTextBuf(VAR f:TEXT;VAR Buf;BufSize:LONGWORD);
  17687. BEGIN
  17688.      if BufSize>16*1024 then SetFileBuf(F,Buf,BufSize);
  17689. END;
  17690.  
  17691. PROCEDURE StrWriteText({VAR f:FILE}CONST s:STRING;format:LONGWORD);
  17692. VAR
  17693.     fi:^FILE;
  17694.     ss:STRING;
  17695.     fillup:BYTE;
  17696.     Adr:LONGINT;
  17697.     SaveIO:BOOLEAN;
  17698. BEGIN
  17699.      ASM
  17700.         MOV EAX,[EBP+4]
  17701.         SUB EAX,5
  17702.         MOV $Adr,EAX
  17703.      END;
  17704.      ASM
  17705.         MOV EAX,[EBP+16]  //VAR f:FILE
  17706.         MOV $fi,EAX
  17707.      END;
  17708.      IF Format+Length(s)>255 THEN Format:=255-length(s);
  17709.      IF format>length(s) THEN
  17710.      BEGIN
  17711.           fillup:=format-length(s);  {erst soviele Leerzeichen}
  17712.           fillchar(ss[0],fillup,32);
  17713.           SaveIO:=RaiseIOError;
  17714.           RaiseIOError:=FALSE;
  17715.           BlockWrite(fi^,ss[0],fillup);
  17716.           RaiseIOError:=SaveIO;
  17717.           IF IOResult<>0 THEN
  17718.           BEGIN
  17719.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  17720.                ELSE exit;
  17721.           END;
  17722.      END;
  17723.      SaveIO:=RaiseIOError;
  17724.      RaiseIOError:=FALSE;
  17725.      {must do this in ASM because s is constant parameter}
  17726.      ASM
  17727.         PUSHL $fi
  17728.         MOV EDI,$s
  17729.         INC EDI
  17730.         PUSH EDI
  17731.         DEC EDI
  17732.         MOVZXB EAX,[EDI+0]
  17733.         PUSH EAX
  17734.         PUSHL OFFSET(SYSTEM.BlockWriteResult)
  17735.         CALLN32 SYSTEM.BlockWrite
  17736.      END;
  17737.      RaiseIOError:=SaveIO;
  17738.      IF IOResult<>0 THEN
  17739.      BEGIN
  17740.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17741.           ELSE exit;
  17742.      END;
  17743. END;
  17744.  
  17745. PROCEDURE CStrWriteText({VAR f:FILE}CONST s:CSTRING;format:LONGWORD);
  17746. VAR
  17747.     ss:STRING;
  17748.     l:LONGWORD;
  17749.     fi:^FILE;
  17750.     fillup:BYTE;
  17751.     Adr:LONGINT;
  17752.     SaveIO:BOOLEAN;
  17753. BEGIN
  17754.      ASM
  17755.         MOV EAX,[EBP+16]  //VAR f:FILE
  17756.         MOV $fi,EAX
  17757.      END;
  17758.      ASM
  17759.         MOV EAX,[EBP+4]
  17760.         SUB EAX,5
  17761.         MOV $Adr,EAX
  17762.      END;
  17763.      l:=length(s);
  17764.      IF Format+l>255 THEN Format:=255-l;
  17765.      IF format>l THEN
  17766.      BEGIN
  17767.           fillup:=format-l;
  17768.           fillchar(ss[0],fillup,32);
  17769.           SaveIO:=RaiseIOError;
  17770.           RaiseIOError:=FALSE;
  17771.           BlockWrite(fi^,ss[0],fillup);
  17772.           RaiseIOError:=SaveIO;
  17773.           IF IOResult<>0 THEN
  17774.           BEGIN
  17775.                IF RaiseIOError THEN InOutError(IOResult,Adr)
  17776.                ELSE exit;
  17777.           END;
  17778.      END;
  17779.      SaveIO:=RaiseIOError;
  17780.      RaiseIOError:=FALSE;
  17781.      {must do this in ASM because s is constant parameter}
  17782.      ASM
  17783.         PUSHL $fi
  17784.         PUSHL $s
  17785.         PUSHL $l
  17786.         PUSHL OFFSET(SYSTEM.BlockWriteResult)
  17787.         CALLN32 SYSTEM.BlockWrite
  17788.      END;
  17789.      RaiseIOError:=SaveIO;
  17790.      IF IOResult<>0 THEN
  17791.      BEGIN
  17792.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17793.           ELSE exit;
  17794.      END;
  17795. END;
  17796.  
  17797. {Float value is in ST(0) !}
  17798. PROCEDURE WriteExtendedText({VAR f:FILE}Format1,Format2:LONGWORD);
  17799. VAR
  17800.    float:EXTENDED;
  17801.    fi:^FILE;
  17802.    s:STRING;
  17803.    Adr:LONGINT;
  17804.    SaveIO:BOOLEAN;
  17805. BEGIN
  17806.      ASM
  17807.         MOV EAX,[EBP+4]
  17808.         SUB EAX,5
  17809.         MOV $Adr,EAX
  17810.      END;
  17811.      ASM
  17812.         MOV EAX,[EBP+16]  //VAR f:FILE
  17813.         MOV $fi,EAX
  17814.         FSTPT $float
  17815.  
  17816.         PUSHL $Format1
  17817.         PUSHL $Format2     //Nachkommas
  17818.         LEA EAX,$float
  17819.         PUSH EAX
  17820.         LEA EAX,$s
  17821.         PUSH EAX
  17822.         CALLN32 SYSTEM.!Extended2Str
  17823.       END;
  17824.       SaveIO:=RaiseIOError;
  17825.       RaiseIOError:=FALSE;
  17826.       BlockWrite(fi^,s[1],length(s));
  17827.       RaiseIOError:=SaveIO;
  17828.       IF IOResult<>0 THEN
  17829.       BEGIN
  17830.            IF RaiseIOError THEN InOutError(IOResult,Adr)
  17831.            ELSE exit;
  17832.       END;
  17833. END;
  17834.  
  17835. PROCEDURE WritelnText(VAR f:FILE);
  17836. VAR
  17837.    w:WORD;
  17838.    Adr:LONGINT;
  17839.    SaveIO:BOOLEAN;
  17840. BEGIN
  17841.      ASM
  17842.         MOV EAX,[EBP+4]
  17843.         SUB EAX,5
  17844.         MOV $Adr,EAX
  17845.      END;
  17846.      {Write #13#10}
  17847.      w:=$0a0d;
  17848.      SaveIO:=RaiseIOError;
  17849.      RaiseIOError:=FALSE;
  17850.      BlockWrite(f,w,2);
  17851.      RaiseIOError:=SaveIO;
  17852.      IF IOResult<>0 THEN
  17853.      BEGIN
  17854.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17855.           ELSE exit;
  17856.      END;
  17857. END;
  17858.  
  17859. PROCEDURE WriteText(VAR f:FILE);
  17860. BEGIN
  17861.      {do nothing here - just pop f}
  17862. END;
  17863.  
  17864. PROCEDURE FileWrite({VAR f:FILE)}VAR Buf;size:LONGWORD);
  17865. VAR
  17866.    fi:^FILE;
  17867.    fr:^FileRec;
  17868.    Adr:LONGINT;
  17869.    SaveIO:BOOLEAN;
  17870. BEGIN
  17871.      ASM
  17872.         MOV EAX,[EBP+4]
  17873.         SUB EAX,5
  17874.         MOV $Adr,EAX
  17875.      END;
  17876.      ASM
  17877.         MOV EAX,[EBP+16]  //VAR f:FILE
  17878.         MOV $fi,EAX
  17879.         MOV $fr,EAX
  17880.      END;
  17881.      SaveIO:=RaiseIOError;
  17882.      RaiseIOError:=FALSE;
  17883.      BlockWrite(fi^,Buf,size DIV fr^.RecSize);
  17884.      RaiseIOError:=SaveIO;
  17885.      IF IOResult<>0 THEN
  17886.      BEGIN
  17887.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17888.           ELSE exit;
  17889.      END;
  17890. END;
  17891.  
  17892. PROCEDURE FileRead({VAR f:FILE;}VAR Buf;size:LONGWORD);
  17893. VAR
  17894.    fi:^FILE;
  17895.    fr:^FileRec;
  17896.    Adr:LONGINT;
  17897.    SaveIO:BOOLEAN;
  17898. BEGIN
  17899.      ASM
  17900.         MOV EAX,[EBP+4]
  17901.         SUB EAX,5
  17902.         MOV $Adr,EAX
  17903.      END;
  17904.      ASM
  17905.         MOV EAX,[EBP+16]  //VAR f:FILE
  17906.         MOV $fi,EAX
  17907.         MOV $fr,EAX
  17908.      END;
  17909.  
  17910.      SaveIO:=RaiseIOError;
  17911.      RaiseIOError:=FALSE;
  17912.      BlockRead(fi^,Buf,size DIV fr^.RecSize);
  17913.      RaiseIOError:=SaveIO;
  17914.      IF IOResult<>0 THEN
  17915.      BEGIN
  17916.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  17917.           ELSE exit;
  17918.      END;
  17919. END;
  17920.  
  17921. FUNCTION SeekEoln(VAR F:Text):Boolean;
  17922. VAR
  17923.     Adr:LONGINT;
  17924.     fi:^FileRec;
  17925.     Offset:LONGINT;
  17926.     Value:BYTE;
  17927.     SaveIoError:BOOLEAN;
  17928.     Res:LONGWORD;
  17929.     t:BYTE;
  17930.     s:STRING;
  17931. BEGIN
  17932.      ASM
  17933.         MOV EAX,[EBP+4]
  17934.         SUB EAX,5
  17935.         MOV $Adr,EAX
  17936.      END;
  17937.  
  17938.      fi:=@f;
  17939.  
  17940.      IF fi^.flags<>$6666 THEN
  17941.      BEGIN
  17942.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  17943.           ELSE
  17944.           BEGIN
  17945.                IOResult:=206;
  17946.                exit;
  17947.           END;
  17948.      END;
  17949.  
  17950.      IF fi^.Handle=$ffffffff THEN
  17951.      BEGIN
  17952.          IOResult:=6; {Invalid handle}
  17953.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  17954.          ELSE exit;
  17955.      END;
  17956.  
  17957.      IF eof(f) THEN
  17958.      BEGIN
  17959.           result:=TRUE;
  17960.           exit;
  17961.      END;
  17962.  
  17963.      Offset:=fi^.Offset;
  17964.  
  17965.      IF fi^.Buffer=NIL THEN
  17966.      BEGIN
  17967.           IF lo(fi^.BufferBytes)=1 THEN
  17968.           BEGIN
  17969.                Value:=Hi(fi^.BufferBytes);
  17970.           END
  17971.           ELSE
  17972.           BEGIN
  17973.                SaveIOError:=RaiseIOError;
  17974.                RaiseIOError:=FALSE;
  17975.                BlockRead(f,Value,1,Res);
  17976.                Seek(f,FilePos(f)-1);
  17977.                RaiseIOError:=SaveIOError;
  17978.                IF Res=0 THEN Value:=26; {EOF}
  17979.           END;
  17980.      END
  17981.      ELSE value:=fi^.Buffer^[Offset];
  17982.  
  17983.      IF value IN [13,10,26] THEN result:=TRUE
  17984.      ELSE
  17985.      BEGIN
  17986.           IF not (value IN [9,32]) THEN result:=FALSE
  17987.           ELSE  {must read the line}
  17988.           BEGIN
  17989.                SaveIOError:=RaiseIOError;
  17990.                RaiseIOError:=FALSE;
  17991.  
  17992.                Offset:=FilePos(f);
  17993.                Readln(f,s);
  17994.                Seek(f,Offset);
  17995.  
  17996.                RaiseIOError:=SaveIOError;
  17997.                result:=TRUE;
  17998.                FOR t:=1 TO length(s) DO
  17999.                  IF not (s[t] IN [#9,#32]) THEN result:=FALSE;
  18000.           END;
  18001.      END;
  18002. END;
  18003.  
  18004. FUNCTION SeekEof(Var F :Text):Boolean;
  18005. VAR
  18006.     Adr:LONGINT;
  18007.     fi:^FileRec;
  18008.     OldFP:LONGWORD;
  18009.     ch:Char;
  18010. BEGIN
  18011.      ASM
  18012.         MOV EAX,[EBP+4]
  18013.         SUB EAX,5
  18014.         MOV $Adr,EAX
  18015.      END;
  18016.  
  18017.      fi:=@f;
  18018.  
  18019.      IF fi^.flags<>$6666 THEN
  18020.      BEGIN
  18021.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  18022.           ELSE
  18023.           BEGIN
  18024.                IOResult:=206;
  18025.                exit;
  18026.           END;
  18027.      END;
  18028.  
  18029.      IF fi^.Handle=$ffffffff THEN
  18030.      BEGIN
  18031.          IOResult:=6; {Invalid handle}
  18032.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  18033.          ELSE exit;
  18034.      END;
  18035.  
  18036.      OldFP := FilePos(F);
  18037.  
  18038.      WHILE not Eof(F) DO
  18039.      BEGIN
  18040.           Read(F,ch);
  18041.           IF not (ch IN [#32,#9,#13,#10]) THEN break;
  18042.      END;
  18043.  
  18044.      Result := Eof(f);
  18045.      Seek(F,OldFP);
  18046. END;
  18047.  
  18048.  
  18049. PROCEDURE TextRead({VAR f:TEXT;VAR Ziel;}VAR s:STRING;Typ,MaxLen:LONGWORD);
  18050. VAR
  18051.    fi:^FileRec;
  18052.    fi2:^TEXT;
  18053.    Offset,Ende,t,Temp,Res,Res1:LONGWORD;
  18054.    Count:WORD;
  18055.    Value:BYTE;
  18056.    SaveIoError:BOOLEAN;
  18057.    Adr:LONGINT;
  18058. LABEL l,skip;
  18059. BEGIN
  18060.      ASM
  18061.         MOV EAX,[EBP+4]
  18062.         SUB EAX,5
  18063.         MOV $Adr,EAX
  18064.      END;
  18065.      ASM
  18066.         MOV EAX,[EBP+24]  //VAR f:TEXT
  18067.         MOV $fi,EAX
  18068.         MOV $fi2,EAX
  18069.      END;
  18070.  
  18071.      IF fi^.flags<>$6666 THEN
  18072.      BEGIN
  18073.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  18074.           ELSE
  18075.           BEGIN
  18076.                IOResult:=206;
  18077.                exit;
  18078.           END;
  18079.      END;
  18080.  
  18081.      IF fi^.Handle=$ffffffff THEN
  18082.      BEGIN
  18083.          IOResult:=6; {Invalid handle}
  18084.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  18085.          ELSE exit;
  18086.      END;
  18087.  
  18088.      fi^.reserved1:=fi^.reserved1 and not 1;
  18089.  
  18090.      IF eof(fi2^) THEN
  18091.      BEGIN
  18092.           (*IOResult:=38;  {Handle EOF}
  18093.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  18094.           ELSE exit;*)
  18095.           CASE Typ OF
  18096.             1:s:=''; {String}
  18097.             2:s:=chr(26); {Char}
  18098.             3:s:=''; {Number}
  18099.             ELSE s:='';
  18100.           END; {case}
  18101.           exit;
  18102.      END;
  18103.  
  18104.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  18105.      ELSE Ende:=fi^.LOffset;
  18106.  
  18107.      Count:=0;
  18108.      s:='';
  18109.  
  18110.      Offset:=fi^.Offset;
  18111.  
  18112.      IF fi^.Buffer=NIL THEN
  18113.      BEGIN
  18114.           Offset:=0;
  18115.           Ende:=256;
  18116.      END;
  18117.  
  18118.      fi^.reserved1:=fi^.reserved1 and not 1;
  18119. l:
  18120.      FOR t:=Offset TO Ende-1 DO
  18121.      BEGIN
  18122.           IF fi^.Buffer=NIL THEN
  18123.           BEGIN
  18124.                IF lo(fi^.BufferBytes)=1 THEN
  18125.                BEGIN
  18126.                     Value:=Hi(fi^.BufferBytes);
  18127.                     fi^.BufferBytes:=0;
  18128.                END
  18129.                ELSE
  18130.                BEGIN
  18131.                     SaveIOError:=RaiseIOError;
  18132.                     RaiseIOError:=FALSE;
  18133.                     BlockRead(fi2^,Value,1,Res);
  18134.                     RaiseIOError:=SaveIOError;
  18135.                     IF IOResult<>0 THEN
  18136.                     BEGIN
  18137.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  18138.                          ELSE exit;
  18139.                     END;
  18140.                     IF Res=0 THEN Value:=26; {EOF}
  18141.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  18142.                END;
  18143.           END
  18144.           ELSE value:=fi^.Buffer^[t];
  18145.  
  18146.           IF value=26 {EOF} THEN
  18147.           BEGIN
  18148.                {SaveIoError:=RaiseIoError;
  18149.                RaiseIOError:=FALSE;
  18150.                Seek(fi2^,FileSize(fi2^));
  18151.                RaiseIOError:=SaveIoError;}
  18152.                fi^.Reserved1:=fi^.Reserved1 OR 1;  {mark EOF}
  18153.                IF Count>255 THEN Count:=255;
  18154.                s[0]:=chr(Count);
  18155.                IF s='' THEN s:=#26;
  18156.                inc(fi^.Offset);
  18157.                fi^.BufferBytes:=0;
  18158.                exit;
  18159.           END;
  18160.  
  18161.           CASE Typ OF
  18162.             1:  {String}
  18163.             BEGIN
  18164.                  CASE value OF
  18165.                    13,10:
  18166.                    BEGIN
  18167.                         IF Count>255 THEN Count:=255;
  18168.                         IF Count>255 THEN Count:=255;
  18169.                         s[0]:=chr(Count);
  18170.                         exit;
  18171.                    END;
  18172.                  END; {case}
  18173.             END;
  18174.             2:  {Char}
  18175.             BEGIN
  18176.                  s[1]:=chr(Value);
  18177.                  s[0]:=#1;
  18178.  
  18179.                  IF fi^.Buffer<>NIL THEN inc(fi^.Offset)
  18180.                  ELSE fi^.BufferBytes:=0;
  18181.                  IF fi^.Offset=Ende THEN
  18182.                  BEGIN
  18183.                       IF Eof(fi2^) THEN exit;
  18184.  
  18185.                       {Ende erreicht --> erweitern}
  18186.                       IF fi^.Buffer=NIL THEN exit;
  18187.                       FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  18188.                       IF IOResult<>0 THEN
  18189.                       BEGIN
  18190.                           IF RaiseIOError THEN InOutError(IOResult,Adr)
  18191.                           ELSE exit;
  18192.                       END;
  18193.                       fi^.offset:=0;
  18194.                       inc(fi^.block);
  18195.                  END;
  18196.                  exit;
  18197.             END;
  18198.             3:  {Number}
  18199.             BEGIN
  18200.                  CASE value OF
  18201.                    13,10,32,9:
  18202.                    BEGIN
  18203.                         IF Count=0 THEN goto skip; {skip preceding chars}
  18204.                         IF Count>255 THEN Count:=255;
  18205.                         s[0]:=chr(Count);
  18206.                         exit;
  18207.                    END;
  18208.                  END; {case}
  18209.             END;
  18210.           END; {case}
  18211.  
  18212.           inc(Count);
  18213.           IF Count<256 THEN IF Count<=MaxLen THEN s[Count]:=chr(value);
  18214. skip:
  18215.           inc(fi^.Offset);
  18216.           fi^.BufferBytes:=0;
  18217.           IF Count>=MaxLen THEN
  18218.           BEGIN
  18219.                IF Count>255 THEN Count:=255;
  18220.                s[0]:=chr(Count);
  18221.                exit;
  18222.           END;
  18223.      END;
  18224.  
  18225.      IF eof(fi2^) THEN
  18226.      BEGIN
  18227.           (*IOResult:=38;  {Handle EOF}
  18228.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  18229.           ELSE exit;*)
  18230.           IF Count>255 THEN Count:=255;
  18231.           s[0]:=chr(Count);
  18232.           exit;
  18233.      END;
  18234.  
  18235.      {Ende erreicht --> erweitern}
  18236.      IF fi^.Buffer<>NIL THEN
  18237.      BEGIN
  18238.           FileBlockIO(fi2^,fi^.block+1,ReadMode,Temp);
  18239.           IF IOResult<>0 THEN
  18240.           BEGIN
  18241.               IF RaiseIOError THEN InOutError(IOResult,Adr)
  18242.               ELSE exit;
  18243.           END;
  18244.  
  18245.           fi^.offset:=0;
  18246.           inc(fi^.block);
  18247.      END;
  18248.  
  18249.      IF eof(fi2^) THEN
  18250.      BEGIN
  18251.           IOResult:=38;  {Handle EOF}
  18252.           IF RaiseIOError THEN InOutError(IOResult,Adr)
  18253.           ELSE exit;
  18254.      END;
  18255.  
  18256.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  18257.      ELSE Ende:=fi^.LOffset;
  18258.      Offset:=fi^.Offset;
  18259.      IF fi^.Buffer=NIL THEN
  18260.      BEGIN
  18261.           Offset:=0;
  18262.           Ende:=256;
  18263.      END;
  18264.      goto l;
  18265. END;
  18266.  
  18267. PROCEDURE TextReadLF(VAR f:TEXT);
  18268. VAR
  18269.    fi:^FileRec;
  18270.    Offset,Ende,t,Temp,Res:LONGWORD;
  18271.    Value:BYTE;
  18272.    Read13,Read10:BOOLEAN;
  18273.    Adr:LONGINT;
  18274.    SaveIO:BOOLEAN;
  18275. LABEL l;
  18276. BEGIN
  18277.      ASM
  18278.         MOV EAX,[EBP+4]
  18279.         SUB EAX,5
  18280.         MOV $Adr,EAX
  18281.      END;
  18282.      fi:=@f;
  18283.  
  18284.      IF fi^.flags<>$6666 THEN
  18285.      BEGIN
  18286.           IF RaiseIOError THEN InvalidFileNameError(Adr)
  18287.           ELSE
  18288.           BEGIN
  18289.                IOResult:=206;
  18290.                exit;
  18291.           END;
  18292.      END;
  18293.  
  18294.      IF fi^.Handle=$ffffffff THEN
  18295.      BEGIN
  18296.          IOResult:=6; {Invalid handle}
  18297.          IF RaiseIOError THEN InOutError(IOResult,Adr)
  18298.          ELSE exit;
  18299.      END;
  18300.  
  18301.      fi^.reserved1:=fi^.reserved1 and not 1;
  18302.  
  18303.      IF Eof(f) THEN exit;
  18304.  
  18305.      Offset:=fi^.Offset;
  18306.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  18307.      ELSE Ende:=fi^.LOffset;
  18308.  
  18309.      IF fi^.Buffer=NIL THEN
  18310.      BEGIN
  18311.           Offset:=0;
  18312.           Ende:=256;
  18313.      END;
  18314.  
  18315.      Read13:=FALSE;
  18316.      Read10:=FALSE;
  18317.  
  18318.      fi^.reserved1:=fi^.reserved1 and not 1;
  18319. l:
  18320.      FOR t:=Offset TO Ende-1 DO
  18321.      BEGIN
  18322.           IF fi^.Buffer=NIL THEN
  18323.           BEGIN
  18324.                IF lo(fi^.BufferBytes)=1 THEN
  18325.                BEGIN
  18326.                     Value:=Hi(fi^.BufferBytes);
  18327.                     fi^.BufferBytes:=0;
  18328.                END
  18329.                ELSE
  18330.                BEGIN
  18331.                     SaveIO:=RaiseIOError;
  18332.                     RaiseIOError:=FALSE;
  18333.                     BlockRead(f,Value,1,Res);
  18334.                     RaiseIOError:=SaveIO;
  18335.                     IF IOResult<>0 THEN
  18336.                     BEGIN
  18337.                          IF RaiseIOError THEN InOutError(IOResult,Adr)
  18338.                          ELSE exit;
  18339.                     END;
  18340.                     IF Res=0 THEN Value:=26; {EOF}
  18341.                     fi^.BufferBytes:=1 OR (Value SHL 8);
  18342.                END;
  18343.           END
  18344.           ELSE value:=fi^.Buffer^[t];
  18345.           CASE value OF
  18346.             26: {EOF}
  18347.             BEGIN
  18348.                fi^.Reserved1:=fi^.Reserved1 OR 1; {mark EOF}
  18349.                exit;
  18350.             END;
  18351.             13:
  18352.             BEGIN
  18353.                  IF ((Read13)OR(Read10)) THEN
  18354.                  BEGIN
  18355.                       fi^.BufferBytes:=0;
  18356.                       exit;
  18357.                  END;
  18358.                  Read13:=TRUE;
  18359.             END;
  18360.             10:
  18361.             BEGIN
  18362.                  IF Read10 THEN
  18363.                  BEGIN
  18364.                       fi^.BufferBytes:=0;
  18365.                       exit;
  18366.                  END;
  18367.                  IF f=Input THEN IF Read13 THEN
  18368.                  BEGIN
  18369.                       fi^.BufferBytes:=0;
  18370.                       exit;
  18371.                  END;
  18372.                  Read10:=TRUE;
  18373.             END;
  18374.             ELSE
  18375.             BEGIN
  18376.                  IF Read13 THEN
  18377.                  BEGIN
  18378.                       fi^.BufferBytes:=0;
  18379.                       exit;
  18380.                  END;
  18381.                  IF Read10 THEN
  18382.                  BEGIN
  18383.                       fi^.BufferBytes:=0;
  18384.                       exit;
  18385.                  END;
  18386.             END;
  18387.           END; {case}
  18388.           inc(fi^.Offset);
  18389.           fi^.BufferBytes:=0;
  18390.      END;
  18391.  
  18392.      IF Eof(f) THEN exit;
  18393.  
  18394.      {Ende erreicht --> erweitern}
  18395.      IF fi^.Buffer<>NIL THEN
  18396.      BEGIN
  18397.          FileBlockIO(f,fi^.block+1,ReadMode,Temp);
  18398.          IF IOResult<>0 THEN
  18399.          BEGIN
  18400.              IF RaiseIOError THEN InOutError(IOResult,Adr)
  18401.              ELSE exit;
  18402.          END;
  18403.          fi^.offset:=0;
  18404.          inc(fi^.block);
  18405.      END;
  18406.  
  18407.      IF eof(f) THEN exit;
  18408.  
  18409.      IF fi^.Block<>fi^.LBlock THEN Ende:=fi^.MaxCacheMem
  18410.      ELSE Ende:=fi^.LOffset;
  18411.      Offset:=fi^.Offset;
  18412.      IF fi^.Buffer=NIL THEN
  18413.      BEGIN
  18414.           Offset:=0;
  18415.           Ende:=256;
  18416.      END;
  18417.      goto l;
  18418. END;
  18419.  
  18420.  
  18421. PROCEDURE ReadLnText(VAR source:TEXT);
  18422. BEGIN
  18423.      TextReadLF(source);
  18424. END;
  18425.  
  18426. ASSEMBLER
  18427.  
  18428. SYSTEM.!ParaInfo PROC NEAR32  //(AL=Function - 1 count of parameters to CL
  18429.                               //               2 Pointer to parameter CL to ESI
  18430.                               //Input:argument start in ESI
  18431.          MOV BX,0      //we start with parameter 0
  18432.          CMP AL,2      //get parameter name ?
  18433.          JNE !no_name
  18434.          PUSH ESI
  18435.          CMP CL,0      //parameter 0 required ?
  18436.          JE !no_args
  18437.          POP ESI
  18438. !no_name:
  18439.          //Overread the EXE file name
  18440.          CLD
  18441.          PUSH AX
  18442. !rrloop:
  18443.          LODSB
  18444.          CMP AL,32
  18445.          JNE !rrloop
  18446.          POP AX
  18447.  
  18448.          CMP AL,2   //get parameter name ?
  18449.          JE !get_argname
  18450.          MOV CL,255 //impossible parameter
  18451. !get_argname:
  18452.          XOR CH,CH
  18453.          MOV BX,1      //now finally we start with parameter 1
  18454.  
  18455.          LODSB
  18456.          //check whether the first character is a separator
  18457.          CMP AL,' '
  18458.          JE !aagain
  18459.          CMP AL,0   //is this already the end -->Urrgh !
  18460.          JNE !al2
  18461.          PUSHL 0    //The (nonexistent) parameters -->Throw it away guy !
  18462.          MOV BL,0   //No parameters
  18463.          JMP !no_args
  18464. !al2:
  18465.          DEC ESI    //restore old position
  18466. !aagain:
  18467.          PUSH ESI   //save last adress
  18468.          CMP CL,BL  //is the parameter reached ??
  18469.          JE !no_args
  18470. !readloop:
  18471.          LODSB
  18472.          CMP AL,0
  18473.          JE !no_args1  //No more arguments detected
  18474.          //check all separators possible
  18475.          CMP AL,' '
  18476.          JE !separator
  18477.          //No separator --> normal character
  18478.          JMP !readloop
  18479. !separator:
  18480.          //Check whether more separators follow
  18481.          LODSB
  18482.          CMP AL,' '
  18483.          JE !one_more
  18484.          CMP AL,0      //A zero parameter is stupid
  18485.          JNE !no_more
  18486.          POP EAX       //Clear stack
  18487.          PUSHL 0       //The (nonexistent) parameter -->Throw it away guy !
  18488.          JMP !no_args
  18489. !one_more:
  18490.          JMP !separator
  18491. !no_more:
  18492.          DEC ESI
  18493.          INC BX        //Increment parameter count
  18494.          POP EAX       //clear stack
  18495.          JMP !aagain
  18496. !no_args1:
  18497.          //Argument index was invalid
  18498.          POP ESI   //Clear Stack
  18499.          PUSHL 0   //Pointer to parameter is NIL
  18500. !no_args:
  18501.          MOV CL,BL     //Parameter count
  18502.          POP ESI       //Adress of last parameter
  18503.          RETN32
  18504. SYSTEM.!ParaInfo ENDP
  18505.  
  18506. END;
  18507.  
  18508. FUNCTION  PARAMSTR(item:Byte):STRING;
  18509. VAR s,s1:STRING;
  18510. BEGIN
  18511.      ParamStr:='';  {Clear}
  18512.      ASM
  18513.          MOV CL,$item                //index to CL
  18514.          MOV AL,2                    //Get Parameter name
  18515.          MOV ESI,SYSTEM.ArgStart
  18516.          CALLN32 SYSTEM.!ParaInfo
  18517.          MOV EDI,[EBP+8]             //Result string
  18518.          MOVB [EDI+0],0              //Result string is empty
  18519.          LEA EDI,$s                  //result string
  18520.          XOR AL,AL                   //Stringlen to 0
  18521.          STOSB
  18522.          CMP ESI,0                   //Parameter invalid ?
  18523.          JE _Lpe
  18524.  
  18525.          CLD
  18526.          LEA EDI,$s   //result string
  18527.          XOR AL,AL    //Stringlen to 0
  18528.          STOSB
  18529.          MOV CL,0     //Len is 0
  18530. __lp1:
  18531.          LODSB
  18532.          //Check all separators
  18533.          CMP AL,' '
  18534.          JE __Lps
  18535.          CMP AL,0    //Last parameter
  18536.          JE __Lps
  18537.          INC CL
  18538.          //No separator --> save
  18539.          STOSB
  18540.          JMP __lp1
  18541. __Lps:
  18542.          LEA EDI,$s            //Result string
  18543.          MOV [EDI+0],CL        //set Stringlen
  18544. _lpe:
  18545.     END;
  18546.     IF item=0 THEN
  18547.     BEGIN
  18548.          IF Length(s)>0 THEN IF s[1]='"' THEN Delete(s,1,1);
  18549.          IF s[length(s)]='"' THEN dec(s[0]);
  18550.          IF pos('.',s)=0 THEN s:=s+'.EXE';
  18551.          IF pos('\',s)=0 THEN
  18552.          BEGIN
  18553.               getdir(0,s1);
  18554.               IF s1[length(s1)]='\' THEN dec(s1[0]);
  18555.               s:=s1+'\'+s;
  18556.          END;
  18557.     END;
  18558.     ParamStr:=s;
  18559. END;
  18560.  
  18561.  
  18562.  
  18563. FUNCTION PARAMCOUNT:Byte;
  18564. BEGIN
  18565.      ASM
  18566.         MOV AL,1  //get parametercount
  18567.         MOV ESI,SYSTEM.ArgStart
  18568.         CALLN32 SYSTEM.!ParaInfo
  18569.         MOV AL,CL
  18570.         XOR AH,AH
  18571.         MOV $!FUNCRESULT,AX
  18572.      END;
  18573. END;
  18574.  
  18575. //************************************************************************
  18576. //
  18577. //
  18578. // System initialization section
  18579. //
  18580. //
  18581. //************************************************************************
  18582.  
  18583.  
  18584. PROCEDURE InitScreenInOut;
  18585. VAR VioModule:LONGWORD;
  18586.     s:CSTRING;
  18587.     Size,Value:WORD;
  18588.     csbi:CONSOLE_SCREEN_BUFFER_INFO;
  18589.     ff:^FileRec;
  18590.     co:COORD;
  18591.     Actual:LONGWORD;
  18592. LABEL l;
  18593. BEGIN
  18594.      ScreenInOut.Create;
  18595.  
  18596.      ff:=@Output;
  18597.      GetConsoleScreenBufferInfo(ff^.Handle,csbi);
  18598.  
  18599.      WITH csbi DO
  18600.      BEGIN
  18601.           IF dwSize.X = 40 THEN LastMode := CO40
  18602.           ELSE LastMode := CO80;
  18603.           IF dwSize.Y > 25 THEN Inc(LastMode,Font8x8);
  18604.      END;
  18605.  
  18606.      WindMin := 0;
  18607.      WindMax := csbi.dwSize.X - 1 + (csbi.dwSize.Y - 1) SHL 8;
  18608.      MaxWindMin :=WindMin;
  18609.      MaxWindMax :=WindMax;
  18610.  
  18611.      co.X:=1;
  18612.      co.Y:=1;
  18613.  
  18614.      ReadConsoleOutputAttribute(ff^.Handle,Value,2,LONGWORD(co),Actual);
  18615.      TextAttr := Hi(Value) AND $7F;
  18616.  
  18617.      ff:=@Input;
  18618.      SetConsoleMode(ff^.Handle,ENABLE_PROCESSED_INPUT OR ENABLE_LINE_INPUT OR
  18619.        ENABLE_ECHO_INPUT OR ENABLE_WINDOW_INPUT OR ENABLE_MOUSE_INPUT OR
  18620.        ENABLE_PROCESSED_OUTPUT OR ENABLE_WRAP_AT_EOL_OUTPUT);
  18621. END;
  18622.  
  18623. PROCEDURE InitScreenInOutPM;
  18624. VAR
  18625.    c:TPMScreenInOutClass;
  18626. BEGIN
  18627.      c.Create;
  18628.      ScreenInOut:=TScreenInOutClass(c);
  18629. END;
  18630.  
  18631. TYPE
  18632.     PSCUFileFormat=^TSCUFileFormat;
  18633.     TSCUFileFormat=RECORD
  18634.                          Version:STRING[5];
  18635.                          ObjectOffset,ObjectLen:LONGINT;
  18636.                          NameTableOffset,NameTableLen:LONGINT;
  18637.                          ResourceOffset,ResourceLen:LONGINT;
  18638.                          ObjectCount:LONGINT;
  18639.                          UseEntry:LONGINT; {used by project management}
  18640.                          NextEntry:POINTER;
  18641.                    END;
  18642.  
  18643. PROCEDURE AddSCUData(Data:PSCUFileFormat);
  18644. BEGIN
  18645.      Data^.NextEntry:=SCUPointer;
  18646.      SCUPointer:=Data;
  18647. END;
  18648.  
  18649. VAR ArgStart:POINTER;
  18650.     EnvStart:POINTER;
  18651.  
  18652. CONST
  18653.     C10:LONGWORD=10;
  18654.     FPUControl:WORD=$133f;
  18655.     FPURound:WORD=$1f3f;
  18656.     Exponent:WORD=0;
  18657.     fl1:ARRAY[0..3] OF BYTE=(0,$42,$c0,$ff);
  18658.     fl2:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$fe,$3f); //0.7853...
  18659.     fl3:ARRAY[0..9] OF BYTE=($35,$c2,$68,$21,$a2,$da,$0f,$c9,$ff,$3f);
  18660.     fl4:ARRAY[0..3] OF BYTE=(0,$4a,$c0,$ff);
  18661.     fl5:ARRAY[0..3] OF BYTE=(0,0,0,$3f);
  18662.     fl6:ARRAY[0..9] OF BYTE=($85,$64,$de,$f9,$33,$f3,4,$b5,$ff,$3f);
  18663.     fl7:ARRAY[0..9] OF BYTE=($48,$7e,$2a,$92,$a2,$da,$0f,$c9,$ff,$3f); //PI/2
  18664.     fl8:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,$fe,$3f);  //0.5
  18665.     fl9:ARRAY[0..9] OF BYTE=(0,0,0,0,0,0,0,$80,0,$40);    //2.0
  18666.     fl10:ARRAY[0..9] OF BYTE=($83,$ab,$4b,$ac,$dd,$8d,$5d,$93,0,$40); //ln(10)
  18667.     fl11:ARRAY[0..9] OF BYTE=($7e,$c0,$68,$77,$0d,$18,$72,$b1,$fe,$3f); //ln(2)
  18668.  
  18669. PROCEDURE ExitAll;
  18670. BEGIN
  18671.      ExitProcess(ExitCode);
  18672. END;
  18673.  
  18674. IMPORTS
  18675. FUNCTION GetCommandLine:PChar;
  18676.                   APIENTRY;  'KERNEL32' name 'GetCommandLineA';
  18677. FUNCTION GetModuleHandle(CONST lpModuleName:CSTRING):LONGWORD;
  18678.                   APIENTRY;  'KERNEL32' name 'GetModuleHandleA';
  18679. END;
  18680.  
  18681. PROCEDURE SystemInit(HeapSize,TheStackSize:LONGWORD);
  18682. VAR ff:^FileRec;
  18683.     ESP:LONGWORD;
  18684. BEGIN
  18685.      ASM
  18686.         MOV $ESP,ESP
  18687.      END;
  18688.      StackSize:=TheStackSize;
  18689.      MinStack:=(ESP-StackSize)+16384;
  18690.      ExcptList:=NIL;
  18691.      ArgStart:=GetCommandLine;
  18692.      AppHandle:=GetModuleHandle(NIL);
  18693.      RedirectIn:=FALSE;
  18694.      RedirectOut:=FALSE;
  18695.      Redirect:=FALSE;
  18696.  
  18697.      ExitProc:=@ExitAll;
  18698.      ASM
  18699.         //Initialize FPU
  18700.         FINIT
  18701.         FCLEX
  18702.         FLDCW SYSTEM.FPUControl
  18703.         FWAIT
  18704.  
  18705.         //correct arguments
  18706.         //CALLN32 SYSTEM.!CorrectArgList
  18707.      END;
  18708.  
  18709.      FileBufSize:=32760;   {Standard file buffer size}
  18710.  
  18711.      ff:=@Input;
  18712.      ff^.Handle:=GetStdHandle(-10); {Handle to standard input}
  18713.      ff^.RecSize:=1;
  18714.      ff^.Name:='';
  18715.      ff^.EAS:=NIL;
  18716.      ff^.Flags:=$6666;
  18717.      ff^.Mode:=0;
  18718.      ff^.Buffer:=NIL;
  18719.      ff^.MaxCacheMem:=0;
  18720.      ff^.Offset:=0;
  18721.      ff^.LOffset:=0;
  18722.      ff^.Block:=0;
  18723.      ff^.LBlock:=0;
  18724.      ff^.Reserved1:=0;
  18725.      ff^.BufferBytes:=0;
  18726.  
  18727.      ff:=@Output;
  18728.      ff^.Handle:=GetStdHandle(-11); {Handle to standard output}
  18729.      ff^.RecSize:=1;
  18730.      ff^.Name:='';
  18731.      ff^.EAS:=NIL;
  18732.      ff^.Flags:=$6666;
  18733.      ff^.Mode:=0;
  18734.      ff^.Buffer:=NIL;
  18735.      ff^.MaxCacheMem:=0;
  18736.      ff^.Offset:=0;
  18737.      ff^.LOffset:=0;
  18738.      ff^.Block:=0;
  18739.      ff^.LBlock:=0;
  18740.      ff^.Reserved1:=0;
  18741.      ff^.BufferBytes:=0;
  18742.  
  18743.      HeapError:=StdHeapError;
  18744.      IF not CreateSystemHeap(HeapSize*1024) THEN RunError(218);
  18745.      OpenedFilesCount:=0;
  18746.      IOResult:=0;
  18747.      FileMode:=fmInOut;
  18748.      SeekMode:=0; {File begin}
  18749.      SetTrigMode(rad);
  18750.  
  18751.      ExcptMutex:=CreateMutex(NIL,FALSE,NIL);
  18752.      SetUnhandledExceptionFilter(@ExcptHandler);
  18753.  
  18754.      ScreenInOut.Create;
  18755. END;
  18756.  
  18757. PROCEDURE SystemEnd;
  18758. BEGIN
  18759.      Halt(0);
  18760. END;
  18761.  
  18762. {$D+}
  18763. BEGIN
  18764. END.
  18765.  
  18766. {$ENDIF}
  18767.