[Ada] Missing range check on assignment to bit-packed array

This patch adds an explicit range check on an assignment to a component
of a bit-packed array, when the index type of the array is an
enumeration type with a non-standard representation,

Executing the following:

   gnatmake -f -gnata -q main
   ./main

must yield:

   1 is invalid
    4097 is invalid
    4116 is invalid
    4117 is invalid
    4118 is invalid
    4119 is invalid
    4120 is invalid
    4121 is invalid

----
with Example;     use Example;
with My_Types;    use My_Types;
with Text_IO; use Text_IO;

procedure main is
begin
   --We try to access an invalid array location.
    begin
     dummy(idx    => 1,    action => DISABLE);
    exception
       when others => Text_IO.Put_Line ("1 is invalid");
    end;

      for I in typ_uint32'(16#1000#) .. 16#101E#  loop
         declare
         begin
            --  Text_IO.Put_Line (typ_uint32'image(I) & " OK");
            Dummy (Idx => I, action => Enable);
        exception
            when others => put_line (typ_uint32'Image (I) & " is invalid");
         end;
      end loop;
end;
----
with Interfaces;     use Interfaces;

package My_Types is

   subtype typ_bool is boolean;

   type typ_uint32 is new Interfaces.Unsigned_32;
   subtype typ_uint16 is typ_uint32 range 0..2**16 - 1;

   type typ_dis_en is ( DISABLE, ENABLE );
   for typ_dis_en'size use 32;
   for typ_dis_en use ( DISABLE => 0, ENABLE  => 1 );

type typ_rid is
   (
      RID_0,
      RID_2,
      RID_3,
      RID_4,
      RID_5,
      RID_6,
      RID_7,
      RID_8,
      RID_9,
      RID_10,
      RID_11,
      RID_12,
      RID_13,
      RID_14,
      RID_15,
      RID_16,
      RID_17,
      RID_18,
      RID_19,
      RID_26,
      RID_27,
      RID_28,
      RID_29,
      RID_30
   );
for typ_rid use
   (
      RID_0   =>  16#1000#,
      RID_2   =>  16#1002#,
      RID_3   =>  16#1003#,
      RID_4   =>  16#1004#,
      RID_5   =>  16#1005#,
      RID_6   =>  16#1006#,
      RID_7   =>  16#1007#,
      RID_8   =>  16#1008#,
      RID_9   =>  16#1009#,
      RID_10  =>  16#100A#,
      RID_11  =>  16#100B#,
      RID_12  =>  16#100C#,
      RID_13  =>  16#100D#,
      RID_14  =>  16#100E#,
      RID_15  =>  16#100F#,
      RID_16  =>  16#1010#,
      RID_17  =>  16#1011#,
      RID_18  =>  16#1012#,
      RID_19  =>  16#1013#,
      RID_26  =>  16#101A#,
      RID_27  =>  16#101B#,
      RID_28  =>  16#101C#,
      RID_29  =>  16#101D#,
      RID_30  =>  16#101E#
   );
for typ_rid'size use 16;

end My_Types;

----
with My_Types;

package  Example is

procedure Check;
procedure dummy
   (
     idx        : in My_Types.typ_uint32;
     action     : in My_Types.typ_dis_en
   );

end Example;
----
with Text_IO; use Text_IO;
with Unchecked_Conversion;
with my_types; use my_types;
package body Example is

   type typ_rid_sts is array (My_Types.typ_rid)
      of My_Types.typ_bool;
   for typ_rid_sts'component_size use 1;

   is_rid_en : typ_rid_sts :=
      (TRUE, false, True, False, true, False, True, false, True, False,
      TRUE, false, True, False, true, False, True, false, True, False,
      TRUE, false, True, False);

   procedure Check is
   begin
     pragma Assert (for all I in is_rid_en'range => is_rid_en (I));
   end Check;

   function toRidEvt is new Unchecked_Conversion
      (
         -- Defining source and target types
         source => My_Types.typ_uint16,
         target => My_Types.typ_rid
      );

   procedure dummy (
     idx        : in My_Types.typ_uint32;
     action     : in My_Types.typ_dis_en)
   is
      rid_evt      : My_Types.typ_rid;

   begin

      rid_evt := toRidEvt(idx);

      if action = My_Types.ENABLE
      then
         is_rid_en(rid_evt) := TRUE;
      else
         is_rid_en(rid_evt) := FALSE;
      end if;

   end dummy;
end Example;

2019-07-05  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_pakd.adb (Expand_Bit_Packed_Element_Set): Add explicit
	range checks when the index type of the bit-packed array is an
	enumeration type with a non-standard representation,

From-SVN: r273119

2 files changed, 38 insertions, 1 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9658895..8daf38b 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-05  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_pakd.adb (Expand_Bit_Packed_Element_Set): Add explicit
+	range checks when the index type of the bit-packed array is an
+	enumeration type with a non-standard representation,
+
 2019-07-05  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_res.adb (Is_Control_Flow_Statement): Delay statements
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index a7d2a0d..9a659fa 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -1022,7 +1022,9 @@ package body Exp_Pakd is
       Ass_OK : constant Boolean := Assignment_OK (Lhs);
       --  Used to preserve assignment OK status when assignment is rewritten
 
-      Rhs : Node_Id := Expression (N);
+      Expr : Node_Id;
+
+      Rhs  : Node_Id := Expression (N);
       --  Initially Rhs is the right hand side value, it will be replaced
       --  later by an appropriate unchecked conversion for the assignment.
 
@@ -1140,6 +1142,35 @@ package body Exp_Pakd is
          Analyze_And_Resolve (Rhs, Ctyp);
       end if;
 
+      --  If any of the indices has a nonstandard representation, introduce
+      --  the proper Rep_To_Pos conversion, which in turn will generate index
+      --  checks when needed. We do this on a copy of the index expression,
+      --  rather that rewriting the LHS altogether.
+
+      Expr := First (Expressions (Lhs));
+      while Present (Expr) loop
+         declare
+            Loc       : constant Source_Ptr := Sloc (Expr);
+            Expr_Typ  : constant Entity_Id := Etype (Expr);
+            Expr_Copy : Node_Id;
+
+         begin
+            if Is_Enumeration_Type (Expr_Typ)
+              and then Has_Non_Standard_Rep (Expr_Typ)
+            then
+               Expr_Copy :=
+                 Make_Attribute_Reference (Loc,
+                   Prefix         => New_Occurrence_Of (Expr_Typ, Loc),
+                   Attribute_Name => Name_Pos,
+                   Expressions    => New_List (Relocate_Node (Expr)));
+               Set_Parent (Expr_Copy, N);
+               Analyze_And_Resolve (Expr_Copy, Standard_Natural);
+            end if;
+         end;
+
+         Next (Expr);
+      end loop;
+
       --  Case of component size 1,2,4 or any component size for the modular
       --  case. These are the cases for which we can inline the code.