[Ada] Finalization for b-i-p that raises exception

[Arnaud Charlet]

This patch fixes a bug where if a limited object is initialized with a
build-in-place function call, and the call does not return on the
secondary stack, and the function raises an exception, so that the
object is not (successfully) created, the uninitialized object is
incorrectly finalized.

The following test should compile and run quietly:

with Ada.Finalization; use Ada.Finalization;
package BIP_Fin_Uninit is
   type Inner is new Limited_Controlled with null record;
   type Outer is limited record
      Inn: Inner;
   end record;
   Heck: exception;
   function Make_Outer return Outer;
   procedure Finalize(X: in out Inner);
end BIP_Fin_Uninit;

package body BIP_Fin_Uninit is
   function Make_Outer return Outer is
   begin
      raise Heck;
      return Make_Outer; -- Bogus recursive call never happens.
   end Make_Outer;

   procedure Finalize(X: in out Inner) is
   begin
      -- This should never be called.
      raise Program_Error with "Finalize called";
   end Finalize;
end BIP_Fin_Uninit;

procedure BIP_Fin_Uninit.Main is
begin
   declare
      X: Outer := Make_Outer; -- Propagates an exception.
   begin
      raise Program_Error; -- Can't get here.
   end;
exception
   when Heck =>
      null; -- OK
end BIP_Fin_Uninit.Main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-09-07  Bob Duff  <d...@adacore.com>

        * exp_ch7.adb (Find_Last_Init): Check for the
        case where a build-in-place function call has been replaced by a
        'Reference attribute reference.


Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 251773)
+++ exp_ch7.adb (working copy)
@@ -2763,9 +2763,30 @@
 
             Stmt := Next_Suitable_Statement (Decl);
 
-            --  Nothing to do for an object with suppressed initialization
+            --  For an object with suppressed initialization, we check whether
+            --  there is in fact no initialization expression. If there is not,
+            --  then this is an object declaration that has been turned into a
+            --  different object declaration that calls the build-in-place
+            --  function in a 'Reference attribute, as in "F(...)'Reference".
+            --  We search for that later object declaration, so that the
+            --  Inc_Decl will be inserted after the call. Otherwise, if the
+            --  call raises an exception, we will finalize the (uninitialized)
+            --  object, which is wrong.
 
             if No_Initialization (Decl) then
+               if No (Expression (Last_Init)) then
+                  loop
+                     Last_Init := Next (Last_Init);
+                     exit when No (Last_Init);
+                     exit when Nkind (Last_Init) = N_Object_Declaration
+                       and then Nkind (Expression (Last_Init)) = N_Reference
+                       and then Nkind (Prefix (Expression (Last_Init))) =
+                                  N_Function_Call
+                       and then Is_Expanded_Build_In_Place_Call
+                                  (Prefix (Expression (Last_Init)));
+                  end loop;
+               end if;
+
                return;
 
             --  In all other cases the initialization calls follow the related
@@ -2955,7 +2976,7 @@
 
          if No (Finalizer_Insert_Nod) then
 
-            --  Insertion after an abort deffered block
+            --  Insertion after an abort deferred block
 
             if Present (Body_Ins) then
                Finalizer_Insert_Nod := Body_Ins;