[multiple changes]

2015-05-26  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Add aspect Disable_Controlled.
	* einfo.ads, einfo.adb (Disable_Controlled): New flag.
	(Is_Controlled_Active): New function.
	* exp_ch3.adb (Expand_Freeze_Record_Type): Use
	Is_Controlled_Active.
	* exp_util.adb (Needs_Finalization): Finalization not needed
	if Disable_Controlled set.
	* freeze.adb (Freeze_Array_Type): Do not set
	Has_Controlled_Component if the component has Disable_Controlled.
	(Freeze_Record_Type): ditto.
	* sem_ch13.adb (Decorate): Minor reformatting.
	(Analyze_Aspect_Specifications): Implement Disable_Controlled.
	* sem_ch3.adb (Analyze_Object_Declaration): Handle
	Disable_Controlled.
	(Array_Type_Declaration): ditto.
	(Build_Derived_Private_Type): ditto.
	(Build_Derived_Type): ditto.
	(Record_Type_Definition): ditto.
	* snames.ads-tmpl: Add Name_Disable_Controlled.

2015-05-26  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_ch6.adb (Expand_Actuals): Use a constant declaration instead
	of a renaming to capture the return value of a function call.
	(Expand_Simple_Function_Return): Call Remove_Side_Effects
	instead of removing side effects manually before the call to
	_Postconditions.

From-SVN: r223667
This commit is contained in:
Arnaud Charlet 2015-05-26 10:15:24 +02:00
parent 2945460b98
commit c859345327
12 changed files with 150 additions and 138 deletions

View File

@ -1,3 +1,33 @@
2015-05-26 Robert Dewar <dewar@adacore.com>
* aspects.ads, aspects.adb: Add aspect Disable_Controlled.
* einfo.ads, einfo.adb (Disable_Controlled): New flag.
(Is_Controlled_Active): New function.
* exp_ch3.adb (Expand_Freeze_Record_Type): Use
Is_Controlled_Active.
* exp_util.adb (Needs_Finalization): Finalization not needed
if Disable_Controlled set.
* freeze.adb (Freeze_Array_Type): Do not set
Has_Controlled_Component if the component has Disable_Controlled.
(Freeze_Record_Type): ditto.
* sem_ch13.adb (Decorate): Minor reformatting.
(Analyze_Aspect_Specifications): Implement Disable_Controlled.
* sem_ch3.adb (Analyze_Object_Declaration): Handle
Disable_Controlled.
(Array_Type_Declaration): ditto.
(Build_Derived_Private_Type): ditto.
(Build_Derived_Type): ditto.
(Record_Type_Definition): ditto.
* snames.ads-tmpl: Add Name_Disable_Controlled.
2015-05-26 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch6.adb (Expand_Actuals): Use a constant declaration instead
of a renaming to capture the return value of a function call.
(Expand_Simple_Function_Return): Call Remove_Side_Effects
instead of removing side effects manually before the call to
_Postconditions.
2015-05-26 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Op_Expon): Deal with problem of wrong

View File

@ -517,6 +517,7 @@ package body Aspects is
Aspect_Depends => Aspect_Depends,
Aspect_Dimension => Aspect_Dimension,
Aspect_Dimension_System => Aspect_Dimension_System,
Aspect_Disable_Controlled => Aspect_Disable_Controlled,
Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate,

View File

@ -171,6 +171,7 @@ package Aspects is
Aspect_Asynchronous,
Aspect_Atomic,
Aspect_Atomic_Components,
Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
Aspect_Effective_Reads, -- GNAT
Aspect_Effective_Writes, -- GNAT
@ -414,6 +415,7 @@ package Aspects is
Aspect_Depends => Name_Depends,
Aspect_Dimension => Name_Dimension,
Aspect_Dimension_System => Name_Dimension_System,
Aspect_Disable_Controlled => Name_Disable_Controlled,
Aspect_Discard_Names => Name_Discard_Names,
Aspect_Dispatching_Domain => Name_Dispatching_Domain,
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
@ -704,6 +706,7 @@ package Aspects is
Aspect_Depends => Never_Delay,
Aspect_Dimension => Never_Delay,
Aspect_Dimension_System => Never_Delay,
Aspect_Disable_Controlled => Never_Delay,
Aspect_Effective_Reads => Never_Delay,
Aspect_Effective_Writes => Never_Delay,
Aspect_Extensions_Visible => Never_Delay,

View File

@ -558,6 +558,7 @@ package body Einfo is
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
-- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
-- Is_Predicate_Function_M Flag256
@ -595,7 +596,6 @@ package body Einfo is
-- Is_Volatile_Full_Access Flag285
-- Needs_Typedef Flag286
-- (unused) Flag253
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
@ -1026,6 +1026,11 @@ package body Einfo is
return Node20 (Id);
end Directly_Designated_Type;
function Disable_Controlled (Id : E) return B is
begin
return Flag253 (Base_Type (Id));
end Disable_Controlled;
function Discard_Names (Id : E) return B is
begin
return Flag88 (Id);
@ -3941,6 +3946,12 @@ package body Einfo is
Set_Node20 (Id, V);
end Set_Directly_Designated_Type;
procedure Set_Disable_Controlled (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag253 (Id, V);
end Set_Disable_Controlled;
procedure Set_Discard_Names (Id : E; V : B := True) is
begin
Set_Flag88 (Id, V);
@ -7394,6 +7405,15 @@ package body Einfo is
K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter;
end Is_Constant_Object;
--------------------------
-- Is_Controlled_Active --
--------------------------
function Is_Controlled_Active (Id : E) return B is
begin
return Is_Controlled (Id) and then not Disable_Controlled (Id);
end Is_Controlled_Active;
--------------------
-- Is_Discriminal --
--------------------

View File

@ -911,6 +911,10 @@ package Einfo is
-- Designated_Type obtains this full type in the case of access to an
-- incomplete type.
-- Disable_Controlled (Flag253)
-- Present in all entities. Set for controlled type (Is_Controlled flag
-- set) if the aspect Disable_Controlled is active for the type.
-- Discard_Names (Flag88)
-- Defined in types and exception entities. Set if pragma Discard_Names
-- applies to the entity. It is also set for declarative regions and
@ -2337,6 +2341,10 @@ package Einfo is
-- i.e. is either a descendant of Ada.Finalization.Controlled or of
-- Ada.Finalization.Limited_Controlled.
-- Is_Controlled_Active (synth) [base type only]
-- Defined in all type entities. Set if Is_Controlled is set for the
-- type, and Disable_Controlled is not set.
-- Is_Controlling_Formal (Flag97)
-- Defined in all Formal_Kind entities. Marks the controlling parameters
-- of dispatching operations.
@ -5413,6 +5421,7 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Depends_On_Private (Flag14)
-- Disable_Controlled (Flag253)
-- Discard_Names (Flag88)
-- Finalize_Storage_Only (Flag158) (base type only)
-- From_Limited_With (Flag159)
@ -5491,6 +5500,7 @@ package Einfo is
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Controlled_Active (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
@ -6724,6 +6734,7 @@ package Einfo is
function Digits_Value (Id : E) return U;
function Direct_Primitive_Operations (Id : E) return L;
function Directly_Designated_Type (Id : E) return E;
function Disable_Controlled (Id : E) return B;
function Discard_Names (Id : E) return B;
function Discriminal (Id : E) return E;
function Discriminal_Link (Id : E) return E;
@ -7206,6 +7217,7 @@ package Einfo is
function Is_Base_Type (Id : E) return B;
function Is_Boolean_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
function Is_Controlled_Active (Id : E) return B;
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
function Is_External_State (Id : E) return B;
@ -7380,6 +7392,7 @@ package Einfo is
procedure Set_Digits_Value (Id : E; V : U);
procedure Set_Direct_Primitive_Operations (Id : E; V : L);
procedure Set_Directly_Designated_Type (Id : E; V : E);
procedure Set_Disable_Controlled (Id : E; V : B := True);
procedure Set_Discard_Names (Id : E; V : B := True);
procedure Set_Discriminal (Id : E; V : E);
procedure Set_Discriminal_Link (Id : E; V : E);
@ -8155,6 +8168,7 @@ package Einfo is
pragma Inline (Digits_Value);
pragma Inline (Direct_Primitive_Operations);
pragma Inline (Directly_Designated_Type);
pragma Inline (Disable_Controlled);
pragma Inline (Discard_Names);
pragma Inline (Discriminal);
pragma Inline (Discriminal_Link);
@ -8658,6 +8672,7 @@ package Einfo is
pragma Inline (Set_Digits_Value);
pragma Inline (Set_Direct_Primitive_Operations);
pragma Inline (Set_Directly_Designated_Type);
pragma Inline (Set_Disable_Controlled);
pragma Inline (Set_Discard_Names);
pragma Inline (Set_Discriminal);
pragma Inline (Set_Discriminal_Link);
@ -9062,6 +9077,7 @@ package Einfo is
pragma Inline (Base_Type);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Controlled_Active);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);

View File

@ -6936,9 +6936,10 @@ package body Exp_Ch3 is
-- type. See Make_CW_Equivalent_Type.
if not Is_Class_Wide_Equivalent_Type (Def_Id)
and then (Has_Controlled_Component (Comp_Typ)
or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Comp_Typ)))
and then
(Has_Controlled_Component (Comp_Typ)
or else (Chars (Comp) /= Name_uParent
and then (Is_Controlled_Active (Comp_Typ))))
then
Set_Has_Controlled_Component (Def_Id);
end if;

View File

@ -1979,7 +1979,7 @@ package body Exp_Ch6 is
-- To deal with this, we replace the call by
-- do
-- Tnnn : function-result-type renames function-call;
-- Tnnn : constant function-result-type := function-call;
-- Post_Call actions
-- in
-- Tnnn;
@ -1996,10 +1996,11 @@ package body Exp_Ch6 is
begin
Prepend_To (Post_Call,
Make_Object_Renaming_Declaration (Loc,
Make_Object_Declaration (Loc,
Defining_Identifier => Tnnn,
Subtype_Mark => New_Occurrence_Of (FRTyp, Loc),
Name => Name));
Object_Definition => New_Occurrence_Of (FRTyp, Loc),
Constant_Present => True,
Expression => Name));
Rewrite (N,
Make_Expression_With_Actions (Loc,
@ -6619,111 +6620,23 @@ package body Exp_Ch6 is
if Ekind (Scope_Id) = E_Function
and then Present (Postconditions_Proc (Scope_Id))
then
-- In the case of discriminated objects, we have created a
-- constrained subtype above, and used the underlying type. This
-- transformation is post-analysis and harmless, except that now the
-- call to the post-condition will be analyzed and the type kinds
-- have to match.
if Nkind (Exp) = N_Unchecked_Type_Conversion
and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
then
Rewrite (Exp, Expression (Relocate_Node (Exp)));
end if;
-- We are going to reference the returned value twice in this case,
-- once in the call to _Postconditions, and once in the actual return
-- statement, but we can't have side effects happening twice, and in
-- any case for efficiency we don't want to do the computation twice.
-- statement, but we can't have side effects happening twice.
-- If the returned expression is an entity name, we don't need to
-- worry since it is efficient and safe to reference it twice, that's
-- also true for literals other than string literals, and for the
-- case of X.all where X is an entity name.
if Is_Entity_Name (Exp)
or else Nkind_In (Exp, N_Character_Literal,
N_Integer_Literal,
N_Real_Literal)
or else (Nkind (Exp) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Exp)))
then
null;
-- Otherwise we are going to need a temporary to capture the value
else
declare
ExpR : Node_Id := Relocate_Node (Exp);
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
begin
-- In the case of discriminated objects, we have created a
-- constrained subtype above, and used the underlying type.
-- This transformation is post-analysis and harmless, except
-- that now the call to the post-condition will be analyzed and
-- type kinds have to match.
if Nkind (ExpR) = N_Unchecked_Type_Conversion
and then
Is_Private_Type (R_Type) /= Is_Private_Type (Etype (ExpR))
then
ExpR := Expression (ExpR);
end if;
-- For a complex expression of an elementary type, capture
-- value in the temporary and use it as the reference.
if Is_Elementary_Type (R_Type) then
Insert_Action (Exp,
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (R_Type, Loc),
Expression => ExpR),
Suppress => All_Checks);
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
-- If we have something we can rename, generate a renaming of
-- the object and replace the expression with a reference
elsif Is_Object_Reference (Exp) then
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Tnn,
Subtype_Mark => New_Occurrence_Of (R_Type, Loc),
Name => ExpR),
Suppress => All_Checks);
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
-- Otherwise we have something like a string literal or an
-- aggregate. We could copy the value, but that would be
-- inefficient. Instead we make a reference to the value and
-- capture this reference with a renaming, the expression is
-- then replaced by a dereference of this renaming.
else
-- For now, copy the value, since the code below does not
-- seem to work correctly ???
Insert_Action (Exp,
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (R_Type, Loc),
Expression => Relocate_Node (Exp)),
Suppress => All_Checks);
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
-- Insert_Action (Exp,
-- Make_Object_Renaming_Declaration (Loc,
-- Defining_Identifier => Tnn,
-- Access_Definition =>
-- Make_Access_Definition (Loc,
-- All_Present => True,
-- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)),
-- Name =>
-- Make_Reference (Loc,
-- Prefix => Relocate_Node (Exp))),
-- Suppress => All_Checks);
-- Rewrite (Exp,
-- Make_Explicit_Dereference (Loc,
-- Prefix => New_Occurrence_Of (Tnn, Loc)));
end if;
end;
end if;
Remove_Side_Effects (Exp);
-- Generate call to _Postconditions
@ -6731,7 +6644,7 @@ package body Exp_Ch6 is
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
Parameter_Associations => New_List (Duplicate_Subexpr (Exp))));
Parameter_Associations => New_List (New_Copy_Tree (Exp))));
end if;
-- Ada 2005 (AI-251): If this return statement corresponds with an

View File

@ -6848,12 +6848,16 @@ package body Exp_Util is
then
return False;
-- Never needs finalization if Disable_Controlled set
elsif Disable_Controlled (T) then
return False;
else
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.
return
Is_Class_Wide_Type (T)
return Is_Class_Wide_Type (T)
or else Is_Controlled (T)
or else Has_Controlled_Component (T)
or else Has_Some_Controlled_Component (T)

View File

@ -2226,7 +2226,7 @@ package body Freeze is
-- Propagate flags for component type
if Is_Controlled (Component_Type (Arr))
if Is_Controlled_Active (Component_Type (Arr))
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (Arr);
@ -4106,7 +4106,7 @@ package body Freeze is
(Has_Controlled_Component (Etype (Comp))
or else
(Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp)))
and then Is_Controlled_Active (Etype (Comp)))
or else
(Is_Protected_Type (Etype (Comp))
and then

View File

@ -1205,8 +1205,7 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
procedure Decorate (Asp : Node_Id; Prag : Node_Id);
-- Establish linkages between an aspect and its corresponding
-- pragma.
-- Establish linkages between an aspect and its corresponding pragma
procedure Insert_After_SPARK_Mode
(Prag : Node_Id;
@ -1235,7 +1234,7 @@ package body Sem_Ch13 is
procedure Decorate (Asp : Node_Id; Prag : Node_Id) is
begin
Set_Aspect_Rep_Item (Asp, Prag);
Set_Aspect_Rep_Item (Asp, Prag);
Set_Corresponding_Aspect (Prag, Asp);
Set_From_Aspect_Specification (Prag);
Set_Parent (Prag, Asp);
@ -3055,7 +3054,7 @@ package body Sem_Ch13 is
-- Case 5: Special handling for aspects with an optional
-- boolean argument.
-- In the general case, the corresponding pragma cannot be
-- In the delayed case, the corresponding pragma cannot be
-- generated yet because the evaluation of the boolean needs
-- to be delayed till the freeze point.
@ -3144,6 +3143,25 @@ package body Sem_Ch13 is
end if;
end if;
goto Continue;
-- Disable_Controlled
elsif A_Id = Aspect_Disable_Controlled then
if Ekind (E) /= E_Record_Type
or else not Is_Controlled (E)
then
Error_Msg_N
("aspect % requires controlled record type", Aspect);
goto Continue;
end if;
if not Present (Expr)
or else Is_True (Static_Boolean (Expr))
then
Set_Disable_Controlled (E);
end if;
goto Continue;
end if;

View File

@ -4386,7 +4386,7 @@ package body Sem_Ch3 is
and then not Is_Constrained (Underlying_Type (T))
and then not Is_Aliased (Id)
and then not Is_Class_Wide_Type (T)
and then not Is_Controlled (T)
and then not Is_Controlled_Active (T)
and then not Has_Controlled_Component (Base_Type (T))
and then Expander_Active
then
@ -5614,7 +5614,7 @@ package body Sem_Ch3 is
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component (Implicit_Base,
Has_Controlled_Component (Element_Type)
or else Is_Controlled (Element_Type));
or else Is_Controlled_Active (Element_Type));
Set_Finalize_Storage_Only (Implicit_Base,
Finalize_Storage_Only (Element_Type));
@ -5640,7 +5640,7 @@ package body Sem_Ch3 is
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
Is_Controlled (Element_Type));
Is_Controlled_Active (Element_Type));
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
(Element_Type));
Set_Default_SSO (T);
@ -7351,16 +7351,18 @@ package body Sem_Ch3 is
Error_Msg_N ("cannot add discriminants to untagged type", N);
end if;
Set_Stored_Constraint (Derived_Type, No_Elist);
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Stored_Constraint (Derived_Type, No_Elist);
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Disable_Controlled (Derived_Type, Disable_Controlled
(Parent_Type));
Set_Has_Controlled_Component
(Derived_Type, Has_Controlled_Component
(Parent_Type));
(Derived_Type, Has_Controlled_Component
(Parent_Type));
-- Direct controlled types do not inherit Finalize_Storage_Only flag
if not Is_Controlled (Parent_Type) then
if not Is_Controlled_Active (Parent_Type) then
Set_Finalize_Storage_Only
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
@ -8974,16 +8976,18 @@ package body Sem_Ch3 is
begin
-- Set common attributes
Set_Scope (Derived_Type, Current_Scope);
Set_Scope (Derived_Type, Current_Scope);
Set_Etype (Derived_Type, Parent_Base);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
Set_Etype (Derived_Type, Parent_Base);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
@ -21174,7 +21178,7 @@ package body Sem_Ch3 is
end;
end if;
Final_Storage_Only := not Is_Controlled (T);
Final_Storage_Only := not Is_Controlled_Active (T);
-- Ada 2005: Check whether an explicit Limited is present in a derived
-- type declaration.
@ -21240,7 +21244,8 @@ package body Sem_Ch3 is
elsif not Is_Class_Wide_Equivalent_Type (T)
and then (Has_Controlled_Component (Etype (Component))
or else (Chars (Component) /= Name_uParent
and then Is_Controlled (Etype (Component))))
and then Is_Controlled_Active
(Etype (Component))))
then
Set_Has_Controlled_Component (T, True);
Final_Storage_Only :=

View File

@ -141,6 +141,7 @@ package Snames is
Name_Default_Component_Value : constant Name_Id := N + $;
Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $;
Name_Disable_Controlled : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;