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

(* File: CaseStmt.m3                                           *)
(* Last modified on Mon Oct 12 14:18:28 PDT 1992 by kalsow     *)
(*      modified on Fri Feb 15 04:03:38 1991 by muller         *)

MODULE CaseStmt;

IMPORT M3, Expr, Stmt, StmtRep, Type, Error, Target, Host, Word;
IMPORT EnumExpr, Temp, Token, IntegerExpr, Emit, Scanner, Int, Fault;
FROM Scanner IMPORT Match, Match1, GetToken, Fail, cur;

TYPE
  P = Stmt.T BRANDED "CaseStmt.P" OBJECT
        expr     : Expr.T   := NIL;
        tree     : Tree     := NIL;
        bodies   : StmtList := NIL;
	complete : BOOLEAN  := FALSE;
        hasElse  : BOOLEAN  := FALSE;
        elseBody : Stmt.T   := NIL;
        nCases   : INTEGER  := 0;
      OVERRIDES
        check    := Check;
	compile  := Compile;
        outcomes := GetOutcome;
      END;

TYPE
  Tree = UNTRACED REF RECORD
           less    : Tree;
           greater : Tree;
           emin    : Expr.T;
           emax    : Expr.T;
           min     : INTEGER;
           max     : INTEGER;
           body    : INTEGER;
         END;

TYPE
  StmtList = UNTRACED REF ARRAY OF Stmt.T;

VAR
  nest   : INTEGER := 0;

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.bodies := NEW (StmtList, 8);

    Match (TK.tCASE, 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;
    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 t: Tree;  fail2: Token.Set;
  BEGIN
    fail2 := fail + Token.Set {TK.tDOTDOT, TK.tIMPLIES, TK.tCOMMA};
    LOOP
      t := NEW (Tree);
      t.less    := p.tree;   p.tree := t;
      t.greater := NIL;
      t.emin    := Expr.Parse (fail2);
      t.emax    := NIL;
      t.body    := p.nCases;
      IF (cur.token = TK.tDOTDOT) THEN
        GetToken (); (* .. *)
        t.emax := Expr.Parse (fail2);
      END;
      IF (cur.token # TK.tCOMMA) THEN EXIT END;
      GetToken (); (* , *)
    END;
    Match (TK.tIMPLIES, fail, Token.StmtStart);
    IF (p.nCases > LAST (p.bodies^)) THEN ExpandBodies (p) END;
    p.bodies[p.nCases] := Stmt.Parse (fail);
    INC (p.nCases);
  END ParseCase;

PROCEDURE ExpandBodies (p: P) =
  VAR old, new: StmtList;
  BEGIN
    old := p.bodies;
    new := NEW (StmtList, NUMBER (old^) * 2);
    FOR i := 0 TO LAST (old^) DO new[i] := old[i] END;
    p.bodies := new;
  END ExpandBodies;

PROCEDURE Check (p: P;  VAR cs: Stmt.CheckState) =
  VAR t, u: Tree;  type: Type.T;  min, max, minE, maxE: INTEGER;
  BEGIN
    (* check out the selector *)
    Expr.TypeCheck (p.expr, cs);
    type := Expr.TypeOf (p.expr);
    IF (Type.Number (type) < 0) THEN
      Error.Msg ("invalid expression type for case selector");
    END;

    (* type check the cases & build a tree *)
    EVAL Type.GetBounds (type, min, max);
    t := p.tree;
    p.tree := NIL;
    WHILE (t # NIL) DO
      u := t.less;
      p.tree := AddNode (p.tree, t, type, min, max, cs);
      t := u;
    END;

    (* type check the bodies *)
    FOR i := 0 TO p.nCases - 1 DO Stmt.TypeCheck (p.bodies[i], cs) END;

    (* check the else clause *)
    IF (p.hasElse) THEN Stmt.TypeCheck (p.elseBody, cs) END;

    (* check for a complete tree *)
    Expr.GetBounds (p.expr, minE, maxE);
    p.complete := p.hasElse OR CompleteTree (p.tree, minE, maxE);
    IF (NOT p.complete) THEN
      Scanner.offset := p.origin;
      Error.Warn (1, "CASE statement does not handle all possible values");
    END;
  END Check;

PROCEDURE AddNode (old, new: Tree;  type: Type.T;  min, max: INTEGER;
                    VAR cs: Stmt.CheckState): Tree =
  BEGIN
    new.min := CheckLabel (new.emin, type, cs);
    IF (new.emax # NIL)
      THEN new.max := CheckLabel (new.emax, type, cs);
      ELSE new.max := new.min;
    END;
    IF (new.min < min) OR (max < new.max) THEN
      Error.Msg ("case labels out of range");
    END;
    RETURN AddToTree (old, new);
  END AddNode;

PROCEDURE CheckLabel (e: Expr.T;  type: Type.T;
                                         VAR cs: Stmt.CheckState): INTEGER =
  VAR t: Type.T;  i: INTEGER;
  BEGIN
    Expr.TypeCheck (e, cs);
    t := Expr.TypeOf (e);
    e := Expr.ConstValue (e);
    IF (e = NIL) THEN Error.Msg ("case label must be constant") END;
    IF NOT Type.IsAssignable (type, t) THEN
      Error.Msg ("case label not compatible with selector");
    END;
    i := 0;
    IF IntegerExpr.Split (e, i) OR EnumExpr.Split (e, i, t) THEN END;
    RETURN i;
  END CheckLabel;

PROCEDURE AddToTree (old, new: Tree): Tree =
  BEGIN
    new.less    := NIL;
    new.greater := NIL;
    IF (old = NIL) THEN
      old := new;
    ELSIF (new.max < old.min) THEN
      old.less := AddToTree (old.less, new);
    ELSIF (old.max < new.min) THEN
      old.greater := AddToTree (old.greater, new);
    ELSE (* old.min <= new.min AND new.max <= old.max *)
      Error.Msg ("duplicate labels in case statement");
    END;
    RETURN old;
  END AddToTree;

PROCEDURE CompleteTree (t: Tree;  min, max: INTEGER): BOOLEAN =
  BEGIN
    WHILE (t # NIL) DO
      IF (t.max < min) OR (max < t.min) THEN
        RETURN (min > max);
      ELSIF (t.min - min > max - t.max) THEN
        IF NOT CompleteTree (t.greater, t.max+1, max) THEN RETURN FALSE END;
	max := t.min-1; t := t.less;
      ELSE
        IF NOT CompleteTree (t.less, min, t.min-1) THEN RETURN FALSE END;
	min := t.max+1; t := t.greater;  
      END;
    END;
    RETURN (min > max);
  END CompleteTree;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR minL, maxL: INTEGER; t: Tree;  oc: Stmt.Outcomes;
  BEGIN
    (* find the smallest label *)
    minL := Target.MAXINT;
    t := p.tree;
    WHILE (t # NIL) DO
      minL := t.min;
      t := t.less;
    END;

    (* find the largest label *)
    maxL := Target.MININT;
    t := p.tree;
    WHILE (t # NIL) DO
      maxL := t.max;
      t := t.greater;
    END;

    (* collapse adjacent tree nodes *)
    p.tree := FlattenTree (p.tree, NIL);

    IF (nest = 0) AND ShouldBeIndexed (p, maxL, minL) THEN
      (* generate an indexed table branch *)
      INC (nest); (* prevent nested case statements because of C, blech! *)
      oc := GenIndexedBranch (p);
      DEC (nest);
    ELSE
      (* generate an IF-ELSE structure *)
      oc := GenIfTable (p);
 (* ELSE generate a binary search table... *)
    END;
    RETURN oc;
  END Compile;

PROCEDURE FlattenTree (t, tail: Tree): Tree =
  BEGIN
    IF (t = NIL) THEN RETURN tail END;
    t.greater := FlattenTree (t.greater, tail);
    RETURN FlattenTree (t.less, t);
  END FlattenTree;

PROCEDURE ShouldBeIndexed (p: P;  maxL, minL: INTEGER): BOOLEAN =
  VAR
    t: Tree;
    last, n_tests: INTEGER;
    n_slots := Word.Minus (maxL, minL);
  BEGIN
    (* don't bother with huge tables *)
    IF (n_slots > 4096) OR (n_slots < 0) THEN RETURN FALSE END;

    (* don't bother with tiny tables *)
    (* => count the number of IF tests that would be needed *)
    n_tests := 0;
    last := Target.MININT;
    t := p.tree;
    WHILE (t # NIL) DO
      IF (last < t.min - 1) THEN INC (n_tests) END;
      INC (n_tests);
      last := t.max;
      t := t.greater;
    END;
    IF (n_tests < 8) THEN RETURN FALSE END;

    (* otherwise, use a table if the density is at least 0.25 *)
    RETURN (p.nCases * 4) > (maxL - minL);
  END ShouldBeIndexed;

PROCEDURE GenIndexedBranch (p: P): Stmt.Outcomes =
  VAR t: Tree;  x: Temp.T;  oc, xc: Stmt.Outcomes;  j: INTEGER;
  BEGIN
    x := Expr.Compile (p.expr);
    Emit.OpT ("switch (@) {\n", x);
    Temp.Free (x);
    oc := Stmt.Outcomes {};

    (* generate the table entries *)
    FOR i := 0 TO p.nCases - 1 DO
      t := p.tree;
      WHILE (t # NIL) DO
        IF (t.body = i) THEN
          j := t.min;
          WHILE (j <= t.max) DO
            Emit.OpI ("case @:\n", j);
            IF (j = t.max) THEN EXIT END;
            INC (j);
          END;
        END;
        t := t.greater;
      END;
      Emit.Op ("\001");
      xc := Stmt.Compile (p.bodies[i]);
      oc := oc + xc;
      IF (Stmt.Outcome.FallThrough IN xc) THEN Emit.Op ("break;\n") END;
      Emit.Op ("\002");
    END;

    (* generate the else clause *)
    Emit.Op ("default:;\n\001");
    IF (p.hasElse) THEN
      oc := oc + Stmt.Compile (p.elseBody);
    ELSIF (NOT p.complete) AND (Host.doCaseChk) THEN
      Fault.Case ();
    END;
    Emit.Op ("\002}\n");
    RETURN oc;
  END GenIndexedBranch;

PROCEDURE GenIfTable (p: P): Stmt.Outcomes =
  VAR
    t: Tree;
    x, y: Temp.T;
    last: INTEGER;
    oc, xc: Stmt.Outcomes;
    gotoExit: BOOLEAN;
    baseLabel, elseLabel, exitLabel: INTEGER;
  BEGIN
    p.tree := CollapseTree (p.tree);
    exitLabel := M3.NextLabel;  INC (M3.NextLabel);
    elseLabel := M3.NextLabel;  INC (M3.NextLabel);
    baseLabel := M3.NextLabel;  INC (M3.NextLabel, p.nCases);
    oc := Stmt.Outcomes {};

    (* compile the tests & branches *)
    x := Expr.Compile (p.expr);
    y := Temp.AllocEmpty (Int.T);
    Emit.OpTT ("@ = @;\n", y, x);
    Temp.Free (x);

    (* walk the list of labels generating the goto's *)
    last := Target.MININT;
    t := p.tree;
    WHILE (t # NIL) DO
      IF (last < t.min - 1) THEN
        Emit.OpTI ("if (@ < @) ", y, t.min);
        Emit.OpL  ("goto @;\n", elseLabel);
      END;
      Emit.OpTI ("if (@ <= @) ", y, t.max);
      Emit.OpL  ("goto @;\n", baseLabel + t.body);
      last := t.max;
      t := t.greater;
    END;
    Emit.OpL ("goto @;\n", elseLabel);
    Temp.Free (y);

    (* generate the bodies *)
    gotoExit := FALSE;
    FOR i := 0 TO p.nCases - 1 DO
      Emit.OpL ("@:;\n\001", baseLabel + i);
      xc := Stmt.Compile (p.bodies[i]);
      oc := oc + xc;
      IF (Stmt.Outcome.FallThrough IN xc) THEN
        Emit.OpL ("goto @;\n", exitLabel);
	gotoExit := TRUE;
      END;
      Emit.Op ("\002");
    END;

    (* generate the else clause *)
    Emit.OpL ("@:;\n\001", elseLabel);
    IF (p.hasElse) THEN
      oc := oc + Stmt.Compile (p.elseBody);
    ELSIF (NOT p.complete) AND (Host.doCaseChk) THEN
      Fault.Case ();
    END;
    Emit.Op ("\002");
    IF (gotoExit) THEN Emit.OpL ("@:;\n", exitLabel) END;
    RETURN oc;
  END GenIfTable;

PROCEDURE CollapseTree (t: Tree): Tree =
  VAR t1, t2: Tree;  x, c: INTEGER;
  BEGIN
    t1 := t;
    WHILE (t1 # NIL) DO
      c := t1.body;
      x := t1.max;
      t2 := t1.greater;
      WHILE (t2 # NIL) AND (t2.body = c) AND (x + 1 = t2.min) DO
        x := t2.max;
        t2 := t2.greater;
      END;
      t1.greater := t2;
      t1.max := x;
      t1 := t2;
    END;
    RETURN t;
  END CollapseTree;

PROCEDURE GetOutcome (p: P): Stmt.Outcomes =
  VAR oc := Stmt.Outcomes {};
  BEGIN
    FOR i := 0 TO p.nCases - 1 DO
      oc := oc + Stmt.GetOutcome (p.bodies[i]);
    END;
    IF (p.hasElse) THEN
      oc := oc + Stmt.GetOutcome (p.elseBody);
    END;
    RETURN oc;
  END GetOutcome;

BEGIN
END CaseStmt.