(*
    Title:    Exceptions - Implementation
    LastEdit: "Tue Nov 13 09:09:20 1984"
    Author:   Trevor Morris
    Cambridge University Computer Laboratory
    
    NS32000/Panos version
*)

(* $T-, $R- *)

IMPLEMENTATION MODULE Exceptions;

(* all dumping stuff currently commented out *)                  
IMPORT (*M2Dump,*) SYSTEM, PanosMCI;
IMPORT CharCodes;

IMPORT Program, IO, Store;


MODULE Output;


IMPORT SYSTEM, IO, CharCodes;


EXPORT QUALIFIED Chars, Hex, Ch, NewLine;


PROCEDURE Chars(err: CARDINAL; chars: ARRAY OF CHAR);

  VAR i: CARDINAL;

  BEGIN
    i := 0;
    WHILE (i <= HIGH(chars)) AND (chars[i] # 0C) DO
      Ch(err, chars[i]);
      INC(i);
    END;
  END Chars;


PROCEDURE Hex(err: CARDINAL; card: CARDINAL);
  BEGIN
    HexInField(err, card, SYSTEM.BYTESPERWORD * 2);
  END Hex;


PROCEDURE HexInField(err: CARDINAL; card, field: CARDINAL);
  BEGIN
    IF (card DIV 16 > 0) OR (field > 1) THEN
      HexInField(err, card DIV 16, field - 1);
    END;
    IF card MOD 16 < 10 THEN
      Ch(err, CHAR(CARDINAL("0") + (card MOD 16)));
    ELSE Ch(err, CHAR(CARDINAL("A") + (card MOD 16) - 10));
    END;
  END HexInField;


PROCEDURE NewLine(err: CARDINAL);
  BEGIN
    Ch(err, CharCodes.NewLineCh);
  END NewLine;


PROCEDURE Ch(err: CARDINAL; ch: CHAR);
  BEGIN
    IO.XSWriteByte(err, CARDINAL(ch));
  END Ch;


END Output;


(* TYPEs useful for looking at stack frames and module table *)
TYPE
  FramePtr = POINTER TO Frame;
  Frame =
    RECORD
      framePtr:  FramePtr;
      savedPC:   SYSTEM.ADDRESS;
      savedMOD:  CARDINAL; (* lower 16 bits are contents of MOD register *)
    END;

  ModuleTablePtr = POINTER TO ModuleTableEntry;
  ModuleTableEntry =
    RECORD
      staticDataPtr: SYSTEM.ADDRESS;
      linkTablePtr:  SYSTEM.ADDRESS;
      codeBasePtr:   SYSTEM.ADDRESS;
      reserved:      SYSTEM.WORD;
    END;


CONST FP = 9; (* frame pointer *)


PROCEDURE Raise(ex: ARRAY OF CHAR; fp: FramePtr);
                                                 
  VAR err: CARDINAL;

  BEGIN
    err := IO.XErrorStream();
    Output.Chars(err, "Modula-2 exception - ");
    Output.Chars(err, ex);
    Output.NewLine(err);
    (*DoDump(err);*)
    Backtrace(err, fp);
    Program.Stop(0);                      
  END Raise;


PROCEDURE RAISE(ex: ARRAY OF CHAR);
  BEGIN
    Raise(ex, FramePtr(SYSTEM.REGISTER(FP)));
  END RAISE;


PROCEDURE RAISEC(code: StdException);

  VAR s: ARRAY [0..30] OF CHAR;

  BEGIN
    CASE code OF
      CaseIndexOutOfRange: s := "CASE index out of range"; |
      AssignmentOutOfRange: s := "Assigned value out of range"; |
      ArrayIndexOutOfRange: s := "Array index out of range"; |
      ReturnMissing: s := "missing RETURN in function"; |
      HaltFault: s := "HALT";
    END (* case *);
    Raise(s, FramePtr(SYSTEM.REGISTER(FP)));
  END RAISEC;

(* all dumping stuff currently commented out *)                                               
(*PROCEDURE DoDump(err: CARDINAL);

  VAR header: M2Dump.Header;
    stream: CARDINAL;
    code: INTEGER;
    written, stackBase: CARDINAL;
    info: Store.HeapInformation;

  PROCEDURE GetPC(): CARDINAL;
    VAR fp: FramePtr;
  BEGIN
    fp := FramePtr(SYSTEM.REGISTER(FP));
    RETURN CARDINAL(fp^.savedPC);
  END GetPC;

  PROCEDURE Check(code: INTEGER);
  BEGIN
    IF code < 0 THEN
      Output.Chars(err, "Dump failed");
      Output.NewLine(err);
      Program.Stop(code);
    END;
  END Check;

  BEGIN
    WITH header DO
      gfTablePtr := PanosMCI.GetGFTablePtr();
      lmTablePtr := PanosMCI.GetLMTablePtr();
      gfTableUpb := PanosMCI.GetGFTableUpb();

      Check(Store.GetStoreInformation(info));
      dataBase := info.Base;
      dataSize := info.Size;

      stackHwm := SYSTEM.ADDRESS(SYSTEM.CALLEXTFUNC("SYSTEM.SPHWM"));
      stackBase := SYSTEM.ADDRESS(SYSTEM.CALLEXTFUNC("SYSTEM.SPBASE"));
      stackSize := stackBase - stackHwm;

      (* save important registers *)
      gregs[4] := SYSTEM.REGISTER(4); gregs[5] := SYSTEM.REGISTER(5);
      gregs[6] := SYSTEM.REGISTER(6); gregs[7] := SYSTEM.REGISTER(7);
      fp := SYSTEM.REGISTER(FP);
      pc := GetPC();

      code := IO.FindOutput(M2Dump.FileName);
      Check(code);
      stream := code;

      Check(IO.SBlockWrite(written, stream,
        SYSTEM.TSIZE(M2Dump.Header), SYSTEM.ADR(header)));
      Check(IO.SBlockWrite(written, stream, dataSize, dataBase));
      Check(IO.SBlockWrite(written, stream, stackSize, stackHwm));

      Check(IO.CloseStream(stream));

      (* all ok, inform user *)
      Output.Chars(err, "program dumped");
      Output.NewLine(err);
    END;
  END DoDump;*)


PROCEDURE Backtrace(err: CARDINAL; fp: FramePtr);
  BEGIN
    Output.Chars(err, "Backtrace:"); Output.NewLine(err);
    WHILE (fp^.framePtr # FramePtr(0)) AND FindModule(err, fp) DO
      fp := fp^.framePtr;
    END;
    Output.Chars(err, "End of backtrace"); Output.NewLine(err);
  END Backtrace;


PROCEDURE FindModule(err: CARDINAL; fp: FramePtr): BOOLEAN;

  VAR mod: ModuleTablePtr;
    offset, i, upb: CARDINAL;
    lmt: PanosMCI.LMTablePtr;

  BEGIN
    mod := ModuleTablePtr(fp^.savedMOD MOD 10000H);
    offset := CARDINAL(fp^.savedPC - mod^.codeBasePtr);

    lmt := PanosMCI.GetLMTablePtr();
    upb := PanosMCI.GetGFTableUpb();
    i := 0;
    WHILE (i <= upb) AND (lmt^[i].moduledata^.codeBase # mod^.codeBasePtr) DO
      INC(i);
    END;

    IF i > upb THEN
      Output.Chars(err, " Failed to find module - stack corrupt?");
      Output.NewLine(err);
      RETURN FALSE;
    ELSE Output.Chars(err, " Offset ");
      Output.Hex(err, offset);
      Output.Chars(err, " in module '");
      Output.Chars(err, lmt^[i].name^);
      Output.Ch(err, "'");
      Output.NewLine(err);
      RETURN TRUE;
    END;
  END FindModule;


END Exceptions.