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

(* File: AssignStmt.m3                                         *)
(* Last modified on Thu Sep  3 17:06:19 PDT 1992 by kalsow         *)
(*      modified on Fri Dec 21 01:24:28 1990 by muller         *)

MODULE AssignStmt;

IMPORT Stmt, StmtRep, Expr, Emit, Type, Error, Module;
IMPORT Token, Scanner, CallStmt, CheckExpr, NarrowExpr, Addr;
IMPORT String, Value, ProcType, NamedExpr, RefType, SetType;
IMPORT QualifyExpr, Variable, Procedure, Temp, OpenArrayType;
IMPORT ProcCheckExpr, ProcExpr, ObjectType, SetExpr, CallExpr;
IMPORT OpenArrayExpr, ArrayType, RecordType, Scope;

TYPE
  P = Stmt.T OBJECT
	lhs     : Expr.T;
	rhs     : Expr.T;
      OVERRIDES
        check    := Check;
	compile  := Compile;
        outcomes := GetOutcome;
      END;

PROCEDURE Parse (READONLY fail: Token.Set): Stmt.T =
  VAR e: Expr.T;  p: P;  s: Stmt.T;  here := Scanner.offset;
  BEGIN
    e := Expr.Parse (fail + Token.Set {Token.T.tASSIGN});
    IF (Scanner.cur.token # Token.T.tASSIGN) THEN
      IF NOT CallExpr.Is (e) THEN
	Error.Msg ("Expression is not a statement");
      END;
      s := CallStmt.New (e);
      s.origin := here;
      RETURN s;
    END;	

    p := NEW (P);
    StmtRep.Init (p);
    p.origin := here;
    Scanner.GetToken (); (* := *)
    p.lhs := e;
    p.rhs := Expr.Parse (fail);
    RETURN p;
  END Parse;

PROCEDURE New (lhs, rhs: Expr.T): Stmt.T =
  VAR p := NEW (P);
  BEGIN
    StmtRep.Init (p);
    p.lhs := lhs;
    p.rhs := rhs;
    RETURN p;
  END New;

PROCEDURE CheckRHS (tlhs: Type.T;  rhs: Expr.T;
                    VAR cs: Stmt.CheckState;  kind:= Kind.assign): Expr.T =
  (* caller is responsible for generating open array shape checks *)
  VAR
    trhs, t, element: Type.T;
    openRHS, openLHS: BOOLEAN;
    lmin, lmax, rmin, rmax: INTEGER;
    zz, tmp: Expr.T;
  BEGIN
    zz := rhs;
    Expr.TypeCheck (rhs, cs);
    trhs := Expr.TypeOf (rhs);

    t := Type.Base (trhs);
    openRHS := OpenArrayType.Split (t, element);
    t := Type.Base (tlhs);
    openLHS := OpenArrayType.Split (t, element);

    IF openLHS OR openRHS THEN
      rhs := OpenArrayExpr.New (tlhs, rhs, kind); 

    ELSIF (tlhs = trhs) OR Type.IsSubtype (trhs, tlhs) THEN
      IF kind = Kind.assign 
        AND ProcType.Is (trhs)
        AND NeedsClosureCheck (rhs) THEN
        rhs := ProcCheckExpr.New (rhs);
      END;

    ELSIF (Type.Number (tlhs) >= 0) THEN
      (* ordinal types:  OK if there is a common supertype *)
      IF  NOT Type.IsSubtype (trhs, Type.Base (tlhs)) THEN
        Error.Msg ("types are not assignable");
      ELSE
        (* ok, but must generate a check *)
        tmp := Expr.ConstValue (rhs);
        IF (tmp # NIL) THEN rhs := tmp END;
        Expr.GetBounds (rhs, rmin, rmax);
        EVAL Type.GetBounds (tlhs, lmin, lmax);
        IF (lmin <= lmax) AND (rmin <= rmax)
          AND ((lmax < rmin) OR (rmax < lmin)) THEN
          (* non-overlappling, non-empty ranges *)
          Error.Warn (2, "value not assignable (range fault)");
          rhs := CheckExpr.New (rhs, lmin, lmax);
        ELSIF (rmin < lmin) AND (rmax > lmax) THEN
          rhs := CheckExpr.New (rhs, lmin, lmax);
        ELSIF (rmin < lmin) THEN
          rhs := CheckExpr.NewLower (rhs, lmin);
        ELSIF (rmax > lmax) THEN
          rhs := CheckExpr.NewUpper (rhs, lmax);
        END;
      END;

    ELSIF Type.IsSubtype (tlhs, trhs) THEN
      IF Type.IsEqual (trhs, Addr.T, NIL) THEN 
        (* that is legal only in UNSAFE modules *)
        IF Module.IsSafe() THEN Error.Msg ("unsafe implicit NARROW") END;
      ELSIF RefType.Is (trhs) OR ObjectType.Is (trhs) THEN
        (* ok, but must narrow rhs before doing the assignment *)
        rhs := NarrowExpr.New (rhs, tlhs, implicit := TRUE);
      ELSE
        (* nope. *)
        Error.Msg ("types are not assignable");
      END;

    ELSE
      Error.Msg ("types are not assignable");
    END;

    IF (rhs # zz) THEN  Expr.TypeCheck (rhs, cs)  END;

    RETURN rhs;
  END CheckRHS;

PROCEDURE NeedsClosureCheck (e: Expr.T): BOOLEAN =
  VAR name: String.T;  obj: Value.T;  class: Value.Class;
  BEGIN
    IF NOT (NamedExpr.Split (e, name, obj)
            OR QualifyExpr.Split (e, obj)
	    OR ProcExpr.Split (e, obj)) THEN
      (* non-constant, non-variable => OK *)
      RETURN FALSE;
    END;
    obj := Value.Base (obj);
    class := Value.ClassOf (obj);
    IF (class = Value.Class.Procedure) THEN
      IF (Procedure.IsNested (obj)) THEN
        Error.Str (Value.CName (obj), "cannot assign nested procedures");
      END;
      RETURN FALSE;
    ELSIF (class = Value.Class.Var) AND Variable.HasClosure (obj) THEN
      RETURN TRUE;
    ELSE (* non-formal, non-const => no check *)
      RETURN FALSE;
      (* OK *)
    END;
  END NeedsClosureCheck;

PROCEDURE Check (p: P;  VAR cs: Stmt.CheckState) =
  VAR tlhs: Type.T;
  BEGIN
    Expr.TypeCheck (p.lhs, cs);
    Expr.TypeCheck (p.rhs, cs);

    tlhs := Expr.TypeOf (p.lhs);
    IF  NOT Expr.IsDesignator (p.lhs) THEN
      Error.Msg ("left-hand side is not a designator");
    ELSIF  NOT Expr.IsWritable (p.lhs) THEN
      Error.Msg ("left-hand side is read-only");
    END;

    p.rhs := CheckRHS (tlhs, p.rhs, cs);
  END Check;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  VAR
    t, u, t2, t4, range, index, elt: Type.T;
    openLHS, openRHS: BOOLEAN;
    tLHS, tRHS: Temp.T;
    fields: Scope.T;
  BEGIN
    t := Type.Base (Expr.TypeOf (p.rhs));
    u := Type.Base (Expr.TypeOf (p.lhs));
    openRHS := OpenArrayType.Split (t, t2);
    openLHS := OpenArrayType.Split (u, t4);
    tRHS := Expr.Compile (p.rhs);
    tLHS := Expr.CompileLValue (p.lhs);
    IF openRHS OR openLHS OR OpenArrayExpr.Is (p.rhs) THEN
      OpenArrayExpr.CompileAssign (p.rhs, tRHS, tLHS);
    ELSIF SetType.Split (t, range) THEN
      SetExpr.CompileAssign (range, tLHS, tRHS);
    ELSIF (Type.Name (t) = Type.Name (u)) THEN
      Emit.OpTT ("@ = @;\n", tLHS, tRHS);
    ELSIF Expr.IsDesignator (p.rhs)
       OR ArrayType.Split (t, index, elt)
       OR RecordType.Split (t, fields) THEN
      Emit.OpT ("@ = ", tLHS);
      Emit.OpF ("*(@*) ", u);
      Emit.OpT ("(& @);\n", tRHS);
    ELSE
      Emit.OpT ("@ = ", tLHS);
      Emit.OpF ("(@) ", u);
      Emit.OpT ("@;\n", tRHS);
    END;
    Expr.NoteWrite (p.lhs);
    Temp.Free (tLHS);
    Temp.Free (tRHS);
    RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough};
  END Compile;

PROCEDURE GetOutcome (<*UNUSED*> p: P): Stmt.Outcomes =
  BEGIN
    RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough};
  END GetOutcome;

BEGIN
END AssignStmt.