[PATCH] ada: Give better oversize warnings

[Samuel Tardieu]

On  7/06, Arnaud Charlet wrote:

| Sorry, I sent a wrong example.
| 
| Here is another one which generates spurious messages:

Ok, I see what you mean (after having fixed "end B" => "end A" and
adding the missing "pragma Elaborate_Body" in B).

The following patch should take care of it. The test case has also been
enhanced to check for the spurious message in the case you gave (see
M8 type declaration).


GNAT gives a warning when declaring a type whose instance declaration
may raise Storage_Error at execution time. Unfortunately, it does so
only when the discriminant type is one of Integer, Natural or Positive.

The following patch gives a warning as soon as the type requires at
least as many bits as Positive to store its values, provided that its
bounds are known at compile time. The attached test program gives the
following warnings, while it precedently gave none:

    18.    type R3 (D : M3 := 100)
                |
        >>> warning: creation of "R3" object may raise Storage_Error

    25.    type R4 (D : M4 := 100)
                |
        >>> warning: creation of "R4" object may raise Storage_Error

    33.    type R5 (D : M5 := 100)
                |
        >>> warning: creation of "R5" object may raise Storage_Error

    44.    type R7 (D : M7 := 100)
                |
        >>> warning: creation of "R7" object may raise Storage_Error

    gcc/ada/
	* sem_res.adb (Large_Storage_Type): A type is large if it
	requires as many bits as Positive to store its values and its
	bounds are known at compile time.
	* sem_ch13.adb (Minimum_Size): Note that this function returns
	0 if the size is not known at compile time.

    gcc/testsuite/
	* gnat.dg/specs/oversize.ads: New.

Regtested on i686-pc-linux-gnu. Ok for trunk?
---
 gcc/ada/sem_ch13.ads                     |    3 +-
 gcc/ada/sem_res.adb                      |   16 +++++---
 gcc/testsuite/gnat.dg/specs/oversize.ads |   56 ++++++++++++++++++++++++++++++
 3 files changed, 68 insertions(+), 7 deletions(-)
 create mode 100644 gcc/testsuite/gnat.dg/specs/oversize.ads

diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index e7c20bc..175f304 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -64,7 +64,8 @@ package Sem_Ch13 is
    --  the given type, of the size the type would have if it were biased. If
    --  the type is already biased, then Minimum_Size returns the biased size,
    --  regardless of the setting of Biased. Also, fixed-point types are never
-   --  biased in the current implementation.
+   --  biased in the current implementation. If the size is not known at
+   --  compile time, this function returns 0.
 
    procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id);
    --  Expr is an expression for an address clause. This procedure checks
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 8001087..a6d42f7 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -56,6 +56,7 @@ with Sem_Cat;  use Sem_Cat;
 with Sem_Ch4;  use Sem_Ch4;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
 with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Elab; use Sem_Elab;
@@ -471,12 +472,15 @@ package body Sem_Res is
 
                function Large_Storage_Type (T : Entity_Id) return Boolean is
                begin
-                  return
-                    T = Standard_Integer
-                      or else
-                    T = Standard_Positive
-                      or else
-                    T = Standard_Natural;
+                  --  The type is considered large if its bounds are known at
+                  --  compile time and if it requires at least as many bits as
+                  --  a Positive to store the possible values.
+
+                  return Compile_Time_Known_Value (Type_Low_Bound (T))
+                    and then Compile_Time_Known_Value (Type_High_Bound (T))
+                    and then
+                      Minimum_Size (T, Biased => True) >=
+                        Esize (Standard_Integer) - 1;
                end Large_Storage_Type;
 
             begin
diff --git a/gcc/testsuite/gnat.dg/specs/oversize.ads b/gcc/testsuite/gnat.dg/specs/oversize.ads
new file mode 100644
index 0000000..e98c8bd
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/oversize.ads
@@ -0,0 +1,56 @@
+with Ada.Numerics.Discrete_Random;
+
+package Oversize is
+
+   subtype M1 is Integer range 1 .. 200;                    -- Won't trigger
+   type R1 (D : M1 := 100) is record
+      Name : String (1 .. D);
+   end record;
+
+   type M2 is new Integer range 1 .. 200;                   -- Won't trigger
+   for M2'Size use 64;
+   type M2S is array (M2 range <>) of Character;
+   type R2 (D : M2 := 100) is record
+      Name : M2S (1 .. D);
+   end record;
+
+   subtype M3 is Integer;                                   -- Will trigger
+   type R3 (D : M3 := 100) -- { dg-error "may raise Storage_Error" }
+   is record
+      Name : String (1 .. D);
+   end record;
+
+   type M4 is new Positive;                                 -- Will trigger
+   type M4S is array (M4 range <>) of Character;
+   type R4 (D : M4 := 100) -- { dg-error "may raise Storage_Error" }
+   is record
+      Name : M4S (1 .. D);
+   end record;
+
+   type M5 is new Positive;                                 -- Will trigger
+   for M5'Size use Integer'Size - 1;
+   type M5S is array (M5 range <>) of Character;
+   type R5 (D : M5 := 100) -- { dg-error "may raise Storage_Error" }
+   is record
+      Name : M5S (1 .. D);
+   end record;
+
+   subtype M6 is Integer range 1 .. (Integer'Last + 1)/2;   -- Won't trigger
+   type R6 (D : M6 := 100) is record
+      Name : String (1 .. D);
+   end record;
+
+   subtype M7 is Integer range 1 .. (Integer'Last + 1)/2+1; -- Will trigger
+   type R7 (D : M7 := 100) -- { dg-error "may raise Storage_Error" }
+   is record
+      Name : String (1 .. D);
+   end record;
+
+   package P8 is new Ada.Numerics.Discrete_Random (Natural);
+   G8 : P8.Generator;
+   subtype M8 is Integer range 1 .. P8.Random (G8);         -- Won't trigger
+   type R8 (D : M8 := 100) is record
+      Name : String (1 .. D);
+   end record;
+
+end Oversize;
-- 
1.5.6.rc1.256.g8c4da