2011-08-29 Tristan Gingold <gingold@adacore.com>

	* exp_sel.ads (Build_Abort_BLock_Handler): New function spec.
	Adjust comment.
	* exp_sel.adb (Build_Abort_Block): Use Build_Abort_Block_Handler.
	(Build_Abort_Block_Handler): New function to build an Abort_Signal
	exception handler.
	* exp_ch9.adb (Expand_N_Asynchronous_Select): Call
	Build_Abort_Block_Handler to build the exception handler. Do not
	undefer aborts for the Abort_Signal exception handler if back-end
	exception mechanism.
	* exp_ch11.adb (Expand_Exception_Handlers): Do not undefer aborts if
	back_end exceptions for all others and abort_signal.
	* s-except.ads (ZCX_By_Default): New constant.
	* a-except-2005.adb (Raise_Exception): Do not defer abort if ZCX.
	(Raise_Exception_Always): Ditto.
	(Raise_From_Signal_Handler): Ditto.
	(Raise_With_Location_And_Msg): Ditto.
	(Raise_With_Msg): Ditto.
	(Reraise): Ditto.
	(Reraise_Occurence): Ditto.
	(Reraise_Occurrence_Always): Ditto.
	* s-tasren.adb (Exceptional_Complete_Rendezvous): Defer aborts if ZCX.
	* s-tpobop.adb: (Exceptional_Complete_Body): Undefer abort if ZCX.
	* s-interr-hwint.adb (Interrupt_Manager): Defer abort if ZCX.

2011-08-29  Thomas Quinot  <quinot@adacore.com>

	* sem_util.ads (Get_Enum_Lit_From_Pos): Clarify documentation.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178194 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 147 insertions, 62 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d6e5955949a..4905b45a65e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,33 @@
+2011-08-29  Tristan Gingold  <gingold@adacore.com>
+
+	* exp_sel.ads (Build_Abort_BLock_Handler): New function spec.
+	Adjust comment.
+	* exp_sel.adb (Build_Abort_Block): Use Build_Abort_Block_Handler.
+	(Build_Abort_Block_Handler): New function to build an Abort_Signal
+	exception handler.
+	* exp_ch9.adb (Expand_N_Asynchronous_Select): Call
+	Build_Abort_Block_Handler to build the exception handler. Do not
+	undefer aborts for the Abort_Signal exception handler if back-end
+	exception mechanism.
+	* exp_ch11.adb (Expand_Exception_Handlers): Do not undefer aborts if
+	back_end exceptions for all others and abort_signal.
+	* s-except.ads (ZCX_By_Default): New constant.
+	* a-except-2005.adb (Raise_Exception): Do not defer abort if ZCX.
+	(Raise_Exception_Always): Ditto.
+	(Raise_From_Signal_Handler): Ditto.
+	(Raise_With_Location_And_Msg): Ditto.
+	(Raise_With_Msg): Ditto.
+	(Reraise): Ditto.
+	(Reraise_Occurence): Ditto.
+	(Reraise_Occurrence_Always): Ditto.
+	* s-tasren.adb (Exceptional_Complete_Rendezvous): Defer aborts if ZCX.
+	* s-tpobop.adb: (Exceptional_Complete_Body): Undefer abort if ZCX.
+	* s-interr-hwint.adb (Interrupt_Manager): Defer abort if ZCX.
+
+2011-08-29  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_util.ads (Get_Enum_Lit_From_Pos): Clarify documentation.
+
 2011-08-29  Robert Dewar  <dewar@adacore.com>
 
 	* snames.adb-tmpl, sem_ch13.adb: Minor reformatting
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 3b72130cbe8..0ff0b5bb8fb 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -855,7 +855,9 @@ package body Ada.Exceptions is
       --  Go ahead and raise appropriate exception
 
       Exception_Data.Set_Exception_Msg (EF, Message);
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Raise_Current_Excep (EF);
    end Raise_Exception;
 
@@ -869,7 +871,9 @@ package body Ada.Exceptions is
    is
    begin
       Exception_Data.Set_Exception_Msg (E, Message);
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Raise_Current_Excep (E);
    end Raise_Exception_Always;
 
@@ -944,7 +948,9 @@ package body Ada.Exceptions is
    is
    begin
       Exception_Data.Set_Exception_C_Msg (E, M);
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
       Exception_Propagation.Propagate_Exception
         (E => E, From_Signal_Handler => True);
@@ -1015,7 +1021,9 @@ package body Ada.Exceptions is
    is
    begin
       Exception_Data.Set_Exception_C_Msg (E, F, L, C, M);
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Raise_Current_Excep (E);
    end Raise_With_Location_And_Msg;
 
@@ -1034,7 +1042,9 @@ package body Ada.Exceptions is
       Excep.Num_Tracebacks   := 0;
       Excep.Cleanup_Flag     := False;
       Excep.Pid              := Local_Partition_ID;
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Raise_Current_Excep (E);
    end Raise_With_Msg;
 
@@ -1276,7 +1286,9 @@ package body Ada.Exceptions is
    procedure Reraise is
       Excep : constant EOA := Get_Current_Excep.all;
    begin
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True);
       Raise_Current_Excep (Excep.Id);
    end Reraise;
@@ -1288,7 +1300,9 @@ package body Ada.Exceptions is
    procedure Reraise_Occurrence (X : Exception_Occurrence) is
    begin
       if X.Id /= null then
-         Abort_Defer.all;
+         if not ZCX_By_Default then
+            Abort_Defer.all;
+         end if;
          Exception_Propagation.Setup_Exception
            (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
          Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
@@ -1302,7 +1316,9 @@ package body Ada.Exceptions is
 
    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
    begin
-      Abort_Defer.all;
+      if not ZCX_By_Default then
+         Abort_Defer.all;
+      end if;
       Exception_Propagation.Setup_Exception
         (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
       Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index fc55d1567cb..65ab2bd32bc 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -1097,7 +1097,9 @@ package body Exp_Ch11 is
                   --  any case this entire handling is relevant only if aborts
                   --  are allowed!
 
-               elsif Abort_Allowed then
+               elsif Abort_Allowed
+                 and then Exception_Mechanism /= Back_End_Exceptions
+               then
 
                   --  There are some special cases in which we do not do the
                   --  undefer. In particular a finalization (AT END) handler
@@ -1122,7 +1124,6 @@ package body Exp_Ch11 is
                       (Others_Choice
                         and then
                           All_Others (First (Exception_Choices (Handler))))
-                    and then Abort_Allowed
                   then
                      Prepend_Call_To_Handler (RE_Abort_Undefer);
                   end if;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index fc6751a92e0..e5d6ac58fd9 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -5848,6 +5848,7 @@ package body Exp_Ch9 is
       Enqueue_Call      : Node_Id;
       Formals           : List_Id;
       Hdle              : List_Id;
+      Handler_Stmt      : Node_Id;
       Index             : Node_Id;
       Lim_Typ_Stmts     : List_Id;
       N_Orig            : Node_Id;
@@ -5859,9 +5860,7 @@ package body Exp_Ch9 is
       ProtP_Stmts       : List_Id;
       Stmt              : Node_Id;
       Stmts             : List_Id;
-      Target_Undefer    : RE_Id;
       TaskE_Stmts       : List_Id;
-      Undefer_Args      : List_Id := No_List;
 
       B   : Entity_Id;  --  Call status flag
       Bnn : Entity_Id;  --  Communication block
@@ -6352,13 +6351,7 @@ package body Exp_Ch9 is
 
             --  Create the inner block to protect the abortable part
 
-            Hdle := New_List (
-              Make_Implicit_Exception_Handler (Loc,
-                Exception_Choices =>
-                  New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
-                Statements => New_List (
-                  Make_Procedure_Call_Statement (Loc,
-                    Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+            Hdle := New_List (Build_Abort_Block_Handler (Loc));
 
             Prepend_To (Astats,
               Make_Procedure_Call_Statement (Loc,
@@ -6513,13 +6506,21 @@ package body Exp_Ch9 is
          --  See 4jexcept.ads for an explanation.
 
          if VM_Target = No_VM then
-            Target_Undefer := RE_Abort_Undefer;
+            if Exception_Mechanism = Back_End_Exceptions then
+               --  Aborts are not deferred at beginning of exception handlers
+               --  in ZCX.
+               Handler_Stmt := Make_Null_Statement (Loc);
+            else
+               Handler_Stmt := Make_Procedure_Call_Statement (Loc,
+                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+                 Parameter_Associations => No_List);
+            end if;
          else
-            Target_Undefer := RE_Update_Exception;
-            Undefer_Args :=
-              New_List (Make_Function_Call (Loc,
-                          Name => New_Occurrence_Of
-                                    (RTE (RE_Current_Target_Exception), Loc)));
+            Handler_Stmt := Make_Procedure_Call_Statement (Loc,
+              Name => New_Reference_To (RTE (RE_Update_Exception), Loc),
+              Parameter_Associations => New_List (Make_Function_Call (Loc,
+                Name => New_Occurrence_Of (RTE (RE_Current_Target_Exception),
+                                           Loc))));
          end if;
 
          Stmts := New_List (
@@ -6542,11 +6543,7 @@ package body Exp_Ch9 is
 
                      Exception_Choices =>
                        New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
-                     Statements => New_List (
-                       Make_Procedure_Call_Statement (Loc,
-                         Name => New_Reference_To (
-                           RTE (Target_Undefer), Loc),
-                         Parameter_Associations => Undefer_Args)))))),
+                     Statements => New_List (Handler_Stmt))))),
 
          --  if not Cancelled (Bnn) then
          --     triggered statements
@@ -6602,14 +6599,7 @@ package body Exp_Ch9 is
 
          --  Create the inner block to protect the abortable part
 
-         Hdle :=  New_List (
-           Make_Implicit_Exception_Handler (Loc,
-             Exception_Choices =>
-               New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
-             Statements =>
-               New_List (
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+         Hdle :=  New_List (Build_Abort_Block_Handler (Loc));
 
          Prepend_To (Astats,
            Make_Procedure_Call_Statement (Loc,
diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb
index 5596f8a10f9..6751cbf0ee0 100644
--- a/gcc/ada/exp_sel.adb
+++ b/gcc/ada/exp_sel.adb
@@ -64,20 +64,38 @@ package body Exp_Sel is
                   Blk),
 
               Exception_Handlers =>
-                New_List (
-                  Make_Implicit_Exception_Handler (Loc,
-                    Exception_Choices =>
-                      New_List (
-                        New_Reference_To (Stand.Abort_Signal, Loc)),
-                    Statements =>
-                      New_List (
-                        Make_Procedure_Call_Statement (Loc,
-                          Name =>
-                            New_Reference_To (RTE (
-                              RE_Abort_Undefer), Loc),
-                          Parameter_Associations => No_List))))));
+                New_List (Build_Abort_Block_Handler (Loc))));
    end Build_Abort_Block;
 
+   -------------------------------
+   -- Build_Abort_Block_Handler --
+   -------------------------------
+
+   function Build_Abort_Block_Handler
+     (Loc : Source_Ptr) return Node_Id
+   is
+      Stmt : Node_Id;
+   begin
+      if Exception_Mechanism = Back_End_Exceptions then
+         --  With ZCX, aborts are not defered in handlers.
+
+         Stmt := Make_Null_Statement (Loc);
+      else
+         --  With FE SJLJ, aborts are defered at the beginning of Abort_Signal
+         --  handlers.
+
+         Stmt := Make_Procedure_Call_Statement (Loc,
+           Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+           Parameter_Associations => No_List);
+      end if;
+
+      return Make_Implicit_Exception_Handler (Loc,
+        Exception_Choices =>
+          New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
+        Statements =>
+          New_List (Stmt));
+   end Build_Abort_Block_Handler;
+
    -------------
    -- Build_B --
    -------------
diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads
index a68459de9d2..426e6829520 100644
--- a/gcc/ada/exp_sel.ads
+++ b/gcc/ada/exp_sel.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -39,10 +39,22 @@ package Exp_Sel is
    --    begin
    --       Blk
    --    exception
-   --       when Abort_Signal => Abort_Undefer;
+   --       when Abort_Signal => Abort_Undefer / null;
    --    end;
    --  Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name
    --  of the encapsulated cleanup block, Blk is the actual block name.
+   --  The exception handler code is built by Build_Abort_Block_Handler.
+
+   function Build_Abort_Block_Handler
+     (Loc : Source_Ptr) return Node_Id;
+   --  Generate if front-end exception:
+   --    when others =>
+   --      Abort_Under;
+   --  or if back-end exception:
+   --    when others =>
+   --      null;
+   --  This is an exception handler to stop propagation of aborts, without
+   --  modifying the deferal level.
 
    function Build_B
      (Loc   : Source_Ptr;
diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads
index 10232978260..30bc23aa59b 100644
--- a/gcc/ada/s-except.ads
+++ b/gcc/ada/s-except.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -42,6 +42,9 @@ package System.Exceptions is
    pragma Preelaborate_05;
    --  To let Ada.Exceptions "with" us and let us "with" Standard_Library
 
+   ZCX_By_Default : constant Boolean;
+   --  Visible copy to allow Ada.Exceptions to know the exception model.
+
    package SSL renames System.Standard_Library;
    --  To let some of the hooks below have formal parameters typed in
    --  accordance with what GDB expects.
@@ -75,4 +78,7 @@ package System.Exceptions is
    --
    --  The argument is the address of the exception data
 
+private
+   ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
+
 end System.Exceptions;
diff --git a/gcc/ada/s-interr-hwint.adb b/gcc/ada/s-interr-hwint.adb
index 038db362f23..3cd50020ff8 100644
--- a/gcc/ada/s-interr-hwint.adb
+++ b/gcc/ada/s-interr-hwint.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1992-2009, Free Software Foundation, Inc.          --
+--         Copyright (C) 1992-2011, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL is free software; you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1025,6 +1025,10 @@ package body System.Interrupts is
 
    exception
       when Standard'Abort_Signal =>
+         if ZCX_By_Default then
+            Initialization.Defer_Abort_Nestable (STPO.Self);
+         end if;
+
          --  Flush interrupt server semaphores, so they can terminate
          Finalize_Interrupt_Servers;
          raise;
diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb
index 8c604c90a79..4846ef0731c 100644
--- a/gcc/ada/s-tasren.adb
+++ b/gcc/ada/s-tasren.adb
@@ -553,6 +553,11 @@ package body System.Tasking.Rendezvous is
          end if;
 
          Initialization.Defer_Abort_Nestable (Self_Id);
+
+      elsif ZCX_By_Default then
+         --  With ZCX, aborts are not automatically deferred in handlers
+
+         Initialization.Defer_Abort_Nestable (Self_Id);
       end if;
 
       --  We need to clean up any accepts which Self may have
diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index 0890181544d..9e227ed3e26 100644
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1998-2010, Free Software Foundation, Inc.          --
+--         Copyright (C) 1998-2011, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL is free software; you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -258,7 +258,9 @@ package body System.Tasking.Protected_Objects.Operations is
             --  enabled for its remaining life.
 
             Self_Id := STPO.Self;
-            Initialization.Undefer_Abort_Nestable (Self_Id);
+            if not ZCX_By_Default then
+               Initialization.Undefer_Abort_Nestable (Self_Id);
+            end if;
             Transfer_Occurrence
               (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
                Self_Id.Common.Compiler_Data.Current_Excep);
@@ -270,6 +272,7 @@ package body System.Tasking.Protected_Objects.Operations is
       end if;
 
       if Runtime_Traces then
+         --  ??? Entry_Call can be null
          Send_Trace_Info (PO_Done, Entry_Call.Self);
       end if;
    end Exceptional_Complete_Entry_Body;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index ef2d3554671..1d0d23eb647 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -507,11 +507,11 @@ package Sem_Util is
      (T   : Entity_Id;
       Pos : Uint;
       Loc : Source_Ptr) return Node_Id;
-   --  This function obtains the E_Enumeration_Literal entity for the specified
-   --  value from the enumeration type or subtype T and returns an identifier
-   --  node referencing this value. The second argument is the Pos value, which
-   --  is assumed to be in range. The third argument supplies a source location
-   --  for constructed nodes returned by this function.
+   --  This function returns an identifier denoting the E_Enumeration_Literal
+   --  entity for the specified value from the enumeration type or subtype T.
+   --  The second argument is the Pos value, which is assumed to be in range.
+   --  The third argument supplies a source location for constructed nodes
+   --  returned by this function.
 
    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id);
    --  Retrieve the fully expanded name of the library unit declared by
@@ -1297,7 +1297,7 @@ package Sem_Util is
    procedure Set_Current_Entity (E : Entity_Id);
    pragma Inline (Set_Current_Entity);
    --  Establish the entity E as the currently visible definition of its
-   --  associated name (i.e. the Node_Id associated with its name)
+   --  associated name (i.e. the Node_Id associated with its name).
 
    procedure Set_Debug_Info_Needed (T : Entity_Id);
    --  Sets the Debug_Info_Needed flag on entity T , and also on any entities