(***************************************************************************

     $RCSfile: Errors.mod $
  Description: Error handling and reporting

   Created by: fjc (Frank Copeland)
    $Revision: 1.6 $
      $Author: fjc $
        $Date: 1994/08/08 16:24:53 $

  Copyright © 1994, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

***************************************************************************)

MODULE Errors;

(*
** $C= CaseChk       $I= IndexChk  $L+ LongAdr   $N- NilChk
** $P= PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
** $V= OvflChk       $Z= ZeroVars
*)

IMPORT SYS := SYSTEM, E := Exec, IU := IntuiUtil;

VAR
  Report * : PROCEDURE (msg1, msg2, msg3 : ARRAY OF CHAR);
  Traps : ARRAY 26 OF E.STRPTR;

CONST
  Line1 = "Oberon-A Error Handler";


(*------------------------------------*)
(*
** This will be changed in a future release to use Intuition.EasyRequest()
*)
PROCEDURE* DefaultReport (msg1, msg2, msg3 : ARRAY OF CHAR);

  VAR bodyText : ARRAY 3 OF E.APTR;

(* $D- disable copying of open arrays *)
BEGIN (* DefaultReport *)
  bodyText [0] := SYS.ADR (msg1);
  bodyText [1] := SYS.ADR (msg2);
  bodyText [2] := SYS.ADR (msg3);
  IU.MultiNotice (NIL, bodyText, 3);
END DefaultReport;


(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE Abort * (msg : ARRAY OF CHAR);

BEGIN (* Abort *)
  (*
  ** Report must be initialised, but it isn't worth an ASSERT, since we
  ** are exiting anyway.
  *)
  IF Report # NIL THEN Report (Line1, msg, "Program terminating ...") END;
  HALT (20)
END Abort;


(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE Assert * (condition : BOOLEAN; msg : ARRAY OF CHAR);

BEGIN (* Assert *)
  IF ~condition THEN Abort (msg) END
END Assert;


(*------------------------------------*)
(* $S- Stack checking OFF, otherwise this DOESN'T WORK *)
PROCEDURE* PutCh ();

BEGIN (* PutCh *)
  SYS.INLINE (16C0H)   (* MOVE.B D0,(A3)+ *)
END PutCh;
(* $S= Stack checking back on *)

(* $L- LongVars OFF, for efficiency *)

(*------------------------------------*)
PROCEDURE* ReportRC ();

  CONST RunTimeError = "Run-time error detected";

  VAR
   line3 : E.STRPTR; str : ARRAY 60 OF CHAR; strPtr : E.STRPTR;
   rc : LONGINT;

BEGIN (* ReportRC *)
  (*
  ** Report must be initialised, but it isn't worth an ASSERT, since we
  ** are exiting anyway.
  *)
  IF Report # NIL THEN
    rc := SYS.RC ();
    IF ((rc >= 102) & (rc <= 111)) OR ((rc >= 132) & (rc <= 147)) THEN
      IF rc <= 111 THEN
        line3 := Traps [rc - 102]
      ELSE
        line3 := Traps [rc - 122]
      END; (* ELSE *)
      Report (Line1, "Processor trap detected", line3^)
    ELSIF rc = 21 THEN
      Report (Line1, RunTimeError, "Failed to open mathffp.library")
    ELSIF rc = 22 THEN
      Report (Line1, RunTimeError, "Freeing unallocated memory")
    ELSIF rc = 23 THEN
      Report (Line1, RunTimeError, "Divide by zero")
    ELSIF rc = 30 THEN
      Report (Line1, RunTimeError, "String conversion: ~(2 <= base <= 16)")
    ELSIF rc = 99 THEN
      Report (Line1, RunTimeError, "Procedure or method not implemented")
    ELSIF rc = 100 THEN
      Report (Line1, RunTimeError, "Failed to open shared library")
    ELSIF rc > 20 THEN
      strPtr := SYS.ADR (str);
      E.base.OldRawDoFmtL ("Error code = %ld", rc, PutCh, strPtr);
      Report (Line1, "Abnormal program exit", str);
    END; (* ELSE *)
  END; (* IF *)
END ReportRC;


BEGIN (* Errors *)
  Report := DefaultReport;
  Traps [0]  := SYS.ADR ("Trap #2 : Bus Error");
  Traps [1]  := SYS.ADR ("Trap #3 : Address Error");
  Traps [2]  := SYS.ADR ("Trap #4 : Illegal Instruction");
  Traps [3]  := SYS.ADR ("Trap #5 : Divide by zero");
  Traps [4]  := SYS.ADR ("Trap #6 : CHK instruction");
  Traps [5]  := SYS.ADR ("Trap #7 : TRAPV instruction");
  Traps [6]  := SYS.ADR ("Trap #8 : Privilege violation");
  Traps [7]  := SYS.ADR ("Trap #9 : Trace bit trap");
  Traps [8]  := SYS.ADR ("Trap #10 : Line 1010 emulator");
  Traps [9]  := SYS.ADR ("Trap #11 : Line 1111 emulator");
  Traps [10] := SYS.ADR ("Trap #32 : Compiler index check failed");
  Traps [11] := SYS.ADR ("Trap #33 : Compiler type check failed");
  Traps [12] := SYS.ADR ("Trap #34 : Compiler NIL check failed");
  Traps [13] := SYS.ADR ("Trap #35 : Compiler case check failed");
  Traps [14] := SYS.ADR ("Trap #36 : RETURN missing in function");
  Traps [15] := SYS.ADR ("Trap #37 : Compiler stack check failed");
  Traps [16] := SYS.ADR ("Trap #38 : Unspecified user trap");
  Traps [17] := SYS.ADR ("Trap #39 : Unspecified user trap");
  Traps [18] := SYS.ADR ("Trap #40 : Unspecified user trap");
  Traps [19] := SYS.ADR ("Trap #41 : Unspecified user trap");
  Traps [20] := SYS.ADR ("Trap #42 : Unspecified user trap");
  Traps [21] := SYS.ADR ("Trap #43 : Unspecified user trap");
  Traps [22] := SYS.ADR ("Trap #44 : Unspecified user trap");
  Traps [23] := SYS.ADR ("Trap #45 : Unspecified user trap");
  Traps [24] := SYS.ADR ("Trap #46 : Unspecified user trap");
  Traps [25] := SYS.ADR ("Trap #47 : Unspecified user trap");
  SYS.SETCLEANUP (ReportRC);
END Errors.