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, ConsExpr;
IMPORT QualifyExpr, Variable, Procedure, OpenArrayType;
IMPORT ProcExpr, ProcType, 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 =
VAR tlhs := Expr.TypeOf (p.lhs);
BEGIN
Expr.PrepLValue (p.lhs);
PrepForEmit (tlhs, p.rhs, initializing := FALSE);
Expr.CompileLValue (p.lhs);
Emit (tlhs, 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 PrepForEmit (tlhs: Type.T; rhs: Expr.T; initializing: BOOLEAN) =
(* When the rhs has the potential to assign its result directly into
a given destination, try to avoid explicit copying. Currently this
means large-result procedure calls and array and record constructors. *)
BEGIN
IF Host.direct_struct_assign
AND Expr.SupportsDirectAssignment (rhs)
AND CanAvoidCopy (tlhs, rhs, initializing)
THEN
Expr.MarkForDirectAssignment (rhs);
ELSE
Expr.Prep (rhs);
END;
END PrepForEmit;
PROCEDURE CanAvoidCopy (tlhs: Type.T; rhs: Expr.T; initializing: BOOLEAN): BOOLEAN =
VAR
t : Type.T;
t_info : Type.Info;
r_info : Type.Info;
base : Expr.T;
BEGIN
t := Type.Base (tlhs); (* strip renaming and packing *)
t := Type.CheckInfo (t, t_info);
IF NOT ProcType.LargeResult (t) THEN
RETURN FALSE;
END;
(* Only attempt to avoid copying records and fixed-length arrays *)
CASE t_info.class OF
| Type.Class.Array =>
(* i.e. lhs is not Type.Class.OpenArray -- check rhs *)
IF OpenArrayType.Is (Expr.TypeOf (rhs)) THEN RETURN FALSE; END;
(* drop out of CASE *)
| Type.Class.Record =>
(* drop out of CASE *)
ELSE
RETURN FALSE;
END;
(* make sure the source and destination are both aligned properly *)
EVAL Type.CheckInfo (tlhs, t_info);
EVAL Type.CheckInfo (Expr.TypeOf (rhs), r_info);
IF (t_info.alignment # r_info.alignment) THEN RETURN FALSE; END;
IF (t_info.class # r_info.class) THEN RETURN FALSE; END;
IF (t_info.class = Type.Class.Packed) THEN RETURN FALSE; END;
IF (r_info.class = Type.Class.Packed) THEN RETURN FALSE; END;
IF CallExpr.Is (rhs) THEN
(* For user procedures, we can always pass in the true destination.
It is the callee's responsibility not to assign to this location
until the final procedure outcome is known, and not to overwrite
the contents until the entire result value has been computed. *)
RETURN CallExpr.IsUserProc (rhs);
END;
(* If the lhs contents are uninitialized (i.e. the Modula-3 spec
only guarantees that the contents will be a member of its type),
then we can write to the final destination incrementally without
worrying about exceptions or references to the original contents. *)
IF NOT initializing THEN RETURN FALSE; END;
IF ConsExpr.Is (rhs) AND Expr.ConstValue (rhs) = NIL THEN
base := ConsExpr.Base (rhs);
IF Expr.SupportsDirectAssignment (base) THEN
Expr.MarkForDirectAssignment (base);
RETURN TRUE;
END;
END;
RETURN FALSE;
END CanAvoidCopy;
PROCEDURE Emit (tlhs: Type.T; rhs: Expr.T) =
(* on entry the lhs is compiled and the rhs is prepped,
preferrably using PrepForEmit() above. *)
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);
IF Expr.IsMarkedForDirectAssignment (rhs) THEN
(* Do the prep now that we have the LHS compiled *)
Expr.Prep (rhs);
Expr.Compile (rhs);
CG.Discard (Type.CGType (Expr.TypeOf (rhs)));
RETURN;
END;
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.stk_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.stk_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.stk_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.stk_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.stk_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);
(* Note: overlap = TRUE because aliased VAR parameters can hide
the open arrays produced by SUBARRAY behind fixed array formal
parameters. *)
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.