------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- S E M _ C H 1 1 --
|
-- S E M _ C H 1 1 --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, 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- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- 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 --
|
-- for more details. You should have received a copy of the GNU General --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Atree; use Atree;
|
with Atree; use Atree;
|
with Checks; use Checks;
|
with Checks; use Checks;
|
with Einfo; use Einfo;
|
with Einfo; use Einfo;
|
with Errout; use Errout;
|
with Errout; use Errout;
|
with Lib; use Lib;
|
with Lib; use Lib;
|
with Lib.Xref; use Lib.Xref;
|
with Lib.Xref; use Lib.Xref;
|
with Namet; use Namet;
|
with Namet; use Namet;
|
with Nlists; use Nlists;
|
with Nlists; use Nlists;
|
with Nmake; use Nmake;
|
with Nmake; use Nmake;
|
with Opt; use Opt;
|
with Opt; use Opt;
|
with Restrict; use Restrict;
|
with Restrict; use Restrict;
|
with Rident; use Rident;
|
with Rident; use Rident;
|
with Rtsfind; use Rtsfind;
|
with Rtsfind; use Rtsfind;
|
with Sem; use Sem;
|
with Sem; use Sem;
|
with Sem_Ch5; use Sem_Ch5;
|
with Sem_Ch5; use Sem_Ch5;
|
with Sem_Ch8; use Sem_Ch8;
|
with Sem_Ch8; use Sem_Ch8;
|
with Sem_Res; use Sem_Res;
|
with Sem_Res; use Sem_Res;
|
with Sem_Util; use Sem_Util;
|
with Sem_Util; use Sem_Util;
|
with Sem_Warn; use Sem_Warn;
|
with Sem_Warn; use Sem_Warn;
|
with Sinfo; use Sinfo;
|
with Sinfo; use Sinfo;
|
with Stand; use Stand;
|
with Stand; use Stand;
|
with Uintp; use Uintp;
|
with Uintp; use Uintp;
|
|
|
package body Sem_Ch11 is
|
package body Sem_Ch11 is
|
|
|
-----------------------------------
|
-----------------------------------
|
-- Analyze_Exception_Declaration --
|
-- Analyze_Exception_Declaration --
|
-----------------------------------
|
-----------------------------------
|
|
|
procedure Analyze_Exception_Declaration (N : Node_Id) is
|
procedure Analyze_Exception_Declaration (N : Node_Id) is
|
Id : constant Entity_Id := Defining_Identifier (N);
|
Id : constant Entity_Id := Defining_Identifier (N);
|
PF : constant Boolean := Is_Pure (Current_Scope);
|
PF : constant Boolean := Is_Pure (Current_Scope);
|
begin
|
begin
|
Generate_Definition (Id);
|
Generate_Definition (Id);
|
Enter_Name (Id);
|
Enter_Name (Id);
|
Set_Ekind (Id, E_Exception);
|
Set_Ekind (Id, E_Exception);
|
Set_Exception_Code (Id, Uint_0);
|
Set_Exception_Code (Id, Uint_0);
|
Set_Etype (Id, Standard_Exception_Type);
|
Set_Etype (Id, Standard_Exception_Type);
|
Set_Is_Statically_Allocated (Id);
|
Set_Is_Statically_Allocated (Id);
|
Set_Is_Pure (Id, PF);
|
Set_Is_Pure (Id, PF);
|
end Analyze_Exception_Declaration;
|
end Analyze_Exception_Declaration;
|
|
|
--------------------------------
|
--------------------------------
|
-- Analyze_Exception_Handlers --
|
-- Analyze_Exception_Handlers --
|
--------------------------------
|
--------------------------------
|
|
|
procedure Analyze_Exception_Handlers (L : List_Id) is
|
procedure Analyze_Exception_Handlers (L : List_Id) is
|
Handler : Node_Id;
|
Handler : Node_Id;
|
Choice : Entity_Id;
|
Choice : Entity_Id;
|
Id : Node_Id;
|
Id : Node_Id;
|
H_Scope : Entity_Id := Empty;
|
H_Scope : Entity_Id := Empty;
|
|
|
procedure Check_Duplication (Id : Node_Id);
|
procedure Check_Duplication (Id : Node_Id);
|
-- Iterate through the identifiers in each handler to find duplicates
|
-- Iterate through the identifiers in each handler to find duplicates
|
|
|
function Others_Present return Boolean;
|
function Others_Present return Boolean;
|
-- Returns True if others handler is present
|
-- Returns True if others handler is present
|
|
|
-----------------------
|
-----------------------
|
-- Check_Duplication --
|
-- Check_Duplication --
|
-----------------------
|
-----------------------
|
|
|
procedure Check_Duplication (Id : Node_Id) is
|
procedure Check_Duplication (Id : Node_Id) is
|
Handler : Node_Id;
|
Handler : Node_Id;
|
Id1 : Node_Id;
|
Id1 : Node_Id;
|
Id_Entity : Entity_Id := Entity (Id);
|
Id_Entity : Entity_Id := Entity (Id);
|
|
|
begin
|
begin
|
if Present (Renamed_Entity (Id_Entity)) then
|
if Present (Renamed_Entity (Id_Entity)) then
|
Id_Entity := Renamed_Entity (Id_Entity);
|
Id_Entity := Renamed_Entity (Id_Entity);
|
end if;
|
end if;
|
|
|
Handler := First_Non_Pragma (L);
|
Handler := First_Non_Pragma (L);
|
while Present (Handler) loop
|
while Present (Handler) loop
|
Id1 := First (Exception_Choices (Handler));
|
Id1 := First (Exception_Choices (Handler));
|
while Present (Id1) loop
|
while Present (Id1) loop
|
|
|
-- Only check against the exception choices which precede
|
-- Only check against the exception choices which precede
|
-- Id in the handler, since the ones that follow Id have not
|
-- Id in the handler, since the ones that follow Id have not
|
-- been analyzed yet and will be checked in a subsequent call.
|
-- been analyzed yet and will be checked in a subsequent call.
|
|
|
if Id = Id1 then
|
if Id = Id1 then
|
return;
|
return;
|
|
|
elsif Nkind (Id1) /= N_Others_Choice
|
elsif Nkind (Id1) /= N_Others_Choice
|
and then
|
and then
|
(Id_Entity = Entity (Id1)
|
(Id_Entity = Entity (Id1)
|
or else (Id_Entity = Renamed_Entity (Entity (Id1))))
|
or else (Id_Entity = Renamed_Entity (Entity (Id1))))
|
then
|
then
|
if Handler /= Parent (Id) then
|
if Handler /= Parent (Id) then
|
Error_Msg_Sloc := Sloc (Id1);
|
Error_Msg_Sloc := Sloc (Id1);
|
Error_Msg_NE
|
Error_Msg_NE
|
("exception choice duplicates &#", Id, Id1);
|
("exception choice duplicates &#", Id, Id1);
|
|
|
else
|
else
|
if Ada_Version = Ada_83
|
if Ada_Version = Ada_83
|
and then Comes_From_Source (Id)
|
and then Comes_From_Source (Id)
|
then
|
then
|
Error_Msg_N
|
Error_Msg_N
|
("(Ada 83): duplicate exception choice&", Id);
|
("(Ada 83): duplicate exception choice&", Id);
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Next_Non_Pragma (Id1);
|
Next_Non_Pragma (Id1);
|
end loop;
|
end loop;
|
|
|
Next (Handler);
|
Next (Handler);
|
end loop;
|
end loop;
|
end Check_Duplication;
|
end Check_Duplication;
|
|
|
--------------------
|
--------------------
|
-- Others_Present --
|
-- Others_Present --
|
--------------------
|
--------------------
|
|
|
function Others_Present return Boolean is
|
function Others_Present return Boolean is
|
H : Node_Id;
|
H : Node_Id;
|
|
|
begin
|
begin
|
H := First (L);
|
H := First (L);
|
while Present (H) loop
|
while Present (H) loop
|
if Nkind (H) /= N_Pragma
|
if Nkind (H) /= N_Pragma
|
and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
|
and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
|
then
|
then
|
return True;
|
return True;
|
end if;
|
end if;
|
|
|
Next (H);
|
Next (H);
|
end loop;
|
end loop;
|
|
|
return False;
|
return False;
|
end Others_Present;
|
end Others_Present;
|
|
|
-- Start of processing for Analyze_Exception_Handlers
|
-- Start of processing for Analyze_Exception_Handlers
|
|
|
begin
|
begin
|
Handler := First (L);
|
Handler := First (L);
|
Check_Restriction (No_Exceptions, Handler);
|
Check_Restriction (No_Exceptions, Handler);
|
Check_Restriction (No_Exception_Handlers, Handler);
|
Check_Restriction (No_Exception_Handlers, Handler);
|
|
|
-- Kill current remembered values, since we don't know where we were
|
-- Kill current remembered values, since we don't know where we were
|
-- when the exception was raised.
|
-- when the exception was raised.
|
|
|
Kill_Current_Values;
|
Kill_Current_Values;
|
|
|
-- Loop through handlers (which can include pragmas)
|
-- Loop through handlers (which can include pragmas)
|
|
|
while Present (Handler) loop
|
while Present (Handler) loop
|
|
|
-- If pragma just analyze it
|
-- If pragma just analyze it
|
|
|
if Nkind (Handler) = N_Pragma then
|
if Nkind (Handler) = N_Pragma then
|
Analyze (Handler);
|
Analyze (Handler);
|
|
|
-- Otherwise we have a real exception handler
|
-- Otherwise we have a real exception handler
|
|
|
else
|
else
|
-- Deal with choice parameter. The exception handler is a
|
-- Deal with choice parameter. The exception handler is a
|
-- declarative part for the choice parameter, so it constitutes a
|
-- declarative part for the choice parameter, so it constitutes a
|
-- scope for visibility purposes. We create an entity to denote
|
-- scope for visibility purposes. We create an entity to denote
|
-- the whole exception part, and use it as the scope of all the
|
-- the whole exception part, and use it as the scope of all the
|
-- choices, which may even have the same name without conflict.
|
-- choices, which may even have the same name without conflict.
|
-- This scope plays no other role in expansion or code generation.
|
-- This scope plays no other role in expansion or code generation.
|
|
|
Choice := Choice_Parameter (Handler);
|
Choice := Choice_Parameter (Handler);
|
|
|
if Present (Choice) then
|
if Present (Choice) then
|
Set_Local_Raise_Not_OK (Handler);
|
Set_Local_Raise_Not_OK (Handler);
|
|
|
if Comes_From_Source (Choice) then
|
if Comes_From_Source (Choice) then
|
Check_Restriction (No_Exception_Propagation, Choice);
|
Check_Restriction (No_Exception_Propagation, Choice);
|
end if;
|
end if;
|
|
|
if No (H_Scope) then
|
if No (H_Scope) then
|
H_Scope :=
|
H_Scope :=
|
New_Internal_Entity
|
New_Internal_Entity
|
(E_Block, Current_Scope, Sloc (Choice), 'E');
|
(E_Block, Current_Scope, Sloc (Choice), 'E');
|
end if;
|
end if;
|
|
|
Push_Scope (H_Scope);
|
Push_Scope (H_Scope);
|
Set_Etype (H_Scope, Standard_Void_Type);
|
Set_Etype (H_Scope, Standard_Void_Type);
|
|
|
-- Set the Finalization Chain entity to Error means that it
|
-- Set the Finalization Chain entity to Error means that it
|
-- should not be used at that level but the parent one should
|
-- should not be used at that level but the parent one should
|
-- be used instead.
|
-- be used instead.
|
|
|
-- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
|
-- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
|
-- ??? using Error for this non-error condition is nasty ???
|
-- ??? using Error for this non-error condition is nasty ???
|
|
|
Set_Finalization_Chain_Entity (H_Scope, Error);
|
Set_Finalization_Chain_Entity (H_Scope, Error);
|
|
|
Enter_Name (Choice);
|
Enter_Name (Choice);
|
Set_Ekind (Choice, E_Variable);
|
Set_Ekind (Choice, E_Variable);
|
|
|
if RTE_Available (RE_Exception_Occurrence) then
|
if RTE_Available (RE_Exception_Occurrence) then
|
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
|
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
|
end if;
|
end if;
|
|
|
Generate_Definition (Choice);
|
Generate_Definition (Choice);
|
|
|
-- Indicate that choice has an initial value, since in effect
|
-- Indicate that choice has an initial value, since in effect
|
-- this field is assigned an initial value by the exception.
|
-- this field is assigned an initial value by the exception.
|
-- We also consider that it is modified in the source.
|
-- We also consider that it is modified in the source.
|
|
|
Set_Has_Initial_Value (Choice, True);
|
Set_Has_Initial_Value (Choice, True);
|
Set_Never_Set_In_Source (Choice, False);
|
Set_Never_Set_In_Source (Choice, False);
|
end if;
|
end if;
|
|
|
Id := First (Exception_Choices (Handler));
|
Id := First (Exception_Choices (Handler));
|
while Present (Id) loop
|
while Present (Id) loop
|
if Nkind (Id) = N_Others_Choice then
|
if Nkind (Id) = N_Others_Choice then
|
if Present (Next (Id))
|
if Present (Next (Id))
|
or else Present (Next (Handler))
|
or else Present (Next (Handler))
|
or else Present (Prev (Id))
|
or else Present (Prev (Id))
|
then
|
then
|
Error_Msg_N ("OTHERS must appear alone and last", Id);
|
Error_Msg_N ("OTHERS must appear alone and last", Id);
|
end if;
|
end if;
|
|
|
else
|
else
|
Analyze (Id);
|
Analyze (Id);
|
|
|
-- In most cases the choice has already been analyzed in
|
-- In most cases the choice has already been analyzed in
|
-- Analyze_Handled_Statement_Sequence, in order to expand
|
-- Analyze_Handled_Statement_Sequence, in order to expand
|
-- local handlers. This advance analysis does not take into
|
-- local handlers. This advance analysis does not take into
|
-- account the case in which a choice has the same name as
|
-- account the case in which a choice has the same name as
|
-- the choice parameter of the handler, which may hide an
|
-- the choice parameter of the handler, which may hide an
|
-- outer exception. This pathological case appears in ACATS
|
-- outer exception. This pathological case appears in ACATS
|
-- B80001_3.adb, and requires an explicit check to verify
|
-- B80001_3.adb, and requires an explicit check to verify
|
-- that the id is not hidden.
|
-- that the id is not hidden.
|
|
|
if not Is_Entity_Name (Id)
|
if not Is_Entity_Name (Id)
|
or else Ekind (Entity (Id)) /= E_Exception
|
or else Ekind (Entity (Id)) /= E_Exception
|
or else
|
or else
|
(Nkind (Id) = N_Identifier
|
(Nkind (Id) = N_Identifier
|
and then Chars (Id) = Chars (Choice))
|
and then Chars (Id) = Chars (Choice))
|
then
|
then
|
Error_Msg_N ("exception name expected", Id);
|
Error_Msg_N ("exception name expected", Id);
|
|
|
else
|
else
|
-- Emit a warning at the declaration level when a local
|
-- Emit a warning at the declaration level when a local
|
-- exception is never raised explicitly.
|
-- exception is never raised explicitly.
|
|
|
if Warn_On_Redundant_Constructs
|
if Warn_On_Redundant_Constructs
|
and then not Is_Raised (Entity (Id))
|
and then not Is_Raised (Entity (Id))
|
and then Scope (Entity (Id)) = Current_Scope
|
and then Scope (Entity (Id)) = Current_Scope
|
then
|
then
|
Error_Msg_NE
|
Error_Msg_NE
|
("?exception & is never raised", Entity (Id), Id);
|
("?exception & is never raised", Entity (Id), Id);
|
end if;
|
end if;
|
|
|
if Present (Renamed_Entity (Entity (Id))) then
|
if Present (Renamed_Entity (Entity (Id))) then
|
if Entity (Id) = Standard_Numeric_Error then
|
if Entity (Id) = Standard_Numeric_Error then
|
Check_Restriction (No_Obsolescent_Features, Id);
|
Check_Restriction (No_Obsolescent_Features, Id);
|
|
|
if Warn_On_Obsolescent_Feature then
|
if Warn_On_Obsolescent_Feature then
|
Error_Msg_N
|
Error_Msg_N
|
("Numeric_Error is an " &
|
("Numeric_Error is an " &
|
"obsolescent feature (RM J.6(1))?", Id);
|
"obsolescent feature (RM J.6(1))?", Id);
|
Error_Msg_N
|
Error_Msg_N
|
("\use Constraint_Error instead?", Id);
|
("\use Constraint_Error instead?", Id);
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Check_Duplication (Id);
|
Check_Duplication (Id);
|
|
|
-- Check for exception declared within generic formal
|
-- Check for exception declared within generic formal
|
-- package (which is illegal, see RM 11.2(8))
|
-- package (which is illegal, see RM 11.2(8))
|
|
|
declare
|
declare
|
Ent : Entity_Id := Entity (Id);
|
Ent : Entity_Id := Entity (Id);
|
Scop : Entity_Id;
|
Scop : Entity_Id;
|
|
|
begin
|
begin
|
if Present (Renamed_Entity (Ent)) then
|
if Present (Renamed_Entity (Ent)) then
|
Ent := Renamed_Entity (Ent);
|
Ent := Renamed_Entity (Ent);
|
end if;
|
end if;
|
|
|
Scop := Scope (Ent);
|
Scop := Scope (Ent);
|
while Scop /= Standard_Standard
|
while Scop /= Standard_Standard
|
and then Ekind (Scop) = E_Package
|
and then Ekind (Scop) = E_Package
|
loop
|
loop
|
if Nkind (Declaration_Node (Scop)) =
|
if Nkind (Declaration_Node (Scop)) =
|
N_Package_Specification
|
N_Package_Specification
|
and then
|
and then
|
Nkind (Original_Node (Parent
|
Nkind (Original_Node (Parent
|
(Declaration_Node (Scop)))) =
|
(Declaration_Node (Scop)))) =
|
N_Formal_Package_Declaration
|
N_Formal_Package_Declaration
|
then
|
then
|
Error_Msg_NE
|
Error_Msg_NE
|
("exception& is declared in " &
|
("exception& is declared in " &
|
"generic formal package", Id, Ent);
|
"generic formal package", Id, Ent);
|
Error_Msg_N
|
Error_Msg_N
|
("\and therefore cannot appear in " &
|
("\and therefore cannot appear in " &
|
"handler (RM 11.2(8))", Id);
|
"handler (RM 11.2(8))", Id);
|
exit;
|
exit;
|
|
|
-- If the exception is declared in an inner
|
-- If the exception is declared in an inner
|
-- instance, nothing else to check.
|
-- instance, nothing else to check.
|
|
|
elsif Is_Generic_Instance (Scop) then
|
elsif Is_Generic_Instance (Scop) then
|
exit;
|
exit;
|
end if;
|
end if;
|
|
|
Scop := Scope (Scop);
|
Scop := Scope (Scop);
|
end loop;
|
end loop;
|
end;
|
end;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Next (Id);
|
Next (Id);
|
end loop;
|
end loop;
|
|
|
-- Check for redundant handler (has only raise statement) and is
|
-- Check for redundant handler (has only raise statement) and is
|
-- either an others handler, or is a specific handler when no
|
-- either an others handler, or is a specific handler when no
|
-- others handler is present.
|
-- others handler is present.
|
|
|
if Warn_On_Redundant_Constructs
|
if Warn_On_Redundant_Constructs
|
and then List_Length (Statements (Handler)) = 1
|
and then List_Length (Statements (Handler)) = 1
|
and then Nkind (First (Statements (Handler))) = N_Raise_Statement
|
and then Nkind (First (Statements (Handler))) = N_Raise_Statement
|
and then No (Name (First (Statements (Handler))))
|
and then No (Name (First (Statements (Handler))))
|
and then (not Others_Present
|
and then (not Others_Present
|
or else Nkind (First (Exception_Choices (Handler))) =
|
or else Nkind (First (Exception_Choices (Handler))) =
|
N_Others_Choice)
|
N_Others_Choice)
|
then
|
then
|
Error_Msg_N
|
Error_Msg_N
|
("useless handler contains only a reraise statement?",
|
("useless handler contains only a reraise statement?",
|
Handler);
|
Handler);
|
end if;
|
end if;
|
|
|
-- Now analyze the statements of this handler
|
-- Now analyze the statements of this handler
|
|
|
Analyze_Statements (Statements (Handler));
|
Analyze_Statements (Statements (Handler));
|
|
|
-- If a choice was present, we created a special scope for it,
|
-- 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.
|
-- so this is where we pop that special scope to get rid of it.
|
|
|
if Present (Choice) then
|
if Present (Choice) then
|
End_Scope;
|
End_Scope;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Next (Handler);
|
Next (Handler);
|
end loop;
|
end loop;
|
end Analyze_Exception_Handlers;
|
end Analyze_Exception_Handlers;
|
|
|
--------------------------------
|
--------------------------------
|
-- Analyze_Handled_Statements --
|
-- Analyze_Handled_Statements --
|
--------------------------------
|
--------------------------------
|
|
|
procedure Analyze_Handled_Statements (N : Node_Id) is
|
procedure Analyze_Handled_Statements (N : Node_Id) is
|
Handlers : constant List_Id := Exception_Handlers (N);
|
Handlers : constant List_Id := Exception_Handlers (N);
|
Handler : Node_Id;
|
Handler : Node_Id;
|
Choice : Node_Id;
|
Choice : Node_Id;
|
|
|
begin
|
begin
|
if Present (Handlers) then
|
if Present (Handlers) then
|
Kill_All_Checks;
|
Kill_All_Checks;
|
end if;
|
end if;
|
|
|
-- We are now going to analyze the statements and then the exception
|
-- 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
|
-- handlers. We certainly need to do things in this order to get the
|
-- proper sequential semantics for various warnings.
|
-- proper sequential semantics for various warnings.
|
|
|
-- However, there is a glitch. When we process raise statements, an
|
-- However, there is a glitch. When we process raise statements, an
|
-- optimization is to look for local handlers and specialize the code
|
-- optimization is to look for local handlers and specialize the code
|
-- in this case.
|
-- in this case.
|
|
|
-- In order to detect if a handler is matching, we must have at least
|
-- 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
|
-- analyzed the choices in the proper scope so that proper visibility
|
-- analysis is performed. Hence we analyze just the choices first,
|
-- analysis is performed. Hence we analyze just the choices first,
|
-- before we analyze the statement sequence.
|
-- before we analyze the statement sequence.
|
|
|
Handler := First_Non_Pragma (Handlers);
|
Handler := First_Non_Pragma (Handlers);
|
while Present (Handler) loop
|
while Present (Handler) loop
|
Choice := First_Non_Pragma (Exception_Choices (Handler));
|
Choice := First_Non_Pragma (Exception_Choices (Handler));
|
while Present (Choice) loop
|
while Present (Choice) loop
|
Analyze (Choice);
|
Analyze (Choice);
|
Next_Non_Pragma (Choice);
|
Next_Non_Pragma (Choice);
|
end loop;
|
end loop;
|
|
|
Next_Non_Pragma (Handler);
|
Next_Non_Pragma (Handler);
|
end loop;
|
end loop;
|
|
|
-- Analyze statements in sequence
|
-- Analyze statements in sequence
|
|
|
Analyze_Statements (Statements (N));
|
Analyze_Statements (Statements (N));
|
|
|
-- If the current scope is a subprogram, then this is the right place to
|
-- If the current scope is a subprogram, then this is the right place to
|
-- check for hanging useless assignments from the statement sequence of
|
-- check for hanging useless assignments from the statement sequence of
|
-- the subprogram body.
|
-- the subprogram body.
|
|
|
if Is_Subprogram (Current_Scope) then
|
if Is_Subprogram (Current_Scope) then
|
Warn_On_Useless_Assignments (Current_Scope);
|
Warn_On_Useless_Assignments (Current_Scope);
|
end if;
|
end if;
|
|
|
-- Deal with handlers or AT END proc
|
-- Deal with handlers or AT END proc
|
|
|
if Present (Handlers) then
|
if Present (Handlers) then
|
Analyze_Exception_Handlers (Handlers);
|
Analyze_Exception_Handlers (Handlers);
|
elsif Present (At_End_Proc (N)) then
|
elsif Present (At_End_Proc (N)) then
|
Analyze (At_End_Proc (N));
|
Analyze (At_End_Proc (N));
|
end if;
|
end if;
|
end Analyze_Handled_Statements;
|
end Analyze_Handled_Statements;
|
|
|
-----------------------------
|
-----------------------------
|
-- Analyze_Raise_Statement --
|
-- Analyze_Raise_Statement --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Analyze_Raise_Statement (N : Node_Id) is
|
procedure Analyze_Raise_Statement (N : Node_Id) is
|
Exception_Id : constant Node_Id := Name (N);
|
Exception_Id : constant Node_Id := Name (N);
|
Exception_Name : Entity_Id := Empty;
|
Exception_Name : Entity_Id := Empty;
|
P : Node_Id;
|
P : Node_Id;
|
|
|
begin
|
begin
|
Check_Unreachable_Code (N);
|
Check_Unreachable_Code (N);
|
|
|
-- Check exception restrictions on the original source
|
-- Check exception restrictions on the original source
|
|
|
if Comes_From_Source (N) then
|
if Comes_From_Source (N) then
|
Check_Restriction (No_Exceptions, N);
|
Check_Restriction (No_Exceptions, N);
|
end if;
|
end if;
|
|
|
-- Check for useless assignment to OUT or IN OUT scalar immediately
|
-- Check for useless assignment to OUT or IN OUT scalar immediately
|
-- preceding the raise. Right now we only look at assignment statements,
|
-- preceding the raise. Right now we only look at assignment statements,
|
-- we could do more.
|
-- we could do more.
|
|
|
if Is_List_Member (N) then
|
if Is_List_Member (N) then
|
declare
|
declare
|
P : Node_Id;
|
P : Node_Id;
|
L : Node_Id;
|
L : Node_Id;
|
|
|
begin
|
begin
|
P := Prev (N);
|
P := Prev (N);
|
|
|
if Present (P)
|
if Present (P)
|
and then Nkind (P) = N_Assignment_Statement
|
and then Nkind (P) = N_Assignment_Statement
|
then
|
then
|
L := Name (P);
|
L := Name (P);
|
|
|
if Is_Scalar_Type (Etype (L))
|
if Is_Scalar_Type (Etype (L))
|
and then Is_Entity_Name (L)
|
and then Is_Entity_Name (L)
|
and then Is_Formal (Entity (L))
|
and then Is_Formal (Entity (L))
|
then
|
then
|
Error_Msg_N
|
Error_Msg_N
|
("?assignment to pass-by-copy formal may have no effect",
|
("?assignment to pass-by-copy formal may have no effect",
|
P);
|
P);
|
Error_Msg_N
|
Error_Msg_N
|
("\?RAISE statement may result in abnormal return" &
|
("\?RAISE statement may result in abnormal return" &
|
" (RM 6.4.1(17))", P);
|
" (RM 6.4.1(17))", P);
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
-- Reraise statement
|
-- Reraise statement
|
|
|
if No (Exception_Id) then
|
if No (Exception_Id) then
|
P := Parent (N);
|
P := Parent (N);
|
while not Nkind_In (P, N_Exception_Handler,
|
while not Nkind_In (P, N_Exception_Handler,
|
N_Subprogram_Body,
|
N_Subprogram_Body,
|
N_Package_Body,
|
N_Package_Body,
|
N_Task_Body,
|
N_Task_Body,
|
N_Entry_Body)
|
N_Entry_Body)
|
loop
|
loop
|
P := Parent (P);
|
P := Parent (P);
|
end loop;
|
end loop;
|
|
|
if Nkind (P) /= N_Exception_Handler then
|
if Nkind (P) /= N_Exception_Handler then
|
Error_Msg_N
|
Error_Msg_N
|
("reraise statement must appear directly in a handler", N);
|
("reraise statement must appear directly in a handler", N);
|
|
|
-- If a handler has a reraise, it cannot be the target of a local
|
-- If a handler has a reraise, it cannot be the target of a local
|
-- raise (goto optimization is impossible), and if the no exception
|
-- raise (goto optimization is impossible), and if the no exception
|
-- propagation restriction is set, this is a violation.
|
-- propagation restriction is set, this is a violation.
|
|
|
else
|
else
|
Set_Local_Raise_Not_OK (P);
|
Set_Local_Raise_Not_OK (P);
|
|
|
-- Do not check the restriction if the reraise statement is part
|
-- Do not check the restriction if the reraise statement is part
|
-- of the code generated for an AT-END handler. That's because
|
-- of the code generated for an AT-END handler. That's because
|
-- if the restriction is actually active, we never generate this
|
-- if the restriction is actually active, we never generate this
|
-- raise anyway, so the apparent violation is bogus.
|
-- raise anyway, so the apparent violation is bogus.
|
|
|
if not From_At_End (N) then
|
if not From_At_End (N) then
|
Check_Restriction (No_Exception_Propagation, N);
|
Check_Restriction (No_Exception_Propagation, N);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Normal case with exception id present
|
-- Normal case with exception id present
|
|
|
else
|
else
|
Analyze (Exception_Id);
|
Analyze (Exception_Id);
|
|
|
if Is_Entity_Name (Exception_Id) then
|
if Is_Entity_Name (Exception_Id) then
|
Exception_Name := Entity (Exception_Id);
|
Exception_Name := Entity (Exception_Id);
|
end if;
|
end if;
|
|
|
if No (Exception_Name)
|
if No (Exception_Name)
|
or else Ekind (Exception_Name) /= E_Exception
|
or else Ekind (Exception_Name) /= E_Exception
|
then
|
then
|
Error_Msg_N
|
Error_Msg_N
|
("exception name expected in raise statement", Exception_Id);
|
("exception name expected in raise statement", Exception_Id);
|
else
|
else
|
Set_Is_Raised (Exception_Name);
|
Set_Is_Raised (Exception_Name);
|
end if;
|
end if;
|
|
|
-- Deal with RAISE WITH case
|
-- Deal with RAISE WITH case
|
|
|
if Present (Expression (N)) then
|
if Present (Expression (N)) then
|
Check_Compiler_Unit (Expression (N));
|
Check_Compiler_Unit (Expression (N));
|
Analyze_And_Resolve (Expression (N), Standard_String);
|
Analyze_And_Resolve (Expression (N), Standard_String);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Kill_Current_Values (Last_Assignment_Only => True);
|
Kill_Current_Values (Last_Assignment_Only => True);
|
end Analyze_Raise_Statement;
|
end Analyze_Raise_Statement;
|
|
|
-----------------------------
|
-----------------------------
|
-- Analyze_Raise_xxx_Error --
|
-- Analyze_Raise_xxx_Error --
|
-----------------------------
|
-----------------------------
|
|
|
-- Normally, the Etype is already set (when this node is used within
|
-- Normally, the Etype is already set (when this node is used within
|
-- an expression, since it is copied from the node which it rewrites).
|
-- an expression, since it is copied from the node which it rewrites).
|
-- If this node is used in a statement context, then we set the type
|
-- If this node is used in a statement context, then we set the type
|
-- Standard_Void_Type. This is used both by Gigi and by the front end
|
-- Standard_Void_Type. This is used both by Gigi and by the front end
|
-- to distinguish the statement use and the subexpression use.
|
-- to distinguish the statement use and the subexpression use.
|
|
|
-- The only other required processing is to take care of the Condition
|
-- The only other required processing is to take care of the Condition
|
-- field if one is present.
|
-- field if one is present.
|
|
|
procedure Analyze_Raise_xxx_Error (N : Node_Id) is
|
procedure Analyze_Raise_xxx_Error (N : Node_Id) is
|
|
|
function Same_Expression (C1, C2 : Node_Id) return Boolean;
|
function Same_Expression (C1, C2 : Node_Id) return Boolean;
|
-- It often occurs that two identical raise statements are generated in
|
-- It often occurs that two identical raise statements are generated in
|
-- succession (for example when dynamic elaboration checks take place on
|
-- succession (for example when dynamic elaboration checks take place on
|
-- separate expressions in a call). If the two statements are identical
|
-- separate expressions in a call). If the two statements are identical
|
-- according to the simple criterion that follows, the raise is
|
-- according to the simple criterion that follows, the raise is
|
-- converted into a null statement.
|
-- converted into a null statement.
|
|
|
---------------------
|
---------------------
|
-- Same_Expression --
|
-- Same_Expression --
|
---------------------
|
---------------------
|
|
|
function Same_Expression (C1, C2 : Node_Id) return Boolean is
|
function Same_Expression (C1, C2 : Node_Id) return Boolean is
|
begin
|
begin
|
if No (C1) and then No (C2) then
|
if No (C1) and then No (C2) then
|
return True;
|
return True;
|
|
|
elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
|
elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
|
return Entity (C1) = Entity (C2);
|
return Entity (C1) = Entity (C2);
|
|
|
elsif Nkind (C1) /= Nkind (C2) then
|
elsif Nkind (C1) /= Nkind (C2) then
|
return False;
|
return False;
|
|
|
elsif Nkind (C1) in N_Unary_Op then
|
elsif Nkind (C1) in N_Unary_Op then
|
return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
|
|
elsif Nkind (C1) in N_Binary_Op then
|
elsif Nkind (C1) in N_Binary_Op then
|
return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
|
return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
|
and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
|
|
elsif Nkind (C1) = N_Null then
|
elsif Nkind (C1) = N_Null then
|
return True;
|
return True;
|
|
|
else
|
else
|
return False;
|
return False;
|
end if;
|
end if;
|
end Same_Expression;
|
end Same_Expression;
|
|
|
-- Start of processing for Analyze_Raise_xxx_Error
|
-- Start of processing for Analyze_Raise_xxx_Error
|
|
|
begin
|
begin
|
if No (Etype (N)) then
|
if No (Etype (N)) then
|
Set_Etype (N, Standard_Void_Type);
|
Set_Etype (N, Standard_Void_Type);
|
end if;
|
end if;
|
|
|
if Present (Condition (N)) then
|
if Present (Condition (N)) then
|
Analyze_And_Resolve (Condition (N), Standard_Boolean);
|
Analyze_And_Resolve (Condition (N), Standard_Boolean);
|
end if;
|
end if;
|
|
|
-- Deal with static cases in obvious manner
|
-- Deal with static cases in obvious manner
|
|
|
if Nkind (Condition (N)) = N_Identifier then
|
if Nkind (Condition (N)) = N_Identifier then
|
if Entity (Condition (N)) = Standard_True then
|
if Entity (Condition (N)) = Standard_True then
|
Set_Condition (N, Empty);
|
Set_Condition (N, Empty);
|
|
|
elsif Entity (Condition (N)) = Standard_False then
|
elsif Entity (Condition (N)) = Standard_False then
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Remove duplicate raise statements. Note that the previous one may
|
-- Remove duplicate raise statements. Note that the previous one may
|
-- already have been removed as well.
|
-- already have been removed as well.
|
|
|
if not Comes_From_Source (N)
|
if not Comes_From_Source (N)
|
and then Nkind (N) /= N_Null_Statement
|
and then Nkind (N) /= N_Null_Statement
|
and then Is_List_Member (N)
|
and then Is_List_Member (N)
|
and then Present (Prev (N))
|
and then Present (Prev (N))
|
and then Nkind (N) = Nkind (Original_Node (Prev (N)))
|
and then Nkind (N) = Nkind (Original_Node (Prev (N)))
|
and then Same_Expression
|
and then Same_Expression
|
(Condition (N), Condition (Original_Node (Prev (N))))
|
(Condition (N), Condition (Original_Node (Prev (N))))
|
then
|
then
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
end if;
|
end if;
|
end Analyze_Raise_xxx_Error;
|
end Analyze_Raise_xxx_Error;
|
|
|
-----------------------------
|
-----------------------------
|
-- Analyze_Subprogram_Info --
|
-- Analyze_Subprogram_Info --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Analyze_Subprogram_Info (N : Node_Id) is
|
procedure Analyze_Subprogram_Info (N : Node_Id) is
|
begin
|
begin
|
Set_Etype (N, RTE (RE_Code_Loc));
|
Set_Etype (N, RTE (RE_Code_Loc));
|
end Analyze_Subprogram_Info;
|
end Analyze_Subprogram_Info;
|
|
|
end Sem_Ch11;
|
end Sem_Ch11;
|
|
|
