(* Copyright (C) 1989, Digital Equipment Corporation *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* File: AssignStmt.m3 *) (* Last modified on Fri Jul 6 23:47:15 1990 by muller *) (* modified on Wed Feb 14 09:27:32 1990 by kalsow *) MODULE AssignStmt; IMPORT Stmt, StmtRep, Expr, Emit, Type, Error, Target, Module; IMPORT Token, Scanner, CallStmt, CheckExpr, NarrowExpr, Address; IMPORT String, Value, ArrayType, ProcType, NamedExpr, RefType, SetType; IMPORT QualifyExpr, Variable, Procedure, Temp, ValueRep; IMPORT ProcCheckExpr, ProcExpr, ObjectType, SetExpr; TYPE P = Stmt.T OBJECT lhs : Expr.T; rhs : Expr.T; METHODS bind := Bind; check := Check; precompile := Precompile; compile := Compile; END; PROCEDURE Parse (READONLY fail: Token.Set): Stmt.T = VAR e: Expr.T; p: P; BEGIN e := Expr.Parse (fail + Token.Set {Token.T.tASSIGN}); IF (Scanner.cur.token # Token.T.tASSIGN) THEN RETURN CallStmt.New (e) END; p := NEW (P); StmtRep.Init (p); 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; kind:= Kind.assign): Expr.T = (* caller is responsible for generating open array shape checks *) VAR trhs, t, index, element: Type.T; openRHS, openLHS: BOOLEAN; lmin, lmax, rmin, rmax: INTEGER; zz: Expr.T; BEGIN zz := rhs; Expr.TypeCheck (rhs); trhs := Expr.TypeOf (rhs); t := Type.Base (trhs); openRHS := ArrayType.Split (t, index, element) AND (index = NIL); t := Type.Base (tlhs); openLHS := ArrayType.Split (t, index, element) AND (index = NIL); IF (tlhs = trhs) OR Type.IsSubtype (trhs, tlhs) THEN (* OK, except for procedure and array checks *) IF (openRHS) OR (openLHS) THEN (* ok, but caller must generate the runtime checks *) ELSIF 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 *) Type.GetBounds (tlhs, lmin, lmax); Expr.GetBounds (rhs, rmin, rmax); 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, Address.T) THEN (* that is legal only in UNSAFE modules *) IF Module.IsSafe() THEN Error.Msg ("unsafe 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); ELSIF (openRHS) OR (openLHS) THEN (* ok, but caller must check for the "same shape" of the arrays *) ELSE (* nope. *) Error.Msg ("types are not assignable"); END; ELSE Error.Msg ("types are not assignable"); END; IF (rhs # zz) THEN Expr.Bind (rhs); Expr.TypeCheck (rhs); 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; class := Value.ClassOf (obj); IF (class = Value.Class.Procedure) THEN IF (Procedure.IsNested (obj)) THEN Error.Str (obj.name, "cannot assign nested procedures"); RETURN FALSE; ELSE RETURN TRUE; END; 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 Bind (p: P) = BEGIN Expr.Bind (p.lhs); Expr.Bind (p.rhs); END Bind; PROCEDURE Check (p: P) = VAR tlhs: Type.T; BEGIN Expr.TypeCheck (p.lhs); 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); END Check; PROCEDURE Precompile (<*UNUSED*> p: P) = BEGIN END Precompile; PROCEDURE Compile (p: P): Stmt.Outcomes = VAR t, u, t1, t2, t3, t4, range: Type.T; openLHS, openRHS: BOOLEAN; tLHS, tRHS: Temp.T; BEGIN t := Type.Base (Expr.TypeOf (p.rhs)); u := Type.Base (Expr.TypeOf (p.lhs)); openRHS := ArrayType.Split (t, t1, t2) AND (t1 = NIL); openLHS := ArrayType.Split (u, t3, t4) AND (t3 = NIL); tRHS := Expr.Compile (p.rhs); tLHS := Expr.CompileLValue (p.lhs); IF (openRHS) AND (openLHS) THEN Emit.Op ("{\001\n"); Emit.OpI ("register t@* src;\n", Type.Name (ArrayType.OpenImpl (t))); Emit.OpI ("register t@* dest;\n", Type.Name (ArrayType.OpenImpl (u))); Emit.OpT ("src = & @;\n", tRHS); Emit.OpT ("dest = & @;\n", tLHS); GenOpenArraySizeChecks (t, u); Emit.Op ("COPY (src->elts, dest->elts, "); GenOpenArraySize (t, u); Emit.Op (");\n\002};\n"); ELSIF (openRHS) THEN Emit.Op ("{\001\n"); Emit.OpI ("register t@* src;\n", Type.Name (ArrayType.OpenImpl (t))); Emit.OpI ("register t@* dest;", Type.Name (u)); Emit.OpT ("src = & @;\n", tRHS); Emit.OpI ("dest = (t@*)", Type.Name (u)); Emit.OpT ("(& @);\n", tLHS); GenOpenArraySizeChecks (t, u); Emit.OpI ("COPY (src->elts, dest->elts, @);\n", Type.Size (u) DIV Target.CHARSIZE); Emit.Op ("\002};\n"); ELSIF (openLHS) THEN Emit.Op ("{\001\n"); Emit.OpI ("register t@* src;\n", Type.Name (t)); Emit.OpI ("register t@* dest;\n", Type.Name (ArrayType.OpenImpl (u))); Emit.OpI ("src = (t@*)", Type.Name (t)); Emit.OpT ("(& @);\n", tRHS); Emit.OpT ("dest = & @;\n", tLHS); GenOpenArraySizeChecks (t, u); Emit.OpI ("COPY (src->elts, dest->elts, @);\n", Type.Size (t) DIV Target.CHARSIZE); Emit.Op ("\002};\n"); ELSIF SetType.Split (t, range) THEN SetExpr.CompileAssign (range, tLHS, tRHS); ELSIF (Type.Name (t) = Type.Name (u)) THEN Emit.OpTT ("@ = @;\n", tLHS, tRHS); ELSE Emit.OpT ("@ = ", tLHS); Emit.OpI ("(t@) ", Type.Name (u)); Emit.OpT ("@;\n", tRHS); END; Temp.Free (tLHS); Temp.Free (tRHS); RETURN Stmt.Outcomes {Stmt.Outcome.FallThrough}; END Compile; PROCEDURE GenOpenArraySizeChecks (t, u: Type.T) = VAR t1, t2, t3, t4: Type.T; b1, b2: BOOLEAN; i, j: INTEGER; BEGIN VAR b: BOOLEAN := ArrayType.Split (t, t1, t2); BEGIN <* ASSERT b *> END; VAR b: BOOLEAN := ArrayType.Split (u, t3, t4); BEGIN <* ASSERT b *> END; i := 0; LOOP IF (t1 = NIL) AND (t3 = NIL) THEN Emit.OpII ("if (src->size[@] != dest->size[@]) NARROWFAULT;\n", i, i); b1 := ArrayType.Split (t2, t1, t2); b2 := ArrayType.Split (t4, t3, t4); <* ASSERT b1 = b2 *> IF (NOT b1) THEN EXIT END; ELSIF (t1 = NIL) THEN Emit.OpII ("if (src->size[@] != @) NARROWFAULT;\n", i, Type.Number (t3)); b1 := ArrayType.Split (t2, t1, t2); b2 := ArrayType.Split (t4, t3, t4); <* ASSERT b1 = b2 *> IF (NOT b1) THEN EXIT END; ELSIF (t3 = NIL) THEN Emit.OpII ("if (dest->size[@] != @) NARROWFAULT;\n", i, Type.Number (t1)); b1 := ArrayType.Split (t2, t1, t2); b2 := ArrayType.Split (t4, t3, t4); <* ASSERT b1 = b2 *> IF (NOT b1) THEN EXIT END; ELSE (* no more variable sized dimensions *) i := Type.Size (t2); j := Type.Size (t4); <* ASSERT i = j *> EXIT; END; INC (i); END; END GenOpenArraySizeChecks; PROCEDURE GenOpenArraySize (t, u: Type.T) = VAR t1, t2, t3, t4: Type.T; b1, b2: BOOLEAN; i: INTEGER; BEGIN VAR b: BOOLEAN := ArrayType.Split (t, t1, t2); BEGIN <* ASSERT b *> END; VAR b: BOOLEAN := ArrayType.Split (u, t3, t4); BEGIN <* ASSERT b *> END; i := 0; WHILE (t1 = NIL) AND (t3 = NIL) DO Emit.OpI ("(src->size[@]) * ", i); b1 := ArrayType.Split (t2, t1, t2); b2 := ArrayType.Split (t4, t3, t4); <* ASSERT b1 = b2 *> IF (NOT b1) THEN t1 := t2(* force EXIT *) END; INC (i); END; IF (t1 = NIL) THEN Emit.OpI ("@", Type.Size (t4) DIV Target.CHARSIZE); ELSE Emit.OpI ("@", Type.Size (t2) DIV Target.CHARSIZE); END; END GenOpenArraySize; BEGIN END AssignStmt.