-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
-with Hostparm; use Hostparm;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-with Rtsfind; use Rtsfind;
with Restrict; use Restrict;
with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
-- Local Subprograms --
-----------------------
- function Find_Local_Handler
- (Ename : Entity_Id;
- Nod : Node_Id) return Node_Id;
- pragma Warnings (Off, Find_Local_Handler);
- -- This function searches for a local exception handler that will handle
- -- the exception named by Ename. If such a local hander exists, then the
- -- corresponding N_Exception_Handler is returned. If no such handler is
- -- found then Empty is returned. In order to match and return True, the
- -- handler may not have a choice parameter specification. N is the raise
- -- node that references the handler.
+ procedure Warn_No_Exception_Propagation_Active (N : Node_Id);
+ -- Generates warning that pragma Restrictions (No_Exception_Propagation)
+ -- is in effect. Caller then generates appropriate continuation message.
+ -- N is the node on which the warning is placed.
procedure Warn_If_No_Propagation (N : Node_Id);
-- Called for an exception raise that is not a local raise (and thus can
return;
end if;
- if Restriction_Active (No_Exception_Handlers) then
+ -- Don't expand an At End handler if we are not allowing exceptions
+ -- or if exceptions are transformed into local gotos, and never
+ -- propagated (No_Exception_Propagation).
+
+ if No_Exception_Handlers_Set then
return;
end if;
if Present (Block) then
- New_Scope (Block);
+ Push_Scope (Block);
end if;
Ohandle :=
Stmnts := New_List (
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Clean, Loc)),
- Make_Raise_Statement (Loc));
+ Name => New_Occurrence_Of (Clean, Loc)));
+
+ -- Generate reraise statement as last statement of AT-END handler,
+ -- unless we are under control of No_Exception_Propagation, in which
+ -- case no exception propagation is possible anyway, so we do not need
+ -- a reraise (the AT END handler in this case is only for normal exits
+ -- not for exceptional exits). Also, we flag the Reraise statement as
+ -- being part of an AT END handler to prevent signalling this reraise
+ -- as a violation of the restriction when it is not set.
+
+ if not Restriction_Active (No_Exception_Propagation) then
+ declare
+ Rstm : constant Node_Id := Make_Raise_Statement (Loc);
+ begin
+ Set_From_At_End (Rstm);
+ Append_To (Stmnts, Rstm);
+ end;
+ end if;
Set_Exception_Handlers (HSS, New_List (
Make_Implicit_Exception_Handler (Loc,
-- There are two cases for this transformation. First the case of
-- explicit raise statements. For this case, the transformation we do
- -- looks like this. Right now we have for example (where L1,L2 are
+ -- looks like this. Right now we have for example (where L1, L2 are
-- exception labels)
-- begin
-- This gets transformed into:
-- begin
- -- L1 : label;
- -- L2 : label;
- -- L3 : label;
+ -- L1 : label; -- marked Exception_Junk
+ -- L2 : label; -- marked Exception_Junk
+ -- L3 : label; -- marked Exception_Junk
- -- begin
+ -- begin -- marked Exception_Junk
-- ...
- -- local_raise (excep1'Identity); -- was raise excep1
+ -- local_raise (excep1'address); -- was raise excep1
-- goto L1;
-- ...
- -- local_raise (excep2'Identity); -- was raise excep2
+ -- local_raise (excep2'address); -- was raise excep2
-- goto L2;
-- ...
-- exception
-- goto L2;
-- end;
- -- goto L3; -- skip handler when exception not raised
+ -- goto L3; -- skip handler if no raise, marked Exception_Junk
- -- <<L1>> -- target label for local exception
- -- estmts1
- -- goto L3;
+ -- <<L1>> -- local excep target label, marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts1
+ -- end;
+ -- goto L3; -- marked Exception_Junk
- -- <<L2>>
- -- estmts2
- -- goto L3;
- -- <<L3>>
+ -- <<L2>> -- marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts2
+ -- end;
+ -- goto L3; -- marked Exception_Junk
+ -- <<L3>> -- marked Exception_Junk
-- end;
-- Note: the reason we wrap the original statement sequence in an
-- must not reenter the same exception handlers.
-- If the restriction No_Exception_Propagation is in effect, then we
- -- can omit the exception handlers, and we do not need the inner block.
+ -- can omit the exception handlers.
-- begin
- -- L1 : label;
- -- L2 : label;
- -- L3 : label;
+ -- L1 : label; -- marked Exception_Junk
+ -- L2 : label; -- marked Exception_Junk
+ -- L3 : label; -- marked Exception_Junk
- -- ...
- -- local_raise (excep1'Identity); -- was raise excep1
- -- goto L1;
- -- ...
- -- local_raise (excep2'Identity); -- was raise excep2
- -- goto L2;
- -- ...
+ -- begin -- marked Exception_Junk
+ -- ...
+ -- local_raise (excep1'address); -- was raise excep1
+ -- goto L1;
+ -- ...
+ -- local_raise (excep2'address); -- was raise excep2
+ -- goto L2;
+ -- ...
+ -- end;
- -- goto L3; -- skip handler when exception not raised
+ -- goto L3; -- skip handler if no raise, marked Exception_Junk
- -- <<L1>> -- target label for local exception
- -- estmts1
- -- goto L3;
+ -- <<L1>> -- local excep target label, marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts1
+ -- end;
+ -- goto L3; -- marked Exception_Junk
- -- <<L2>>
- -- estmts2
- -- goto L3;
- -- <<L3>>
+ -- <<L2>> -- marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts2
+ -- end;
+
+ -- <<L3>> -- marked Exception_Junk
-- end;
-- The second case is for exceptions generated by the back end in one
-- raise, then the front end does the expansion described previously,
-- creating a label to be used as a goto target to raise the exception.
-- However, no attempt is made in the front end to convert any related
- -- raise statements into gotos, e.g. all Raise_xxx_Error nodes are left
- -- unchanged and passed to the back end.
+ -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
+ -- left unchanged and passed to the back end.
-- Instead, the front end generates two nodes
-- of code, no optimization is possible.
-- The back end must maintain three stacks, one for each exception case,
- -- the Push node pushes an entry onto the corresponding stack, and pop
+ -- the Push node pushes an entry onto the corresponding stack, and Pop
-- node pops off the entry. Then instead of calling Rcheck_nn, if the
-- corresponding top stack entry has an non-empty label, a goto is
- -- generated instead of the call. This goto should be preceded by a
- -- call to Local_Raise as described above.
+ -- generated. This goto should be preceded by a call to Local_Raise as
+ -- described above.
-- An example of this transformation is as follows, given:
-- L2 : label;
-- begin
- -- %push_constraint_error_label (L1)
- -- R1b : constant long_long_integer := long_long_integer?(b) +
- -- long_long_integer?(c);
- -- [constraint_error when
- -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
- -- "overflow check failed"]
+ -- %push_constraint_error_label (L1)
+ -- R1b : constant long_long_integer := long_long_integer?(b) +
+ -- long_long_integer?(c);
+ -- [constraint_error when
+ -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
+ -- "overflow check failed"]
-- a := integer?(R1b);
-- %pop_constraint_error_Label
-- <<L2>>
-- end;
+ -- Note: the generated labels and goto statements all have the flag
+ -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
+ -- this generated exception stuff when checking for missing return
+ -- statements (see circuitry in Check_Statement_Sequence).
+
+ -- Note: All of the processing described above occurs only if
+ -- restriction No_Exception_Propagation applies or debug flag .g is
+ -- enabled.
+
CE_Locally_Handled : Boolean := False;
SE_Locally_Handled : Boolean := False;
PE_Locally_Handled : Boolean := False;
procedure Add_Exception_Label (H : Node_Id);
-- H is an exception handler. First check for an Exception_Label
- -- already allocated for H. If not, allocate one, set the field in
+ -- already allocated for H. If none, allocate one, set the field in
-- the handler node, add the label declaration, and set the flag
- -- Local_Expansion_Required. Note: if Local_Handlers_Not_OK is set
+ -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
-- the call has no effect and Exception_Label is left empty.
procedure Add_Label_Declaration (L : Entity_Id);
begin
if No (Exception_Label (H))
and then not Local_Raise_Not_OK (H)
+ and then not Special_Exception_Package_Used
then
Local_Expansion_Required := True;
declare
- L : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (H),
- Chars => New_Internal_Name ('L'));
+ L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
begin
Set_Exception_Label (H, L);
Add_Label_Declaration (L);
Pop : constant Node_Id := Make_Pop_Label (Sloc (L));
begin
- Set_Exception_Label (Push, Exception_Label (H));
+ -- We make sure that a call to Get_Local_Raise_Call_Entity is
+ -- made during front end processing, so that when we need it
+ -- in the back end, it will already be available and loaded.
+ Discard_Node (Get_Local_Raise_Call_Entity);
+
+ -- Prepare and insert Push and Pop nodes
+
+ Set_Exception_Label (Push, Exception_Label (H));
Insert_Before (F, Push);
Set_Analyzed (Push);
-- Local declarations
Loc : constant Source_Ptr := Sloc (HSS);
- Stmts : List_Id;
+ Stmts : List_Id := No_List;
Choice : Node_Id;
+ Excep : Entity_Id;
procedure Generate_Push_Pop_For_Constraint_Error is
new Generate_Push_Pop
-- not already done), and generate Push/Pop nodes for the exception
-- label at the start and end of the statements of HSS.
+ -- Start of processing for Expand_Local_Exception_Handlers
+
begin
- -- See if we have any potential local raises to expand
+ -- No processing if all exception handlers will get removed
+
+ if Debug_Flag_Dot_X then
+ return;
+ end if;
+
+ -- See for each handler if we have any local raises to expand
Handler := First_Non_Pragma (Handlrs);
while Present (Handler) loop
-- If we are doing local raise to goto optimization (restriction
-- No_Exception_Propagation set or debug flag .g set), then check
- -- to see if handler handles CE,PE,SE and if so generate the
- -- appropriate push/pop sequences for the back end
+ -- to see if handler handles CE, PE, SE and if so generate the
+ -- appropriate push/pop sequence for the back end.
- if Debug_Flag_Dot_G
- or else Restriction_Active (No_Exception_Propagation)
+ if (Debug_Flag_Dot_G
+ or else Restriction_Active (No_Exception_Propagation))
+ and then Has_Local_Raise (Handler)
then
Choice := First (Exception_Choices (Handler));
while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
+ if Nkind (Choice) = N_Others_Choice
+ and then not All_Others (Choice)
+ then
Generate_Push_Pop_For_Constraint_Error (Handler);
Generate_Push_Pop_For_Program_Error (Handler);
Generate_Push_Pop_For_Storage_Error (Handler);
elsif Is_Entity_Name (Choice) then
- if Entity (Choice) = Standard_Constraint_Error then
+ Excep := Get_Renamed_Entity (Entity (Choice));
+
+ if Excep = Standard_Constraint_Error then
Generate_Push_Pop_For_Constraint_Error (Handler);
- elsif Entity (Choice) = Standard_Program_Error then
- Generate_Push_Pop_For_Program_Error (Handler);
- elsif Entity (Choice) = Standard_Storage_Error then
- Generate_Push_Pop_For_Storage_Error (Handler);
+ elsif Excep = Standard_Program_Error then
+ Generate_Push_Pop_For_Program_Error (Handler);
+ elsif Excep = Standard_Storage_Error then
+ Generate_Push_Pop_For_Storage_Error (Handler);
end if;
end if;
-- Prepare to do the transformation
declare
- L3_Dent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ -- L3 is the label to exit the HSS
+
+ L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
Labl_L3 : constant Node_Id :=
Make_Label (Loc,
Identifier => New_Occurrence_Of (L3_Dent, Loc));
- Old_HSS : Node_Id;
Blk_Stm : Node_Id;
Relmt : Elmt_Id;
begin
+ Set_Exception_Junk (Labl_L3);
Add_Label_Declaration (L3_Dent);
- -- If the No_Exception_Propagation restriction is not active,
- -- then we must wrap the existing statements and exception
- -- handlers in an inner block.
-
- if not Restriction_Active (No_Exception_Propagation) then
- Old_HSS := Relocate_Node (HSS);
-
- -- Construct and analyze the block with a dummy HSS inside it
- -- for now (if we do the analyze call with the real HSS in
- -- place we have nasty recursion problems).
+ -- Wrap existing statements and handlers in an inner block
- Blk_Stm :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Empty_List));
+ Blk_Stm :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => Relocate_Node (HSS));
+ Set_Exception_Junk (Blk_Stm);
- Rewrite (HSS,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Blk_Stm)));
- Analyze (HSS);
+ Rewrite (HSS,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Blk_Stm),
+ End_Label => Relocate_Node (End_Label (HSS))));
- -- Now we can set the real statement sequence in place
+ -- Set block statement as analyzed, we don't want to actually call
+ -- Analyze on this block, it would cause a recursion in exception
+ -- handler processing which would mess things up.
- Set_Handled_Statement_Sequence (Blk_Stm, Old_HSS);
- end if;
+ Set_Analyzed (Blk_Stm);
-- Now loop through the exception handlers to deal with those that
-- are targets of local raise statements.
declare
Loc : constant Source_Ptr := Sloc (Handler);
+ -- L1 is the start label for this handler
+
L1_Dent : constant Entity_Id := Exception_Label (Handler);
Labl_L1 : constant Node_Id :=
Identifier =>
New_Occurrence_Of (L1_Dent, Loc));
+ -- Jump to L1 to be used as replacement for the original
+ -- handler (used in the case where exception propagation
+ -- may still occur).
+
Name_L1 : constant Node_Id :=
New_Occurrence_Of (L1_Dent, Loc);
Make_Goto_Statement (Loc,
Name => Name_L1);
+ -- Jump to L3 to be used at the end of handler
+
Name_L3 : constant Node_Id :=
New_Occurrence_Of (L3_Dent, Loc);
H_Stmts : constant List_Id := Statements (Handler);
begin
+ Set_Exception_Junk (Labl_L1);
+ Set_Exception_Junk (Goto_L3);
+
+ -- Note: we do NOT set Exception_Junk in Goto_L1, since
+ -- this is a real transfer of control that we want the
+ -- Sem_Ch6.Check_Returns procedure to recognize properly.
+
-- Replace handler by a goto L1. We can mark this as
-- analyzed since it is fully formed, and we don't
- -- want it going through any further checks.
+ -- want it going through any further checks. We save
+ -- the last statement location in the goto L1 node for
+ -- the benefit of Sem_Ch6.Check_Returns.
Set_Statements (Handler, New_List (Goto_L1));
Set_Analyzed (Goto_L1);
Relmt := First_Elmt (Local_Raise_Statements (Handler));
while Present (Relmt) loop
declare
- Raise_S : constant Node_Id := Node (Relmt);
-
+ Raise_S : constant Node_Id := Node (Relmt);
+ RLoc : constant Source_Ptr := Sloc (Raise_S);
Name_L1 : constant Node_Id :=
New_Occurrence_Of (L1_Dent, Loc);
-
Goto_L1 : constant Node_Id :=
- Make_Goto_Statement (Loc,
+ Make_Goto_Statement (RLoc,
Name => Name_L1);
begin
end loop;
end if;
- -- Add goto L3 at end of statement list in block. The
+ -- Add a goto L3 at end of statement list in block. The
-- first time, this is what skips over the exception
-- handlers in the normal case. Subsequent times, it
- -- terminates the execution of the handler code, and
- -- skips subsequent handlers.
+ -- terminates the execution of the previous handler code,
+ -- and skips subsequent handlers.
Stmts := Statements (HSS);
Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
Insert_After_And_Analyze (Last (Stmts), Labl_L1);
- Insert_List_After (Last (Stmts), H_Stmts);
+
+ declare
+ Loc : constant Source_Ptr := Sloc (First (H_Stmts));
+ Blk : constant Node_Id :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => H_Stmts));
+ begin
+ Set_Exception_Junk (Blk);
+ Insert_After_And_Analyze (Last (Stmts), Blk);
+ end;
end;
-- Here if we have local raise statements but the handler is
-- not suitable for processing with a local raise. In this
- -- case we have to delete the Local_Raise call and also
- -- generate possible diagnostics.
+ -- case we have to generate possible diagnostics.
- else
+ elsif Has_Local_Raise (Handler)
+ and then Local_Raise_Statements (Handler) /= No_Elist
+ then
Relmt := First_Elmt (Local_Raise_Statements (Handler));
while Present (Relmt) loop
Warn_If_No_Propagation (Node (Relmt));
- Remove (Prev (Node (Relmt)));
Next_Elmt (Relmt);
end loop;
end if;
-- Only remaining step is to drop the L3 label and we are done
Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
- Insert_After_And_Analyze (Last (Stmts), Labl_L3);
+
+ -- If we had at least one handler, then we drop the label after
+ -- the last statement of that handler.
+
+ if Stmts /= No_List then
+ Insert_After_And_Analyze (Last (Stmts), Labl_L3);
+
+ -- Otherwise we have removed all the handlers (this results from
+ -- use of pragma Restrictions (No_Exception_Propagation), and we
+ -- drop the label at the end of the statements of the HSS.
+
+ else
+ Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
+ end if;
+
return;
end;
end Expand_Local_Exception_Handlers;
Ent : constant Entity_Id := RTE (Proc);
begin
- -- If we have no Entity, then we are probably in no run time mode
- -- or some weird error has occured. In either case do do nothing!
+ -- If we have no Entity, then we are probably in no run time mode or
+ -- some weird error has occurred. In either case do nothing. Note use
+ -- of No_Location to hide this code from the debugger, so single
+ -- stepping doesn't jump back and forth.
if Present (Ent) then
declare
Call : constant Node_Id :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (Proc), Loc),
+ Make_Procedure_Call_Statement (No_Location,
+ Name => New_Occurrence_Of (RTE (Proc), No_Location),
Parameter_Associations => Args);
begin
Excep := Standard_Program_Error;
Cond := Condition (Raise_S);
- -- The only other possibility is a node that is or used to be
- -- a simple raise statement.
+ -- The only other possibility is a node that is or used to be a
+ -- simple raise statement.
else
Orig := Original_Node (Raise_S);
end if;
-- Here Excep is the exception to raise, and Cond is the condition
- -- First prepare the call to Local_Raise (excep'Identity).
+ -- First prepare the call to Local_Raise (excep'address).
if RTE_Available (RE_Local_Raise) then
LR :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Excep, Loc),
- Attribute_Name => Name_Identity)));
+ Unchecked_Convert_To (RTE (RE_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Excep, Loc),
+ Attribute_Name => Name_Identity))));
-- Use null statement if Local_Raise not available
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (LR, Goto_L1))));
+ Set_Exception_Junk (Raise_S);
-- If there is a condition, we rewrite as
Handler := First_Non_Pragma (Handlrs);
Handler_Loop : while Present (Handler) loop
+ Process_Statements_For_Controlled_Objects (Handler);
+
Next_Handler := Next_Non_Pragma (Handler);
- -- Remove source handler if gnat debug flag N is set
+ -- Remove source handler if gnat debug flag .x is set
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
Remove (Handler);
-- Remove handler if no exception propagation, generating a warning
-- if a source generated handler was not the target of a local raise.
- elsif Restriction_Active (No_Exception_Propagation) then
- if No (Local_Raise_Statements (Handler))
+ else
+ if Restriction_Active (No_Exception_Propagation)
+ and then not Has_Local_Raise (Handler)
and then Comes_From_Source (Handler)
and then Warn_On_Non_Local_Exception
then
- Error_Msg_N
- ("?pragma Restrictions (No_Exception_Propagation) in effect",
- Handler);
+ Warn_No_Exception_Propagation_Active (Handler);
Error_Msg_N
("\?this handler can never be entered, and has been removed",
Handler);
end if;
- Remove (Handler);
-
- -- Exception handler is active and retained and must be processed
-
- else
- -- If an exception occurrence is present, then we must declare it
- -- and initialize it from the value stored in the TSD
+ if No_Exception_Propagation_Active then
+ Remove (Handler);
- -- declare
- -- name : Exception_Occurrence;
- -- begin
- -- Save_Occurrence (name, Get_Current_Excep.all)
- -- ...
- -- end;
+ -- Exception handler is active and retained and must be processed
- if Present (Choice_Parameter (Handler)) then
- declare
- Cparm : constant Entity_Id := Choice_Parameter (Handler);
- Clc : constant Source_Ptr := Sloc (Cparm);
- Save : Node_Id;
-
- begin
- Save :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Cparm, Clc),
- Make_Explicit_Dereference (Loc,
- Make_Function_Call (Loc,
- Name => Make_Explicit_Dereference (Loc,
- New_Occurrence_Of
- (RTE (RE_Get_Current_Excep), Loc))))));
-
- Mark_Rewrite_Insertion (Save);
- Prepend (Save, Statements (Handler));
-
- Obj_Decl :=
- Make_Object_Declaration
- (Clc,
- Defining_Identifier => Cparm,
- Object_Definition =>
- New_Occurrence_Of
- (RTE (RE_Exception_Occurrence), Clc));
- Set_No_Initialization (Obj_Decl, True);
-
- Rewrite (Handler,
- Make_Implicit_Exception_Handler (Loc,
- Exception_Choices => Exception_Choices (Handler),
-
- Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => New_List (Obj_Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements (Handler))))));
-
- Analyze_List (Statements (Handler), Suppress => All_Checks);
- end;
- end if;
-
- -- The processing at this point is rather different for the JVM
- -- case, so we completely separate the processing.
-
- -- For the JVM case, we unconditionally call Update_Exception,
- -- passing a call to the intrinsic Current_Target_Exception (see
- -- JVM version of Ada.Exceptions in 4jexcept.adb for details).
+ else
+ -- If an exception occurrence is present, then we must declare
+ -- it and initialize it from the value stored in the TSD
- if Hostparm.Java_VM then
- declare
- Arg : constant Node_Id :=
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Current_Target_Exception), Loc));
- begin
- Prepend_Call_To_Handler
- (RE_Update_Exception, New_List (Arg));
- end;
+ -- declare
+ -- name : Exception_Occurrence;
+ -- begin
+ -- Save_Occurrence (name, Get_Current_Excep.all)
+ -- ...
+ -- end;
- -- For the normal case, we have to worry about the state of
- -- abort deferral. Generally, we defer abort during runtime
- -- handling of exceptions. When control is passed to the
- -- handler, then in the normal case we undefer aborts. In any
- -- case this entire handling is relevant only if aborts are
- -- allowed!
+ if Present (Choice_Parameter (Handler)) then
+ declare
+ Cparm : constant Entity_Id := Choice_Parameter (Handler);
+ Cloc : constant Source_Ptr := Sloc (Cparm);
+ Hloc : constant Source_Ptr := Sloc (Handler);
+ Save : Node_Id;
- elsif Abort_Allowed then
+ begin
+ -- Note use of No_Location to hide this code from the
+ -- debugger, so single stepping doesn't jump back and
+ -- forth.
+
+ Save :=
+ Make_Procedure_Call_Statement (No_Location,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Save_Occurrence),
+ No_Location),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Cparm, Cloc),
+ Make_Explicit_Dereference (No_Location,
+ Make_Function_Call (No_Location,
+ Name => Make_Explicit_Dereference (No_Location,
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ No_Location))))));
+
+ Mark_Rewrite_Insertion (Save);
+ Prepend (Save, Statements (Handler));
+
+ Obj_Decl :=
+ Make_Object_Declaration
+ (Cloc,
+ Defining_Identifier => Cparm,
+ Object_Definition =>
+ New_Occurrence_Of
+ (RTE (RE_Exception_Occurrence), Cloc));
+ Set_No_Initialization (Obj_Decl, True);
+
+ Rewrite (Handler,
+ Make_Exception_Handler (Hloc,
+ Choice_Parameter => Empty,
+ Exception_Choices => Exception_Choices (Handler),
+
+ Statements => New_List (
+ Make_Block_Statement (Hloc,
+ Declarations => New_List (Obj_Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Hloc,
+ Statements => Statements (Handler))))));
+
+ -- Local raise statements can't occur, since exception
+ -- handlers with choice parameters are not allowed when
+ -- No_Exception_Propagation applies, so set attributes
+ -- accordingly.
+
+ Set_Local_Raise_Statements (Handler, No_Elist);
+ Set_Local_Raise_Not_OK (Handler);
+
+ Analyze_List
+ (Statements (Handler), Suppress => All_Checks);
+ end;
+ end if;
- -- There are some special cases in which we do not do the
- -- undefer. In particular a finalization (AT END) handler
- -- wants to operate with aborts still deferred.
+ -- The processing at this point is rather different for the JVM
+ -- case, so we completely separate the processing.
- -- We also suppress the call if this is the special handler
- -- for Abort_Signal, since if we are aborting, we want to keep
- -- aborts deferred (one abort is enough thank you very much :-)
+ -- For the VM case, we unconditionally call Update_Exception,
+ -- passing a call to the intrinsic Current_Target_Exception
+ -- (see JVM/.NET versions of Ada.Exceptions for details).
- -- If abort really needs to be deferred the expander must add
- -- this call explicitly, see Expand_N_Asynchronous_Select.
+ if VM_Target /= No_VM then
+ declare
+ Arg : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Current_Target_Exception), Loc));
+ begin
+ Prepend_Call_To_Handler
+ (RE_Update_Exception, New_List (Arg));
+ end;
- Others_Choice :=
- Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
+ -- For the normal case, we have to worry about the state of
+ -- abort deferral. Generally, we defer abort during runtime
+ -- handling of exceptions. When control is passed to the
+ -- handler, then in the normal case we undefer aborts. In
+ -- any case this entire handling is relevant only if aborts
+ -- are allowed!
- if (Others_Choice
- or else Entity (First (Exception_Choices (Handler))) /=
- Stand.Abort_Signal)
- and then not
- (Others_Choice
- and then All_Others (First (Exception_Choices (Handler))))
- and then Abort_Allowed
+ elsif Abort_Allowed
+ and then Exception_Mechanism /= Back_End_Exceptions
then
- Prepend_Call_To_Handler (RE_Abort_Undefer);
+ -- There are some special cases in which we do not do the
+ -- undefer. In particular a finalization (AT END) handler
+ -- wants to operate with aborts still deferred.
+
+ -- We also suppress the call if this is the special handler
+ -- for Abort_Signal, since if we are aborting, we want to
+ -- keep aborts deferred (one abort is enough).
+
+ -- If abort really needs to be deferred the expander must
+ -- add this call explicitly, see
+ -- Expand_N_Asynchronous_Select.
+
+ Others_Choice :=
+ Nkind (First (Exception_Choices (Handler))) =
+ N_Others_Choice;
+
+ if (Others_Choice
+ or else Entity (First (Exception_Choices (Handler))) /=
+ Stand.Abort_Signal)
+ and then not
+ (Others_Choice
+ and then
+ All_Others (First (Exception_Choices (Handler))))
+ then
+ Prepend_Call_To_Handler (RE_Abort_Undefer);
+ end if;
end if;
end if;
end if;
Handler := Next_Handler;
end loop Handler_Loop;
- -- If all handlers got removed, then remove the list
+ -- If all handlers got removed, then remove the list. Note we cannot
+ -- reference HSS here, since expanding local handlers may have buried
+ -- the handlers in an inner block.
- if Is_Empty_List (Exception_Handlers (HSS)) then
- Set_Exception_Handlers (HSS, No_List);
+ if Is_Empty_List (Handlrs) then
+ Set_Exception_Handlers (Parent (Handlrs), No_List);
end if;
end Expand_Exception_Handlers;
Exname : constant Node_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
+ procedure Force_Static_Allocation_Of_Referenced_Objects
+ (Aggregate : Node_Id);
+ -- A specialized solution to one particular case of an ugly problem
+ --
+ -- The given aggregate includes an Unchecked_Conversion as one of the
+ -- component values. The call to Analyze_And_Resolve below ends up
+ -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
+ -- to introduce a (constant) temporary and then obtain the component
+ -- value by evaluating the temporary.
+ --
+ -- In the case of an exception declared within a subprogram (or any
+ -- other dynamic scope), this is a bad transformation. The exception
+ -- object is marked as being Statically_Allocated but the temporary is
+ -- not. If the initial value of a Statically_Allocated declaration
+ -- references a dynamically allocated object, this prevents static
+ -- initialization of the object.
+ --
+ -- We cope with this here by marking the temporary Statically_Allocated.
+ -- It might seem cleaner to generalize this utility and then use it to
+ -- enforce a rule that the entities referenced in the declaration of any
+ -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
+ -- entity must also be either Library_Level or hoisted. It turns out
+ -- that this would be incompatible with the current treatment of an
+ -- object which is local to a subprogram, subject to an Export pragma,
+ -- not subject to an address clause, and whose declaration contains
+ -- references to other local (non-hoisted) objects (e.g., in the initial
+ -- value expression).
+
+ ---------------------------------------------------
+ -- Force_Static_Allocation_Of_Referenced_Objects --
+ ---------------------------------------------------
+
+ procedure Force_Static_Allocation_Of_Referenced_Objects
+ (Aggregate : Node_Id)
+ is
+ function Fixup_Node (N : Node_Id) return Traverse_Result;
+ -- If the given node references a dynamically allocated object, then
+ -- correct the declaration of the object.
+
+ ----------------
+ -- Fixup_Node --
+ ----------------
+
+ function Fixup_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Has_Entity
+ and then Present (Entity (N))
+ and then not Is_Library_Level_Entity (Entity (N))
+
+ -- Note: the following test is not needed but it seems cleaner
+ -- to do this test (this would be more important if procedure
+ -- Force_Static_Allocation_Of_Referenced_Objects recursively
+ -- traversed the declaration of an entity after marking it as
+ -- statically allocated).
+
+ and then not Is_Statically_Allocated (Entity (N))
+ then
+ Set_Is_Statically_Allocated (Entity (N));
+ end if;
+
+ return OK;
+ end Fixup_Node;
+
+ procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
+
+ -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
+
+ begin
+ Fixup_Tree (Aggregate);
+ end Force_Static_Allocation_Of_Referenced_Objects;
+
+ -- Start of processing for Expand_N_Exception_Declaration
+
begin
-- There is no expansion needed when compiling for the JVM since the
- -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
+ -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
+ -- for details.
- if Hostparm.Java_VM then
+ if VM_Target /= No_VM then
return;
end if;
Defining_Identifier => Exname,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
+ Expression =>
+ Make_String_Literal (Loc,
+ Strval => Fully_Qualified_Name_String (Id))));
Set_Is_Statically_Allocated (Exname);
Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
Analyze_And_Resolve (Expression (N), Etype (Id));
+ Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
+
-- Register_Exception (except'Unchecked_Access);
- if not Restriction_Active (No_Exception_Handlers)
+ if not No_Exception_Handlers_Set
and then not Restriction_Active (No_Exception_Registration)
then
L := New_List (
Insert_List_After_And_Analyze (N, L);
end if;
end if;
-
end Expand_N_Exception_Declaration;
---------------------------------------------
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
begin
+ -- Expand exception handlers
+
if Present (Exception_Handlers (N))
and then not Restriction_Active (No_Exception_Handlers)
then
Expand_Exception_Handlers (N);
end if;
- -- The following code needs comments ???
+ -- If local exceptions are being expanded, the previous call will
+ -- have rewritten the construct as a block and reanalyzed it. No
+ -- further expansion is needed.
+
+ if Analyzed (N) then
+ return;
+ end if;
+
+ -- Add clean up actions if required
if Nkind (Parent (N)) /= N_Package_Body
and then Nkind (Parent (N)) /= N_Accept_Statement
-- what strange optimization in future may require this adjustment!
Adjust_Condition (Condition (N));
+
+ -- Now deal with possible local raise handling
+
+ Possible_Local_Raise (N, Standard_Constraint_Error);
end Expand_N_Raise_Constraint_Error;
----------------------------------
-- what strange optimization in future may require this adjustment!
Adjust_Condition (Condition (N));
+
+ -- Now deal with possible local raise handling
+
+ Possible_Local_Raise (N, Standard_Program_Error);
end Expand_N_Raise_Program_Error;
------------------------------
E : Entity_Id;
Str : String_Id;
H : Node_Id;
+ Src : Boolean;
begin
- -- Debug_Flag_Dot_G := True;
-
-- Processing for locally handled exception (exclude reraise case)
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
-- is analyzed twice and would otherwise be added twice.
Append_Unique_Elmt (N, Local_Raise_Statements (H));
+ Set_Has_Local_Raise (H);
+
+ -- If no local handler, then generate no propagation warning
+
+ else
+ Warn_If_No_Propagation (N);
end if;
- else
- Warn_If_No_Propagation (N);
end if;
end if;
-- If a string expression is present, then the raise statement is
-- converted to a call:
-
-- Raise_Exception (exception-name'Identity, string);
-
- -- and there is nothing else to do
+ -- and there is nothing else to do.
if Present (Expression (N)) then
- Rewrite (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Name (N),
- Attribute_Name => Name_Identity),
- Expression (N))));
- Analyze (N);
- return;
- end if;
- -- Remaining processing is for the case where no string expression
- -- is present.
+ -- Avoid passing exception-name'identity in runtimes in which this
+ -- argument is not used. This avoids generating undefined references
+ -- to these exceptions when compiling with no optimization
- -- There is no expansion needed for statement "raise <exception>;" when
- -- compiling for the JVM since the JVM has a built-in exception
- -- mechanism. However we need to keep the expansion for "raise;"
- -- statements. See 4jexcept.ads for details.
+ if Configurable_Run_Time_On_Target
+ and then (Restriction_Active (No_Exception_Handlers)
+ or else
+ Restriction_Active (No_Exception_Propagation))
+ then
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (RTE (RE_Null_Id), Loc),
+ Expression (N))));
+ else
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Name (N),
+ Attribute_Name => Name_Identity),
+ Expression (N))));
+ end if;
- if Present (Name (N)) and then Hostparm.Java_VM then
+ Analyze (N);
return;
end if;
- -- Don't expand a raise statement that does not come from source
- -- if we have already had configurable run-time violations, since
- -- most likely it will be junk cascaded nonsense.
+ -- Remaining processing is for the case where no string expression is
+ -- present.
+
+ -- Don't expand a raise statement that does not come from source if we
+ -- have already had configurable run-time violations, since most likely
+ -- it will be junk cascaded nonsense.
if Configurable_Run_Time_Violations > 0
and then not Comes_From_Source (N)
-- Convert explicit raise of Program_Error, Constraint_Error, and
-- Storage_Error into the corresponding raise (in High_Integrity_Mode
-- all other raises will get normal expansion and be disallowed,
- -- but this is also faster in all modes).
+ -- but this is also faster in all modes). Propagate Comes_From_Source
+ -- flag to the new node.
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
+ Src := Comes_From_Source (N);
+
if Entity (Name (N)) = Standard_Constraint_Error then
Rewrite (N,
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Explicit_Raise));
+ Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Program_Error then
Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Explicit_Raise));
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Storage_Error then
Rewrite (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Explicit_Raise));
+ Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
end if;
Id : Entity_Id := Entity (Name (N));
begin
+ Name_Len := 0;
Build_Location_String (Loc);
-- If the exception is a renaming, use the exception that it
-- Build a C-compatible string in case of no exception handlers,
-- since this is what the last chance handler is expecting.
- if Restriction_Active (No_Exception_Handlers) then
+ if No_Exception_Handlers_Set then
-- Generate an empty message if configuration pragma
-- Suppress_Exception_Locations is set for this unit.
-- does not have a choice parameter specification, then we provide one.
else
+ -- Bypass expansion to a run-time call when back-end exception
+ -- handling is active, unless the target is a VM, CodePeer or
+ -- GNATprove. In CodePeer, raising an exception is treated as an
+ -- error, while in GNATprove all code with exceptions falls outside
+ -- the subset of code which can be formally analyzed.
+
+ if VM_Target = No_VM
+ and then not CodePeer_Mode
+ and then Exception_Mechanism = Back_End_Exceptions
+ then
+ return;
+ end if;
+
-- Find innermost enclosing exception handler (there must be one,
-- since the semantics has already verified that this raise statement
-- is valid, and a raise with no arguments is only permitted in the
-- be referencing this entity by normal visibility methods.
if No (Choice_Parameter (Ehand)) then
- E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ E := Make_Temporary (Loc, 'E');
Set_Choice_Parameter (Ehand, E);
Set_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
-- what strange optimization in future may require this adjustment!
Adjust_Condition (Condition (N));
+
+ -- Now deal with possible local raise handling
+
+ Possible_Local_Raise (N, Standard_Storage_Error);
end Expand_N_Raise_Storage_Error;
+ --------------------------
+ -- Possible_Local_Raise --
+ --------------------------
+
+ procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
+ begin
+ -- Nothing to do if local raise optimization not active
+
+ if not Debug_Flag_Dot_G
+ and then not Restriction_Active (No_Exception_Propagation)
+ then
+ return;
+ end if;
+
+ -- Nothing to do if original node was an explicit raise, because in
+ -- that case, we already generated the required warning for the raise.
+
+ if Nkind (Original_Node (N)) = N_Raise_Statement then
+ return;
+ end if;
+
+ -- Otherwise see if we have a local handler for the exception
+
+ declare
+ H : constant Node_Id := Find_Local_Handler (E, N);
+
+ begin
+ -- If so, mark that it has a local raise
+
+ if Present (H) then
+ Set_Has_Local_Raise (H, True);
+
+ -- Otherwise, if the No_Exception_Propagation restriction is active
+ -- and the warning is enabled, generate the appropriate warnings.
+
+ elsif Warn_On_Non_Local_Exception
+ and then Restriction_Active (No_Exception_Propagation)
+ then
+ Warn_No_Exception_Propagation_Active (N);
+
+ if Configurable_Run_Time_Mode then
+ Error_Msg_NE
+ ("\?& may call Last_Chance_Handler", N, E);
+ else
+ Error_Msg_NE
+ ("\?& may result in unhandled exception", N, E);
+ end if;
+ end if;
+ end;
+ end Possible_Local_Raise;
+
------------------------------
-- Expand_N_Subprogram_Info --
------------------------------
H : Node_Id;
C : Node_Id;
+ SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ -- This is used to test for wrapped actions below
+
ERaise : Entity_Id;
EHandle : Entity_Id;
-- The entity Id's for the exception we are raising and handling, using
-- the renamed exception if a Renamed_Entity is present.
begin
+ -- Never any local handler if all handlers removed
+
+ if Debug_Flag_Dot_X then
+ return Empty;
+ end if;
+
-- Get the exception we are raising, allowing for renaming
- ERaise := Ename;
- while Present (Renamed_Entity (ERaise)) loop
- ERaise := Renamed_Entity (ERaise);
- end loop;
+ ERaise := Get_Renamed_Entity (Ename);
+
+ -- We need to check if the node we are looking at is contained in
+ --
-- Loop to search up the tree
P := Parent (N);
-- If we get to the top of the tree, or to a subprogram, task, entry,
- -- or protected body without having found a matching handler, then
- -- there is no local handler.
+ -- protected body, or accept statement without having found a
+ -- matching handler, then there is no local handler.
if No (P)
or else Nkind (P) = N_Subprogram_Body
or else Nkind (P) = N_Task_Body
or else Nkind (P) = N_Protected_Body
or else Nkind (P) = N_Entry_Body
+ or else Nkind (P) = N_Accept_Statement
then
return Empty;
- -- Test for handled sequence of statements, where we are in the
- -- statement section (the exception handlers of a handled sequence
- -- of statements do not cover themselves!)
+ -- Test for handled sequence of statements with at least one
+ -- exception handler which might be the one we are looking for.
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
- and then Is_List_Member (N)
- and then List_Containing (N) = Statements (P)
+ and then Present (Exception_Handlers (P))
then
- -- If we have exception handlers, look at them
-
- if Present (Exception_Handlers (P)) then
-
+ -- Before we proceed we need to check if the node N is covered
+ -- by the statement part of P rather than one of its exception
+ -- handlers (an exception handler obviously does not cover its
+ -- own statements).
+
+ -- This test is more delicate than might be thought. It is not
+ -- just a matter of checking the Statements (P), because the node
+ -- might be waiting to be wrapped in a transient scope, in which
+ -- case it will end up in the block statements, even though it
+ -- is not there now.
+
+ if Is_List_Member (N)
+ and then (List_Containing (N) = Statements (P)
+ or else
+ List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
+ or else
+ List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
+ then
-- Loop through exception handlers
H := First (Exception_Handlers (P));
-- Get exception being handled, dealing with renaming
- EHandle := Entity (C);
- while Present (Renamed_Entity (EHandle)) loop
- EHandle := Renamed_Entity (EHandle);
- end loop;
+ EHandle := Get_Renamed_Entity (Entity (C));
-- If match, then check choice parameter
-- Get_Local_Raise_Call_Entity --
---------------------------------
+ -- Note: this is primary provided for use by the back end in generating
+ -- calls to Local_Raise. But it would be too late in the back end to call
+ -- RTE if this actually caused a load/analyze of the unit. So what we do
+ -- is to ensure there is a dummy call to this function during front end
+ -- processing so that the unit gets loaded then, and not later.
+
+ Local_Raise_Call_Entity : Entity_Id;
+ Local_Raise_Call_Entity_Set : Boolean := False;
+
function Get_Local_Raise_Call_Entity return Entity_Id is
begin
- if RTE_Available (RE_Local_Raise) then
- return RTE (RE_Local_Raise);
- else
- return Empty;
+ if not Local_Raise_Call_Entity_Set then
+ Local_Raise_Call_Entity_Set := True;
+
+ if RTE_Available (RE_Local_Raise) then
+ Local_Raise_Call_Entity := RTE (RE_Local_Raise);
+ else
+ Local_Raise_Call_Entity := Empty;
+ end if;
end if;
+
+ return Local_Raise_Call_Entity;
end Get_Local_Raise_Call_Entity;
-----------------------------
procedure Warn_If_No_Propagation (N : Node_Id) is
begin
- if Restriction_Active (No_Exception_Propagation)
+ if Restriction_Check_Required (No_Exception_Propagation)
and then Warn_On_Non_Local_Exception
then
- Error_Msg_N
- ("?No_Exception_Propagation restriction is active", N);
+ Warn_No_Exception_Propagation_Active (N);
if Configurable_Run_Time_Mode then
Error_Msg_N
- ("?Last_Chance_Handler will be called on exception", N);
+ ("\?Last_Chance_Handler will be called on exception", N);
else
Error_Msg_N
- ("?program may terminate with unhandled exception", N);
+ ("\?execution may raise unhandled exception", N);
end if;
end if;
end Warn_If_No_Propagation;
+ ------------------------------------------
+ -- Warn_No_Exception_Propagation_Active --
+ ------------------------------------------
+
+ procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
+ begin
+ Error_Msg_N
+ ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
+ end Warn_No_Exception_Propagation_Active;
+
end Exp_Ch11;
OSDN Git Service
