URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [exp_ch11.adb] - Blame information for rev 281

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ C H 1 1                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, 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
 
      --     <<L1>>          -- local excep target label, marked Exception_Junk
      --        begin        -- marked Exception_Junk
      --           estmts1
      --        end;
      --        goto L3;     -- marked Exception_Junk
 
      --     <<L2>>          -- marked Exception_Junk
      --        begin        -- marked Exception_Junk
      --           estmts2
      --        end;
      --        goto L3;     -- marked Exception_Junk
      --     <<L3>>          -- marked Exception_Junk
      --  end;
 
      --  Note: the reason we wrap the original statement sequence in an
      --  inner block is that there may be raise statements within the
      --  sequence of statements in the handlers, and we must ensure that
      --  these are properly handled, and in particular, such raise statements
      --  must not reenter the same exception handlers.
 
      --  If the restriction No_Exception_Propagation is in effect, then we
      --  can omit the exception handlers.
 
      --  begin
      --     L1 : label;                        -- marked Exception_Junk
      --     L2 : label;                        -- marked Exception_Junk
      --     L3 : label;                        -- marked Exception_Junk
 
      --     begin                              -- marked Exception_Junk
      --        ...
      --        local_raise (excep1'address);   -- was raise excep1
      --        goto L1;
      --        ...
      --        local_raise (excep2'address);   -- was raise excep2
      --        goto L2;
      --        ...
      --     end;
 
      --     goto L3;        -- skip handler if no raise, marked Exception_Junk
 
      --     <<L1>>          -- local excep target label, marked Exception_Junk
      --        begin        -- marked Exception_Junk
      --           estmts1
      --        end;
      --        goto L3;     -- marked Exception_Junk
 
      --     <<L2>>          -- marked Exception_Junk
      --        begin        -- marked Exception_Junk
      --           estmts2
      --        end;
 
      --     <<L3>>          -- marked Exception_Junk
      --  end;
 
      --  The second case is for exceptions generated by the back end in one
      --  of three situations:
 
      --    1. Front end generates N_Raise_xxx_Error node
      --    2. Front end sets Do_xxx_Check flag in subexpression node
      --    3. Back end detects a situation where an exception is appropriate
 
      --  In all these cases, the current processing in gigi is to generate a
      --  call to the appropriate Rcheck_xx routine (where xx encodes both the
      --  exception message and the exception to be raised, Constraint_Error,
      --  Program_Error, or Storage_Error.
 
      --  We could handle some subcases of 1 using the same front end expansion
      --  into gotos, but even for case 1, we can't handle all cases, since
      --  generating gotos in the middle of expressions is not possible (it's
      --  possible at the gigi/gcc level, but not at the level of the GNAT
      --  tree).
 
      --  In any case, it seems easier to have a scheme which handles all three
      --  cases in a uniform manner. So here is how we proceed in this case.
 
      --  This procedure detects all handlers for these three exceptions,
      --  Constraint_Error, Program_Error and Storage_Error (including WHEN
      --  OTHERS handlers that cover one or more of these cases).
 
      --  If the handler meets the requirements for being the target of a local
      --  raise, then the front end does the expansion described previously,
      --  creating a label to be used as a goto target to raise the exception.
      --  However, no attempt is made in the front end to convert any related
      --  raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
      --  left unchanged and passed to the back end.
 
      --  Instead, the front end generates two nodes
 
      --     N_Push_Constraint_Error_Label
      --     N_Push_Program_Error_Label
      --     N_Push_Storage_Error_Label
 
      --       The Push node is generated at the start of the statements
      --       covered by the handler, and has as a parameter the label to be
      --       used as the raise target.
 
      --     N_Pop_Constraint_Error_Label
      --     N_Pop_Program_Error_Label
      --     N_Pop_Storage_Error_Label
 
      --       The Pop node is generated at the end of the covered statements
      --       and undoes the effect of the preceding corresponding Push node.
 
      --  In the case where the handler does NOT meet the requirements, the
      --  front end will still generate the Push and Pop nodes, but the label
      --  field in the Push node will be empty signifying that for this region
      --  of code, no optimization is possible.
 
      --  The back end must maintain three stacks, one for each exception case,
      --  the Push node pushes an entry onto the corresponding stack, and Pop
      --  node pops off the entry. Then instead of calling Rcheck_nn, if the
      --  corresponding top stack entry has an non-empty label, a goto is
      --  generated. This goto should be preceded by a call to Local_Raise as
      --  described above.
 
      --  An example of this transformation is as follows, given:
 
      --  declare
      --    A : Integer range 1 .. 10;
      --  begin
      --    A := B + C;
      --  exception
      --    when Constraint_Error =>
      --       estmts
      --  end;
 
      --  gets transformed to:
 
      --  declare
      --    A : Integer range 1 .. 10;
 
      --  begin
      --     L1 : label;
      --     L2 : label;
 
      --     begin
      --        %push_constraint_error_label (L1)
      --        R1b : constant long_long_integer := long_long_integer?(b) +
      --          long_long_integer?(c);
      --        [constraint_error when
      --          not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
      --          "overflow check failed"]
      --        a := integer?(R1b);
      --        %pop_constraint_error_Label
 
      --     exception
      --        ...
      --        when constraint_error =>
      --           goto L1;
      --     end;
 
      --     goto L2;       -- skip handler when exception not raised
      --     <<L1>>         -- target label for local exception
      --     estmts
      --     <<L2>>
      --  end;
 
      --  Note: the generated labels and goto statements all have the flag
      --  Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
      --  this generated exception stuff when checking for missing return
      --  statements (see circuitry in Check_Statement_Sequence).
 
      --  Note: All of the processing described above occurs only if
      --  restriction No_Exception_Propagation applies or debug flag .g is
      --  enabled.
 
      CE_Locally_Handled : Boolean := False;
      SE_Locally_Handled : Boolean := False;
      PE_Locally_Handled : Boolean := False;
      --  These three flags indicate whether a handler for the corresponding
      --  exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
      --  is present. If so the switch is set to True, the Exception_Label
      --  field of the corresponding handler is set, and appropriate Push
      --  and Pop nodes are inserted into the code.
 
      Local_Expansion_Required : Boolean := False;
      --  Set True if we have at least one handler requiring local raise
      --  expansion as described above.
 
      procedure Expand_Local_Exception_Handlers is
 
         procedure Add_Exception_Label (H : Node_Id);
         --  H is an exception handler. First check for an Exception_Label
         --  already allocated for H. If none, allocate one, set the field in
         --  the handler node, add the label declaration, and set the flag
         --  Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
         --  the call has no effect and Exception_Label is left empty.
 
         procedure Add_Label_Declaration (L : Entity_Id);
         --  Add an implicit declaration of the given label to the declaration
         --  list in the parent of the current sequence of handled statements.
 
         generic
            Exc_Locally_Handled : in out Boolean;
            --  Flag indicating whether a local handler for this exception
            --  has already been generated.
 
            with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
            --  Function to create a Push_xxx_Label node
 
            with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
            --  Function to create a Pop_xxx_Label node
 
         procedure Generate_Push_Pop (H : Node_Id);
         --  Common code for Generate_Push_Pop_xxx below, used to generate an
         --  exception label and Push/Pop nodes for Constraint_Error,
         --  Program_Error, or Storage_Error.
 
         -------------------------
         -- Add_Exception_Label --
         -------------------------
 
         procedure Add_Exception_Label (H : Node_Id) is
         begin
            if No (Exception_Label (H))
              and then not Local_Raise_Not_OK (H)
              and then not Special_Exception_Package_Used
            then
               Local_Expansion_Required := True;
 
               declare
                  L : constant Entity_Id :=
                        Make_Defining_Identifier (Sloc (H),
                          Chars => New_Internal_Name ('L'));
               begin
                  Set_Exception_Label (H, L);
                  Add_Label_Declaration (L);
               end;
            end if;
         end Add_Exception_Label;
 
         ---------------------------
         -- Add_Label_Declaration --
         ---------------------------
 
         procedure Add_Label_Declaration (L : Entity_Id) is
            P : constant Node_Id := Parent (HSS);
 
            Decl_L : constant Node_Id :=
                       Make_Implicit_Label_Declaration (Loc,
                         Defining_Identifier => L);
 
         begin
            if Declarations (P) = No_List then
               Set_Declarations (P, Empty_List);
            end if;
 
            Append (Decl_L, Declarations (P));
            Analyze (Decl_L);
         end Add_Label_Declaration;
 
         -----------------------
         -- Generate_Push_Pop --
         -----------------------
 
         procedure Generate_Push_Pop (H : Node_Id) is
         begin
            if Exc_Locally_Handled then
               return;
            else
               Exc_Locally_Handled := True;
            end if;
 
            Add_Exception_Label (H);
 
            declare
               F : constant Node_Id := First (Statements (HSS));
               L : constant Node_Id := Last  (Statements (HSS));
 
               Push : constant Node_Id := Make_Push_Label (Sloc (F));
               Pop  : constant Node_Id := Make_Pop_Label  (Sloc (L));
 
            begin
               --  We make sure that a call to Get_Local_Raise_Call_Entity is
               --  made during front end processing, so that when we need it
               --  in the back end, it will already be available and loaded.
 
               Discard_Node (Get_Local_Raise_Call_Entity);
 
               --  Prepare and insert Push and Pop nodes
 
               Set_Exception_Label (Push, Exception_Label (H));
               Insert_Before (F, Push);
               Set_Analyzed (Push);
 
               Insert_After (L, Pop);
               Set_Analyzed (Pop);
            end;
         end Generate_Push_Pop;
 
         --  Local declarations
 
         Loc    : constant Source_Ptr := Sloc (HSS);
         Stmts  : List_Id := No_List;
         Choice : Node_Id;
         Excep  : Entity_Id;
 
         procedure Generate_Push_Pop_For_Constraint_Error is
           new Generate_Push_Pop
             (Exc_Locally_Handled => CE_Locally_Handled,
              Make_Push_Label     => Make_Push_Constraint_Error_Label,
              Make_Pop_Label      => Make_Pop_Constraint_Error_Label);
         --  If no Push/Pop has been generated for CE yet, then set the flag
         --  CE_Locally_Handled, allocate an Exception_Label for handler H (if
         --  not already done), and generate Push/Pop nodes for the exception
         --  label at the start and end of the statements of HSS.
 
         procedure Generate_Push_Pop_For_Program_Error is
           new Generate_Push_Pop
             (Exc_Locally_Handled => PE_Locally_Handled,
              Make_Push_Label     => Make_Push_Program_Error_Label,
              Make_Pop_Label      => Make_Pop_Program_Error_Label);
         --  If no Push/Pop has been generated for PE yet, then set the flag
         --  PE_Locally_Handled, allocate an Exception_Label for handler H (if
         --  not already done), and generate Push/Pop nodes for the exception
         --  label at the start and end of the statements of HSS.
 
         procedure Generate_Push_Pop_For_Storage_Error is
           new Generate_Push_Pop
             (Exc_Locally_Handled => SE_Locally_Handled,
              Make_Push_Label     => Make_Push_Storage_Error_Label,
              Make_Pop_Label      => Make_Pop_Storage_Error_Label);
         --  If no Push/Pop has been generated for SE yet, then set the flag
         --  SE_Locally_Handled, allocate an Exception_Label for handler H (if
         --  not already done), and generate Push/Pop nodes for the exception
         --  label at the start and end of the statements of HSS.
 
      --  Start of processing for Expand_Local_Exception_Handlers
 
      begin
         --  No processing if all exception handlers will get removed
 
         if Debug_Flag_Dot_X then
            return;
         end if;
 
         --  See for each handler if we have any local raises to expand
 
         Handler := First_Non_Pragma (Handlrs);
         while Present (Handler) loop
 
            --  Note, we do not test Local_Raise_Not_OK here, because in the
            --  case of Push/Pop generation we want to generate push with a
            --  null label. The Add_Exception_Label routine has no effect if
            --  Local_Raise_Not_OK is set, so this works as required.
 
            if Present (Local_Raise_Statements (Handler)) then
               Add_Exception_Label (Handler);
            end if;
 
            --  If we are doing local raise to goto optimization (restriction
            --  No_Exception_Propagation set or debug flag .g set), then check
            --  to see if handler handles CE, PE, SE and if so generate the
            --  appropriate push/pop sequence for the back end.
 
            if (Debug_Flag_Dot_G
                 or else Restriction_Active (No_Exception_Propagation))
              and then Has_Local_Raise (Handler)
            then
               Choice := First (Exception_Choices (Handler));
               while Present (Choice) loop
                  if Nkind (Choice) = N_Others_Choice
                    and then not All_Others (Choice)
                  then
                     Generate_Push_Pop_For_Constraint_Error (Handler);
                     Generate_Push_Pop_For_Program_Error    (Handler);
                     Generate_Push_Pop_For_Storage_Error    (Handler);
 
                  elsif Is_Entity_Name (Choice) then
                     Excep := Get_Renamed_Entity (Entity (Choice));
 
                     if Excep = Standard_Constraint_Error then
                        Generate_Push_Pop_For_Constraint_Error (Handler);
                     elsif Excep = Standard_Program_Error then
                        Generate_Push_Pop_For_Program_Error    (Handler);
                     elsif Excep = Standard_Storage_Error then
                        Generate_Push_Pop_For_Storage_Error    (Handler);
                     end if;
                  end if;
 
                  Next (Choice);
               end loop;
            end if;
 
            Next_Non_Pragma (Handler);
         end loop;
 
         --  Nothing to do if no handlers requiring the goto transformation
 
         if not (Local_Expansion_Required) then
            return;
         end if;
 
         --  Prepare to do the transformation
 
         declare
            --  L3 is the label to exit the HSS
 
            L3_Dent : constant Entity_Id :=
                        Make_Defining_Identifier (Loc,
                          Chars => New_Internal_Name ('L'));
 
            Labl_L3 : constant Node_Id :=
                        Make_Label (Loc,
                          Identifier => New_Occurrence_Of (L3_Dent, Loc));
 
            Blk_Stm : Node_Id;
            Relmt   : Elmt_Id;
 
         begin
            Set_Exception_Junk (Labl_L3);
            Add_Label_Declaration (L3_Dent);
 
            --  Wrap existing statements and handlers in an inner block
 
            Blk_Stm :=
              Make_Block_Statement (Loc,
                Handled_Statement_Sequence => Relocate_Node (HSS));
            Set_Exception_Junk (Blk_Stm);
 
            Rewrite (HSS,
              Make_Handled_Sequence_Of_Statements (Loc,
                Statements => New_List (Blk_Stm)));
 
            --  Set block statement as analyzed, we don't want to actually call
            --  Analyze on this block, it would cause a recursion in exception
            --  handler processing which would mess things up.
 
            Set_Analyzed (Blk_Stm);
 
            --  Now loop through the exception handlers to deal with those that
            --  are targets of local raise statements.
 
            Handler := First_Non_Pragma (Handlrs);
            while Present (Handler) loop
               if Present (Exception_Label (Handler)) then
 
                  --  This handler needs the goto expansion
 
                  declare
                     Loc : constant Source_Ptr := Sloc (Handler);
 
                     --  L1 is the start label for this handler
 
                     L1_Dent : constant Entity_Id := Exception_Label (Handler);
 
                     Labl_L1 : constant Node_Id :=
                                 Make_Label (Loc,
                                   Identifier =>
                                     New_Occurrence_Of (L1_Dent, Loc));
 
                     --  Jump to L1 to be used as replacement for the original
                     --  handler (used in the case where exception propagation
                     --  may still occur).
 
                     Name_L1 : constant Node_Id :=
                                 New_Occurrence_Of (L1_Dent, Loc);
 
                     Goto_L1 : constant Node_Id :=
                                 Make_Goto_Statement (Loc,
                                   Name => Name_L1);
 
                     --  Jump to L3 to be used at the end of handler
 
                     Name_L3 : constant Node_Id :=
                                 New_Occurrence_Of (L3_Dent, Loc);
 
                     Goto_L3 : constant Node_Id :=
                                 Make_Goto_Statement (Loc,
                                   Name => Name_L3);
 
                     H_Stmts : constant List_Id := Statements (Handler);
 
                  begin
                     Set_Exception_Junk (Labl_L1);
                     Set_Exception_Junk (Goto_L3);
 
                     --  Note: we do NOT set Exception_Junk in Goto_L1, since
                     --  this is a real transfer of control that we want the
                     --  Sem_Ch6.Check_Returns procedure to recognize properly.
 
                     --  Replace handler by a goto L1. We can mark this as
                     --  analyzed since it is fully formed, and we don't
                     --  want it going through any further checks. We save
                     --  the last statement location in the goto L1 node for
                     --  the benefit of Sem_Ch6.Check_Returns.
 
                     Set_Statements (Handler, New_List (Goto_L1));
                     Set_Analyzed (Goto_L1);
                     Set_Etype (Name_L1, Standard_Void_Type);
 
                     --  Now replace all the raise statements by goto L1
 
                     if Present (Local_Raise_Statements (Handler)) then
                        Relmt := First_Elmt (Local_Raise_Statements (Handler));
                        while Present (Relmt) loop
                           declare
                              Raise_S : constant Node_Id := Node (Relmt);
 
                              Name_L1 : constant Node_Id :=
                                          New_Occurrence_Of (L1_Dent, Loc);
 
                              Goto_L1 : constant Node_Id :=
                                          Make_Goto_Statement (Loc,
                                            Name => Name_L1);
 
                           begin
                              --  Replace raise by goto L1
 
                              Set_Analyzed (Goto_L1);
                              Set_Etype (Name_L1, Standard_Void_Type);
                              Replace_Raise_By_Goto (Raise_S, Goto_L1);
                           end;
 
                           Next_Elmt (Relmt);
                        end loop;
                     end if;
 
                     --  Add a goto L3 at end of statement list in block. The
                     --  first time, this is what skips over the exception
                     --  handlers in the normal case. Subsequent times, it
                     --  terminates the execution of the previous handler code,
                     --  and skips subsequent handlers.
 
                     Stmts := Statements (HSS);
 
                     Insert_After (Last (Stmts), Goto_L3);
                     Set_Analyzed (Goto_L3);
                     Set_Etype (Name_L3, Standard_Void_Type);
 
                     --  Now we drop the label that marks the handler start,
                     --  followed by the statements of the handler.
 
                     Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
 
                     Insert_After_And_Analyze (Last (Stmts), Labl_L1);
 
                     declare
                        Loc : constant Source_Ptr := Sloc (First (H_Stmts));
                        Blk : constant Node_Id :=
                                Make_Block_Statement (Loc,
                                  Handled_Statement_Sequence =>
                                    Make_Handled_Sequence_Of_Statements (Loc,
                                      Statements => H_Stmts));
                     begin
                        Set_Exception_Junk (Blk);
                        Insert_After_And_Analyze (Last (Stmts), Blk);
                     end;
                  end;
 
                  --  Here if we have local raise statements but the handler is
                  --  not suitable for processing with a local raise. In this
                  --  case we have to generate possible diagnostics.
 
               elsif Has_Local_Raise (Handler)
                 and then Local_Raise_Statements (Handler) /= No_Elist
               then
                  Relmt := First_Elmt (Local_Raise_Statements (Handler));
                  while Present (Relmt) loop
                     Warn_If_No_Propagation (Node (Relmt));
                     Next_Elmt (Relmt);
                  end loop;
               end if;
 
               Next (Handler);
            end loop;
 
            --  Only remaining step is to drop the L3 label and we are done
 
            Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
 
            --  If we had at least one handler, then we drop the label after
            --  the last statement of that handler.
 
            if Stmts /= No_List then
               Insert_After_And_Analyze (Last (Stmts), Labl_L3);
 
            --  Otherwise we have removed all the handlers (this results from
            --  use of pragma Restrictions (No_Exception_Propagation), and we
            --  drop the label at the end of the statements of the HSS.
 
            else
               Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
            end if;
 
            return;
         end;
      end Expand_Local_Exception_Handlers;
 
      -----------------------------
      -- 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 4jexcept.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 => Full_Qualified_Name (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.
 
      --  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 to keep the expansion for "raise;"
      --  statements. See 4jexcept.ads for details.
 
      if Present (Name (N)) and then VM_Target /= No_VM then
         return;
      end if;
 
      --  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_Defining_Identifier (Loc, New_Internal_Name ('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_Active (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;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [exp_ch11.adb] - Blame information for rev 281

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- E X P _ C H 1 1 --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Atree; use Atree;`
27			`with Casing; use Casing;`
28			`with Debug; use Debug;`
29			`with Einfo; use Einfo;`
30			`with Elists; use Elists;`
31			`with Errout; use Errout;`
32			`with Exp_Ch7; use Exp_Ch7;`
33			`with Exp_Util; use Exp_Util;`
34			`with Namet; use Namet;`
35			`with Nlists; use Nlists;`
36			`with Nmake; use Nmake;`
37			`with Opt; use Opt;`
38			`with Restrict; use Restrict;`
39			`with Rident; use Rident;`
40			`with Rtsfind; use Rtsfind;`