[Ada] Test for object too large

[Arnaud Charlet]

Test on object too large on a 32-bit machine were not generating an exception.
This patch adds a special front end test that at least catches some common
cases for array types.

The following program:

procedure obj_too_large is
   function id (x : integer) return integer is
   begin return x; end;
   type m is array
     (integer'first .. id (integer'last)) of integer;
   type p is access m;
   pv : p;
begin
   pv := new m;
end;

executed on a 32-bit machine previously executed silently
(allocating some junk too small array), with the patch it
generates:

raised STORAGE_ERROR : obj_too_large.adb:9 object too large

Tested on x86_64-pc-linux-gnu, committed on trunk

2009-04-15  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Allocator): Install test for object too large

-------------- next part --------------
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 146089)
+++ exp_ch4.adb	(working copy)
@@ -2935,6 +2935,11 @@ package body Exp_Ch4 is
       --  constrain. Such occurrences can be rewritten as aliased objects
       --  and their unrestricted access used instead of the coextension.
 
+      function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
+      --  Given a type E, returns a node representing the code to compute the
+      --  size in storage elements for the given type. This is not as trivial
+      --  as one might expect, as explained in the body.
+
       ---------------------------------------
       -- Complete_Coextension_Finalization --
       ---------------------------------------
@@ -3031,8 +3036,10 @@ package body Exp_Ch4 is
 
                      --  Retrieve the declaration of the body
 
-                     Decl := Parent (Parent (
-                               Corresponding_Body (Parent (Parent (S)))));
+                     Decl :=
+                       Parent
+                         (Parent
+                            (Corresponding_Body (Parent (Parent (S)))));
                      exit;
                   end if;
 
@@ -3161,6 +3168,74 @@ package body Exp_Ch4 is
          Analyze_And_Resolve (N, PtrT);
       end Rewrite_Coextension;
 
+      ------------------------------
+      -- Size_In_Storage_Elements --
+      ------------------------------
+
+      function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
+      begin
+         --  Logically this just returns E'Max_Size_In_Storage_Elements.
+         --  However, the reason for the existence of this function is
+         --  to construct a test for sizes too large, which means near the
+         --  32-bit limit on a 32-bit machine, and precisely the trouble
+         --  is that we get overflows when sizes are greater than 2**31.
+
+         --  So what we end up doing is using this expression for non-array
+         --  types, where it is not quite right, but should be good enough
+         --  most of the time. But for non-packed arrays, instead we compute
+         --  the expression:
+
+         --    number-of-elements * component_type'Max_Size_In_Storage_Elements
+
+         --  which avoids this problem. All this is a big bogus, but it does
+         --  mean we catch common cases of trying to allocate arrays that
+         --  are too large, and which in the absence of a check results in
+         --  undetected chaos ???
+
+         if Is_Array_Type (E) and then Is_Constrained (E) then
+            declare
+               Len : Node_Id;
+               Res : Node_Id;
+
+            begin
+               for J in 1 .. Number_Dimensions (E) loop
+                  Len :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => New_Occurrence_Of (E, Loc),
+                      Attribute_Name => Name_Length,
+                      Expressions    => New_List (
+                        Make_Integer_Literal (Loc, J)));
+
+                  if J = 1 then
+                     Res := Len;
+
+                  else
+                     Res :=
+                       Make_Op_Multiply (Loc,
+                         Left_Opnd  => Res,
+                         Right_Opnd => Len);
+                  end if;
+               end loop;
+
+               return
+                 Make_Op_Multiply (Loc,
+                   Left_Opnd  => Len,
+                   Right_Opnd =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix => New_Occurrence_Of (Component_Type (E), Loc),
+                       Attribute_Name => Name_Max_Size_In_Storage_Elements));
+            end;
+
+            --  Here for other than non-bit-packed array
+
+         else
+            return
+              Make_Attribute_Reference (Loc,
+                Prefix         => New_Occurrence_Of (E, Loc),
+                Attribute_Name => Name_Max_Size_In_Storage_Elements);
+         end if;
+      end Size_In_Storage_Elements;
+
    --  Start of processing for Expand_N_Allocator
 
    begin
@@ -3272,6 +3347,36 @@ package body Exp_Ch4 is
          Complete_Coextension_Finalization;
       end if;
 
+      --  Check for size too large, we do this because the back end misses
+      --  proper checks here and can generate rubbish allocation calls when
+      --  we are near the limit. We only do this for the 32-bit address case
+      --  since that is from a practical point of view where we see a problem.
+
+      if System_Address_Size = 32
+        and then not Storage_Checks_Suppressed (PtrT)
+        and then not Storage_Checks_Suppressed (Dtyp)
+        and then not Storage_Checks_Suppressed (Etyp)
+      then
+         --  The check we want to generate should look like
+
+         --  if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
+         --    raise Storage_Error;
+         --  end if;
+
+         --  where 3.5 gigabytes is a constant large enough to accomodate
+         --  any reasonable request for
+
+         Insert_Action (N,
+           Make_Raise_Storage_Error (Loc,
+             Condition =>
+               Make_Op_Gt (Loc,
+                 Left_Opnd => Size_In_Storage_Elements (Etyp),
+                 Right_Opnd =>
+                   Make_Integer_Literal (Loc,
+                     Intval => Uint_7 * (Uint_2 ** 29))),
+             Reason    => SE_Object_Too_Large));
+      end if;
+
       --  Handle case of qualified expression (other than optimization above)
 
       if Nkind (Expression (N)) = N_Qualified_Expression then