diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/a-except.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 1160 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_sel.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/gnatbind.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/par-ch11.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/s-rident.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_ch11.adb | 113 | ||||
| -rw-r--r-- | gcc/ada/tbuild.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/tbuild.ads | 13 |
16 files changed, 1315 insertions, 210 deletions
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 0c9bc6807f3..48633214f64 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -760,6 +760,16 @@ package body Ada.Exceptions is -- in case we do not want any exception tracing support. This is -- why this package is separated. + ----------------- + -- Local_Raise -- + ----------------- + + procedure Local_Raise (Excep : Exception_Id) is + pragma Warnings (Off, Excep); + begin + return; + end Local_Raise; + ----------------------- -- Stream Attributes -- ----------------------- diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index fd42ab79cd4..f42d094ae05 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -139,6 +139,23 @@ package Ada.Exceptions is (Source : Exception_Occurrence) return Exception_Occurrence_Access; + -- Ada 2005 (AI-438): The language revision introduces the + -- following subprograms and attribute definitions. We do not + -- provide them explicitly; instead, the corresponding stream + -- attributes are made available through a pragma Stream_Convert + -- in the private part of this package. + + -- procedure Read_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : out Exception_Occurrence); + + -- procedure Write_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : Exception_Occurrence); + + -- for Exception_Occurrence'Read use Read_Exception_Occurrence; + -- for Exception_Occurrence'Write use Write_Exception_Occurrence; + private package SSL renames System.Standard_Library; package SP renames System.Parameters; @@ -192,6 +209,15 @@ private -- private barrier, so we can place this function in the private part -- where the compiler can find it, but the spec is unchanged.) + procedure Local_Raise (Excep : Exception_Id); + pragma Export (Ada, Local_Raise); + -- This is a dummy routine, used only by the debugger for the purpose of + -- logging local raise statements that were transformed into a direct goto + -- to the handler code. The compiler in this case generates: + -- + -- Local_Raise (exception_id); + -- goto Handler + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 44c7640a1ee..41d7e026689 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -690,6 +690,16 @@ package body Ada.Exceptions is -- in case we do not want any exception tracing support. This is -- why this package is separated. + ----------------- + -- Local_Raise -- + ----------------- + + procedure Local_Raise (Excep : Exception_Id) is + pragma Warnings (Off, Excep); + begin + return; + end Local_Raise; + ----------------------- -- Stream Attributes -- ----------------------- diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 2dae518140e..0c1f2246c00 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -35,7 +35,10 @@ -- -- ------------------------------------------------------------------------------ --- This version of Ada.Exceptions is a full Ada 95 version. +-- This version of Ada.Exceptions is a full Ada 95 version. It omits Ada 2005 +-- features such as the additional definitions of Exception_Name returning +-- Wide_[Wide_]String. + -- It is used for building the compiler and the basic tools, since these -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files @@ -172,6 +175,15 @@ private -- private barrier, so we can place this function in the private part -- where the compiler can find it, but the spec is unchanged.) + procedure Local_Raise (Excep : Exception_Id); + pragma Export (Ada, Local_Raise); + -- This is a dummy routine, used only by the debugger for the purpose of + -- logging local raise statements that were transformed into a direct goto + -- to the handler code. The compiler in this case generates: + -- + -- Local_Raise (exception_id); + -- goto Handler + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); pragma No_Return (Raise_Exception_Always); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d7dd11e41ba..e0823fa70c5 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -99,7 +99,7 @@ package body Debug is -- d.d -- d.e -- d.f Inhibit folding of static expressions - -- d.g + -- d.g Enable conversion of raise into goto -- d.h -- d.i -- d.j @@ -474,6 +474,11 @@ package body Debug is -- in seriously non-conforming behavior, but is useful sometimes -- when tracking down handling of complex expressions. + -- d.g Enables conversion of a raise statement into a goto when the + -- relevant handler is statically determinable. For now we only try + -- this if this debug flag is set. Later we will enable this more + -- generally by default. + -- d.l Use Ada 95 semantics for limited function returns. This may be -- used to work around the incompatibility introduced by AI-318-2. -- It is useful only in -gnat05 mode. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 2312f504dd7..61013c2016c 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -28,6 +28,7 @@ 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; @@ -54,6 +55,26 @@ with Uintp; use Uintp; package body Exp_Ch11 is + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Find_Local_Handler + (Ename : Entity_Id; + Nod : Node_Id) return Node_Id; + pragma Warnings (Off, Find_Local_Handler); + -- This function searches for a local exception handler that will handle + -- the exception named by Ename. If such a local hander exists, then the + -- corresponding N_Exception_Handler is returned. If no such handler is + -- found then Empty is returned. In order to match and return True, the + -- handler may not have a choice parameter specification. N is the raise + -- node that references the handler. + + procedure Warn_If_No_Propagation (N : Node_Id); + -- Called for an exception raise that is not a local raise (and thus can + -- not be optimized to a goto. Issues warning if No_Exception_Propagation + -- restriction is set. N is the node for the raise or equivalent call. + --------------------------- -- Expand_At_End_Handler -- --------------------------- @@ -128,7 +149,7 @@ package body Exp_Ch11 is Make_Raise_Statement (Loc)); Set_Exception_Handlers (HSS, New_List ( - Make_Exception_Handler (Loc, + Make_Implicit_Exception_Handler (Loc, Exception_Choices => New_List (Ohandle), Statements => Stmnts))); @@ -145,11 +166,16 @@ package body Exp_Ch11 is ------------------------------- procedure Expand_Exception_Handlers (HSS : Node_Id) is - Handlrs : constant List_Id := Exception_Handlers (HSS); - Loc : Source_Ptr; + Handlrs : constant List_Id := Exception_Handlers (HSS); + Loc : constant Source_Ptr := Sloc (HSS); Handler : Node_Id; Others_Choice : Boolean; Obj_Decl : Node_Id; + Next_Handler : Node_Id; + + procedure Expand_Local_Exception_Handlers; + -- This procedure handles the expansion of exception handlers for the + -- optimization of local raise statements into goto statements. procedure Prepend_Call_To_Handler (Proc : RE_Id; @@ -157,6 +183,573 @@ package body Exp_Ch11 is -- Routine to prepend a call to the procedure referenced by Proc at -- the start of the handler code for the current Handler. + procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id); + -- Raise_S is a raise statement (possibly expanded, and possibly of the + -- form of a Raise_xxx_Error node with a condition. This procedure is + -- called to replace the raise action with the (already analyzed) goto + -- statement passed as Goto_L1. This procedure also takes care of the + -- requirement of inserting a Local_Raise call where possible. + + ------------------------------------- + -- Expand_Local_Exception_Handlers -- + ------------------------------------- + + -- There are two cases for this transformation. First the case of + -- explicit raise statements. For this case, the transformation we do + -- looks like this. Right now we have for example (where L1,L2 are + -- exception labels) + + -- begin + -- ... + -- raise_exception (excep1'identity); -- was raise excep1 + -- ... + -- raise_exception (excep2'identity); -- was raise excep2 + -- ... + -- exception + -- when excep1 => + -- estmts1 + -- when excep2 => + -- estmts2 + -- end; + + -- This gets transformed into: + + -- begin + -- L1 : label; + -- L2 : label; + -- L3 : label; + + -- begin + -- ... + -- local_raise (excep1'Identity); -- was raise excep1 + -- goto L1; + -- ... + -- local_raise (excep2'Identity); -- was raise excep2 + -- goto L2; + -- ... + -- exception + -- when excep1 => + -- goto L1; + -- when excep2 => + -- goto L2; + -- end; + + -- goto L3; -- skip handler when exception not raised + + -- <<L1>> -- target label for local exception + -- estmts1 + -- goto L3; + + -- <<L2>> + -- estmts2 + -- goto L3; + -- <<L3>> + -- end; + + -- Note: the reason we wrap the original statement sequence in an + -- inner block is that there may be raise statements within the + -- sequence of statements in the handlers, and we must ensure that + -- these are properly handled, and in particular, such raise statements + -- must not reenter the same exception handlers. + + -- If the restriction No_Exception_Propagation is in effect, then we + -- can omit the exception handlers, and we do not need the inner block. + + -- begin + -- L1 : label; + -- L2 : label; + -- L3 : label; + + -- ... + -- local_raise (excep1'Identity); -- was raise excep1 + -- goto L1; + -- ... + -- local_raise (excep2'Identity); -- was raise excep2 + -- goto L2; + -- ... + + -- goto L3; -- skip handler when exception not raised + + -- <<L1>> -- target label for local exception + -- estmts1 + -- goto L3; + + -- <<L2>> + -- estmts2 + -- goto L3; + -- <<L3>> + -- end; + + -- The second case is for exceptions generated by the back end in one + -- of three situations: + + -- 1. Front end generates N_Raise_xxx_Error node + -- 2. Front end sets Do_xxx_Check flag in subexpression node + -- 3. Back end detects a situation where an exception is appropriate + + -- In all these cases, the current processing in gigi is to generate a + -- call to the appropriate Rcheck_xx routine (where xx encodes both the + -- exception message and the exception to be raised, Constraint_Error, + -- Program_Error, or Storage_Error. + + -- We could handle some subcases of 1 using the same front end expansion + -- into gotos, but even for case 1, we can't handle all cases, since + -- generating gotos in the middle of expressions is not possible (it's + -- possible at the gigi/gcc level, but not at the level of the GNAT + -- tree). + + -- In any case, it seems easier to have a scheme which handles all three + -- cases in a uniform manner. So here is how we proceed in this case. + + -- This procedure detects all handlers for these three exceptions, + -- Constraint_Error, Program_Error and Storage_Error (including WHEN + -- OTHERS handlers that cover one or more of these cases). + + -- If the handler meets the requirements for being the target of a local + -- raise, then the front end does the expansion described previously, + -- creating a label to be used as a goto target to raise the exception. + -- However, no attempt is made in the front end to convert any related + -- raise statements into gotos, e.g. all Raise_xxx_Error nodes are left + -- unchanged and passed to the back end. + + -- Instead, the front end generates two nodes + + -- N_Push_Constraint_Error_Label + -- N_Push_Program_Error_Label + -- N_Push_Storage_Error_Label + + -- The Push node is generated at the start of the statements + -- covered by the handler, and has as a parameter the label to be + -- used as the raise target. + + -- N_Pop_Constraint_Error_Label + -- N_Pop_Program_Error_Label + -- N_Pop_Storage_Error_Label + + -- The Pop node is generated at the end of the covered statements + -- and undoes the effect of the preceding corresponding Push node. + + -- In the case where the handler does NOT meet the requirements, the + -- front end will still generate the Push and Pop nodes, but the label + -- field in the Push node will be empty signifying that for this region + -- of code, no optimization is possible. + + -- The back end must maintain three stacks, one for each exception case, + -- the Push node pushes an entry onto the corresponding stack, and pop + -- node pops off the entry. Then instead of calling Rcheck_nn, if the + -- corresponding top stack entry has an non-empty label, a goto is + -- generated instead of the call. This goto should be preceded by a + -- call to Local_Raise as described above. + + -- An example of this transformation is as follows, given: + + -- declare + -- A : Integer range 1 .. 10; + -- begin + -- A := B + C; + -- exception + -- when Constraint_Error => + -- estmts + -- end; + + -- gets transformed to: + + -- declare + -- A : Integer range 1 .. 10; + + -- begin + -- L1 : label; + -- L2 : label; + + -- begin + -- %push_constraint_error_label (L1) + -- R1b : constant long_long_integer := long_long_integer?(b) + + -- long_long_integer?(c); + -- [constraint_error when + -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#) + -- "overflow check failed"] + -- a := integer?(R1b); + -- %pop_constraint_error_Label + + -- exception + -- ... + -- when constraint_error => + -- goto L1; + -- end; + + -- goto L2; -- skip handler when exception not raised + -- <<L1>> -- target label for local exception + -- estmts + -- <<L2>> + -- end; + + CE_Locally_Handled : Boolean := False; + SE_Locally_Handled : Boolean := False; + PE_Locally_Handled : Boolean := False; + -- These three flags indicate whether a handler for the corresponding + -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error) + -- is present. If so the switch is set to True, the Exception_Label + -- field of the corresponding handler is set, and appropriate Push + -- and Pop nodes are inserted into the code. + + Local_Expansion_Required : Boolean := False; + -- Set True if we have at least one handler requiring local raise + -- expansion as described above. + + procedure Expand_Local_Exception_Handlers is + + procedure Add_Exception_Label (H : Node_Id); + -- H is an exception handler. First check for an Exception_Label + -- already allocated for H. If not, allocate one, set the field in + -- the handler node, add the label declaration, and set the flag + -- Local_Expansion_Required. Note: if Local_Handlers_Not_OK is set + -- the call has no effect and Exception_Label is left empty. + + procedure Add_Label_Declaration (L : Entity_Id); + -- Add an implicit declaration of the given label to the declaration + -- list in the parent of the current sequence of handled statements. + + generic + Exc_Locally_Handled : in out Boolean; + -- Flag indicating whether a local handler for this exception + -- has already been generated. + + with function Make_Push_Label (Loc : Source_Ptr) return Node_Id; + -- Function to create a Push_xxx_Label node + + with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id; + -- Function to create a Pop_xxx_Label node + + procedure Generate_Push_Pop (H : Node_Id); + -- Common code for Generate_Push_Pop_xxx below, used to generate an + -- exception label and Push/Pop nodes for Constraint_Error, + -- Program_Error, or Storage_Error. + + ------------------------- + -- Add_Exception_Label -- + ------------------------- + + procedure Add_Exception_Label (H : Node_Id) is + begin + if No (Exception_Label (H)) + and then not Local_Raise_Not_OK (H) + then + Local_Expansion_Required := True; + + declare + L : constant Entity_Id := + Make_Defining_Identifier (Sloc (H), + Chars => New_Internal_Name ('L')); + begin + Set_Exception_Label (H, L); + Add_Label_Declaration (L); + end; + end if; + end Add_Exception_Label; + + --------------------------- + -- Add_Label_Declaration -- + --------------------------- + + procedure Add_Label_Declaration (L : Entity_Id) is + P : constant Node_Id := Parent (HSS); + + Decl_L : constant Node_Id := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => L); + + begin + if Declarations (P) = No_List then + Set_Declarations (P, Empty_List); + end if; + + Append (Decl_L, Declarations (P)); + Analyze (Decl_L); + end Add_Label_Declaration; + + ----------------------- + -- Generate_Push_Pop -- + ----------------------- + + procedure Generate_Push_Pop (H : Node_Id) is + begin + if Exc_Locally_Handled then + return; + else + Exc_Locally_Handled := True; + end if; + + Add_Exception_Label (H); + + declare + F : constant Node_Id := First (Statements (HSS)); + L : constant Node_Id := Last (Statements (HSS)); + + Push : constant Node_Id := Make_Push_Label (Sloc (F)); + Pop : constant Node_Id := Make_Pop_Label (Sloc (L)); + + begin + Set_Exception_Label (Push, Exception_Label (H)); + + Insert_Before (F, Push); + Set_Analyzed (Push); + + Insert_After (L, Pop); + Set_Analyzed (Pop); + end; + end Generate_Push_Pop; + + -- Local declarations + + Loc : constant Source_Ptr := Sloc (HSS); + Stmts : List_Id; + Choice : Node_Id; + + procedure Generate_Push_Pop_For_Constraint_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => CE_Locally_Handled, + Make_Push_Label => Make_Push_Constraint_Error_Label, + Make_Pop_Label => Make_Pop_Constraint_Error_Label); + -- If no Push/Pop has been generated for CE yet, then set the flag + -- CE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + procedure Generate_Push_Pop_For_Program_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => PE_Locally_Handled, + Make_Push_Label => Make_Push_Program_Error_Label, + Make_Pop_Label => Make_Pop_Program_Error_Label); + -- If no Push/Pop has been generated for PE yet, then set the flag + -- PE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + procedure Generate_Push_Pop_For_Storage_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => SE_Locally_Handled, + Make_Push_Label => Make_Push_Storage_Error_Label, + Make_Pop_Label => Make_Pop_Storage_Error_Label); + -- If no Push/Pop has been generated for SE yet, then set the flag + -- SE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + begin + -- See if we have any potential local raises to expand + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + + -- Note, we do not test Local_Raise_Not_OK here, because in the + -- case of Push/Pop generation we want to generate push with a + -- null label. The Add_Exception_Label routine has no effect if + -- Local_Raise_Not_OK is set, so this works as required. + + if Present (Local_Raise_Statements (Handler)) then + Add_Exception_Label (Handler); + end if; + + -- If we are doing local raise to goto optimization (restriction + -- No_Exception_Propagation set or debug flag .g set), then check + -- to see if handler handles CE,PE,SE and if so generate the + -- appropriate push/pop sequences for the back end + + if Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation) + then + Choice := First (Exception_Choices (Handler)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Generate_Push_Pop_For_Constraint_Error (Handler); + Generate_Push_Pop_For_Program_Error (Handler); + Generate_Push_Pop_For_Storage_Error (Handler); + + elsif Is_Entity_Name (Choice) then + if Entity (Choice) = Standard_Constraint_Error then + Generate_Push_Pop_For_Constraint_Error (Handler); + elsif Entity (Choice) = Standard_Program_Error then + Generate_Push_Pop_For_Program_Error (Handler); + elsif Entity (Choice) = Standard_Storage_Error then + Generate_Push_Pop_For_Storage_Error (Handler); + end if; + end if; + + Next (Choice); + end loop; + end if; + + Next_Non_Pragma (Handler); + end loop; + + -- Nothing to do if no handlers requiring the goto transformation + + if not (Local_Expansion_Required) then + return; + end if; + + -- Prepare to do the transformation + + declare + L3_Dent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Labl_L3 : constant Node_Id := + Make_Label (Loc, + Identifier => New_Occurrence_Of (L3_Dent, Loc)); + + Old_HSS : Node_Id; + Blk_Stm : Node_Id; + Relmt : Elmt_Id; + + begin + Add_Label_Declaration (L3_Dent); + + -- If the No_Exception_Propagation restriction is not active, + -- then we must wrap the existing statements and exception + -- handlers in an inner block. + + if not Restriction_Active (No_Exception_Propagation) then + Old_HSS := Relocate_Node (HSS); + + -- Construct and analyze the block with a dummy HSS inside it + -- for now (if we do the analyze call with the real HSS in + -- place we have nasty recursion problems). + + Blk_Stm := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Empty_List)); + + Rewrite (HSS, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Blk_Stm))); + Analyze (HSS); + + -- Now we can set the real statement sequence in place + + Set_Handled_Statement_Sequence (Blk_Stm, Old_HSS); + end if; + + -- Now loop through the exception handlers to deal with those that + -- are targets of local raise statements. + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + if Present (Exception_Label (Handler)) then + + -- This handler needs the goto expansion + + declare + Loc : constant Source_Ptr := Sloc (Handler); + + L1_Dent : constant Entity_Id := Exception_Label (Handler); + + Labl_L1 : constant Node_Id := + Make_Label (Loc, + Identifier => + New_Occurrence_Of (L1_Dent, Loc)); + + Name_L1 : constant Node_Id := + New_Occurrence_Of (L1_Dent, Loc); + + Goto_L1 : constant Node_Id := + Make_Goto_Statement (Loc, + Name => Name_L1); + + Name_L3 : constant Node_Id := + New_Occurrence_Of (L3_Dent, Loc); + + Goto_L3 : constant Node_Id := + Make_Goto_Statement (Loc, + Name => Name_L3); + + H_Stmts : constant List_Id := Statements (Handler); + + begin + -- Replace handler by a goto L1. We can mark this as + -- analyzed since it is fully formed, and we don't + -- want it going through any further checks. + + Set_Statements (Handler, New_List (Goto_L1)); + Set_Analyzed (Goto_L1); + Set_Etype (Name_L1, Standard_Void_Type); + + -- Now replace all the raise statements by goto L1 + + if Present (Local_Raise_Statements (Handler)) then + Relmt := First_Elmt (Local_Raise_Statements (Handler)); + while Present (Relmt) loop + declare + Raise_S : constant Node_Id := Node (Relmt); + + Name_L1 : constant Node_Id := + New_Occurrence_Of (L1_Dent, Loc); + + Goto_L1 : constant Node_Id := + Make_Goto_Statement (Loc, + Name => Name_L1); + + begin + -- Replace raise by goto L1 + + Set_Analyzed (Goto_L1); + Set_Etype (Name_L1, Standard_Void_Type); + Replace_Raise_By_Goto (Raise_S, Goto_L1); + end; + + Next_Elmt (Relmt); + end loop; + end if; + + -- Add goto L3 at end of statement list in block. The + -- first time, this is what skips over the exception + -- handlers in the normal case. Subsequent times, it + -- terminates the execution of the handler code, and + -- skips subsequent handlers. + + Stmts := Statements (HSS); + + Insert_After (Last (Stmts), Goto_L3); + Set_Analyzed (Goto_L3); + Set_Etype (Name_L3, Standard_Void_Type); + + -- Now we drop the label that marks the handler start, + -- followed by the statements of the handler. + + Set_Etype (Identifier (Labl_L1), Standard_Void_Type); + + Insert_After_And_Analyze (Last (Stmts), Labl_L1); + Insert_List_After (Last (Stmts), H_Stmts); + end; + + -- Here if we have local raise statements but the handler is + -- not suitable for processing with a local raise. In this + -- case we have to delete the Local_Raise call and also + -- generate possible diagnostics. + + else + Relmt := First_Elmt (Local_Raise_Statements (Handler)); + while Present (Relmt) loop + Warn_If_No_Propagation (Node (Relmt)); + Remove (Prev (Node (Relmt))); + Next_Elmt (Relmt); + end loop; + end if; + + Next (Handler); + end loop; + + -- Only remaining step is to drop the L3 label and we are done + + Set_Etype (Identifier (Labl_L3), Standard_Void_Type); + Insert_After_And_Analyze (Last (Stmts), Labl_L3); + return; + end; + end Expand_Local_Exception_Handlers; + ----------------------------- -- Prepend_Call_To_Handler -- ----------------------------- @@ -185,145 +778,254 @@ package body Exp_Ch11 is end if; end Prepend_Call_To_Handler; + --------------------------- + -- Replace_Raise_By_Goto -- + --------------------------- + + procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is + Loc : constant Source_Ptr := Sloc (Raise_S); + Excep : Entity_Id; + LR : Node_Id; + Cond : Node_Id; + Orig : Node_Id; + + begin + -- If we have a null statement, it means that there is no replacement + -- needed (typically this results from a suppressed check). + + if Nkind (Raise_S) = N_Null_Statement then + return; + + -- Test for Raise_xxx_Error + + elsif Nkind (Raise_S) = N_Raise_Constraint_Error then + Excep := Standard_Constraint_Error; + Cond := Condition (Raise_S); + + elsif Nkind (Raise_S) = N_Raise_Storage_Error then + Excep := Standard_Storage_Error; + Cond := Condition (Raise_S); + + elsif Nkind (Raise_S) = N_Raise_Program_Error then + Excep := Standard_Program_Error; + Cond := Condition (Raise_S); + + -- The only other possibility is a node that is or used to be + -- a simple raise statement. + + else + Orig := Original_Node (Raise_S); + pragma Assert (Nkind (Orig) = N_Raise_Statement + and then Present (Name (Orig)) + and then No (Expression (Orig))); + Excep := Entity (Name (Orig)); + Cond := Empty; + end if; + + -- Here Excep is the exception to raise, and Cond is the condition + -- First prepare the call to Local_Raise (excep'Identity). + + if RTE_Available (RE_Local_Raise) then + LR := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Excep, Loc), + Attribute_Name => Name_Identity))); + + -- Use null statement if Local_Raise not available + + else + LR := + Make_Null_Statement (Loc); + end if; + + -- If there is no condition, we rewrite as + + -- begin + -- Local_Raise (excep'Identity); + -- goto L1; + -- end; + + if No (Cond) then + Rewrite (Raise_S, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (LR, Goto_L1)))); + + -- If there is a condition, we rewrite as + + -- if condition then + -- Local_Raise (excep'Identity); + -- goto L1; + -- end if; + + else + Rewrite (Raise_S, + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (LR, Goto_L1))); + end if; + + Analyze (Raise_S); + end Replace_Raise_By_Goto; + -- Start of processing for Expand_Exception_Handlers begin + Expand_Local_Exception_Handlers; + -- Loop through handlers Handler := First_Non_Pragma (Handlrs); Handler_Loop : while Present (Handler) loop - Loc := Sloc (Handler); + Next_Handler := Next_Non_Pragma (Handler); -- Remove source handler if gnat debug flag N is set if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then - declare - H : constant Node_Id := Handler; - begin - Next_Non_Pragma (Handler); - Remove (H); - goto Continue_Handler_Loop; - end; - end if; - - -- If an exception occurrence is present, then we must declare it - -- and initialize it from the value stored in the TSD - - -- declare - -- name : Exception_Occurrence; - -- - -- begin - -- Save_Occurrence (name, Get_Current_Excep.all) - -- ... - -- end; + Remove (Handler); - if Present (Choice_Parameter (Handler)) then - declare - Cparm : constant Entity_Id := Choice_Parameter (Handler); - Clc : constant Source_Ptr := Sloc (Cparm); - Save : Node_Id; + -- Remove handler if no exception propagation, generating a warning + -- if a source generated handler was not the target of a local raise. - begin - Save := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Cparm, Clc), - Make_Explicit_Dereference (Loc, - Make_Function_Call (Loc, - Name => Make_Explicit_Dereference (Loc, - New_Occurrence_Of - (RTE (RE_Get_Current_Excep), Loc)))))); - - Mark_Rewrite_Insertion (Save); - Prepend (Save, Statements (Handler)); - - Obj_Decl := - Make_Object_Declaration (Clc, - Defining_Identifier => Cparm, - Object_Definition => - New_Occurrence_Of - (RTE (RE_Exception_Occurrence), Clc)); - Set_No_Initialization (Obj_Decl, True); - - Rewrite (Handler, - Make_Exception_Handler (Loc, - Exception_Choices => Exception_Choices (Handler), - - Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => New_List (Obj_Decl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements (Handler)))))); - - Analyze_List (Statements (Handler), Suppress => All_Checks); - end; - end if; + elsif Restriction_Active (No_Exception_Propagation) then + if No (Local_Raise_Statements (Handler)) + and then Comes_From_Source (Handler) + and then Warn_On_Non_Local_Exception + then + Error_Msg_N + ("?pragma Restrictions (No_Exception_Propagation) in effect", + Handler); + Error_Msg_N + ("\?this handler can never be entered, and has been removed", + Handler); + end if; - -- The processing at this point is rather different for the - -- JVM case, so we completely separate the processing. + Remove (Handler); - -- For the JVM case, we unconditionally call Update_Exception, - -- passing a call to the intrinsic function Current_Target_Exception - -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details). + -- Exception handler is active and retained and must be processed - if Hostparm.Java_VM then - declare - Arg : constant Node_Id := - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Current_Target_Exception), Loc)); - begin - Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg)); - end; + else + -- If an exception occurrence is present, then we must declare it + -- and initialize it from the value stored in the TSD - -- For the normal case, we have to worry about the state of abort - -- deferral. Generally, we defer abort during runtime handling of - -- exceptions. When control is passed to the handler, then in the - -- normal case we undefer aborts. In any case this entire handling - -- is relevant only if aborts are allowed! + -- declare + -- name : Exception_Occurrence; + -- begin + -- Save_Occurrence (name, Get_Current_Excep.all) + -- ... + -- end; - elsif Abort_Allowed then + if Present (Choice_Parameter (Handler)) then + declare + Cparm : constant Entity_Id := Choice_Parameter (Handler); + Clc : constant Source_Ptr := Sloc (Cparm); + Save : Node_Id; - -- There are some special cases in which we do not do the - -- undefer. In particular a finalization (AT END) handler - -- wants to operate with aborts still deferred. + begin + Save := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cparm, Clc), + Make_Explicit_Dereference (Loc, + Make_Function_Call (Loc, + Name => Make_Explicit_Dereference (Loc, + New_Occurrence_Of + (RTE (RE_Get_Current_Excep), Loc)))))); + + Mark_Rewrite_Insertion (Save); + Prepend (Save, Statements (Handler)); + + Obj_Decl := + Make_Object_Declaration + (Clc, + Defining_Identifier => Cparm, + Object_Definition => + New_Occurrence_Of + (RTE (RE_Exception_Occurrence), Clc)); + Set_No_Initialization (Obj_Decl, True); + + Rewrite (Handler, + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => Exception_Choices (Handler), + + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements (Handler)))))); + + Analyze_List (Statements (Handler), Suppress => All_Checks); + end; + end if; - -- We also suppress the call if this is the special handler - -- for Abort_Signal, since if we are aborting, we want to keep - -- aborts deferred (one abort is enough thank you very much :-) + -- The processing at this point is rather different for the JVM + -- case, so we completely separate the processing. - -- If abort really needs to be deferred the expander must add - -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select. + -- For the JVM case, we unconditionally call Update_Exception, + -- passing a call to the intrinsic Current_Target_Exception (see + -- JVM version of Ada.Exceptions in 4jexcept.adb for details). - Others_Choice := - Nkind (First (Exception_Choices (Handler))) = N_Others_Choice; + if Hostparm.Java_VM then + declare + Arg : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc)); + begin + Prepend_Call_To_Handler + (RE_Update_Exception, New_List (Arg)); + end; - if (Others_Choice - or else Entity (First (Exception_Choices (Handler))) /= - Stand.Abort_Signal) - and then not - (Others_Choice - and then All_Others (First (Exception_Choices (Handler)))) - and then Abort_Allowed - then - Prepend_Call_To_Handler (RE_Abort_Undefer); + -- For the normal case, we have to worry about the state of + -- abort deferral. Generally, we defer abort during runtime + -- handling of exceptions. When control is passed to the + -- handler, then in the normal case we undefer aborts. In any + -- case this entire handling is relevant only if aborts are + -- allowed! + + elsif Abort_Allowed then + + -- There are some special cases in which we do not do the + -- undefer. In particular a finalization (AT END) handler + -- wants to operate with aborts still deferred. + + -- We also suppress the call if this is the special handler + -- for Abort_Signal, since if we are aborting, we want to keep + -- aborts deferred (one abort is enough thank you very much :-) + + -- If abort really needs to be deferred the expander must add + -- this call explicitly, see Expand_N_Asynchronous_Select. + + Others_Choice := + Nkind (First (Exception_Choices (Handler))) = N_Others_Choice; + + if (Others_Choice + or else Entity (First (Exception_Choices (Handler))) /= + Stand.Abort_Signal) + and then not + (Others_Choice + and then All_Others (First (Exception_Choices (Handler)))) + and then Abort_Allowed + then + Prepend_Call_To_Handler (RE_Abort_Undefer); + end if; end if; end if; - Next_Non_Pragma (Handler); - - <<Continue_Handler_Loop>> - null; + Handler := Next_Handler; end loop Handler_Loop; - -- If all handlers got removed by gnatdN, then remove the list + -- If all handlers got removed, then remove the list - if Debug_Flag_Dot_X - and then Is_Empty_List (Exception_Handlers (HSS)) - then + if Is_Empty_List (Exception_Handlers (HSS)) then Set_Exception_Handlers (HSS, No_List); end if; end Expand_Exception_Handlers; @@ -492,21 +1194,19 @@ package body Exp_Ch11 is else Set_First_Real_Statement (N, First (Statements (N))); end if; - end Expand_N_Handled_Sequence_Of_Statements; ------------------------------------- -- Expand_N_Raise_Constraint_Error -- ------------------------------------- - -- The only processing required is to adjust the condition to deal - -- with the C/Fortran boolean case. This may well not be necessary, - -- as all such conditions are generated by the expander and probably - -- are all standard boolean, but who knows what strange optimization - -- in future may require this adjustment! - procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + Adjust_Condition (Condition (N)); end Expand_N_Raise_Constraint_Error; @@ -514,14 +1214,13 @@ package body Exp_Ch11 is -- Expand_N_Raise_Program_Error -- ---------------------------------- - -- The only processing required is to adjust the condition to deal - -- with the C/Fortran boolean case. This may well not be necessary, - -- as all such conditions are generated by the expander and probably - -- are all standard boolean, but who knows what strange optimization - -- in future may require this adjustment! - procedure Expand_N_Raise_Program_Error (N : Node_Id) is begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + Adjust_Condition (Condition (N)); end Expand_N_Raise_Program_Error; @@ -534,8 +1233,39 @@ package body Exp_Ch11 is Ehand : Node_Id; E : Entity_Id; Str : String_Id; + H : Node_Id; begin + -- Debug_Flag_Dot_G := True; + + -- Processing for locally handled exception (exclude reraise case) + + if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then + if Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation) + then + -- If we have a local handler, then note that this is potentially + -- able to be transformed into a goto statement. + + H := Find_Local_Handler (Entity (Name (N)), N); + + if Present (H) then + if Local_Raise_Statements (H) = No_Elist then + Set_Local_Raise_Statements (H, New_Elmt_List); + end if; + + -- Append the new entry if it is not there already. Sometimes + -- we have situations where due to reexpansion, the same node + -- is analyzed twice and would otherwise be added twice. + + Append_Unique_Elmt (N, Local_Raise_Statements (H)); + end if; + + else + Warn_If_No_Propagation (N); + end if; + end if; + -- If a string expression is present, then the raise statement is -- converted to a call: @@ -561,7 +1291,7 @@ package body Exp_Ch11 is -- There is no expansion needed for statement "raise <exception>;" when -- compiling for the JVM since the JVM has a built-in exception - -- mechanism. However we need the keep the expansion for "raise;" + -- mechanism. However we need to keep the expansion for "raise;" -- statements. See 4jexcept.ads for details. if Present (Name (N)) and then Hostparm.Java_VM then @@ -769,14 +1499,13 @@ package body Exp_Ch11 is -- Expand_N_Raise_Storage_Error -- ---------------------------------- - -- The only processing required is to adjust the condition to deal - -- with the C/Fortran boolean case. This may well not be necessary, - -- as all such conditions are generated by the expander and probably - -- are all standard boolean, but who knows what strange optimization - -- in future may require this adjustment! - procedure Expand_N_Raise_Storage_Error (N : Node_Id) is begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + Adjust_Condition (Condition (N)); end Expand_N_Raise_Storage_Error; @@ -801,6 +1530,149 @@ package body Exp_Ch11 is Analyze_And_Resolve (N, RTE (RE_Code_Loc)); end Expand_N_Subprogram_Info; + ------------------------ + -- Find_Local_Handler -- + ------------------------ + + function Find_Local_Handler + (Ename : Entity_Id; + Nod : Node_Id) return Node_Id + is + N : Node_Id; + P : Node_Id; + H : Node_Id; + C : Node_Id; + + ERaise : Entity_Id; + EHandle : Entity_Id; + -- The entity Id's for the exception we are raising and handling, using + -- the renamed exception if a Renamed_Entity is present. + + begin + -- Get the exception we are raising, allowing for renaming + + ERaise := Ename; + while Present (Renamed_Entity (ERaise)) loop + ERaise := Renamed_Entity (ERaise); + end loop; + + -- Loop to search up the tree + + N := Nod; + loop + P := Parent (N); + + -- If we get to the top of the tree, or to a subprogram, task, entry, + -- or protected body without having found a matching handler, then + -- there is no local handler. + + if No (P) + or else Nkind (P) = N_Subprogram_Body + or else Nkind (P) = N_Task_Body + or else Nkind (P) = N_Protected_Body + or else Nkind (P) = N_Entry_Body + then + return Empty; + + -- Test for handled sequence of statements, where we are in the + -- statement section (the exception handlers of a handled sequence + -- of statements do not cover themselves!) + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then Is_List_Member (N) + and then List_Containing (N) = Statements (P) + then + -- If we have exception handlers, look at them + + if Present (Exception_Handlers (P)) then + + -- Loop through exception handlers + + H := First (Exception_Handlers (P)); + while Present (H) loop + + -- Loop through choices in one handler + + C := First (Exception_Choices (H)); + while Present (C) loop + + -- Deal with others case + + if Nkind (C) = N_Others_Choice then + + -- Matching others handler, but we need to ensure + -- there is no choice parameter. If there is, then we + -- don't have a local handler after all (since we do + -- not allow choice parameters for local handlers). + + if No (Choice_Parameter (H)) then + return H; + else + return Empty; + end if; + + -- If not others must be entity name + + elsif Nkind (C) /= N_Others_Choice then + pragma Assert (Is_Entity_Name (C)); + pragma Assert (Present (Entity (C))); + + -- Get exception being handled, dealing with renaming + + EHandle := Entity (C); + while Present (Renamed_Entity (EHandle)) loop + EHandle := Renamed_Entity (EHandle); + end loop; + + -- If match, then check choice parameter + + if ERaise = EHandle then + if No (Choice_Parameter (H)) then + return H; + else + return Empty; + end if; + end if; + end if; + + Next (C); + end loop; + + Next (H); + end loop; + end if; + end if; + + N := P; + end loop; + end Find_Local_Handler; + + --------------------------------- + -- Get_Local_Raise_Call_Entity -- + --------------------------------- + + function Get_Local_Raise_Call_Entity return Entity_Id is + begin + if RTE_Available (RE_Local_Raise) then + return RTE (RE_Local_Raise); + else + return Empty; + end if; + end Get_Local_Raise_Call_Entity; + + ----------------------------- + -- Get_RT_Exception_Entity -- + ----------------------------- + + function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is + begin + case R is + when RT_CE_Exceptions => return Standard_Constraint_Error; + when RT_PE_Exceptions => return Standard_Program_Error; + when RT_SE_Exceptions => return Standard_Storage_Error; + end case; + end Get_RT_Exception_Entity; + ---------------------- -- Is_Non_Ada_Error -- ---------------------- @@ -824,4 +1696,26 @@ package body Exp_Ch11 is return True; end Is_Non_Ada_Error; + ---------------------------- + -- Warn_If_No_Propagation -- + ---------------------------- + + procedure Warn_If_No_Propagation (N : Node_Id) is + begin + if Restriction_Active (No_Exception_Propagation) + and then Warn_On_Non_Local_Exception + then + Error_Msg_N + ("?No_Exception_Propagation restriction is active", N); + + if Configurable_Run_Time_Mode then + Error_Msg_N + ("?Last_Chance_Handler will be called on exception", N); + else + Error_Msg_N + ("?program may terminate with unhandled exception", N); + end if; + end if; + end Warn_If_No_Propagation; + end Exp_Ch11; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index 85340d672df..354dcff1f10 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -56,6 +56,19 @@ package Exp_Ch11 is -- is also called to expand the special exception handler built for -- accept bodies (see Exp_Ch9.Build_Accept_Body). + function Get_Local_Raise_Call_Entity return Entity_Id; + -- This function is provided for use by the back end in conjunction with + -- generation of Local_Raise calls when an exception raise is converted to + -- a goto statement. If Local_Raise is defined, its entity is returned, + -- if not, Empty is returned (in which case the call is silently skipped). + + function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id; + -- This function is provided for use by the back end in conjunction with + -- generation of Local_Raise calls when an exception raise is converted to + -- a goto statement. The argument is the reason code which would be used + -- to determine which Rcheck_nn procedure to call. The returned result is + -- the exception entity to be passed to Local_Raise. + function Is_Non_Ada_Error (E : Entity_Id) return Boolean; -- This function is provided for Gigi use. It returns True if operating on -- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error. diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb index dbb7fb29086..d080a327cd2 100644 --- a/gcc/ada/exp_sel.adb +++ b/gcc/ada/exp_sel.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -63,7 +63,7 @@ package body Exp_Sel is Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, + Make_Implicit_Exception_Handler (Loc, Exception_Choices => New_List ( New_Reference_To (Stand.Abort_Signal, Loc)), diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 9895362a167..02f20e693d4 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -121,12 +121,15 @@ procedure Gnatbind is -- Define those restrictions that should be output if the gnatbind -- -r switch is used. Not all restrictions are output for the reasons - -- given above in the list, and this array is used to test whether + -- given below in the list, and this array is used to test whether -- the corresponding pragma should be listed. True means that it -- should not be listed. No_Restriction_List : constant array (All_Restrictions) of Boolean := - (No_Exceptions => True, + (No_Exception_Propagation => True, + -- Modifies code resulting in different exception semantics + + No_Exceptions => True, -- Has unexpected Suppress (All_Checks) effect No_Implicit_Conditionals => True, @@ -268,7 +271,7 @@ procedure Gnatbind is "procedure names missing in -L"); end if; - -- -Sin -Slo -Shi -Sxx + -- -Sin -Slo -Shi -Sxx -Sev elsif Argv'Length = 4 and then Argv (2) = 'S' diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 1dfbfdb36f9..ee8c72e8112 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -94,6 +94,7 @@ package body Ch11 is begin Handler_Node := New_Node (N_Exception_Handler, Token_Ptr); + Set_Local_Raise_Statements (Handler_Node, No_Elist); T_When; -- Test for possible choice parameter present diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 93fd6f0b045..c13537da39f 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -129,22 +129,32 @@ package body Restrict is Get_File_Name (U, Subunit => False); begin - if not Is_Predefined_File_Name (Fnam) then - return; + -- Get file name - -- Predefined spec, needs checking against list + Get_Name_String (Fnam); - else - -- Pad name to 8 characters with blanks + -- Nothing to do if name not at least 5 characters long ending + -- in .ads or .adb extension, which we strip. + + if Name_Len < 5 + or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" + and then + Name_Buffer (Name_Len - 4 .. Name_Len) /= ".adb") + then + return; + end if; - Get_Name_String (Fnam); - Name_Len := Name_Len - 4; + -- Strip extension and pad to eight characters - while Name_Len < 8 loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ' '; - end loop; + Name_Len := Name_Len - 4; + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + -- If predefined unit, check the list of restricted units + if Is_Predefined_File_Name (Fnam) then for J in Unit_Array'Range loop if Name_Len = 8 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm @@ -152,6 +162,15 @@ package body Restrict is Check_Restriction (Unit_Array (J).Res_Id, N); end if; end loop; + + -- If not predefied unit, then one special check still remains. + -- GNAT.Current_Exception is not allowed if we have restriction + -- No_Exception_Propagation active. + + else + if Name_Buffer (1 .. 8) = "g-curexc" then + Check_Restriction (No_Exception_Propagation, N); + end if; end if; end; end if; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index b873b18df77..b88e3691cba 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -74,6 +74,7 @@ package System.Rident is No_Entry_Calls_In_Elaboration_Code, -- GNAT No_Entry_Queue, -- GNAT (Ravenscar) No_Exception_Handlers, -- GNAT + No_Exception_Propagation, -- GNAT No_Exception_Registration, -- GNAT No_Exceptions, -- (RM H.4(12)) No_Finalization, -- GNAT diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 8c5a2a569e3..7967c364162 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -610,6 +610,12 @@ package body Sem is N_Mod_Clause | N_Modular_Type_Definition | N_Ordinary_Fixed_Point_Definition | + N_Pop_Constraint_Error_Label | + N_Pop_Program_Error_Label | + N_Pop_Storage_Error_Label | + N_Push_Constraint_Error_Label | + N_Push_Program_Error_Label | + N_Push_Storage_Error_Label | N_Parameter_Specification | N_Pragma_Argument_Association | N_Procedure_Specification | @@ -626,18 +632,24 @@ package body Sem is Debug_A_Exit ("analyzing ", N, " (done)"); - -- Now that we have analyzed the node, we call the expander to - -- perform possible expansion. This is done only for nodes that - -- are not subexpressions, because in the case of subexpressions, - -- we don't have the type yet, and the expander will need to know - -- the type before it can do its job. For subexpression nodes, the - -- call to the expander happens in the Sem_Res.Resolve. + -- Now that we have analyzed the node, we call the expander to perform + -- possible expansion. We skip this for subexpressions, because we don't + -- have the type yet, and the expander will need to know the type before + -- it can do its job. For subexpression nodes, the call to the expander + -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error, + -- which can appear in a statement context, and needs expanding now in + -- the case (distinguished by Etype, as documented in Sinfo). -- The Analyzed flag is also set at this point for non-subexpression - -- nodes (in the case of subexpression nodes, we can't set the flag - -- yet, since resolution and expansion have not yet been completed) - - if Nkind (N) not in N_Subexpr then + -- nodes (in the case of subexpression nodes, we can't set the flag yet, + -- since resolution and expansion have not yet been completed). Note + -- that for N_Raise_xxx_Error we have to distinguish the expression + -- case from the statement case. + + if Nkind (N) not in N_Subexpr + or else (Nkind (N) in N_Raise_xxx_Error + and then Etype (N) = Standard_Void_Type) + then Expand (N); end if; end Analyze; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 75ee081a16d..0f2245e33f8 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -55,16 +55,14 @@ package body Sem_Ch11 is procedure Analyze_Exception_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); PF : constant Boolean := Is_Pure (Current_Scope); - begin - Generate_Definition (Id); - Enter_Name (Id); - Set_Ekind (Id, E_Exception); - Set_Exception_Code (Id, Uint_0); - Set_Etype (Id, Standard_Exception_Type); - + Generate_Definition (Id); + Enter_Name (Id); + Set_Ekind (Id, E_Exception); + Set_Exception_Code (Id, Uint_0); + Set_Etype (Id, Standard_Exception_Type); Set_Is_Statically_Allocated (Id); - Set_Is_Pure (Id, PF); + Set_Is_Pure (Id, PF); end Analyze_Exception_Declaration; -------------------------------- @@ -182,28 +180,35 @@ package body Sem_Ch11 is -- Otherwise we have a real exception handler else - -- Deal with choice parameter. The exception handler is - -- a declarative part for it, so it constitutes a scope - -- for visibility purposes. We create an entity to denote - -- the whole exception part, and use it as the scope of all - -- the choices, which may even have the same name without - -- conflict. This scope plays no other role in expansion or - -- or code generation. + -- Deal with choice parameter. The exception handler is a + -- declarative part for the choice parameter, so it constitutes a + -- scope for visibility purposes. We create an entity to denote + -- the whole exception part, and use it as the scope of all the + -- choices, which may even have the same name without conflict. + -- This scope plays no other role in expansion or or code + -- generation. Choice := Choice_Parameter (Handler); if Present (Choice) then + Set_Local_Raise_Not_OK (Handler); + + if Comes_From_Source (Choice) then + Check_Restriction (No_Exception_Propagation, Choice); + end if; + if No (H_Scope) then - H_Scope := New_Internal_Entity - (E_Block, Current_Scope, Sloc (Choice), 'E'); + H_Scope := + New_Internal_Entity + (E_Block, Current_Scope, Sloc (Choice), 'E'); end if; New_Scope (H_Scope); Set_Etype (H_Scope, Standard_Void_Type); -- Set the Finalization Chain entity to Error means that it - -- should not be used at that level but the parent one - -- should be used instead. + -- should not be used at that level but the parent one should + -- be used instead. -- ??? this usage needs documenting in Einfo/Exp_Ch7 ??? -- ??? using Error for this non-error condition is nasty ??? @@ -215,8 +220,8 @@ package body Sem_Ch11 is Set_Etype (Choice, RTE (RE_Exception_Occurrence)); Generate_Definition (Choice); - -- Set source assigned flag, since in effect this field - -- is always assigned an initial value by the exception. + -- Set source assigned flag, since in effect this field is + -- always assigned an initial value by the exception. Set_Never_Set_In_Source (Choice, False); end if; @@ -234,8 +239,20 @@ package body Sem_Ch11 is else Analyze (Id); + -- In most cases the choice has already been analyzed in + -- Analyze_Handled_Statement_Sequence, in order to expand + -- local handlers. This advance analysis does not take into + -- account the case in which a choice has the same name as + -- the choice parameter of the handler, which may hide an + -- outer exception. This pathological case appears in ACATS + -- B80001_3.adb, and requires an explicit check to verify + -- that the id is not hidden. + if not Is_Entity_Name (Id) or else Ekind (Entity (Id)) /= E_Exception + or else + (Nkind (Id) = N_Identifier + and then Chars (Id) = Chars (Choice)) then Error_Msg_N ("exception name expected", Id); @@ -303,9 +320,9 @@ package body Sem_Ch11 is Next (Id); end loop; - -- Check for redundant handler (has only raise statement) and - -- is either an others handler, or is a specific handler when - -- no others handler is present. + -- Check for redundant handler (has only raise statement) and is + -- either an others handler, or is a specific handler when no + -- others handler is present. if Warn_On_Redundant_Constructs and then List_Length (Statements (Handler)) = 1 @@ -342,20 +359,45 @@ package body Sem_Ch11 is procedure Analyze_Handled_Statements (N : Node_Id) is Handlers : constant List_Id := Exception_Handlers (N); + Handler : Node_Id; + Choice : Node_Id; begin if Present (Handlers) then Kill_All_Checks; end if; + -- We are now going to analyze the statements and then the exception + -- handlers. We certainly need to do things in this order to get the + -- proper sequential semantics for various warnings. + + -- However, there is a glitch. When we process raise statements, an + -- optimization is to look for local handlers and specialize the code + -- in this case. + + -- In order to detect if a handler is matching, we must have at least + -- analyzed the choices in the proper scope so that proper visibility + -- analysis is performed. Hence we analyze just the choices first, + -- before we analyze the statement sequence. + + Handler := First_Non_Pragma (Handlers); + while Present (Handler) loop + Choice := First_Non_Pragma (Exception_Choices (Handler)); + while Present (Choice) loop + Analyze (Choice); + Next_Non_Pragma (Choice); + end loop; + + Next_Non_Pragma (Handler); + end loop; + -- Analyze statements in sequence Analyze_Statements (Statements (N)); - -- If the current scope is a subprogram, and there are no explicit - -- exception handlers, then this is the right place to check for - -- hanging useless assignments from the statement sequence of the - -- subprogram body. + -- If the current scope is a subprogram, then this is the right place to + -- check for hanging useless assignments from the statement sequence of + -- the subprogram body. if Is_Subprogram (Current_Scope) then Warn_On_Useless_Assignments (Current_Scope); @@ -389,9 +431,9 @@ package body Sem_Ch11 is Check_Restriction (No_Exceptions, N); end if; - -- Check for useless assignment to OUT or IN OUT scalar - -- immediately preceding the raise. Right now we only look - -- at assignment statements, we could do more. + -- Check for useless assignment to OUT or IN OUT scalar immediately + -- preceding the raise. Right now we only look at assignment statements, + -- we could do more. if Is_List_Member (N) then declare @@ -424,7 +466,6 @@ package body Sem_Ch11 is -- Reraise statement if No (Exception_Id) then - P := Parent (N); Nkind_P := Nkind (P); @@ -441,6 +482,14 @@ package body Sem_Ch11 is if Nkind (P) /= N_Exception_Handler then Error_Msg_N ("reraise statement must appear directly in a handler", N); + + -- If a handler has a reraise, it cannot be the target of a local + -- raise (goto optimization is impossible), and if the no exception + -- propagation restriction is set, this is a violation. + + else + Set_Local_Raise_Not_OK (P); + Check_Restriction (No_Exception_Propagation, N); end if; -- Normal case with exception id present diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index f7966b156a4..543379079d1 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -53,25 +53,46 @@ package body Tbuild is -- Add_Unique_Serial_Number -- ------------------------------ - procedure Add_Unique_Serial_Number is - Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); + Config_Serial_Number : Nat := 0; + -- Counter for use in config pragmas, see comment below + procedure Add_Unique_Serial_Number is begin - Add_Nat_To_Name_Buffer (Increment_Serial_Number); + -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will + -- not be set yet. This happens for example when analyzing static + -- string expressions in configuration pragmas. For this case, we + -- just maintain a local counter, defined above and we do not need + -- to add a b or s indication in this case. - -- Add either b or s, depending on whether current unit is a spec - -- or a body. This is needed because we may generate the same name - -- in a spec and a body otherwise. + if No (Cunit (Current_Sem_Unit)) then + Config_Serial_Number := Config_Serial_Number + 1; + Add_Nat_To_Name_Buffer (Config_Serial_Number); + return; - Name_Len := Name_Len + 1; + -- Normal case, within a unit - if Nkind (Unit_Node) = N_Package_Declaration - or else Nkind (Unit_Node) = N_Subprogram_Declaration - or else Nkind (Unit_Node) in N_Generic_Declaration - then - Name_Buffer (Name_Len) := 's'; else - Name_Buffer (Name_Len) := 'b'; + declare + Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); + + begin + Add_Nat_To_Name_Buffer (Increment_Serial_Number); + + -- Add either b or s, depending on whether current unit is a spec + -- or a body. This is needed because we may generate the same name + -- in a spec and a body otherwise. + + Name_Len := Name_Len + 1; + + if Nkind (Unit_Node) = N_Package_Declaration + or else Nkind (Unit_Node) = N_Subprogram_Declaration + or else Nkind (Unit_Node) in N_Generic_Declaration + then + Name_Buffer (Name_Len) := 's'; + else + Name_Buffer (Name_Len) := 'b'; + end if; + end; end if; end Add_Unique_Serial_Number; @@ -178,6 +199,24 @@ package body Tbuild is New_Reference_To (First_Tag_Component (Full_Type), Loc))); end Make_DT_Access; + ------------------------------------- + -- Make_Implicit_Exception_Handler -- + ------------------------------------- + + function Make_Implicit_Exception_Handler + (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) return Node_Id + is + Handler : constant Node_Id := + Make_Exception_Handler + (Sloc, Choice_Parameter, Exception_Choices, Statements); + begin + Set_Local_Raise_Statements (Handler, No_Elist); + return Handler; + end Make_Implicit_Exception_Handler; + -------------------------------- -- Make_Implicit_If_Statement -- -------------------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 4ffedaf7c8d..67fe5a1d153 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -74,6 +74,17 @@ package Tbuild is -- Create an access to the Dispatch Table by using the Tag field -- of a tagged record : Acc_Dt (Rec.tag).all + function Make_Implicit_Exception_Handler + (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) return Node_Id; + pragma Inline (Make_Implicit_Exception_Handler); + -- This is just like Make_Exception_Handler, except that it also sets the + -- Local_Raise_Statements field to No_Elist, ensuring that it is properly + -- initialized. This should always be used when creating exception handlers + -- as part of the expansion. + function Make_Implicit_If_Statement (Node : Node_Id; Condition : Node_Id; |