When using 'Valid_Scalars on unconstrained arrays, the expanded code
includes unchecked conversion to the unconstrained base type, which may
lead to incorrect code being generated.
Fixed by replacing Validated_View by Get_Fullest_View except for records
where it is still needed.
We also take this opportunity to evaluate at compile time many more
cases of 'Valid expansion, in particular related to indexed components
which were never evaluated at compile time.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_attr.adb (Build_Array_VS_Func, Build_Record_VS_Func,
Expand_N_Attribute_Reference): Use Get_Fullest_View instead of
Validated_View.
(Build_Record_VS_Func): Adjust to keep using Validated_View.
(Expand_N_Attribute_Reference) [Valid]: Use
Small_Integer_Type_For to allow for more compile time
evaluations.
* sem_util.adb (Cannot_Raise_Constraint_Error): Add more precise
support for N_Indexed_Component and fix support for
N_Selected_Component which wasn't completely safe.
(List_Cannot_Raise_CE): New.
* libgnat/i-cobol.adb (Valid_Packed): Simplify test to address
new GNAT warning.diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -244,7 +244,7 @@ package body Exp_Attr is
is
Loc : constant Source_Ptr := Sloc (Attr);
Comp_Typ : constant Entity_Id :=
- Validated_View (Component_Type (Array_Typ));
+ Get_Fullest_View (Component_Type (Array_Typ));
function Validate_Component
(Obj_Id : Entity_Id;
@@ -531,7 +531,7 @@ package body Exp_Attr is
is
Field_Id : constant Entity_Id := Defining_Entity (Field);
Field_Nam : constant Name_Id := Chars (Field_Id);
- Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
+ Field_Typ : constant Entity_Id := Get_Fullest_View (Etype (Field_Id));
Attr_Nam : Name_Id;
begin
@@ -733,7 +733,7 @@ package body Exp_Attr is
-- Start of processing for Build_Record_VS_Func
begin
- Typ := Rec_Typ;
+ Typ := Validated_View (Rec_Typ);
-- Use the root type when dealing with a class-wide type
@@ -7329,7 +7329,7 @@ package body Exp_Attr is
-- of the size of the type, not the range of the values). We write
-- this as two tests, rather than a range check, so that static
-- evaluation will easily remove either or both of the checks if
- -- they can be -statically determined to be true (this happens
+ -- they can be statically determined to be true (this happens
-- when the type of X is static and the range extends to the full
-- range of stored values).
@@ -7350,12 +7350,39 @@ package body Exp_Attr is
else
declare
- Uns : constant Boolean
- := Is_Unsigned_Type (Ptyp)
- or else (Is_Private_Type (Ptyp)
- and then Is_Unsigned_Type (Btyp));
+ Uns : constant Boolean :=
+ Is_Unsigned_Type (Ptyp)
+ or else (Is_Private_Type (Ptyp)
+ and then Is_Unsigned_Type (Btyp));
+ Size : Uint;
+ P : Node_Id := Pref;
+
begin
- PBtyp := Integer_Type_For (Esize (Ptyp), Uns);
+ -- If the prefix has an entity, use the Esize from this entity
+ -- to handle in a more user friendly way the case of objects
+ -- or components with a large Size aspect: if a Size aspect is
+ -- specified, we want to read a scalar value as large as the
+ -- Size, unless the Size is larger than
+ -- System_Max_Integer_Size.
+
+ if Nkind (P) = N_Selected_Component then
+ P := Selector_Name (P);
+ end if;
+
+ if Nkind (P) in N_Has_Entity
+ and then Present (Entity (P))
+ and then Esize (Entity (P)) /= Uint_0
+ then
+ if Esize (Entity (P)) <= System_Max_Integer_Size then
+ Size := Esize (Entity (P));
+ else
+ Size := UI_From_Int (System_Max_Integer_Size);
+ end if;
+ else
+ Size := Esize (Ptyp);
+ end if;
+
+ PBtyp := Small_Integer_Type_For (Size, Uns);
Rewrite (N, Make_Range_Test);
end;
end if;
@@ -7385,7 +7412,7 @@ package body Exp_Attr is
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
- Val_Typ : constant Entity_Id := Validated_View (Ptyp);
+ Val_Typ : constant Entity_Id := Get_Fullest_View (Ptyp);
Expr : Node_Id;
begin
diff --git a/gcc/ada/libgnat/i-cobol.adb b/gcc/ada/libgnat/i-cobol.adb
--- a/gcc/ada/libgnat/i-cobol.adb
+++ b/gcc/ada/libgnat/i-cobol.adb
@@ -692,7 +692,7 @@ package body Interfaces.COBOL is
-- For signed, accept all standard and non-standard signs
else
- return Item (Item'Last) in 16#A# .. 16#F#;
+ return Item (Item'Last) >= 16#A#;
end if;
end case;
end Valid_Packed;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2900,6 +2900,32 @@ package body Sem_Util is
-----------------------------------
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
+
+ function List_Cannot_Raise_CE (L : List_Id) return Boolean;
+ -- Returns True if none of the list members cannot possibly raise
+ -- Constraint_Error.
+
+ --------------------------
+ -- List_Cannot_Raise_CE --
+ --------------------------
+
+ function List_Cannot_Raise_CE (L : List_Id) return Boolean is
+ N : Node_Id;
+ begin
+ N := First (L);
+ while Present (N) loop
+ if Cannot_Raise_Constraint_Error (N) then
+ Next (N);
+ else
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end List_Cannot_Raise_CE;
+
+ -- Start of processing for Cannot_Raise_Constraint_Error
+
begin
if Compile_Time_Known_Value (Expr) then
return True;
@@ -2918,8 +2944,14 @@ package body Sem_Util is
when N_Expanded_Name =>
return True;
+ when N_Indexed_Component =>
+ return not Do_Range_Check (Expr)
+ and then Cannot_Raise_Constraint_Error (Prefix (Expr))
+ and then List_Cannot_Raise_CE (Expressions (Expr));
+
when N_Selected_Component =>
- return not Do_Discriminant_Check (Expr);
+ return not Do_Discriminant_Check (Expr)
+ and then Cannot_Raise_Constraint_Error (Prefix (Expr));
when N_Attribute_Reference =>
if Do_Overflow_Check (Expr) then
@@ -2929,21 +2961,7 @@ package body Sem_Util is
return True;
else
- declare
- N : Node_Id;
-
- begin
- N := First (Expressions (Expr));
- while Present (N) loop
- if Cannot_Raise_Constraint_Error (N) then
- Next (N);
- else
- return False;
- end if;
- end loop;
-
- return True;
- end;
+ return List_Cannot_Raise_CE (Expressions (Expr));
end if;
when N_Type_Conversion =>
