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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-23 Hristian Kirtchev <kirtc...@adacore.com>
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.--- gcc/ada/exp_ch3.adb
+++ 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
--- gcc/ada/freeze.adb
+++ 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;
-----------------------------
--- gcc/ada/sem_ch3.adb
+++ 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);
--- /dev/null
new file mode 100644
+++ 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;
