From 7f4b58c2582067694e7f9e8944187ac5794579d0 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 23 May 2018 10:23:54 +0000 Subject: [PATCH] [Ada] Spurious Storage_Error on imported array This patch moves the check which verifies that a large modular array is created from expansion to freezing in order to take interfacing pragmas in account. The check is no longer performed on imported objects because no object is created in that case. 2018-05-23 Hristian Kirtchev gcc/ada/ * exp_ch3.adb (Check_Large_Modular_Array): Moved to Freeze. (Expand_N_Object_Declaration): Do not check for a large modular array here. * freeze.adb (Check_Large_Modular_Array): Moved from Exp_Ch3. (Freeze_Object_Declaration): Code cleanup. Check for a large modular array. * sem_ch3.adb: Minor reformatting. gcc/testsuite/ * gnat.dg/import2.adb: New testcase. From-SVN: r260597 --- gcc/ada/ChangeLog | 10 ++ gcc/ada/exp_ch3.adb | 64 ----------- gcc/ada/freeze.adb | 172 +++++++++++++++++++++++------- gcc/ada/sem_ch3.adb | 3 +- gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gnat.dg/import2.adb | 11 ++ 6 files changed, 160 insertions(+), 104 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/import2.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2be21310c98..e1f83b5e013 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2018-05-23 Hristian Kirtchev + + * exp_ch3.adb (Check_Large_Modular_Array): Moved to Freeze. + (Expand_N_Object_Declaration): Do not check for a large modular array + here. + * freeze.adb (Check_Large_Modular_Array): Moved from Exp_Ch3. + (Freeze_Object_Declaration): Code cleanup. Check for a large modular + array. + * sem_ch3.adb: Minor reformatting. + 2018-05-23 Ed Schonberg * einfo.ads: New attribute on types: Predicated_Parent, to simplify the diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f4d2117b67d..3c1bedef96d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5606,13 +5606,6 @@ package body Exp_Ch3 is -- 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 Count_Default_Sized_Task_Stacks (Typ : Entity_Id; Pri_Stacks : out Int; @@ -5759,61 +5752,6 @@ package body Exp_Ch3 is end if; 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) > (2 ** 30) - - -- 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; - ------------------------------------- -- Count_Default_Sized_Task_Stacks -- ------------------------------------- @@ -6434,8 +6372,6 @@ package body Exp_Ch3 is Build_Master_Entity (Def_Id); end if; - Check_Large_Modular_Array; - -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations -- restrictions are active then default-sized secondary stacks are -- generated by the binder and allocated by SS_Init. To provide the diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 032dcf516f8..6643c5c26b0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3187,6 +3187,100 @@ package body Freeze is ------------------------------- procedure Freeze_Object_Declaration (E : Entity_Id) is + + procedure Check_Large_Modular_Array (Typ : Entity_Id); + -- Check that the size of array type Typ can be computed without + -- overflow, and generates a Storage_Error otherwise. This is only + -- relevant for array types whose index is a (mod 2**64) type, where + -- wrap-around arithmetic might yield a meaningless value for the + -- length of the array, or its corresponding attribute. + + ------------------------------- + -- Check_Large_Modular_Array -- + ------------------------------- + + procedure Check_Large_Modular_Array (Typ : Entity_Id) is + Obj_Loc : constant Source_Ptr := Sloc (E); + Idx_Typ : Entity_Id; + + begin + -- Nothing to do when expansion is disabled because this routine + -- generates a runtime check. + + if not Expander_Active then + return; + + -- Nothing to do for String literal subtypes because their index + -- cannot be a modular type. + + elsif Ekind (Typ) = E_String_Literal_Subtype then + return; + + -- Nothing to do for an imported object because the object will + -- be created on the exporting side. + + elsif Is_Imported (E) then + return; + + -- Nothing to do for unconstrained array types. This case arises + -- when the object declaration is illegal. + + elsif not Is_Constrained (Typ) then + return; + end if; + + Idx_Typ := Etype (First_Index (Typ)); + + -- To prevent arithmetic overflow with large values, we raise + -- Storage_Error under the following guard: + -- + -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30) + -- + -- 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. + + if Is_Modular_Integer_Type (Idx_Typ) + and then RM_Size (Idx_Typ) = RM_Size (Standard_Long_Long_Integer) + then + Insert_Action (Declaration_Node (E), + Make_Raise_Storage_Error (Obj_Loc, + Condition => + Make_Op_Ge (Obj_Loc, + Left_Opnd => + Make_Op_Subtract (Obj_Loc, + Left_Opnd => + Make_Op_Divide (Obj_Loc, + Left_Opnd => + Make_Attribute_Reference (Obj_Loc, + Prefix => + New_Occurrence_Of (Typ, Obj_Loc), + Attribute_Name => Name_Last), + Right_Opnd => + Make_Integer_Literal (Obj_Loc, Uint_2)), + Right_Opnd => + Make_Op_Divide (Obj_Loc, + Left_Opnd => + Make_Attribute_Reference (Obj_Loc, + Prefix => + New_Occurrence_Of (Typ, Obj_Loc), + Attribute_Name => Name_First), + Right_Opnd => + Make_Integer_Literal (Obj_Loc, Uint_2))), + Right_Opnd => + Make_Integer_Literal (Obj_Loc, (Uint_2 ** 30))), + Reason => SE_Object_Too_Large)); + end if; + end Check_Large_Modular_Array; + + -- Local variables + + Typ : constant Entity_Id := Etype (E); + Def : Node_Id; + + -- Start of processing for Freeze_Object_Declaration + begin -- Abstract type allowed only for C++ imported variables or constants @@ -3195,22 +3289,20 @@ package body Freeze is -- x'Class'Input where x is abstract) where we legitimately -- generate an abstract object. - if Is_Abstract_Type (Etype (E)) + if Is_Abstract_Type (Typ) and then Comes_From_Source (Parent (E)) - and then not (Is_Imported (E) and then Is_CPP_Class (Etype (E))) + and then not (Is_Imported (E) and then Is_CPP_Class (Typ)) then - Error_Msg_N ("type of object cannot be abstract", - Object_Definition (Parent (E))); + Def := Object_Definition (Parent (E)); + + Error_Msg_N ("type of object cannot be abstract", Def); if Is_CPP_Class (Etype (E)) then - Error_Msg_NE - ("\} may need a cpp_constructor", - Object_Definition (Parent (E)), Etype (E)); + Error_Msg_NE ("\} may need a cpp_constructor", Def, Typ); elsif Present (Expression (Parent (E))) then Error_Msg_N -- CODEFIX - ("\maybe a class-wide type was meant", - Object_Definition (Parent (E))); + ("\maybe a class-wide type was meant", Def); end if; end if; @@ -3221,20 +3313,20 @@ package body Freeze is Validate_Object_Declaration (Declaration_Node (E)); - -- If there is an address clause, check that it is valid - -- and if need be move initialization to the freeze node. + -- If there is an address clause, check that it is valid and if need + -- be move initialization to the freeze node. Check_Address_Clause (E); - -- Similar processing is needed for aspects that may affect - -- object layout, like Alignment, if there is an initialization - -- expression. We don't do this if there is a pragma Linker_Section, - -- because it would prevent the back end from statically initializing - -- the object; we don't want elaboration code in that case. + -- Similar processing is needed for aspects that may affect object + -- layout, like Alignment, if there is an initialization expression. + -- We don't do this if there is a pragma Linker_Section, because it + -- would prevent the back end from statically initializing the + -- object; we don't want elaboration code in that case. if Has_Delayed_Aspects (E) and then Expander_Active - and then Is_Array_Type (Etype (E)) + and then Is_Array_Type (Typ) and then Present (Expression (Parent (E))) and then No (Linker_Section_Pragma (E)) then @@ -3243,7 +3335,6 @@ package body Freeze is Lhs : constant Node_Id := New_Occurrence_Of (E, Loc); begin - -- Capture initialization value at point of declaration, and -- make explicit assignment legal, because object may be a -- constant. @@ -3251,7 +3342,7 @@ package body Freeze is Remove_Side_Effects (Expression (Decl)); Set_Assignment_OK (Lhs); - -- Move initialization to freeze actions. + -- Move initialization to freeze actions Append_Freeze_Action (E, Make_Assignment_Statement (Loc, @@ -3283,7 +3374,7 @@ package body Freeze is -- a dispatch table entry, then we mean it. if Ekind (E) /= E_Constant - and then (Is_Aliased (E) or else Is_Aliased (Etype (E))) + and then (Is_Aliased (E) or else Is_Aliased (Typ)) and then not Is_Internal_Name (Chars (E)) then Set_Is_True_Constant (E, False); @@ -3304,11 +3395,11 @@ package body Freeze is and then not Is_Imported (E) and then not Has_Init_Expression (Declaration_Node (E)) and then - ((Has_Non_Null_Base_Init_Proc (Etype (E)) + ((Has_Non_Null_Base_Init_Proc (Typ) and then not No_Initialization (Declaration_Node (E)) - and then not Initialization_Suppressed (Etype (E))) + and then not Initialization_Suppressed (Typ)) or else - (Needs_Simple_Initialization (Etype (E)) + (Needs_Simple_Initialization (Typ) and then not Is_Internal (E))) then Has_Default_Initialization := True; @@ -3316,9 +3407,9 @@ package body Freeze is (No_Default_Initialization, Declaration_Node (E)); end if; - -- Check that a Thread_Local_Storage variable does not have - -- default initialization, and any explicit initialization must - -- either be the null constant or a static constant. + -- Check that a Thread_Local_Storage variable does not have default + -- initialization, and any explicit initialization must either be the + -- null constant or a static constant. if Has_Pragma_Thread_Local_Storage (E) then declare @@ -3356,31 +3447,30 @@ package body Freeze is Set_Is_Public (E); end if; - -- For source objects that are not Imported and are library - -- level, if no linker section pragma was given inherit the - -- appropriate linker section from the corresponding type. + -- For source objects that are not Imported and are library level, if + -- no linker section pragma was given inherit the appropriate linker + -- section from the corresponding type. if Comes_From_Source (E) and then not Is_Imported (E) and then Is_Library_Level_Entity (E) and then No (Linker_Section_Pragma (E)) then - Set_Linker_Section_Pragma - (E, Linker_Section_Pragma (Etype (E))); + Set_Linker_Section_Pragma (E, Linker_Section_Pragma (Typ)); end if; - -- For convention C objects of an enumeration type, warn if the - -- size is not integer size and no explicit size given. Skip - -- warning for Boolean, and Character, assume programmer expects - -- 8-bit sizes for these cases. + -- For convention C objects of an enumeration type, warn if the size + -- is not integer size and no explicit size given. Skip warning for + -- Boolean and Character, and assume programmer expects 8-bit sizes + -- for these cases. if (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) - and then Is_Enumeration_Type (Etype (E)) - and then not Is_Character_Type (Etype (E)) - and then not Is_Boolean_Type (Etype (E)) - and then Esize (Etype (E)) < Standard_Integer_Size + and then Is_Enumeration_Type (Typ) + and then not Is_Character_Type (Typ) + and then not Is_Boolean_Type (Typ) + and then Esize (Typ) < Standard_Integer_Size and then not Has_Size_Clause (E) then Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); @@ -3388,6 +3478,10 @@ package body Freeze is ("??convention C enumeration object has size less than ^", E); Error_Msg_N ("\??use explicit size clause to set size", E); end if; + + if Is_Array_Type (Typ) then + Check_Large_Modular_Array (Typ); + end if; end Freeze_Object_Declaration; ----------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 50b99100296..9f23b564e68 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -21676,7 +21676,8 @@ package body Sem_Ch3 is then Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); - -- ... but more comonly by a discriminated record type. + -- ... but more commonly is completed by a discriminated record + -- type. else Constrain_Discriminated_Type (Def_Id, S, Related_Nod); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 254db69dfd6..e5b473d5f32 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-23 Hristian Kirtchev + + * gnat.dg/import2.adb: New testcase. + 2018-05-23 Ed Schonberg * gnat.dg/discr51.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/import2.adb b/gcc/testsuite/gnat.dg/import2.adb new file mode 100644 index 00000000000..07ba880d3f7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/import2.adb @@ -0,0 +1,11 @@ +-- { dg-do run } + +procedure Import2 is + type Index_Typ is mod 2**64; + type Mod_Array is array (Index_Typ) of Integer; + + Obj : Mod_Array; + pragma Import (Ada, Obj); +begin + null; +end Import2; -- 2.30.2