einfo.ads, einfo.adb: New flag Is_Raised (Flag224).

2007-08-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.ads, einfo.adb: New flag Is_Raised (Flag224). Update the
	structure of E_Exception to reflect the new flag.
	(Is_Raised, Set_Is_Raised): New inlined routines.
	Update the usage of available flag to reflect the addition of Is_Raised.
	(Is_Raised, Set_Is_Raised): Bodies of new routines.
	(Write_Entity_Flags): Write the status of flag Is_Raised.
	(Is_Descendent_Of_Address): New entity flag, to simplify handling of
	spurious ambiguities when integer literals appear in the context of an
	address type that is a visible integer type.

	* sem_ch11.adb (Analyze_Exception_Handler): Add code to warn on local
	exceptions never being raised.
	(Analyze_Raise_Statement): When analyzing an exception, mark it as being
	explicitly raised.

From-SVN: r127970

3 files changed, 60 insertions, 2 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index cbfb4a6..7b705b0 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -480,8 +480,8 @@ package body Einfo is
 
    --    Has_Pragma_Preelab_Init         Flag221
    --    Used_As_Generic_Actual          Flag222
-   --    (unused)                        Flag223
-   --    (unused)                        Flag224
+   --    Is_Descendent_Of_Address        Flag223
+   --    Is_Raised                       Flag224
    --    (unused)                        Flag225
    --    (unused)                        Flag226
    --    (unused)                        Flag227
@@ -1634,6 +1634,12 @@ package body Einfo is
       return Flag176 (Id);
    end Is_Discrim_SO_Function;
 
+   function Is_Descendent_Of_Address (Id : E) return B is
+   begin
+      pragma Assert (Is_Type (Id));
+      return Flag223 (Id);
+   end Is_Descendent_Of_Address;
+
    function Is_Dispatching_Operation (Id : E) return B is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -1894,6 +1900,12 @@ package body Einfo is
       return Flag189 (Id);
    end Is_Pure_Unit_Access_Type;
 
+   function Is_Raised (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Exception);
+      return Flag224 (Id);
+   end Is_Raised;
+
    function Is_Remote_Call_Interface (Id : E) return B is
    begin
       return Flag62 (Id);
@@ -3913,6 +3925,12 @@ package body Einfo is
       Set_Flag74 (Id, V);
    end Set_Is_CPP_Class;
 
+   procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Type (Id));
+      Set_Flag223 (Id, V);
+   end Set_Is_Descendent_Of_Address;
+
    procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is
    begin
       Set_Flag176 (Id, V);
@@ -4195,6 +4213,12 @@ package body Einfo is
       Set_Flag189 (Id, V);
    end Set_Is_Pure_Unit_Access_Type;
 
+   procedure Set_Is_Raised (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Exception);
+      Set_Flag224 (Id, V);
+   end Set_Is_Raised;
+
    procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is
    begin
       Set_Flag62 (Id, V);
@@ -7168,6 +7192,7 @@ package body Einfo is
       W ("Is_Constructor",                  Flag76  (Id));
       W ("Is_Controlled",                   Flag42  (Id));
       W ("Is_Controlling_Formal",           Flag97  (Id));
+      W ("Is_Descendent_Of_Address",        Flag223 (Id));
       W ("Is_Discrim_SO_Function",          Flag176 (Id));
       W ("Is_Dispatching_Operation",        Flag6   (Id));
       W ("Is_Eliminated",                   Flag124 (Id));
@@ -7215,6 +7240,7 @@ package body Einfo is
       W ("Is_Public",                       Flag10  (Id));
       W ("Is_Pure",                         Flag44  (Id));
       W ("Is_Pure_Unit_Access_Type",        Flag189 (Id));
+      W ("Is_Raised",                       Flag224 (Id));
       W ("Is_Remote_Call_Interface",        Flag62  (Id));
       W ("Is_Remote_Types",                 Flag61  (Id));
       W ("Is_Renaming_Of_Object",           Flag112 (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index bee3d2b..924472b 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1997,6 +1997,12 @@ package Einfo is
 --       Applies to all entities. Determine if given entity is a derived type.
 --       Always false if argument is not a type.
 
+--    Is_Descendent_Of_Address (Flag223)
+--       Applies to all types. Indicates that a type is an address type that
+--       is visibly a numeric type. Used for semantic checks on VMS to remove
+--       ambiguities in universal integer expressions that may have an address
+--       interpretation
+
 --    Is_Discrete_Type (synthesized)
 --       Applies to all entities, true for all discrete types and subtypes
 
@@ -2481,6 +2487,10 @@ package Einfo is
 --       subtype appears in a pure unit. Used to give an error message at
 --       freeze time if the access type has a storage pool.
 
+--    Is_Raised (Flag224)
+--       Present in entities which denote exceptions. Set if the exception is
+--       thrown by a raise statement.
+
 --    Is_Real_Type (synthesized)
 --       Applies to all entities, true for real types and subtypes
 
@@ -4745,6 +4755,7 @@ package Einfo is
    --    Exception_Code                      (Uint22)
    --    Discard_Names                       (Flag88)
    --    Is_VMS_Exception                    (Flag133)
+   --    Is_Raised                           (Flag224)
 
    --  E_Exception_Type
    --    Equivalent_Type                     (Node18)
@@ -5734,6 +5745,7 @@ package Einfo is
    function Is_Public                           (Id : E) return B;
    function Is_Pure                             (Id : E) return B;
    function Is_Pure_Unit_Access_Type            (Id : E) return B;
+   function Is_Raised                           (Id : E) return B;
    function Is_Remote_Call_Interface            (Id : E) return B;
    function Is_Remote_Types                     (Id : E) return B;
    function Is_Renaming_Of_Object               (Id : E) return B;
@@ -5871,6 +5883,7 @@ package Einfo is
    function Is_Concurrent_Type                  (Id : E) return B;
    function Is_Decimal_Fixed_Point_Type         (Id : E) return B;
    function Is_Digits_Type                      (Id : E) return B;
+   function Is_Descendent_Of_Address            (Id : E) return B;
    function Is_Discrete_Or_Fixed_Point_Type     (Id : E) return B;
    function Is_Discrete_Type                    (Id : E) return B;
    function Is_Elementary_Type                  (Id : E) return B;
@@ -6223,6 +6236,7 @@ package Einfo is
    procedure Set_Is_Constructor                  (Id : E; V : B := True);
    procedure Set_Is_Controlled                   (Id : E; V : B := True);
    procedure Set_Is_Controlling_Formal           (Id : E; V : B := True);
+   procedure Set_Is_Descendent_Of_Address        (Id : E; V : B := True);
    procedure Set_Is_Discrim_SO_Function          (Id : E; V : B := True);
    procedure Set_Is_Dispatching_Operation        (Id : E; V : B := True);
    procedure Set_Is_Eliminated                   (Id : E; V : B := True);
@@ -6271,6 +6285,7 @@ package Einfo is
    procedure Set_Is_Public                       (Id : E; V : B := True);
    procedure Set_Is_Pure                         (Id : E; V : B := True);
    procedure Set_Is_Pure_Unit_Access_Type        (Id : E; V : B := True);
+   procedure Set_Is_Raised                       (Id : E; V : B := True);
    procedure Set_Is_Remote_Call_Interface        (Id : E; V : B := True);
    procedure Set_Is_Remote_Types                 (Id : E; V : B := True);
    procedure Set_Is_Renaming_Of_Object           (Id : E; V : B := True);
@@ -6826,6 +6841,7 @@ package Einfo is
    pragma Inline (Is_Decimal_Fixed_Point_Type);
    pragma Inline (Is_Discrim_SO_Function);
    pragma Inline (Is_Digits_Type);
+   pragma Inline (Is_Descendent_Of_Address);
    pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
    pragma Inline (Is_Discrete_Type);
    pragma Inline (Is_Dispatching_Operation);
@@ -6895,6 +6911,7 @@ package Einfo is
    pragma Inline (Is_Public);
    pragma Inline (Is_Pure);
    pragma Inline (Is_Pure_Unit_Access_Type);
+   pragma Inline (Is_Raised);
    pragma Inline (Is_Real_Type);
    pragma Inline (Is_Record_Type);
    pragma Inline (Is_Remote_Call_Interface);
@@ -7216,6 +7233,7 @@ package Einfo is
    pragma Inline (Set_Is_Constructor);
    pragma Inline (Set_Is_Controlled);
    pragma Inline (Set_Is_Controlling_Formal);
+   pragma Inline (Set_Is_Descendent_Of_Address);
    pragma Inline (Set_Is_Discrim_SO_Function);
    pragma Inline (Set_Is_Dispatching_Operation);
    pragma Inline (Set_Is_Eliminated);
@@ -7264,6 +7282,7 @@ package Einfo is
    pragma Inline (Set_Is_Public);
    pragma Inline (Set_Is_Pure);
    pragma Inline (Set_Is_Pure_Unit_Access_Type);
+   pragma Inline (Set_Is_Raised);
    pragma Inline (Set_Is_Remote_Call_Interface);
    pragma Inline (Set_Is_Remote_Types);
    pragma Inline (Set_Is_Renaming_Of_Object);
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index a6d937d..8846203 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -264,6 +264,17 @@ package body Sem_Ch11 is
                      Error_Msg_N ("exception name expected", Id);
 
                   else
+                     --  Emit a warning at the declaration level when a local
+                     --  exception is never raised explicitly.
+
+                     if Warn_On_Redundant_Constructs
+                       and then not Is_Raised (Entity (Id))
+                       and then Scope (Entity (Id)) = Current_Scope
+                     then
+                        Error_Msg_NE
+                          ("?exception & is never raised", Entity (Id), Id);
+                     end if;
+
                      if Present (Renamed_Entity (Entity (Id))) then
                         if Entity (Id) = Standard_Numeric_Error then
                            Check_Restriction (No_Obsolescent_Features, Id);
@@ -513,6 +524,8 @@ package body Sem_Ch11 is
          then
             Error_Msg_N
               ("exception name expected in raise statement", Exception_Id);
+         else
+            Set_Is_Raised (Exception_Name);
          end if;
 
          if Present (Expression (N)) then