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
+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
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.
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.
projects / platform / upstream / gcc.git / commitdiff