This patch computes a guard for a storage error on an object declaration for an array type with a modular index type with the size of Long_Long_Integer. Special processing is needed in this case to compute reliably the size of the object, and eventually to raise Storage_Error, when wrap-around arithmetic might compute a meangingless size for the object.
Executing: gnatmake -q -gnatws -fstack-check fail fail must yield: raised STORAGE_ERROR : fail.adb:6 object too large --- with Mod_Array; use Mod_Array; procedure Fail is Str : String (1 .. 2014); function Create (Last : My_Index) return A is R : A (0 .. Last); for R'Address use Str'Address; pragma Import (Ada, R); begin return R; end Create; function Create2 (Last : My_Index) return A is R : A (0 .. Last); begin return R; end Create2; C : constant A := Create (My_Index'Last); begin if C'Length = 0 then raise Program_Error; end if; if Create2 (My_Index'Last)'Length = 0 then raise Program_Error; end if; end Fail; --- package Mod_Array with SPARK_mode is type My_Index is mod 2 ** 64; type redundant is new Long_Long_Integer; type A is array (My_Index range <>) of Boolean with Pack; function My_Length (X : A) return My_Index is (X'Length); end Mod_Array; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-01-23 Ed Schonberg <schonb...@adacore.com> * exp_ch3.adb (Check_Large_Modular_Array): New procedure, subsidiary to Expand_N_Object_ Declaration, to compute a guard on an object declaration for an array type with a modular index type with the size of Long_Long_Integer. Special processing is needed in this case to compute reliably the size of the object, and eventually to raise Storage_Error, when wrap-around arithmetic might compute a meangingless size for the object.
Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 244773) +++ exp_ch3.adb (working copy) @@ -5465,6 +5465,13 @@ -- value, it may be possible to build an equivalent aggregate instead, -- and prevent an actual call to the initialization procedure. + procedure Check_Large_Modular_Array; + -- Check that the size of the array can be computed without overflow, + -- and generate a Storage_Error otherwise. This is only relevant for + -- array types whose index in a (mod 2**64) type, where wrap-around + -- arithmetic might yield a meaningless value for the length of the + -- array, or its corresponding attribute. + procedure Default_Initialize_Object (After : Node_Id); -- Generate all default initialization actions for object Def_Id. Any -- new code is inserted after node After. @@ -5603,6 +5610,58 @@ end Build_Equivalent_Aggregate; ------------------------------- + -- Check_Large_Modular_Array -- + ------------------------------- + + procedure Check_Large_Modular_Array is + Index_Typ : Entity_Id; + + begin + if Is_Array_Type (Typ) + and then Is_Modular_Integer_Type (Etype (First_Index (Typ))) + then + -- To prevent arithmetic overflow with large values, we + -- raise Storage_Error under the following guard: + -- + -- (Arr'Last / 2 - Arr'First / 2) > (Typ'Last - 1) / 2 + + -- This takes care of the boundary case, but it is preferable + -- to use a smaller limit, because even on 64-bit architectures + -- an array of more than 2 ** 30 bytes is likely to raise + -- Storage_Error. + + Index_Typ := Etype (First_Index (Typ)); + if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then + Insert_Action (N, + Make_Raise_Storage_Error (Loc, + Condition => + Make_Op_Ge (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Last), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_2)), + Right_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_First), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_2))), + Right_Opnd => + Make_Integer_Literal (Loc, (Uint_2 ** 30))), + Reason => SE_Object_Too_Large)); + end if; + end if; + end Check_Large_Modular_Array; + + ------------------------------- -- Default_Initialize_Object -- ------------------------------- @@ -6012,6 +6071,8 @@ Build_Master_Entity (Def_Id); end if; + Check_Large_Modular_Array; + -- Default initialization required, and no expression present if No (Expr) then