2007-04-06 Robert Dewar <dewar@adacore.com>

	* a-except.adb, a-except.ads, a-except-2005.ads, a-except-2005.adb
	(Local_Raise): New dummy procedure called when a raise is converted
	to a local goto. Used for debugger to detect that the exception
	is raised.

	* debug.adb: Document new d.g flag (expand local raise statements to
	gotos even if pragma Restriction (No_Exception_Propagation) is not set)

	* exp_sel.adb: Use Make_Implicit_Exception_Handler

	* exp_ch11.adb (Expand_Exception_Handlers): Use new flag -gnatw.x to
	suppress warnings for unused handlers.
	(Warn_If_No_Propagation):  Use new flag -gnatw.x to suppress
	warnings for raise statements not handled locally.
	(Get_RT_Exception_Entity): New function
	(Get_Local_Call_Entity): New function
	(Find_Local_Handler): New function
	(Warn_If_No_Propagation): New procedure
	(Expand_At_End_Handler): Call Make_Implicit_Handler
	(Expand_Exception_Handlers): Major additions to deal with local handlers
	(Expand_N_Raise_Constraint_Error, Expand_N_Raise_Program_Error,
	Expand_N_Raise_Storage_Error, (Expand_N_Raise_Statement): Add handling
	for local raise

	* exp_ch11.ads (Get_RT_Exception_Entity): New function
	(Get_Local_Call_Entity): New function

	* gnatbind.adb (Restriction_List): Add No_Exception_Propagation to list
	of restrictions that the binder will never suggest adding.

	* par-ch11.adb (P_Exception_Handler): Set Local_Raise_Statements field
	to No_Elist.

	* restrict.adb (Check_Restricted_Unit): GNAT.Current_Exception may not
	be with'ed in the presence of pragma Restriction
	(No_Exception_Propagation).

	* sem.adb (Analyze): Add entries for N_Push and N_Pop nodes

	* sem_ch11.adb (Analyze_Exception_Handler): If there is a choice
	parameter, then the handler is not a suitable target for a local raise,
	and this is a violation of restriction No_Exception_Propagation.
	(Analyze_Handled_Statements): Analyze choice parameters in exception
	handlers before analyzing statement sequence (needed for proper
	detection of local raise statements).
	(Analyze_Raise_Statement): Reraise statement is a violation of the
	No_Exception_Propagation restriction.

	* s-rident.ads: Add new restriction No_Exception_Propagation

	* tbuild.ads, tbuild.adb (Make_Implicit_Exception_Handler): New
	function, like Make_Exception_Handler but sets Local_Raise_Statements
	to No_List.
	(Add_Unique_Serial_Number): Deal with case where this is called during
	processing of configuration pragmas.



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

1 files changed, 53 insertions, 14 deletions

diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index f7966b156a4..543379079d1 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.        --
+--          Copyright (C) 1992-2006, 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- --
@@ -53,25 +53,46 @@ package body Tbuild is
    -- Add_Unique_Serial_Number --
    ------------------------------
 
-   procedure Add_Unique_Serial_Number is
-      Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+   Config_Serial_Number : Nat := 0;
+   --  Counter for use in config pragmas, see comment below
 
+   procedure Add_Unique_Serial_Number is
    begin
-      Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+      --  If we are analyzing configuration pragmas, Cunit (Main_Unit) will
+      --  not be set yet. This happens for example when analyzing static
+      --  string expressions in configuration pragmas. For this case, we
+      --  just maintain a local counter, defined above and we do not need
+      --  to add a b or s indication in this case.
 
-      --  Add either b or s, depending on whether current unit is a spec
-      --  or a body. This is needed because we may generate the same name
-      --  in a spec and a body otherwise.
+      if No (Cunit (Current_Sem_Unit)) then
+         Config_Serial_Number := Config_Serial_Number + 1;
+         Add_Nat_To_Name_Buffer (Config_Serial_Number);
+         return;
 
-      Name_Len := Name_Len + 1;
+      --  Normal case, within a unit
 
-      if Nkind (Unit_Node) = N_Package_Declaration
-        or else Nkind (Unit_Node) = N_Subprogram_Declaration
-        or else Nkind (Unit_Node) in N_Generic_Declaration
-      then
-         Name_Buffer (Name_Len) := 's';
       else
-         Name_Buffer (Name_Len) := 'b';
+         declare
+            Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+
+         begin
+            Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+
+            --  Add either b or s, depending on whether current unit is a spec
+            --  or a body. This is needed because we may generate the same name
+            --  in a spec and a body otherwise.
+
+            Name_Len := Name_Len + 1;
+
+            if Nkind (Unit_Node) = N_Package_Declaration
+              or else Nkind (Unit_Node) = N_Subprogram_Declaration
+              or else Nkind (Unit_Node) in N_Generic_Declaration
+            then
+               Name_Buffer (Name_Len) := 's';
+            else
+               Name_Buffer (Name_Len) := 'b';
+            end if;
+         end;
       end if;
    end Add_Unique_Serial_Number;
 
@@ -178,6 +199,24 @@ package body Tbuild is
               New_Reference_To (First_Tag_Component (Full_Type), Loc)));
    end Make_DT_Access;
 
+   -------------------------------------
+   -- Make_Implicit_Exception_Handler --
+   -------------------------------------
+
+   function Make_Implicit_Exception_Handler
+     (Sloc              : Source_Ptr;
+      Choice_Parameter  : Node_Id := Empty;
+      Exception_Choices : List_Id;
+      Statements        : List_Id) return Node_Id
+   is
+      Handler : constant Node_Id :=
+                  Make_Exception_Handler
+                    (Sloc, Choice_Parameter, Exception_Choices, Statements);
+   begin
+      Set_Local_Raise_Statements (Handler, No_Elist);
+      return Handler;
+   end Make_Implicit_Exception_Handler;
+
    --------------------------------
    -- Make_Implicit_If_Statement --
    --------------------------------