Mercurial > hg > CbC > CbC_gcc
view gcc/ada/exp_ch11.adb @ 131:84e7813d76e9
gcc-8.2
| author | mir3636 |
|---|---|
| date | Thu, 25 Oct 2018 07:37:49 +0900 |
| parents | 04ced10e8804 |
| children | 1830386684a0 |
line wrap: on
line source
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2018, 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 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 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 Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Intr; use Exp_Intr; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch11 is ----------------------- -- Local Subprograms -- ----------------------- 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 -- 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 -- --------------------------- -- For a handled statement sequence that has a cleanup (At_End_Proc -- field set), an exception handler of the following form is required: -- exception -- when all others => -- cleanup call -- raise; -- Note: this exception handler is treated rather specially by -- subsequent expansion in two respects: -- The normal call to Undefer_Abort is omitted -- The raise call does not do Defer_Abort -- This is because the current tasking code seems to assume that -- the call to the cleanup routine that is made from an exception -- handler for the abort signal is called with aborts deferred. -- This expansion is only done if we have front end exception handling. -- If we have back end exception handling, then the AT END handler is -- left alone, and cleanups (including the exceptional case) are handled -- by the back end. -- In the front end case, the exception handler described above handles -- the exceptional case. The AT END handler is left in the generated tree -- and the code generator (e.g. gigi) must still handle proper generation -- of cleanup calls for the non-exceptional case. procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); Ohandle : Node_Id; Stmnts : List_Id; Loc : constant Source_Ptr := No_Location; -- Location used for expansion. We quite deliberately do not set a -- specific source location for the expanded handler. This makes -- sense since really the handler is not associated with specific -- source. We used to set this to Sloc (Clean), but that caused -- useless and annoying bouncing around of line numbers in the -- debugger in some circumstances. begin pragma Assert (Present (Clean)); pragma Assert (No (Exception_Handlers (HSS))); -- Back end exception schemes don't need explicit handlers to -- trigger AT-END actions on exceptional paths. if Back_End_Exceptions then return; end if; -- Don't expand an At End handler if we have already had configurable -- run-time violations, since likely this will just be a matter of -- generating useless cascaded messages if Configurable_Run_Time_Violations > 0 then return; end if; -- 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 (Blk_Id) then Push_Scope (Blk_Id); end if; Ohandle := Make_Others_Choice (Loc); Set_All_Others (Ohandle); Stmnts := New_List ( Make_Procedure_Call_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, Exception_Choices => New_List (Ohandle), Statements => Stmnts))); Analyze_List (Stmnts, Suppress => All_Checks); Expand_Exception_Handlers (HSS); if Present (Blk_Id) then Pop_Scope; end if; end Expand_At_End_Handler; ------------------------------- -- Expand_Exception_Handlers -- ------------------------------- procedure Expand_Exception_Handlers (HSS : Node_Id) is 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; Args : List_Id := No_List); -- 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; -- 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 three 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. -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set -- since they are useless in this case, and in CodePeer mode, where -- they serve no purpose and can intefere with the analysis. -- 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_Temporary (Sloc (H), '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 Restriction_Active (No_Exception_Handlers) or else CodePeer_Mode then return; end if; 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_Temporary (Loc, '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), End_Label => Relocate_Node (End_Label (HSS)))); -- 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); 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 (RLoc, 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; ----------------------------- -- Prepend_Call_To_Handler -- ----------------------------- procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List) is 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 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 (No_Location, Name => New_Occurrence_Of (RTE (Proc), No_Location), Parameter_Associations => Args); begin Prepend_To (Statements (Handler), Call); Analyze (Call, Suppress => All_Checks); end; 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. Note that the string expression in the -- original Raise statement is ignored. else Orig := Original_Node (Raise_S); pragma Assert (Nkind (Orig) = N_Raise_Statement and then Present (Name (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'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 ( 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 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)))); Set_Exception_Junk (Raise_S); -- 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 Process_Statements_For_Controlled_Objects (Handler); Next_Handler := Next_Non_Pragma (Handler); -- 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. else if not Has_Local_Raise (Handler) and then Comes_From_Source (Handler) then Warn_If_No_Local_Raise (Handler); end if; if No_Exception_Propagation_Active then 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 -- declare -- name : Exception_Occurrence; -- begin -- Save_Occurrence (name, Get_Current_Excep.all) -- ... -- end; -- This expansion is only performed when using front-end -- exceptions. Gigi will insert a call to initialize the -- choice parameter. if Present (Choice_Parameter (Handler)) and then (Front_End_Exceptions or else CodePeer_Mode) then declare Cparm : constant Entity_Id := Choice_Parameter (Handler); Cloc : constant Source_Ptr := Sloc (Cparm); Hloc : constant Source_Ptr := Sloc (Handler); Save : Node_Id; begin -- Note: No_Location used to hide 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, No_Location), Make_Explicit_Dereference (No_Location, Prefix => Make_Function_Call (No_Location, Name => Make_Explicit_Dereference (No_Location, Prefix => 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; -- 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 Abort_Allowed and then not ZCX_Exceptions 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). -- 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. Note we cannot -- reference HSS here, since expanding local handlers may have buried -- the handlers in an inner block. if Is_Empty_List (Handlrs) then Set_Exception_Handlers (Parent (Handlrs), No_List); end if; end Expand_Exception_Handlers; ------------------------------------ -- Expand_N_Exception_Declaration -- ------------------------------------ -- Generates: -- exceptE : constant String := "A.B.EXCEP"; -- static data -- except : exception_data := -- (Handled_By_Other => False, -- Lang => 'A', -- Name_Length => exceptE'Length, -- Full_Name => exceptE'Address, -- HTable_Ptr => null, -- Foreign_Data => null, -- Raise_Hook => null); -- (protecting test only needed if not at library level) -- exceptF : Boolean := True -- static data -- if exceptF then -- exceptF := False; -- Register_Exception (except'Unchecked_Access); -- end if; procedure Expand_N_Exception_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); Loc : constant Source_Ptr := Sloc (N); 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). function Null_String return String_Id; -- Build a null-terminated empty string --------------------------------------------------- -- 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; ----------------- -- Null_String -- ----------------- function Null_String return String_Id is begin Start_String; Store_String_Char (Get_Char_Code (ASCII.NUL)); return End_String; end Null_String; -- Local variables Ex_Id : Entity_Id; Ex_Val : String_Id; Flag_Id : Entity_Id; L : List_Id; -- Start of processing for Expand_N_Exception_Declaration begin -- Nothing to do when generating C code if Modify_Tree_For_C then return; end if; -- Definition of the external name: nam : constant String := "A.B.NAME"; Ex_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E')); -- Do not generate an external name if the exception declaration is -- subject to pragma Discard_Names. Use a null-terminated empty name -- to ensure that Ada.Exceptions.Exception_Name functions properly. if Global_Discard_Names or else Discard_Names (Ex_Id) then Ex_Val := Null_String; -- Otherwise generate the fully qualified name of the exception else Ex_Val := Fully_Qualified_Name_String (Id); end if; Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Ex_Id, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Ex_Val))); Set_Is_Statically_Allocated (Ex_Id); -- Create the aggregate list for type Standard.Exception_Type: -- Handled_By_Other component: False L := Empty_List; Append_To (L, New_Occurrence_Of (Standard_False, Loc)); -- Lang component: 'A' Append_To (L, Make_Character_Literal (Loc, Chars => Name_uA, Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); -- Name_Length component: Nam'Length Append_To (L, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ex_Id, Loc), Attribute_Name => Name_Length)); -- Full_Name component: Standard.A_Char!(Nam'Address) -- The unchecked conversion causes capacity issues for CodePeer in some -- cases and is never useful, so we set the Full_Name component to null -- instead for CodePeer. if CodePeer_Mode then Append_To (L, Make_Null (Loc)); else Append_To (L, Unchecked_Convert_To (Standard_A_Char, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ex_Id, Loc), Attribute_Name => Name_Address))); end if; -- HTable_Ptr component: null Append_To (L, Make_Null (Loc)); -- Foreign_Data component: null Append_To (L, Make_Null (Loc)); -- Raise_Hook component: null Append_To (L, Make_Null (Loc)); 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 No_Exception_Handlers_Set and then not Restriction_Active (No_Exception_Registration) then L := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Id, Loc), Attribute_Name => Name_Unrestricted_Access))))); Set_Register_Exception_Call (Id, First (L)); if not Is_Library_Level_Entity (Id) then Flag_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Id), 'F')); Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Flag_Id, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); Set_Is_Statically_Allocated (Flag_Id); Append_To (L, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Flag_Id, Loc), Expression => New_Occurrence_Of (Standard_False, Loc))); Insert_After_And_Analyze (N, Make_Implicit_If_Statement (N, Condition => New_Occurrence_Of (Flag_Id, Loc), Then_Statements => L)); else Insert_List_After_And_Analyze (N, L); end if; end if; end Expand_N_Exception_Declaration; --------------------------------------------- -- Expand_N_Handled_Sequence_Of_Statements -- --------------------------------------------- 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; -- 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 cleanup actions if required. No cleanup actions are needed in -- thunks associated with interfaces, because they only displace the -- pointer to the object. For extended return statements, we need -- cleanup actions if the Handled_Statement_Sequence contains generated -- objects of controlled types, for example. We do not want to clean up -- the return object. if not Nkind_In (Parent (N), N_Accept_Statement, N_Extended_Return_Statement, N_Package_Body) and then not Delay_Cleanups (Current_Scope) and then not Is_Thunk (Current_Scope) then Expand_Cleanup_Actions (Parent (N)); elsif Nkind (Parent (N)) = N_Extended_Return_Statement and then Handled_Statement_Sequence (Parent (N)) = N and then not Delay_Cleanups (Current_Scope) then pragma Assert (not Is_Thunk (Current_Scope)); Expand_Cleanup_Actions (Parent (N)); else Set_First_Real_Statement (N, First (Statements (N))); end if; end Expand_N_Handled_Sequence_Of_Statements; ------------------------------------- -- Expand_N_Raise_Constraint_Error -- ------------------------------------- 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)); -- Now deal with possible local raise handling Possible_Local_Raise (N, Standard_Constraint_Error); end Expand_N_Raise_Constraint_Error; ------------------------------- -- Expand_N_Raise_Expression -- ------------------------------- procedure Expand_N_Raise_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); RCE : Node_Id; begin Possible_Local_Raise (N, Entity (Name (N))); -- Later we must teach the back end/gigi how to deal with this, but -- for now we will assume the type is Standard_Boolean and transform -- the node to: -- do -- raise X [with string] -- in -- raise Constraint_Error; -- unless the flag Convert_To_Return_False is set, in which case -- the transformation is to: -- do -- return False; -- in -- raise Constraint_Error; -- The raise constraint error can never be executed. It is just a dummy -- node that can be labeled with an arbitrary type. RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); Set_Etype (RCE, Typ); if Convert_To_Return_False (N) then Rewrite (N, Make_Expression_With_Actions (Loc, Actions => New_List ( Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc))), Expression => RCE)); else Rewrite (N, Make_Expression_With_Actions (Loc, Actions => New_List ( Make_Raise_Statement (Loc, Name => Name (N), Expression => Expression (N))), Expression => RCE)); end if; Analyze_And_Resolve (N, Typ); end Expand_N_Raise_Expression; ---------------------------------- -- Expand_N_Raise_Program_Error -- ---------------------------------- 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)); -- Now deal with possible local raise handling Possible_Local_Raise (N, Standard_Program_Error); end Expand_N_Raise_Program_Error; ------------------------------ -- Expand_N_Raise_Statement -- ------------------------------ procedure Expand_N_Raise_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ehand : Node_Id; E : Entity_Id; Str : String_Id; H : Node_Id; Src : Boolean; begin -- 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)); Set_Has_Local_Raise (H); -- If no local handler, then generate no propagation warning else Warn_If_No_Propagation (N); end if; 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. if Present (Expression (N)) then -- Adjust message to deal with Prefix_Exception_Messages. We only -- add the prefix to string literals, if the message is being -- constructed, we assume it already deals with uniqueness. if Prefix_Exception_Messages and then Nkind (Expression (N)) = N_String_Literal then declare Buf : Bounded_String; begin Add_Source_Info (Buf, Loc, Name_Enclosing_Entity); Append (Buf, ": "); Append (Buf, Strval (Expression (N))); Rewrite (Expression (N), Make_String_Literal (Loc, +Buf)); Analyze_And_Resolve (Expression (N), Standard_String); end; end if; -- 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 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; Analyze (N); return; end if; -- 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) then return; end if; -- 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). 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)); 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)); 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)); Set_Comes_From_Source (N, Src); Analyze (N); return; end if; end if; -- Case of name present, in this case we expand raise name to -- Raise_Exception (name'Identity, location_string); -- where location_string identifies the file/line of the raise if Present (Name (N)) then declare Id : Entity_Id := Entity (Name (N)); Buf : Bounded_String; begin Build_Location_String (Buf, Loc); -- If the exception is a renaming, use the exception that it -- renames (which might be a predefined exception, e.g.). if Present (Renamed_Object (Id)) then Id := Renamed_Object (Id); end if; -- Build a C-compatible string in case of no exception handlers, -- since this is what the last chance handler is expecting. if No_Exception_Handlers_Set then -- Generate an empty message if configuration pragma -- Suppress_Exception_Locations is set for this unit. if Opt.Exception_Locations_Suppressed then Buf.Length := 0; end if; Append (Buf, ASCII.NUL); end if; if Opt.Exception_Locations_Suppressed then Buf.Length := 0; end if; Str := String_From_Name_Buffer (Buf); -- Convert raise to call to the Raise_Exception routine 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), Make_String_Literal (Loc, Strval => Str)))); end; -- Case of no name present (reraise). We rewrite the raise to: -- Reraise_Occurrence_Always (EO); -- where EO is the current exception occurrence. If the current handler -- 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 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 not CodePeer_Mode and then 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 -- context of an exception handler. Ehand := Parent (N); while Nkind (Ehand) /= N_Exception_Handler loop Ehand := Parent (Ehand); end loop; -- Make exception choice parameter if none present. Note that we do -- not need to put the entity on the entity chain, since no one will -- be referencing this entity by normal visibility methods. if No (Choice_Parameter (Ehand)) then E := Make_Temporary (Loc, 'E'); Set_Choice_Parameter (Ehand, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); Set_Scope (E, Current_Scope); end if; -- Now rewrite the raise as a call to Reraise. A special case arises -- if this raise statement occurs in the context of a handler for -- all others (i.e. an at end handler). in this case we avoid -- the call to defer abort, cleanup routines are expected to be -- called in this case with aborts deferred. declare Ech : constant Node_Id := First (Exception_Choices (Ehand)); Ent : Entity_Id; begin if Nkind (Ech) = N_Others_Choice and then All_Others (Ech) then Ent := RTE (RE_Reraise_Occurrence_No_Defer); else Ent := RTE (RE_Reraise_Occurrence_Always); end if; Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Ent, Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); end; end if; Analyze (N); end Expand_N_Raise_Statement; ---------------------------------- -- Expand_N_Raise_Storage_Error -- ---------------------------------- 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)); -- 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. -- ??? Do not do it for the Call_Marker nodes inserted by the ABE -- mechanism because this generates too many false positives, or -- for generic instantiations for the same reason. elsif Warn_On_Non_Local_Exception and then Restriction_Active (No_Exception_Propagation) and then Nkind (N) /= N_Call_Marker and then Nkind (N) not in N_Generic_Instantiation then Warn_No_Exception_Propagation_Active (N); if Configurable_Run_Time_Mode then Error_Msg_NE ("\?X?& may call Last_Chance_Handler", N, E); else Error_Msg_NE ("\?X?& may result in unhandled exception", N, E); end if; end if; end; end Possible_Local_Raise; ------------------------ -- 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; 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 := Get_Renamed_Entity (Ename); -- We need to check if the node we are looking at is contained in -- -- 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, -- 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 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 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) then declare LCN : constant List_Id := List_Containing (N); begin if LCN = Statements (P) or else LCN = SSE.Actions_To_Be_Wrapped (Before) or else LCN = SSE.Actions_To_Be_Wrapped (After) or else LCN = SSE.Actions_To_Be_Wrapped (Cleanup) then -- Loop through exception handlers H := First (Exception_Handlers (P)); while Present (H) loop -- Guard against other constructs appearing in the -- list of exception handlers. if Nkind (H) = N_Exception_Handler then -- 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 := Get_Renamed_Entity (Entity (C)); -- 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; end if; Next (H); end loop; end if; end; end if; end if; N := P; end loop; end Find_Local_Handler; --------------------------------- -- Get_Local_Raise_Call_Entity -- --------------------------------- -- Note: this is primarily 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 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; ----------------------------- -- Get_RT_Exception_Entity -- ----------------------------- function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is begin case Rkind (R) is when CE_Reason => return Standard_Constraint_Error; when PE_Reason => return Standard_Program_Error; when SE_Reason => return Standard_Storage_Error; end case; end Get_RT_Exception_Entity; --------------------------- -- Get_RT_Exception_Name -- --------------------------- procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is begin case Code is when CE_Access_Check_Failed => Add_Str_To_Name_Buffer ("CE_Access_Check"); when CE_Access_Parameter_Is_Null => Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter"); when CE_Discriminant_Check_Failed => Add_Str_To_Name_Buffer ("CE_Discriminant_Check"); when CE_Divide_By_Zero => Add_Str_To_Name_Buffer ("CE_Divide_By_Zero"); when CE_Explicit_Raise => Add_Str_To_Name_Buffer ("CE_Explicit_Raise"); when CE_Index_Check_Failed => Add_Str_To_Name_Buffer ("CE_Index_Check"); when CE_Invalid_Data => Add_Str_To_Name_Buffer ("CE_Invalid_Data"); when CE_Length_Check_Failed => Add_Str_To_Name_Buffer ("CE_Length_Check"); when CE_Null_Exception_Id => Add_Str_To_Name_Buffer ("CE_Null_Exception_Id"); when CE_Null_Not_Allowed => Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed"); when CE_Overflow_Check_Failed => Add_Str_To_Name_Buffer ("CE_Overflow_Check"); when CE_Partition_Check_Failed => Add_Str_To_Name_Buffer ("CE_Partition_Check"); when CE_Range_Check_Failed => Add_Str_To_Name_Buffer ("CE_Range_Check"); when CE_Tag_Check_Failed => Add_Str_To_Name_Buffer ("CE_Tag_Check"); when PE_Access_Before_Elaboration => Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration"); when PE_Accessibility_Check_Failed => Add_Str_To_Name_Buffer ("PE_Accessibility_Check"); when PE_Address_Of_Intrinsic => Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic"); when PE_Aliased_Parameters => Add_Str_To_Name_Buffer ("PE_Aliased_Parameters"); when PE_All_Guards_Closed => Add_Str_To_Name_Buffer ("PE_All_Guards_Closed"); when PE_Bad_Predicated_Generic_Type => Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type"); when PE_Build_In_Place_Mismatch => Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch"); when PE_Current_Task_In_Entry_Body => Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body"); when PE_Duplicated_Entry_Address => Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address"); when PE_Explicit_Raise => Add_Str_To_Name_Buffer ("PE_Explicit_Raise"); when PE_Finalize_Raised_Exception => Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception"); when PE_Implicit_Return => Add_Str_To_Name_Buffer ("PE_Implicit_Return"); when PE_Misaligned_Address_Value => Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value"); when PE_Missing_Return => Add_Str_To_Name_Buffer ("PE_Missing_Return"); when PE_Non_Transportable_Actual => Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); when PE_Overlaid_Controlled_Object => Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object"); when PE_Potentially_Blocking_Operation => Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation"); when PE_Stream_Operation_Not_Allowed => Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed"); when PE_Stubbed_Subprogram_Called => Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called"); when PE_Unchecked_Union_Restriction => Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction"); when SE_Empty_Storage_Pool => Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool"); when SE_Explicit_Raise => Add_Str_To_Name_Buffer ("SE_Explicit_Raise"); when SE_Infinite_Recursion => Add_Str_To_Name_Buffer ("SE_Infinite_Recursion"); when SE_Object_Too_Large => Add_Str_To_Name_Buffer ("SE_Object_Too_Large"); end case; end Get_RT_Exception_Name; ---------------------------- -- Warn_If_No_Local_Raise -- ---------------------------- procedure Warn_If_No_Local_Raise (N : Node_Id) is begin if Restriction_Active (No_Exception_Propagation) and then Warn_On_Non_Local_Exception then Warn_No_Exception_Propagation_Active (N); Error_Msg_N ("\?X?this handler can never be entered, and has been removed", N); end if; end Warn_If_No_Local_Raise; ---------------------------- -- Warn_If_No_Propagation -- ---------------------------- procedure Warn_If_No_Propagation (N : Node_Id) is begin if Restriction_Check_Required (No_Exception_Propagation) and then Warn_On_Non_Local_Exception then Warn_No_Exception_Propagation_Active (N); if Configurable_Run_Time_Mode then Error_Msg_N ("\?X?Last_Chance_Handler will be called on exception", N); else Error_Msg_N ("\?X?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 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N); end Warn_No_Exception_Propagation_Active; end Exp_Ch11;