[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 7f63a2d88d13924a7a5954027192986fd2fb60a9..b3ac7b7a9fc2834bca089d613dd2cff16d756b9a 100644 (file)
--- 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 d69ef9d4378b655679cf038cec1e772e70060fe6..96f6f810e85015a75e4ac82e2ccc7a126086bfda 100644 (file)
--- 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 1cf5c6990b1434cbd7946e35ccda0c32577e664f..e3ac718fedf6d669544d54cf5b3139be2e1d3b40 100644 (file)
--- 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 =>