Skip to content

R
riscv-gcc-1
Commit d5e96bc6 by Hristian Kirtchev Committed by Arnaud Charlet
Options

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
parent bb6e3d41
Showing with 60 additions and 2 deletions
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));
......
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);
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment