Copyright (C) 1994, Digital Equipment Corp.File: AssignStmt.m3
MODULE--------------------------------------------------------- type checking ---; 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 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; 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; PROCEDURECompile (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; 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 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; 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-overlappling, 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 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 ---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; 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.Emit (rhs, min, max); CG.Store_indirect (lhs_info.cg_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.cg_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.cg_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.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; 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); 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); 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; 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); 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; 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 (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; 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 (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;
PROCEDUREEmitCheck (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; PROCEDUREDoCheckOrdinal (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; 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.Narrow_fault (); 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); 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); 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); 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 (Type.Number (ilhs)); CG.Check_eq (); INC (n); tlhs := elhs; trhs := erhs; END; END GenOpenArraySizeChk; BEGIN END AssignStmt.