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

(* File: TypeCaseStmt.m3                                       *)
(* Last modified on Mon Mar  2 11:13:22 PST 1992 by kalsow     *)
(*      modified on Thu Feb 21 23:57:16 1991 by muller         *)

MODULE TypeCaseStmt;

IMPORT M3, Expr, Stmt, StmtRep, Type, Variable, Scope, Emit;
IMPORT Error, Token, Null, Temp, ObjectAdr, RefType, Scanner;
IMPORT Int, Host, Frame, Fault, String, Reff, Addr;
FROM Scanner IMPORT Match, Match1, MatchID, GetToken, Fail, cur;

TYPE
  P = Stmt.T OBJECT
        expr     : Expr.T;
        cases    : Case;
        complete : BOOLEAN;
        hasElse  : BOOLEAN;
        elseBody : Stmt.T;
      OVERRIDES
        check    := Check;
	compile  := Compile;
        outcomes := GetOutcome;
      END;

TYPE
  Case = UNTRACED REF RECORD
           next  : Case;
           nTags : INTEGER;
           tags  : TypeList;
           var   : Variable.T;
           scope : Scope.T;
           stmt  : Stmt.T;
         END;

TYPE TypeList = UNTRACED REF ARRAY OF Type.T;

PROCEDURE Parse (READONLY fail: Token.Set): Stmt.T =
  TYPE TK = Token.T;
  VAR p: P;  bar: BOOLEAN;
  BEGIN
    p := NEW (P);
    StmtRep.Init (p);
    p.cases    := NIL;
    p.complete := FALSE;
    p.hasElse  := FALSE;
    p.elseBody := NIL;

    Match (TK.tTYPECASE, fail, Token.Set {TK.tOF, TK.tBAR, TK.tEND});
    p.expr := Expr.Parse (fail + Token.Set {TK.tOF, TK.tBAR, TK.tEND});
    Match (TK.tOF, fail, Token.Set {TK.tBAR, TK.tELSE, TK.tEND});
    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;
      ParseCase (p, fail + Token.Set {TK.tELSE, TK.tEND});
      IF (cur.token # TK.tBAR) THEN EXIT END;
      bar := TRUE; GetToken (); (* | *)
    END;

    ReverseCases (p);
    IF (bar) THEN
      Fail ("missing case", fail + Token.Set {TK.tELSE, 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 ParseCase (p: P;  READONLY fail: Token.Set) =
  TYPE TK = Token.T;
  VAR c: Case;  fail2: Token.Set;  id: String.T;
  BEGIN
    fail2 := fail + Token.Set {TK.tLPAREN, TK.tIMPLIES, TK.tCOMMA};
    c := NEW (Case);
    c.next  := p.cases;  p.cases := c;
    c.var   := NIL;
    c.scope := NIL;
    c.stmt  := NIL;
    c.nTags := 0;
    c.tags  := NEW (TypeList, 2);

    LOOP
      IF (c.nTags > LAST (c.tags^)) THEN ExpandTags (c) END;
      c.tags[c.nTags] := Type.Parse (fail2);
      INC (c.nTags);
      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);
      c.var := Variable.New (id, FALSE);
      c.scope := Scope.New1 (c.var);
      Variable.BindType (c.var, c.tags[0], FALSE, FALSE);
      Match (TK.tRPAREN, fail, Token.Set {TK.tIMPLIES} + Token.StmtStart);
      Match (TK.tIMPLIES, fail, Token.StmtStart);
      c.stmt := Stmt.Parse (fail);
      Scope.PopNew ();
    ELSE
      Match (TK.tIMPLIES, fail, Token.StmtStart);
      c.stmt := Stmt.Parse (fail);
    END;
  END ParseCase;

PROCEDURE ExpandTags (c: Case) =
  VAR new, old: TypeList;
  BEGIN
    old := c.tags;
    new := NEW (TypeList, 2 * NUMBER (old^));
    FOR i := 0 TO LAST (old^) DO new[i] := old[i] END;
    c.tags := new;
  END ExpandTags;

PROCEDURE ReverseCases (p: P) =
  VAR c1, c2, c3: Case;
  BEGIN
    c1 := p.cases;
    c3 := NIL;
    WHILE (c1 # NIL) DO
      c2 := c1.next;
      c1.next := c3;
      c3 := c1;
      c1 := c2;
    END;
    p.cases := c3;
  END ReverseCases;

PROCEDURE Check (p: P;  VAR cs: Stmt.CheckState) =
  VAR t: Type.T;  c: Case;
  BEGIN
    Expr.TypeCheck (p.expr, cs);
    t := Type.Base (Expr.TypeOf (p.expr));

    IF (NOT Type.IsSubtype (t, Reff.T))
      AND (NOT Type.IsSubtype (t, ObjectAdr.T)) THEN
      Error.Msg ("typecase selector must be a REF or OBJECT type");
    END;

    (* check each of the cases *)
    p.complete := p.hasElse;
    c := p.cases;
    WHILE (c # NIL) DO
      IF CheckCase (c, t, cs) THEN  p.complete := TRUE  END;
      c := c.next;
    END;

    Stmt.TypeCheck (p.elseBody, cs);

    IF (NOT p.complete) THEN
      Scanner.offset := p.origin;
      Error.Warn (1, "TYPECASE statement may not handle all cases");
    END;
  END Check;

PROCEDURE CheckCase (c: Case;  exprType: Type.T;
                                           VAR cs: Stmt.CheckState): BOOLEAN =
  VAR t, u: Type.T;  complete: BOOLEAN;  zz: Scope.T;
  BEGIN
    (* check the labels *)
    complete := FALSE;
    u := c.tags[0];
    FOR i := 0 TO c.nTags - 1 DO
      t := c.tags[i];
      Type.Check (t);
      IF (c.scope # NIL) AND (NOT Type.IsEqual (t, u, NIL)) THEN
        Error.Msg ("type labels are incompatible");
      END;
      IF (NOT Type.IsSubtype (t, exprType))
        AND (NOT Type.IsSubtype (exprType, t)) THEN
        Error.Msg ("type label incompatible with case expression");
      END;
      complete := complete OR Type.IsSubtype (exprType, t);
    END;

    (* check the body *)
    IF (c.scope # NIL) THEN
      zz := Scope.Push (c.scope);
        Scope.TypeCheck (c.scope, cs);
        Stmt.TypeCheck (c.stmt, cs);
        Scope.WarnUnused (c.scope);
      Scope.Pop (zz);
    ELSE
      Stmt.TypeCheck (c.stmt, cs);
    END;
    RETURN complete;
  END CheckCase;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR c: Case;  x, ref, tc: Temp.T;  i: INTEGER;  oc: Stmt.Outcomes; 
      foundForSure := FALSE;
      baseLabel, nullLabel, elseLabel, exitLabel: INTEGER;
  BEGIN
    nullLabel := M3.NextLabel;  INC (M3.NextLabel);
    baseLabel := M3.NextLabel;  INC (M3.NextLabel, CntCases (p.cases));
    elseLabel := M3.NextLabel;  INC (M3.NextLabel);
    exitLabel := M3.NextLabel;  INC (M3.NextLabel);

    (* capture the ref and its typecode *)
    x := Expr.Compile (p.expr);
    ref := Temp.AllocEmpty (Addr.T);
    tc  := Temp.AllocEmpty (Int.T);
    Emit.OpTT ("@ = (_ADDRESS) @;\n", ref, x);
    Emit.OpT  ("if (@ == 0) ", ref);
    Emit.OpL  ("goto @;\n", nullLabel);
    Emit.OpTT ("@ = _TYPECODZ (@);\n", tc, ref);
    Temp.Free (x);

    (* compile the tests *)
    c := p.cases;  i := 0;
    WHILE (c # NIL) DO
      foundForSure := CompileCaseTest (p, c, tc, baseLabel + i);
      IF foundForSure THEN
        IF (c.next # NIL) THEN UnreachableCases (c.next) END;
        c := NIL;
      ELSE
        c := c.next;
      END;
      INC (i);
    END;
    IF NOT foundForSure THEN Emit.OpL ("goto @;\n", elseLabel); END;
    Temp.Free (tc);

    (* compile the case bodies *)
    oc := Stmt.Outcomes {};
    Emit.OpL ("@:;\n", nullLabel);
    c := p.cases;
    i := 0;
    WHILE (c # NIL) DO
      oc := oc + CompileCaseBody (c, ref, baseLabel + i, exitLabel);
      c := c.next;
      INC (i);
    END;
    IF foundForSure THEN
      IF (p.elseBody # NIL) THEN
        Error.Warn (1, "unreachable ELSE in TYPECASE");
      END;
    ELSE
      Emit.OpL ("@:;\n\001", elseLabel);
      IF (p.hasElse) THEN
        oc := oc + Stmt.Compile (p.elseBody);
      ELSIF (NOT p.complete) AND (Host.doTCaseChk) THEN
        Fault.TypeCase ();
      END;
      Emit.Op ("\002");
    END;
    Emit.OpL ("@:;\n", exitLabel);
    Temp.Free (ref);
    RETURN oc;
  END Compile;

PROCEDURE CntCases (c: Case): INTEGER =
  VAR n := 0;
  BEGIN
    WHILE (c # NIL) DO INC (n);  c := c.next END;
    RETURN n;
  END CntCases;

PROCEDURE CompileCaseTest (p: P; c: Case; tc: Temp.T; label: INTEGER): BOOLEAN=
  VAR t, u: Type.T;
  BEGIN
    u := Expr.TypeOf (p.expr);
    FOR i := 0 TO c.nTags - 1 DO
      t := c.tags[i];
      IF Type.IsEqual (t, Null.T, NIL) THEN
        (* nothing to do; we have already generated a goto tc0 
           if the expr is NIL *)
      ELSIF Type.IsSubtype (u, t) THEN
        (* the test succedes statically! *)
        Emit.OpL ("goto @;\n", label);
        RETURN TRUE;
      ELSIF RefType.Is (t) THEN
        Type.Compile (t);
        Emit.OpT ("if (@ == ", tc);
        Emit.OpF ("@_TC->typecode) ", t);
        Emit.OpL ("goto @;\n", label);
      ELSE
        Type.Compile (t);
        Emit.OpT ("if (_ISSUBTYPZ (@, ", tc);
        Emit.OpF ("@_TC)) ", t);
        Emit.OpL ("goto @;\n", label);
      END;
    END;
    RETURN FALSE;
  END CompileCaseTest;

PROCEDURE CompileCaseBody (c: Case;  ref: Temp.T;
                                        label, exit: INTEGER): Stmt.Outcomes =
  VAR oc: Stmt.Outcomes;  zz: Scope.T;  block: INTEGER;
  BEGIN
    Emit.OpL ("@:;\n\001", label);
    IF (c.scope # NIL) THEN
      zz := Scope.Push (c.scope);
      Frame.PushBlock (block);
        Scope.Enter (c.scope);
        Scope.InitValues (c.scope);
        Emit.OpV  ("@ = ", c.var);
        Emit.OpFT ("(@) @;\n", c.tags[0], ref);
        oc := Stmt.Compile (c.stmt);
        Scope.Exit (c.scope);
      Frame.PopBlock (block);
      Scope.Pop (zz);
    ELSE
      oc := Stmt.Compile (c.stmt);
    END;
    IF (Stmt.Outcome.FallThrough IN oc) THEN
      Emit.OpL ("goto @;\n", exit);
    END;
    Emit.Op ("\002");
    RETURN oc;
  END CompileCaseBody;

PROCEDURE UnreachableCases (c: Case) =
  VAR save: INTEGER;
  BEGIN
    save := Scanner.offset;
    WHILE (c # NIL) DO
      IF (c.stmt # NIL) THEN Scanner.offset := c.stmt.origin END;
      Error.Warn (1, "unreachable case");
      c := c.next;
    END;
    Scanner.offset := save;
  END UnreachableCases;

PROCEDURE GetOutcome (p: P): Stmt.Outcomes =
  VAR c: Case;  oc := Stmt.Outcomes {};
  BEGIN
    c := p.cases;
    WHILE (c # NIL) DO
      oc := oc + Stmt.GetOutcome (c.stmt);
      c := c.next;
    END;
    IF (p.hasElse) THEN  oc := oc + Stmt.GetOutcome (p.elseBody)  END;
    RETURN oc;
  END GetOutcome;

BEGIN
END TypeCaseStmt.