(* Copyright (C) 1990, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* Last modified on Sat Jun 27 22:22:30 PDT 1992 by muller     *)
(*      modified on Thu Apr  9 09:50:51 PDT 1992 by kalsow     *)

UNSAFE MODULE RTMisc;

IMPORT RTHeap, RTProc, Unix, Usignal, Uprocess, Cstring, SmallIO;

(*-------------------------------- program startup/shutdown -----------------*)

REVEAL
  Exitor = BRANDED "RTMisc.Exitor" REF RECORD
              proc: PROCEDURE (n: INTEGER) RAISES ANY;
              next: Exitor;
           END;

VAR
  exitors: Exitor := NIL;

PROCEDURE RegisterExitor (p: PROCEDURE (n: INTEGER) RAISES ANY): Exitor =
  VAR e := NEW (Exitor, proc := p, next := exitors);
  BEGIN
    exitors := e;
    RETURN (e);
  END RegisterExitor;

PROCEDURE UnregisterExitor (e: Exitor) =
  BEGIN
    e.proc := NIL;
  END UnregisterExitor;

PROCEDURE InvokeExitors () =
  VAR tmp: Exitor;
  BEGIN
    (* run the registered "exit" routines *)
    WHILE exitors # NIL DO
      (* to ensure progress, remove an element from
         the list before invoking it *)
      tmp := exitors;
      exitors := exitors.next;
      IF (tmp.proc # NIL) THEN
        <*FATAL ANY*>
        BEGIN
          tmp.proc (-1);
        END;
      END;
    END;
  END InvokeExitors;

PROCEDURE Exit (n: INTEGER) =
  BEGIN
    InvokeExitors ();
    Unix.exit (n);
  END Exit;

(*------------------------------- byte copying ------------------------------*)

PROCEDURE Copy (src, dest: ADDRESS;  len: INTEGER) =
  BEGIN
    EVAL Cstring.memcpy (dest, src, len);
  END Copy;

PROCEDURE Zero (dest: ADDRESS;  len: INTEGER) =
  BEGIN
    EVAL Cstring.memset (dest, 0, len);
  END Zero;



(*------------------------------- rounded arithmetic ------------------------*)

PROCEDURE Align (a: ADDRESS; y: INTEGER): ADDRESS =
  BEGIN 
    RETURN LOOPHOLE (Upper (LOOPHOLE (a, INTEGER), y), ADDRESS);
  END Align;

PROCEDURE Upper (x, y: INTEGER): INTEGER =
  BEGIN
    RETURN ((x + y - 1) DIV y) * y;
  END Upper;



(*------------------------------- runtime error reporting -------------------*)

PROCEDURE FatalError (file: TEXT;  line: INTEGER;
                       msgA, msgB, msgC: TEXT := NIL) =
  BEGIN
    SmallIO.PutText (SmallIO.stderr, "\n\n***\n*** runtime error:\n***    ");
    IF (msgA # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgA) END;
    IF (msgB # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgB) END;
    IF (msgC # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgC) END;
    IF (file # NIL) THEN
      SmallIO.PutText (SmallIO.stderr, "\n***    file \"");
      SmallIO.PutText (SmallIO.stderr, file);
      SmallIO.PutText (SmallIO.stderr, "\", line ");
      SmallIO.PutInt  (SmallIO.stderr, line);
    END;
    SmallIO.PutText (SmallIO.stderr, "\n***\n\n");
    Crash ();
  END FatalError;

PROCEDURE FatalErrorI (msg: TEXT := NIL;  i: INTEGER) =
  BEGIN
    SmallIO.PutText (SmallIO.stderr, "\n\n***\n*** runtime error:\n***    ");
    SmallIO.PutText (SmallIO.stderr, msg);
    SmallIO.PutInt  (SmallIO.stderr, i);
    SmallIO.PutText (SmallIO.stderr, "\n***\n\n");
    Crash ();
  END FatalErrorI;

PROCEDURE FatalErrorPC (pc: INTEGER;  msgA, msgB, msgC: TEXT := NIL) =
  VAR proc: RTProc.Proc;  name: RTProc.Name;
  BEGIN
    SmallIO.PutText (SmallIO.stderr, "\n\n***\n*** runtime error:\n***    ");
    IF (msgA # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgA) END;
    IF (msgB # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgB) END;
    IF (msgC # NIL) THEN SmallIO.PutText (SmallIO.stderr, msgC) END;
    IF (pc # 0) THEN
      SmallIO.PutText  (SmallIO.stderr, "\n***    pc = ");
      SmallIO.PutHexa  (SmallIO.stderr, pc);
      RTProc.FromPC (LOOPHOLE (pc, ADDRESS), proc, name);
      IF (name # NIL) THEN
        SmallIO.PutText  (SmallIO.stderr, " = ");
        SmallIO.PutChars (SmallIO.stderr, name, Cstring.strlen (name));
        pc := pc - LOOPHOLE (proc, INTEGER);
        IF (pc # 0) THEN
          SmallIO.PutText  (SmallIO.stderr, " + ");
          SmallIO.PutHexa  (SmallIO.stderr, pc);
        END;
      END;
    END;
    SmallIO.PutText (SmallIO.stderr, "\n***\n\n");
    Crash ();
  END FatalErrorPC;

PROCEDURE Crash () =
  BEGIN
    SmallIO.Flush (SmallIO.stderr);

    (* run the registered "exit" routines *)
    InvokeExitors ();

    (* crash *)
    EVAL Usignal.kill (Uprocess.getpid (), Usignal.SIGQUIT);
    LOOP END; (* wait for the signal to arrive *)
  END Crash;

PROCEDURE AssertFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "ASSERT failed");
  END AssertFault;

PROCEDURE ReturnFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Function did not return a value");
  END ReturnFault;

PROCEDURE CaseFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Unhandled value in CASE statement");
  END CaseFault;

PROCEDURE TypecaseFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Unhandled type in TYPECASE statement");
  END TypecaseFault;

PROCEDURE RangeFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Value out of range");
  END RangeFault;

PROCEDURE SubscriptFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Subscript out of range");
  END SubscriptFault;

PROCEDURE NarrowFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "NARROW failed");
  END NarrowFault;

PROCEDURE NilFault (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "attempt to dereference NIL");
  END NilFault;

PROCEDURE RaisesFault (ex_name: TEXT) =
  BEGIN
    FatalError (NIL, 0, "Exception \"", ex_name, "\" not in RAISES list");
  END RaisesFault;

PROCEDURE HandlerFault (ex_name: TEXT) =
  BEGIN
    FatalError (NIL, 0, "Unhandled exception \"", ex_name, "\"");
  END HandlerFault;

PROCEDURE StackOverflow (file: TEXT;  line: INTEGER) =
  BEGIN
    FatalError (file, line, "Stack overflow");
  END StackOverflow;

BEGIN
  EVAL RTHeap.Allocate; (*an attempt to force the allocator to be initialized*)
END RTMisc.