+ 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; -- marked Exception_Junk
+ -- L2 : label; -- marked Exception_Junk
+ -- L3 : label; -- marked Exception_Junk
+
+ -- begin -- marked Exception_Junk
+ -- ...
+ -- local_raise (excep1'address); -- was raise excep1
+ -- goto L1;
+ -- ...
+ -- local_raise (excep2'address); -- was raise excep2
+ -- goto L2;
+ -- ...
+ -- exception
+ -- when excep1 =>
+ -- goto L1;
+ -- when excep2 =>
+ -- goto L2;
+ -- end;
+
+ -- goto L3; -- skip handler if no raise, marked Exception_Junk
+
+ -- <<L1>> -- local excep target label, marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts1
+ -- end;
+ -- goto L3; -- marked Exception_Junk
+
+ -- <<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
+ -- 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.
+
+ -- begin
+ -- L1 : label; -- marked Exception_Junk
+ -- L2 : label; -- marked Exception_Junk
+ -- L3 : label; -- marked Exception_Junk
+
+ -- 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 if no raise, marked Exception_Junk
+
+ -- <<L1>> -- local excep target label, marked Exception_Junk
+ -- begin -- marked Exception_Junk
+ -- estmts1
+ -- end;
+ -- goto L3; -- marked Exception_Junk
+
+ -- <<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
+ -- 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 N_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. 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;
+
+ -- 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;
+ -- 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 none, allocate one, set the field in
+ -- the handler node, add the label declaration, and set the flag
+ -- 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);
+ -- 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)
+ 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'));
+ 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
+ -- 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);
+
+ Insert_After (L, Pop);
+ Set_Analyzed (Pop);
+ end;
+ end Generate_Push_Pop;
+
+ -- Local declarations
+
+ Loc : constant Source_Ptr := Sloc (HSS);
+ Stmts : List_Id := No_List;
+ Choice : Node_Id;
+ Excep : Entity_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.
+
+ -- Start of processing for Expand_Local_Exception_Handlers
+
+ begin
+ -- 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
+
+ -- 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 sequence for the back end.
+
+ 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
+ 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
+ Excep := Get_Renamed_Entity (Entity (Choice));
+
+ if Excep = Standard_Constraint_Error then
+ Generate_Push_Pop_For_Constraint_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;
+
+ 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 is the label to exit the HSS
+
+ 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));
+
+ Blk_Stm : Node_Id;
+ Relmt : Elmt_Id;
+
+ begin
+ Set_Exception_Junk (Labl_L3);
+ Add_Label_Declaration (L3_Dent);
+
+ -- Wrap existing statements and handlers in an inner block
+
+ 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)));
+
+ -- 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_Analyzed (Blk_Stm);
+
+ -- 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 is the start label for this handler
+
+ L1_Dent : constant Entity_Id := Exception_Label (Handler);
+
+ Labl_L1 : constant Node_Id :=
+ Make_Label (Loc,
+ 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);
+
+ Goto_L1 : constant Node_Id :=
+ 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);
+
+ Goto_L3 : constant Node_Id :=
+ Make_Goto_Statement (Loc,
+ Name => Name_L3);
+
+ 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. 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);
+ 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 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 previous 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);
+
+ 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 generate possible diagnostics.
+
+ 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));
+ 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);
+
+ -- 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;
+