with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
package body Exp_Ch11 is
+ -----------------------
+ -- 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_If_No_Propagation (N : Node_Id);
+ -- Called for an exception raise that is not a local raise (and thus can
+ -- not be optimized to a goto. Issues warning if No_Exception_Propagation
+ -- restriction is set. N is the node for the raise or equivalent call.
+
---------------------------
-- Expand_At_End_Handler --
---------------------------
Make_Raise_Statement (Loc));
Set_Exception_Handlers (HSS, New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => Stmnts)));
-------------------------------
procedure Expand_Exception_Handlers (HSS : Node_Id) is
- Handlrs : constant List_Id := Exception_Handlers (HSS);
- Loc : Source_Ptr;
+ Handlrs : constant List_Id := Exception_Handlers (HSS);
+ Loc : constant Source_Ptr := Sloc (HSS);
Handler : Node_Id;
Others_Choice : Boolean;
Obj_Decl : Node_Id;
+ Next_Handler : Node_Id;
+
+ procedure Expand_Local_Exception_Handlers;
+ -- This procedure handles the expansion of exception handlers for the
+ -- optimization of local raise statements into goto statements.
procedure Prepend_Call_To_Handler
(Proc : RE_Id;
-- Routine to prepend a call to the procedure referenced by Proc at
-- the start of the handler code for the current Handler.
+ procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
+ -- Raise_S is a raise statement (possibly expanded, and possibly of the
+ -- form of a Raise_xxx_Error node with a condition. This procedure is
+ -- called to replace the raise action with the (already analyzed) goto
+ -- statement passed as Goto_L1. This procedure also takes care of the
+ -- requirement of inserting a Local_Raise call where possible.
+
+ -------------------------------------
+ -- Expand_Local_Exception_Handlers --
+ -------------------------------------
+
+ -- 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
+ -- exception labels)
+
+ -- begin
+ -- ...
+ -- raise_exception (excep1'identity); -- was raise excep1
+ -- ...
+ -- raise_exception (excep2'identity); -- was raise excep2
+ -- ...
+ -- exception
+ -- when excep1 =>
+ -- estmts1
+ -- when excep2 =>
+ -- estmts2
+ -- end;
+
+ -- This gets transformed into:
+
+ -- begin
+ -- L1 : label;
+ -- L2 : label;
+ -- L3 : label;
+
+ -- begin
+ -- ...
+ -- local_raise (excep1'Identity); -- was raise excep1
+ -- goto L1;
+ -- ...
+ -- local_raise (excep2'Identity); -- was raise excep2
+ -- goto L2;
+ -- ...
+ -- exception
+ -- when excep1 =>
+ -- goto L1;
+ -- when excep2 =>
+ -- goto L2;
+ -- end;
+
+ -- goto L3; -- skip handler when exception not raised
+
+ -- <<L1>> -- target label for local exception
+ -- estmts1
+ -- goto L3;
+
+ -- <<L2>>
+ -- estmts2
+ -- goto L3;
+ -- <<L3>>
+ -- end;
+
+ -- Note: the reason we wrap the original statement sequence in an
+ -- inner block is that there may be raise statements within the
+ -- sequence of statements in the handlers, and we must ensure that
+ -- these are properly handled, and in particular, such raise statements
+ -- 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.
+
+ -- begin
+ -- L1 : label;
+ -- L2 : label;
+ -- L3 : label;
+
+ -- ...
+ -- local_raise (excep1'Identity); -- was raise excep1
+ -- goto L1;
+ -- ...
+ -- local_raise (excep2'Identity); -- was raise excep2
+ -- goto L2;
+ -- ...
+
+ -- goto L3; -- skip handler when exception not raised
+
+ -- <<L1>> -- target label for local exception
+ -- estmts1
+ -- goto L3;
+
+ -- <<L2>>
+ -- estmts2
+ -- goto L3;
+ -- <<L3>>
+ -- end;
+
+ -- The second case is for exceptions generated by the back end in one
+ -- of three situations:
+
+ -- 1. Front end generates N_Raise_xxx_Error node
+ -- 2. Front end sets Do_xxx_Check flag in subexpression node
+ -- 3. Back end detects a situation where an exception is appropriate
+
+ -- In all these cases, the current processing in gigi is to generate a
+ -- call to the appropriate Rcheck_xx routine (where xx encodes both the
+ -- exception message and the exception to be raised, Constraint_Error,
+ -- Program_Error, or Storage_Error.
+
+ -- We could handle some subcases of 1 using the same front end expansion
+ -- into gotos, but even for case 1, we can't handle all cases, since
+ -- generating gotos in the middle of expressions is not possible (it's
+ -- possible at the gigi/gcc level, but not at the level of the GNAT
+ -- tree).
+
+ -- In any case, it seems easier to have a scheme which handles all three
+ -- cases in a uniform manner. So here is how we proceed in this case.
+
+ -- This procedure detects all handlers for these three exceptions,
+ -- Constraint_Error, Program_Error and Storage_Error (including WHEN
+ -- OTHERS handlers that cover one or more of these cases).
+
+ -- If the handler meets the requirements for being the target of a local
+ -- 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.
+
+ -- Instead, the front end generates two nodes
+
+ -- N_Push_Constraint_Error_Label
+ -- N_Push_Program_Error_Label
+ -- N_Push_Storage_Error_Label
+
+ -- The Push node is generated at the start of the statements
+ -- covered by the handler, and has as a parameter the label to be
+ -- used as the raise target.
+
+ -- N_Pop_Constraint_Error_Label
+ -- N_Pop_Program_Error_Label
+ -- N_Pop_Storage_Error_Label
+
+ -- The Pop node is generated at the end of the covered statements
+ -- and undoes the effect of the preceding corresponding Push node.
+
+ -- In the case where the handler does NOT meet the requirements, the
+ -- front end will still generate the Push and Pop nodes, but the label
+ -- field in the Push node will be empty signifying that for this region
+ -- 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
+ -- 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.
+
+ -- An example of this transformation is as follows, given:
+
+ -- declare
+ -- A : Integer range 1 .. 10;
+ -- begin
+ -- A := B + C;
+ -- exception
+ -- when Constraint_Error =>
+ -- estmts
+ -- end;
+
+ -- gets transformed to:
+
+ -- declare
+ -- A : Integer range 1 .. 10;
+
+ -- begin
+ -- L1 : label;
+ -- 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"]
+ -- a := integer?(R1b);
+ -- %pop_constraint_error_Label
+
+ -- exception
+ -- ...
+ -- when constraint_error =>
+ -- goto L1;
+ -- end;
+
+ -- goto L2; -- skip handler when exception not raised
+ -- <<L1>> -- target label for local exception
+ -- estmts
+ -- <<L2>>
+ -- end;
+
+ CE_Locally_Handled : Boolean := False;
+ SE_Locally_Handled : Boolean := False;
+ PE_Locally_Handled : Boolean := False;
+ -- These three flags indicate whether a handler for the corresponding
+ -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
+ -- is present. If so the switch is set to True, the Exception_Label
+ -- field of the corresponding handler is set, and appropriate Push
+ -- and Pop nodes are inserted into the code.
+
+ Local_Expansion_Required : Boolean := False;
+ -- Set True if we have at least one handler requiring local raise
+ -- expansion as described above.
+
+ procedure Expand_Local_Exception_Handlers is
+
+ 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
+ -- the handler node, add the label declaration, and set the flag
+ -- Local_Expansion_Required. Note: if Local_Handlers_Not_OK is set
+ -- the call has no effect and Exception_Label is left empty.
+
+ procedure Add_Label_Declaration (L : Entity_Id);
+ -- Add an implicit declaration of the given label to the declaration
+ -- list in the parent of the current sequence of handled statements.
+
+ generic
+ Exc_Locally_Handled : in out Boolean;
+ -- Flag indicating whether a local handler for this exception
+ -- has already been generated.
+
+ with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
+ -- Function to create a Push_xxx_Label node
+
+ with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
+ -- Function to create a Pop_xxx_Label node
+
+ procedure Generate_Push_Pop (H : Node_Id);
+ -- Common code for Generate_Push_Pop_xxx below, used to generate an
+ -- exception label and Push/Pop nodes for Constraint_Error,
+ -- Program_Error, or Storage_Error.
+
+ -------------------------
+ -- Add_Exception_Label --
+ -------------------------
+
+ procedure Add_Exception_Label (H : Node_Id) is
+ begin
+ if No (Exception_Label (H))
+ and then not Local_Raise_Not_OK (H)
+ then
+ Local_Expansion_Required := True;
+
+ declare
+ L : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (H),
+ Chars => New_Internal_Name ('L'));
+ begin
+ Set_Exception_Label (H, L);
+ Add_Label_Declaration (L);
+ end;
+ end if;
+ end Add_Exception_Label;
+
+ ---------------------------
+ -- Add_Label_Declaration --
+ ---------------------------
+
+ procedure Add_Label_Declaration (L : Entity_Id) is
+ P : constant Node_Id := Parent (HSS);
+
+ Decl_L : constant Node_Id :=
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => L);
+
+ begin
+ if Declarations (P) = No_List then
+ Set_Declarations (P, Empty_List);
+ end if;
+
+ Append (Decl_L, Declarations (P));
+ Analyze (Decl_L);
+ end Add_Label_Declaration;
+
+ -----------------------
+ -- Generate_Push_Pop --
+ -----------------------
+
+ procedure Generate_Push_Pop (H : Node_Id) is
+ begin
+ if Exc_Locally_Handled then
+ return;
+ else
+ Exc_Locally_Handled := True;
+ end if;
+
+ Add_Exception_Label (H);
+
+ declare
+ F : constant Node_Id := First (Statements (HSS));
+ L : constant Node_Id := Last (Statements (HSS));
+
+ Push : constant Node_Id := Make_Push_Label (Sloc (F));
+ Pop : constant Node_Id := Make_Pop_Label (Sloc (L));
+
+ begin
+ Set_Exception_Label (Push, Exception_Label (H));
+
+ Insert_Before (F, Push);
+ Set_Analyzed (Push);
+
+ Insert_After (L, Pop);
+ Set_Analyzed (Pop);
+ end;
+ end Generate_Push_Pop;
+
+ -- Local declarations
+
+ Loc : constant Source_Ptr := Sloc (HSS);
+ Stmts : List_Id;
+ Choice : Node_Id;
+
+ procedure Generate_Push_Pop_For_Constraint_Error is
+ new Generate_Push_Pop
+ (Exc_Locally_Handled => CE_Locally_Handled,
+ Make_Push_Label => Make_Push_Constraint_Error_Label,
+ Make_Pop_Label => Make_Pop_Constraint_Error_Label);
+ -- If no Push/Pop has been generated for CE yet, then set the flag
+ -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
+ -- not already done), and generate Push/Pop nodes for the exception
+ -- label at the start and end of the statements of HSS.
+
+ procedure Generate_Push_Pop_For_Program_Error is
+ new Generate_Push_Pop
+ (Exc_Locally_Handled => PE_Locally_Handled,
+ Make_Push_Label => Make_Push_Program_Error_Label,
+ Make_Pop_Label => Make_Pop_Program_Error_Label);
+ -- If no Push/Pop has been generated for PE yet, then set the flag
+ -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
+ -- not already done), and generate Push/Pop nodes for the exception
+ -- label at the start and end of the statements of HSS.
+
+ procedure Generate_Push_Pop_For_Storage_Error is
+ new Generate_Push_Pop
+ (Exc_Locally_Handled => SE_Locally_Handled,
+ Make_Push_Label => Make_Push_Storage_Error_Label,
+ Make_Pop_Label => Make_Pop_Storage_Error_Label);
+ -- If no Push/Pop has been generated for SE yet, then set the flag
+ -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
+ -- not already done), and generate Push/Pop nodes for the exception
+ -- label at the start and end of the statements of HSS.
+
+ begin
+ -- See if we have any potential local raises to expand
+
+ Handler := First_Non_Pragma (Handlrs);
+ while Present (Handler) loop
+
+ -- Note, we do not test Local_Raise_Not_OK here, because in the
+ -- case of Push/Pop generation we want to generate push with a
+ -- null label. The Add_Exception_Label routine has no effect if
+ -- Local_Raise_Not_OK is set, so this works as required.
+
+ if Present (Local_Raise_Statements (Handler)) then
+ Add_Exception_Label (Handler);
+ end if;
+
+ -- 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
+
+ if Debug_Flag_Dot_G
+ or else Restriction_Active (No_Exception_Propagation)
+ then
+ Choice := First (Exception_Choices (Handler));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_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
+ 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);
+ end if;
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next_Non_Pragma (Handler);
+ end loop;
+
+ -- Nothing to do if no handlers requiring the goto transformation
+
+ if not (Local_Expansion_Required) then
+ return;
+ end if;
+
+ -- Prepare to do the transformation
+
+ declare
+ L3_Dent : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('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
+ 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).
+
+ Blk_Stm :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Empty_List));
+
+ Rewrite (HSS,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Blk_Stm)));
+ Analyze (HSS);
+
+ -- Now we can set the real statement sequence in place
+
+ Set_Handled_Statement_Sequence (Blk_Stm, Old_HSS);
+ end if;
+
+ -- Now loop through the exception handlers to deal with those that
+ -- are targets of local raise statements.
+
+ Handler := First_Non_Pragma (Handlrs);
+ while Present (Handler) loop
+ if Present (Exception_Label (Handler)) then
+
+ -- This handler needs the goto expansion
+
+ declare
+ Loc : constant Source_Ptr := Sloc (Handler);
+
+ L1_Dent : constant Entity_Id := Exception_Label (Handler);
+
+ Labl_L1 : constant Node_Id :=
+ Make_Label (Loc,
+ Identifier =>
+ New_Occurrence_Of (L1_Dent, Loc));
+
+ Name_L1 : constant Node_Id :=
+ New_Occurrence_Of (L1_Dent, Loc);
+
+ Goto_L1 : constant Node_Id :=
+ Make_Goto_Statement (Loc,
+ Name => Name_L1);
+
+ Name_L3 : constant Node_Id :=
+ New_Occurrence_Of (L3_Dent, Loc);
+
+ Goto_L3 : constant Node_Id :=
+ Make_Goto_Statement (Loc,
+ Name => Name_L3);
+
+ H_Stmts : constant List_Id := Statements (Handler);
+
+ begin
+ -- 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.
+
+ Set_Statements (Handler, New_List (Goto_L1));
+ Set_Analyzed (Goto_L1);
+ Set_Etype (Name_L1, Standard_Void_Type);
+
+ -- Now replace all the raise statements by goto L1
+
+ if Present (Local_Raise_Statements (Handler)) then
+ Relmt := First_Elmt (Local_Raise_Statements (Handler));
+ while Present (Relmt) loop
+ declare
+ Raise_S : constant Node_Id := Node (Relmt);
+
+ Name_L1 : constant Node_Id :=
+ New_Occurrence_Of (L1_Dent, Loc);
+
+ Goto_L1 : constant Node_Id :=
+ Make_Goto_Statement (Loc,
+ Name => Name_L1);
+
+ begin
+ -- Replace raise by goto L1
+
+ Set_Analyzed (Goto_L1);
+ Set_Etype (Name_L1, Standard_Void_Type);
+ Replace_Raise_By_Goto (Raise_S, Goto_L1);
+ end;
+
+ Next_Elmt (Relmt);
+ end loop;
+ end if;
+
+ -- Add 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.
+
+ Stmts := Statements (HSS);
+
+ Insert_After (Last (Stmts), Goto_L3);
+ Set_Analyzed (Goto_L3);
+ Set_Etype (Name_L3, Standard_Void_Type);
+
+ -- Now we drop the label that marks the handler start,
+ -- followed by the statements of the handler.
+
+ Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
+
+ Insert_After_And_Analyze (Last (Stmts), Labl_L1);
+ Insert_List_After (Last (Stmts), H_Stmts);
+ 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.
+
+ else
+ 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;
+
+ Next (Handler);
+ end loop;
+
+ -- 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);
+ return;
+ end;
+ end Expand_Local_Exception_Handlers;
+
-----------------------------
-- Prepend_Call_To_Handler --
-----------------------------
end if;
end Prepend_Call_To_Handler;
+ ---------------------------
+ -- Replace_Raise_By_Goto --
+ ---------------------------
+
+ procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Raise_S);
+ Excep : Entity_Id;
+ LR : Node_Id;
+ Cond : Node_Id;
+ Orig : Node_Id;
+
+ begin
+ -- If we have a null statement, it means that there is no replacement
+ -- needed (typically this results from a suppressed check).
+
+ if Nkind (Raise_S) = N_Null_Statement then
+ return;
+
+ -- Test for Raise_xxx_Error
+
+ elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
+ Excep := Standard_Constraint_Error;
+ Cond := Condition (Raise_S);
+
+ elsif Nkind (Raise_S) = N_Raise_Storage_Error then
+ Excep := Standard_Storage_Error;
+ Cond := Condition (Raise_S);
+
+ elsif Nkind (Raise_S) = N_Raise_Program_Error then
+ 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.
+
+ else
+ Orig := Original_Node (Raise_S);
+ pragma Assert (Nkind (Orig) = N_Raise_Statement
+ and then Present (Name (Orig))
+ and then No (Expression (Orig)));
+ Excep := Entity (Name (Orig));
+ Cond := Empty;
+ end if;
+
+ -- Here Excep is the exception to raise, and Cond is the condition
+ -- First prepare the call to Local_Raise (excep'Identity).
+
+ 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)));
+
+ -- Use null statement if Local_Raise not available
+
+ else
+ LR :=
+ Make_Null_Statement (Loc);
+ end if;
+
+ -- If there is no condition, we rewrite as
+
+ -- begin
+ -- Local_Raise (excep'Identity);
+ -- goto L1;
+ -- end;
+
+ if No (Cond) then
+ Rewrite (Raise_S,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (LR, Goto_L1))));
+
+ -- If there is a condition, we rewrite as
+
+ -- if condition then
+ -- Local_Raise (excep'Identity);
+ -- goto L1;
+ -- end if;
+
+ else
+ Rewrite (Raise_S,
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => New_List (LR, Goto_L1)));
+ end if;
+
+ Analyze (Raise_S);
+ end Replace_Raise_By_Goto;
+
-- Start of processing for Expand_Exception_Handlers
begin
+ Expand_Local_Exception_Handlers;
+
-- Loop through handlers
Handler := First_Non_Pragma (Handlrs);
Handler_Loop : while Present (Handler) loop
- Loc := Sloc (Handler);
+ Next_Handler := Next_Non_Pragma (Handler);
-- Remove source handler if gnat debug flag N is set
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
- declare
- H : constant Node_Id := Handler;
- begin
- Next_Non_Pragma (Handler);
- Remove (H);
- goto Continue_Handler_Loop;
- end;
- end if;
-
- -- If an exception occurrence is present, then we must declare it
- -- and initialize it from the value stored in the TSD
-
- -- declare
- -- name : Exception_Occurrence;
- --
- -- begin
- -- Save_Occurrence (name, Get_Current_Excep.all)
- -- ...
- -- end;
+ Remove (Handler);
- if Present (Choice_Parameter (Handler)) then
- declare
- Cparm : constant Entity_Id := Choice_Parameter (Handler);
- Clc : constant Source_Ptr := Sloc (Cparm);
- Save : Node_Id;
+ -- Remove handler if no exception propagation, generating a warning
+ -- if a source generated handler was not the target of a local raise.
- 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_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;
+ elsif Restriction_Active (No_Exception_Propagation) then
+ if No (Local_Raise_Statements (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);
+ Error_Msg_N
+ ("\?this handler can never be entered, and has been removed",
+ Handler);
+ end if;
- -- The processing at this point is rather different for the
- -- JVM case, so we completely separate the processing.
+ Remove (Handler);
- -- For the JVM case, we unconditionally call Update_Exception,
- -- passing a call to the intrinsic function Current_Target_Exception
- -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
+ -- Exception handler is active and retained and must be processed
- 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;
+ else
+ -- If an exception occurrence is present, then we must declare it
+ -- and initialize it from the value stored in the TSD
- -- 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!
+ -- declare
+ -- name : Exception_Occurrence;
+ -- begin
+ -- Save_Occurrence (name, Get_Current_Excep.all)
+ -- ...
+ -- end;
- elsif Abort_Allowed then
+ if Present (Choice_Parameter (Handler)) then
+ declare
+ Cparm : constant Entity_Id := Choice_Parameter (Handler);
+ Clc : constant Source_Ptr := Sloc (Cparm);
+ Save : Node_Id;
- -- 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.
+ 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;
- -- 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 :-)
+ -- The processing at this point is rather different for the JVM
+ -- case, so we completely separate the processing.
- -- If abort really needs to be deferred the expander must add
- -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
+ -- 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).
- Others_Choice :=
- Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
+ 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;
- 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
- then
- Prepend_Call_To_Handler (RE_Abort_Undefer);
+ -- 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!
+
+ elsif Abort_Allowed then
+
+ -- 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 thank you very much :-)
+
+ -- 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))))
+ and then Abort_Allowed
+ then
+ Prepend_Call_To_Handler (RE_Abort_Undefer);
+ end if;
end if;
end if;
- Next_Non_Pragma (Handler);
-
- <<Continue_Handler_Loop>>
- null;
+ Handler := Next_Handler;
end loop Handler_Loop;
- -- If all handlers got removed by gnatdN, then remove the list
+ -- If all handlers got removed, then remove the list
- if Debug_Flag_Dot_X
- and then Is_Empty_List (Exception_Handlers (HSS))
- then
+ if Is_Empty_List (Exception_Handlers (HSS)) then
Set_Exception_Handlers (HSS, No_List);
end if;
end Expand_Exception_Handlers;
else
Set_First_Real_Statement (N, First (Statements (N)));
end if;
-
end Expand_N_Handled_Sequence_Of_Statements;
-------------------------------------
-- Expand_N_Raise_Constraint_Error --
-------------------------------------
- -- The only processing required is to adjust the condition to deal
- -- with the C/Fortran boolean case. This may well not be necessary,
- -- as all such conditions are generated by the expander and probably
- -- are all standard boolean, but who knows what strange optimization
- -- in future may require this adjustment!
-
procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
begin
+ -- We adjust the condition to deal with the C/Fortran boolean case. This
+ -- may well not be necessary, as all such conditions are generated by
+ -- the expander and probably are all standard boolean, but who knows
+ -- what strange optimization in future may require this adjustment!
+
Adjust_Condition (Condition (N));
end Expand_N_Raise_Constraint_Error;
-- Expand_N_Raise_Program_Error --
----------------------------------
- -- The only processing required is to adjust the condition to deal
- -- with the C/Fortran boolean case. This may well not be necessary,
- -- as all such conditions are generated by the expander and probably
- -- are all standard boolean, but who knows what strange optimization
- -- in future may require this adjustment!
-
procedure Expand_N_Raise_Program_Error (N : Node_Id) is
begin
+ -- We adjust the condition to deal with the C/Fortran boolean case. This
+ -- may well not be necessary, as all such conditions are generated by
+ -- the expander and probably are all standard boolean, but who knows
+ -- what strange optimization in future may require this adjustment!
+
Adjust_Condition (Condition (N));
end Expand_N_Raise_Program_Error;
Ehand : Node_Id;
E : Entity_Id;
Str : String_Id;
+ H : Node_Id;
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
+ if Debug_Flag_Dot_G
+ or else Restriction_Active (No_Exception_Propagation)
+ then
+ -- If we have a local handler, then note that this is potentially
+ -- able to be transformed into a goto statement.
+
+ H := Find_Local_Handler (Entity (Name (N)), N);
+
+ if Present (H) then
+ if Local_Raise_Statements (H) = No_Elist then
+ Set_Local_Raise_Statements (H, New_Elmt_List);
+ end if;
+
+ -- Append the new entry if it is not there already. Sometimes
+ -- we have situations where due to reexpansion, the same node
+ -- is analyzed twice and would otherwise be added twice.
+
+ Append_Unique_Elmt (N, Local_Raise_Statements (H));
+ 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:
-- 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 the keep the expansion for "raise;"
+ -- mechanism. However we need to keep the expansion for "raise;"
-- statements. See 4jexcept.ads for details.
if Present (Name (N)) and then Hostparm.Java_VM then
-- Expand_N_Raise_Storage_Error --
----------------------------------
- -- The only processing required is to adjust the condition to deal
- -- with the C/Fortran boolean case. This may well not be necessary,
- -- as all such conditions are generated by the expander and probably
- -- are all standard boolean, but who knows what strange optimization
- -- in future may require this adjustment!
-
procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
begin
+ -- We adjust the condition to deal with the C/Fortran boolean case. This
+ -- may well not be necessary, as all such conditions are generated by
+ -- the expander and probably are all standard boolean, but who knows
+ -- what strange optimization in future may require this adjustment!
+
Adjust_Condition (Condition (N));
end Expand_N_Raise_Storage_Error;
Analyze_And_Resolve (N, RTE (RE_Code_Loc));
end Expand_N_Subprogram_Info;
+ ------------------------
+ -- Find_Local_Handler --
+ ------------------------
+
+ function Find_Local_Handler
+ (Ename : Entity_Id;
+ Nod : Node_Id) return Node_Id
+ is
+ N : Node_Id;
+ P : Node_Id;
+ H : Node_Id;
+ C : Node_Id;
+
+ 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
+ -- Get the exception we are raising, allowing for renaming
+
+ ERaise := Ename;
+ while Present (Renamed_Entity (ERaise)) loop
+ ERaise := Renamed_Entity (ERaise);
+ end loop;
+
+ -- Loop to search up the tree
+
+ N := Nod;
+ loop
+ 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.
+
+ 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
+ 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!)
+
+ elsif Nkind (P) = N_Handled_Sequence_Of_Statements
+ and then Is_List_Member (N)
+ and then List_Containing (N) = Statements (P)
+ then
+ -- If we have exception handlers, look at them
+
+ if Present (Exception_Handlers (P)) then
+
+ -- Loop through exception handlers
+
+ H := First (Exception_Handlers (P));
+ while Present (H) loop
+
+ -- Loop through choices in one handler
+
+ C := First (Exception_Choices (H));
+ while Present (C) loop
+
+ -- Deal with others case
+
+ if Nkind (C) = N_Others_Choice then
+
+ -- Matching others handler, but we need to ensure
+ -- there is no choice parameter. If there is, then we
+ -- don't have a local handler after all (since we do
+ -- not allow choice parameters for local handlers).
+
+ if No (Choice_Parameter (H)) then
+ return H;
+ else
+ return Empty;
+ end if;
+
+ -- If not others must be entity name
+
+ elsif Nkind (C) /= N_Others_Choice then
+ pragma Assert (Is_Entity_Name (C));
+ pragma Assert (Present (Entity (C)));
+
+ -- Get exception being handled, dealing with renaming
+
+ EHandle := Entity (C);
+ while Present (Renamed_Entity (EHandle)) loop
+ EHandle := Renamed_Entity (EHandle);
+ end loop;
+
+ -- If match, then check choice parameter
+
+ if ERaise = EHandle then
+ if No (Choice_Parameter (H)) then
+ return H;
+ else
+ return Empty;
+ end if;
+ end if;
+ end if;
+
+ Next (C);
+ end loop;
+
+ Next (H);
+ end loop;
+ end if;
+ end if;
+
+ N := P;
+ end loop;
+ end Find_Local_Handler;
+
+ ---------------------------------
+ -- Get_Local_Raise_Call_Entity --
+ ---------------------------------
+
+ 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;
+ end if;
+ end Get_Local_Raise_Call_Entity;
+
+ -----------------------------
+ -- Get_RT_Exception_Entity --
+ -----------------------------
+
+ function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
+ begin
+ case R is
+ when RT_CE_Exceptions => return Standard_Constraint_Error;
+ when RT_PE_Exceptions => return Standard_Program_Error;
+ when RT_SE_Exceptions => return Standard_Storage_Error;
+ end case;
+ end Get_RT_Exception_Entity;
+
----------------------
-- Is_Non_Ada_Error --
----------------------
return True;
end Is_Non_Ada_Error;
+ ----------------------------
+ -- Warn_If_No_Propagation --
+ ----------------------------
+
+ procedure Warn_If_No_Propagation (N : Node_Id) is
+ begin
+ if Restriction_Active (No_Exception_Propagation)
+ and then Warn_On_Non_Local_Exception
+ then
+ Error_Msg_N
+ ("?No_Exception_Propagation restriction is active", N);
+
+ if Configurable_Run_Time_Mode then
+ Error_Msg_N
+ ("?Last_Chance_Handler will be called on exception", N);
+ else
+ Error_Msg_N
+ ("?program may terminate with unhandled exception", N);
+ end if;
+ end if;
+ end Warn_If_No_Propagation;
+
end Exp_Ch11;
projects / gcc.git / commitdiff