Ensure that the consequences of indexing into an array with the value of
an uninitialized variable are consistent with Ada RM 13.9.1(11) by
generating additional validity checks in some array indexing cases.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* checks.ads: Define a type Dimension_Set. Add an out-mode
parameter of this new type to Generate_Index_Checks so that
callers can know for which dimensions a check was generated. Add
an in-mode parameter of this new type to
Apply_Subscript_Validity_Checks so that callers can indicate
that no check is needed for certain dimensions.
* checks.adb (Generate_Index_Checks): Implement new
Checks_Generated parameter.
(Apply_Subscript_Validity_Checks): Implement new No_Check_Needed
parameter.
* exp_ch4.adb (Expand_N_Indexed_Component): Call
Apply_Subscript_Validity_Checks in more cases than before. This
includes declaring two new local functions,
(Is_Renamed_Variable_Name,
Type_Requires_Subscript_Validity_Checks_For_Reads): To help in
deciding whether to call Apply_Subscript_Validity_Checks.
Adjust to parameter profile changes in Generate_Index_Checks and
Apply_Subscript_Validity_Checks.diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -3552,9 +3552,12 @@ package body Checks is
-- Apply_Subscript_Validity_Checks --
-------------------------------------
- procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
+ procedure Apply_Subscript_Validity_Checks
+ (Expr : Node_Id;
+ No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is
Sub : Node_Id;
+ Dimension : Pos := 1;
begin
pragma Assert (Nkind (Expr) = N_Indexed_Component);
@@ -3568,11 +3571,16 @@ package body Checks is
-- for the subscript, and that convert will do the necessary validity
-- check.
- Ensure_Valid (Sub, Holes_OK => True);
+ if (No_Check_Needed = Empty_Dimension_Set)
+ or else not No_Check_Needed.Elements (Dimension)
+ then
+ Ensure_Valid (Sub, Holes_OK => True);
+ end if;
-- Move to next subscript
Next (Sub);
+ Dimension := Dimension + 1;
end loop;
end Apply_Subscript_Validity_Checks;
@@ -7233,7 +7241,10 @@ package body Checks is
-- Generate_Index_Checks --
---------------------------
- procedure Generate_Index_Checks (N : Node_Id) is
+ procedure Generate_Index_Checks
+ (N : Node_Id;
+ Checks_Generated : out Dimension_Set)
+ is
function Entity_Of_Prefix return Entity_Id;
-- Returns the entity of the prefix of N (or Empty if not found)
@@ -7268,6 +7279,8 @@ package body Checks is
-- Start of processing for Generate_Index_Checks
begin
+ Checks_Generated.Elements := (others => False);
+
-- Ignore call if the prefix is not an array since we have a serious
-- error in the sources. Ignore it also if index checks are suppressed
-- for array object or type.
@@ -7330,6 +7343,8 @@ package body Checks is
Prefix => New_Occurrence_Of (Etype (A), Loc),
Attribute_Name => Name_Range)),
Reason => CE_Index_Check_Failed));
+
+ Checks_Generated.Elements (1) := True;
end if;
-- General case
@@ -7416,6 +7431,8 @@ package body Checks is
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
Reason => CE_Index_Check_Failed));
+
+ Checks_Generated.Elements (Ind) := True;
end if;
Next_Index (A_Idx);
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -44,6 +44,14 @@ with Urealp; use Urealp;
package Checks is
+ type Bit_Vector is array (Pos range <>) of Boolean;
+ type Dimension_Set (Dimensions : Nat) is
+ record
+ Elements : Bit_Vector (1 .. Dimensions);
+ end record;
+ Empty_Dimension_Set : constant Dimension_Set
+ := (Dimensions => 0, Elements => (others => <>));
+
procedure Initialize;
-- Called for each new main source program, to initialize internal
-- variables used in the package body of the Checks unit.
@@ -721,11 +729,16 @@ package Checks is
-- Do_Range_Check flag, and if it is set, this routine is called, which
-- turns the flag off in code-generation mode.
- procedure Generate_Index_Checks (N : Node_Id);
+ procedure Generate_Index_Checks
+ (N : Node_Id;
+ Checks_Generated : out Dimension_Set);
-- This procedure is called to generate index checks on the subscripts for
-- the indexed component node N. Each subscript expression is examined, and
-- if the Do_Range_Check flag is set, an appropriate index check is
-- generated and the flag is reset.
+ -- The out-mode parameter Checks_Generated indicates the dimensions for
+ -- which checks were generated. Checks_Generated.Dimensions must match
+ -- the number of dimensions of the array type.
-- Similarly, we set the flag Do_Discriminant_Check in the semantic
-- analysis to indicate that a discriminant check is required for selected
@@ -858,10 +871,14 @@ package Checks is
-- The following procedures are used in handling validity checking
- procedure Apply_Subscript_Validity_Checks (Expr : Node_Id);
+ procedure Apply_Subscript_Validity_Checks
+ (Expr : Node_Id;
+ No_Check_Needed : Dimension_Set := Empty_Dimension_Set);
-- Expr is the node for an indexed component. If validity checking and
- -- range checking are enabled, all subscripts for this indexed component
- -- are checked for validity.
+ -- range checking are enabled, each subscript for this indexed component
+ -- whose dimension does not belong to the No_Check_Needed set is checked
+ -- for validity. No_Check_Needed.Dimensions must match the number of
+ -- dimensions of the array type or be zero.
procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id);
-- Expr is a lvalue, i.e. an expression representing the target of an
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -7087,11 +7088,123 @@ package body Exp_Ch4 is
--------------------------------
procedure Expand_N_Indexed_Component (N : Node_Id) is
+
+ Wild_Reads_May_Have_Bad_Side_Effects : Boolean
+ renames Validity_Check_Subscripts;
+ -- This Boolean needs to be True if reading from a bad address can
+ -- have a bad side effect (e.g., a segmentation fault that is not
+ -- transformed into a Storage_Error exception, or interactions with
+ -- memory-mapped I/O) that needs to be prevented. This refers to the
+ -- act of reading itself, not to any damage that might be caused later
+ -- by making use of whatever value was read. We assume here that
+ -- Validity_Check_Subscripts meets this requirement, but introduce
+ -- this declaration in order to document this assumption.
+
+ function Is_Renamed_Variable_Name (N : Node_Id) return Boolean;
+ -- Returns True if the given name occurs as part of the renaming
+ -- of a variable. In this case, the indexing operation should be
+ -- treated as a write, rather than a read, with respect to validity
+ -- checking. This is because the renamed variable can later be
+ -- written to.
+
+ function Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ : Entity_Id) return Boolean;
+ -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
+ -- into an array of characters in order to read an element, it is ok
+ -- if an invalid index value goes undetected. But if it is an array of
+ -- pointers or an array of tasks, the consequences of such a read are
+ -- potentially more severe and so we want to detect an invalid index
+ -- value. This function captures that distinction; this is intended to
+ -- be consistent with the "but does not by itself lead to erroneous
+ -- ... execution" rule of RM 13.9.1(11).
+
+ ------------------------------
+ -- Is_Renamed_Variable_Name --
+ ------------------------------
+
+ function Is_Renamed_Variable_Name (N : Node_Id) return Boolean is
+ Rover : Node_Id := N;
+ begin
+ if Is_Variable (N) then
+ loop
+ declare
+ Rover_Parent : constant Node_Id := Parent (Rover);
+ begin
+ case Nkind (Rover_Parent) is
+ when N_Object_Renaming_Declaration =>
+ return Rover = Name (Rover_Parent);
+
+ when N_Indexed_Component
+ | N_Slice
+ | N_Selected_Component
+ =>
+ exit when Rover /= Prefix (Rover_Parent);
+ Rover := Rover_Parent;
+
+ -- No need to check for qualified expressions or type
+ -- conversions here, mostly because of the Is_Variable
+ -- test. It is possible to have a view conversion for
+ -- which Is_Variable yields True and which occurs as
+ -- part of an object renaming, but only if the type is
+ -- tagged; in that case this function will not be called.
+
+ when others =>
+ exit;
+ end case;
+ end;
+ end loop;
+ end if;
+ return False;
+ end Is_Renamed_Variable_Name;
+
+ -------------------------------------------------------
+ -- Type_Requires_Subscript_Validity_Checks_For_Reads --
+ -------------------------------------------------------
+
+ function Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ : Entity_Id) return Boolean
+ is
+ -- a shorter name for recursive calls
+ function Needs_Check (Typ : Entity_Id) return Boolean renames
+ Type_Requires_Subscript_Validity_Checks_For_Reads;
+ begin
+ if Is_Access_Type (Typ)
+ or else Is_Tagged_Type (Typ)
+ or else Is_Concurrent_Type (Typ)
+ or else (Is_Array_Type (Typ)
+ and then Needs_Check (Component_Type (Typ)))
+ or else (Is_Scalar_Type (Typ)
+ and then Has_Aspect (Typ, Aspect_Default_Value))
+ then
+ return True;
+ end if;
+
+ if Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
+ begin
+ while Present (Comp) loop
+ if Needs_Check (Etype (Comp)) then
+ return True;
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Type_Requires_Subscript_Validity_Checks_For_Reads;
+
+ -- Local constants
+
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
+ -- Start of processing for Expand_N_Indexed_Component
+
begin
-- A special optimization, if we have an indexed component that is
-- selecting from a slice, then we can eliminate the slice, since, for
@@ -7141,11 +7254,42 @@ package body Exp_Ch4 is
-- Generate index and validity checks
- Generate_Index_Checks (N);
+ declare
+ Dims_Checked : Dimension_Set (Dimensions => Number_Dimensions (T));
+ -- Dims_Checked is used to avoid generating two checks (one in
+ -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
+ -- for the same index value in cases where the index check eliminates
+ -- the need for the validity check.
- if Validity_Checks_On and then Validity_Check_Subscripts then
- Apply_Subscript_Validity_Checks (N);
- end if;
+ begin
+ Generate_Index_Checks (N, Checks_Generated => Dims_Checked);
+
+ if Validity_Checks_On
+ and then (Validity_Check_Subscripts
+ or else Wild_Reads_May_Have_Bad_Side_Effects
+ or else Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ)
+ or else Is_Renamed_Variable_Name (N))
+ then
+ if Validity_Check_Subscripts then
+ -- If we index into an array with an uninitialized variable
+ -- and we generate an index check that passes at run time,
+ -- passing that check does not ensure that the variable is
+ -- valid (although it does in the common case where the
+ -- object's subtype matches the index subtype).
+ -- Consider an uninitialized variable with subtype 1 .. 10
+ -- used to index into an array with bounds 1 .. 20 when the
+ -- value of the uninitialized variable happens to be 15.
+ -- The index check will succeed but the variable is invalid.
+ -- If Validity_Check_Subscripts is True then we need to
+ -- ensure validity, so we adjust Dims_Checked accordingly.
+ Dims_Checked.Elements := (others => False);
+ end if;
+
+ Apply_Subscript_Validity_Checks
+ (N, No_Check_Needed => Dims_Checked);
+ end if;
+ end;
-- If selecting from an array with atomic components, and atomic sync
-- is not suppressed for this array type, set atomic sync flag.
