+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
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,
Aspect_Asynchronous,
Aspect_Atomic,
Aspect_Atomic_Components,
+ Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
Aspect_Effective_Reads, -- GNAT
Aspect_Effective_Writes, -- GNAT
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,
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,
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
+ -- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
-- Is_Predicate_Function_M Flag256
-- Is_Volatile_Full_Access Flag285
-- Needs_Typedef Flag286
- -- (unused) Flag253
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
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);
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);
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 --
--------------------
-- 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
-- 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.
-- 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)
-- 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)
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;
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;
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);
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);
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);
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);
-- 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;
-- 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;
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,
if Ekind (Scope_Id) = E_Function
and then Present (Postconditions_Proc (Scope_Id))
then
- -- 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.
-
- -- 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)))
+ -- 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
- 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.
+ Rewrite (Exp, Expression (Relocate_Node (Exp)));
+ end if;
- else
- -- For now, copy the value, since the code below does not
- -- seem to work correctly ???
+ -- 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.
- 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
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
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)
-- 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);
(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
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;
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);
-- 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.
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;
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
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));
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);
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;
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));
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.
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 :=
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 + $;
projects / gcc.git / commitdiff