ada: Simplify finalization of temporaries created for interface objects

The expansion of (class-wide) interface objects generates a temporary that
holds the actual data and the objects are rewritten as the renaming of the
dereference at the interface tag present in it. These temporaries may need
to be finalized and this is currently done through the renamings, by using
pattern matching to recognize the original source constructs.

Now these temporaries may also need to be adjusted and this is currently
done "naturally", i.e. by using the standard machinery for them, so there
is no fundamental reason why the finalization cannot be done this way too.

Therefore this changes removes the special machinery implemented for their
finalization and let them be handled by the standard one instead.

gcc/ada/

	* exp_util.ads (Is_Tag_To_Class_Wide_Conversion): Delete.
	(Is_Displacement_Of_Object_Or_Function_Result): Likewise.
	* exp_util.adb (Is_Tag_To_Class_Wide_Conversion): Rename to...
	(Is_Temporary_For_Interface_Object): ...this.
	(Is_Finalizable_Transient): Adjust call to above renaming.
	(Is_Displacement_Of_Object_Or_Function_Result): Delete.
	(Requires_Cleanup_Actions): Remove special handling of the
	temporaries created for interface objects.
	* exp_ch7.adb (Build_Finalizer): Likewise.

3 files changed, 31 insertions, 286 deletions

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 4cb2689..f29a97a 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -2264,16 +2264,13 @@ package body Exp_Ch7 is
                --  The object is of the form:
                --    Obj : [constant] Typ [:= Expr];
 
-               --  Do not process tag-to-class-wide conversions because they do
-               --  not yield an object. Do not process the incomplete view of a
-               --  deferred constant. Note that an object initialized by means
-               --  of a build-in-place function call may appear as a deferred
-               --  constant after expansion activities. These kinds of objects
-               --  must be finalized.
+               --  Do not process the incomplete view of a deferred constant.
+               --  Note that an object initialized by means of a BIP function
+               --  call may appear as a deferred constant after expansion
+               --  activities. These kinds of objects must be finalized.
 
                elsif not Is_Imported (Obj_Id)
                  and then Needs_Finalization (Obj_Typ)
-                 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
                  and then not (Ekind (Obj_Id) = E_Constant
                                 and then not Has_Completion (Obj_Id)
                                 and then No (BIP_Initialization_Call (Obj_Id)))
@@ -2388,23 +2385,6 @@ package body Exp_Ch7 is
                  and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
                then
                   Processing_Actions (Has_No_Init => True);
-
-               --  Detect a case where a source object has been initialized by
-               --  a controlled function call or another object which was later
-               --  rewritten as a class-wide conversion of Ada.Tags.Displace:
-
-               --     Obj1 : CW_Type := Function_Call (...);
-               --     Obj2 : CW_Type := Src_Obj;
-
-               --     Tmp  : ... := Function_Call (...)'reference;
-               --     Rnn  : access CW_Type := (... Ada.Tags.Displace (Tmp));
-               --     Obj1 : CW_Type renames Rnn.all;
-
-               --     Rnn : access CW_Type := (...Ada.Tags.Displace (Src_Obj));
-               --     Obj2 : CW_Type renames Rnn.all;
-
-               elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
-                  Processing_Actions (Has_No_Init => True);
                end if;
 
             --  Inspect the freeze node of an access-to-controlled type and
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index ab4b18d..e89c6a9 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -168,9 +168,10 @@ package body Exp_Util is
    --  Force evaluation of bounds of a slice, which may be given by a range
    --  or by a subtype indication with or without a constraint.
 
-   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
-   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
-   --  an assertion expression that should be verified at run time.
+   function Is_Temporary_For_Interface_Object
+     (Obj_Id : Entity_Id) return Boolean;
+   --  Determine whether Obj_Id is a temporary created for the handling of a
+   --  (class-wide) interface object.
 
    function Is_Uninitialized_Aggregate
      (Exp : Node_Id;
@@ -182,6 +183,10 @@ package body Exp_Util is
    --  the bounds of the aggregate can be propagated directly to the
    --  object declaration.
 
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
+   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
+   --  an assertion expression that should be verified at run time.
+
    function Make_CW_Equivalent_Type
      (T : Entity_Id;
       E : Node_Id) return Entity_Id;
@@ -8185,216 +8190,6 @@ package body Exp_Util is
       end if;
    end Is_Captured_Function_Call;
 
-   --------------------------------------------------
-   -- Is_Displacement_Of_Object_Or_Function_Result --
-   --------------------------------------------------
-
-   function Is_Displacement_Of_Object_Or_Function_Result
-     (Obj_Id : Entity_Id) return Boolean
-   is
-      function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
-      --  Determine whether node N denotes a controlled function call
-
-      function Is_Controlled_Indexing (N : Node_Id) return Boolean;
-      --  Determine whether node N denotes a generalized indexing form which
-      --  involves a controlled result.
-
-      function Is_Displace_Call (N : Node_Id) return Boolean;
-      --  Determine whether node N denotes a call to Ada.Tags.Displace
-
-      function Is_Source_Object (N : Node_Id) return Boolean;
-      --  Determine whether a particular node denotes a source object
-
-      function Strip (N : Node_Id) return Node_Id;
-      --  Examine arbitrary node N by stripping various indirections and return
-      --  the "real" node.
-
-      ---------------------------------
-      -- Is_Controlled_Function_Call --
-      ---------------------------------
-
-      function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
-         Expr : Node_Id;
-
-      begin
-         --  When a function call appears in Object.Operation format, the
-         --  original representation has several possible forms depending on
-         --  the availability and form of actual parameters:
-
-         --    Obj.Func                    N_Selected_Component
-         --    Obj.Func (Actual)           N_Indexed_Component
-         --    Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-         --                                N_Selected_Component
-
-         Expr := Original_Node (N);
-         loop
-            if Nkind (Expr) = N_Function_Call then
-               Expr := Name (Expr);
-
-            --  "Obj.Func (Actual)" case
-
-            elsif Nkind (Expr) = N_Indexed_Component then
-               Expr := Prefix (Expr);
-
-            --  "Obj.Func" or "Obj.Func (Formal => Actual) case
-
-            elsif Nkind (Expr) = N_Selected_Component then
-               Expr := Selector_Name (Expr);
-
-            else
-               exit;
-            end if;
-         end loop;
-
-         return
-           Nkind (Expr) in N_Has_Entity
-             and then Present (Entity (Expr))
-             and then Ekind (Entity (Expr)) = E_Function
-             and then Needs_Finalization (Etype (Entity (Expr)));
-      end Is_Controlled_Function_Call;
-
-      ----------------------------
-      -- Is_Controlled_Indexing --
-      ----------------------------
-
-      function Is_Controlled_Indexing (N : Node_Id) return Boolean is
-         Expr : constant Node_Id := Original_Node (N);
-
-      begin
-         return
-           Nkind (Expr) = N_Indexed_Component
-             and then Present (Generalized_Indexing (Expr))
-             and then Needs_Finalization (Etype (Expr));
-      end Is_Controlled_Indexing;
-
-      ----------------------
-      -- Is_Displace_Call --
-      ----------------------
-
-      function Is_Displace_Call (N : Node_Id) return Boolean is
-         Call : constant Node_Id := Strip (N);
-
-      begin
-         return
-           Present (Call)
-             and then Nkind (Call) = N_Function_Call
-             and then Nkind (Name (Call)) in N_Has_Entity
-             and then Is_RTE (Entity (Name (Call)), RE_Displace);
-      end Is_Displace_Call;
-
-      ----------------------
-      -- Is_Source_Object --
-      ----------------------
-
-      function Is_Source_Object (N : Node_Id) return Boolean is
-         Obj : constant Node_Id := Strip (N);
-
-      begin
-         return
-           Present (Obj)
-             and then Comes_From_Source (Obj)
-             and then Nkind (Obj) in N_Has_Entity
-             and then Is_Object (Entity (Obj));
-      end Is_Source_Object;
-
-      -----------
-      -- Strip --
-      -----------
-
-      function Strip (N : Node_Id) return Node_Id is
-         Result : Node_Id;
-
-      begin
-         Result := N;
-         loop
-            if Nkind (Result) = N_Explicit_Dereference then
-               Result := Prefix (Result);
-
-            elsif Nkind (Result) in
-                    N_Type_Conversion | N_Unchecked_Type_Conversion
-            then
-               Result := Expression (Result);
-
-            else
-               exit;
-            end if;
-         end loop;
-
-         return Result;
-      end Strip;
-
-      --  Local variables
-
-      Obj_Decl  : constant Node_Id   := Declaration_Node (Obj_Id);
-      Obj_Typ   : constant Entity_Id := Base_Type (Etype (Obj_Id));
-      Orig_Decl : constant Node_Id   := Original_Node (Obj_Decl);
-      Orig_Expr : Node_Id;
-
-   --  Start of processing for Is_Displacement_Of_Object_Or_Function_Result
-
-   begin
-      --  Case 1:
-
-      --     Obj : CW_Type := Function_Call (...);
-
-      --  is rewritten into:
-
-      --     Tmp : ... := Function_Call (...)'reference;
-      --     Rnn : constant access CW_Type := (... Ada.Tags.Displace (Tmp));
-      --     Obj : CW_Type renames Rnn.all;
-
-      --  where the return type of the function and the class-wide type require
-      --  dispatch table pointer displacement.
-
-      --  Case 2:
-
-      --     Obj : CW_Type := Container (...);
-
-      --  is rewritten into:
-
-      --     Tmp : ... := Function_Call (Container, ...)'reference;
-      --     Rnn : constant access CW_Type := (... Ada.Tags.Displace (Tmp));
-      --     Obj : CW_Type renames Rnn.all;
-
-      --  where the container element type and the class-wide type require
-      --  dispatch table pointer dispacement.
-
-      --  Case 3:
-
-      --     Obj : CW_Type := Src_Obj;
-
-      --  is rewritten into:
-
-      --     Rnn : constant access CW_Type := (...Ada.Tags.Displace (Src_Obj));
-      --     Obj : CW_Type renames Rnn.all;
-
-      --  where the type of the source object and the class-wide type require
-      --  dispatch table pointer displacement.
-
-      if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
-        and then Is_Class_Wide_Type (Obj_Typ)
-        and then not Is_Special_Return_Object (Obj_Id)
-        and then Nkind (Renamed_Object (Obj_Id)) = N_Explicit_Dereference
-        and then Is_Entity_Name (Prefix (Renamed_Object (Obj_Id)))
-        and then Ekind (Entity (Prefix (Renamed_Object (Obj_Id)))) = E_Constant
-        and then
-          Is_Displace_Call
-            (Constant_Value (Entity (Prefix (Renamed_Object (Obj_Id)))))
-        and then Nkind (Orig_Decl) = N_Object_Declaration
-        and then Comes_From_Source (Orig_Decl)
-      then
-         Orig_Expr := Expression (Orig_Decl);
-
-         return
-           Is_Controlled_Function_Call (Orig_Expr)
-             or else Is_Controlled_Indexing (Orig_Expr)
-             or else Is_Source_Object (Orig_Expr);
-
-      else
-         return False;
-      end if;
-   end Is_Displacement_Of_Object_Or_Function_Result;
-
    ------------------------------
    -- Is_Finalizable_Transient --
    ------------------------------
@@ -8845,9 +8640,10 @@ package body Exp_Util is
 
           and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
 
-          --  Do not consider conversions of tags to class-wide types
+          --  Do not consider temporaries created for (class-wide) interface
+          --  objects because they must exist as long as the object is around.
 
-          and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
+          and then not Is_Temporary_For_Interface_Object (Obj_Id)
 
           --  Do not consider iterators because those are treated as normal
           --  controlled objects and are processed by the usual finalization
@@ -9356,22 +9152,23 @@ package body Exp_Util is
         and then Has_Controlling_Result (Id);
    end Is_Secondary_Stack_Thunk;
 
-   -------------------------------------
-   -- Is_Tag_To_Class_Wide_Conversion --
-   -------------------------------------
+   ---------------------------------------
+   -- Is_Temporary_For_Interface_Object --
+   ---------------------------------------
 
-   function Is_Tag_To_Class_Wide_Conversion
+   function Is_Temporary_For_Interface_Object
      (Obj_Id : Entity_Id) return Boolean
    is
-      Expr : constant Node_Id := Expression (Parent (Obj_Id));
+      Expr : constant Node_Id := Expression (Declaration_Node (Obj_Id));
 
    begin
-      return
-        Is_Class_Wide_Type (Etype (Obj_Id))
-          and then Present (Expr)
-          and then Nkind (Expr) = N_Unchecked_Type_Conversion
-          and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
-   end Is_Tag_To_Class_Wide_Conversion;
+      --  This must be kept synchronized with Expand_N_Object_Declaration
+
+      return Is_Class_Wide_Type (Etype (Obj_Id))
+        and then Present (Expr)
+        and then Nkind (Expr) = N_Unchecked_Type_Conversion
+        and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
+   end Is_Temporary_For_Interface_Object;
 
    --------------------------------
    -- Is_Uninitialized_Aggregate --
@@ -12880,16 +12677,13 @@ package body Exp_Util is
             --  The object is of the form:
             --    Obj : [constant] Typ [:= Expr];
             --
-            --  Do not process tag-to-class-wide conversions because they do
-            --  not yield an object. Do not process the incomplete view of a
-            --  deferred constant. Note that an object initialized by means
-            --  of a build-in-place function call may appear as a deferred
-            --  constant after expansion activities. These kinds of objects
-            --  must be finalized.
+            --  Do not process the incomplete view of a deferred constant.
+            --  Note that an object initialized by means of a BIP function
+            --  call may appear as a deferred constant after expansion
+            --  activities. These kinds of objects must be finalized.
 
             elsif not Is_Imported (Obj_Id)
               and then Needs_Finalization (Obj_Typ)
-              and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
               and then not (Ekind (Obj_Id) = E_Constant
                              and then not Has_Completion (Obj_Id)
                              and then No (BIP_Initialization_Call (Obj_Id)))
@@ -12975,23 +12769,6 @@ package body Exp_Util is
               and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
             then
                return True;
-
-            --  Detect a case where a source object has been initialized by
-            --  a controlled function call or another object which was later
-            --  rewritten as a class-wide conversion of Ada.Tags.Displace:
-
-            --     Obj1 : CW_Type := Function_Call (...);
-            --     Obj2 : CW_Type := Src_Obj;
-
-            --     Tmp  : ... := Function_Call (...)'reference;
-            --     Rnn  : access CW_Type := (... Ada.Tags.Displace (Tmp));
-            --     Obj1 : CW_Type renames Rnn.all;
-
-            --     Rnn  : access CW_Type := (... Ada.Tags.Displace (Src_Obj));
-            --     Obj2 : CW_Type renames Rnn.all;
-
-            elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
-               return True;
             end if;
 
          --  Inspect the freeze node of an access-to-controlled type and look
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index b770d02..0b6cb23 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -765,13 +765,6 @@ package Exp_Util is
    --    Rnn : constant Ann := Func (...)'reference;
    --    Rnn.all
 
-   function Is_Displacement_Of_Object_Or_Function_Result
-     (Obj_Id : Entity_Id) return Boolean;
-   --  Determine whether Obj_Id is a source entity that has been initialized by
-   --  either a controlled function call or the assignment of another source
-   --  object. In both cases the initialization expression is rewritten as a
-   --  class-wide conversion of Ada.Tags.Displace.
-
    function Is_Finalizable_Transient
      (Decl     : Node_Id;
       Rel_Node : Node_Id) return Boolean;
@@ -851,11 +844,6 @@ package Exp_Util is
 
    --  WARNING: There is a matching C declaration of this subprogram in fe.h
 
-   function Is_Tag_To_Class_Wide_Conversion
-     (Obj_Id : Entity_Id) return Boolean;
-   --  Determine whether object Obj_Id is the result of a tag-to-class-wide
-   --  type conversion.
-
    function Is_Untagged_Derivation (T : Entity_Id) return Boolean;
    --  Returns true if type T is not tagged and is a derived type,
    --  or is a private type whose completion is such a type.