+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.
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
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);
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
To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
+ Unlock_Task.all;
end if;
-- Call the user-specific actions
with Osint;
with Par;
with Prepcomp;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind;
with Sprint;
with Scn; use Scn;
-- 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;
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
Free (Config.Aliases);
Free (Config.Expansions);
Free (Config.Prefixes);
+ Free (Config.Sections);
+ Free (Config.Switches);
Unchecked_Free (Config);
end if;
end Free;
-- 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
-- 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
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);
-- --
------------------------------------------------------------------------------
+with Ada.Unchecked_Deallocation;
with Prj.Err;
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 --
-------------------------------
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;
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Unchecked_Deallocation;
with Debug;
with Output; use Output;
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;
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
-- 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
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;
------------------------------------
when 'X' =>
Warn_On_Non_Local_Exception := False;
+ No_Warn_On_Non_Local_Exception := True;
when others =>
return False;
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;
projects / thirdparty / gcc.git / commitdiff
