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;