MODULE ForStmt;

IMPORT M3ID, CG, Error, Scope, Expr, Stmt, StmtRep;
IMPORT EnumType, Type, Int, LInt, Variable, Target, TargetMap, TInt, ErrType;
IMPORT IntegerExpr, EnumExpr, Token, Marker, Tracer;
FROM Scanner IMPORT Match, MatchID, GetToken, cur;

TYPE
  P = Stmt.T OBJECT
        scope   : Scope.T;
        var     : Variable.T;
        from    : Expr.T;
        limit   : Expr.T;
        step    : Expr.T;
        body    : Stmt.T;
      OVERRIDES
        check       := Check;
        compile     := Compile;
        outcomes    := GetOutcome;
      END;

PROCEDURE Parse (): Stmt.T =
  TYPE TK = Token.T;
  VAR id: M3ID.T;  p: P;  trace: Tracer.T;
  BEGIN
    p := NEW (P);
    StmtRep.Init (p);
    Match (TK.tFOR);
    id := MatchID ();
    trace := Variable.ParseTrace ();
    Match (TK.tASSIGN);
    p.from := Expr.Parse ();
    Match (TK.tTO);
    p.limit := Expr.Parse ();
    p.step := NIL;
    IF (cur.token = TK.tBY) THEN
      GetToken (); (* BY *)
      p.step := Expr.Parse ();
    END;
    p.var := Variable.New (id, TRUE);
    p.scope := Scope.New1 (p.var);
    Variable.BindTrace (p.var, trace);
    Match (TK.tDO);
    p.body := Stmt.Parse ();
    Match (TK.tEND);
    Scope.PopNew ();
    RETURN p;
  END Parse;

PROCEDURE Check (p: P;  VAR cs: Stmt.CheckState) =
  VAR
    tFrom, tTo, tStep  : Type.T;
    minFrom,  maxFrom  : Target.Int;
    minLimit, maxLimit : Target.Int;
    minStep,  maxStep  : Target.Int;
    newMin,   newMax   : Target.Int;
    zz                 : Scope.T;
    errored            : BOOLEAN := FALSE;
  BEGIN
    Expr.TypeCheck (p.from, cs);
    Expr.TypeCheck (p.limit, cs);
    tFrom := Type.Base (Expr.TypeOf (p.from));
    tTo   := Type.Base (Expr.TypeOf (p.limit));

    IF (tFrom = ErrType.T) OR (tTo = ErrType.T) THEN
      (* already an error... *)
      tFrom := ErrType.T;
      tTo := ErrType.T;
      tStep := Int.T;
      errored := TRUE;
    ELSIF EnumType.Is (tFrom) THEN
      IF NOT Type.IsEqual (tFrom, tTo, NIL) THEN
        Error.Msg ("\'from\' and \'to\' expressions are incompatible");
        errored := TRUE;
      END;
      tStep := Int.T;
    ELSIF (tFrom = Int.T) AND (tTo = Int.T) THEN
      tStep := Int.T;
    ELSIF (tFrom = LInt.T) AND (tTo = LInt.T) THEN
      tStep := LInt.T;
    ELSE
      Error.Msg("\'from\' and \'to\' expressions must be compatible ordinals");
      errored := TRUE;
      tStep := Int.T;
    END;

    IF p.step = NIL THEN p.step := IntegerExpr.New (tStep, TInt.One) END;
    Expr.TypeCheck (p.step, cs);
    IF NOT Type.IsSubtype (Expr.TypeOf (p.step), tStep) THEN
      Error.Msg ("\'by\' expression must be an integer");
      errored := TRUE;
    END;

    (* set the type of the control variable *)
    Variable.BindType (p.var, tFrom, indirect := FALSE, readonly := TRUE,
                       needs_init := FALSE,  open_array_ok := FALSE);

    (* determine the ranges of the control values *)
    IF Reduce (p.step, minStep)
      THEN maxStep := minStep;
      ELSE Expr.GetBounds (p.step, minStep, maxStep);
    END;
    IF Reduce (p.from, minFrom)
      THEN maxFrom := minFrom;
      ELSE Expr.GetBounds (p.from, minFrom, maxFrom);
    END;
    IF Reduce (p.limit, minLimit)
      THEN maxLimit := minLimit;
      ELSE Expr.GetBounds (p.limit, minLimit, maxLimit);
    END;

    IF TInt.EQ (minStep, TInt.Zero) AND TInt.EQ (maxStep, TInt.Zero) THEN
      (* warning suggested by Ernst A. Heinz <heinze@ira.uka.de>
         to catch typos. (March 19, 1995) *)
      Error.Warn (1, "zero \'by\' value in FOR loop");
      errored := TRUE;
    END;

    (* try to tighten up the range of the new index variable *)
    IF TInt.LE (TInt.Zero, minStep) THEN
      (* we're counting up! *)
      newMin := minFrom;
      newMax := maxLimit;
    ELSIF TInt.LT (maxStep, TInt.Zero) THEN
      (* we're counting down *)
      newMin := minLimit;
      newMax := maxFrom;
    ELSE
      (* we might be counting in either direction... *)
      IF TInt.LT (minFrom, minLimit)
        THEN newMin := minFrom;
        ELSE newMin := minLimit;
      END;
      IF TInt.LT (maxFrom, maxLimit)
        THEN newMax := maxLimit;
        ELSE newMax := maxFrom;
      END;
    END;
    Variable.SetBounds (p.var, newMin, newMax);

    IF NOT errored AND TInt.LT (newMax, newMin) THEN
      Error.Warn (1, "FOR loop body is unreachable (empty range)");
    END;

    zz := Scope.Push (p.scope);
      Scope.TypeCheck (p.scope, cs);
      Marker.PushExit (CG.No_label);
      Stmt.TypeCheck (p.body, cs);
      Marker.Pop ();
    Scope.Pop (zz);
  END Check;

PROCEDURE Reduce (VAR expr: Expr.T;  VAR i: Target.Int): BOOLEAN =
  VAR e: Expr.T;  t: Type.T;
  BEGIN
    e := Expr.ConstValue (expr);
    IF (e = NIL) THEN RETURN FALSE END;
    expr := e;
    RETURN IntegerExpr.Split (e, i, t) OR EnumExpr.Split (e, i, t);
  END Reduce;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR
    step, limit, from: Expr.T;
    step_val, limit_val, from_val: Target.Int;
    step_min, step_max: Target.Int;
    t: Type.T;
    oc: Stmt.Outcomes;
    zz: Scope.T;
    index, to, by: CG.Var;
    t_index, t_to, t_by: CG.Val;
    l_top, l_test, l_less, l_exit: CG.Label;
    type: Type.T;
    global, indirect, lhs, index_copy: BOOLEAN;
    info: Type.Info;
    offset: INTEGER;
    cg_type: CG.Type;
    uid: INTEGER;
  BEGIN
    Variable.Split (p.var, type, global, indirect, lhs);
    IF Type.IsSubtype (type, LInt.T)
      THEN cg_type := Target.Longint.cg_type; uid := Type.GlobalUID (LInt.T);
      ELSE cg_type := Target.Integer.cg_type; uid := Type.GlobalUID (Int.T);
    END;

    from := Expr.ConstValue (p.from);
    IF (from = NIL) THEN
      Expr.Prep (p.from);
      Expr.Compile (p.from);
      t_index := CG.Pop_temp ();
    ELSE
      (* lower bound is a constant *)
      from_val := TInt.Zero;
      EVAL IntegerExpr.Split (from, from_val, t)
        OR EnumExpr.Split (from, from_val, t);
    END;

    limit := Expr.ConstValue (p.limit);
    IF (limit = NIL) THEN
      Expr.Prep (p.limit);
      Expr.Compile (p.limit);
      t_to := CG.Pop_temp ();
    ELSE (* upper bound is a constant *)
      limit_val := TInt.Zero;
      EVAL IntegerExpr.Split (limit, limit_val, t)
        OR EnumExpr.Split (limit, limit_val, t);
    END;

    step := Expr.ConstValue (p.step);
    IF (step = NIL) THEN
      (* non-constant step value *)
      Expr.Prep (p.step);
      Expr.Compile (p.step);
      t_by := CG.Pop_temp ();
      Expr.GetBounds (p.step, step_min, step_max);
    ELSE (* step is a constant *)
      step_val := TInt.Zero;
      EVAL IntegerExpr.Split (step, step_val, t)
        OR EnumExpr.Split (step, step_val, t);
    END;

    l_top  := CG.Next_label (3);
    l_test := l_top + 1;
    l_exit := l_top + 2;

    zz := Scope.Push (p.scope);
      Scope.Enter (p.scope);
      Scope.InitValues (p.scope);

      IF Type.IsEqual (type, Int.T, NIL) OR Type.IsEqual (type, LInt.T, NIL) THEN
        (* use the user's variable *)
        index_copy := FALSE;
        Variable.LocalCGName (p.var, index, offset);
        <*ASSERT offset = 0*>
      ELSE
        (* declare a fresh local variable for the index *)
        (* 'cause small variables may overflow at the end of their ranges *)
        index_copy := TRUE;
        index := CG.Declare_local (M3ID.NoID, TargetMap.CG_Size[cg_type],
                                   TargetMap.CG_Align[cg_type], cg_type, uid,
                                   in_memory := FALSE, up_level := FALSE,
                                   f := CG.Always);
      END;

      IF (from = NIL) THEN
        CG.Push (t_index);
        CG.Store_int (cg_type, index);
        CG.Free (t_index);
      ELSE
        CG.Load_integer (cg_type, from_val);
        CG.Store_int (cg_type, index);
      END;

      IF (limit = NIL) THEN
        (* declare the local variable *)
        to := CG.Declare_local (M3ID.NoID, TargetMap.CG_Size[cg_type],
                                TargetMap.CG_Align[cg_type], cg_type, uid,
                                in_memory := FALSE, up_level := FALSE,
                                f := CG.Maybe);
        CG.Push (t_to);
        CG.Store_int (cg_type, to);
        CG.Free (t_to);
      END;

      IF (step = NIL) THEN
        (* declare the local variable *)
        by := CG.Declare_local (M3ID.NoID, TargetMap.CG_Size[cg_type],
                                TargetMap.CG_Align[cg_type], cg_type, uid,
                                in_memory := FALSE, up_level := FALSE,
                                f := CG.Maybe);
        CG.Push (t_by);
        CG.Store_int (cg_type, by);
        CG.Free (t_by);
      END;

      IF (from = NIL) OR (limit = NIL) OR (step = NIL) THEN
        (* we don't know all three values... *)
        CG.Jump (l_test);
      ELSIF TInt.LE (TInt.Zero, step_val)
        AND TInt.LE (from_val, limit_val) THEN
        (* we know we'll execute the loop at least once. *)
      ELSIF TInt.LE (step_val, TInt.Zero)
        AND TInt.LE (limit_val, from_val) THEN
        (* we know we'll execute the loop at least once. *)
      ELSE
        (* we won't execute the loop... *)
        CG.Jump (l_test);
      END;
      CG.Set_label (l_top);

      Marker.PushExit (l_exit);

      IF (index_copy) THEN
        (* make the user's variable equal to the counter *)
        EVAL Type.CheckInfo (type, info);
        Variable.LoadLValue (p.var);
        CG.Load_int (cg_type, index);
        CG.Store_indirect (info.stk_type, 0, info.size);
      END;
      Variable.ScheduleTrace (p.var);

      oc := Stmt.Compile (p.body);

      (* increment the counter *)
      CG.Gen_location (p.origin);
      CG.Load_int (cg_type, index);
      IF (step # NIL)
        THEN CG.Load_integer (cg_type, step_val);
        ELSE CG.Load_int (cg_type, by);
      END;
      CG.Add (cg_type);
      CG.Store_int (cg_type, index);

      (* generate the loop test *)
      CG.Gen_location (p.origin);
      CG.Set_label (l_test);
      IF (step # NIL) THEN (* constant step value *)
        CG.Load_int (cg_type, index);
        IF (limit # NIL)
          THEN CG.Load_integer (cg_type, limit_val);
          ELSE CG.Load_int (cg_type, to);
        END;
        IF TInt.LE (TInt.Zero, step_val)
          THEN CG.If_compare (cg_type, CG.Cmp.LE, l_top, CG.Likely);
          ELSE CG.If_compare (cg_type, CG.Cmp.GE, l_top, CG.Likely);
        END;
      ELSIF TInt.LE (TInt.Zero, step_min) THEN
        (* positive, variable step value *)
        CG.Load_int (cg_type, index);
        IF (limit # NIL)
          THEN CG.Load_integer (cg_type, limit_val);
          ELSE CG.Load_int (cg_type, to);
        END;
        CG.If_compare (cg_type, CG.Cmp.LE, l_top, CG.Likely);
      ELSIF TInt.LT (step_max, TInt.Zero) THEN
        (* negative, variable step value *)
        CG.Load_int (cg_type, index);
        IF (limit # NIL)
          THEN CG.Load_integer (cg_type, limit_val);
          ELSE CG.Load_int (cg_type, to);
        END;
        CG.If_compare (cg_type, CG.Cmp.GE, l_top, CG.Likely);
      ELSE (* variable step value *)
        l_less := CG.Next_label (2);
        CG.Load_int (cg_type, by);
        CG.Load_integer (cg_type, TInt.Zero);
        CG.If_compare (cg_type, CG.Cmp.LT, l_less, CG.Likely);
        CG.Load_int (cg_type, index);
        IF (limit # NIL)
          THEN CG.Load_integer (cg_type, limit_val);
          ELSE CG.Load_int (cg_type, to);
        END;
        CG.If_compare (cg_type, CG.Cmp.LE, l_top, CG.Likely);
        CG.Jump (l_less+1);
        CG.Set_label (l_less);
        CG.Load_int (cg_type, index);
        IF (limit # NIL)
          THEN CG.Load_integer (cg_type, limit_val);
          ELSE CG.Load_int (cg_type, to);
        END;
        CG.If_compare (cg_type, CG.Cmp.GE, l_top, CG.Likely);
        CG.Set_label (l_less+1);
      END;

      Marker.Pop ();
      CG.Set_label (l_exit);

      Scope.Exit (p.scope);
    Scope.Pop (zz);

    (* a FOR can fall through if its index range may be empty *)
    (* or if its body can fall through or exit.  -- Ernst Heinz *)
    IF (Stmt.Outcome.Exits IN oc)
      OR (from = NIL) OR (limit = NIL) OR (step = NIL) OR
       (NOT TInt.LT (step_val, TInt.Zero) AND TInt.LT (limit_val, from_val)) OR
       (    TInt.LT (step_val, TInt.Zero) AND TInt.LT (from_val, limit_val))
      THEN oc := oc + Stmt.Outcomes {Stmt.Outcome.FallThrough};
    END;

    RETURN oc - Stmt.Outcomes {Stmt.Outcome.Exits};
  END Compile;

PROCEDURE GetOutcome (p: P): Stmt.Outcomes =
  BEGIN
    RETURN Stmt.GetOutcome (p.body)
            - Stmt.Outcomes {Stmt.Outcome.Exits}
            + Stmt.Outcomes {Stmt.Outcome.FallThrough};
  END GetOutcome;

BEGIN
END ForStmt.