+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.
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.
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:
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
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.
(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;
-- 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
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;
-- 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);
end if;
end if;
- if Etype (A) = Any_Type then
+ if A_Typ = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
-- 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)
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);
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;
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;
+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
--- /dev/null
+-- { 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;
projects / gcc.git / commitdiff