re PR ada/66242 (Front-end error if exception propagation disabled)

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	PR ada/66242

	* exp_ch3.adb (Default_Initialize_Object): Reimplemented. Abort
	defer / undefer pairs are now encapsulated in a block with
	an AT END handler. Partial finalization now takes restriction
	No_Exception_Propagation into account when generating blocks.
	* exp_ch7.adb Various reformattings.
	(Create_Finalizer): Change
	the generation of abort defer / undefer pairs and explain the
	lack of an AT END handler.
	(Process_Transient_Objects): Add generation of abort defer/undefer
	pairs.
	* exp_ch9.adb Various reformattings.
	(Build_Protected_Subprogram_Body): Use
	Build_Runtime_Call to construct a call to Abort_Defer.
	(Build_Protected_Subprogram_Call_Cleanup): Use
	Build_Runtime_Call to construct a call to Abort_Undefer.
	(Expand_N_Asynchronous_Select): Use Build_Runtime_Call to
	construct a call to Abort_Defer.
	* exp_intr.adb (Expand_Unc_Deallocation): Abort defer
	/ undefer pairs are now encapsulated in a block with
	an AT END handler. Finalization now takes restriction
	No_Exception_Propagation into account when generating blocks.
	* exp_util.ads, exp_util.adb (Wrap_Cleanup_Procedure): Removed.

From-SVN: r230531

gcc/ada/exp_intr.adb

@@ -1022,6 +1022,7 @@ package body Exp_Intr is
 
       Abrt_Blk    : Node_Id := Empty;
       Abrt_Blk_Id : Entity_Id;
+      Abrt_HSS    : Node_Id;
       AUD         : Entity_Id;
       Fin_Blk     : Node_Id;
       Fin_Call    : Node_Id;
@@ -1031,10 +1032,6 @@ package body Exp_Intr is
       Gen_Code    : Node_Id;
       Obj_Ref     : Node_Id;
 
-      Dummy : Entity_Id;
-      --  This variable captures an unused dummy internal entity, see the
-      --  comment associated with its use.
-
    begin
       --  Nothing to do if we know the argument is null
 
@@ -1048,10 +1045,10 @@ package body Exp_Intr is
       --    Ex     : Exception_Occurrence;
       --    Raised : Boolean := False;
 
-      --    begin                             --  aborts allowed
+      --    begin
       --       Abort_Defer;
 
-      --       begin                          --  exception propagation allowed
+      --       begin
       --          [Deep_]Finalize (Obj_Ref);
 
       --       exception
@@ -1121,50 +1118,51 @@ package body Exp_Intr is
                     Exception_Handlers => New_List (
                       Build_Exception_Handler (Fin_Data))));
 
-            --  The finalization action must be protected by an abort defer
-            --  undefer pair when aborts are allowed. Generate:
+         --  Otherwise exception propagation is not allowed
 
-            --    begin
-            --       Abort_Defer;
-            --       <Fin_Blk>
-            --    at end
-            --       Abort_Undefer_Direct;
-            --    end;
+         else
+            Fin_Blk := Fin_Call;
+         end if;
 
-            if Abort_Allowed then
-               AUD := RTE (RE_Abort_Undefer_Direct);
+         --  The finalization action must be protected by an abort defer and
+         --  undefer pair when aborts are allowed. Generate:
 
-               Abrt_Blk :=
-                 Make_Block_Statement (Loc,
-                   Handled_Statement_Sequence =>
-                     Make_Handled_Sequence_Of_Statements (Loc,
-                       Statements  => New_List (
-                         Build_Runtime_Call (Loc, RE_Abort_Defer),
-                         Fin_Blk),
-                       At_End_Proc => New_Occurrence_Of (AUD, Loc)));
+         --    begin
+         --       Abort_Defer;
+         --       <Fin_Blk>
+         --    at end
+         --       Abort_Undefer_Direct;
+         --    end;
 
-               Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
+         if Abort_Allowed then
+            AUD := RTE (RE_Abort_Undefer_Direct);
 
-               --  Present the Abort_Undefer_Direct function to the backend so
-               --  that it can inline the call to the function.
+            Abrt_HSS :=
+              Make_Handled_Sequence_Of_Statements (Loc,
+                Statements  => New_List (
+                  Build_Runtime_Call (Loc, RE_Abort_Defer),
+                  Fin_Blk),
+                At_End_Proc => New_Occurrence_Of (AUD, Loc));
 
-               Add_Inlined_Body (AUD, N);
-               Append_To (Stmts, Abrt_Blk);
+            Abrt_Blk :=
+              Make_Block_Statement (Loc,
+                Handled_Statement_Sequence => Abrt_HSS);
 
-            --  Otherwise aborts are not allowed. Generate a dummy entity to
-            --  ensure that the internal symbols are in sync when a unit is
-            --  compiled with and without aborts.
+            Add_Block_Identifier  (Abrt_Blk, Abrt_Blk_Id);
+            Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
 
-            else
-               Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
-               Append_To (Stmts, Fin_Blk);
-            end if;
+            --  Present the Abort_Undefer_Direct function to the backend so
+            --  that it can inline the call to the function.
 
-         --  Otherwise exception propagation is not allowed
+            Add_Inlined_Body (AUD, N);
+
+         --  Otherwise aborts are not allowed
 
          else
-            Append_To (Stmts, Fin_Call);
+            Abrt_Blk := Fin_Blk;
          end if;
+
+         Append_To (Stmts, Abrt_Blk);
       end if;
 
       --  For a task type, call Free_Task before freeing the ATCB. We used to
@@ -1174,8 +1172,8 @@ package body Exp_Intr is
       --  (the task will be freed once it terminates).
 
       if Is_Task_Type (Desig_Typ) then
-         Append_To
-           (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
+         Append_To (Stmts,
+           Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
 
       --  For composite types that contain tasks, recurse over the structure
       --  to build the selectors for the task subcomponents.
@@ -1411,15 +1409,6 @@ package body Exp_Intr is
 
       Rewrite (N, Gen_Code);
       Analyze (N);
-
-      --  If we generated a block with an At_End_Proc, expand the exception
-      --  handler. We need to wait until after everything else is analyzed.
-
-      if Present (Abrt_Blk) then
-         Expand_At_End_Handler
-           (HSS    => Handled_Statement_Sequence (Abrt_Blk),
-            Blk_Id => Entity (Identifier (Abrt_Blk)));
-      end if;
    end Expand_Unc_Deallocation;
 
    -----------------------

gcc/ada/exp_util.adb

@@ -9453,19 +9453,4 @@ package body Exp_Util is
         and then not Is_Predicate_Function_M (S);
    end Within_Internal_Subprogram;
 
-   ----------------------------
-   -- Wrap_Cleanup_Procedure --
-   ----------------------------
-
-   procedure Wrap_Cleanup_Procedure (N : Node_Id) is
-      Loc   : constant Source_Ptr := Sloc (N);
-      Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
-      Stmts : constant List_Id    := Statements (Stseq);
-   begin
-      if Abort_Allowed then
-         Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-         Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
-      end if;
-   end Wrap_Cleanup_Procedure;
-
 end Exp_Util;

gcc/ada/exp_util.ads

@@ -1020,15 +1020,6 @@ package Exp_Util is
    --  predefined primitive operation. Some expansion activity (e.g. predicate
    --  checks) is disabled in such.
 
-   procedure Wrap_Cleanup_Procedure (N : Node_Id);
-   --  Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
-   --  at the start of the statement sequence, and an Abort_Undefer call at the
-   --  end of the statement sequence. All cleanup routines (i.e. those that are
-   --  called from "at end" handlers) must defer abort on entry and undefer
-   --  abort on exit. Note that it is assumed that the code for the procedure
-   --  does not contain any return statements which would allow the flow of
-   --  control to escape doing the undefer call.
-
 private
    pragma Inline (Duplicate_Subexpr);
    pragma Inline (Force_Evaluation);