===================================================================
@@ -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;
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 <duff@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.