[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