checks.adb (Insert_Valid_Check): Code cleanup.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Insert_Valid_Check): Code cleanup.
	* exp_ch6.adb (Add_Validation_Call_By_Copy_Code): New routine.
	(Expand_Actuals): Generate proper copy-back for a validation
	variable when it acts as the argument of a type conversion.
	* sem_util.adb (Is_Validation_Variable_Reference): Augment the
	predicate to operate on type qualifications.

From-SVN: r247180

gcc/ada/ChangeLog

 2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* checks.adb (Insert_Valid_Check): Code cleanup.
+	* exp_ch6.adb (Add_Validation_Call_By_Copy_Code): New routine.
+	(Expand_Actuals): Generate proper copy-back for a validation
+	variable when it acts as the argument of a type conversion.
+	* sem_util.adb (Is_Validation_Variable_Reference): Augment the
+	predicate to operate on type qualifications.
+
+2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* sem_prag.adb, exp_ch6.adb, binde.adb, sem_disp.adb, s-fileio.adb:
 	Minor reformatting.
 

gcc/ada/checks.adb

@@ -7286,10 +7286,11 @@ package body Checks is
 
       declare
          DRC : constant Boolean := Do_Range_Check (Exp);
-         CE  : Node_Id;
-         Obj : Node_Id;
-         PV  : Node_Id;
-         Var : Entity_Id;
+
+         CE     : Node_Id;
+         Obj    : Node_Id;
+         PV     : Node_Id;
+         Var_Id : Entity_Id;
 
       begin
          Set_Do_Range_Check (Exp, False);
@@ -7301,14 +7302,14 @@ package body Checks is
          --    1) The evaluation of the object results in only one read in the
          --       case where the object is atomic or volatile.
 
-         --         Temp ... := Object;  --  read
+         --         Var ... := Object;  --  read
 
          --    2) The captured value is the one verified by attribute 'Valid.
          --       As a result the object is not evaluated again, which would
          --       result in an unwanted read in the case where the object is
          --       atomic or volatile.
 
-         --         if not Temp'Valid then    --  OK, no read of Object
+         --         if not Var'Valid then     --  OK, no read of Object
 
          --         if not Object'Valid then  --  Wrong, extra read of Object
 
@@ -7316,7 +7317,7 @@ package body Checks is
          --       As a result the object is not evaluated again, in the same
          --       vein as 2).
 
-         --         ... Temp ...    --  OK, no read of Object
+         --         ... Var ...     --  OK, no read of Object
 
          --         ... Object ...  --  Wrong, extra read of Object
 
@@ -7326,24 +7327,24 @@ package body Checks is
 
          --         procedure Call (Val : in out ...);
 
-         --         Temp : ... := Object;   --  read Object
-         --         if not Temp'Valid then  --  validity check
-         --         Call (Temp);            --  modify Temp
-         --         Object := Temp;         --  update Object
+         --         Var : ... := Object;   --  read Object
+         --         if not Var'Valid then  --  validity check
+         --         Call (Var);            --  modify Var
+         --         Object := Var;         --  update Object
 
          if Is_Variable (Exp) then
-            Obj := New_Copy_Tree (Exp);
-            Var := Make_Temporary (Loc, 'T', Exp);
+            Obj    := New_Copy_Tree (Exp);
+            Var_Id := Make_Temporary (Loc, 'T', Exp);
 
             Insert_Action (Exp,
               Make_Object_Declaration (Loc,
-                Defining_Identifier => Var,
+                Defining_Identifier => Var_Id,
                 Object_Definition   => New_Occurrence_Of (Typ, Loc),
                 Expression          => Relocate_Node (Exp)));
-            Set_Validated_Object (Var, Obj);
+            Set_Validated_Object (Var_Id, Obj);
 
-            Rewrite (Exp, New_Occurrence_Of (Var, Loc));
-            PV := New_Occurrence_Of (Var, Loc);
+            Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc));
+            PV := New_Occurrence_Of (Var_Id, Loc);
 
          --  Otherwise the expression does not denote a variable. Force its
          --  evaluation by capturing its value in a constant. Generate:

gcc/ada/exp_ch6.adb

@@ -1180,6 +1180,10 @@ package body Exp_Ch6 is
       --  that all that is needed is to simply create a temporary and copy
       --  the value in and out of the temporary.
 
+      procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
+      --  Perform copy-back for actual parameter Act which denotes a validation
+      --  variable.
+
       procedure Check_Fortran_Logical;
       --  A value of type Logical that is passed through a formal parameter
       --  must be normalized because .TRUE. usually does not have the same
@@ -1618,6 +1622,85 @@ package body Exp_Ch6 is
          end if;
       end Add_Simple_Call_By_Copy_Code;
 
+      --------------------------------------
+      -- Add_Validation_Call_By_Copy_Code --
+      --------------------------------------
+
+      procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
+         Expr    : Node_Id;
+         Obj     : Node_Id;
+         Obj_Typ : Entity_Id;
+         Var     : Node_Id;
+         Var_Id  : Entity_Id;
+
+      begin
+         Var := Act;
+
+         --  Use the expression when the context qualifies a reference in some
+         --  fashion.
+
+         while Nkind_In (Var, N_Qualified_Expression,
+                              N_Type_Conversion,
+                              N_Unchecked_Type_Conversion)
+         loop
+            Var := Expression (Var);
+         end loop;
+
+         --  Copy the value of the validation variable back into the object
+         --  being validated.
+
+         if Is_Entity_Name (Var) then
+            Var_Id  := Entity (Var);
+            Obj     := Validated_Object (Var_Id);
+            Obj_Typ := Etype (Obj);
+
+            Expr := New_Occurrence_Of (Var_Id, Loc);
+
+            --  A type conversion is needed when the validation variable and
+            --  the validated object carry different types. This case occurs
+            --  when the actual is qualified in some fashion.
+
+            --    Common:
+            --      subtype Int is Integer range ...;
+            --      procedure Call (Val : in out Integer);
+
+            --    Original:
+            --      Object : Int;
+            --      Call (Integer (Object));
+
+            --    Expanded:
+            --      Object : Int;
+            --      Var : Integer := Object;  --  conversion to base type
+            --      if not Var'Valid then     --  validity check
+            --      Call (Var);               --  modify Var
+            --      Object := Int (Var);      --  conversion to subtype
+
+            if Etype (Var_Id) /= Obj_Typ then
+               Expr :=
+                 Make_Type_Conversion (Loc,
+                   Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
+                   Expression   => Expr);
+            end if;
+
+            --  Generate:
+            --    Object := Var;
+            --      <or>
+            --    Object := Object_Type (Var);
+
+            Append_To (Post_Call,
+              Make_Assignment_Statement (Loc,
+                Name       => Obj,
+                Expression => Expr));
+
+         --  If the flow reaches this point, then this routine was invoked with
+         --  an actual which does not denote a validation variable.
+
+         else
+            pragma Assert (False);
+            null;
+         end if;
+      end Add_Validation_Call_By_Copy_Code;
+
       ---------------------------
       -- Check_Fortran_Logical --
       ---------------------------
@@ -1831,10 +1914,26 @@ package body Exp_Ch6 is
                end if;
             end if;
 
-            --  If argument is a type conversion for a type that is passed
-            --  by copy, then we must pass the parameter by copy.
+            --  The actual denotes a variable which captures the value of an
+            --  object for validation purposes. Add a copy-back to reflect any
+            --  potential changes in value back into the original object.
+
+            --    Var : ... := Object;
+            --    if not Var'Valid then  --  validity check
+            --    Call (Var);            --  modify var
+            --    Object := Var;         --  update Object
+
+            --  This case is given higher priority because the subsequent check
+            --  for type conversion may add an extra copy of the variable and
+            --  prevent proper value propagation back in the original object.
+
+            if Is_Validation_Variable_Reference (Actual) then
+               Add_Validation_Call_By_Copy_Code (Actual);
 
-            if Nkind (Actual) = N_Type_Conversion
+            --  If argument is a type conversion for a type that is passed by
+            --  copy, then we must pass the parameter by copy.
+
+            elsif Nkind (Actual) = N_Type_Conversion
               and then
                 (Is_Numeric_Type (E_Formal)
                   or else Is_Access_Type (E_Formal)
@@ -1913,21 +2012,6 @@ package body Exp_Ch6 is
             then
                Add_Call_By_Copy_Code;
 
-            --  The actual denotes a variable which captures the value of an
-            --  object for validation purposes. Add a copy-back to reflect any
-            --  potential changes in value back into the original object.
-
-            --    Temp : ... := Object;
-            --    if not Temp'Valid then ...
-            --    Call (Temp);
-            --    Object := Temp;
-
-            elsif Is_Validation_Variable_Reference (Actual) then
-               Append_To (Post_Call,
-                 Make_Assignment_Statement (Loc,
-                   Name       => Validated_Object (Entity (Actual)),
-                   Expression => New_Occurrence_Of (Entity (Actual), Loc)));
-
             elsif Nkind (Actual) = N_Indexed_Component
               and then Is_Entity_Name (Prefix (Actual))
               and then Has_Volatile_Components (Entity (Prefix (Actual)))

gcc/ada/sem_util.adb

@@ -15282,12 +15282,32 @@ package body Sem_Util is
    --------------------------------------
 
    function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
+      Var    : Node_Id;
+      Var_Id : Entity_Id;
+
    begin
+      Var := N;
+
+      --  Use the expression when the context qualifies a reference in some
+      --  fashion.
+
+      while Nkind_In (Var, N_Qualified_Expression,
+                           N_Type_Conversion,
+                           N_Unchecked_Type_Conversion)
+      loop
+         Var := Expression (Var);
+      end loop;
+
+      Var_Id := Empty;
+
+      if Is_Entity_Name (Var) then
+         Var_Id := Entity (Var);
+      end if;
+
       return
-        Is_Entity_Name (N)
-          and then Present (Entity (N))
-          and then Ekind (Entity (N)) = E_Variable
-          and then Present (Validated_Object (Entity (N)));
+        Present (Var_Id)
+          and then Ekind (Var_Id) = E_Variable
+          and then Present (Validated_Object (Var_Id));
    end Is_Validation_Variable_Reference;
 
    ----------------------------