[Ada] Undefined symbol at link time due to Disable_Controlled
Pierre-Marie de Rodat
derodat@adacore.com
Wed Sep 13 10:03:00 GMT 2017
This patch reimplements aspect Disable_Controlled to plug the following holes
in its original implementation:
* The aspect may appear without an expression in which case the aspect
defaults to True, however the compiler would crash due to the lack of
expression.
* If the expression is present, then it should be static, however the
compiler would silently accept a non-static expression.
* Various types that derive and/or contain a component of a type subject
to the aspect are now properly handled.
The patch also modifies predicate Is_Controlled to indicate whether a type is
derived from [Limited_]Controlled AND NOT subject to aspect Disable_Controlled.
This modification allows the semantics of the aspect to automatically perculate
to derived types and/or composite types with components subject to the aspect.
As a result, the finalization mechanism now properly handles such types and
generates the appropriate Deep_Adjust, Deep_Initialize, and Deep_Finalize
primitives.
------------
-- Source --
------------
-- factorial.ads
function Factorial (Val : Natural) return Natural;
-- factorial.adb
function Factorial (Val : Natural) return Natural is
begin
if Val > 1 then
return Val * Factorial (Val - 1);
end if;
return 1;
end Factorial;
-- semantics.ads
with Ada.Finalization; use Ada.Finalization;
with Factorial;
package Semantics is
generic
Flag : Boolean;
Int : Integer;
package Nested_Gen is
type Ctrl_Rec_1 is new Controlled with null record
with Disable_Controlled => Int; -- Error
type Ctrl_Rec_2 is new Limited_Controlled with null record
with Disable_Controlled => Factorial (3) = 6; -- N/A
type Ctrl_Rec_3 is new Controlled with null record
with Disable_Controlled => Flag; -- OK
end Nested_Gen;
subtype Small_Int is Integer range 1 .. 10
with Disable_Controlled; -- Error
type Rec is null record
with Disable_Controlled => False; -- Error
type Ctrl_Rec_1 is new Controlled with null record
with Disable_Controlled => "what?"; -- Error
type Ctrl_Rec_2 is new Limited_Controlled with null record
with Disable_Controlled => Factorial (3) = 6; -- Error
type Ctrl_Rec_3 is new Controlled with null record
with Disable_Controlled => True; -- OK
Is_True : constant Boolean := True;
type Ctrl_Rec_4 is new Limited_Controlled with null record
with Disable_Controlled => Is_True; -- OK
end Semantics;
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
generic
Flag : Boolean;
package Gen is
type Ctrl is new Controlled with record
Id : Natural;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
type Ctrl_DC is new Controlled with record
Id : Natural;
end record
with Disable_Controlled => Flag;
procedure Adjust (Obj : in out Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_DC);
type Ctrl_Ctrl_DC is new Controlled with record
Id : Natural;
Comp : Ctrl_DC;
end record;
procedure Adjust (Obj : in out Ctrl_Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_Ctrl_DC);
type Ctrl_DC_Ctrl is new Controlled with record
Id : Natural;
Comp : Ctrl;
end record
with Disable_Controlled => True;
procedure Adjust (Obj : in out Ctrl_DC_Ctrl);
procedure Finalize (Obj : in out Ctrl_DC_Ctrl);
procedure Initialize (Obj : in out Ctrl_DC_Ctrl);
type Ctrl_DC_Ctrl_DC is new Controlled with record
Id : Natural;
Comp : Ctrl_DC;
end record
with Disable_Controlled;
procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC);
type Rec_Ctrl_DC is record
Comp : Ctrl_DC;
end record;
end Gen;
generic
Typ_Name : String;
type Typ is private;
procedure Test;
type Ctrl is new Controlled with record
Id : Natural;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
type Ctrl_DC is new Controlled with record
Id : Natural;
end record
with Disable_Controlled => True;
procedure Adjust (Obj : in out Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_DC);
type Ctrl_Ctrl_DC is new Controlled with record
Id : Natural;
Comp : Ctrl_DC;
end record;
procedure Adjust (Obj : in out Ctrl_Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_Ctrl_DC);
type Ctrl_DC_Ctrl is new Controlled with record
Id : Natural;
Comp : Ctrl;
end record
with Disable_Controlled => True;
procedure Adjust (Obj : in out Ctrl_DC_Ctrl);
procedure Finalize (Obj : in out Ctrl_DC_Ctrl);
procedure Initialize (Obj : in out Ctrl_DC_Ctrl);
type Ctrl_DC_Ctrl_DC is new Controlled with record
Id : Natural;
Comp : Ctrl_DC;
end record
with Disable_Controlled;
procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC);
procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC);
procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC);
type Rec_Ctrl_DC is record
Comp : Ctrl_DC;
end record;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 100;
procedure Adjust_Id (Owner : String; Id : in out Natural);
procedure Finalize_Id (Owner : String; Id : in out Natural);
procedure Initialize_Id (Owner : String; Id : in out Natural);
--------
-- Id --
--------
procedure Adjust_Id (Owner : String; Id : in out Natural) is
Old_Id : constant Natural := Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line (" " & Owner & " adj: ERROR: already finalized");
else
Put_Line (" " & Owner & " adj:" & Old_Id'Img & " =>" & New_Id'Img);
Id := New_Id;
end if;
end Adjust_Id;
procedure Finalize_Id (Owner : String; Id : in out Natural) is
Old_Id : constant Natural := Id;
begin
if Old_Id = 0 then
Put_Line (" " & Owner & " fin: ERROR: already finalized");
else
Put_Line (" " & Owner & " fin:" & Old_Id'Img);
Id := 0;
end if;
end Finalize_Id;
procedure Initialize_Id (Owner : String; Id : in out Natural) is
begin
Id := Id_Gen;
Id_Gen := Id_Gen + 1;
Put_Line (" " & Owner & " ini:" & Id'Img);
end Initialize_Id;
package body Gen is
----------
-- Ctrl --
----------
procedure Adjust (Obj : in out Ctrl) is
begin
Adjust_Id ("gen Ctrl", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
begin
Finalize_Id ("gen Ctrl", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Initialize_Id ("gen Ctrl", Obj.Id);
end Initialize;
-------------
-- Ctrl_DC --
-------------
procedure Adjust (Obj : in out Ctrl_DC) is
begin
Adjust_Id ("gen Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC) is
begin
Finalize_Id ("gen Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC) is
begin
Initialize_Id ("gen Ctrl_DC", Obj.Id);
end Initialize;
------------------
-- Ctrl_Ctrl_DC --
------------------
procedure Adjust (Obj : in out Ctrl_Ctrl_DC) is
begin
Adjust_Id ("gen Ctrl_Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_Ctrl_DC) is
begin
Finalize_Id ("gen Ctrl_Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_Ctrl_DC) is
begin
Initialize_Id ("gen Ctrl_Ctrl_DC", Obj.Id);
end Initialize;
-------------
-- Ctrl_DC --
-------------
procedure Adjust (Obj : in out Ctrl_DC_Ctrl) is
begin
Adjust_Id ("gen Ctrl_DC_Ctrl", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC_Ctrl) is
begin
Finalize_Id ("gen Ctrl_DC_Ctrl", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC_Ctrl) is
begin
Initialize_Id ("gen Ctrl_DC_Ctrl", Obj.Id);
end Initialize;
---------------------
-- Ctrl_DC_Ctrl_DC --
---------------------
procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Adjust_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Finalize_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Initialize_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id);
end Initialize;
end Gen;
procedure Test is
begin
Put_Line (Typ_Name & " start");
declare
Obj_1 : Typ;
Obj_2 : Typ;
pragma Warnings (Off, Obj_2);
begin
Obj_1 := Obj_2;
end;
Put_Line (Typ_Name & " end");
end Test;
----------
-- Ctrl --
----------
procedure Adjust (Obj : in out Ctrl) is
begin
Adjust_Id ("Ctrl", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
begin
Finalize_Id ("Ctrl", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Initialize_Id ("Ctrl", Obj.Id);
end Initialize;
-------------
-- Ctrl_DC --
-------------
procedure Adjust (Obj : in out Ctrl_DC) is
begin
Adjust_Id ("Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC) is
begin
Finalize_Id ("Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC) is
begin
Initialize_Id ("Ctrl_DC", Obj.Id);
end Initialize;
------------------
-- Ctrl_Ctrl_DC --
------------------
procedure Adjust (Obj : in out Ctrl_Ctrl_DC) is
begin
Adjust_Id ("Ctrl_Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_Ctrl_DC) is
begin
Finalize_Id ("Ctrl_Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_Ctrl_DC) is
begin
Initialize_Id ("Ctrl_Ctrl_DC", Obj.Id);
end Initialize;
-------------
-- Ctrl_DC --
-------------
procedure Adjust (Obj : in out Ctrl_DC_Ctrl) is
begin
Adjust_Id ("Ctrl_DC_Ctrl", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC_Ctrl) is
begin
Finalize_Id ("Ctrl_DC_Ctrl", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC_Ctrl) is
begin
Initialize_Id ("Ctrl_DC_Ctrl", Obj.Id);
end Initialize;
---------------------
-- Ctrl_DC_Ctrl_DC --
---------------------
procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Adjust_Id ("Ctrl_DC_Ctrl_DC", Obj.Id);
end Adjust;
procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Finalize_Id ("Ctrl_DC_Ctrl_DC", Obj.Id);
end Finalize;
procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC) is
begin
Initialize_Id ("Ctrl_DC_Ctrl_DC", Obj.Id);
end Initialize;
end Types;
----------------------------
-- Compilation and output --
----------------------------
$ gcc -c semantics.ads
$ gnatmake -q executable.adb
$ ./executable
semantics.ads:11:36: expected a boolean type
semantics.ads:11:36: found type "Standard.Integer"
semantics.ads:21:11: aspect "Disable_Controlled" requires controlled record
type
semantics.ads:24:11: aspect "Disable_Controlled" requires controlled record
type
semantics.ads:27:33: expected a boolean type
semantics.ads:27:33: found a string type
semantics.ads:30:11: expression of aspect "Disable_Controlled" must be static
gen Ctrl start
gen Ctrl ini: 100
gen Ctrl ini: 101
gen Ctrl fin: 100
gen Ctrl adj: 101 => 102
gen Ctrl fin: 101
gen Ctrl fin: 102
gen Ctrl end
gen Ctrl_DC start
gen Ctrl_DC end
gen Ctrl_Ctrl_DC start
gen Ctrl_Ctrl_DC ini: 102
gen Ctrl_Ctrl_DC ini: 103
gen Ctrl_Ctrl_DC fin: 102
gen Ctrl_Ctrl_DC adj: 103 => 104
gen Ctrl_Ctrl_DC fin: 103
gen Ctrl_Ctrl_DC fin: 104
gen Ctrl_Ctrl_DC end
gen Ctrl_DC_Ctrl start
gen Ctrl ini: 104
gen Ctrl ini: 105
gen Ctrl fin: 104
gen Ctrl adj: 105 => 106
gen Ctrl fin: 105
gen Ctrl fin: 106
gen Ctrl_DC_Ctrl end
gen Ctrl_DC_Ctrl_DC start
gen Ctrl_DC_Ctrl_DC end
gen Rec_Ctrl_DC start
gen Rec_Ctrl_DC end
Ctrl start
Ctrl ini: 106
Ctrl ini: 107
Ctrl fin: 106
Ctrl adj: 107 => 108
Ctrl fin: 107
Ctrl fin: 108
Ctrl end
Ctrl_DC start
Ctrl_DC end
Ctrl_Ctrl_DC start
Ctrl_Ctrl_DC ini: 108
Ctrl_Ctrl_DC ini: 109
Ctrl_Ctrl_DC fin: 108
Ctrl_Ctrl_DC adj: 109 => 110
Ctrl_Ctrl_DC fin: 109
Ctrl_Ctrl_DC fin: 110
Ctrl_Ctrl_DC end
Ctrl_DC_Ctrl start
Ctrl ini: 110
Ctrl ini: 111
Ctrl fin: 110
Ctrl adj: 111 => 112
Ctrl fin: 111
Ctrl fin: 112
Ctrl_DC_Ctrl end
Ctrl_DC_Ctrl_DC start
Ctrl_DC_Ctrl_DC end
Rec_Ctrl_DC start
Rec_Ctrl_DC end
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-13 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Flag42 is now Is_Controlled_Active.
(Is_Controlled): This attribute is now synthesized.
(Is_Controlled_Active): This attribute is now an explicit flag rather
than a synthesized attribute. (Set_Is_Controlled): Removed.
(Set_Is_Controlled_Active): New routine.
(Write_Entity_Flags): Update the output for Flag42.
* einfo.ads: Update the documentation of the following attributes:
Disable_Controlled, Is_Controlled, Is_Controlled_Active, Is_Controlled
and Is_Controlled_Active have swapped their functionality.
(Is_Controlled): Renamed to Is_Controlled_Active.
(Is_Controlled_Active): Renamed to Is_Controlled.
(Set_Is_Controlled): Renamed to Set_Is_Controlled_Active.
* exp_ch3.adb (Expand_Freeze_Record_Type): Restore the original use of
Is_Controlled.
* exp_util.adb (Has_Some_Controlled_Component): Code clean up.
(Needs_Finalization): Code clean up. Remove the tests for
Disable_Controlled because a) they were incorrect as they would reject
a type which is sublect to the aspect, but may contain controlled
components, and b) they are no longer necessary.
* exp_util.ads (Needs_Finalization): Update comment on documentation.
* freeze.adb (Freeze_Array_Type): Restore the original use of
Is_Controlled.
(Freeze_Record_Type): Restore the original use of Is_Controlled.
* sem_ch3.adb (Analyze_Object_Declaration): Restore the original use of
Is_Controlled.
(Array_Type_Declaration): Restore the original use of Is_Controlled.
(Build_Derived_Private_Type): Restore the original use of
Is_Controlled.
(Build_Derived_Record_Type): Set the Is_Controlled_Active flag of a
type derived from Ada.Finalization.[Limited_]Controlled.
(Build_Derived_Type): Restore the original use of Is_Controlled.
(Record_Type_Definition): Restore the original use of Is_Controlled.
* sem_ch7.adb (Preserve_Full_Attributes): Restore the original use of
Is_Controlled.
* sem_ch13.adb (Analyze_Aspect_Disable_Controlled): New routine.
(Analyze_Aspect_Specifications): Use routine
Analyze_Aspect_Disable_Controlled to process aspect Disable_Controlled.
-------------- next part --------------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 252062)
+++ einfo.adb (working copy)
@@ -334,7 +334,7 @@
-- Body_Needed_For_SAL Flag40
-- Treat_As_Volatile Flag41
- -- Is_Controlled Flag42
+ -- Is_Controlled_Active Flag42
-- Has_Controlled_Component Flag43
-- Is_Pure Flag44
-- In_Private_Part Flag45
@@ -2189,10 +2189,10 @@
return Flag76 (Id);
end Is_Constructor;
- function Is_Controlled (Id : E) return B is
+ function Is_Controlled_Active (Id : E) return B is
begin
return Flag42 (Base_Type (Id));
- end Is_Controlled;
+ end Is_Controlled_Active;
function Is_Controlling_Formal (Id : E) return B is
begin
@@ -5341,11 +5341,11 @@
Set_Flag76 (Id, V);
end Set_Is_Constructor;
- procedure Set_Is_Controlled (Id : E; V : B := True) is
+ procedure Set_Is_Controlled_Active (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
Set_Flag42 (Id, V);
- end Set_Is_Controlled;
+ end Set_Is_Controlled_Active;
procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is
begin
@@ -7902,14 +7902,14 @@
K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter;
end Is_Constant_Object;
- --------------------------
- -- Is_Controlled_Active --
- --------------------------
+ -------------------
+ -- Is_Controlled --
+ -------------------
- function Is_Controlled_Active (Id : E) return B is
+ function Is_Controlled (Id : E) return B is
begin
- return Is_Controlled (Id) and then not Disable_Controlled (Id);
- end Is_Controlled_Active;
+ return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
+ end Is_Controlled;
--------------------
-- Is_Discriminal --
@@ -9549,7 +9549,7 @@
W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id));
W ("Is_Constrained", Flag12 (Id));
W ("Is_Constructor", Flag76 (Id));
- W ("Is_Controlled", Flag42 (Id));
+ W ("Is_Controlled_Active", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
W ("Is_Descendant_Of_Address", Flag223 (Id));
W ("Is_DIC_Procedure", Flag132 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 252062)
+++ einfo.ads (working copy)
@@ -980,8 +980,9 @@
-- incomplete type.
-- Disable_Controlled (Flag253)
--- Present in all entities. Set for a controlled type (Is_Controlled flag
--- set) if the aspect Disable_Controlled is active for the type.
+-- Present in all entities. Set for a controlled type subject to aspect
+-- Disable_Controlled which evaluates to True. This flag is taken into
+-- account in synthesized attribute Is_Controlled.
-- Discard_Names (Flag88)
-- Defined in types and exception entities. Set if pragma Discard_Names
@@ -2443,14 +2444,14 @@
-- Defined in function and procedure entities. Set if a pragma
-- CPP_Constructor applies to the subprogram.
--- Is_Controlled (Flag42) [base type only]
+-- Is_Controlled_Active (Flag42) [base type only]
-- Defined in all type entities. Indicates that the type is controlled,
-- 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_Controlled (synth) [base type only]
+-- Defined in all type entities. Set if Is_Controlled_Active 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
@@ -5648,7 +5649,7 @@
-- Is_Atomic (Flag85)
-- Is_Constr_Subt_For_U_Nominal (Flag80)
-- Is_Constr_Subt_For_UN_Aliased (Flag141)
- -- Is_Controlled (Flag42) (base type only)
+ -- Is_Controlled_Active (Flag42) (base type only)
-- Is_Eliminated (Flag124)
-- Is_Frozen (Flag4)
-- Is_Generic_Actual_Type (Flag94)
@@ -5684,7 +5685,7 @@
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
- -- Is_Controlled_Active (synth)
+ -- Is_Controlled (synth)
-- Partial_Invariant_Procedure (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
@@ -6344,7 +6345,7 @@
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
- -- Is_Controlled (Flag42) (base type only)
+ -- Is_Controlled_Active (Flag42) (base type only)
-- Is_For_Access_Subtype (Flag118) (subtype only)
-- (plus type attributes)
@@ -6497,7 +6498,7 @@
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
- -- Is_Controlled (Flag42) (base type only)
+ -- Is_Controlled_Active (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
-- No_Reordering (Flag239) (base type only)
@@ -6526,7 +6527,7 @@
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
- -- Is_Controlled (Flag42) (base type only)
+ -- Is_Controlled_Active (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
-- No_Reordering (Flag239) (base type only)
@@ -7169,7 +7170,7 @@
function Is_Constr_Subt_For_UN_Aliased (Id : E) return B;
function Is_Constrained (Id : E) return B;
function Is_Constructor (Id : E) return B;
- function Is_Controlled (Id : E) return B;
+ function Is_Controlled_Active (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_CPP_Class (Id : E) return B;
function Is_Descendant_Of_Address (Id : E) return B;
@@ -7489,7 +7490,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_Controlled (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;
@@ -7858,7 +7859,7 @@
procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True);
procedure Set_Is_Constrained (Id : E; V : B := True);
procedure Set_Is_Constructor (Id : E; V : B := True);
- procedure Set_Is_Controlled (Id : E; V : B := True);
+ procedure Set_Is_Controlled_Active (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_CPP_Class (Id : E; V : B := True);
procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True);
@@ -8676,7 +8677,7 @@
pragma Inline (Is_Constr_Subt_For_UN_Aliased);
pragma Inline (Is_Constrained);
pragma Inline (Is_Constructor);
- pragma Inline (Is_Controlled);
+ pragma Inline (Is_Controlled_Active);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_CPP_Class);
pragma Inline (Is_Decimal_Fixed_Point_Type);
@@ -9190,7 +9191,7 @@
pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased);
pragma Inline (Set_Is_Constrained);
pragma Inline (Set_Is_Constructor);
- pragma Inline (Set_Is_Controlled);
+ pragma Inline (Set_Is_Controlled_Active);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_CPP_Class);
pragma Inline (Set_Is_Descendant_Of_Address);
@@ -9434,7 +9435,7 @@
pragma Inline (Base_Type);
pragma Inline (Is_Base_Type);
- pragma Inline (Is_Controlled_Active);
+ pragma Inline (Is_Controlled);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 252062)
+++ exp_ch3.adb (working copy)
@@ -4951,7 +4951,7 @@
and then
(Has_Controlled_Component (Comp_Typ)
or else (Chars (Comp) /= Name_uParent
- and then (Is_Controlled_Active (Comp_Typ))))
+ and then Is_Controlled (Comp_Typ)))
then
Set_Has_Controlled_Component (Typ);
end if;
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 252062)
+++ exp_util.adb (working copy)
@@ -10296,48 +10296,48 @@
-- Needs_Finalization --
------------------------
- function Needs_Finalization (T : Entity_Id) return Boolean is
- function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
- -- If type is not frozen yet, check explicitly among its components,
- -- because the Has_Controlled_Component flag is not necessarily set.
+ function Needs_Finalization (Typ : Entity_Id) return Boolean is
+ function Has_Some_Controlled_Component
+ (Input_Typ : Entity_Id) return Boolean;
+ -- Determine whether type Input_Typ has at least one controlled
+ -- component.
-----------------------------------
-- Has_Some_Controlled_Component --
-----------------------------------
function Has_Some_Controlled_Component
- (Rec : Entity_Id) return Boolean
+ (Input_Typ : Entity_Id) return Boolean
is
Comp : Entity_Id;
begin
- if Has_Controlled_Component (Rec) then
+ -- When a type is already frozen and has at least one controlled
+ -- component, or is manually decorated, it is sufficient to inspect
+ -- flag Has_Controlled_Component.
+
+ if Has_Controlled_Component (Input_Typ) then
return True;
- elsif not Is_Frozen (Rec) then
- if Is_Record_Type (Rec) then
- Comp := First_Entity (Rec);
+ -- Otherwise inspect the internals of the type
+ elsif not Is_Frozen (Input_Typ) then
+ if Is_Array_Type (Input_Typ) then
+ return Needs_Finalization (Component_Type (Input_Typ));
+
+ elsif Is_Record_Type (Input_Typ) then
+ Comp := First_Component (Input_Typ);
while Present (Comp) loop
- if not Is_Type (Comp)
- and then Needs_Finalization (Etype (Comp))
- then
+ if Needs_Finalization (Etype (Comp)) then
return True;
end if;
- Next_Entity (Comp);
+ Next_Component (Comp);
end loop;
-
- return False;
-
- else
- return
- Is_Array_Type (Rec)
- and then Needs_Finalization (Component_Type (Rec));
end if;
- else
- return False;
end if;
+
+ return False;
end Has_Some_Controlled_Component;
-- Start of processing for Needs_Finalization
@@ -10349,32 +10349,34 @@
if Restriction_Active (No_Finalization) then
return False;
- -- C++ types are not considered controlled. It is assumed that the
- -- non-Ada side will handle their clean up.
+ -- C++ types are not considered controlled. It is assumed that the non-
+ -- Ada side will handle their clean up.
- elsif Convention (T) = Convention_CPP then
+ elsif Convention (Typ) = Convention_CPP then
return False;
- -- Never needs finalization if Disable_Controlled set
+ -- Class-wide types are treated as controlled because derivations from
+ -- the root type may introduce controlled components.
- elsif Disable_Controlled (T) then
- return False;
+ elsif Is_Class_Wide_Type (Typ) then
+ return True;
- elsif Is_Class_Wide_Type (T) and then Disable_Controlled (Etype (T)) then
- return False;
+ -- Concurrent types are controlled as long as their corresponding record
+ -- is controlled.
+ elsif Is_Concurrent_Type (Typ)
+ and then Present (Corresponding_Record_Type (Typ))
+ and then Needs_Finalization (Corresponding_Record_Type (Typ))
+ then
+ return True;
+
+ -- Otherwise the type is controlled when it is either derived from type
+ -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
+ -- contains at least one controlled component.
+
else
- -- Class-wide types are treated as controlled because derivations
- -- from the root type can introduce controlled components.
-
return
- Is_Class_Wide_Type (T)
- or else Is_Controlled (T)
- or else Has_Some_Controlled_Component (T)
- or else
- (Is_Concurrent_Type (T)
- and then Present (Corresponding_Record_Type (T))
- and then Needs_Finalization (Corresponding_Record_Type (T)));
+ Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
end if;
end Needs_Finalization;
@@ -10387,7 +10389,6 @@
Typ : Entity_Id) return Boolean
is
begin
-
-- If we have no initialization of any kind, then we don't need to place
-- any restrictions on the address clause, because the object will be
-- elaborated after the address clause is evaluated. This happens if the
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 252062)
+++ exp_util.ads (working copy)
@@ -924,11 +924,9 @@
-- consist of constants, when the object has a nontrivial initialization
-- or is controlled.
- function Needs_Finalization (T : Entity_Id) return Boolean;
- -- True if type T is controlled, or has controlled subcomponents. Also
- -- True if T is a class-wide type, because some type extension might add
- -- controlled subcomponents, except that if pragma Restrictions
- -- (No_Finalization) applies, this is False for class-wide types.
+ function Needs_Finalization (Typ : Entity_Id) return Boolean;
+ -- Determine whether type Typ is controlled and this requires finalization
+ -- actions.
function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
-- An anonymous access type may designate a limited view. Check whether
Index: freeze.adb
===================================================================
--- freeze.adb (revision 252062)
+++ freeze.adb (working copy)
@@ -2574,7 +2574,7 @@
-- Propagate flags for component type
- if Is_Controlled_Active (Component_Type (Arr))
+ if Is_Controlled (Component_Type (Arr))
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (Arr);
@@ -4508,7 +4508,7 @@
(Has_Controlled_Component (Etype (Comp))
or else
(Chars (Comp) /= Name_uParent
- and then Is_Controlled_Active (Etype (Comp)))
+ and then Is_Controlled (Etype (Comp)))
or else
(Is_Protected_Type (Etype (Comp))
and then
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 252062)
+++ sem_ch13.adb (working copy)
@@ -1595,6 +1595,9 @@
procedure Analyze_Aspect_Convention;
-- Perform analysis of aspect Convention
+ procedure Analyze_Aspect_Disable_Controlled;
+ -- Perform analysis of aspect Disable_Controlled
+
procedure Analyze_Aspect_Export_Import;
-- Perform analysis of aspects Export or Import
@@ -1678,6 +1681,60 @@
end if;
end Analyze_Aspect_Convention;
+ ---------------------------------------
+ -- Analyze_Aspect_Disable_Controlled --
+ ---------------------------------------
+
+ procedure Analyze_Aspect_Disable_Controlled is
+ begin
+ -- The aspect applies only to controlled records
+
+ if not (Ekind (E) = E_Record_Type
+ and then Is_Controlled_Active (E))
+ then
+ Error_Msg_N
+ ("aspect % requires controlled record type", Aspect);
+ return;
+ end if;
+
+ -- Preanalyze the expression (if any) when the aspect resides
+ -- in a generic unit.
+
+ if Inside_A_Generic then
+ if Present (Expr) then
+ Preanalyze_And_Resolve (Expr, Any_Boolean);
+ end if;
+
+ -- Otherwise the aspect resides in a nongeneric context
+
+ else
+ -- A controlled record type loses its controlled semantics
+ -- when the expression statically evaluates to True.
+
+ if Present (Expr) then
+ Analyze_And_Resolve (Expr, Any_Boolean);
+
+ if Is_OK_Static_Expression (Expr) then
+ if Is_True (Static_Boolean (Expr)) then
+ Set_Disable_Controlled (E);
+ end if;
+
+ -- Otherwise the expression is not static
+
+ else
+ Error_Msg_N
+ ("expression of aspect % must be static", Aspect);
+ end if;
+
+ -- Otherwise the aspect appears without an expression and
+ -- defaults to True.
+
+ else
+ Set_Disable_Controlled (E);
+ end if;
+ end if;
+ end Analyze_Aspect_Disable_Controlled;
+
----------------------------------
-- Analyze_Aspect_Export_Import --
----------------------------------
@@ -3468,34 +3525,7 @@
-- 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 we're in a generic template, we don't want to try
- -- to disable controlled types, because typical usage is
- -- "Disable_Controlled => not <some_check>'Enabled", and
- -- the value of Enabled is not known until we see a
- -- particular instance. In such a context, we just need
- -- to preanalyze the expression for legality.
-
- if Expander_Active then
- Analyze_And_Resolve (Expr, Standard_Boolean);
-
- if not Present (Expr)
- or else Is_True (Static_Boolean (Expr))
- then
- Set_Disable_Controlled (E);
- end if;
-
- elsif Serious_Errors_Detected = 0 then
- Preanalyze_And_Resolve (Expr, Standard_Boolean);
- end if;
-
+ Analyze_Aspect_Disable_Controlled;
goto Continue;
end if;
@@ -10839,8 +10869,8 @@
E : constant Entity_Id := Entity (N);
- Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
- -- True in non-generic case. Some of the processing here is skipped
+ Nongeneric_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
+ -- True in nongeneric case. Some of the processing here is skipped
-- for the generic case since it is not needed. Basically in the
-- generic case, we only need to do stuff that might generate error
-- messages or warnings.
@@ -10867,7 +10897,7 @@
-- This is not needed in the generic case
if Ada_Version >= Ada_2005
- and then Non_Generic_Case
+ and then Nongeneric_Case
and then Ekind (E) = E_Record_Type
and then Is_Tagged_Type (E)
and then not Is_Interface (E)
@@ -11003,7 +11033,7 @@
-- predefined primitives.
if Is_Type (E)
- and then Non_Generic_Case
+ and then Nongeneric_Case
and then not Within_Internal_Subprogram
and then Has_Predicates (E)
then
@@ -11019,7 +11049,7 @@
-- This is also not needed in the generic case
- if Non_Generic_Case
+ if Nongeneric_Case
and then Has_Delayed_Aspects (E)
and then Scope (E) = Current_Scope
then
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 252062)
+++ sem_ch3.adb (working copy)
@@ -4848,7 +4848,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_Active (T)
+ and then not Is_Controlled (T)
and then not Has_Controlled_Component (Base_Type (T))
and then Expander_Active
then
@@ -6157,7 +6157,7 @@
Set_Has_Controlled_Component
(Implicit_Base,
Has_Controlled_Component (Element_Type)
- or else Is_Controlled_Active (Element_Type));
+ or else Is_Controlled (Element_Type));
Set_Packed_Array_Impl_Type
(Implicit_Base, Empty);
@@ -6178,7 +6178,7 @@
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
- Is_Controlled_Active (Element_Type));
+ Is_Controlled (Element_Type));
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
(Element_Type));
Set_Default_SSO (T);
@@ -7897,18 +7897,21 @@
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_Disable_Controlled (Derived_Type, Disable_Controlled
- (Parent_Type));
+ Set_Stored_Constraint (Derived_Type, No_Elist);
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+
+ Set_Is_Controlled_Active
+ (Derived_Type, Is_Controlled_Active (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_Active (Parent_Type) then
+ if not Is_Controlled (Parent_Type) then
Set_Finalize_Storage_Only
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
@@ -9206,9 +9209,10 @@
and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
then
- Set_Is_Controlled (Derived_Type);
+ Set_Is_Controlled_Active (Derived_Type);
else
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
+ Set_Is_Controlled_Active
+ (Derived_Type, Is_Controlled_Active (Parent_Base));
end if;
-- Minor optimization: there is no need to generate the class-wide
@@ -9475,20 +9479,21 @@
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));
Propagate_Concurrent_Flags (Derived_Type, 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_Active
+ (Derived_Type, Is_Controlled_Active (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));
- Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
- Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
-
if Is_Tagged_Type (Derived_Type) then
Set_No_Tagged_Streams_Pragma
(Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
@@ -21799,7 +21804,7 @@
end;
end if;
- Final_Storage_Only := not Is_Controlled_Active (T);
+ Final_Storage_Only := not Is_Controlled (T);
-- Ada 2005: Check whether an explicit Limited is present in a derived
-- type declaration.
@@ -21859,8 +21864,7 @@
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_Active
- (Etype (Component))))
+ and then Is_Controlled (Etype (Component))))
then
Set_Has_Controlled_Component (T, True);
Final_Storage_Only :=
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 252062)
+++ sem_ch7.adb (working copy)
@@ -2644,7 +2644,8 @@
end if;
if Priv_Is_Base_Type then
- Set_Is_Controlled (Priv, Is_Controlled (Full_Base));
+ Set_Is_Controlled_Active
+ (Priv, Is_Controlled_Active (Full_Base));
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only (Full_Base));
Set_Has_Controlled_Component
More information about the Gcc-patches
mailing list