From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/exp_ch11.adb | 2035 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2035 insertions(+) create mode 100644 gcc/ada/exp_ch11.adb (limited to 'gcc/ada/exp_ch11.adb') diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb new file mode 100644 index 000000000..80d1d8d69 --- /dev/null +++ b/gcc/ada/exp_ch11.adb @@ -0,0 +1,2035 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 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; +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; Block : Node_Id) is + Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); + Loc : constant Source_Ptr := Sloc (Clean); + Ohandle : Node_Id; + Stmnts : List_Id; + + begin + pragma Assert (Present (Clean)); + pragma Assert (No (Exception_Handlers (HSS))); + + -- Don't expand if back end exception handling active + + if Exception_Mechanism = 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 (Block) then + Push_Scope (Block); + 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 (Block) 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 + + -- <> -- local excep target label, marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts1 + -- end; + -- goto L3; -- marked Exception_Junk + + -- <> -- marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts2 + -- end; + -- goto L3; -- marked Exception_Junk + -- <> -- 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 + + -- <> -- local excep target label, marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts1 + -- end; + -- goto L3; -- marked Exception_Junk + + -- <> -- marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts2 + -- end; + + -- <> -- 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 + -- <> -- target label for local exception + -- estmts + -- <> + -- 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 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. + + 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'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 + 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 Restriction_Active (No_Exception_Propagation) + and then not Has_Local_Raise (Handler) + and then Comes_From_Source (Handler) + and then Warn_On_Non_Local_Exception + then + Warn_No_Exception_Propagation_Active (Handler); + Error_Msg_N + ("\?this handler can never be entered, and has been removed", + 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; + + if Present (Choice_Parameter (Handler)) then + declare + Cparm : constant Entity_Id := Choice_Parameter (Handler); + Cloc : constant Source_Ptr := Sloc (Cparm); + Hloc : constant Source_Ptr := Sloc (Handler); + Save : Node_Id; + + begin + -- Note use of No_Location to hide this code from the + -- debugger, so single stepping doesn't jump back and + -- forth. + + Save := + Make_Procedure_Call_Statement (No_Location, + Name => + New_Occurrence_Of (RTE (RE_Save_Occurrence), + No_Location), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cparm, Cloc), + Make_Explicit_Dereference (No_Location, + Make_Function_Call (No_Location, + Name => Make_Explicit_Dereference (No_Location, + New_Occurrence_Of + (RTE (RE_Get_Current_Excep), + No_Location)))))); + + Mark_Rewrite_Insertion (Save); + Prepend (Save, Statements (Handler)); + + Obj_Decl := + Make_Object_Declaration + (Cloc, + Defining_Identifier => Cparm, + Object_Definition => + New_Occurrence_Of + (RTE (RE_Exception_Occurrence), Cloc)); + Set_No_Initialization (Obj_Decl, True); + + Rewrite (Handler, + Make_Exception_Handler (Hloc, + Choice_Parameter => Empty, + Exception_Choices => Exception_Choices (Handler), + + Statements => New_List ( + Make_Block_Statement (Hloc, + Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Hloc, + Statements => Statements (Handler)))))); + + -- Local raise statements can't occur, since exception + -- handlers with choice parameters are not allowed when + -- No_Exception_Propagation applies, so set attributes + -- accordingly. + + Set_Local_Raise_Statements (Handler, No_Elist); + Set_Local_Raise_Not_OK (Handler); + + Analyze_List + (Statements (Handler), Suppress => All_Checks); + end; + end if; + + -- The processing at this point is rather different for the JVM + -- case, so we completely separate the processing. + + -- For the VM case, we unconditionally call Update_Exception, + -- passing a call to the intrinsic Current_Target_Exception + -- (see JVM/.NET versions of Ada.Exceptions for details). + + if VM_Target /= No_VM then + declare + Arg : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc)); + begin + Prepend_Call_To_Handler + (RE_Update_Exception, New_List (Arg)); + end; + + -- 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). + + -- 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; + 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, + -- Import_Code => 0, + -- 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 + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + L : List_Id := New_List; + Flag_Id : Entity_Id; + + Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E'); + Exname : constant Node_Id := + Make_Defining_Identifier (Loc, Name_Exname); + + procedure Force_Static_Allocation_Of_Referenced_Objects + (Aggregate : Node_Id); + -- A specialized solution to one particular case of an ugly problem + -- + -- The given aggregate includes an Unchecked_Conversion as one of the + -- component values. The call to Analyze_And_Resolve below ends up + -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide + -- to introduce a (constant) temporary and then obtain the component + -- value by evaluating the temporary. + -- + -- In the case of an exception declared within a subprogram (or any + -- other dynamic scope), this is a bad transformation. The exception + -- object is marked as being Statically_Allocated but the temporary is + -- not. If the initial value of a Statically_Allocated declaration + -- references a dynamically allocated object, this prevents static + -- initialization of the object. + -- + -- We cope with this here by marking the temporary Statically_Allocated. + -- It might seem cleaner to generalize this utility and then use it to + -- enforce a rule that the entities referenced in the declaration of any + -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) + -- entity must also be either Library_Level or hoisted. It turns out + -- that this would be incompatible with the current treatment of an + -- object which is local to a subprogram, subject to an Export pragma, + -- not subject to an address clause, and whose declaration contains + -- references to other local (non-hoisted) objects (e.g., in the initial + -- value expression). + + --------------------------------------------------- + -- Force_Static_Allocation_Of_Referenced_Objects -- + --------------------------------------------------- + + procedure Force_Static_Allocation_Of_Referenced_Objects + (Aggregate : Node_Id) + is + function Fixup_Node (N : Node_Id) return Traverse_Result; + -- If the given node references a dynamically allocated object, then + -- correct the declaration of the object. + + ---------------- + -- Fixup_Node -- + ---------------- + + function Fixup_Node (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) in N_Has_Entity + and then Present (Entity (N)) + and then not Is_Library_Level_Entity (Entity (N)) + + -- Note: the following test is not needed but it seems cleaner + -- to do this test (this would be more important if procedure + -- Force_Static_Allocation_Of_Referenced_Objects recursively + -- traversed the declaration of an entity after marking it as + -- statically allocated). + + and then not Is_Statically_Allocated (Entity (N)) + then + Set_Is_Statically_Allocated (Entity (N)); + end if; + + return OK; + end Fixup_Node; + + procedure Fixup_Tree is new Traverse_Proc (Fixup_Node); + + -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects + + begin + Fixup_Tree (Aggregate); + end Force_Static_Allocation_Of_Referenced_Objects; + + -- Start of processing for Expand_N_Exception_Declaration + + begin + -- There is no expansion needed when compiling for the JVM since the + -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads + -- for details. + + if VM_Target /= No_VM then + return; + end if; + + -- Definition of the external name: nam : constant String := "A.B.NAME"; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String (Id)))); + + Set_Is_Statically_Allocated (Exname); + + -- Create the aggregate list for type Standard.Exception_Type: + -- Handled_By_Other component: False + + 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 (Exname, Loc), + Attribute_Name => Name_Length)); + + -- Full_Name component: Standard.A_Char!(Nam'Address) + + Append_To (L, Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Exname, Loc), + Attribute_Name => Name_Address))); + + -- HTable_Ptr component: null + + Append_To (L, Make_Null (Loc)); + + -- Import_Code component: 0 + + Append_To (L, Make_Integer_Literal (Loc, 0)); + + -- 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, + 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 clean up actions if required + + if Nkind (Parent (N)) /= N_Package_Body + and then Nkind (Parent (N)) /= N_Accept_Statement + and then Nkind (Parent (N)) /= N_Extended_Return_Statement + and then not Delay_Cleanups (Current_Scope) + then + 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_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; + + 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 + + -- 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). + + if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then + if Entity (Name (N)) = Standard_Constraint_Error then + Rewrite (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Explicit_Raise)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Program_Error then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Storage_Error then + Rewrite (N, + Make_Raise_Storage_Error (Loc, + Reason => SE_Explicit_Raise)); + 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)); + + begin + Name_Len := 0; + Build_Location_String (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 + Name_Len := 1; + else + Name_Len := Name_Len + 1; + end if; + + Name_Buffer (Name_Len) := ASCII.NUL; + end if; + + if Opt.Exception_Locations_Suppressed then + Name_Len := 0; + end if; + + Str := String_From_Name_Buffer; + + -- For VMS exceptions, convert the raise into a call to + -- lib$stop so it will be handled by __gnat_error_handler. + + if Is_VMS_Exception (Id) then + declare + Excep_Image : String_Id; + Cond : Node_Id; + + begin + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + if Exception_Code (Id) /= No_Uint then + Cond := + Make_Integer_Literal (Loc, Exception_Code (Id)); + else + Cond := + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Import_Value), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image)))); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), + Parameter_Associations => New_List (Cond))); + Analyze_And_Resolve (Cond, Standard_Integer); + end; + + -- Not VMS exception case, convert raise to call to the + -- Raise_Exception routine. + + 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), + Make_String_Literal (Loc, + Strval => Str)))); + end if; + 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 + -- 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. + + elsif Warn_On_Non_Local_Exception + and then Restriction_Active (No_Exception_Propagation) + then + Warn_No_Exception_Propagation_Active (N); + + if Configurable_Run_Time_Mode then + Error_Msg_NE + ("\?& may call Last_Chance_Handler", N, E); + else + Error_Msg_NE + ("\?& may result in unhandled exception", N, E); + end if; + end if; + end; + end Possible_Local_Raise; + + ------------------------------ + -- Expand_N_Subprogram_Info -- + ------------------------------ + + procedure Expand_N_Subprogram_Info (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- For now, we replace an Expand_N_Subprogram_Info node with an + -- attribute reference that gives the address of the procedure. + -- This is because gigi does not yet recognize this node, and + -- for the initial targets, this is the right value anyway. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Identifier (N), + Attribute_Name => Name_Code_Address)); + + 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; + + 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) + and then (List_Containing (N) = Statements (P) + or else + List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before + or else + List_Containing (N) = SSE.Actions_To_Be_Wrapped_After) + then + -- Loop through exception handlers + + H := First (Exception_Handlers (P)); + 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 := 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; + + Next (H); + end loop; + end if; + end if; + + N := P; + end loop; + end Find_Local_Handler; + + --------------------------------- + -- Get_Local_Raise_Call_Entity -- + --------------------------------- + + -- Note: this is primary provided for use by the back end in generating + -- calls to Local_Raise. But it would be too late in the back end to call + -- RTE if this actually caused a load/analyze of the unit. So what we do + -- is to ensure there is a dummy call to this function during front end + -- processing so that the unit gets loaded then, and not later. + + Local_Raise_Call_Entity : Entity_Id; + Local_Raise_Call_Entity_Set : Boolean := False; + + function Get_Local_Raise_Call_Entity return Entity_Id is + begin + if 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 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 -- + ---------------------- + + function Is_Non_Ada_Error (E : Entity_Id) return Boolean is + begin + if not OpenVMS_On_Target then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Note: it is a little irregular for the body of exp_ch11 to know + -- the details of the encoding scheme for names, but on the other + -- hand, gigi knows them, and this is for gigi's benefit anyway! + + if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then + return False; + end if; + + return True; + end Is_Non_Ada_Error; + + ---------------------------- + -- 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 + ("\?Last_Chance_Handler will be called on exception", N); + else + Error_Msg_N + ("\?execution may raise unhandled exception", N); + end if; + end if; + end Warn_If_No_Propagation; + + ------------------------------------------ + -- Warn_No_Exception_Propagation_Active -- + ------------------------------------------ + + procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is + begin + Error_Msg_N + ("?pragma Restrictions (No_Exception_Propagation) in effect", N); + end Warn_No_Exception_Propagation_Active; + +end Exp_Ch11; -- cgit v1.2.3