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

(* Last modified on Thu Mar  5 10:15:58 PST 1992 by kalsow     *)
(*      modified on Wed Mar  4 20:38:23 PST 1992 by muller     *)


UNSAFE MODULE RTException;

IMPORT RTMisc, Csetjmp, Thread, ThreadF, Text, SmallIO;

TYPE HC = HandlerClass;

VAR stack_grows_up: BOOLEAN := FALSE;

PROCEDURE Raise (en: ExceptionName;  arg: ExceptionArg) RAISES ANY =
  VAR
    i: CARDINAL;
    h := LOOPHOLE (ThreadF.currentHandlers, Handler);
    h1 : Handler;
  BEGIN
    IF (h = NIL) THEN NoHandler (en, raises := FALSE) END;
    LOOP
      (* check this handler *)
      CASE h.class OF
      | HC.Except => 
          i := 0;
          WHILE (h.handles [i] # NIL) DO
            IF (h.handles [i] = en) THEN RaiseForSure (en, arg) END;
            INC (i);
          END;
      | HC.ExceptElse =>
          RaiseForSure (en, arg);
      | HC.Raises =>
          (* check that this procedure does indeed raise 'en' *)
          i := 0;
          LOOP
            IF (h.handles[i] = NIL) THEN  NoHandler (en) END;
            IF (h.handles[i] = en)  THEN  (* ok, it passes *) EXIT  END;
            INC (i);
          END;
      | HC.RaisesNone =>
          NoHandler (en);
      | HC.Finally, HC.FinallyProc, HC.Lock => 
          (* ignore for this pass *)
      ELSE
          BadStack ();
      END;

      (* move to the next handler (in a paranoid way) *)
      h1 := h.next;
      IF (h1 = NIL) THEN NoHandler (en, raises := FALSE) END;
      IF (stack_grows_up)
        THEN IF (h1 >= h) THEN BadStack () END;
        ELSE IF (h1 <= h) THEN BadStack () END;
      END;
      h := h1;
    END;
  END Raise;

PROCEDURE RaiseForSure (en: ExceptionName;  arg: ExceptionArg) RAISES ANY =
  VAR
    h := LOOPHOLE (ThreadF.currentHandlers, Handler);
    i : CARDINAL;
    h1: Handler;
  BEGIN
    (* scan the handler stack *)
    IF (h = NIL) THEN BadStack () END;
    LOOP
      CASE h.class OF
      | HC.ExceptElse, HC.Finally =>
          ThreadF.currentHandlers := h.next;  (* cut to the new handler *)
          h.current := en;                    (* record the exception *)
          h.arg := arg;                       (* and its argument *)
          Csetjmp.ulongjmp (h.jmp_buf, 1);    (* and jump... *)
      | HC.Except =>
          i := 0;
          WHILE (h.handles[i] # NIL) DO
            IF (h.handles[i] = en) THEN
              (* we found the handler *)
              ThreadF.currentHandlers := h.next;  (* cut to the new handler *)
              h.current := en;                    (* record the exception *)
              h.arg := arg;                       (* and its argument *)
              Csetjmp.ulongjmp (h.jmp_buf, 1);    (* and jump... *)
            END;
            INC (i);
          END;
      | HC.Raises =>
          (* ignore *)
      | HC.RaisesNone =>
          BadStack ();
      | HC.FinallyProc =>
          ThreadF.currentHandlers := h.next;  (* cut to this handler *)
          VAR x := LOOPHOLE (h, FinallyProcHandler); BEGIN
            x.proc (x.frame);
          END;
      | HC.Lock => 
          ThreadF.currentHandlers := h.next;  (* cut to this handler *)
          VAR x := LOOPHOLE (h, LockHandler); BEGIN
            Thread.Release (x.mutex);
          END;
      ELSE
          BadStack ();
      END;
      h1 := h.next;
      IF (h1 = NIL) THEN BadStack () END;
      IF (stack_grows_up)
        THEN IF (h1 >= h) THEN BadStack () END;
        ELSE IF (h1 <= h) THEN BadStack () END;
      END;
      h := h1;
    END;
  END RaiseForSure;

PROCEDURE NoHandler (en: ExceptionName;  raises := TRUE) =
  BEGIN
    DumpStack ();
    IF (raises)
      THEN RTMisc.RaisesFault (EName (en));
      ELSE RTMisc.HandlerFault (EName (en));
    END;
  END NoHandler;

PROCEDURE SanityCheck () =
  <*FATAL ANY*>
  CONST Min_HC = ORD (FIRST (HC));
  CONST Max_HC = ORD (LAST (HC));
  VAR h := LOOPHOLE (ThreadF.currentHandlers, Handler);
  VAR h1 : Handler;
  VAR i: INTEGER;
  BEGIN
    WHILE (h # NIL) DO
      i := ORD (h.class);
      IF (i < Min_HC) OR (Max_HC < i) THEN BadStack () END;
      h1 := h.next;
      IF (h1 = NIL) THEN EXIT END;
      IF (stack_grows_up)
        THEN IF (h1 >= h) THEN BadStack () END;
        ELSE IF (h1 <= h) THEN BadStack () END;
      END;
      h := h1;
    END;
  END SanityCheck;

PROCEDURE BadStack () =
  BEGIN
    DumpStack ();
    RTMisc.FatalError (NIL, 0, "corrupt exception stack");
  END BadStack;

PROCEDURE DumpStack () =
  CONST BadLink = "*** BAD EXCEPTION STACK LINK ***\n";
  VAR h := LOOPHOLE (ThreadF.currentHandlers, Handler);  h1: Handler;
  BEGIN
    Txt ("****************** EXCEPTION HANDLER STACK *********************\n");
    WHILE (h # NIL) DO
      Addr (h);
      CASE h.class OF
      | HC.Except =>
          Txt  (" TRY-EXCEPT ");
          DumpHandles (h.handles);
      | HC.ExceptElse =>
          Txt  (" TRY-EXCEPT-ELSE ");
          DumpHandles (h.handles);
      | HC.Finally =>
          Txt  (" TRY-FINALLY ");
      | HC.Raises =>
          Txt  (" RAISES ");
          DumpHandles (h.handles);
      | HC.RaisesNone =>
          Txt  (" RAISES {}");
      | HC.FinallyProc =>
          VAR x := LOOPHOLE (h, FinallyProcHandler); BEGIN
            Txt  (" TRY-FINALLY  proc = ");
            Addr (LOOPHOLE (x.proc, ADDRESS));
            Txt  ("   frame = ");
            Addr (x.frame);
          END;
      | HC.Lock =>
          VAR x := LOOPHOLE (h, LockHandler); BEGIN
            Txt  (" LOCK  mutex = ");
            Addr (LOOPHOLE (x.mutex, ADDRESS));
          END;
      ELSE
         Txt (" *** BAD EXCEPTION RECORD, class = ");
         Int (ORD (h.class));
         Txt (" ***\n");
         EXIT;
      END;
      Txt ("\n");
      h1 := h.next;
      IF (h1 = NIL) THEN EXIT END;
      IF (stack_grows_up)
        THEN IF (h1 >= h) THEN  Txt (BadLink);  h1 := NIL  END;
        ELSE IF (h1 <= h) THEN  Txt (BadLink);  h1 := NIL  END;
      END;
      h := h1;
    END;
    Txt ("****************************************************************\n");
  END DumpStack;

PROCEDURE DumpHandles (x: UNTRACED REF ARRAY LOTS OF ExceptionName) =
  BEGIN
    Txt ("{");
    IF (x # NIL) THEN
      FOR i := FIRST (LOTS) TO LAST (LOTS) DO
        IF (x[i] = NIL) THEN EXIT END;
        IF (i # FIRST (LOTS)) THEN Txt (", ") END;
        Txt (EName (x[i]));
      END;
    END;
    Txt ("}");
  END DumpHandles;

PROCEDURE Txt (t: TEXT) =
  BEGIN
    SmallIO.PutText (SmallIO.stderr, t)
  END Txt;

PROCEDURE Int (i: INTEGER) =
  BEGIN
    SmallIO.PutInt (SmallIO.stderr, i)
  END Int;

PROCEDURE Addr (a: ADDRESS) =
  BEGIN
    SmallIO.PutHexa (SmallIO.stderr, LOOPHOLE (a, INTEGER))
  END Addr;

PROCEDURE EName (en: ExceptionName): TEXT =
  VAR i: CARDINAL := 0;
  BEGIN
    WHILE (en^^[i] # '\000') DO INC (i) END;
    RETURN Text.FromChars (SUBARRAY (en^^, 0, i));
  END EName;

PROCEDURE Setup (VAR i: INTEGER) =
  VAR j: INTEGER;
  BEGIN
    stack_grows_up := ADR (i) < ADR (j);
  END Setup;

BEGIN
  VAR i: INTEGER; BEGIN Setup (i) END;
END RTException.