File: AssignStmt.m3 Last modified on Fri Jul 7 15:10:54 PDT 1995 by kalsow modified on Thu Jun 15 15:12:38 PDT 1995 by ericv modified on Fri Dec 21 01:24:28 1990 by muller
MODULE--------------------------------------------------------- type checking ---; IMPORT CG, Stmt, StmtRep, Expr, Type, Error, Module, Target, TInt; IMPORT Token, Scanner, CallStmt, Addr, CheckExpr, ErrType; 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 AssignStmt 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; PROCEDURECheckMethod (p: P; VAR cs: Stmt.CheckState) = VAR tlhs: Type.T; rhs_info: Type.Info; 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"); ELSE EVAL Type.CheckInfo (Expr.TypeOf (p.rhs), rhs_info); IF NOT Expr.IsWritable (p.lhs, rhs_info.isTraced) THEN Error.Msg ("left-hand side is read-only"); END; END; Check (tlhs, p.rhs, cs); END CheckMethod; PROCEDURECompile (p: P): Stmt.Outcomes = VAR tlhs := Expr.TypeOf (p.lhs); rhs_info: Type.Info; BEGIN EVAL Type.CheckInfo (Expr.TypeOf (p.rhs), rhs_info); Expr.PrepLValue (p.lhs, traced := rhs_info.isTraced); PrepForEmit (tlhs, p.rhs, initializing := FALSE); Expr.CompileLValue (p.lhs, traced := rhs_info.isTraced); DoEmit (tlhs, p.rhs); Expr.NoteWrite (p.lhs); RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough}; END Compile; PROCEDUREGetOutcome (<*UNUSED*> p: P): Stmt.Outcomes = BEGIN RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough}; END GetOutcome;
PROCEDURE------------------------------------------------------- code generation ---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 IF (tlhs # ErrType.T) AND (trhs # ErrType.T) THEN Error.Msg ("types are not assignable"); END; 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; PROCEDURECheckOrdinal (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-overlapping, non-empty ranges *) Error.Warn (2, "value not assignable (range fault)"); END; END CheckOrdinal; PROCEDURECheckReference (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; PROCEDURECheckProcedure (rhs: Expr.T) = BEGIN IF NeedsClosureCheck (rhs, TRUE) THEN (* may generate a more detailed message *) END; END CheckProcedure; PROCEDURENeedsClosureCheck (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;
PROCEDURE---------------------------------------- code generation: checking only ---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; PROCEDURECanAvoidCopy (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; PROCEDUREDoEmit (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.Longint, 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); | Type.Class.Error => ELSE <*ASSERT FALSE*> END; END DoEmit; PROCEDUREAssignOrdinal (tlhs: Type.T; rhs: Expr.T; READONLY lhs_info: Type.Info) = VAR min, max : Target.Int; BEGIN EVAL Type.GetBounds (tlhs, min, max); CheckExpr.EmitChecks (rhs, min, max, CG.RuntimeError.ValueOutOfRange); CG.Store_indirect (lhs_info.stk_type, 0, lhs_info.size); END AssignOrdinal; PROCEDUREAssignFloat (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; PROCEDUREAssignReference (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; PROCEDUREAssignProcedure (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.Abort (CG.RuntimeError.NarrowFailed); 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; PROCEDUREAssignRecord (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, traced := FALSE); ELSE Expr.Compile (rhs); END; CG.Copy (lhs_info.size, overlap := FALSE); END AssignRecord; PROCEDUREAssignSet (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, traced := FALSE); 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; PROCEDUREAssertSameSize (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; PROCEDUREAssignArray (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, traced := FALSE); 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; PROCEDUREGenOpenArraySizeChecks (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 (Target.Integer.cg_type, Type.Number (ilhs)); CG.Check_eq (Target.Integer.cg_type, CG.RuntimeError.IncompatibleArrayShape); ELSIF (irhs # NIL) THEN CG.Push (lhs); CG.Open_size (n); CG.Load_integer (Target.Integer.cg_type, Type.Number (irhs)); CG.Check_eq (Target.Integer.cg_type, CG.RuntimeError.IncompatibleArrayShape); ELSE (* both arrays are open *) CG.Push (lhs); CG.Open_size (n); CG.Push (rhs); CG.Open_size (n); CG.Check_eq (Target.Integer.cg_type, CG.RuntimeError.IncompatibleArrayShape); END; INC (n); tlhs := elhs; trhs := erhs; END; END GenOpenArraySizeChecks; PROCEDUREGenOpenArrayCopy (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 (Target.Word.cg_type) 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;
PROCEDUREDoEmitCheck (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.Longint, 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 DoEmitCheck; PROCEDUREDoCheckOrdinal (tlhs: Type.T; rhs: Expr.T) = VAR min, max : Target.Int; BEGIN EVAL Type.GetBounds (tlhs, min, max); CheckExpr.EmitChecks (rhs, min, max, CG.RuntimeError.ValueOutOfRange); END DoCheckOrdinal; PROCEDUREDoCheckFloat (rhs: Expr.T) = BEGIN Expr.Compile (rhs); END DoCheckFloat; PROCEDUREDoCheckReference (tlhs: Type.T; rhs: Expr.T) = BEGIN Expr.Compile (rhs); IF Host.doNarrowChk THEN Narrow.Emit (tlhs, Expr.TypeOf (rhs)) END; END DoCheckReference; PROCEDUREDoCheckProcedure (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.Abort (CG.RuntimeError.NarrowFailed); CG.Set_label (ok); CG.Push (t1); CG.Free (t1); END; END DoCheckProcedure; PROCEDUREDoCheckRecord (tlhs: Type.T; rhs: Expr.T) = BEGIN AssertSameSize (tlhs, Expr.TypeOf (rhs)); IF Expr.IsDesignator (rhs) THEN Expr.CompileLValue (rhs, traced := FALSE); ELSE Expr.Compile (rhs); END; END DoCheckRecord; PROCEDUREDoCheckSet (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, traced := FALSE); ELSE Expr.Compile (rhs); END; ELSE (* small set *) Expr.Compile (rhs); END; END DoCheckSet; PROCEDUREDoCheckArray (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, traced := FALSE); 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; PROCEDUREGenOpenArraySizeChk (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 (Target.Integer.cg_type, Type.Number (ilhs)); CG.Check_eq (Target.Integer.cg_type, CG.RuntimeError.IncompatibleArrayShape); INC (n); tlhs := elhs; trhs := erhs; END; END GenOpenArraySizeChk; BEGIN END AssignStmt.