This implements a new aspect Disable_Controlled which can only be
used for controlled record types. It causes suppression of related
calls to Initialize, Adjust, Finalize (for conditional compilation
purposes).
The following test:
1. with Ada.Finalization; use Ada.Finalization;
2. with Text_IO; use Text_IO;
3. procedure DisableC is
4. procedure Test1 is
5. type R is new Controlled with
6. record
7. X : Integer;
8. end record
9. with Disable_Controlled => False;
10. procedure Initialize (A : in out R);
11. procedure Adjust (A : in out R);
12. procedure Finalize (A : in out R);
13. procedure Initialize (A : in out R) is
14. begin
15. A.X := 0;
16. Put_Line (" Initialize called");
17. end;
18. procedure Adjust (A : in out R) is
19. begin
20. A.X := A.X + 1;
21. Put_Line (" Adjust called");
22. end;
23. procedure Finalize (A : in out R) is
24. begin
25. A.X := A.X - 1;
26. Put_Line (" Finalize called");
27. end;
28. R1, R2 : R;
29. begin
30. R1 := R2;
31. end Test1;
32. procedure Test2 is
33. type R is new Controlled with
34. record
35. X : Integer;
36. end record
37. with Disable_Controlled => True;
38. procedure Initialize (A : in out R);
39. procedure Adjust (A : in out R);
40. procedure Finalize (A : in out R);
41. procedure Initialize (A : in out R) is
42. begin
43. A.X := 0;
44. Put_Line (" Initialize called");
45. end;
46. procedure Adjust (A : in out R) is
47. begin
48. A.X := A.X + 1;
49. Put_Line (" Adjust called");
50. end;
51. procedure Finalize (A : in out R) is
52. begin
53. A.X := A.X - 1;
54. Put_Line (" Finalize called");
55. end;
56. R1, R2 : R;
57. begin
58. R1 := R2;
59. end;
60. begin
61. Put_Line ("Enabled:");
62. Test1;
63. Put_Line ("Disabled:");
64. Test2;
65. end;
generates the output:
Enabled:
Initialize called
Initialize called
Finalize called
Adjust called
Finalize called
Finalize called
Disabled:
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-05-26 Robert Dewar <de...@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.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 223661)
+++ sem_ch3.adb (working copy)
@@ -4386,7 +4386,7 @@
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 @@
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 @@
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 @@
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 @@
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_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_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
@@ -21174,7 +21178,7 @@
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 @@
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 :=
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 223661)
+++ exp_util.adb (working copy)
@@ -6848,12 +6848,16 @@
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)
Index: einfo.adb
===================================================================
--- einfo.adb (revision 223661)
+++ einfo.adb (working copy)
@@ -558,6 +558,7 @@
-- 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 @@
-- Is_Volatile_Full_Access Flag285
-- Needs_Typedef Flag286
- -- (unused) Flag253
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
@@ -1026,6 +1026,11 @@
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 @@
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 @@
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 --
--------------------
Index: einfo.ads
===================================================================
--- einfo.ads (revision 223665)
+++ einfo.ads (working copy)
@@ -911,6 +911,10 @@
-- 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 @@
-- 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 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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);
Index: freeze.adb
===================================================================
--- freeze.adb (revision 223661)
+++ freeze.adb (working copy)
@@ -2226,7 +2226,7 @@
-- 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 @@
(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
Index: aspects.adb
===================================================================
--- aspects.adb (revision 223661)
+++ aspects.adb (working copy)
@@ -517,6 +517,7 @@
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,
Index: aspects.ads
===================================================================
--- aspects.ads (revision 223661)
+++ aspects.ads (working copy)
@@ -171,6 +171,7 @@
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 @@
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 @@
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,
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 223661)
+++ sem_ch13.adb (working copy)
@@ -1205,8 +1205,7 @@
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 @@
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 @@
-- 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.
@@ -3145,6 +3144,25 @@
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;
-- Library unit aspects require special handling in the case
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 223661)
+++ snames.ads-tmpl (working copy)
@@ -141,6 +141,7 @@
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 + $;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 223661)
+++ exp_ch3.adb (working copy)
@@ -6936,9 +6936,10 @@
-- 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;
