===================================================================
@@ -3336,6 +3336,18 @@
-- or a variant record type is encountered, Check_Restrictions is called
-- indicating the count is unknown.
+ function Delayed_Aspect_Present return Boolean;
+ -- If the declaration has an expression that is an aggregate, and it
+ -- has aspects that require delayed analysis, the resolution of the
+ -- aggregate must be deferred to the freeze point of the objet. This
+ -- special processing was created for address clauses, but it must
+ -- also apply to Alignment.
+ -- This must be done before the aspect specifications are analyzed
+ -- because we must handle the aggregate before the analysis of the
+ -- object declaration is complete.
+
+ -- any other relevant delayed aspects on object declarations ???
+
-----------------
-- Count_Tasks --
-----------------
@@ -3390,6 +3402,32 @@
end if;
end Count_Tasks;
+ ----------------------------
+ -- Delayed_Aspect_Present --
+ ----------------------------
+
+ function Delayed_Aspect_Present return Boolean is
+ A : Node_Id;
+ A_Id : Aspect_Id;
+
+ begin
+ if Present (Aspect_Specifications (N)) then
+ A := First (Aspect_Specifications (N));
+ A_Id := Get_Aspect_Id (Chars (Identifier (A)));
+ while Present (A) loop
+ if
+ A_Id = Aspect_Alignment or else A_Id = Aspect_Address
+ then
+ return True;
+ end if;
+
+ Next (A);
+ end loop;
+ end if;
+
+ return False;
+ end Delayed_Aspect_Present;
+
-- Start of processing for Analyze_Object_Declaration
begin
@@ -3705,7 +3743,8 @@
if Comes_From_Source (N)
and then Expander_Active
and then Nkind (E) = N_Aggregate
- and then Present (Following_Address_Clause (N))
+ and then (Present (Following_Address_Clause (N))
+ or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
===================================================================
@@ -1894,6 +1894,10 @@
procedure Freeze_Array_Type (Arr : Entity_Id);
-- Freeze array type, including freezing index and component types
+ procedure Freeze_Object_Declaration (E : Entity_Id);
+ -- Perfom checks and generate freeze node if needed for a constant
+ -- or variable declared by an object declaration.
+
function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id;
-- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages.
@@ -2782,6 +2786,211 @@
end if;
end Freeze_Array_Type;
+ -------------------------------
+ -- Freeze_Object_Declaration --
+ -------------------------------
+
+ procedure Freeze_Object_Declaration (E : Entity_Id) is
+ begin
+ -- Abstract type allowed only for C++ imported variables or
+ -- constants.
+
+ -- Note: we inhibit this check for objects that do not come
+ -- from source because there is at least one case (the
+ -- expansion of x'Class'Input where x is abstract) where we
+ -- legitimately generate an abstract object.
+
+ if Is_Abstract_Type (Etype (E))
+ and then Comes_From_Source (Parent (E))
+ and then not (Is_Imported (E) and then Is_CPP_Class (Etype (E)))
+ then
+ Error_Msg_N ("type of object cannot be abstract",
+ Object_Definition (Parent (E)));
+
+ if Is_CPP_Class (Etype (E)) then
+ Error_Msg_NE ("\} may need a cpp_constructor",
+ Object_Definition (Parent (E)), Etype (E));
+
+ elsif Present (Expression (Parent (E))) then
+ Error_Msg_N -- CODEFIX
+ ("\maybe a class-wide type was meant",
+ Object_Definition (Parent (E)));
+ end if;
+ end if;
+
+ -- For object created by object declaration, perform required
+ -- categorization (preelaborate and pure) checks. Defer these
+ -- checks to freeze time since pragma Import inhibits default
+ -- initialization and thus pragma Import affects these checks.
+
+ 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.
+
+ Check_Address_Clause (E);
+
+ -- Similar processing is needed for aspects that may affect
+ -- object layout, like Alignment, if there is an initialization
+ -- expression.
+
+ if Has_Delayed_Aspects (E)
+ and then Expander_Active
+ and then Is_Array_Type (Etype (E))
+ and then Present (Expression (Parent (E)))
+ then
+ declare
+ Decl : constant Node_Id := Parent (E);
+ 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.
+
+ Remove_Side_Effects (Expression (Decl));
+ Set_Assignment_OK (Lhs);
+
+ -- Move initialization to freeze actions.
+
+ Append_Freeze_Action (E,
+ Make_Assignment_Statement (Loc,
+ Name => Lhs,
+ Expression => Expression (Decl)));
+
+ Set_No_Initialization (Decl);
+ -- Set_Is_Frozen (E, False);
+ end;
+ end if;
+
+ -- Reset Is_True_Constant for non-constant aliased object. We
+ -- consider that the fact that a non-constant object is aliased
+ -- may indicate that some funny business is going on, e.g. an
+ -- aliased object is passed by reference to a procedure which
+ -- captures the address of the object, which is later used to
+ -- assign a new value, even though the compiler thinks that it
+ -- is not modified. Such code is highly dubious, but we choose
+ -- to make it "work" for non-constant aliased objects.
+ -- Note that we used to do this for all aliased objects, whether
+ -- or not constant, but this caused anomalies down the line
+ -- because we ended up with static objects that were not
+ -- Is_True_Constant. Not resetting Is_True_Constant for (aliased)
+ -- constant objects ensures that this anomaly never occurs.
+
+ -- However, we don't do that for internal entities. We figure
+ -- that if we deliberately set Is_True_Constant for an internal
+ -- entity, e.g. 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 not Is_Internal_Name (Chars (E))
+ then
+ Set_Is_True_Constant (E, False);
+ end if;
+
+ -- If the object needs any kind of default initialization, an
+ -- error must be issued if No_Default_Initialization applies.
+ -- The check doesn't apply to imported objects, which are not
+ -- ever default initialized, and is why the check is deferred
+ -- until freezing, at which point we know if Import applies.
+ -- Deferred constants are also exempted from this test because
+ -- their completion is explicit, or through an import pragma.
+
+ if Ekind (E) = E_Constant
+ and then Present (Full_View (E))
+ then
+ null;
+
+ elsif Comes_From_Source (E)
+ 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))
+ and then not No_Initialization (Declaration_Node (E))
+ and then not Is_Value_Type (Etype (E))
+ and then not Initialization_Suppressed (Etype (E)))
+ or else
+ (Needs_Simple_Initialization (Etype (E))
+ and then not Is_Internal (E)))
+ then
+ Has_Default_Initialization := True;
+ Check_Restriction
+ (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.
+
+ if Has_Pragma_Thread_Local_Storage (E) then
+ declare
+ Decl : constant Node_Id := Declaration_Node (E);
+ begin
+ if Has_Default_Initialization
+ or else
+ (Has_Init_Expression (Decl)
+ and then
+ (No (Expression (Decl))
+ or else not
+ (Is_OK_Static_Expression (Expression (Decl))
+ or else Nkind (Expression (Decl)) = N_Null)))
+ then
+ Error_Msg_NE
+ ("Thread_Local_Storage variable& is "
+ & "improperly initialized", Decl, E);
+ Error_Msg_NE
+ ("\only allowed initialization is explicit "
+ & "NULL or static expression", Decl, E);
+ end if;
+ end;
+ end if;
+
+ -- For imported objects, set Is_Public unless there is also an
+ -- address clause, which means that there is no external symbol
+ -- needed for the Import (Is_Public may still be set for other
+ -- unrelated reasons). Note that we delayed this processing
+ -- till freeze time so that we can be sure not to set the flag
+ -- if there is an address clause. If there is such a clause,
+ -- then the only purpose of the Import pragma is to suppress
+ -- implicit initialization.
+
+ if Is_Imported (E) and then No (Address_Clause (E)) then
+ 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.
+
+ 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)));
+ 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.
+
+ 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 not Has_Size_Clause (E)
+ then
+ Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size);
+ Error_Msg_N
+ ("??convention C enumeration object has size less than ^", E);
+ Error_Msg_N ("\??use explicit size clause to set size", E);
+ end if;
+ end Freeze_Object_Declaration;
+
-----------------------------
-- Freeze_Generic_Entities --
-----------------------------
@@ -4690,176 +4899,7 @@
-- Special processing for objects created by object declaration
if Nkind (Declaration_Node (E)) = N_Object_Declaration then
-
- -- Abstract type allowed only for C++ imported variables or
- -- constants.
-
- -- Note: we inhibit this check for objects that do not come
- -- from source because there is at least one case (the
- -- expansion of x'Class'Input where x is abstract) where we
- -- legitimately generate an abstract object.
-
- if Is_Abstract_Type (Etype (E))
- and then Comes_From_Source (Parent (E))
- and then not (Is_Imported (E)
- and then Is_CPP_Class (Etype (E)))
- then
- Error_Msg_N ("type of object cannot be abstract",
- Object_Definition (Parent (E)));
-
- if Is_CPP_Class (Etype (E)) then
- Error_Msg_NE
- ("\} may need a cpp_constructor",
- Object_Definition (Parent (E)), Etype (E));
-
- elsif Present (Expression (Parent (E))) then
- Error_Msg_N -- CODEFIX
- ("\maybe a class-wide type was meant",
- Object_Definition (Parent (E)));
- end if;
- end if;
-
- -- For object created by object declaration, perform required
- -- categorization (preelaborate and pure) checks. Defer these
- -- checks to freeze time since pragma Import inhibits default
- -- initialization and thus pragma Import affects these checks.
-
- Validate_Object_Declaration (Declaration_Node (E));
-
- -- If there is an address clause, check that it is valid
-
- Check_Address_Clause (E);
-
- -- Reset Is_True_Constant for non-constant aliased object. We
- -- consider that the fact that a non-constant object is aliased
- -- may indicate that some funny business is going on, e.g. an
- -- aliased object is passed by reference to a procedure which
- -- captures the address of the object, which is later used to
- -- assign a new value, even though the compiler thinks that
- -- it is not modified. Such code is highly dubious, but we
- -- choose to make it "work" for non-constant aliased objects.
- -- Note that we used to do this for all aliased objects,
- -- whether or not constant, but this caused anomalies down
- -- the line because we ended up with static objects that
- -- were not Is_True_Constant. Not resetting Is_True_Constant
- -- for (aliased) constant objects ensures that this anomaly
- -- never occurs.
-
- -- However, we don't do that for internal entities. We figure
- -- that if we deliberately set Is_True_Constant for an internal
- -- entity, e.g. 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 not Is_Internal_Name (Chars (E))
- then
- Set_Is_True_Constant (E, False);
- end if;
-
- -- If the object needs any kind of default initialization, an
- -- error must be issued if No_Default_Initialization applies.
- -- The check doesn't apply to imported objects, which are not
- -- ever default initialized, and is why the check is deferred
- -- until freezing, at which point we know if Import applies.
- -- Deferred constants are also exempted from this test because
- -- their completion is explicit, or through an import pragma.
-
- if Ekind (E) = E_Constant
- and then Present (Full_View (E))
- then
- null;
-
- elsif Comes_From_Source (E)
- 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))
- and then not No_Initialization (Declaration_Node (E))
- and then not Is_Value_Type (Etype (E))
- and then not Initialization_Suppressed (Etype (E)))
- or else
- (Needs_Simple_Initialization (Etype (E))
- and then not Is_Internal (E)))
- then
- Has_Default_Initialization := True;
- Check_Restriction
- (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.
-
- if Has_Pragma_Thread_Local_Storage (E) then
- declare
- Decl : constant Node_Id := Declaration_Node (E);
- begin
- if Has_Default_Initialization
- or else
- (Has_Init_Expression (Decl)
- and then
- (No (Expression (Decl))
- or else not
- (Is_OK_Static_Expression (Expression (Decl))
- or else
- Nkind (Expression (Decl)) = N_Null)))
- then
- Error_Msg_NE
- ("Thread_Local_Storage variable& is "
- & "improperly initialized", Decl, E);
- Error_Msg_NE
- ("\only allowed initialization is explicit "
- & "NULL or static expression", Decl, E);
- end if;
- end;
- end if;
-
- -- For imported objects, set Is_Public unless there is also an
- -- address clause, which means that there is no external symbol
- -- needed for the Import (Is_Public may still be set for other
- -- unrelated reasons). Note that we delayed this processing
- -- till freeze time so that we can be sure not to set the flag
- -- if there is an address clause. If there is such a clause,
- -- then the only purpose of the Import pragma is to suppress
- -- implicit initialization.
-
- if Is_Imported (E) and then No (Address_Clause (E)) then
- 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.
-
- 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)));
- 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.
-
- 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 not Has_Size_Clause (E)
- then
- Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size);
- Error_Msg_N
- ("??convention C enumeration object has size less than ^",
- E);
- Error_Msg_N ("\??use explicit size clause to set size", E);
- end if;
+ Freeze_Object_Declaration (E);
end if;
-- Check that a constant which has a pragma Volatile[_Components]
When an object declaration for an array object includes an aggregate expression and the aspect Alignment is specified for the object, the object must be initialized with an explicit assignment at the point the object is frozen. Such special processing was developed for address clauses, but it must apply to other aspects that may affect object layout, and that have to be delayed in Ada 2012 because they may contain forward references. The following must compile quietly: with A; procedure Main is type Rec is record C: Duration; end record; package TestA_Pkg is new A (Rec); package TestB_Pkg is new TestA_Pkg.B; D: aliased Rec := (C => 1.0); begin TestB_Pkg.P (D'Access); end Main; --- generic type T is private; package A is generic package B is procedure P (Item: access T); end B; end A; --- package body A is package body B is subtype Buff_Type is String (1 .. T'Size); procedure P (Item: access T) is Buff : Buff_Type := (others => ' ') with Alignment => Standard'Maximum_Alignment; Item2 : aliased T with Alignment => 8, Address => Buff'Address; Align : constant := Standard'Maximum_alignment; Temp : T; begin Temp := Item2'Access.all; end P; end B; end A; Tested on x86_64-pc-linux-gnu, committed on trunk 2015-05-12 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Analyze_Object_Declaration): New function Has_Delayed_Aspect, used to defer resolution of an aggregate expression when the object declaration carries aspects Address and/or Alignment. * freeze.adb (Freeze_Object_Declaration): New subsidiary procedure to Freeze_Entity. In addition to the previous processing steps at the freeze point of an object, this procedure also handles aggregates in object declarations, when the declaration carries delayed aspects that require that the initialization of the object be attached to its freeze actions.