From: Arnaud Charlet Date: Wed, 2 Dec 2020 09:15:36 +0000 (-0500) Subject: [Ada] Bad handling of 'Valid_Scalars and arrays X-Git-Tag: basepoints/gcc-13~8129 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=ce32ccfc25a1b12ff9f42b1d9b6150ea128a26ec;p=thirdparty%2Fgcc.git [Ada] Bad handling of 'Valid_Scalars and arrays 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 index 7f63a2d88d13..b3ac7b7a9fc2 100644 --- 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 index d69ef9d4378b..96f6f810e850 100644 --- 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 index 1cf5c6990b14..e3ac718fedf6 100644 --- 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 =>