Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SHDK_1.ZIP/SHERRMSG.PAS

Pascal/Delphi Source File | 1992-03-23 | 9.8 KB | 322 lines

{$V-}
unit  ShErrMsg;
{
                                ShErrMsg

                         An Exit Procedure Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342

                  Copyright 1991 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}

interface

procedure CheckOn;
procedure CheckOff;
{These two procedures turn error checking on and off. If off, control
 is passed directly to the TP exit procedure chain. The default state
 is On.}

procedure RunErrorMsg(Code : integer; Msg : string);
{This procedure simulates the effect of a runtime error, but unlike the
 Tp RunError procedure, it uses the entire CODE instead of only the low
 byte. Also unlike Tp RunError and system exit procedures, RunErrorMsg
 reports the error address in normalized form (the offset is always <=
 $F). If, however, a program using ShErrMsg is run from a batch file and
 ErrorLevel is checked, only the low byte will be reported. This is a
 restriction of DOS.}

procedure HaltMsg(Code : word; Msg : string); {This procedure simulates
 the effect of the System.Halt procedure, but unlike System.Halt, it uses
 the entire CODE instead of only the low byte. Also unlike Tp Halt and
 system exit procedures, HaltMsg reports the error address in normalized
 form (the offset is always <= $F). If, however, a program using ShErrMsg
 is run from a batch file and ErrorLevel is checked, only the low byte
 will be reported. This is a restriction of DOS.}

implementation

{The string W and the array of strings M together contain, in coded
 form, all of the built-in runtime error messages. In the array M, an
 "@" is a functional escape character. The byte value of the following
 character is an index into string W. The runtime error message actually
 displayed is constructed by locating the appropriate string in M,
 displaying that string until an "@" is encountered, using the byte
 value of the character following "@" as an index into W, and displaying
 characters from W until a blank is encountered.

 While this may seem unnecessarily complex, it provides considerable
 space saving in any programs using ShErrMsg.

 It also suggests that W and M be modified only with extreme caution.}


const
  W : string = 'Cannot '+
               'Device '+
               'Disk '+
               'File '+
               'Floating '+
               'Invalid '+
               'Overlay '+
               'Unknown '+
               'access '+
               'been '+
               'data '+
               'drive '+
               'error '+
               'fault '+
               'file '+
               'files '+
               'for '+
               'format '+
               'found '+
               'has '+
               'input '+
               'memory '+
               'not '+
               'number '+
               'open '+
               'operation '+
               'or '+
               'overflow '+
               'point '+
               'read '+
               'write ';

type
  Mstring = string[41];

const
  M : array[1..49] of Mstring =
                ('1 - @" DOS function @Ä',
                 '2 - @ @ @s',
                 '3 - Path @ @s',
                 '4 - Too many @ò @b',
                 '5 - @ @: denied',
                 '6 - @" @] handle - Handle @y @A trashed',
                 '7 - Memory control blocks destroyed',
                 '8 - Insufficient @â',
                 '9 - @" @â block address',
                 '10 - @" environment',
                 '11 - @" @l',
                 '12 - @" @] @: code',
                 '13 - @" @F',
                 '14 - Unused (reserved)',
                 '15 - @" @K @Ä',
                 '16 - @
 remove current directory',
                 '17 - @
 rename across drives',
                 '18 - No more @b',
                 '100 -  @ @╢ @Q',
                 '101 - @ @╗ @Q - @ probably full',
                 '102 - @ @ assigned',
                 '103 - @ @ @ò',
                 '104 - @ @ @ò @h @}',
                 '105 - @ @ @ò @h output',
                 '106 - @" numeric @l @í @}',
                 '150 - @ @ @╗ protected',
                 '151 - @2 unit',
                 '152 - Drive @ ready',
                 '153 - @2 command',
                 '154 - CRC @Q @ @F',
                 '155 - Bad @K request structure length',
                 '156 - @ seek @Q',
                 '157 - @2 media type',
                 '158 - Sector @ @s',
                 '159 - Printer out of paper',
                 '160 - @ @╗ @W',
                 '161 - @ @╢ @W',
                 '162 - Hardware failure',
                 '200 - Division by zero',
                 '201 - Range check @Q',
                 '202 - Stack @º @Q',
                 '203 - Heap @º @Q',
                 '204 - @" pointer @Ü',
                 '205 - @ @░ @º',
                 '206 - @ @░ underflow',
                 '207 - @" floating @░ @Ü @T 80x87 stack @º',
                 '208 - @* Manager @ installed',
                 '209 - @* @] @╢ @Q',
                 '210 - Object @ initialized');

procedure GetNext(var S1, S2  : string);
  var
    T1  : byte;
  begin
    while (S1[1] = ' ') and (Length(S1) > 0) do
      Delete(S1,1,1);
    T1 := Pos(' ',S1);
    if (T1 = 0) then begin
      S2 := S1;
      S1 := '';
      exit;
      end;
    S2 := Copy(S1,1,T1-1);
    Delete(S1,1,T1);
    end;

function DisplayMessages(Idx  : word) : string;
{Given an error code "Idx", an error message will be returned. If
 Idx is not recognized, an empty string will be returned.}
  var
    W1  : word;
    IdxS: string[5];
    T1  : byte;
    Msg,
    S1  : string;
    Mx  : Mstring;
  begin
    W1 := 1;
    str(Idx, IdxS);
    IdxS := IdxS + ' ';
    while (Pos(IdxS, M[W1]) <> 1) and (W1 < 49) do begin
      inc(W1);
      end;
    if Pos(IdxS, M[W1]) <> 1 then begin
      DisplayMessages := IdxS + ' Unknown error code';
      exit;
      end;
    Msg := '';
    Mx := M[W1];
    repeat
      GetNext(Mx, S1);
      if S1 <> '' then
        if S1[1] <> '@' then
          Msg := Msg + S1 + ' '
        else begin
          T1 := byte(S1[2]);
          repeat
            Msg := Msg + W[T1];
            inc(T1);
            until W[T1-1] = ' ';
          end;
      until S1 = '';
    DisplayMessages := Msg;
    end; {DisplayMessages}

const
  Check4Errors  : boolean = true;

procedure CheckOn;
  begin
    Check4Errors := true;
    end;

procedure CheckOff;
  begin
    Check4Errors := false;
    end;

var
  UsrAddr,
  ExitSave  : pointer;
  UsrCode   : integer;
  UsrMsg    : string[80];
  W1, W2    : word;

procedure RunErrorMsg(Code : integer; Msg : string);
{This procedure simulates the effect of a runtime error, but unlike the
 Tp RunError procedure, it uses the entire CODE instead of only the low
 byte.}
  begin
    Inline(
      $36/$8B/$46/$02/       {ss: mov  ax, [bp+2]}
      $A3/>w1/               {    mov  [>w1], ax}
      $36/$8B/$46/$04/       {ss: mov  ax, [bp+4]}
      $A3/>w2);              {    mov  [>w2], ax}

    UsrCode := Code;
    UsrMsg  := Msg;
    UsrAddr := ptr(W2, W1);
    System.RunError(Code);
    end;

procedure HaltMsg(Code : word; Msg : string);
{This procedure simulates the effect of the System.Halt procedure, but
 unlike System.Halt, it uses the entire CODE instead of only the low
 byte.}
  begin
    UsrCode := Code;
    UsrMsg := Msg;
    System.Halt(Code);
    end;

{$F+}
procedure ShErr;
  function HexW(W : Word) : string;
    {-Return hex string for word}
    const
      Digits : array[0..$F] of Char = '0123456789ABCDEF';
    begin
      HexW[0] := #4;
      HexW[1] := Digits[hi(W) shr 4];
      HexW[2] := Digits[hi(W) and $F];
      HexW[3] := Digits[lo(W) shr 4];
      HexW[4] := Digits[lo(W) and $F];
      end;
  function HexPtr(P : Pointer) : string;
    {-Return hex string for pointer}
    var
      LP  : LongInt;
    begin
      LP := (Seg(P^) shl 4) + Ofs(P^);
      HexPtr := HexW(LP shr 4) + ':' + HexW(LP mod $10);
      end;

  begin {ShErr}
    ExitProc := ExitSave;

    {Process a normal termination, including Halt(0).}
    if (ExitCode = 0) and (ErrorAddr = nil) then exit;

    {Process if error messages not desired.}
    if not Check4Errors then exit;

    {Process for error messages.}
    if ErrorAddr = nil then begin           {It was a HALT}
      if UsrMsg = '' then    {Display message if there is one}
        exit                 {otherwise, just exit}
      else begin
        ExitCode := UsrCode;
        WriteLn(^M^J'ErrorLevel ',UsrCode);
        WriteLn('     ',UsrMsg);
        exit;
        end; {else}
      end {if ErrorAddr = nil}
    else if UsrMsg = '' then begin
                                            {Runtime error}
      WriteLn(^M^J^G'Runtime error '+DisplayMessages(ExitCode));
      WriteLn('     Error at '+HexPtr(ErrorAddr));
      end {if HexPtr(ErrorAddr) <> HexPtr(UsrAddr)}
    else begin
      WriteLn(^M^J^G'Runtime error ', UsrCode, ' at ', HexPtr(UsrAddr));
      WriteLn('':5, UsrMsg);
      end;
    ErrorAddr := nil;
    end; {ShErr}
{$F-}

begin
  ExitSave := ExitProc;
  ExitProc := @ShErr;
  UsrCode := 0;
  UsrAddr := nil;
  UsrMsg := '';
  end.