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_ch9.adb

@@ -4315,14 +4315,17 @@ package body Exp_Ch9 is
       if Nkind (Op_Spec) = N_Function_Specification then
          if Exc_Safe then
             R := Make_Temporary (Loc, 'R');
+
             Unprot_Call :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier => R,
                 Constant_Present    => True,
-                Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
+                Object_Definition   =>
+                  New_Copy (Result_Definition (N_Op_Spec)),
                 Expression          =>
                   Make_Function_Call (Loc,
-                    Name => Make_Identifier (Loc,
+                    Name                   =>
+                      Make_Identifier (Loc,
                         Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
                     Parameter_Associations => Uactuals));
 
@@ -4331,8 +4334,10 @@ package body Exp_Ch9 is
                 Expression => New_Occurrence_Of (R, Loc));
 
          else
-            Unprot_Call := Make_Simple_Return_Statement (Loc,
-              Expression => Make_Function_Call (Loc,
+            Unprot_Call :=
+              Make_Simple_Return_Statement (Loc,
+                Expression =>
+                  Make_Function_Call (Loc,
                     Name                   =>
                       Make_Identifier (Loc,
                         Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
@@ -4354,7 +4359,8 @@ package body Exp_Ch9 is
       --  Wrap call in block that will be covered by an at_end handler
 
       if not Exc_Safe then
-         Unprot_Call := Make_Block_Statement (Loc,
+         Unprot_Call :=
+           Make_Block_Statement (Loc,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (Unprot_Call)));
@@ -4385,15 +4391,14 @@ package body Exp_Ch9 is
                Selector_Name => Make_Identifier (Loc, Name_uObject)),
            Attribute_Name => Name_Unchecked_Access);
 
-      Lock_Stmt := Make_Procedure_Call_Statement (Loc,
+      Lock_Stmt :=
+        Make_Procedure_Call_Statement (Loc,
           Name                   => Lock_Name,
           Parameter_Associations => New_List (Object_Parm));
 
       if Abort_Allowed then
          Stmts := New_List (
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
-             Parameter_Associations => Empty_List),
+           Build_Runtime_Call (Loc, RE_Abort_Defer),
            Lock_Stmt);
 
       else
@@ -4417,12 +4422,13 @@ package body Exp_Ch9 is
          Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
 
          if Nkind (Op_Spec) = N_Function_Specification then
-            Append (Return_Stmt, Stmts);
-            Append (Make_Block_Statement (Loc,
+            Append_To (Stmts, Return_Stmt);
+            Append_To (Pre_Stmts,
+              Make_Block_Statement (Loc,
                 Declarations               => New_List (Unprot_Call),
                 Handled_Statement_Sequence =>
                   Make_Handled_Sequence_Of_Statements (Loc,
-                  Statements => Stmts)), Pre_Stmts);
+                    Statements => Stmts)));
             Stmts := Pre_Stmts;
          end if;
       end if;
@@ -4594,11 +4600,7 @@ package body Exp_Ch9 is
       --    Abort_Undefer;
 
       if Abort_Allowed then
-         Append_To (Stmts,
-           Make_Procedure_Call_Statement (Loc,
-             Name                   =>
-               New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
-             Parameter_Associations => Empty_List));
+         Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
       end if;
    end Build_Protected_Subprogram_Call_Cleanup;
 
@@ -7169,6 +7171,8 @@ package body Exp_Ch9 is
                Name => New_Occurrence_Of (Proc, Loc)));
       end Rewrite_Abortable_Part;
 
+   --  Start of processing for Expand_N_Asynchronous_Select
+
    begin
       Process_Statements_For_Controlled_Objects (Trig);
       Process_Statements_For_Controlled_Objects (Abrt);
@@ -7426,8 +7430,7 @@ package body Exp_Ch9 is
                       Name_uDisp_Asynchronous_Select),
                     Loc),
 
-                Parameter_Associations =>
-                  New_List (
+                Parameter_Associations => New_List (
                   New_Copy_Tree (Obj),             --  <object>
                   New_Occurrence_Of (S, Loc),      --  S
                   Make_Attribute_Reference (Loc,   --  P'Address
@@ -7439,10 +7442,7 @@ package body Exp_Ch9 is
             --  Generate:
             --    Abort_Defer;
 
-            Prepend_To (TaskE_Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
-                Parameter_Associations => No_List));
+            Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
 
             --  Generate:
             --    Abort_Undefer;
@@ -7450,10 +7450,8 @@ package body Exp_Ch9 is
 
             Cleanup_Stmts := New_Copy_List_Tree (Astats);
 
-            Prepend_To (Cleanup_Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
-                Parameter_Associations => No_List));
+            Prepend_To
+              (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
 
             --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
             --  will generate a _clean for the additional status flag.
@@ -7640,9 +7638,7 @@ package body Exp_Ch9 is
 
             Hdle := New_List (Build_Abort_Block_Handler (Loc));
 
-            Prepend_To (Astats,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
+            Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
 
             Abortable_Block :=
               Make_Block_Statement (Loc,
@@ -7788,17 +7784,14 @@ package body Exp_Ch9 is
              Has_Created_Identifier => True,
              Is_Asynchronous_Call_Block => True);
 
-         if Exception_Mechanism = Back_End_Exceptions then
-
-            --  Aborts are not deferred at beginning of exception handlers
-            --  in ZCX.
+         --  Aborts are not deferred at beginning of exception handlers in
+         --  ZCX.
 
+         if Exception_Mechanism = Back_End_Exceptions then
             Handler_Stmt := Make_Null_Statement (Loc);
 
          else
-            Handler_Stmt := Make_Procedure_Call_Statement (Loc,
-              Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
-              Parameter_Associations => No_List);
+            Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
          end if;
 
          Stmts := New_List (
@@ -7881,9 +7874,7 @@ package body Exp_Ch9 is
 
          Hdle := New_List (Build_Abort_Block_Handler (Loc));
 
-         Prepend_To (Astats,
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
+         Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
 
          Abortable_Block :=
            Make_Block_Statement (Loc,
@@ -7927,10 +7918,7 @@ package body Exp_Ch9 is
 
          --  Protected the call against abort
 
-         Prepend_To (Stmts,
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
-             Parameter_Associations => Empty_List));
+         Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
       end if;
 
       Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
@@ -10762,9 +10750,7 @@ package body Exp_Ch9 is
             --  analysis with unknown calls, so don't do it.
 
             if not CodePeer_Mode then
-               Call :=
-                 Make_Procedure_Call_Statement (Eloc,
-                   Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Eloc));
+               Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
                Insert_Before
                  (First (Statements (Handled_Statement_Sequence
                                        (Accept_Statement (Alt)))),

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,7 +1118,13 @@ package body Exp_Intr is
                     Exception_Handlers => New_List (
                       Build_Exception_Handler (Fin_Data))));
 
-            --  The finalization action must be protected by an abort defer
+         --  Otherwise exception propagation is not allowed
+
+         else
+            Fin_Blk := Fin_Call;
+         end if;
+
+         --  The finalization action must be protected by an abort defer and
          --  undefer pair when aborts are allowed. Generate:
 
          --    begin
@@ -1134,37 +1137,32 @@ package body Exp_Intr is
          if Abort_Allowed then
             AUD := RTE (RE_Abort_Undefer_Direct);
 
-               Abrt_Blk :=
-                 Make_Block_Statement (Loc,
-                   Handled_Statement_Sequence =>
+            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)));
+                At_End_Proc => New_Occurrence_Of (AUD, Loc));
+
+            Abrt_Blk :=
+              Make_Block_Statement (Loc,
+                Handled_Statement_Sequence => Abrt_HSS);
 
             Add_Block_Identifier  (Abrt_Blk, Abrt_Blk_Id);
+            Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
 
             --  Present the Abort_Undefer_Direct function to the backend so
             --  that it can inline the call to the function.
 
             Add_Inlined_Body (AUD, N);
-               Append_To (Stmts, Abrt_Blk);
 
-            --  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.
+         --  Otherwise aborts are not allowed
 
          else
-               Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
-               Append_To (Stmts, Fin_Blk);
+            Abrt_Blk := Fin_Blk;
          end if;
 
-         --  Otherwise exception propagation is not allowed
-
-         else
-            Append_To (Stmts, Fin_Call);
-         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);