[Ada] Fix missing range check for In/Out parameter with -gnatVa

This plugs another small loophole in the front-end which fails to
generate a range check for a scalar In/Out parameter when -gnatVa is
specified.  This also fixes a few more leaks of the Do_Range_Check flag
on actual parameters, both in regular and -gnatVa modes, as well as a
leak specific to expression function in -gnatp mode.

2019-08-12  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* checks.adb (Insert_Valid_Check): Reset the Do_Range_Check flag
	on the validated object.
	* exp_ch6.adb (Add_Call_By_Copy_Code): Reset the Do_Range_Check
	flag on the actual here, as well as on the Expression if the
	actual is a N_Type_Conversion node.
	(Add_Validation_Call_By_Copy_Code): Generate the incoming range
	check if needed and reset the Do_Range_Check flag on the
	Expression if the actual is a N_Type_Conversion node.
	(Expand_Actuals): Do not reset the Do_Range_Check flag here.
	Generate the incoming range check for In parameters here instead
	of...
	(Expand_Call_Helper): ...here.  Remove redudant condition.
	* sem_res.adb (Resolve_Actuals): Use local variable A_Typ and
	remove obsolete comments.
	(Resolve_Type_Conversion): Do not force the Do_Range_Check flag
	on the operand if range checks are suppressed.

gcc/testsuite/

	* gnat.dg/range_check6.adb: New testcase.

From-SVN: r274280

6 files changed, 94 insertions, 36 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 749d96a..7c7aa83 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,24 @@
 2019-08-12  Eric Botcazou  <ebotcazou@adacore.com>
 
+	* checks.adb (Insert_Valid_Check): Reset the Do_Range_Check flag
+	on the validated object.
+	* exp_ch6.adb (Add_Call_By_Copy_Code): Reset the Do_Range_Check
+	flag on the actual here, as well as on the Expression if the
+	actual is a N_Type_Conversion node.
+	(Add_Validation_Call_By_Copy_Code): Generate the incoming range
+	check if needed and reset the Do_Range_Check flag on the
+	Expression if the actual is a N_Type_Conversion node.
+	(Expand_Actuals): Do not reset the Do_Range_Check flag here.
+	Generate the incoming range check for In parameters here instead
+	of...
+	(Expand_Call_Helper): ...here.  Remove redudant condition.
+	* sem_res.adb (Resolve_Actuals): Use local variable A_Typ and
+	remove obsolete comments.
+	(Resolve_Type_Conversion): Do not force the Do_Range_Check flag
+	on the operand if range checks are suppressed.
+
+2019-08-12  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* checks.adb (Activate_Range_Check): Remove redundant argument.
 	(Generate_Range_Check): Likewise.
 	(Apply_Float_Conversion_Check): Reset the Do_Range_Check flag on
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 813ffec..5d8efce 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -7588,8 +7588,12 @@ package body Checks is
               Suppress => Validity_Check);
 
             Set_Validated_Object (Var_Id, New_Copy_Tree (Exp));
+
+            --  Reset the Do_Range_Check flag so it doesn't leak elsewhere
+
+            Set_Do_Range_Check (Validated_Object (Var_Id), False);
+
             Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc));
-            PV := New_Occurrence_Of (Var_Id, Loc);
 
             --  Copy the Do_Range_Check flag over to the new Exp, so it doesn't
             --  get lost. Floating point types are handled elsewhere.
@@ -7598,6 +7602,8 @@ package body Checks is
                Set_Do_Range_Check (Exp, Do_Range_Check (Original_Node (Exp)));
             end if;
 
+            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:
 
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index f38dd67..3f2d0e3 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1295,7 +1295,14 @@ package body Exp_Ch6 is
             Indic := New_Occurrence_Of (F_Typ, Loc);
          end if;
 
+         --  The new code will be properly analyzed below and the setting of
+         --  the Do_Range_Check flag recomputed so remove the obsolete one.
+
+         Set_Do_Range_Check (Actual, False);
+
          if Nkind (Actual) = N_Type_Conversion then
+            Set_Do_Range_Check (Expression (Actual), False);
+
             V_Typ := Etype (Expression (Actual));
 
             --  If the formal is an (in-)out parameter, capture the name
@@ -1689,6 +1696,20 @@ package body Exp_Ch6 is
          Var_Id  : Entity_Id;
 
       begin
+         --  Generate range check if required
+
+         if Do_Range_Check (Actual) then
+            Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+         end if;
+
+         --  If there is a type conversion in the actual, it will be reinstated
+         --  below, the new instance will be properly analyzed and the setting
+         --  of the Do_Range_Check flag recomputed so remove the obsolete one.
+
+         if Nkind (Actual) = N_Type_Conversion then
+            Set_Do_Range_Check (Expression (Actual), False);
+         end if;
+
          --  Copy the value of the validation variable back into the object
          --  being validated.
 
@@ -2073,14 +2094,6 @@ package body Exp_Ch6 is
                     (Ekind (Formal) = E_In_Out_Parameter
                       and then not In_Subrange_Of (E_Actual, E_Formal)))
             then
-               --  Perhaps the setting back to False should be done within
-               --  Add_Call_By_Copy_Code, since it could get set on other
-               --  cases occurring above???
-
-               if Do_Range_Check (Actual) then
-                  Set_Do_Range_Check (Actual, False);
-               end if;
-
                Add_Call_By_Copy_Code;
             end if;
 
@@ -2194,6 +2207,12 @@ package body Exp_Ch6 is
          --  Processing for IN parameters
 
          else
+            --  Generate range check if required
+
+            if Do_Range_Check (Actual) then
+               Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+            end if;
+
             --  For IN parameters in the bit-packed array case, we expand an
             --  indexed component (the circuit in Exp_Ch4 deliberately left
             --  indexed components appearing as actuals untouched, so that
@@ -3054,16 +3073,6 @@ package body Exp_Ch6 is
       Actual := First_Actual (Call_Node);
       Param_Count := 1;
       while Present (Formal) loop
-
-         --  Generate range check if required
-
-         if Do_Range_Check (Actual)
-           and then Ekind (Formal) = E_In_Parameter
-         then
-            Generate_Range_Check
-              (Actual, Etype (Formal), CE_Range_Check_Failed);
-         end if;
-
          --  Prepare to examine current entry
 
          Prev := Actual;
@@ -3582,9 +3591,7 @@ package body Exp_Ch6 is
                --  or IN OUT parameter. We do reset the Is_Known_Valid flag
                --  since the subprogram could have returned in invalid value.
 
-               if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
-                 and then Is_Assignable (Ent)
-               then
+               if Is_Assignable (Ent) then
                   Sav := Last_Assignment (Ent);
                   Kill_Current_Values (Ent);
                   Set_Last_Assignment (Ent, Sav);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index b668a51..8162b8e 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4517,7 +4517,7 @@ package body Sem_Res is
                end if;
             end if;
 
-            if Etype (A) = Any_Type then
+            if A_Typ = Any_Type then
                Set_Etype (N, Any_Type);
                return;
             end if;
@@ -4539,18 +4539,10 @@ package body Sem_Res is
 
                --  Apply required constraint checks
 
-               --  Gigi looks at the check flag and uses the appropriate types.
-               --  For now since one flag is used there is an optimization
-               --  which might not be done in the IN OUT case since Gigi does
-               --  not do any analysis. More thought required about this ???
-
-               --  In fact is this comment obsolete??? doesn't the expander now
-               --  generate all these tests anyway???
-
-               if Is_Scalar_Type (Etype (A)) then
+               if Is_Scalar_Type (A_Typ) then
                   Apply_Scalar_Range_Check (A, F_Typ);
 
-               elsif Is_Array_Type (Etype (A)) then
+               elsif Is_Array_Type (A_Typ) then
                   Apply_Length_Check (A, F_Typ);
 
                elsif Is_Record_Type (F_Typ)
@@ -4624,9 +4616,8 @@ package body Sem_Res is
                      Apply_Scalar_Range_Check
                        (Expression (A), Etype (Expression (A)), A_Typ);
 
-                     --  In addition, the returned value of the parameter must
-                     --  satisfy the bounds of the object type (see comment
-                     --  below).
+                     --  In addition the return value must meet the constraints
+                     --  of the object type (see the comment below).
 
                      Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
 
@@ -4650,6 +4641,7 @@ package body Sem_Res is
                     and then Ekind (F) = E_Out_Parameter
                   then
                      Apply_Length_Check (A, F_Typ);
+
                   else
                      Apply_Range_Check (A, A_Typ, F_Typ);
                   end if;
@@ -11757,6 +11749,8 @@ package body Sem_Res is
         and then (Is_Fixed_Point_Type (Operand_Typ)
                    or else (not GNATprove_Mode
                              and then Is_Floating_Point_Type (Operand_Typ)))
+        and then not Range_Checks_Suppressed (Target_Typ)
+        and then not Range_Checks_Suppressed (Operand_Typ)
       then
          Set_Do_Range_Check (Operand);
       end if;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fdcb620..90ce94d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-08-12  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/range_check6.adb: New testcase.
+
 2019-08-11  Iain Buclaw  <ibuclaw@gdcproject.org>
 
 	PR d/90601
diff --git a/gcc/testsuite/gnat.dg/range_check6.adb b/gcc/testsuite/gnat.dg/range_check6.adb
new file mode 100644
index 0000000..00fa705
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/range_check6.adb
@@ -0,0 +1,28 @@
+--  { dg-do run }
+--  { dg-options "-O0 -gnatVa" }
+
+procedure Range_Check6 is
+
+  type Byte is range -2**7 .. 2**7-1;
+  for Byte'Size use 8;
+
+  subtype Hour is Byte range 0 .. 23;
+
+  type Rec is record
+    B : Byte;
+  end record;
+
+  procedure Encode (H : in out Hour) is
+  begin
+    null;
+  end;
+
+  R : Rec;
+
+begin
+  R.B := 24;
+  Encode (R.B);
+  raise Program_Error;
+exception
+  when Constraint_Error => null;
+end;