{$nomain}
{$nowalkback}
{[l-,r+,b+]}
PROGRAM error;

{ NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE:

  Copyright (C) 1984 Oregon Software, Inc.
  All Rights Reserved.

  This program is the property of Oregon Software.  The program or
  parts of it may be copied and used only as provided under a signed
  license agreement with Oregon Software.  Any support purchased from 
  Oregon Software does not apply to user-modified programs.  All copies 
  of this program must display this notice and all copyright notices. 
  
  
  Release version: 2.1D  Level: 1
  Processor: ~processor~
  System: ~system~

  Report runtime Pascal program errors

 Last modified by [2,44] on 17-Jul-1984 15:07:56
 Purpose:
UPDATE TO 2.1D

}

{
  This procedure is called by the Pascal support library to process
  run-time errors.
}

  TYPE
    error_type = (fatal, ioerror);

    %INCLUDE 'libdef';
    error_num = (blank, nomem, subscr, ovrflo, nfserr, divzer, numerr, sqrter,
                 experr, logerr, noblk, cntopn, blank1, blank2, filnam,
                 wrteof, toomny, filend, geterr, puterr, intovr, newof0,
                 ddeal, badint, badset, fpperr, seek0, notrnd, trap10, notopn,
                 badver, blank3, iotran, disnil, subrng, nilptr, caserr,
                 stovfl, notinp, notout, nodel, delerr, renerr, trap4,
                 fovrfl);

    text_pointer = ^text;
    error_block =
      RECORD
        error_number: error_num;
        class: error_type;
        xfile: text_pointer;
        io_status: integer;
        user_pc: word;
      END;


  PROCEDURE p$error(VAR err: error_block);

    EXTERNAL;


  PROCEDURE p$error;

    VAR
      f: user_file_variable;
      i: word;
      SysError:boolean; {indicates RT-11 error rather than suplib}
      Tstats: integer; {temporary I/O status }
{
  Print one word as 3 RAD50 characters, ignoring spaces
}


    PROCEDURE rad50(i: word);

      CONST
        rad = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.?0123456789';


      BEGIN
        IF i >= 40 THEN rad50(i DIV 40);
        IF (i MOD 40) <> 0 THEN write(rad[(i MOD 40) + 1]);
      END;

{
  Write out the name of a file
}


    PROCEDURE say_name(VAR f: user_file_variable);


      BEGIN
        WITH f^ DO
          BEGIN
          IF dev <> 0 THEN
            BEGIN
            rad50(dev);
            write(':');
            END;
          IF name1 <> 0 THEN
            BEGIN
            rad50(name1);
            rad50(name2);
            write('.');
            rad50(ext);
            END;
          END;
      END;


    BEGIN
      WITH err DO
        BEGIN
        writeln;
        write('PASCAL');
        write('--');
        IF class = fatal THEN write('Fatal');
        IF class = ioerror THEN write('I/O');
        writeln(' error at user PC= ', user_pc: - 1, 'B');
        CASE error_number OF
          nomem: writeln('Not enough memory');
          subscr: writeln('Array subscript out of bounds');
          ovrflo: writeln('Floating point overflow');
          nfserr: writeln('NFS access to file device');
          divzer: writeln('Division by zero');
          numerr: writeln('Floating point format error');
          sqrter: writeln('SQRT() of a negative number');
          experr: writeln('EXP() overflow');
          logerr: writeln('LOG() of zero or a negative number');
          noblk: writeln('Not enough memory for file buffer');
          cntopn: writeln('Can''t open file');
          filnam: writeln('File name syntax error');
          wrteof: writeln('Attempt to write past end of file');
          toomny: writeln('Too many files open ');
          filend: writeln('Attempt to read past end of file');
          geterr: writeln('Error reading file');
          puterr: writeln('Error writing file');
          intovr: writeln('TRUNC/ROUND overflow');
          newof0: writeln('NEW() of zero length');
          ddeal: writeln('Double deallocation of dynamic memory');
          badint: writeln('Illegal value for integer');
          badset: writeln('Set element out of range');
          fpperr: writeln('Floating point support error');
          seek0: writeln('SEEK() out of range');
          notrnd: writeln('File is not a random access file. Use /SEEK');
          trap10: writeln('Reserved instruction execution');
          notopn: writeln('File not open');
          badver: writeln('Compiler/library mismatch');
          iotran: writeln('I/O transfer error');
          nilptr: writeln('Attempted reference through NIL pointer');
          subrng: writeln('Variable subrange exceeded');
          disnil: writeln('DISPOSE() of a NIL pointer');
          stovfl: writeln('Stack overflow');
          caserr: writeln('CASE selector matches no label');
          notinp: writeln('File is not an input file');
          notout: writeln('File is not an output file');
          nodel: writeln('RENAME/DELETE of non-disk file');
          delerr: writeln('Can''t delete file');
          renerr: writeln('Can''t rename file');
          trap4: writeln('Odd address or nonexistent memory trap');
          fovrfl: writeln('Attempt to access block > 65535');
          OTHERWISE
            writeln('Unknown Pascal run-time error #', ord(error_number): 1)
          END;
        IF class = ioerror THEN
          BEGIN
          tstats := io_status and 377B; {mask high byte}
          syserror := (io_status and 300B) <> 0; {is sign bit on}
          write('I/O error code= ');
          if syserror then write('-');
	  write(io_status and 177B: 1);
          f := loophole(user_file_variable, xfile^);
          IF f <> NIL THEN
            BEGIN
            write(' in file: ');
            say_name(f);
            END
          ELSE write('Unknown file variable');
          writeln;
          END;
        END;
    END;
                                                                                                                                                                           