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

(* File: TryStmt.m3                                            *)
(* Last modified on Wed Apr 25 01:42:19 1990 by muller         *)
(*      modified on Mon Feb 12 09:51:18 1990 by kalsow         *)




MODULE TryStmt;

IMPORT Variable, Scope, Exceptionz, Value, Error, Procedure, Marker;
IMPORT Type, String, Emit, Expr, Stmt, StmtRep, TryFinStmt, Token, Void;
FROM Scanner IMPORT Match, MatchID, GetToken, Fail, cur;

TYPE
  P = Stmt.T OBJECT
        body       : Stmt.T;
        handles    : Handler;
        else       : BOOLEAN;
        elseBody   : Stmt.T;
        id         : INTEGER;
      METHODS
	bind       := Bind;
        check      := Check;
	precompile := Precompile;
	compile    := Compile;
      END;

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

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

VAR
  labelPrefix : String.T := NIL;
  nextID      : INTEGER  := 0;

PROCEDURE Parse (READONLY fail: Token.Set): Stmt.T =
  TYPE TK = Token.T;
  VAR s: Stmt.T;  p: P;  bar: BOOLEAN;
  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
      RETURN TryFinStmt.Parse (s, fail);
    END;

    p := NEW (P);
    StmtRep.Init (p);
    p.body     := s;
    p.else     := 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.else := TRUE;
      p.elseBody := Stmt.Parse (fail + Token.Set {TK.tEND});
    END;

    Match (TK.tEND, fail, Token.Set {});
    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;
  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;
    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);
      Match (TK.tRPAREN, fail, Token.Set {TK.tIMPLIES} + Token.StmtStart);
      h.var := Variable.New (id, FALSE);
      h.scope := Scope.New1 (h.var);
      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 Bind (p: P) =
  VAR h: Handler;
  BEGIN
    Stmt.Bind (p.body);
    h := p.handles;
    WHILE (h # NIL) DO
      BindHandler (h);
      h := h.next;
    END;
    Stmt.Bind (p.elseBody);
  END Bind;

PROCEDURE BindHandler (h: Handler) =
  VAR e: Except;  obj: Value.T;
  BEGIN
    e := h.tags;
    WHILE (e # NIL) DO
      obj := Scope.LookUpQID (e.name);
      IF (obj = NIL) THEN Error.QID (e.name, "undefined") END;
      e.obj := obj;
      Value.Bind (obj);
      e := e.next;
    END;
    IF (h.scope # NIL) THEN
      h.type := Exceptionz.ArgType (obj);
      h.type := Type.Bind (h.type);
      IF h.type = NIL THEN h.type := Type.Bind (Void.T); END;
      Variable.BindType (h.var, h.type, FALSE, FALSE);
      (*** Value.Bind (h.var); ***)
      Scope.Push (h.scope);
      Scope.Bind (h.scope, TRUE);
      Stmt.Bind (h.body);
      Scope.Pop ();
    ELSE
      Stmt.Bind (h.body);
    END;
  END BindHandler;

PROCEDURE Check (p: P) =
  VAR h: Handler;
  BEGIN
    IF (p.else)
      THEN Marker.PushTry (NIL, 0);
      ELSE Marker.PushTryElse (NIL, 0);
    END;
    Stmt.TypeCheck (p.body);
    Marker.Pop ();
    h := p.handles;
    WHILE (h # NIL) DO
      CheckHandler (h);
      h := h.next;
    END;
    Stmt.TypeCheck (p.elseBody);
  END Check;

PROCEDURE CheckHandler (h: Handler) =
  VAR e: Except;  obj: Value.T;  t: Type.T;
  BEGIN
    e := h.tags;
    WHILE (e # NIL) DO
      obj := e.obj;
      IF (Value.ClassOf (obj) # Value.Class.Exception) THEN
        Error.QID (e.name, "is not an exception");
      ELSE
        Value.TypeCheck (obj);
        IF (h.scope # NIL) THEN
          t := Exceptionz.ArgType (obj);
          IF  NOT (Type.IsEqual (t, h.type)) THEN
            Error.Msg ("incompatible argument types");
          END;
        END;
      END;
      e := e.next;
    END;
    IF (h.scope # NIL) THEN
      IF Type.IsEqual (h.type, Void.T) THEN
        Error.Msg ("exception(s) don\'t have a return argument");
      END;
      Scope.TypeCheck (h.scope, TRUE);
      Scope.Push (h.scope);
        Stmt.TypeCheck (h.body);
      Scope.WarnUnused (h.scope);
      Scope.Pop ();
    ELSE
      Stmt.TypeCheck (h.body);
    END;
  END CheckHandler;

PROCEDURE Precompile (p: P) =
  VAR h: Handler;
  BEGIN
    p.id := nextID;  INC (nextID);
    IF (p.else)
      THEN Marker.PushTryElse (NIL, 0);
      ELSE Marker.PushTry (NIL, 0);
    END;
    Stmt.Precompile (p.body);
    Marker.Pop ();

    h := p.handles;
    WHILE (h # NIL) DO
      IF (h.scope # NIL) THEN
        Scope.Push (h.scope);
        Stmt.Precompile (h.body);
        Scope.Pop ();
      ELSE
        Stmt.Precompile (h.body);
      END;
      h := h.next;
    END;
    Stmt.Precompile (p.elseBody);
    IF  NOT p.else THEN GenExceptionList (p, p.id);  END;
  END Precompile;

PROCEDURE GenExceptionList (p: P;  label: INTEGER) =
  VAR h: Handler;  e: Except;
  BEGIN
    Emit.OpI ("PRIVATE EXCEPTION_NAME *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 ("0\n\002};\n");
  END GenExceptionList;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR h: Handler; label: INTEGER;  oc: Stmt.Outcomes;
  BEGIN
    label := p.id;
    IF (labelPrefix = NIL) THEN labelPrefix := String.Add ("try_") END;
    Emit.OpSI ("{\001\nHANDLER h@@;\n", labelPrefix, label);
    IF (p.else) THEN
      Emit.OpSI ("PUSH_TRY (h@@, 0, ", labelPrefix, label);
      Emit.OpSI ("@@);\n", labelPrefix, label);
      Marker.PushTryElse (labelPrefix, label);
    ELSE
      Emit.OpSI ("PUSH_TRY (h@@, ", labelPrefix, label);
      Emit.OpI ("try_labels_@, ", label);
      Emit.OpSI ("@@);\n", labelPrefix, label);
      Marker.PushTry (labelPrefix, label);
    END;

    oc := Stmt.Compile (p.body);
    Marker.Pop ();
    IF (Stmt.Outcome.FallThrough IN oc) THEN
      Emit.OpSI ("CUT_TO_NEXT_HANDLER (h@@);\n", labelPrefix, label);
      Emit.OpSI ("goto @@_exit;\n", labelPrefix, label);
    END;

    Emit.OpSI ("\n@@:\n\001", labelPrefix, label);
    Emit.OpSI ("CUT_TO_NEXT_HANDLER (h@@);\n", labelPrefix, label);
    h := p.handles;
    WHILE (h # NIL) DO
      oc := oc + GenOneHandler (h, label);
      h := h.next;
    END;
    IF (p.else)
      THEN oc := oc + Stmt.Compile (p.elseBody);
      ELSE Marker.EmitElse (labelPrefix, label);
    END;
    Emit.OpSI ("\002@@_exit: /**/;\n\002};\n", labelPrefix, label);
    RETURN oc;
  END Compile;

PROCEDURE GenOneHandler (h: Handler;  label: INTEGER): Stmt.Outcomes =
  VAR e: Except;  oc: Stmt.Outcomes;
  BEGIN
    Emit.Op ("if (");
    e := h.tags;
    WHILE (e # NIL) DO
      Emit.OpSI ("(h@@.exception->e == ", labelPrefix, label);
      Emit.OpN ("& @)", e.obj);
      e := e.next;
      IF (e # NIL) THEN Emit.Op (" || ") END;
    END;
    Emit.Op (") {\n\001");
    IF (h.scope # NIL) THEN
      Scope.Push (h.scope);
      Scope.Enter (h.scope);
      Emit.OpV ("@ = ", h.var);
      Emit.OpI ("*((t@ *)", Type.Name (h.type));
      Emit.OpSI ("h@@.exception->a);\n", labelPrefix, label);
      oc := Stmt.Compile (h.body);
      Scope.Exit (h.scope);
      Scope.Pop ();
    ELSE
      oc := Stmt.Compile (h.body);
    END;
    IF (Stmt.Outcome.FallThrough IN oc) THEN
      Emit.OpI ("goto try_@_exit;\n", label);
    END;
    Emit.Op ("\002};\n");
    RETURN oc;
  END GenOneHandler;

BEGIN
END TryStmt.