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

[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