m3front/src/stmts/AssignStmt.m3


Copyright (C) 1994, Digital Equipment Corp.
File: AssignStmt.m3

MODULE AssignStmt;

IMPORT CG, Stmt, StmtRep, Expr, Type, Error, Module, Target, TInt;
IMPORT Token, Scanner, CallStmt, Addr, CheckExpr;
IMPORT M3ID, Value, NamedExpr, ArrayType;
IMPORT QualifyExpr, Variable, Procedure, OpenArrayType;
IMPORT ProcExpr, ObjectType, CallExpr, Host, Narrow;

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

PROCEDURE Parse (): Stmt.T =
  VAR e: Expr.T;  p: P;  s: Stmt.T;  here := Scanner.offset;
  BEGIN
    e := Expr.Parse ();
    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 ();
    RETURN p;
  END Parse;

PROCEDURE CheckMethod (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;

    Check (tlhs, p.rhs, cs);
  END CheckMethod;

PROCEDURE Compile (p: P): Stmt.Outcomes =
  BEGIN
    Expr.PrepLValue (p.lhs);
    Expr.Prep (p.rhs);
    Expr.CompileLValue (p.lhs);
    Emit (Expr.TypeOf (p.lhs), p.rhs);
    Expr.NoteWrite (p.lhs);
    RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough};
  END Compile;

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

PROCEDURE Check (tlhs: Type.T;  rhs: Expr.T;  VAR cs: Stmt.CheckState) =
  VAR
    t := Type.Base (tlhs); (* strip renaming and packing *)
    trhs := Expr.TypeOf (rhs);
    lhs_info, t_info: Type.Info;
    c: Type.Class;
  BEGIN
    tlhs := Type.CheckInfo (tlhs, lhs_info);
    t := Type.CheckInfo (t, t_info);
    c := t_info.class;
    Expr.TypeCheck (rhs, cs);

    IF NOT Type.IsAssignable (tlhs, trhs) THEN
      Error.Msg ("types are not assignable");

    ELSIF (Type.IsOrdinal (t)) THEN
      CheckOrdinal (tlhs, rhs);

    ELSIF (c = Type.Class.Ref) OR (c = Type.Class.Object)
       OR (c = Type.Class.Opaque) THEN
      CheckReference (tlhs, trhs, lhs_info);

    ELSIF (c = Type.Class.Procedure) THEN
      CheckProcedure (rhs);

    ELSE
      (* ok *)

    END;
  END Check;

PROCEDURE CheckOrdinal (tlhs: Type.T;  rhs: Expr.T) =
  VAR lmin, lmax, rmin, rmax: Target.Int;  constant: Expr.T;
  BEGIN
    (* ok, but must generate a check *)
    constant := Expr.ConstValue (rhs);
    IF (constant # NIL) THEN rhs := constant END;
    Expr.GetBounds (rhs, rmin, rmax);
    EVAL Type.GetBounds (tlhs, lmin, lmax);
    IF TInt.LE (lmin, lmax) AND TInt.LE (rmin, rmax)
      AND (TInt.LT (lmax, rmin) OR TInt.LT (rmax, lmin)) THEN
      (* non-overlappling, non-empty ranges *)
      Error.Warn (2, "value not assignable (range fault)");
    END;
  END CheckOrdinal;

PROCEDURE CheckReference (tlhs, trhs: Type.T;  READONLY lhs_info: Type.Info) =
  BEGIN
    IF Type.IsSubtype (trhs, tlhs) THEN
      (* ok *)
    ELSIF NOT Type.IsSubtype (tlhs, trhs) THEN
      Error.Msg ("types are not assignable");
    ELSIF 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 ObjectType.Is (trhs) THEN
      (* ok *)
    ELSIF lhs_info.isTraced THEN
      (* ok *)
    ELSE
      Error.Msg ("types are not assignable");
    END;
  END CheckReference;

PROCEDURE CheckProcedure (rhs: Expr.T) =
  BEGIN
    IF NeedsClosureCheck (rhs, TRUE) THEN
      (* may generate more detailed message *)
    END;
  END CheckProcedure;

PROCEDURE NeedsClosureCheck (proc: Expr.T;  errors: BOOLEAN): BOOLEAN =
  VAR name: M3ID.T;  obj: Value.T;  class: Value.Class;  nested: BOOLEAN;
  BEGIN
    IF NOT (NamedExpr.Split (proc, name, obj)
            OR QualifyExpr.Split (proc, obj)
	    OR ProcExpr.Split (proc, obj)) THEN
      (* non-constant, non-variable => OK *)
      RETURN FALSE;
    END;
    obj := Value.Base (obj);
    class := Value.ClassOf (obj);
    IF (class = Value.Class.Procedure) THEN
      nested := Procedure.IsNested (obj);
      IF (nested) AND (errors) THEN
        Error.ID (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;
    END;
  END NeedsClosureCheck;
------------------------------------------------------- code generation ---

PROCEDURE Emit (tlhs: Type.T;  rhs: Expr.T) =
  (* on entry the lhs is compiled and the rhs is prepped. *)
  VAR
    t := Type.Base (tlhs); (* strip renaming and packing *)
    lhs_info, t_info: Type.Info;
  BEGIN
    t := Type.CheckInfo (t, t_info);
    tlhs := Type.CheckInfo (tlhs, lhs_info);

    CASE t_info.class OF
    | Type.Class.Integer, Type.Class.Subrange, Type.Class.Enum =>
        AssignOrdinal (tlhs, rhs, lhs_info);
    | Type.Class.Real, Type.Class.Longreal, Type.Class.Extended =>
        AssignFloat (rhs, lhs_info);
    | Type.Class.Object, Type.Class.Opaque, Type.Class.Ref =>
        AssignReference (tlhs, rhs, lhs_info);
    | Type.Class.Array, Type.Class.OpenArray =>
        AssignArray (tlhs, rhs, lhs_info);
    | Type.Class.Procedure =>
        AssignProcedure (rhs, lhs_info);
    | Type.Class.Record =>
        AssignRecord (tlhs, rhs, lhs_info);
    | Type.Class.Set =>
        AssignSet (tlhs, rhs, lhs_info);
    ELSE <* ASSERT FALSE *>
    END;
  END Emit;

PROCEDURE AssignOrdinal (tlhs: Type.T;  rhs: Expr.T;
                         READONLY lhs_info: Type.Info) =
  VAR min, max : Target.Int;
  BEGIN
    EVAL Type.GetBounds (tlhs, min, max);
    CheckExpr.Emit (rhs, min, max);
    CG.Store_indirect (lhs_info.cg_type, 0, lhs_info.size);
  END AssignOrdinal;

PROCEDURE AssignFloat (rhs: Expr.T;  READONLY lhs_info: Type.Info) =
  BEGIN
    Expr.Compile (rhs);
    CG.Store_indirect (lhs_info.cg_type, 0, lhs_info.size);
  END AssignFloat;

PROCEDURE AssignReference (tlhs: Type.T;  rhs: Expr.T;
                           READONLY lhs_info: Type.Info) =
  VAR lhs: CG.Val;
  BEGIN
    lhs := CG.Pop ();
    Expr.Compile (rhs);
    IF Host.doNarrowChk THEN Narrow.Emit (tlhs, Expr.TypeOf (rhs)) END;
    CG.Push (lhs);
    CG.Swap ();
    CG.Store_indirect (lhs_info.cg_type, 0, lhs_info.size);
    CG.Free (lhs);
  END AssignReference;

PROCEDURE AssignProcedure (rhs: Expr.T;  READONLY lhs_info: Type.Info) =
  VAR ok: CG.Label;  lhs, t1: CG.Val;
  BEGIN
    IF NOT Host.doNarrowChk THEN
      Expr.Compile (rhs);
    ELSIF NOT NeedsClosureCheck (rhs, FALSE) THEN
      Expr.Compile (rhs);
    ELSE
      lhs := CG.Pop ();
      Expr.Compile (rhs);
      t1 := CG.Pop ();
      ok := CG.Next_label ();
      CG.If_closure (t1, CG.No_label, ok, CG.Always);
      CG.Narrow_fault ();
      CG.Set_label (ok);
      CG.Push (t1);  CG.Free (t1);
      CG.Push (lhs);
      CG.Swap ();
      CG.Free (lhs);
    END;
    CG.Store_indirect (lhs_info.cg_type, 0, lhs_info.size);
  END AssignProcedure;

PROCEDURE AssignRecord (tlhs: Type.T;  rhs: Expr.T;
                        READONLY lhs_info: Type.Info) =
  BEGIN
    AssertSameSize (tlhs, Expr.TypeOf (rhs));
    IF Expr.IsDesignator (rhs)
      THEN Expr.CompileLValue (rhs);
      ELSE Expr.Compile (rhs);
    END;
    CG.Copy (lhs_info.size, overlap := FALSE);
  END AssignRecord;

PROCEDURE AssignSet (tlhs: Type.T;  rhs: Expr.T;
                     READONLY lhs_info: Type.Info) =
  BEGIN
    AssertSameSize (tlhs, Expr.TypeOf (rhs));
    IF Type.IsStructured (tlhs) THEN
      IF Expr.IsDesignator (rhs)
        THEN Expr.CompileLValue (rhs);
        ELSE Expr.Compile (rhs);
      END;
      CG.Copy (lhs_info.size, overlap := FALSE);
    ELSE (* small set *)
      Expr.Compile (rhs);
      CG.Store_indirect (lhs_info.cg_type, 0, lhs_info.size);
    END;
  END AssignSet;

PROCEDURE AssertSameSize (a, b: Type.T) =
  VAR a_info, b_info: Type.Info;
  BEGIN
    EVAL Type.CheckInfo (a, a_info);
    EVAL Type.CheckInfo (b, b_info);
    IF (a_info.size # b_info.size) THEN
      Error.Msg ("INTERNAL ERROR: trying to assign values of differing sizes");
      <* ASSERT FALSE *>
    END;
  END AssertSameSize;

PROCEDURE AssignArray (tlhs: Type.T;  e_rhs: Expr.T;
                       READONLY lhs_info: Type.Info) =
  VAR
    trhs    := Expr.TypeOf (e_rhs);
    openRHS := OpenArrayType.Is (trhs);
    openLHS := OpenArrayType.Is (tlhs);
    alignLHS:= ArrayType.EltAlign (tlhs);
    alignRHS:= ArrayType.EltAlign (trhs);
    lhs, rhs: CG.Val;
    rhs_info: Type.Info;
  BEGIN
    (* capture the lhs & rhs pointers *)
    IF (openRHS) OR (openLHS) THEN lhs := CG.Pop (); END;
    IF Expr.IsDesignator (e_rhs)
      THEN Expr.CompileLValue (e_rhs);
      ELSE Expr.Compile (e_rhs);
    END;
    IF (openRHS) OR (openLHS) THEN rhs := CG.Pop (); END;

    IF openRHS AND openLHS THEN
      GenOpenArraySizeChecks (lhs, rhs, tlhs, trhs);
      CG.Push (lhs);
      CG.Open_elt_ptr (alignLHS);
      CG.Force ();
      CG.Push (rhs);
      CG.Open_elt_ptr (alignRHS);
      CG.Force ();
      GenOpenArrayCopy (rhs, tlhs, trhs);

    ELSIF openRHS THEN
      GenOpenArraySizeChecks (lhs, rhs, tlhs, trhs);
      CG.Push (lhs);
      CG.Push (rhs);
      CG.Open_elt_ptr (alignRHS);
      CG.Copy (lhs_info.size, overlap := TRUE);

    ELSIF openLHS THEN
      EVAL Type.CheckInfo (trhs, rhs_info);
      GenOpenArraySizeChecks (lhs, rhs, tlhs, trhs);
      CG.Push (lhs);
      CG.Open_elt_ptr (alignLHS);
      CG.Push (rhs);
      CG.Copy (rhs_info.size, overlap := TRUE);

    ELSE (* both sides are fixed length arrays *)
      CG.Copy (lhs_info.size, overlap := TRUE);
    END;

    IF (openRHS) OR (openLHS) THEN
      CG.Free (lhs);
      CG.Free (rhs);
    END;
  END AssignArray;

PROCEDURE GenOpenArraySizeChecks (READONLY lhs, rhs: CG.Val;
                                           tlhs, trhs: Type.T) =
  VAR ilhs, irhs, elhs, erhs: Type.T;  n := 0;
  BEGIN
    IF NOT Host.doNarrowChk THEN RETURN END;
    WHILE ArrayType.Split (tlhs, ilhs, elhs)
      AND ArrayType.Split (trhs, irhs, erhs) DO

      IF (ilhs # NIL) AND (irhs # NIL) THEN
        RETURN;
      ELSIF (ilhs # NIL) THEN
        CG.Push (rhs);
        CG.Open_size (n);
        CG.Load_integer (Type.Number (ilhs));
        CG.Check_eq ();
      ELSIF (irhs # NIL) THEN
        CG.Push (lhs);
        CG.Open_size (n);
        CG.Load_integer (Type.Number (irhs));
        CG.Check_eq ();
      ELSE (* both arrays are open *)
        CG.Push (lhs);
        CG.Open_size (n);
        CG.Push (rhs);
        CG.Open_size (n);
        CG.Check_eq ();
      END;
      INC (n);
      tlhs := elhs;
      trhs := erhs;
    END;
  END GenOpenArraySizeChecks;

PROCEDURE GenOpenArrayCopy (READONLY rhs: CG.Val;  tlhs, trhs: Type.T) =
  VAR
    lhs_depth := OpenArrayType.OpenDepth (tlhs);
    rhs_depth := OpenArrayType.OpenDepth (trhs);
  BEGIN
    <*ASSERT (lhs_depth > 0) AND (rhs_depth > 0) *>

    FOR i := 0 TO MIN (lhs_depth, rhs_depth) - 1 DO
      CG.Push (rhs);
      CG.Open_size (i);
      IF (i # 0) THEN CG.Multiply (CG.Type.Word) END;
    END;

    IF (lhs_depth < rhs_depth)
      THEN CG.Copy_n (OpenArrayType.EltPack (tlhs), overlap := TRUE);
      ELSE CG.Copy_n (OpenArrayType.EltPack (trhs), overlap := TRUE);
    END;
  END GenOpenArrayCopy;
---------------------------------------- code generation: checking only ---

PROCEDURE EmitCheck (tlhs: Type.T;  rhs: Expr.T) =
  (* on entry the lhs is compiled and the rhs is prepped. *)
  VAR
    t := Type.Base (tlhs); (* strip renaming and packing *)
    lhs_info, t_info: Type.Info;
  BEGIN
    t := Type.CheckInfo (t, t_info);
    tlhs := Type.CheckInfo (tlhs, lhs_info);

    CASE t_info.class OF
    | Type.Class.Integer, Type.Class.Subrange, Type.Class.Enum =>
        DoCheckOrdinal (tlhs, rhs);
    | Type.Class.Real, Type.Class.Longreal, Type.Class.Extended =>
        DoCheckFloat (rhs);
    | Type.Class.Object, Type.Class.Opaque, Type.Class.Ref =>
        DoCheckReference (tlhs, rhs);
    | Type.Class.Array, Type.Class.OpenArray =>
        DoCheckArray (tlhs, rhs);
    | Type.Class.Procedure =>
        DoCheckProcedure (rhs);
    | Type.Class.Record =>
        DoCheckRecord (tlhs, rhs);
    | Type.Class.Set =>
        DoCheckSet (tlhs, rhs);
    ELSE <* ASSERT FALSE *>
    END;
  END EmitCheck;

PROCEDURE DoCheckOrdinal (tlhs: Type.T;  rhs: Expr.T) =
  VAR min, max : Target.Int;
  BEGIN
    EVAL Type.GetBounds (tlhs, min, max);
    CheckExpr.Emit (rhs, min, max);
  END DoCheckOrdinal;

PROCEDURE DoCheckFloat (rhs: Expr.T) =
  BEGIN
    Expr.Compile (rhs);
  END DoCheckFloat;

PROCEDURE DoCheckReference (tlhs: Type.T;  rhs: Expr.T) =
  BEGIN
    Expr.Compile (rhs);
    IF Host.doNarrowChk THEN Narrow.Emit (tlhs, Expr.TypeOf (rhs)) END;
  END DoCheckReference;

PROCEDURE DoCheckProcedure (rhs: Expr.T) =
  VAR ok: CG.Label;  t1: CG.Val;
  BEGIN
    IF NOT Host.doNarrowChk THEN
      Expr.Compile (rhs);
    ELSIF NOT NeedsClosureCheck (rhs, FALSE) THEN
      Expr.Compile (rhs);
    ELSE
      Expr.Compile (rhs);
      t1 := CG.Pop ();
      ok := CG.Next_label ();
      CG.If_closure (t1, CG.No_label, ok, CG.Always);
      CG.Narrow_fault ();
      CG.Set_label (ok);
      CG.Push (t1);  CG.Free (t1);
    END;
  END DoCheckProcedure;

PROCEDURE DoCheckRecord (tlhs: Type.T;  rhs: Expr.T) =
  BEGIN
    AssertSameSize (tlhs, Expr.TypeOf (rhs));
    IF Expr.IsDesignator (rhs)
      THEN Expr.CompileLValue (rhs);
      ELSE Expr.Compile (rhs);
    END;
  END DoCheckRecord;

PROCEDURE DoCheckSet (tlhs: Type.T;  rhs: Expr.T) =
  BEGIN
    AssertSameSize (tlhs, Expr.TypeOf (rhs));
    IF Type.IsStructured (tlhs) THEN
      IF Expr.IsDesignator (rhs)
        THEN Expr.CompileLValue (rhs);
        ELSE Expr.Compile (rhs);
      END;
    ELSE (* small set *)
      Expr.Compile (rhs);
    END;
  END DoCheckSet;

PROCEDURE DoCheckArray (tlhs: Type.T;  e_rhs: Expr.T) =
  VAR
    trhs    := Expr.TypeOf (e_rhs);
    openRHS := OpenArrayType.Is (trhs);
    openLHS := OpenArrayType.Is (tlhs);
    rhs     : CG.Val;
  BEGIN
    (* evaluate the right-hand side *)
    IF Expr.IsDesignator (e_rhs)
      THEN Expr.CompileLValue (e_rhs);
      ELSE Expr.Compile (e_rhs);
    END;

    IF openLHS THEN
      Error.Msg ("INTERNAL ERROR: AssignStmt.EmitCheck (OPEN ARRAY)");

    ELSIF openRHS THEN
      rhs := CG.Pop ();
      GenOpenArraySizeChk (rhs, tlhs, trhs);
      CG.Push (rhs);
      CG.Open_elt_ptr (ArrayType.EltAlign (trhs));
      CG.Free (rhs);

    ELSE (* both sides are fixed length arrays *)
      (* no more code to generate *)

    END;

  END DoCheckArray;

PROCEDURE GenOpenArraySizeChk (READONLY rhs: CG.Val;  tlhs, trhs: Type.T) =
  VAR ilhs, irhs, elhs, erhs: Type.T;  n := 0;
  BEGIN
    IF NOT Host.doNarrowChk THEN RETURN END;
    WHILE ArrayType.Split (tlhs, ilhs, elhs)
      AND ArrayType.Split (trhs, irhs, erhs)
      AND (irhs = NIL) DO

      CG.Push (rhs);
      CG.Open_size (n);
      CG.Load_integer (Type.Number (ilhs));
      CG.Check_eq ();

      INC (n);
      tlhs := elhs;
      trhs := erhs;
    END;
  END GenOpenArraySizeChk;

BEGIN
END AssignStmt.

interface M3ID is in: