home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / dos.swg / 0050_Critical Error Handler.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-01-27  |  20.7 KB  |  620 lines
  1. {$I- $F+}
  2. UNIT Errtrp;
  3. INTERFACE
  4.  
  5. USES
  6. crt,
  7. dos;
  8.  
  9. CONST
  10. ScrSeg : WORD = $B800;
  11. FGNorm = lightgray;
  12. BGNorm = blue;
  13. FGErr = white;
  14. BGErr = red;
  15.  
  16. VAR
  17. SaveInt24 : POINTER;
  18. ErrorRetry : BOOLEAN;
  19. IOCode    : INTEGER;
  20. version   : INTEGER;
  21.  
  22. PROCEDURE DisplayError (ErrNo : INTEGER);
  23. PROCEDURE RuntimeError;
  24. PROCEDURE DisableErrorHandler;
  25. PROCEDURE ErrTrap (ErrNo : INTEGER);
  26.  
  27.  
  28. IMPLEMENTATION
  29.  
  30.  
  31. VAR
  32.   ExitSave : POINTER;
  33.   regs : REGISTERS;
  34.  
  35.  
  36. (**************************************************************************)
  37.  
  38. CONST
  39.  INT59ERROR  : INTEGER  = 0;
  40.  ERRORACTION : BYTE = 0;
  41.  ERRORTYPE   : BYTE = 0;
  42.  ERRORAREA   : BYTE = 0;
  43.  ERRORRESP   : BYTE = 0;
  44.  ERRORRESULT : INTEGER = 0;
  45.  
  46. TYPE
  47. errmsg         = ARRAY [0..89] OF STRING;
  48. ermsgPtr       = ^errmsg;
  49.  
  50. VAR
  51. Errs : ermsgPTR;
  52.  
  53. PROCEDURE HideCursor; Assembler;
  54. Asm
  55.   MOV   ax, $0100
  56.   MOV   cx, $2607
  57.   INT   $10
  58. END;
  59.  
  60. PROCEDURE ShowCursor; Assembler;
  61. Asm
  62.   MOV   ax, $0100
  63.   MOV   cx, $0506
  64.   INT   $10
  65. END;
  66.  
  67.  
  68. PROCEDURE box;
  69. VAR
  70.  i : INTEGER;
  71. BEGIN
  72.   TEXTCOLOR (FGErr);
  73.   TEXTBACKGROUND (BGErr);
  74.   GOTOXY (1, 1);
  75.   WRITELN ('┌───────────────  Critical Error  ───────────────┐');
  76.     FOR i := 1 TO 5 DO
  77.   WRITELN ('│                                                │');
  78.   WRITE  ('└────────────────────────────────────────────────┘');
  79. END;{box}
  80.  
  81. FUNCTION DosVer : INTEGER;
  82. VAR
  83.  Maj : shortint;
  84.  Min : shortint;
  85.  regs : REGISTERS;
  86.  
  87. BEGIN
  88.  regs.ah := $30;
  89.  MSDOS (Regs);
  90.  Maj := regs.al;
  91.  Min := regs.ah;
  92.  DosVer := Maj;
  93. END;
  94.  
  95. PROCEDURE InitErrs;
  96. BEGIN
  97. NEW (Errs);
  98. Errs^ [0] :=   '             No error occured           ';
  99. Errs^ [1] :=    '          Invalid function number       ';
  100. Errs^ [2] :=    '              File not found            ';
  101. Errs^ [3] :=    '              Path not found            ';
  102. Errs^ [4] :=    '            No handle available         ';
  103. Errs^ [5] :=    '              Access denied             ';
  104. Errs^ [6] :=    '             Invalid handle             ';
  105. Errs^ [7] :=    '     Memory control blocks destroyed    ';
  106. Errs^ [8] :=    '           Insufficient memory          ';
  107. Errs^ [9] :=    '      Invalid memory block address      ';
  108. Errs^ [10] :=    '       Invalid SET command string       ';
  109. Errs^ [11] :=    '             Invalid format             ';
  110. Errs^ [12] :=    '          Invalid access code           ';
  111. Errs^ [13] :=    '              Invalid data              ';
  112. Errs^ [14] :=    '                Reserved                ';
  113. Errs^ [15] :=    '       Invalid drive specification      ';
  114. Errs^ [16] :=    '   Attempt to remove current directory  ';
  115. Errs^ [17] :=    '             Not same device            ';
  116. Errs^ [18] :=    '        No more files to be found       ';
  117. Errs^ [19] :=    '          Disk write protected          ';
  118. Errs^ [20] :=    '            Unknown unit ID             ';
  119. Errs^ [21] :=    '          Disk drive not ready          ';
  120. Errs^ [22] :=    '          Command not defined           ';
  121. Errs^ [23] :=    '            Disk data error             ';
  122. Errs^ [24] :=    '      Bad request structure length      ';
  123. Errs^ [25] :=    '             Disk seek error            ';
  124. Errs^ [26] :=    '         Unknown disk media type        ';
  125. Errs^ [27] :=    '          Disk sector not found         ';
  126. Errs^ [28] :=    '          Printer out of paper          ';
  127. Errs^ [29] :=    '      Write error - Printer Error?      ';
  128. Errs^ [30] :=    '               Read error               ';
  129. Errs^ [31] :=    '            General failure             ';
  130. Errs^ [32] :=    '         File sharing violation         ';
  131. Errs^ [33] :=    '         File locking violation         ';
  132. Errs^ [34] :=    '          Improper disk change          ';
  133. Errs^ [35] :=    '             No FCB available           ';
  134. Errs^ [36] :=    '         Sharing buffer overflow        ';
  135. Errs^ [37] :=    '                Reserved                ';
  136. Errs^ [38] :=    '                Reserved                ';
  137. Errs^ [39] :=    '                Reserved                ';
  138. Errs^ [40] :=    '                Reserved                ';
  139. Errs^ [41] :=    '                Reserved                ';
  140. Errs^ [42] :=    '                Reserved                ';
  141. Errs^ [43] :=    '                Reserved                ';
  142. Errs^ [44] :=    '                Reserved                ';
  143. Errs^ [45] :=    '                Reserved                ';
  144. Errs^ [46] :=    '                Reserved                ';
  145. Errs^ [47] :=    '                Reserved                ';
  146. Errs^ [48] :=    '                Reserved                ';
  147. Errs^ [49] :=    '                Reserved                ';
  148. Errs^ [50] :=    '      Network request not supported     ';
  149. Errs^ [51] :=    '      Remote computer not listening     ';
  150. Errs^ [52] :=    '        Duplicate name on network       ';
  151. Errs^ [53] :=    '         Network name not found         ';
  152. Errs^ [54] :=    '             Network busy               ';
  153. Errs^ [55] :=    '      Network device no longer exists   ';
  154. Errs^ [56] :=    '      NetBIOS command limit exceeded    ';
  155. Errs^ [57] :=    '      Network adapter hardware error    ';
  156. Errs^ [58] :=    '      Incorrect response from network   ';
  157. Errs^ [59] :=    '        Unexpected network error        ';
  158. Errs^ [60] :=    '      Incompatible remote adapter       ';
  159. Errs^ [61] :=    '            Print queue full            ';
  160. Errs^ [62] :=    '      Not enough space for print file   ';
  161. Errs^ [63] :=    '         Print file was deleted         ';
  162. Errs^ [64] :=    '        Network name was deleted        ';
  163. Errs^ [65] :=    '             Access denied              ';
  164. Errs^ [66] :=    '       Network device type incorrect    ';
  165. Errs^ [67] :=    '          Network name not found        ';
  166. Errs^ [68] :=    '        Network name limit exceeded     ';
  167. Errs^ [69] :=    '      NetBIOS session limit exceeded    ';
  168. Errs^ [70] :=    '           Temporarily paused           ';
  169. Errs^ [71] :=    '       Network request not accepted     ';
  170. Errs^ [72] :=    '  Print or disk re-direction is paused  ';
  171. Errs^ [73] :=    '                Reserved                ';
  172. Errs^ [74] :=    '                Reserved                ';
  173. Errs^ [75] :=    '                Reserved                ';
  174. Errs^ [76] :=    '                Reserved                ';
  175. Errs^ [77] :=    '                Reserved                ';
  176. Errs^ [78] :=    '                Reserved                ';
  177. Errs^ [79] :=    '                Reserved                ';
  178. Errs^ [80] :=    '           File already exists          ';
  179. Errs^ [81] :=    '                Reserved                ';
  180. Errs^ [82] :=    '              Cannot make               ';
  181. Errs^ [83] :=    '     Critical-error interrupt failure   ';
  182. Errs^ [84] :=    '          Too many redirections         ';
  183. Errs^ [85] :=    '          Duplicate redirection         ';
  184. Errs^ [86] :=    '           Duplicate password           ';
  185. Errs^ [87] :=    '            Invalid parameter           ';
  186. Errs^ [88] :=    '            Network data fault          ';
  187. Errs^ [89] :=    '             Undefined Error            ';
  188. END;
  189.  
  190. PROCEDURE CritError (Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP : WORD);
  191.  INTERRUPT;
  192. TYPE
  193. ScrPtr         = ^ScrBuff;
  194. ScrBuff        = ARRAY [1..4096] OF BYTE;
  195.  
  196. VAR
  197.   Display,
  198.   SaveScr    : ScrPtr;
  199.  
  200.   c         : CHAR;
  201.   ErrorPrompt,
  202.   msg        : STRING;
  203.   ErrNum     : BYTE;
  204.  
  205.   drive,
  206.   area,
  207.   al, ah      : BYTE;
  208.  
  209.   deviceattr : ^WORD;
  210.   devicename : ^CHAR;
  211.   ch,
  212.   i          : shortint;
  213.   actmsg,
  214.   tmsg,
  215.   amsg,
  216.   dname      : STRING;
  217. BEGIN
  218.     ah := HI (ax);
  219.     al := LO (ax);                            { in case DOS version < 3     }
  220.     ErrNum := LO (DI) + 19;                     { save the error and add      }
  221.     msg := Errs^ [ErrNum];                    { add 19 to convert to        }
  222.                                            { standard DOS error          }
  223.     tmsg := '';
  224.     actmsg := '';                            { we can't suggest a response }
  225.  
  226.  IF (ah AND $80) = 0 THEN                    { if a disk error then        }
  227.    BEGIN                                   { get the drive and area      }
  228.      amsg := ' drive ' + CHR (al + 65) + ':';
  229.      area := (ah AND 6) SHR 1;
  230.      CASE area OF
  231.      0 : amsg := amsg + ' dos communications area ';
  232.      1 : amsg := amsg + ' disk directory area ';
  233.      2 : amsg := amsg + ' files area ';
  234.      END;
  235.    END
  236. ELSE                                       { else if a device error }
  237.    BEGIN                                   { get type of device     }
  238.      deviceattr := PTR (bp, si + 4);
  239.      i := 0;
  240.      IF (deviceattr^ AND $8000) <> 0 THEN     { if a character device }
  241.        BEGIN                                { like a printer        }
  242.          amsg := 'character device';
  243.          ch := 0;
  244.          REPEAT
  245.          i := i + 1;
  246.          devicename := PTR (bp, si + $0a + ch);      { get the device name  }
  247.          dname [i] := devicename^;
  248.          dname [0] := CHR (i);
  249.          INC (ch);
  250.          UNTIL (devicename^ = CHR (0) ) OR (ch > 7);
  251.        END
  252.     ELSE                                     { else }
  253.       BEGIN                                  { just inform of the error }
  254.         dname := 'disk in ' + CHR (al) + ':';
  255.         msg := ' general failure ' ;
  256.         END;
  257.      amsg := amsg + ' ' + dname;
  258.      END;
  259.  
  260.  INLINE ($FA);                           { Enable interrupts       }
  261.  Display := PTR (ScrSeg, $0000);            { save the current screen }
  262.  NEW (SaveScr);
  263.  SaveScr^ := Display^;
  264.  WINDOW (15, 10, 65, 16);                   { make a box to display the}
  265.  TEXTCOLOR (FGErr);                      { error message            }
  266.  TEXTBACKGROUND (BGErr);
  267.  CLRSCR;
  268.  box;
  269.  
  270.   IF Version >= 3 THEN                     { check the DOS version   }
  271.   BEGIN                                  { major component         }
  272.   regs.ah := $59;                          { and use DosExtErr since }
  273.   regs.bx := $00;                          { it is available         }
  274.   MSDOS (Regs);
  275.   INT59ERROR := regs.ax;
  276.   ERRORTYPE := regs.bh;
  277.   ERRORACTION := regs.bl;
  278.   ERRORAREA := regs.ch;
  279.   msg := Errs^ [INT59ERROR];                { get the error information}
  280. (*
  281.   case ERRORAREA of
  282.   1: amsg:='Unknown';
  283.   2: amsg:='Block Device';               { usually disk access error}
  284.   3: amsg:='Network Problem';
  285.   4: amsg:='Serial Device';              { printer or COM problem   }
  286.   5: amsg:='Memory';                     { corrupted memory         }
  287.   end;
  288. *)
  289.   CASE ERRORTYPE OF
  290.   1 : tmsg := 'Out of Resource';            { no channels, space       }
  291.   2 : tmsg := 'Temporary situation';        { file locked for instance;}
  292.                                           { not an error and will    }
  293.                                           { clear eventually         }
  294.   3 : tmsg := 'Authorization Violation';     { permission problem e.g.  }
  295.                                           { write to read only file  }
  296.   4 : tmsg := 'Internal Software Error';     { system software bug      }
  297.   5 : tmsg := 'Hardware Error';              { serious trouble -- fix   }
  298.                                           { the machine              }
  299.   6 : tmsg := 'System Error';                { serious trouble software }
  300.                                           { at fault -- e.g. missing }
  301.                                           { CONFIG file              }
  302.   7 : tmsg := 'Program Error';               { inconsistent request     }
  303.                                           { from your program        }
  304.   8 : tmsg := 'Not found';                   { as stated                }
  305.   9 : tmsg := 'Bad Format';                  { as stated                }
  306.   10 : tmsg := 'Locked';                      { interlock situation      }
  307.   11 : tmsg := 'Media Error';                 { CRC error, wrong disk in }
  308.                                           { drive, bad disk cluster  }
  309.   12 : tmsg := 'Exists';                      { collision with existing  }
  310.                                           { item, e.g. duplicate     }
  311.                                           { device name              }
  312.   13 : tmsg := 'Unknown Error';
  313.   END;
  314.  
  315.   CASE ERRORACTION OF
  316.   1 : actmsg := 'Retry';                     { retry a few times then   }
  317.                                           { give user abort option   }
  318.                                           { if not fixed             }
  319.   2 : actmsg := 'Delay Retry';               { pause, retry, then give  }
  320.                                           { user abort option        }
  321.   3 : actmsg := 'User Action';               { ask user to reenter item }
  322.                                           { e.g. bad drive letter or }
  323.                                           { filename used            }
  324.   4 : actmsg := 'Abort';                      { invoke an orderly shut   }
  325.                                           { down -- close files, etc }
  326.   5 : actmsg := 'Immediate Exit';             { don't clean up, you may  }
  327.                                           { really screw something up}
  328.   6 : actmsg := 'Ignore';
  329.   7 : actmsg := 'Retry';                     { after user intervention: }
  330.   END;                                    { let the user fix it first}
  331.  
  332.   END;
  333. amsg := tmsg + amsg;
  334. actmsg := 'Suggested Action: ' + actmsg;
  335.  
  336. GOTOXY ( (54 - LENGTH (msg) ) DIV 2, 3);
  337. WRITE (msg);
  338.  
  339. GOTOXY ( (54 - LENGTH (amsg) ) DIV 2, 4);
  340. WRITE (amsg);
  341.  
  342. GOTOXY ( (54 - LENGTH (actmsg) ) DIV 2, 6);
  343. WRITE (actmsg);
  344.                                           { display it              }
  345.  
  346. ErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';
  347. GOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);
  348. WRITE (ErrorPrompt);
  349. REPEAT                                     { get the user response  }
  350. c := READKEY;
  351. c := UPCASE (c);
  352. UNTIL c IN ['A', 'R', 'I', 'F'];
  353. WINDOW (1, 1, 80, 25);                         { restore the screen     }
  354. TEXTCOLOR (FGNorm);
  355. TEXTBACKGROUND (BGNorm);
  356. Display^ := SaveScr^;
  357. DISPOSE (SaveScr);
  358. CASE c OF
  359.   'I' : BEGIN
  360.         AX := 0;
  361.         ERRORRETRY := FALSE;
  362.       END;
  363.   'R' : BEGIN
  364.         AX := 1;
  365.         ERRORRETRY := TRUE;
  366.       END;
  367.   'A' : BEGIN
  368.         Ax := 2;
  369.         ERRORRETRY := FALSE;
  370.         Showcursor;
  371.       END;
  372.   'F' : BEGIN
  373.         Ax := 3;
  374.         ERRORRETRY := FALSE;
  375.         Showcursor;
  376.       END;
  377. END;
  378.  
  379. END;{procedure CritError}
  380.  
  381. (**************************************************************************)
  382. PROCEDURE DisplayError (ErrNo : INTEGER);
  383. VAR
  384. msg,
  385. exitmsg : STRING;
  386. BEGIN
  387.     CASE ErrNo OF
  388.     2 : exitmsg := 'File not found';
  389.     3 : exitmsg := 'Path not found';
  390.     4 : exitmsg := 'Too many open files';
  391.     5 : exitmsg := 'Access denied';
  392.     6 : exitmsg := 'Invalid file handle';
  393.     12 : exitmsg := 'Invalid file access code';
  394.     15 : exitmsg := 'Invalid drive';
  395.     16 : exitmsg := 'Cannot remove current directory';
  396.     17 : exitmsg := 'Cannot rename across drives';
  397.     100 : exitmsg := 'Disk read error';
  398.     101 : exitmsg := 'Disk write error - Disk Full ?';
  399.     102 : exitmsg := 'File not assigned';
  400.     103 : exitmsg := 'File not opened';
  401.     104 : exitmsg := 'File not open for input';
  402.     105 : exitmsg := 'File not open for output';
  403.     106 : exitmsg := 'Invalid numeric format';
  404.     150 : exitmsg := 'Disk is write protected';
  405.     151 : exitmsg := 'Unknown unit';
  406.     152 : exitmsg := 'Drive not ready';
  407.     153 : exitmsg := 'Unkown command';
  408.     154 : exitmsg := 'CRC error in data';
  409.     155 : exitmsg := 'Bad drive request structure length';
  410.     156 : exitmsg := 'Disk seek error';
  411.     157 : exitmsg := 'Unknown media type';
  412.     158 : exitmsg := 'Sector not found';
  413.     159 : exitmsg := 'Printer out of paper';
  414.     160 : exitmsg := 'Device write fault';
  415.     161 : exitmsg := 'Device read fault';
  416.     162 : exitmsg := 'Hardware failure';
  417.     200 : exitmsg := 'Division by zero';
  418.     201 : exitmsg := 'Range check error';
  419.     202 : exitmsg := 'Stack overflow';
  420.     203 : exitmsg := 'Heap overflow';
  421.     204 : exitmsg := 'Invalid pointer operation';
  422.     205 : exitmsg := 'Floating point overflow';
  423.     206 : exitmsg := 'Floating point underflow';
  424.     207 : exitmsg := 'Invalid floating point operation'
  425.     ELSE exitmsg := 'Unknown Error # ';
  426.     END;
  427.  
  428.   msg := exitmsg;
  429.  
  430.   TEXTCOLOR (FGErr);
  431.   TEXTBACKGROUND (BGErr);
  432.   GOTOXY ( (50 - LENGTH (msg) ) DIV 2, 3);
  433.   WRITE (msg);
  434.  
  435. END;
  436.  
  437. PROCEDURE ErrTrap (ErrNo : INTEGER);
  438. TYPE
  439. ScrPtr         = ^ScrBuff;
  440. ScrBuff        = ARRAY [1..4096] OF BYTE;
  441.  
  442. VAR
  443.   Display,
  444.   SaveScr    : ScrPtr;
  445.  
  446.   c         : CHAR;
  447.   ErrorPrompt,
  448.   msg : STRING;
  449.  
  450. BEGIN
  451.  
  452.  Display := PTR (ScrSeg, $0000);            { save the current screen }
  453.  NEW (SaveScr);
  454.  SaveScr^ := Display^;
  455.  WINDOW (15, 10, 65, 16);                   { make a box to display the}
  456.  TEXTCOLOR (FGErr);                      { error message            }
  457.  TEXTBACKGROUND (BGErr);
  458.  CLRSCR;
  459.  box;
  460.  
  461.   ErrorRetry := TRUE;
  462.   DisplayError (ErrNo);
  463.  
  464.                                           { display it              }
  465.  
  466. ErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';
  467. GOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);
  468. WRITE (ErrorPrompt);
  469. REPEAT                                     { get the user response  }
  470. c := READKEY;
  471. c := UPCASE (c);
  472. UNTIL c IN ['A', 'R', 'I', 'F'];
  473. CASE c OF
  474.   'I' : ErrorRetry := FALSE;
  475.   'R' : ErrorRetry := TRUE;
  476.   'A' : BEGIN
  477.         ErrorRetry := FALSE;
  478.         Showcursor;
  479.       END;
  480.   'F' : BEGIN
  481.         ErrorRetry := FALSE;
  482.         Showcursor;
  483.       END;
  484.   END;
  485.   IF ErrorRetry = FALSE THEN
  486.     BEGIN
  487.       GOTOXY (4, 4);
  488.       WRITE ('If you are unable to correct the error');
  489.       GOTOXY (4, 5);
  490.       WRITE ('please report the error ', #40, Errno, #41, ' and      ');
  491.       GOTOXY (4, 6);
  492.       WRITE ('exact circumstances when it occurred to us.');
  493.       WINDOW (1, 1, 80, 25);                         { restore the screen     }
  494.       TEXTCOLOR (FGNorm);
  495.       TEXTBACKGROUND (BGNorm);
  496.       Display^ := SaveScr^;
  497.       DISPOSE (SaveScr);
  498.  
  499.       ErrorAddr := NIL;
  500.       GOTOXY (1, 1);
  501.       Showcursor;
  502.       HALT;
  503.     END;
  504. WINDOW (1, 1, 80, 25);                         { restore the screen     }
  505. TEXTCOLOR (FGNorm);
  506. TEXTBACKGROUND (BGNorm);
  507. Display^ := SaveScr^;
  508. DISPOSE (SaveScr);
  509. END;
  510.  
  511. PROCEDURE RuntimeError;
  512.  
  513. TYPE
  514. ScrPtr         = ^ScrBuff;
  515. ScrBuff        = ARRAY [1..4096] OF BYTE;
  516.  
  517. VAR
  518.   Display,
  519.   SaveScr    : ScrPtr;
  520.  
  521.   c         : CHAR;
  522.   ErrorPrompt,
  523.   msg : STRING;
  524.  
  525. BEGIN
  526.   IF ErrorAddr <> NIL THEN
  527.     BEGIN
  528.       Display := PTR (ScrSeg, $0000);            { save the current screen }
  529.       NEW (SaveScr);
  530.       SaveScr^ := Display^;
  531.       WINDOW (15, 10, 65, 16);                   { make a box to display the}
  532.       TEXTCOLOR (FGErr);                      { error message            }
  533.       TEXTBACKGROUND (BGErr);
  534.       CLRSCR;
  535.       box;
  536.       GOTOXY (15, 1);
  537.       WRITE ('   Fatal  Error   ');
  538.       DisplayError (ExitCode);
  539.       GOTOXY (20, 2);
  540.       WRITE ('Run time error ', ExitCode);
  541.       GOTOXY (4, 4);
  542.       WRITE ('If you are unable to correct the error');
  543.       GOTOXY (4, 5);
  544.       WRITE ('Please report the error and exact');
  545.       GOTOXY (4, 6);
  546.       WRITE ('circumstances when it occurred to us.');
  547.       GOTOXY (4, 7);
  548.       WRITE ( ' Press a key to continue ');
  549.       ErrorAddr := NIL;
  550.  
  551.       ExitProc := ExitSave;
  552.       c := READKEY;
  553.     END;
  554.   WINDOW (1, 1, 80, 25);                         { restore the screen     }
  555.   TEXTCOLOR (FGNorm);
  556.   TEXTBACKGROUND (BGNorm);
  557.   Display^ := SaveScr^;
  558.   DISPOSE (SaveScr);
  559.  
  560.   ShowCursor;
  561.   TEXTCOLOR (lightgray);
  562.   TEXTBACKGROUND (black);
  563.  
  564.   SETINTVEC ($24, SaveInt24);
  565. END;
  566.  
  567. PROCEDURE DisableErrorHandler;
  568. BEGIN
  569.   SETINTVEC ($24, SaveInt24);
  570.   ExitProc := ExitSave;
  571. END;
  572.  
  573. (**************************************************************************)
  574. BEGIN
  575.   InitErrs;
  576.   Version := DosVer;
  577.   Hidecursor;
  578.   IF mem [$0000 : $0449] <> 7 THEN ScrSeg := $B800 ELSE ScrSeg := $B000;
  579.   GETINTVEC ($24, SaveInt24);
  580.   SETINTVEC ($24, @CritError);
  581.   ExitSave := ExitProc;
  582.   ExitProc := @RuntimeError;
  583. END.
  584.  
  585. { ---------------------   DEMO PROGRAM -------------------------- }
  586.  
  587. {$I-}  { THIS MUST BE HERE FOR THE ERROR TRAP TO WORK !! }
  588. PROGRAM testerr;
  589. USES dos, crt, printer, errtrp;
  590. VAR
  591. regs : REGISTERS;
  592. fil : FILE;
  593. Pchar : STRING;
  594. BEGIN
  595. CLRSCR;
  596. (*COMMENT OUT THE FUNCTIONS NOT BEING TESTED*)
  597. (*       USING THE CRITICAL ERROR HANDLER PROCEDURE CRITERR  *)
  598.  
  599. (* remove disc from A: drive to test this *)
  600. (******************************************)
  601.  
  602. WRITE ('trying to write to drive a: ');
  603.  
  604.   ASSIGN (fil, 'A:filename.ext');
  605.   REWRITE (fil);
  606.  
  607. DisableErrorHandler;
  608.  
  609. (*  USING THE ERRTRAP PROCEDURE *)
  610.  
  611. WRITE ('trying to write to drive a: using ERRTRAP');
  612. REPEAT
  613. ASSIGN (fil, 'A:filename.ext');
  614. REWRITE (fil);
  615. iocode := IORESULT;
  616. IF IOCode <> 0 THEN ErrTrap (IOCode);
  617. UNTIL ERRORRETRY = FALSE;
  618.  
  619. END.
  620.