home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 15 / CD_ASCQ_15_070894.iso / vrac / sk210f.zip / SHERRMSG.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-11  |  10KB  |  332 lines
  1. {$I SHDEFINE.INC}
  2.  
  3. {$I SHUNITSW.INC}
  4. {$O-}
  5.  
  6. {$D-,L-}
  7. {$V-}
  8. unit  ShErrMsg;
  9. {
  10.                                 ShErrMsg
  11.  
  12.                          An Exit Procedure Unit
  13.  
  14.                                    by
  15.  
  16.                               Bill Madison
  17.  
  18.                    W. G. Madison and Associates, Ltd.
  19.                           13819 Shavano Downs
  20.                             P.O. Box 780956
  21.                        San Antonio, TX 78278-0956
  22.                              (512)492-2777
  23.                              CIS 73240,342
  24.                 Internet bill.madison@lchance.sat.tx.us
  25.  
  26.                 Copyright 1990, '94 Madison & Associates
  27.                           All Rights Reserved
  28.  
  29.         This file may  be used and distributed  only in accord-
  30.         ance with the provisions described on the title page of
  31.                   the accompanying documentation file
  32.                               SKYHAWK.DOC
  33. }
  34.  
  35. interface
  36.  
  37. const
  38.   Copyr = 'Copyright 1990, 1994 by W.G. Madison';
  39.  
  40. procedure CheckOn;
  41. procedure CheckOff;
  42. {These two procedures turn error checking on and off. If off, control
  43.  is passed directly to the TP exit procedure chain. The default state
  44.  is On.}
  45.  
  46. procedure RunErrorMsg(Code : integer; Msg : string);
  47. {This procedure simulates the effect of a runtime error, but unlike the
  48.  Tp RunError procedure, it uses the entire CODE instead of only the low
  49.  byte. Also unlike Tp RunError and system exit procedures, RunErrorMsg
  50.  reports the error address in normalized form (the offset is always <=
  51.  $F). If, however, a program using ShErrMsg is run from a batch file and
  52.  ErrorLevel is checked, only the low byte will be reported. This is a
  53.  restriction of DOS.}
  54.  
  55. procedure HaltMsg(Code : word; Msg : string); {This procedure simulates
  56.  the effect of the System.Halt procedure, but unlike System.Halt, it uses
  57.  the entire CODE instead of only the low byte. Also unlike Tp Halt and
  58.  system exit procedures, HaltMsg reports the error address in normalized
  59.  form (the offset is always <= $F). If, however, a program using ShErrMsg
  60.  is run from a batch file and ErrorLevel is checked, only the low byte
  61.  will be reported. This is a restriction of DOS.}
  62.  
  63. implementation
  64.  
  65. {The string W and the array of strings M together contain, in coded
  66.  form, all of the built-in runtime error messages. In the array M, an
  67.  "@" is a functional escape character. The byte value of the following
  68.  character is an index into string W. The runtime error message actually
  69.  displayed is constructed by locating the appropriate string in M,
  70.  displaying that string until an "@" is encountered, using the byte
  71.  value of the character following "@" as an index into W, and displaying
  72.  characters from W until a blank is encountered.
  73.  
  74.  While this may seem unnecessarily complex, it provides considerable
  75.  space saving in any programs using ShErrMsg.
  76.  
  77.  It also suggests that W and M be modified only with extreme caution.}
  78.  
  79.  
  80. const
  81.   W : string = 'Cannot '+
  82.                'Device '+
  83.                'Disk '+
  84.                'File '+
  85.                'Floating '+
  86.                'Invalid '+
  87.                'Overlay '+
  88.                'Unknown '+
  89.                'access '+
  90.                'been '+
  91.                'data '+
  92.                'drive '+
  93.                'error '+
  94.                'fault '+
  95.                'file '+
  96.                'files '+
  97.                'for '+
  98.                'format '+
  99.                'found '+
  100.                'has '+
  101.                'input '+
  102.                'memory '+
  103.                'not '+
  104.                'number '+
  105.                'open '+
  106.                'operation '+
  107.                'or '+
  108.                'overflow '+
  109.                'point '+
  110.                'read '+
  111.                'write ';
  112.  
  113. type
  114.   Mstring = string[41];
  115.  
  116. const
  117.   M : array[1..49] of Mstring =
  118.                 ('1 - @" DOS function @Ä',
  119.                  '2 - @ @ @s',
  120.                  '3 - Path @ @s',
  121.                  '4 - Too many @ò @b',
  122.                  '5 - @ @: denied',
  123.                  '6 - @" @] handle - Handle @y @A trashed',
  124.                  '7 - Memory control blocks destroyed',
  125.                  '8 - Insufficient @â',
  126.                  '9 - @" @â block address',
  127.                  '10 - @" environment',
  128.                  '11 - @" @l',
  129.                  '12 - @" @] @: code',
  130.                  '13 - @" @F',
  131.                  '14 - Unused (reserved)',
  132.                  '15 - @" @K @Ä',
  133.                  '16 - @ remove current directory',
  134.                  '17 - @ rename across drives',
  135.                  '18 - No more @b',
  136.                  '100 -  @ @╢ @Q',
  137.                  '101 - @ @╗ @Q - @ probably full',
  138.                  '102 - @ @ assigned',
  139.                  '103 - @ @ @ò',
  140.                  '104 - @ @ @ò @h @}',
  141.                  '105 - @ @ @ò @h output',
  142.                  '106 - @" numeric @l @í @}',
  143.                  '150 - @ @ @╗ protected',
  144.                  '151 - @2 unit',
  145.                  '152 - Drive @ ready',
  146.                  '153 - @2 command',
  147.                  '154 - CRC @Q @ @F',
  148.                  '155 - Bad @K request structure length',
  149.                  '156 - @ seek @Q',
  150.                  '157 - @2 media type',
  151.                  '158 - Sector @ @s',
  152.                  '159 - Printer out of paper',
  153.                  '160 - @ @╗ @W',
  154.                  '161 - @ @╢ @W',
  155.                  '162 - Hardware failure',
  156.                  '200 - Division by zero',
  157.                  '201 - Range check @Q',
  158.                  '202 - Stack @º @Q',
  159.                  '203 - Heap @º @Q',
  160.                  '204 - @" pointer @Ü',
  161.                  '205 - @ @░ @º',
  162.                  '206 - @ @░ underflow',
  163.                  '207 - @" floating @░ @Ü @T 80x87 stack @º',
  164.                  '208 - @* Manager @ installed',
  165.                  '209 - @* @] @╢ @Q',
  166.                  '210 - Object @ initialized');
  167.  
  168. procedure GetNext(var S1, S2  : string);
  169.   var
  170.     T1  : byte;
  171.   begin
  172.     while (S1[1] = ' ') and (Length(S1) > 0) do
  173.       Delete(S1,1,1);
  174.     T1 := Pos(' ',S1);
  175.     if (T1 = 0) then begin
  176.       S2 := S1;
  177.       S1 := '';
  178.       exit;
  179.       end;
  180.     S2 := Copy(S1,1,T1-1);
  181.     Delete(S1,1,T1);
  182.     end;
  183.  
  184. function DisplayMessages(Idx  : word) : string;
  185. {Given an error code "Idx", an error message will be returned. If
  186.  Idx is not recognized, an empty string will be returned.}
  187.   var
  188.     W1  : word;
  189.     IdxS: string[5];
  190.     T1  : byte;
  191.     Msg,
  192.     S1  : string;
  193.     Mx  : Mstring;
  194.   begin
  195.     W1 := 1;
  196.     str(Idx, IdxS);
  197.     IdxS := IdxS + ' ';
  198.     while (Pos(IdxS, M[W1]) <> 1) and (W1 < 49) do begin
  199.       inc(W1);
  200.       end;
  201.     if Pos(IdxS, M[W1]) <> 1 then begin
  202.       DisplayMessages := IdxS + ' Unknown error code';
  203.       exit;
  204.       end;
  205.     Msg := '';
  206.     Mx := M[W1];
  207.     repeat
  208.       GetNext(Mx, S1);
  209.       if S1 <> '' then
  210.         if S1[1] <> '@' then
  211.           Msg := Msg + S1 + ' '
  212.         else begin
  213.           T1 := byte(S1[2]);
  214.           repeat
  215.             Msg := Msg + W[T1];
  216.             inc(T1);
  217.             until W[T1-1] = ' ';
  218.           end;
  219.       until S1 = '';
  220.     DisplayMessages := Msg;
  221.     end; {DisplayMessages}
  222.  
  223. const
  224.   Check4Errors  : boolean = true;
  225.  
  226. procedure CheckOn;
  227.   begin
  228.     Check4Errors := true;
  229.     end;
  230.  
  231. procedure CheckOff;
  232.   begin
  233.     Check4Errors := false;
  234.     end;
  235.  
  236. var
  237.   UsrAddr,
  238.   ExitSave  : pointer;
  239.   UsrCode   : integer;
  240.   UsrMsg    : string[80];
  241.   W1, W2    : word;
  242.  
  243. procedure RunErrorMsg(Code : integer; Msg : string);
  244. {This procedure simulates the effect of a runtime error, but unlike the
  245.  Tp RunError procedure, it uses the entire CODE instead of only the low
  246.  byte.}
  247.   begin
  248.     Inline(
  249.       $36/$8B/$46/$02/       {ss: mov  ax, [bp+2]}
  250.       $A3/>w1/               {    mov  [>w1], ax}
  251.       $36/$8B/$46/$04/       {ss: mov  ax, [bp+4]}
  252.       $A3/>w2);              {    mov  [>w2], ax}
  253.  
  254.     UsrCode := Code;
  255.     UsrMsg  := Msg;
  256.     UsrAddr := ptr(W2, W1);
  257.     System.RunError(Code);
  258.     end;
  259.  
  260. procedure HaltMsg(Code : word; Msg : string);
  261. {This procedure simulates the effect of the System.Halt procedure, but
  262.  unlike System.Halt, it uses the entire CODE instead of only the low
  263.  byte.}
  264.   begin
  265.     UsrCode := Code;
  266.     UsrMsg := Msg;
  267.     System.Halt(Code);
  268.     end;
  269.  
  270. {$F+}
  271. procedure ShErr;
  272.   function HexW(W : Word) : string;
  273.     {-Return hex string for word}
  274.     const
  275.       Digits : array[0..$F] of Char = '0123456789ABCDEF';
  276.     begin
  277.       HexW[0] := #4;
  278.       HexW[1] := Digits[hi(W) shr 4];
  279.       HexW[2] := Digits[hi(W) and $F];
  280.       HexW[3] := Digits[lo(W) shr 4];
  281.       HexW[4] := Digits[lo(W) and $F];
  282.       end;
  283.   function HexPtr(P : Pointer) : string;
  284.     {-Return hex string for pointer}
  285.     var
  286.       LP  : LongInt;
  287.     begin
  288.       LP := (Seg(P^) shl 4) + Ofs(P^);
  289.       HexPtr := HexW(LP shr 4) + ':' + HexW(LP mod $10);
  290.       end;
  291.  
  292.   begin {ShErr}
  293.     ExitProc := ExitSave;
  294.  
  295.     {Process a normal termination, including Halt(0).}
  296.     if (ExitCode = 0) and (ErrorAddr = nil) then exit;
  297.  
  298.     {Process if error messages not desired.}
  299.     if not Check4Errors then exit;
  300.  
  301.     {Process for error messages.}
  302.     if ErrorAddr = nil then begin           {It was a HALT}
  303.       if UsrMsg = '' then    {Display message if there is one}
  304.         exit                 {otherwise, just exit}
  305.       else begin             
  306.         ExitCode := UsrCode;
  307.         WriteLn(^M^J'ErrorLevel ',UsrCode);
  308.         WriteLn('     ',UsrMsg);
  309.         exit;
  310.         end; {else}
  311.       end {if ErrorAddr = nil}
  312.     else if UsrMsg = '' then begin
  313.                                             {Runtime error}
  314.       WriteLn(^M^J^G'Runtime error '+DisplayMessages(ExitCode));
  315.       WriteLn('     Error at '+HexPtr(ErrorAddr));
  316.       end {if HexPtr(ErrorAddr) <> HexPtr(UsrAddr)}
  317.     else begin
  318.       WriteLn(^M^J^G'Runtime error ', UsrCode, ' at ', HexPtr(UsrAddr));
  319.       WriteLn('':5, UsrMsg);
  320.       end;
  321.     ErrorAddr := nil;
  322.     end; {ShErr}
  323. {$F-}
  324.  
  325. begin
  326.   ExitSave := ExitProc;
  327.   ExitProc := @ShErr;
  328.   UsrCode := 0;
  329.   UsrAddr := nil;
  330.   UsrMsg := '';
  331.   end.
  332.