2009-04-15 Robert Dewar <dewar@adacore.com>

	* frontend.adb (Frontend): Set proper default for
	Warn_On_Non_Local_Exception.

	* opt.ads (Exception_Handler_Encountered): New flag
	(No_Warn_On_Non_Local_Exception): New flag

	* par-ch11.adb (P_Exception_Handler): Set Exception_Handler_Encountered

	* sem_warn.adb (Set_Warning_Switch): Set No_Warn_On_Non_Local_Exception
	(Set_Dot_Warning_Switch): Set No_Warn_On_Non_Local_Exception

2009-04-15  Cyrille Comar  <comar@adacore.com>

	* s-tassta.adb, a-exextr.adb, a-elchha.adb
	(Ada.Exception.Last_Chance_Handler): Do not print unhandled exception
	message when exception traces are active since it would generate
	redundant information.
	(Exception_Traces.Notify_Exception): put message output by a critical
	section to avoid unsynchronized output.
	(Trace_Unhandled_Exception_In_Task): put message output by a critical
	section to avoid unsynchronized output.

2009-04-15  Emmanuel Briot  <briot@adacore.com>

	* g-comlin.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads
	(Free): New subprogram.



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

13 files changed, 148 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cb212e69e05..99395eb4191 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,32 @@
+2009-04-15  Robert Dewar  <dewar@adacore.com>
+
+	* frontend.adb (Frontend): Set proper default for
+	Warn_On_Non_Local_Exception.
+
+	* opt.ads (Exception_Handler_Encountered): New flag
+	(No_Warn_On_Non_Local_Exception): New flag
+
+	* par-ch11.adb (P_Exception_Handler): Set Exception_Handler_Encountered
+
+	* sem_warn.adb (Set_Warning_Switch): Set No_Warn_On_Non_Local_Exception
+	(Set_Dot_Warning_Switch): Set No_Warn_On_Non_Local_Exception
+
+2009-04-15  Cyrille Comar  <comar@adacore.com>
+
+	* s-tassta.adb, a-exextr.adb, a-elchha.adb
+	(Ada.Exception.Last_Chance_Handler): Do not print unhandled exception
+	message when exception traces are active since it would generate
+	redundant information.
+	(Exception_Traces.Notify_Exception): put message output by a critical
+	section to avoid unsynchronized output.
+	(Trace_Unhandled_Exception_In_Task): put message output by a critical
+	section to avoid unsynchronized output.
+
+2009-04-15  Emmanuel Briot  <briot@adacore.com>
+
+	* g-comlin.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads
+	(Free): New subprogram.
+
 2009-04-15  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* a-calend.adb: Add new constant Nanos_In_Four_Years.
diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb
index caa89ffb7b5..087e22f4ffb 100644
--- a/gcc/ada/a-elchha.adb
+++ b/gcc/ada/a-elchha.adb
@@ -79,7 +79,7 @@ begin
    System.Soft_Links.Task_Termination_Handler :=
      System.Soft_Links.Task_Termination_NT'Access;
 
-   --  Let's shutdown the runtime now. The rest of the procedure needs to be
+   --  We shutdown the runtime now. The rest of the procedure needs to be
    --  careful not to use anything that would require runtime support. In
    --  particular, functions returning strings are banned since the sec stack
    --  is no longer functional. This is particularly important to note for the
@@ -93,11 +93,16 @@ begin
 
    System.Standard_Library.Adafinal;
 
+   --  Print a message only when exception traces are not active
+
+   if Exception_Trace /= RM_Convention then
+      null;
+
    --  Check for special case of raising _ABORT_SIGNAL, which is not
    --  really an exception at all. We recognize this by the fact that
    --  it is the only exception whose name starts with underscore.
 
-   if To_Ptr (Except.Id.Full_Name) (1) = '_' then
+   elsif To_Ptr (Except.Id.Full_Name) (1) = '_' then
       To_Stderr (Nline);
       To_Stderr ("Execution terminated by abort of environment task");
       To_Stderr (Nline);
diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb
index 967a54b1099..2ea9a3ad1e5 100644
--- a/gcc/ada/a-exextr.adb
+++ b/gcc/ada/a-exextr.adb
@@ -101,9 +101,13 @@ package body Exception_Traces is
 
       if not Excep.Id.Not_Handled_By_Others
         and then
-        (Exception_Trace = Every_Raise
-          or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled))
+          (Exception_Trace = Every_Raise
+            or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled))
       then
+         --  Exception trace messages need to be protected when several tasks
+         --  can issue them at the same time.
+
+         Lock_Task.all;
          To_Stderr (Nline);
 
          if Is_Unhandled then
@@ -113,6 +117,7 @@ package body Exception_Traces is
          To_Stderr ("Exception raised");
          To_Stderr (Nline);
          To_Stderr (Tailored_Exception_Information (Excep.all));
+         Unlock_Task.all;
       end if;
 
       --  Call the user-specific actions
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 8f16a117866..5fd28221533 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -43,6 +43,8 @@ with Opt;      use Opt;
 with Osint;
 with Par;
 with Prepcomp;
+with Restrict; use Restrict;
+with Rident;   use Rident;
 with Rtsfind;
 with Sprint;
 with Scn;      use Scn;
@@ -64,12 +66,12 @@ procedure Frontend is
    --  Gather configuration pragmas
 
 begin
-   --  Carry out package initializations. These are initializations which
-   --  might logically be performed at elaboration time, were it not for
-   --  the fact that we may be doing things more than once in the big loop
-   --  over files. Like elaboration, the order in which these calls are
-   --  made is in some cases important. For example, Lib cannot be
-   --  initialized until Namet, since it uses names table entries.
+   --  Carry out package initializations. These are initializations which might
+   --  logically be performed at elaboration time, were it not for the fact
+   --  that we may be doing things more than once in the big loop over files.
+   --  Like elaboration, the order in which these calls are made is in some
+   --  cases important. For example, Lib cannot be initialized until Namet,
+   --  since it uses names table entries.
 
    Rtsfind.Initialize;
    Atree.Initialize;
@@ -275,6 +277,17 @@ begin
       end;
    end if;
 
+   --  If we have restriction No_Exception_Propagation, and we did not have
+   --  an explicit switch turning off Warn_On_Local_Exception, then turn on
+   --  this warning by default if we have encountered an exception handler.
+
+   if Restriction_Active (No_Exception_Propagation)
+     and then not No_Warn_On_Non_Local_Exception
+     and then Exception_Handler_Encountered
+   then
+      Warn_On_Non_Local_Exception := True;
+   end if;
+
    --  Now on to the semantics. Skip if in syntax only mode
 
    if Operating_Mode /= Check_Syntax then
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 307f890750e..9564ff2d754 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -2449,6 +2449,8 @@ package body GNAT.Command_Line is
          Free (Config.Aliases);
          Free (Config.Expansions);
          Free (Config.Prefixes);
+         Free (Config.Sections);
+         Free (Config.Switches);
          Unchecked_Free (Config);
       end if;
    end Free;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 71bcb19871b..547afefb5f5 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -415,6 +415,12 @@ package Opt is
    --  to make a single long message, and then this message is split up into
    --  multiple lines not exceeding the specified length. Set by -gnatj=nn.
 
+   Exception_Handler_Encountered : Boolean := False;
+   --  GNAT
+   --  This flag is set true if the parser encounters an exception handler.
+   --  It is used to set Warn_On_Exception_Propagation True if the restriction
+   --  No_Exception_Propagation is set.
+
    Exception_Locations_Suppressed : Boolean := False;
    --  GNAT
    --  This flag is set True if a Suppress_Exception_Locations configuration
@@ -1309,7 +1315,15 @@ package Opt is
    --  Set to True to generate warnings for non-local exception raises and also
    --  handlers that can never handle a local raise. This warning is only ever
    --  generated if pragma Restrictions (No_Exception_Propagation) is set. The
-   --  default is not to generate the warnings even if the restriction is set.
+   --  default is not to generate the warnings except that if the source has
+   --  at least one exception, and this restriction is set, and the warning
+   --  was not explicitly turned off, then it is turned on by default.
+
+   No_Warn_On_Non_Local_Exception : Boolean := False;
+   --  GNAT
+   --  This is set to True if the above warning is explicitly suppressed. We
+   --  use this to avoid turning it on by default when No_Exception_Propagation
+   --  restriction is set.
 
    Warn_On_Obsolescent_Feature : Boolean := False;
    --  GNAT
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index 412456e1a7e..14129bc6230 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -92,6 +92,7 @@ package body Ch11 is
       Choice_Param_Node : Node_Id;
 
    begin
+      Exception_Handler_Encountered := True;
       Handler_Node := New_Node (N_Exception_Handler, Token_Ptr);
       Set_Local_Raise_Statements (Handler_Node, No_Elist);
 
diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb
index 0f9f5de986f..61a329fcb02 100644
--- a/gcc/ada/prj-tree.adb
+++ b/gcc/ada/prj-tree.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Ada.Unchecked_Deallocation;
 with Prj.Err;
 
 package body Prj.Tree is
@@ -984,6 +985,21 @@ package body Prj.Tree is
       Projects_Htable.Reset (Tree.Projects_HT);
    end Initialize;
 
+   ----------
+   -- Free --
+   ----------
+
+   procedure Free (Prj : in out Project_Node_Tree_Ref) is
+      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+        (Project_Node_Tree_Data, Project_Node_Tree_Ref);
+   begin
+      if Prj /= null then
+         Project_Node_Table.Free (Prj.Project_Nodes);
+         Projects_Htable.Reset (Prj.Projects_HT);
+         Unchecked_Free (Prj);
+      end if;
+   end Free;
+
    -------------------------------
    -- Is_Followed_By_Empty_Line --
    -------------------------------
diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads
index 94526660e20..75961ff08e1 100644
--- a/gcc/ada/prj-tree.ads
+++ b/gcc/ada/prj-tree.ads
@@ -1300,6 +1300,9 @@ package Prj.Tree is
    end record;
    --  The data for a project node tree
 
+   procedure Free (Prj : in out Project_Node_Tree_Ref);
+   --  Free memory used by Prj
+
 private
    type Comment_Array is array (Positive range <>) of Comment_Data;
    type Comments_Ptr is access Comment_Array;
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index ca804d9b0a8..6c26bc182a3 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -24,6 +24,7 @@
 ------------------------------------------------------------------------------
 
 with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Unchecked_Deallocation;
 
 with Debug;
 with Output;   use Output;
@@ -826,17 +827,51 @@ package body Prj is
       end if;
    end Register_Default_Naming_Scheme;
 
+   ----------
+   -- Free --
+   ----------
+
+   procedure Free (Tree : in out Project_Tree_Ref) is
+      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+        (Project_Tree_Data, Project_Tree_Ref);
+   begin
+      if Tree /= null then
+         Language_Data_Table.Free (Tree.Languages_Data);
+         Name_List_Table.Free (Tree.Name_Lists);
+         String_Element_Table.Free (Tree.String_Elements);
+         Variable_Element_Table.Free (Tree.Variable_Elements);
+         Array_Element_Table.Free (Tree.Array_Elements);
+         Array_Table.Free (Tree.Arrays);
+         Package_Table.Free (Tree.Packages);
+         Project_List_Table.Free (Tree.Project_Lists);
+         Project_Table.Free (Tree.Projects);
+         Source_Data_Table.Free (Tree.Sources);
+         Alternate_Language_Table.Free (Tree.Alt_Langs);
+         Unit_Table.Free (Tree.Units);
+         Units_Htable.Reset (Tree.Units_HT);
+         Files_Htable.Reset (Tree.Files_HT);
+         Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
+         Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
+
+         --  Private part
+
+         Naming_Table.Free (Tree.Private_Part.Namings);
+         Path_File_Table.Free (Tree.Private_Part.Path_Files);
+         Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
+         Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
+
+         --  Naming data (nothing to free ?)
+         null;
+
+         Unchecked_Free (Tree);
+      end if;
+   end Free;
+
    -----------
    -- Reset --
    -----------
 
    procedure Reset (Tree : Project_Tree_Ref) is
-
-      --  Def_Lang : constant Name_Node :=
-      --             (Name => Name_Ada,
-      --              Next => No_Name_List);
-      --  Why is the above commented out ???
-
    begin
       Prj.Env.Initialize;
 
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index adc57472329..0d506338055 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -116,6 +116,9 @@ package Prj is
 
    No_Project_Tree : constant Project_Tree_Ref;
 
+   procedure Free (Tree : in out Project_Tree_Ref);
+   --  Free memory associated with the tree
+
    function Default_Ada_Spec_Suffix return File_Name_Type;
    pragma Inline (Default_Ada_Spec_Suffix);
    --  The name for the standard GNAT suffix for Ada spec source file name
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index eaa6ff0b430..836f332334c 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -1388,6 +1388,7 @@ package body System.Tasking.Stages is
       --  unwound. The common notification routine has been called at the
       --  raise point already.
 
+      Initialization.Task_Lock (Self_Id);
       To_Stderr ("task ");
 
       if Self_Id.Common.Task_Image_Len /= 0 then
@@ -1400,6 +1401,7 @@ package body System.Tasking.Stages is
       To_Stderr (" terminated by unhandled exception");
       To_Stderr ((1 => ASCII.LF));
       To_Stderr (Tailored_Exception_Information (Excep.all));
+      Initialization.Task_Unlock (Self_Id);
    end Trace_Unhandled_Exception_In_Task;
 
    ------------------------------------
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 3550392f872..29a850a6e0a 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -3006,6 +3006,7 @@ package body Sem_Warn is
 
          when 'X' =>
             Warn_On_Non_Local_Exception         := False;
+            No_Warn_On_Non_Local_Exception      := True;
 
          when others =>
             return False;
@@ -3079,6 +3080,8 @@ package body Sem_Warn is
             Warn_On_Unrepped_Components         := False;
             Warn_On_Warnings_Off                := False;
 
+            No_Warn_On_Non_Local_Exception      := True;
+
          when 'b' =>
             Warn_On_Bad_Fixed_Value             := True;