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

(* File: TryStmt.m3                                            *)
(* Last modified on Mon Oct 12 09:14:55 PDT 1992 by kalsow     *)
(*      modified on Fri Oct  5 06:40:21 1990 by muller         *)

MODULE TryStmt;

IMPORT M3, Variable, Scope, Exceptionz, Value, Error, Marker;
IMPORT Type, String, Emit, Stmt, StmtRep, TryFinStmt, Token;
IMPORT Scanner, ESet, Frame, Void, Tracer, Target;
FROM Scanner IMPORT Match, Match1, MatchID, GetToken, Fail, cur;

TYPE
  P = Stmt.T OBJECT
        scope    : Scope.T;
        body     : Stmt.T;
        handles  : Handler;
        hasElse  : BOOLEAN;
        elseBody : Stmt.T;
      OVERRIDES
        check    := Check;
	compile  := Compile;
        outcomes := GetOutcome;
      END;

TYPE
  Handler = UNTRACED REF RECORD
              next   : Handler;
              tags   : Except;
              type   : Type.T;
              var    : Variable.T;
              scope  : Scope.T;
              body   : Stmt.T;
              origin : INTEGER;
            END;

TYPE
  Except = UNTRACED REF RECORD
             next : Except;
             name : String.QID;
             obj  : Value.T;
           END;

PROCEDURE Parse (READONLY fail: Token.Set): Stmt.T =
  TYPE TK = Token.T;
  VAR s: Stmt.T;  p: P;  bar: BOOLEAN;  here := Scanner.offset;
  BEGIN
    Match (TK.tTRY, fail, Token.Set {TK.tEXCEPT, TK.tFINALLY, TK.tEND});
    s := Stmt.Parse (fail + Token.Set {TK.tEXCEPT, TK.tFINALLY, TK.tEND});
    IF (cur.token = TK.tFINALLY) THEN
      s := TryFinStmt.Parse (s, fail);
      s.origin := here;
      RETURN s;
    END;

    p := NEW (P);
    StmtRep.Init (p);
    p.origin   := here;
    p.scope    := Scope.Top ();
    p.body     := s;
    p.hasElse  := FALSE;
    p.elseBody := NIL;
    p.handles  := NIL;

    Match (TK.tEXCEPT, fail, Token.Set {TK.tEND, TK.tBAR});
    bar := (cur.token = TK.tBAR);
    IF (bar) THEN GetToken (); (* | *)  END;
    LOOP
      IF (cur.token = TK.tELSE) THEN EXIT END;
      IF (cur.token = TK.tEND) THEN EXIT END;
      bar := FALSE;
      ParseHandler (p, fail + Token.Set {TK.tELSE, TK.tEND});
      IF (cur.token # TK.tBAR) THEN EXIT END;
      GetToken (); (* | *)
    END;

    ReverseHandlers (p);
    IF (bar) THEN
      Fail ("missing handler", fail + Token.Set {TK.tEND});
    END;

    IF (cur.token = TK.tELSE) THEN
      GetToken (); (* ELSE *)
      p.hasElse := TRUE;
      p.elseBody := Stmt.Parse (fail + Token.Set {TK.tEND});
    END;

    Match1 (TK.tEND, fail);
    RETURN p;
  END Parse;

PROCEDURE ParseHandler (p: P;  READONLY fail: Token.Set) =
  TYPE TK = Token.T;
  CONST Markers = Token.Set {TK.tLPAREN, TK.tIMPLIES} + Token.StmtStart;
  VAR h: Handler;  e: Except;  id: String.T;  trace: Tracer.T;
  BEGIN
    h := NEW (Handler);
    h.next   := p.handles;  p.handles := h;
    h.tags   := NIL;
    h.type   := NIL;
    h.var    := NIL;
    h.scope  := NIL;
    h.body   := NIL;
    h.origin := Scanner.offset;
    LOOP
      e := NEW (Except);
      e.next := h.tags;  h.tags := e;
      e.obj  := NIL;
      e.name.module := NIL;
      e.name.item  := MatchID (fail, Markers);
      IF (cur.token = TK.tDOT) THEN
        GetToken (); (* . *)
        e.name.module := e.name.item;
        e.name.item   := MatchID (fail, Markers);
      END;
      IF (cur.token # TK.tCOMMA) THEN EXIT END;
      GetToken (); (* , *)
    END;
    IF (cur.token = TK.tLPAREN) THEN
      GetToken (); (* ( *)
      id := MatchID (fail, Token.Set{TK.tRPAREN,TK.tIMPLIES}+Token.StmtStart);
      trace := Variable.ParseTrace (fail
                   + Token.Set{TK.tRPAREN,TK.tIMPLIES} + Token.StmtStart);
      Match (TK.tRPAREN, fail, Token.Set {TK.tIMPLIES} + Token.StmtStart);
      h.var := Variable.New (id, FALSE);
      h.scope := Scope.New1 (h.var);
      Variable.BindTrace (h.var, trace);
      Match (TK.tIMPLIES, fail, Token.StmtStart);
      h.body := Stmt.Parse (fail);
      Scope.PopNew ();
    ELSE
      Match (TK.tIMPLIES, fail, Token.StmtStart);
      h.body := Stmt.Parse (fail);
    END;
  END ParseHandler;

PROCEDURE ReverseHandlers (p: P) =
  VAR h1, h2, h3: Handler;
  BEGIN
    h1 := p.handles;
    h3 := NIL;
    WHILE (h1 # NIL) DO
      h2 := h1.next;
      h1.next := h3;
      h3 := h1;
      h1 := h2;
    END;
    p.handles := h3;
  END ReverseHandlers;

PROCEDURE Check (p: P;  VAR cs: Stmt.CheckState) =
  VAR h: Handler;  handled: ESet.T;
  BEGIN
    h := p.handles;
    WHILE (h # NIL) DO CheckLabels (h, p.scope, cs); h := h.next; END;

    IF (p.hasElse) THEN
      Marker.PushTryElse (0);
      handled := ESet.NewAny ();
    ELSE
      Marker.PushTry (0);
      handled := ESet.NewEmpty ();
      h := p.handles;
      WHILE (h # NIL) DO PushRaises (h, handled); h := h.next; END;
    END;

    ESet.Push (cs, handled, NIL, stop := FALSE);
    Stmt.TypeCheck (p.body, cs);
    ESet.Pop  (cs, handled, NIL, stop := FALSE);
    Marker.Pop ();

    h := p.handles;
    WHILE (h # NIL) DO CheckHandler (h, cs); h := h.next; END;

    Stmt.TypeCheck (p.elseBody, cs);
  END Check;

PROCEDURE CheckLabels (h: Handler;  scope: Scope.T;  VAR cs: Stmt.CheckState) =
  VAR e: Except;  obj: Value.T;  t: Type.T;
  BEGIN
    Scanner.offset := h.origin;
    e := h.tags;
    WHILE (e # NIL) DO
      obj := Scope.LookUpQID (scope, e.name);
      IF (obj = NIL) THEN Error.QID (e.name, "undefined") END;
      e.obj := obj;
      Value.TypeCheck (obj, cs);
      IF (Value.ClassOf (obj) # Value.Class.Exception) THEN
        Error.QID (e.name, "is not an exception");
      ELSE
        IF (h.scope # NIL) THEN
          t := Exceptionz.ArgType (obj);
          IF (e = h.tags) THEN (* first one *)
            h.type := t;
          ELSIF NOT Type.IsEqual (t, h.type, NIL) THEN
            Error.Msg ("exceptions have incompatible types");
          END;
        END;
      END;
      e := e.next;
    END;
  END CheckLabels;

PROCEDURE PushRaises (h: Handler;  handled: ESet.T) =
  VAR e: Except;
  BEGIN
    e := h.tags;
    WHILE (e # NIL) DO
      ESet.Add (handled, e.name, e.obj);
      e := e.next;
    END;
  END PushRaises;

PROCEDURE CheckHandler (h: Handler;  VAR cs: Stmt.CheckState) =
  VAR zz: Scope.T;
  BEGIN
    Scanner.offset := h.origin;
    IF (h.scope # NIL) THEN
      IF Type.IsEqual (h.type, Void.T, NIL) THEN
        Error.Msg ("exception(s) don\'t have a return argument");
      END;
      Variable.BindType (h.var, h.type, FALSE, FALSE);
      Scope.TypeCheck (h.scope, cs);
      zz :=Scope.Push (h.scope);
        Stmt.TypeCheck (h.body, cs);
        Scope.WarnUnused (h.scope);
      Scope.Pop (zz);
    ELSE
      Stmt.TypeCheck (h.body, cs);
    END;
  END CheckHandler;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR h: Handler; label: INTEGER;  oc: Stmt.Outcomes;  save: Emit.Stream;
  BEGIN
    label := M3.NextLabel;  INC (M3.NextLabel, 2);
    save := Emit.SwitchToDecls ();
    Emit.OpI ("_TRY_HANDLER _h@;\n", label);
    INC (Frame.cur.size, 5 + (Target.JumpBufSize DIV Target.ADDRSIZE));
    EVAL Emit.Switch (save);
    IF (p.hasElse) THEN
      Emit.OpI ("_PUSH_TRY_ELSE (_h@, ", label);
      Emit.OpL ("@);\001\n", label);
      Marker.PushTryElse (label);
    ELSE
      Emit.OpI ("_PUSH_TRY (_h@, ", label);
      Emit.OpI ("_try_labels_@, ", label);
      Emit.OpL ("@);\001\n", label);
      Marker.PushTry (label);
      GenExceptionList (p, label);
    END;

    oc := Stmt.Compile (p.body);
    Marker.Pop ();
    Emit.Op ("\002");
    IF (Stmt.Outcome.FallThrough IN oc) THEN
      Emit.OpI ("_CUT_TO_NEXT_HANDLER (_h@);\n", label);
      Emit.OpL ("goto @;\n", label+1);
    END;

    IF (p.hasElse) THEN
      (* EXITs and RETURNs from the body are caught by the ELSE clause *)
      oc := oc - Stmt.Outcomes {Stmt.Outcome.Returns, Stmt.Outcome.Exits};
    END;

    Emit.OpL ("@:;\001\n", label);
    h := p.handles;
    WHILE (h # NIL) DO
      oc := oc + GenOneHandler (h, label, (NOT p.hasElse) AND (h.next = NIL));
      h := h.next;
    END;
    IF (p.hasElse) THEN
      oc := oc + Stmt.Compile (p.elseBody);
    END;
    Emit.OpL ("\002@:;\n", label+1);
    RETURN oc;
  END Compile;

PROCEDURE GenExceptionList (p: P;  label: INTEGER) =
  VAR h: Handler;  e: Except;  save: Emit.Stream;
  BEGIN
    save := Emit.Switch (Emit.Stream.Constants);
    Emit.OpI ("_PRIVATE _VOLATILE _EXCEPTION _try_labels_@ [] = {\n\001", label);
    h := p.handles;
    WHILE (h # NIL) DO
      e := h.tags;
      WHILE (e # NIL) DO
        IF (e.obj # NIL) THEN Emit.OpN ("& @,\n", e.obj) END;
        e := e.next;
      END;
      h := h.next;
    END;
    Emit.Op ("(_EXCEPTION) _NIL\n\002};\n");
    EVAL Emit.Switch (save);
  END GenExceptionList;

PROCEDURE GenOneHandler (h: Handler;  label: INTEGER;  last: BOOLEAN)
                                                             : Stmt.Outcomes =
  VAR e: Except;  oc: Stmt.Outcomes; zz: Scope.T;  block: INTEGER;
  BEGIN
    IF (NOT last) THEN
      (* we need to check for a match *)
      Emit.Op ("if (");
      e := h.tags;
      WHILE (e # NIL) DO
        Emit.OpI ("(_h@.exception == ", label);
        Emit.OpN ("& @)", e.obj);
        e := e.next;
        IF (e # NIL) THEN Emit.Op (" || ") END;
      END;
      Emit.Op (") ");
    END;
    Frame.PushBlock (block, 0);
    IF (h.scope # NIL) THEN
      zz := Scope.Push (h.scope);
        Scope.Enter (h.scope);
        Scope.InitValues (h.scope);
        Emit.OpV ("@ = ", h.var);
        IF Exceptionz.ArgByReference (h.type) THEN
          Emit.OpF ("*((@ *)", h.type);
          Emit.OpI ("_h@.arg);\n", label);
        ELSE
          Emit.OpF ("(@)", h.type);
          Emit.OpI ("_h@.arg;\n", label);
        END;
        Variable.ScheduleTrace (h.var);
        oc := Stmt.Compile (h.body);
        Scope.Exit (h.scope);
      Scope.Pop (zz);
    ELSE
      oc := Stmt.Compile (h.body);
    END;
    IF (Stmt.Outcome.FallThrough IN oc) AND (NOT last) THEN
      Emit.OpL ("goto @;\n", label+1);
    END;
    Frame.PopBlock (block);
    RETURN oc;
  END GenOneHandler;

PROCEDURE GetOutcome (p: P): Stmt.Outcomes =
  VAR h: Handler;  oc := Stmt.GetOutcome (p.body);
  BEGIN
    IF (p.hasElse) THEN
      (* EXITs and RETURNs from the body are caught by the ELSE clause *)
      oc := oc - Stmt.Outcomes {Stmt.Outcome.Returns, Stmt.Outcome.Exits};
    END;

    h := p.handles;
    WHILE (h # NIL) DO
      oc := oc + Stmt.GetOutcome (h.body);
      h := h.next;
    END;

    IF (p.hasElse) THEN
      oc := oc + Stmt.GetOutcome (p.elseBody)
    END;

    RETURN oc;
  END GetOutcome;

BEGIN
END TryStmt.