-- --
-- B o d y --
-- --
--- $Revision: 1.96 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
+with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Uintp; use Uintp;
procedure Analyze_Exception_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
PF : constant Boolean := Is_Pure (Current_Scope);
-
begin
- Generate_Definition (Id);
- Enter_Name (Id);
- Set_Ekind (Id, E_Exception);
- Set_Exception_Code (Id, Uint_0);
- Set_Etype (Id, Standard_Exception_Type);
-
+ Generate_Definition (Id);
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Exception);
+ Set_Exception_Code (Id, Uint_0);
+ Set_Etype (Id, Standard_Exception_Type);
Set_Is_Statically_Allocated (Id);
- Set_Is_Pure (Id, PF);
-
+ Set_Is_Pure (Id, PF);
end Analyze_Exception_Declaration;
--------------------------------
procedure Check_Duplication (Id : Node_Id);
-- Iterate through the identifiers in each handler to find duplicates
+ function Others_Present return Boolean;
+ -- Returns True if others handler is present
+
-----------------------
-- Check_Duplication --
-----------------------
procedure Check_Duplication (Id : Node_Id) is
- Handler : Node_Id;
- Id1 : Node_Id;
+ Handler : Node_Id;
+ Id1 : Node_Id;
+ Id_Entity : Entity_Id := Entity (Id);
begin
+ if Present (Renamed_Entity (Id_Entity)) then
+ Id_Entity := Renamed_Entity (Id_Entity);
+ end if;
+
Handler := First_Non_Pragma (L);
while Present (Handler) loop
Id1 := First (Exception_Choices (Handler));
-
while Present (Id1) loop
-- Only check against the exception choices which precede
return;
elsif Nkind (Id1) /= N_Others_Choice
- and then Entity (Id) = Entity (Id1)
+ and then
+ (Id_Entity = Entity (Id1)
+ or else (Id_Entity = Renamed_Entity (Entity (Id1))))
then
if Handler /= Parent (Id) then
Error_Msg_Sloc := Sloc (Id1);
("exception choice duplicates &#", Id, Id1);
else
- if Ada_83 and then Comes_From_Source (Id) then
+ if Ada_Version = Ada_83
+ and then Comes_From_Source (Id)
+ then
Error_Msg_N
("(Ada 83): duplicate exception choice&", Id);
end if;
end loop;
end Check_Duplication;
+ --------------------
+ -- Others_Present --
+ --------------------
+
+ function Others_Present return Boolean is
+ H : Node_Id;
+
+ begin
+ H := First (L);
+ while Present (H) loop
+ if Nkind (H) /= N_Pragma
+ and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
+ then
+ return True;
+ end if;
+
+ Next (H);
+ end loop;
+
+ return False;
+ end Others_Present;
+
-- Start processing for Analyze_Exception_Handlers
begin
Check_Restriction (No_Exceptions, Handler);
Check_Restriction (No_Exception_Handlers, Handler);
+ -- Kill current remembered values, since we don't know where we were
+ -- when the exception was raised.
+
+ Kill_Current_Values;
+
-- Loop through handlers (which can include pragmas)
while Present (Handler) loop
-- Otherwise we have a real exception handler
else
- -- Deal with choice parameter. The exception handler is
- -- a declarative part for it, so it constitutes a scope
- -- for visibility purposes. We create an entity to denote
- -- the whole exception part, and use it as the scope of all
- -- the choices, which may even have the same name without
- -- conflict. This scope plays no other role in expansion or
- -- or code generation.
+ -- Deal with choice parameter. The exception handler is a
+ -- declarative part for the choice parameter, so it constitutes a
+ -- scope for visibility purposes. We create an entity to denote
+ -- the whole exception part, and use it as the scope of all the
+ -- choices, which may even have the same name without conflict.
+ -- This scope plays no other role in expansion or or code
+ -- generation.
Choice := Choice_Parameter (Handler);
if Present (Choice) then
+ Set_Local_Raise_Not_OK (Handler);
+
+ if Comes_From_Source (Choice) then
+ Check_Restriction (No_Exception_Propagation, Choice);
+ end if;
if No (H_Scope) then
- H_Scope := New_Internal_Entity
- (E_Block, Current_Scope, Sloc (Choice), 'E');
+ H_Scope :=
+ New_Internal_Entity
+ (E_Block, Current_Scope, Sloc (Choice), 'E');
end if;
- New_Scope (H_Scope);
+ Push_Scope (H_Scope);
Set_Etype (H_Scope, Standard_Void_Type);
-- Set the Finalization Chain entity to Error means that it
- -- should not be used at that level but the parent one
- -- should be used instead.
+ -- should not be used at that level but the parent one should
+ -- be used instead.
-- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
-- ??? using Error for this non-error condition is nasty ???
Enter_Name (Choice);
Set_Ekind (Choice, E_Variable);
- Set_Etype (Choice, RTE (RE_Exception_Occurrence));
+
+ if RTE_Available (RE_Exception_Occurrence) then
+ Set_Etype (Choice, RTE (RE_Exception_Occurrence));
+ end if;
+
Generate_Definition (Choice);
+
+ -- Indicate that choice has an initial value, since in effect
+ -- this field is assigned an initial value by the exception.
+ -- We also consider that it is modified in the source.
+
+ Set_Has_Initial_Value (Choice, True);
+ Set_Never_Set_In_Source (Choice, False);
end if;
Id := First (Exception_Choices (Handler));
else
Analyze (Id);
+ -- In most cases the choice has already been analyzed in
+ -- Analyze_Handled_Statement_Sequence, in order to expand
+ -- local handlers. This advance analysis does not take into
+ -- account the case in which a choice has the same name as
+ -- the choice parameter of the handler, which may hide an
+ -- outer exception. This pathological case appears in ACATS
+ -- B80001_3.adb, and requires an explicit check to verify
+ -- that the id is not hidden.
+
if not Is_Entity_Name (Id)
or else Ekind (Entity (Id)) /= E_Exception
+ or else
+ (Nkind (Id) = N_Identifier
+ and then Chars (Id) = Chars (Choice))
then
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
- Set_Entity (Id, Renamed_Entity (Entity (Id)));
+ if Entity (Id) = Standard_Numeric_Error then
+ Check_Restriction (No_Obsolescent_Features, Id);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("Numeric_Error is an " &
+ "obsolescent feature (RM J.6(1))?", Id);
+ Error_Msg_N
+ ("\use Constraint_Error instead?", Id);
+ end if;
+ end if;
end if;
Check_Duplication (Id);
declare
Ent : Entity_Id := Entity (Id);
- Scop : Entity_Id := Scope (Ent);
+ Scop : Entity_Id;
begin
+ if Present (Renamed_Entity (Ent)) then
+ Ent := Renamed_Entity (Ent);
+ end if;
+
+ Scop := Scope (Ent);
while Scop /= Standard_Standard
and then Ekind (Scop) = E_Package
loop
- -- If the exception is declared in an inner
- -- instance, nothing else to check.
-
- if Is_Generic_Instance (Scop) then
- exit;
-
- elsif Nkind (Declaration_Node (Scop)) =
+ if Nkind (Declaration_Node (Scop)) =
N_Package_Specification
and then
Nkind (Original_Node (Parent
"generic formal package", Id, Ent);
Error_Msg_N
("\and therefore cannot appear in " &
- "handler ('R'M 11.2(8))", Id);
+ "handler (RM 11.2(8))", Id);
+ exit;
+
+ -- If the exception is declared in an inner
+ -- instance, nothing else to check.
+
+ elsif Is_Generic_Instance (Scop) then
exit;
end if;
Next (Id);
end loop;
+ -- Check for redundant handler (has only raise statement) and is
+ -- either an others handler, or is a specific handler when no
+ -- others handler is present.
+
+ if Warn_On_Redundant_Constructs
+ and then List_Length (Statements (Handler)) = 1
+ and then Nkind (First (Statements (Handler))) = N_Raise_Statement
+ and then No (Name (First (Statements (Handler))))
+ and then (not Others_Present
+ or else Nkind (First (Exception_Choices (Handler))) =
+ N_Others_Choice)
+ then
+ Error_Msg_N
+ ("useless handler contains only a reraise statement?",
+ Handler);
+ end if;
+
+ -- Now analyze the statements of this handler
+
Analyze_Statements (Statements (Handler));
+ -- If a choice was present, we created a special scope for it,
+ -- so this is where we pop that special scope to get rid of it.
+
if Present (Choice) then
End_Scope;
end if;
-
end if;
Next (Handler);
procedure Analyze_Handled_Statements (N : Node_Id) is
Handlers : constant List_Id := Exception_Handlers (N);
+ Handler : Node_Id;
+ Choice : Node_Id;
begin
+ if Present (Handlers) then
+ Kill_All_Checks;
+ end if;
+
+ -- We are now going to analyze the statements and then the exception
+ -- handlers. We certainly need to do things in this order to get the
+ -- proper sequential semantics for various warnings.
+
+ -- However, there is a glitch. When we process raise statements, an
+ -- optimization is to look for local handlers and specialize the code
+ -- in this case.
+
+ -- In order to detect if a handler is matching, we must have at least
+ -- analyzed the choices in the proper scope so that proper visibility
+ -- analysis is performed. Hence we analyze just the choices first,
+ -- before we analyze the statement sequence.
+
+ Handler := First_Non_Pragma (Handlers);
+ while Present (Handler) loop
+ Choice := First_Non_Pragma (Exception_Choices (Handler));
+ while Present (Choice) loop
+ Analyze (Choice);
+ Next_Non_Pragma (Choice);
+ end loop;
+
+ Next_Non_Pragma (Handler);
+ end loop;
+
+ -- Analyze statements in sequence
+
Analyze_Statements (Statements (N));
+ -- If the current scope is a subprogram, then this is the right place to
+ -- check for hanging useless assignments from the statement sequence of
+ -- the subprogram body.
+
+ if Is_Subprogram (Current_Scope) then
+ Warn_On_Useless_Assignments (Current_Scope);
+ end if;
+
+ -- Deal with handlers or AT END proc
+
if Present (Handlers) then
Analyze_Exception_Handlers (Handlers);
-
elsif Present (At_End_Proc (N)) then
Analyze (At_End_Proc (N));
end if;
procedure Analyze_Raise_Statement (N : Node_Id) is
Exception_Id : constant Node_Id := Name (N);
- Exception_Name : Entity_Id := Empty;
+ Exception_Name : Entity_Id := Empty;
P : Node_Id;
Nkind_P : Node_Kind;
Check_Restriction (No_Exceptions, N);
end if;
+ -- Check for useless assignment to OUT or IN OUT scalar immediately
+ -- preceding the raise. Right now we only look at assignment statements,
+ -- we could do more.
+
+ if Is_List_Member (N) then
+ declare
+ P : Node_Id;
+ L : Node_Id;
+
+ begin
+ P := Prev (N);
+
+ if Present (P)
+ and then Nkind (P) = N_Assignment_Statement
+ then
+ L := Name (P);
+
+ if Is_Scalar_Type (Etype (L))
+ and then Is_Entity_Name (L)
+ and then Is_Formal (Entity (L))
+ then
+ Error_Msg_N
+ ("?assignment to pass-by-copy formal may have no effect",
+ P);
+ Error_Msg_N
+ ("\?RAISE statement may result in abnormal return" &
+ " (RM 6.4.1(17))", P);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Reraise statement
if No (Exception_Id) then
-
P := Parent (N);
Nkind_P := Nkind (P);
if Nkind (P) /= N_Exception_Handler then
Error_Msg_N
("reraise statement must appear directly in a handler", N);
+
+ -- If a handler has a reraise, it cannot be the target of a local
+ -- raise (goto optimization is impossible), and if the no exception
+ -- propagation restriction is set, this is a violation.
+
+ else
+ Set_Local_Raise_Not_OK (P);
+ Check_Restriction (No_Exception_Propagation, N);
end if;
-- Normal case with exception id present
if Is_Entity_Name (Exception_Id) then
Exception_Name := Entity (Exception_Id);
-
- if Present (Renamed_Object (Exception_Name)) then
- Set_Entity (Exception_Id, Renamed_Object (Exception_Name));
- end if;
end if;
if No (Exception_Name)
then
Error_Msg_N
("exception name expected in raise statement", Exception_Id);
+ else
+ Set_Is_Raised (Exception_Name);
+ end if;
+
+ -- Deal with RAISE WITH case
+
+ if Present (Expression (N)) then
+ Check_Compiler_Unit (Expression (N));
+ Analyze_And_Resolve (Expression (N), Standard_String);
end if;
end if;
end Analyze_Raise_Statement;
Rewrite (N, Make_Null_Statement (Sloc (N)));
end if;
end if;
-
end Analyze_Raise_xxx_Error;
-----------------------------
OSDN Git Service
