sem_ch11.adb: Fix No_Exception_Restriction violation for SJLJ

2008-03-26  Robert Dewar  <dewar@adacore.com>

	* sem_ch11.adb: Fix No_Exception_Restriction violation for SJLJ
	* sinfo.ads, sinfo.adb (From_At_End): New flag

From-SVN: r133576

diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index 66cfc88a99302f3045b4115ad6fc73d8a4f11c38..2be74709f093ec0ad545d4f72843b0b7d624f473 100644 (file)
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -437,7 +437,6 @@ package body Sem_Ch11 is
       Exception_Id   : constant Node_Id := Name (N);
       Exception_Name : Entity_Id        := Empty;
       P              : Node_Id;
-      Nkind_P        : Node_Kind;
 
    begin
       Check_Unreachable_Code (N);
@@ -484,16 +483,13 @@ package body Sem_Ch11 is
 
       if No (Exception_Id) then
          P := Parent (N);
-         Nkind_P := Nkind (P);
-
-         while Nkind_P /= N_Exception_Handler
-           and then Nkind_P /= N_Subprogram_Body
-           and then Nkind_P /= N_Package_Body
-           and then Nkind_P /= N_Task_Body
-           and then Nkind_P /= N_Entry_Body
+         while not Nkind_In (P, N_Exception_Handler,
+                                N_Subprogram_Body,
+                                N_Package_Body,
+                                N_Task_Body,
+                                N_Entry_Body)
          loop
             P := Parent (P);
-            Nkind_P := Nkind (P);
          end loop;
 
          if Nkind (P) /= N_Exception_Handler then
@@ -506,7 +502,15 @@ package body Sem_Ch11 is
 
          else
             Set_Local_Raise_Not_OK (P);
-            Check_Restriction (No_Exception_Propagation, N);
+
+            --  Do not check the restriction if the reraise statement is part
+            --  of the code generated for an AT-END handler. That's because
+            --  if the restriction is actually active, we never generate this
+            --  raise anyway, so the apparent violation is bogus.
+
+            if not From_At_End (N) then
+               Check_Restriction (No_Exception_Propagation, N);
+            end if;
          end if;
 
       --  Normal case with exception id present

diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 2baa94b7d3a825b2623b0ebb952523439ef39e33..528d7f43a40fa69d00e1360b43f1b922e711b645 100644 (file)
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -1264,6 +1264,14 @@ package body Sinfo is
       return Flag5 (N);
    end Forwards_OK;
 
+   function From_At_End
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Raise_Statement);
+      return Flag4 (N);
+   end From_At_End;
+
    function From_At_Mod
       (N : Node_Id) return Boolean is
    begin
@@ -3995,6 +4003,14 @@ package body Sinfo is
       Set_Flag5 (N, Val);
    end Set_Forwards_OK;
 
+   procedure Set_From_At_End
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Raise_Statement);
+      Set_Flag4 (N, Val);
+   end Set_From_At_End;
+
    procedure Set_From_At_Mod
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -5574,9 +5590,9 @@ package body Sinfo is
         UI_From_Int (Int (S) - Int (Sloc (N))));
    end Set_End_Location;
 
-   --------------------------------
-   -- Node_Kind Membership Tests --
-   --------------------------------
+   --------------
+   -- Nkind_In --
+   --------------
 
    function Nkind_In
      (T  : Node_Kind;
@@ -5690,4 +5706,13 @@ package body Sinfo is
              T = V8;
    end Nkind_In;
 
+   -----------------
+   -- Pragma_Name --
+   -----------------
+
+   function Pragma_Name (N : Node_Id) return Name_Id is
+   begin
+      return Chars (Pragma_Identifier (N));
+   end Pragma_Name;
+
 end Sinfo;

diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index d1f201767688b66e57cb5d35929c12660f608a31..5c131465a92cec5a874c2f51658df388b15a4af5 100644 (file)
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -1032,6 +1032,13 @@ package Sinfo is
    --    could not determine that either direction is definitely safe, and a
    --    runtime check is required.
 
+   --  From_At_End (Flag4-Sem)
+   --    This flag is set on an N_Raise_Statement node if it corresponds to
+   --    the reraise statement generated as the last statement of an AT END
+   --    handler when SJLJ exception handling is active. It is used to stop
+   --    a bogus violation of restriction (No_Exception_Propagation), bogus
+   --    because if the restriction is set, the reraise is not generated.
+
    --  From_At_Mod (Flag4-Sem)
    --    This flag is set on the attribute definition clause node that is
    --    generated by a transformation of an at mod phrase in a record
@@ -1876,7 +1883,6 @@ package Sinfo is
 
       --  N_Pragma
       --  Sloc points to pragma identifier
-      --  Chars (Name1) identifier name from pragma identifier
       --  Pragma_Argument_Associations (List2) (set to No_List if none)
       --  Debug_Statement (Node3) (set to Empty if not Debug, Assert)
       --  Pragma_Identifier (Node4)
@@ -1887,12 +1893,8 @@ package Sinfo is
       --  Psect_Object is always converted to Common_Object, but there are
       --  undoubtedly many other similar notes required ???
 
-      --  Note: we don't really need the Chars field, since it can trivially
-      --  be obtained as Chars (Pragma_Identifier (Node)). However, it is
-      --  convenient to have this directly available, and historically the
-      --  Chars field has been around for ever, whereas the Pragma_Identifier
-      --  field was added much later (when we found the need to be able to get
-      --  the Sloc of the pragma identifier).
+      --  Note: a utility function Pragma_Name may be applied to pragma nodes
+      --  to conveniently obtain the Chars field of the Pragma_Identifier.
 
       --------------------------------------
       -- 2.8  Pragma Argument Association --
@@ -5660,6 +5662,7 @@ package Sinfo is
       --  Sloc points to RAISE
       --  Name (Node2) (set to Empty if no exception name present)
       --  Expression (Node3) (set to Empty if no expression present)
+      --  From_At_End (Flag4-Sem)
 
       -------------------------------
       -- 12.1  Generic Declaration --
@@ -6886,7 +6889,6 @@ package Sinfo is
       --  N_Has_Chars
 
       N_Empty,
-      N_Pragma,
       N_Pragma_Argument_Association,
 
       --  N_Has_Etype
@@ -6983,10 +6985,8 @@ package Sinfo is
       N_Conditional_Expression,
       N_Explicit_Dereference,
       N_Function_Call,
-
       N_Indexed_Component,
       N_Integer_Literal,
-
       N_Null,
       N_Or_Else,
       N_Procedure_Call_Statement,
@@ -7215,6 +7215,7 @@ package Sinfo is
       N_Package_Specification,
       N_Parameter_Association,
       N_Parameter_Specification,
+      N_Pragma,
       N_Protected_Definition,
       N_Range_Constraint,
       N_Real_Range_Specification,
@@ -7796,6 +7797,9 @@ package Sinfo is
    function Forwards_OK
      (N : Node_Id) return Boolean;    -- Flag5
 
+   function From_At_End
+     (N : Node_Id) return Boolean;    -- Flag4
+
    function From_At_Mod
      (N : Node_Id) return Boolean;    -- Flag4
 
@@ -8666,6 +8670,9 @@ package Sinfo is
    procedure Set_From_At_Mod
      (N : Node_Id; Val : Boolean := True);    -- Flag4
 
+   procedure Set_From_At_End
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
    procedure Set_From_Default
      (N : Node_Id; Val : Boolean := True);    -- Flag6
 
@@ -9238,6 +9245,14 @@ package Sinfo is
    pragma Inline (Nkind_In);
    --  Inline all above functions
 
+   -----------------------
+   -- Utility Functions --
+   -----------------------
+
+   function Pragma_Name (N : Node_Id) return Name_Id;
+   pragma Inline (Pragma_Name);
+   --  Convenient function to obtain Chars field of Pragma_Identifier
+
    -----------------------------
    -- Syntactic Parent Tables --
    -----------------------------
@@ -10908,6 +10923,7 @@ package Sinfo is
    pragma Inline (Float_Truncate);
    pragma Inline (Formal_Type_Definition);
    pragma Inline (Forwards_OK);
+   pragma Inline (From_At_End);
    pragma Inline (From_At_Mod);
    pragma Inline (From_Default);
    pragma Inline (Generic_Associations);
@@ -11194,6 +11210,7 @@ package Sinfo is
    pragma Inline (Set_Float_Truncate);
    pragma Inline (Set_Formal_Type_Definition);
    pragma Inline (Set_Forwards_OK);
+   pragma Inline (Set_From_At_End);
    pragma Inline (Set_From_At_Mod);
    pragma Inline (Set_From_Default);
    pragma Inline (Set_Generic_Associations);