File : exp_ch11.adb


   1 ------------------------------------------------------------------------------
   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-2016, 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 Debug;    use Debug;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Ch7;  use Exp_Ch7;
  32 with Exp_Intr; use Exp_Intr;
  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;
  41 with Sem;      use Sem;
  42 with Sem_Ch8;  use Sem_Ch8;
  43 with Sem_Res;  use Sem_Res;
  44 with Sem_Util; use Sem_Util;
  45 with Sinfo;    use Sinfo;
  46 with Sinput;   use Sinput;
  47 with Snames;   use Snames;
  48 with Stand;    use Stand;
  49 with Stringt;  use Stringt;
  50 with Targparm; use Targparm;
  51 with Tbuild;   use Tbuild;
  52 with Uintp;    use Uintp;
  53 
  54 package body Exp_Ch11 is
  55 
  56    -----------------------
  57    -- Local Subprograms --
  58    -----------------------
  59 
  60    procedure Warn_No_Exception_Propagation_Active (N : Node_Id);
  61    --  Generates warning that pragma Restrictions (No_Exception_Propagation)
  62    --  is in effect. Caller then generates appropriate continuation message.
  63    --  N is the node on which the warning is placed.
  64 
  65    procedure Warn_If_No_Propagation (N : Node_Id);
  66    --  Called for an exception raise that is not a local raise (and thus can
  67    --  not be optimized to a goto. Issues warning if No_Exception_Propagation
  68    --  restriction is set. N is the node for the raise or equivalent call.
  69 
  70    ---------------------------
  71    -- Expand_At_End_Handler --
  72    ---------------------------
  73 
  74    --  For a handled statement sequence that has a cleanup (At_End_Proc
  75    --  field set), an exception handler of the following form is required:
  76 
  77    --     exception
  78    --       when all others =>
  79    --          cleanup call
  80    --          raise;
  81 
  82    --  Note: this exception handler is treated rather specially by
  83    --  subsequent expansion in two respects:
  84 
  85    --    The normal call to Undefer_Abort is omitted
  86    --    The raise call does not do Defer_Abort
  87 
  88    --  This is because the current tasking code seems to assume that
  89    --  the call to the cleanup routine that is made from an exception
  90    --  handler for the abort signal is called with aborts deferred.
  91 
  92    --  This expansion is only done if we have front end exception handling.
  93    --  If we have back end exception handling, then the AT END handler is
  94    --  left alone, and cleanups (including the exceptional case) are handled
  95    --  by the back end.
  96 
  97    --  In the front end case, the exception handler described above handles
  98    --  the exceptional case. The AT END handler is left in the generated tree
  99    --  and the code generator (e.g. gigi) must still handle proper generation
 100    --  of cleanup calls for the non-exceptional case.
 101 
 102    procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is
 103       Clean   : constant Entity_Id  := Entity (At_End_Proc (HSS));
 104       Ohandle : Node_Id;
 105       Stmnts  : List_Id;
 106 
 107       Loc : constant Source_Ptr := No_Location;
 108       --  Location used for expansion. We quite deliberately do not set a
 109       --  specific source location for the expanded handler. This makes
 110       --  sense since really the handler is not associated with specific
 111       --  source. We used to set this to Sloc (Clean), but that caused
 112       --  useless and annoying bouncing around of line numbers in the
 113       --  debugger in some circumstances.
 114 
 115    begin
 116       pragma Assert (Present (Clean));
 117       pragma Assert (No (Exception_Handlers (HSS)));
 118 
 119       --  Back end exception schemes don't need explicit handlers to
 120       --  trigger AT-END actions on exceptional paths.
 121 
 122       if Back_End_Exceptions then
 123          return;
 124       end if;
 125 
 126       --  Don't expand an At End handler if we have already had configurable
 127       --  run-time violations, since likely this will just be a matter of
 128       --  generating useless cascaded messages
 129 
 130       if Configurable_Run_Time_Violations > 0 then
 131          return;
 132       end if;
 133 
 134       --  Don't expand an At End handler if we are not allowing exceptions
 135       --  or if exceptions are transformed into local gotos, and never
 136       --  propagated (No_Exception_Propagation).
 137 
 138       if No_Exception_Handlers_Set then
 139          return;
 140       end if;
 141 
 142       if Present (Blk_Id) then
 143          Push_Scope (Blk_Id);
 144       end if;
 145 
 146       Ohandle :=
 147         Make_Others_Choice (Loc);
 148       Set_All_Others (Ohandle);
 149 
 150       Stmnts := New_List (
 151         Make_Procedure_Call_Statement (Loc,
 152           Name => New_Occurrence_Of (Clean, Loc)));
 153 
 154       --  Generate reraise statement as last statement of AT-END handler,
 155       --  unless we are under control of No_Exception_Propagation, in which
 156       --  case no exception propagation is possible anyway, so we do not need
 157       --  a reraise (the AT END handler in this case is only for normal exits
 158       --  not for exceptional exits). Also, we flag the Reraise statement as
 159       --  being part of an AT END handler to prevent signalling this reraise
 160       --  as a violation of the restriction when it is not set.
 161 
 162       if not Restriction_Active (No_Exception_Propagation) then
 163          declare
 164             Rstm : constant Node_Id := Make_Raise_Statement (Loc);
 165          begin
 166             Set_From_At_End (Rstm);
 167             Append_To (Stmnts, Rstm);
 168          end;
 169       end if;
 170 
 171       Set_Exception_Handlers (HSS, New_List (
 172         Make_Implicit_Exception_Handler (Loc,
 173           Exception_Choices => New_List (Ohandle),
 174           Statements        => Stmnts)));
 175 
 176       Analyze_List (Stmnts, Suppress => All_Checks);
 177       Expand_Exception_Handlers (HSS);
 178 
 179       if Present (Blk_Id) then
 180          Pop_Scope;
 181       end if;
 182    end Expand_At_End_Handler;
 183 
 184    -------------------------------
 185    -- Expand_Exception_Handlers --
 186    -------------------------------
 187 
 188    procedure Expand_Exception_Handlers (HSS : Node_Id) is
 189       Handlrs       : constant List_Id    := Exception_Handlers (HSS);
 190       Loc           : constant Source_Ptr := Sloc (HSS);
 191       Handler       : Node_Id;
 192       Others_Choice : Boolean;
 193       Obj_Decl      : Node_Id;
 194       Next_Handler  : Node_Id;
 195 
 196       procedure Expand_Local_Exception_Handlers;
 197       --  This procedure handles the expansion of exception handlers for the
 198       --  optimization of local raise statements into goto statements.
 199 
 200       procedure Prepend_Call_To_Handler
 201         (Proc : RE_Id;
 202          Args : List_Id := No_List);
 203       --  Routine to prepend a call to the procedure referenced by Proc at
 204       --  the start of the handler code for the current Handler.
 205 
 206       procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
 207       --  Raise_S is a raise statement (possibly expanded, and possibly of the
 208       --  form of a Raise_xxx_Error node with a condition. This procedure is
 209       --  called to replace the raise action with the (already analyzed) goto
 210       --  statement passed as Goto_L1. This procedure also takes care of the
 211       --  requirement of inserting a Local_Raise call where possible.
 212 
 213       -------------------------------------
 214       -- Expand_Local_Exception_Handlers --
 215       -------------------------------------
 216 
 217       --  There are two cases for this transformation. First the case of
 218       --  explicit raise statements. For this case, the transformation we do
 219       --  looks like this. Right now we have for example (where L1, L2 are
 220       --  exception labels)
 221 
 222       --  begin
 223       --     ...
 224       --     raise_exception (excep1'identity);  -- was raise excep1
 225       --     ...
 226       --     raise_exception (excep2'identity);  -- was raise excep2
 227       --     ...
 228       --  exception
 229       --     when excep1 =>
 230       --        estmts1
 231       --     when excep2 =>
 232       --        estmts2
 233       --  end;
 234 
 235       --  This gets transformed into:
 236 
 237       --  begin
 238       --     L1 : label;                        -- marked Exception_Junk
 239       --     L2 : label;                        -- marked Exception_Junk
 240       --     L3 : label;                        -- marked Exception_Junk
 241 
 242       --     begin                              -- marked Exception_Junk
 243       --        ...
 244       --        local_raise (excep1'address);   -- was raise excep1
 245       --        goto L1;
 246       --        ...
 247       --        local_raise (excep2'address);   -- was raise excep2
 248       --        goto L2;
 249       --        ...
 250       --     exception
 251       --        when excep1 =>
 252       --           goto L1;
 253       --        when excep2 =>
 254       --           goto L2;
 255       --     end;
 256 
 257       --     goto L3;        -- skip handler if no raise, marked Exception_Junk
 258 
 259       --     <<L1>>          -- local excep target label, marked Exception_Junk
 260       --        begin        -- marked Exception_Junk
 261       --           estmts1
 262       --        end;
 263       --        goto L3;     -- marked Exception_Junk
 264 
 265       --     <<L2>>          -- marked Exception_Junk
 266       --        begin        -- marked Exception_Junk
 267       --           estmts2
 268       --        end;
 269       --        goto L3;     -- marked Exception_Junk
 270       --     <<L3>>          -- marked Exception_Junk
 271       --  end;
 272 
 273       --  Note: the reason we wrap the original statement sequence in an
 274       --  inner block is that there may be raise statements within the
 275       --  sequence of statements in the handlers, and we must ensure that
 276       --  these are properly handled, and in particular, such raise statements
 277       --  must not reenter the same exception handlers.
 278 
 279       --  If the restriction No_Exception_Propagation is in effect, then we
 280       --  can omit the exception handlers.
 281 
 282       --  begin
 283       --     L1 : label;                        -- marked Exception_Junk
 284       --     L2 : label;                        -- marked Exception_Junk
 285       --     L3 : label;                        -- marked Exception_Junk
 286 
 287       --     begin                              -- marked Exception_Junk
 288       --        ...
 289       --        local_raise (excep1'address);   -- was raise excep1
 290       --        goto L1;
 291       --        ...
 292       --        local_raise (excep2'address);   -- was raise excep2
 293       --        goto L2;
 294       --        ...
 295       --     end;
 296 
 297       --     goto L3;        -- skip handler if no raise, marked Exception_Junk
 298 
 299       --     <<L1>>          -- local excep target label, marked Exception_Junk
 300       --        begin        -- marked Exception_Junk
 301       --           estmts1
 302       --        end;
 303       --        goto L3;     -- marked Exception_Junk
 304 
 305       --     <<L2>>          -- marked Exception_Junk
 306       --        begin        -- marked Exception_Junk
 307       --           estmts2
 308       --        end;
 309 
 310       --     <<L3>>          -- marked Exception_Junk
 311       --  end;
 312 
 313       --  The second case is for exceptions generated by the back end in one
 314       --  of three situations:
 315 
 316       --    1. Front end generates N_Raise_xxx_Error node
 317       --    2. Front end sets Do_xxx_Check flag in subexpression node
 318       --    3. Back end detects a situation where an exception is appropriate
 319 
 320       --  In all these cases, the current processing in gigi is to generate a
 321       --  call to the appropriate Rcheck_xx routine (where xx encodes both the
 322       --  exception message and the exception to be raised, Constraint_Error,
 323       --  Program_Error, or Storage_Error.
 324 
 325       --  We could handle some subcases of 1 using the same front end expansion
 326       --  into gotos, but even for case 1, we can't handle all cases, since
 327       --  generating gotos in the middle of expressions is not possible (it's
 328       --  possible at the gigi/gcc level, but not at the level of the GNAT
 329       --  tree).
 330 
 331       --  In any case, it seems easier to have a scheme which handles all three
 332       --  cases in a uniform manner. So here is how we proceed in this case.
 333 
 334       --  This procedure detects all handlers for these three exceptions,
 335       --  Constraint_Error, Program_Error and Storage_Error (including WHEN
 336       --  OTHERS handlers that cover one or more of these cases).
 337 
 338       --  If the handler meets the requirements for being the target of a local
 339       --  raise, then the front end does the expansion described previously,
 340       --  creating a label to be used as a goto target to raise the exception.
 341       --  However, no attempt is made in the front end to convert any related
 342       --  raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
 343       --  left unchanged and passed to the back end.
 344 
 345       --  Instead, the front end generates three nodes
 346 
 347       --     N_Push_Constraint_Error_Label
 348       --     N_Push_Program_Error_Label
 349       --     N_Push_Storage_Error_Label
 350 
 351       --       The Push node is generated at the start of the statements
 352       --       covered by the handler, and has as a parameter the label to be
 353       --       used as the raise target.
 354 
 355       --     N_Pop_Constraint_Error_Label
 356       --     N_Pop_Program_Error_Label
 357       --     N_Pop_Storage_Error_Label
 358 
 359       --       The Pop node is generated at the end of the covered statements
 360       --       and undoes the effect of the preceding corresponding Push node.
 361 
 362       --  In the case where the handler does NOT meet the requirements, the
 363       --  front end will still generate the Push and Pop nodes, but the label
 364       --  field in the Push node will be empty signifying that for this region
 365       --  of code, no optimization is possible.
 366 
 367       --  These Push/Pop nodes are inhibited if No_Exception_Handlers is set
 368       --  since they are useless in this case, and in CodePeer mode, where
 369       --  they serve no purpose and can intefere with the analysis.
 370 
 371       --  The back end must maintain three stacks, one for each exception case,
 372       --  the Push node pushes an entry onto the corresponding stack, and Pop
 373       --  node pops off the entry. Then instead of calling Rcheck_nn, if the
 374       --  corresponding top stack entry has an non-empty label, a goto is
 375       --  generated. This goto should be preceded by a call to Local_Raise as
 376       --  described above.
 377 
 378       --  An example of this transformation is as follows, given:
 379 
 380       --  declare
 381       --    A : Integer range 1 .. 10;
 382       --  begin
 383       --    A := B + C;
 384       --  exception
 385       --    when Constraint_Error =>
 386       --       estmts
 387       --  end;
 388 
 389       --  gets transformed to:
 390 
 391       --  declare
 392       --    A : Integer range 1 .. 10;
 393 
 394       --  begin
 395       --     L1 : label;
 396       --     L2 : label;
 397 
 398       --     begin
 399       --        %push_constraint_error_label (L1)
 400       --        R1b : constant long_long_integer := long_long_integer?(b) +
 401       --          long_long_integer?(c);
 402       --        [constraint_error when
 403       --          not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
 404       --          "overflow check failed"]
 405       --        a := integer?(R1b);
 406       --        %pop_constraint_error_Label
 407 
 408       --     exception
 409       --        ...
 410       --        when constraint_error =>
 411       --           goto L1;
 412       --     end;
 413 
 414       --     goto L2;       -- skip handler when exception not raised
 415       --     <<L1>>         -- target label for local exception
 416       --     estmts
 417       --     <<L2>>
 418       --  end;
 419 
 420       --  Note: the generated labels and goto statements all have the flag
 421       --  Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
 422       --  this generated exception stuff when checking for missing return
 423       --  statements (see circuitry in Check_Statement_Sequence).
 424 
 425       --  Note: All of the processing described above occurs only if
 426       --  restriction No_Exception_Propagation applies or debug flag .g is
 427       --  enabled.
 428 
 429       CE_Locally_Handled : Boolean := False;
 430       SE_Locally_Handled : Boolean := False;
 431       PE_Locally_Handled : Boolean := False;
 432       --  These three flags indicate whether a handler for the corresponding
 433       --  exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
 434       --  is present. If so the switch is set to True, the Exception_Label
 435       --  field of the corresponding handler is set, and appropriate Push
 436       --  and Pop nodes are inserted into the code.
 437 
 438       Local_Expansion_Required : Boolean := False;
 439       --  Set True if we have at least one handler requiring local raise
 440       --  expansion as described above.
 441 
 442       procedure Expand_Local_Exception_Handlers is
 443          procedure Add_Exception_Label (H : Node_Id);
 444          --  H is an exception handler. First check for an Exception_Label
 445          --  already allocated for H. If none, allocate one, set the field in
 446          --  the handler node, add the label declaration, and set the flag
 447          --  Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
 448          --  the call has no effect and Exception_Label is left empty.
 449 
 450          procedure Add_Label_Declaration (L : Entity_Id);
 451          --  Add an implicit declaration of the given label to the declaration
 452          --  list in the parent of the current sequence of handled statements.
 453 
 454          generic
 455             Exc_Locally_Handled : in out Boolean;
 456             --  Flag indicating whether a local handler for this exception
 457             --  has already been generated.
 458 
 459             with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
 460             --  Function to create a Push_xxx_Label node
 461 
 462             with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
 463             --  Function to create a Pop_xxx_Label node
 464 
 465          procedure Generate_Push_Pop (H : Node_Id);
 466          --  Common code for Generate_Push_Pop_xxx below, used to generate an
 467          --  exception label and Push/Pop nodes for Constraint_Error,
 468          --  Program_Error, or Storage_Error.
 469 
 470          -------------------------
 471          -- Add_Exception_Label --
 472          -------------------------
 473 
 474          procedure Add_Exception_Label (H : Node_Id) is
 475          begin
 476             if No (Exception_Label (H))
 477               and then not Local_Raise_Not_OK (H)
 478               and then not Special_Exception_Package_Used
 479             then
 480                Local_Expansion_Required := True;
 481 
 482                declare
 483                   L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
 484                begin
 485                   Set_Exception_Label (H, L);
 486                   Add_Label_Declaration (L);
 487                end;
 488             end if;
 489          end Add_Exception_Label;
 490 
 491          ---------------------------
 492          -- Add_Label_Declaration --
 493          ---------------------------
 494 
 495          procedure Add_Label_Declaration (L : Entity_Id) is
 496             P : constant Node_Id := Parent (HSS);
 497 
 498             Decl_L : constant Node_Id :=
 499                        Make_Implicit_Label_Declaration (Loc,
 500                          Defining_Identifier => L);
 501 
 502          begin
 503             if Declarations (P) = No_List then
 504                Set_Declarations (P, Empty_List);
 505             end if;
 506 
 507             Append (Decl_L, Declarations (P));
 508             Analyze (Decl_L);
 509          end Add_Label_Declaration;
 510 
 511          -----------------------
 512          -- Generate_Push_Pop --
 513          -----------------------
 514 
 515          procedure Generate_Push_Pop (H : Node_Id) is
 516          begin
 517             if Restriction_Active (No_Exception_Handlers)
 518               or else CodePeer_Mode
 519             then
 520                return;
 521             end if;
 522 
 523             if Exc_Locally_Handled then
 524                return;
 525             else
 526                Exc_Locally_Handled := True;
 527             end if;
 528 
 529             Add_Exception_Label (H);
 530 
 531             declare
 532                F : constant Node_Id := First (Statements (HSS));
 533                L : constant Node_Id := Last  (Statements (HSS));
 534 
 535                Push : constant Node_Id := Make_Push_Label (Sloc (F));
 536                Pop  : constant Node_Id := Make_Pop_Label  (Sloc (L));
 537 
 538             begin
 539                --  We make sure that a call to Get_Local_Raise_Call_Entity is
 540                --  made during front end processing, so that when we need it
 541                --  in the back end, it will already be available and loaded.
 542 
 543                Discard_Node (Get_Local_Raise_Call_Entity);
 544 
 545                --  Prepare and insert Push and Pop nodes
 546 
 547                Set_Exception_Label (Push, Exception_Label (H));
 548                Insert_Before (F, Push);
 549                Set_Analyzed (Push);
 550 
 551                Insert_After (L, Pop);
 552                Set_Analyzed (Pop);
 553             end;
 554          end Generate_Push_Pop;
 555 
 556          --  Local declarations
 557 
 558          Loc    : constant Source_Ptr := Sloc (HSS);
 559          Stmts  : List_Id := No_List;
 560          Choice : Node_Id;
 561          Excep  : Entity_Id;
 562 
 563          procedure Generate_Push_Pop_For_Constraint_Error is
 564            new Generate_Push_Pop
 565              (Exc_Locally_Handled => CE_Locally_Handled,
 566               Make_Push_Label     => Make_Push_Constraint_Error_Label,
 567               Make_Pop_Label      => Make_Pop_Constraint_Error_Label);
 568          --  If no Push/Pop has been generated for CE yet, then set the flag
 569          --  CE_Locally_Handled, allocate an Exception_Label for handler H (if
 570          --  not already done), and generate Push/Pop nodes for the exception
 571          --  label at the start and end of the statements of HSS.
 572 
 573          procedure Generate_Push_Pop_For_Program_Error is
 574            new Generate_Push_Pop
 575              (Exc_Locally_Handled => PE_Locally_Handled,
 576               Make_Push_Label     => Make_Push_Program_Error_Label,
 577               Make_Pop_Label      => Make_Pop_Program_Error_Label);
 578          --  If no Push/Pop has been generated for PE yet, then set the flag
 579          --  PE_Locally_Handled, allocate an Exception_Label for handler H (if
 580          --  not already done), and generate Push/Pop nodes for the exception
 581          --  label at the start and end of the statements of HSS.
 582 
 583          procedure Generate_Push_Pop_For_Storage_Error is
 584            new Generate_Push_Pop
 585              (Exc_Locally_Handled => SE_Locally_Handled,
 586               Make_Push_Label     => Make_Push_Storage_Error_Label,
 587               Make_Pop_Label      => Make_Pop_Storage_Error_Label);
 588          --  If no Push/Pop has been generated for SE yet, then set the flag
 589          --  SE_Locally_Handled, allocate an Exception_Label for handler H (if
 590          --  not already done), and generate Push/Pop nodes for the exception
 591          --  label at the start and end of the statements of HSS.
 592 
 593       --  Start of processing for Expand_Local_Exception_Handlers
 594 
 595       begin
 596          --  No processing if all exception handlers will get removed
 597 
 598          if Debug_Flag_Dot_X then
 599             return;
 600          end if;
 601 
 602          --  See for each handler if we have any local raises to expand
 603 
 604          Handler := First_Non_Pragma (Handlrs);
 605          while Present (Handler) loop
 606 
 607             --  Note, we do not test Local_Raise_Not_OK here, because in the
 608             --  case of Push/Pop generation we want to generate push with a
 609             --  null label. The Add_Exception_Label routine has no effect if
 610             --  Local_Raise_Not_OK is set, so this works as required.
 611 
 612             if Present (Local_Raise_Statements (Handler)) then
 613                Add_Exception_Label (Handler);
 614             end if;
 615 
 616             --  If we are doing local raise to goto optimization (restriction
 617             --  No_Exception_Propagation set or debug flag .g set), then check
 618             --  to see if handler handles CE, PE, SE and if so generate the
 619             --  appropriate push/pop sequence for the back end.
 620 
 621             if (Debug_Flag_Dot_G
 622                  or else Restriction_Active (No_Exception_Propagation))
 623               and then Has_Local_Raise (Handler)
 624             then
 625                Choice := First (Exception_Choices (Handler));
 626                while Present (Choice) loop
 627                   if Nkind (Choice) = N_Others_Choice
 628                     and then not All_Others (Choice)
 629                   then
 630                      Generate_Push_Pop_For_Constraint_Error (Handler);
 631                      Generate_Push_Pop_For_Program_Error    (Handler);
 632                      Generate_Push_Pop_For_Storage_Error    (Handler);
 633 
 634                   elsif Is_Entity_Name (Choice) then
 635                      Excep := Get_Renamed_Entity (Entity (Choice));
 636 
 637                      if Excep = Standard_Constraint_Error then
 638                         Generate_Push_Pop_For_Constraint_Error (Handler);
 639                      elsif Excep = Standard_Program_Error then
 640                         Generate_Push_Pop_For_Program_Error    (Handler);
 641                      elsif Excep = Standard_Storage_Error then
 642                         Generate_Push_Pop_For_Storage_Error    (Handler);
 643                      end if;
 644                   end if;
 645 
 646                   Next (Choice);
 647                end loop;
 648             end if;
 649 
 650             Next_Non_Pragma (Handler);
 651          end loop;
 652 
 653          --  Nothing to do if no handlers requiring the goto transformation
 654 
 655          if not (Local_Expansion_Required) then
 656             return;
 657          end if;
 658 
 659          --  Prepare to do the transformation
 660 
 661          declare
 662             --  L3 is the label to exit the HSS
 663 
 664             L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
 665 
 666             Labl_L3 : constant Node_Id :=
 667                         Make_Label (Loc,
 668                           Identifier => New_Occurrence_Of (L3_Dent, Loc));
 669 
 670             Blk_Stm : Node_Id;
 671             Relmt   : Elmt_Id;
 672 
 673          begin
 674             Set_Exception_Junk (Labl_L3);
 675             Add_Label_Declaration (L3_Dent);
 676 
 677             --  Wrap existing statements and handlers in an inner block
 678 
 679             Blk_Stm :=
 680               Make_Block_Statement (Loc,
 681                 Handled_Statement_Sequence => Relocate_Node (HSS));
 682             Set_Exception_Junk (Blk_Stm);
 683 
 684             Rewrite (HSS,
 685               Make_Handled_Sequence_Of_Statements (Loc,
 686                 Statements => New_List (Blk_Stm),
 687                 End_Label  => Relocate_Node (End_Label (HSS))));
 688 
 689             --  Set block statement as analyzed, we don't want to actually call
 690             --  Analyze on this block, it would cause a recursion in exception
 691             --  handler processing which would mess things up.
 692 
 693             Set_Analyzed (Blk_Stm);
 694 
 695             --  Now loop through the exception handlers to deal with those that
 696             --  are targets of local raise statements.
 697 
 698             Handler := First_Non_Pragma (Handlrs);
 699             while Present (Handler) loop
 700                if Present (Exception_Label (Handler)) then
 701 
 702                   --  This handler needs the goto expansion
 703 
 704                   declare
 705                      Loc : constant Source_Ptr := Sloc (Handler);
 706 
 707                      --  L1 is the start label for this handler
 708 
 709                      L1_Dent : constant Entity_Id := Exception_Label (Handler);
 710 
 711                      Labl_L1 : constant Node_Id :=
 712                                  Make_Label (Loc,
 713                                    Identifier =>
 714                                      New_Occurrence_Of (L1_Dent, Loc));
 715 
 716                      --  Jump to L1 to be used as replacement for the original
 717                      --  handler (used in the case where exception propagation
 718                      --  may still occur).
 719 
 720                      Name_L1 : constant Node_Id :=
 721                                  New_Occurrence_Of (L1_Dent, Loc);
 722 
 723                      Goto_L1 : constant Node_Id :=
 724                                  Make_Goto_Statement (Loc,
 725                                    Name => Name_L1);
 726 
 727                      --  Jump to L3 to be used at the end of handler
 728 
 729                      Name_L3 : constant Node_Id :=
 730                                  New_Occurrence_Of (L3_Dent, Loc);
 731 
 732                      Goto_L3 : constant Node_Id :=
 733                                  Make_Goto_Statement (Loc,
 734                                    Name => Name_L3);
 735 
 736                      H_Stmts : constant List_Id := Statements (Handler);
 737 
 738                   begin
 739                      Set_Exception_Junk (Labl_L1);
 740                      Set_Exception_Junk (Goto_L3);
 741 
 742                      --  Note: we do NOT set Exception_Junk in Goto_L1, since
 743                      --  this is a real transfer of control that we want the
 744                      --  Sem_Ch6.Check_Returns procedure to recognize properly.
 745 
 746                      --  Replace handler by a goto L1. We can mark this as
 747                      --  analyzed since it is fully formed, and we don't
 748                      --  want it going through any further checks. We save
 749                      --  the last statement location in the goto L1 node for
 750                      --  the benefit of Sem_Ch6.Check_Returns.
 751 
 752                      Set_Statements (Handler, New_List (Goto_L1));
 753                      Set_Analyzed (Goto_L1);
 754                      Set_Etype (Name_L1, Standard_Void_Type);
 755 
 756                      --  Now replace all the raise statements by goto L1
 757 
 758                      if Present (Local_Raise_Statements (Handler)) then
 759                         Relmt := First_Elmt (Local_Raise_Statements (Handler));
 760                         while Present (Relmt) loop
 761                            declare
 762                               Raise_S : constant Node_Id    := Node (Relmt);
 763                               RLoc    : constant Source_Ptr := Sloc (Raise_S);
 764                               Name_L1 : constant Node_Id :=
 765                                           New_Occurrence_Of (L1_Dent, Loc);
 766                               Goto_L1 : constant Node_Id :=
 767                                           Make_Goto_Statement (RLoc,
 768                                             Name => Name_L1);
 769 
 770                            begin
 771                               --  Replace raise by goto L1
 772 
 773                               Set_Analyzed (Goto_L1);
 774                               Set_Etype (Name_L1, Standard_Void_Type);
 775                               Replace_Raise_By_Goto (Raise_S, Goto_L1);
 776                            end;
 777 
 778                            Next_Elmt (Relmt);
 779                         end loop;
 780                      end if;
 781 
 782                      --  Add a goto L3 at end of statement list in block. The
 783                      --  first time, this is what skips over the exception
 784                      --  handlers in the normal case. Subsequent times, it
 785                      --  terminates the execution of the previous handler code,
 786                      --  and skips subsequent handlers.
 787 
 788                      Stmts := Statements (HSS);
 789 
 790                      Insert_After (Last (Stmts), Goto_L3);
 791                      Set_Analyzed (Goto_L3);
 792                      Set_Etype (Name_L3, Standard_Void_Type);
 793 
 794                      --  Now we drop the label that marks the handler start,
 795                      --  followed by the statements of the handler.
 796 
 797                      Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
 798 
 799                      Insert_After_And_Analyze (Last (Stmts), Labl_L1);
 800 
 801                      declare
 802                         Loc : constant Source_Ptr := Sloc (First (H_Stmts));
 803                         Blk : constant Node_Id :=
 804                                 Make_Block_Statement (Loc,
 805                                   Handled_Statement_Sequence =>
 806                                     Make_Handled_Sequence_Of_Statements (Loc,
 807                                       Statements => H_Stmts));
 808                      begin
 809                         Set_Exception_Junk (Blk);
 810                         Insert_After_And_Analyze (Last (Stmts), Blk);
 811                      end;
 812                   end;
 813 
 814                   --  Here if we have local raise statements but the handler is
 815                   --  not suitable for processing with a local raise. In this
 816                   --  case we have to generate possible diagnostics.
 817 
 818                elsif Has_Local_Raise (Handler)
 819                  and then Local_Raise_Statements (Handler) /= No_Elist
 820                then
 821                   Relmt := First_Elmt (Local_Raise_Statements (Handler));
 822                   while Present (Relmt) loop
 823                      Warn_If_No_Propagation (Node (Relmt));
 824                      Next_Elmt (Relmt);
 825                   end loop;
 826                end if;
 827 
 828                Next (Handler);
 829             end loop;
 830 
 831             --  Only remaining step is to drop the L3 label and we are done
 832 
 833             Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
 834 
 835             --  If we had at least one handler, then we drop the label after
 836             --  the last statement of that handler.
 837 
 838             if Stmts /= No_List then
 839                Insert_After_And_Analyze (Last (Stmts), Labl_L3);
 840 
 841             --  Otherwise we have removed all the handlers (this results from
 842             --  use of pragma Restrictions (No_Exception_Propagation), and we
 843             --  drop the label at the end of the statements of the HSS.
 844 
 845             else
 846                Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
 847             end if;
 848 
 849             return;
 850          end;
 851       end Expand_Local_Exception_Handlers;
 852 
 853       -----------------------------
 854       -- Prepend_Call_To_Handler --
 855       -----------------------------
 856 
 857       procedure Prepend_Call_To_Handler
 858         (Proc : RE_Id;
 859          Args : List_Id := No_List)
 860       is
 861          Ent : constant Entity_Id := RTE (Proc);
 862 
 863       begin
 864          --  If we have no Entity, then we are probably in no run time mode or
 865          --  some weird error has occurred. In either case do nothing. Note use
 866          --  of No_Location to hide this code from the debugger, so single
 867          --  stepping doesn't jump back and forth.
 868 
 869          if Present (Ent) then
 870             declare
 871                Call : constant Node_Id :=
 872                         Make_Procedure_Call_Statement (No_Location,
 873                           Name => New_Occurrence_Of (RTE (Proc), No_Location),
 874                           Parameter_Associations => Args);
 875 
 876             begin
 877                Prepend_To (Statements (Handler), Call);
 878                Analyze (Call, Suppress => All_Checks);
 879             end;
 880          end if;
 881       end Prepend_Call_To_Handler;
 882 
 883       ---------------------------
 884       -- Replace_Raise_By_Goto --
 885       ---------------------------
 886 
 887       procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
 888          Loc   : constant Source_Ptr := Sloc (Raise_S);
 889          Excep : Entity_Id;
 890          LR    : Node_Id;
 891          Cond  : Node_Id;
 892          Orig  : Node_Id;
 893 
 894       begin
 895          --  If we have a null statement, it means that there is no replacement
 896          --  needed (typically this results from a suppressed check).
 897 
 898          if Nkind (Raise_S) = N_Null_Statement then
 899             return;
 900 
 901          --  Test for Raise_xxx_Error
 902 
 903          elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
 904             Excep := Standard_Constraint_Error;
 905             Cond  := Condition (Raise_S);
 906 
 907          elsif Nkind (Raise_S) = N_Raise_Storage_Error then
 908             Excep := Standard_Storage_Error;
 909             Cond := Condition (Raise_S);
 910 
 911          elsif Nkind (Raise_S) = N_Raise_Program_Error then
 912             Excep := Standard_Program_Error;
 913             Cond := Condition (Raise_S);
 914 
 915             --  The only other possibility is a node that is or used to be a
 916             --  simple raise statement.
 917 
 918          else
 919             Orig := Original_Node (Raise_S);
 920             pragma Assert (Nkind (Orig) = N_Raise_Statement
 921                              and then Present (Name (Orig))
 922                              and then No (Expression (Orig)));
 923             Excep := Entity (Name (Orig));
 924             Cond := Empty;
 925          end if;
 926 
 927          --  Here Excep is the exception to raise, and Cond is the condition
 928          --  First prepare the call to Local_Raise (excep'address).
 929 
 930          if RTE_Available (RE_Local_Raise) then
 931             LR :=
 932               Make_Procedure_Call_Statement (Loc,
 933                 Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
 934                 Parameter_Associations => New_List (
 935                   Unchecked_Convert_To (RTE (RE_Address),
 936                     Make_Attribute_Reference (Loc,
 937                       Prefix         => New_Occurrence_Of (Excep, Loc),
 938                       Attribute_Name => Name_Identity))));
 939 
 940             --  Use null statement if Local_Raise not available
 941 
 942          else
 943             LR :=
 944               Make_Null_Statement (Loc);
 945          end if;
 946 
 947          --  If there is no condition, we rewrite as
 948 
 949          --    begin
 950          --       Local_Raise (excep'Identity);
 951          --       goto L1;
 952          --    end;
 953 
 954          if No (Cond) then
 955             Rewrite (Raise_S,
 956               Make_Block_Statement (Loc,
 957                 Handled_Statement_Sequence =>
 958                   Make_Handled_Sequence_Of_Statements (Loc,
 959                     Statements => New_List (LR, Goto_L1))));
 960             Set_Exception_Junk (Raise_S);
 961 
 962          --  If there is a condition, we rewrite as
 963 
 964          --    if condition then
 965          --       Local_Raise (excep'Identity);
 966          --       goto L1;
 967          --    end if;
 968 
 969          else
 970             Rewrite (Raise_S,
 971               Make_If_Statement (Loc,
 972                 Condition       => Cond,
 973                 Then_Statements => New_List (LR, Goto_L1)));
 974          end if;
 975 
 976          Analyze (Raise_S);
 977       end Replace_Raise_By_Goto;
 978 
 979    --  Start of processing for Expand_Exception_Handlers
 980 
 981    begin
 982       Expand_Local_Exception_Handlers;
 983 
 984       --  Loop through handlers
 985 
 986       Handler := First_Non_Pragma (Handlrs);
 987       Handler_Loop : while Present (Handler) loop
 988          Process_Statements_For_Controlled_Objects (Handler);
 989 
 990          Next_Handler := Next_Non_Pragma (Handler);
 991 
 992          --  Remove source handler if gnat debug flag .x is set
 993 
 994          if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
 995             Remove (Handler);
 996 
 997          --  Remove handler if no exception propagation, generating a warning
 998          --  if a source generated handler was not the target of a local raise.
 999 
1000          else
1001             if Restriction_Active (No_Exception_Propagation)
1002               and then not Has_Local_Raise (Handler)
1003               and then Comes_From_Source (Handler)
1004               and then Warn_On_Non_Local_Exception
1005             then
1006                Warn_No_Exception_Propagation_Active (Handler);
1007                Error_Msg_N
1008                  ("\?X?this handler can never be entered, "
1009                   & "and has been removed", Handler);
1010             end if;
1011 
1012             if No_Exception_Propagation_Active then
1013                Remove (Handler);
1014 
1015             --  Exception handler is active and retained and must be processed
1016 
1017             else
1018                --  If an exception occurrence is present, then we must declare
1019                --  it and initialize it from the value stored in the TSD
1020 
1021                --     declare
1022                --        name : Exception_Occurrence;
1023                --     begin
1024                --        Save_Occurrence (name, Get_Current_Excep.all)
1025                --        ...
1026                --     end;
1027 
1028                --  This expansion is only performed when using front-end
1029                --  exceptions. Gigi will insert a call to initialize the
1030                --  choice parameter.
1031 
1032                if Present (Choice_Parameter (Handler))
1033                  and then (Front_End_Exceptions
1034                             or else CodePeer_Mode)
1035                then
1036                   declare
1037                      Cparm : constant Entity_Id  := Choice_Parameter (Handler);
1038                      Cloc  : constant Source_Ptr := Sloc (Cparm);
1039                      Hloc  : constant Source_Ptr := Sloc (Handler);
1040                      Save  : Node_Id;
1041 
1042                   begin
1043                      --  Note: No_Location used to hide code from the debugger,
1044                      --  so single stepping doesn't jump back and forth.
1045 
1046                      Save :=
1047                        Make_Procedure_Call_Statement (No_Location,
1048                          Name                   =>
1049                            New_Occurrence_Of
1050                              (RTE (RE_Save_Occurrence), No_Location),
1051                          Parameter_Associations => New_List (
1052                            New_Occurrence_Of (Cparm, No_Location),
1053                            Make_Explicit_Dereference (No_Location,
1054                              Prefix =>
1055                                Make_Function_Call (No_Location,
1056                                  Name =>
1057                                    Make_Explicit_Dereference (No_Location,
1058                                      Prefix =>
1059                                        New_Occurrence_Of
1060                                          (RTE (RE_Get_Current_Excep),
1061                                           No_Location))))));
1062 
1063                      Mark_Rewrite_Insertion (Save);
1064                      Prepend (Save, Statements (Handler));
1065 
1066                      Obj_Decl :=
1067                        Make_Object_Declaration (Cloc,
1068                          Defining_Identifier => Cparm,
1069                          Object_Definition   =>
1070                            New_Occurrence_Of
1071                              (RTE (RE_Exception_Occurrence), Cloc));
1072                      Set_No_Initialization (Obj_Decl, True);
1073 
1074                      Rewrite (Handler,
1075                        Make_Exception_Handler (Hloc,
1076                          Choice_Parameter  => Empty,
1077                          Exception_Choices => Exception_Choices (Handler),
1078                          Statements        => New_List (
1079                            Make_Block_Statement (Hloc,
1080                              Declarations => New_List (Obj_Decl),
1081                              Handled_Statement_Sequence =>
1082                                Make_Handled_Sequence_Of_Statements (Hloc,
1083                                  Statements => Statements (Handler))))));
1084 
1085                      --  Local raise statements can't occur, since exception
1086                      --  handlers with choice parameters are not allowed when
1087                      --  No_Exception_Propagation applies, so set attributes
1088                      --  accordingly.
1089 
1090                      Set_Local_Raise_Statements (Handler, No_Elist);
1091                      Set_Local_Raise_Not_OK (Handler);
1092 
1093                      Analyze_List
1094                        (Statements (Handler), Suppress => All_Checks);
1095                   end;
1096                end if;
1097 
1098                --  For the normal case, we have to worry about the state of
1099                --  abort deferral. Generally, we defer abort during runtime
1100                --  handling of exceptions. When control is passed to the
1101                --  handler, then in the normal case we undefer aborts. In
1102                --  any case this entire handling is relevant only if aborts
1103                --  are allowed.
1104 
1105                if Abort_Allowed
1106                  and then not ZCX_Exceptions
1107                then
1108                   --  There are some special cases in which we do not do the
1109                   --  undefer. In particular a finalization (AT END) handler
1110                   --  wants to operate with aborts still deferred.
1111 
1112                   --  We also suppress the call if this is the special handler
1113                   --  for Abort_Signal, since if we are aborting, we want to
1114                   --  keep aborts deferred (one abort is enough).
1115 
1116                   --  If abort really needs to be deferred the expander must
1117                   --  add this call explicitly, see
1118                   --  Expand_N_Asynchronous_Select.
1119 
1120                   Others_Choice :=
1121                     Nkind (First (Exception_Choices (Handler))) =
1122                                                          N_Others_Choice;
1123 
1124                   if (Others_Choice
1125                        or else Entity (First (Exception_Choices (Handler))) /=
1126                                                          Stand.Abort_Signal)
1127                     and then not
1128                       (Others_Choice
1129                         and then
1130                           All_Others (First (Exception_Choices (Handler))))
1131                   then
1132                      Prepend_Call_To_Handler (RE_Abort_Undefer);
1133                   end if;
1134                end if;
1135             end if;
1136          end if;
1137 
1138          Handler := Next_Handler;
1139       end loop Handler_Loop;
1140 
1141       --  If all handlers got removed, then remove the list. Note we cannot
1142       --  reference HSS here, since expanding local handlers may have buried
1143       --  the handlers in an inner block.
1144 
1145       if Is_Empty_List (Handlrs) then
1146          Set_Exception_Handlers (Parent (Handlrs), No_List);
1147       end if;
1148    end Expand_Exception_Handlers;
1149 
1150    ------------------------------------
1151    -- Expand_N_Exception_Declaration --
1152    ------------------------------------
1153 
1154    --  Generates:
1155    --     exceptE : constant String := "A.B.EXCEP";   -- static data
1156    --     except : exception_data :=
1157    --                (Handled_By_Other => False,
1158    --                 Lang             => 'A',
1159    --                 Name_Length      => exceptE'Length,
1160    --                 Full_Name        => exceptE'Address,
1161    --                 HTable_Ptr       => null,
1162    --                 Foreign_Data     => null,
1163    --                 Raise_Hook       => null);
1164 
1165    --  (protecting test only needed if not at library level)
1166 
1167    --     exceptF : Boolean := True --  static data
1168    --     if exceptF then
1169    --        exceptF := False;
1170    --        Register_Exception (except'Unchecked_Access);
1171    --     end if;
1172 
1173    procedure Expand_N_Exception_Declaration (N : Node_Id) is
1174       Id      : constant Entity_Id  := Defining_Identifier (N);
1175       Loc     : constant Source_Ptr := Sloc (N);
1176       Ex_Id   : Entity_Id;
1177       Flag_Id : Entity_Id;
1178       L       : List_Id;
1179 
1180       procedure Force_Static_Allocation_Of_Referenced_Objects
1181         (Aggregate : Node_Id);
1182       --  A specialized solution to one particular case of an ugly problem
1183       --
1184       --  The given aggregate includes an Unchecked_Conversion as one of the
1185       --  component values. The call to Analyze_And_Resolve below ends up
1186       --  calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1187       --  to introduce a (constant) temporary and then obtain the component
1188       --  value by evaluating the temporary.
1189       --
1190       --  In the case of an exception declared within a subprogram (or any
1191       --  other dynamic scope), this is a bad transformation. The exception
1192       --  object is marked as being Statically_Allocated but the temporary is
1193       --  not. If the initial value of a Statically_Allocated declaration
1194       --  references a dynamically allocated object, this prevents static
1195       --  initialization of the object.
1196       --
1197       --  We cope with this here by marking the temporary Statically_Allocated.
1198       --  It might seem cleaner to generalize this utility and then use it to
1199       --  enforce a rule that the entities referenced in the declaration of any
1200       --  "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1201       --  entity must also be either Library_Level or hoisted. It turns out
1202       --  that this would be incompatible with the current treatment of an
1203       --  object which is local to a subprogram, subject to an Export pragma,
1204       --  not subject to an address clause, and whose declaration contains
1205       --  references to other local (non-hoisted) objects (e.g., in the initial
1206       --  value expression).
1207 
1208       ---------------------------------------------------
1209       -- Force_Static_Allocation_Of_Referenced_Objects --
1210       ---------------------------------------------------
1211 
1212       procedure Force_Static_Allocation_Of_Referenced_Objects
1213         (Aggregate : Node_Id)
1214       is
1215          function Fixup_Node (N : Node_Id) return Traverse_Result;
1216          --  If the given node references a dynamically allocated object, then
1217          --  correct the declaration of the object.
1218 
1219          ----------------
1220          -- Fixup_Node --
1221          ----------------
1222 
1223          function Fixup_Node (N : Node_Id) return Traverse_Result is
1224          begin
1225             if Nkind (N) in N_Has_Entity
1226               and then Present (Entity (N))
1227               and then not Is_Library_Level_Entity (Entity (N))
1228 
1229               --  Note: the following test is not needed but it seems cleaner
1230               --  to do this test (this would be more important if procedure
1231               --  Force_Static_Allocation_Of_Referenced_Objects recursively
1232               --  traversed the declaration of an entity after marking it as
1233               --  statically allocated).
1234 
1235               and then not Is_Statically_Allocated (Entity (N))
1236             then
1237                Set_Is_Statically_Allocated (Entity (N));
1238             end if;
1239 
1240             return OK;
1241          end Fixup_Node;
1242 
1243          procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
1244 
1245       --  Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1246 
1247       begin
1248          Fixup_Tree (Aggregate);
1249       end Force_Static_Allocation_Of_Referenced_Objects;
1250 
1251    --  Start of processing for Expand_N_Exception_Declaration
1252 
1253    begin
1254       --  Nothing to do when generating C code
1255 
1256       if Generate_C_Code then
1257          return;
1258       end if;
1259 
1260       --  Definition of the external name: nam : constant String := "A.B.NAME";
1261 
1262       Ex_Id :=
1263         Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E'));
1264 
1265       Insert_Action (N,
1266         Make_Object_Declaration (Loc,
1267           Defining_Identifier => Ex_Id,
1268           Constant_Present    => True,
1269           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1270           Expression          =>
1271             Make_String_Literal (Loc,
1272               Strval => Fully_Qualified_Name_String (Id))));
1273 
1274       Set_Is_Statically_Allocated (Ex_Id);
1275 
1276       --  Create the aggregate list for type Standard.Exception_Type:
1277       --  Handled_By_Other component: False
1278 
1279       L := Empty_List;
1280       Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1281 
1282       --  Lang component: 'A'
1283 
1284       Append_To (L,
1285         Make_Character_Literal (Loc,
1286           Chars              =>  Name_uA,
1287           Char_Literal_Value =>  UI_From_Int (Character'Pos ('A'))));
1288 
1289       --  Name_Length component: Nam'Length
1290 
1291       Append_To (L,
1292         Make_Attribute_Reference (Loc,
1293           Prefix         => New_Occurrence_Of (Ex_Id, Loc),
1294           Attribute_Name => Name_Length));
1295 
1296       --  Full_Name component: Standard.A_Char!(Nam'Address)
1297 
1298       --  The unchecked conversion causes capacity issues for CodePeer in some
1299       --  cases and is never useful, so we set the Full_Name component to null
1300       --  instead for CodePeer.
1301 
1302       if CodePeer_Mode then
1303          Append_To (L, Make_Null (Loc));
1304       else
1305          Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1306            Make_Attribute_Reference (Loc,
1307              Prefix         => New_Occurrence_Of (Ex_Id, Loc),
1308              Attribute_Name => Name_Address)));
1309       end if;
1310 
1311       --  HTable_Ptr component: null
1312 
1313       Append_To (L, Make_Null (Loc));
1314 
1315       --  Foreign_Data component: null
1316 
1317       Append_To (L, Make_Null (Loc));
1318 
1319       --  Raise_Hook component: null
1320 
1321       Append_To (L, Make_Null (Loc));
1322 
1323       Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1324       Analyze_And_Resolve (Expression (N), Etype (Id));
1325 
1326       Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
1327 
1328       --  Register_Exception (except'Unchecked_Access);
1329 
1330       if not No_Exception_Handlers_Set
1331         and then not Restriction_Active (No_Exception_Registration)
1332       then
1333          L := New_List (
1334            Make_Procedure_Call_Statement (Loc,
1335              Name                   =>
1336                New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1337              Parameter_Associations => New_List (
1338                Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1339                  Make_Attribute_Reference (Loc,
1340                    Prefix         => New_Occurrence_Of (Id, Loc),
1341                    Attribute_Name => Name_Unrestricted_Access)))));
1342 
1343          Set_Register_Exception_Call (Id, First (L));
1344 
1345          if not Is_Library_Level_Entity (Id) then
1346             Flag_Id :=
1347               Make_Defining_Identifier (Loc,
1348                 Chars => New_External_Name (Chars (Id), 'F'));
1349 
1350             Insert_Action (N,
1351               Make_Object_Declaration (Loc,
1352                 Defining_Identifier => Flag_Id,
1353                 Object_Definition   =>
1354                   New_Occurrence_Of (Standard_Boolean, Loc),
1355                 Expression          =>
1356                   New_Occurrence_Of (Standard_True, Loc)));
1357 
1358             Set_Is_Statically_Allocated (Flag_Id);
1359 
1360             Append_To (L,
1361               Make_Assignment_Statement (Loc,
1362                 Name       => New_Occurrence_Of (Flag_Id, Loc),
1363                 Expression => New_Occurrence_Of (Standard_False, Loc)));
1364 
1365             Insert_After_And_Analyze (N,
1366               Make_Implicit_If_Statement (N,
1367                 Condition       => New_Occurrence_Of (Flag_Id, Loc),
1368                 Then_Statements => L));
1369 
1370          else
1371             Insert_List_After_And_Analyze (N, L);
1372          end if;
1373       end if;
1374    end Expand_N_Exception_Declaration;
1375 
1376    ---------------------------------------------
1377    -- Expand_N_Handled_Sequence_Of_Statements --
1378    ---------------------------------------------
1379 
1380    procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1381    begin
1382       --  Expand exception handlers
1383 
1384       if Present (Exception_Handlers (N))
1385         and then not Restriction_Active (No_Exception_Handlers)
1386       then
1387          Expand_Exception_Handlers (N);
1388       end if;
1389 
1390       --  If local exceptions are being expanded, the previous call will
1391       --  have rewritten the construct as a block and reanalyzed it. No
1392       --  further expansion is needed.
1393 
1394       if Analyzed (N) then
1395          return;
1396       end if;
1397 
1398       --  Add clean up actions if required
1399 
1400       if not Nkind_In (Parent (N), N_Package_Body,
1401                                    N_Accept_Statement,
1402                                    N_Extended_Return_Statement)
1403         and then not Delay_Cleanups (Current_Scope)
1404 
1405         --  No cleanup action needed in thunks associated with interfaces
1406         --  because they only displace the pointer to the object.
1407 
1408         and then not Is_Thunk (Current_Scope)
1409       then
1410          Expand_Cleanup_Actions (Parent (N));
1411       else
1412          Set_First_Real_Statement (N, First (Statements (N)));
1413       end if;
1414    end Expand_N_Handled_Sequence_Of_Statements;
1415 
1416    -------------------------------------
1417    -- Expand_N_Raise_Constraint_Error --
1418    -------------------------------------
1419 
1420    procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1421    begin
1422       --  We adjust the condition to deal with the C/Fortran boolean case. This
1423       --  may well not be necessary, as all such conditions are generated by
1424       --  the expander and probably are all standard boolean, but who knows
1425       --  what strange optimization in future may require this adjustment.
1426 
1427       Adjust_Condition (Condition (N));
1428 
1429       --  Now deal with possible local raise handling
1430 
1431       Possible_Local_Raise (N, Standard_Constraint_Error);
1432    end Expand_N_Raise_Constraint_Error;
1433 
1434    -------------------------------
1435    -- Expand_N_Raise_Expression --
1436    -------------------------------
1437 
1438    procedure Expand_N_Raise_Expression (N : Node_Id) is
1439       Loc : constant Source_Ptr := Sloc (N);
1440       Typ : constant Entity_Id  := Etype (N);
1441       RCE : Node_Id;
1442 
1443    begin
1444       Possible_Local_Raise (N, Entity (Name (N)));
1445 
1446       --  Later we must teach the back end/gigi how to deal with this, but
1447       --  for now we will assume the type is Standard_Boolean and transform
1448       --  the node to:
1449 
1450       --     do
1451       --       raise X [with string]
1452       --     in
1453       --       raise Constraint_Error;
1454 
1455       --  unless the flag Convert_To_Return_False is set, in which case
1456       --  the transformation is to:
1457 
1458       --     do
1459       --       return False;
1460       --     in
1461       --       raise Constraint_Error;
1462 
1463       --  The raise constraint error can never be executed. It is just a dummy
1464       --  node that can be labeled with an arbitrary type.
1465 
1466       RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise);
1467       Set_Etype (RCE, Typ);
1468 
1469       if Convert_To_Return_False (N) then
1470          Rewrite (N,
1471            Make_Expression_With_Actions (Loc,
1472              Actions     => New_List (
1473                Make_Simple_Return_Statement (Loc,
1474                  Expression => New_Occurrence_Of (Standard_False, Loc))),
1475               Expression => RCE));
1476 
1477       else
1478          Rewrite (N,
1479            Make_Expression_With_Actions (Loc,
1480              Actions     => New_List (
1481                Make_Raise_Statement (Loc,
1482                  Name       => Name (N),
1483                  Expression => Expression (N))),
1484               Expression => RCE));
1485       end if;
1486 
1487       Analyze_And_Resolve (N, Typ);
1488    end Expand_N_Raise_Expression;
1489 
1490    ----------------------------------
1491    -- Expand_N_Raise_Program_Error --
1492    ----------------------------------
1493 
1494    procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1495    begin
1496       --  We adjust the condition to deal with the C/Fortran boolean case. This
1497       --  may well not be necessary, as all such conditions are generated by
1498       --  the expander and probably are all standard boolean, but who knows
1499       --  what strange optimization in future may require this adjustment.
1500 
1501       Adjust_Condition (Condition (N));
1502 
1503       --  Now deal with possible local raise handling
1504 
1505       Possible_Local_Raise (N, Standard_Program_Error);
1506    end Expand_N_Raise_Program_Error;
1507 
1508    ------------------------------
1509    -- Expand_N_Raise_Statement --
1510    ------------------------------
1511 
1512    procedure Expand_N_Raise_Statement (N : Node_Id) is
1513       Loc   : constant Source_Ptr := Sloc (N);
1514       Ehand : Node_Id;
1515       E     : Entity_Id;
1516       Str   : String_Id;
1517       H     : Node_Id;
1518       Src   : Boolean;
1519 
1520    begin
1521       --  Processing for locally handled exception (exclude reraise case)
1522 
1523       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1524          if Debug_Flag_Dot_G
1525            or else Restriction_Active (No_Exception_Propagation)
1526          then
1527             --  If we have a local handler, then note that this is potentially
1528             --  able to be transformed into a goto statement.
1529 
1530             H := Find_Local_Handler (Entity (Name (N)), N);
1531 
1532             if Present (H) then
1533                if Local_Raise_Statements (H) = No_Elist then
1534                   Set_Local_Raise_Statements (H, New_Elmt_List);
1535                end if;
1536 
1537                --  Append the new entry if it is not there already. Sometimes
1538                --  we have situations where due to reexpansion, the same node
1539                --  is analyzed twice and would otherwise be added twice.
1540 
1541                Append_Unique_Elmt (N, Local_Raise_Statements (H));
1542                Set_Has_Local_Raise (H);
1543 
1544             --  If no local handler, then generate no propagation warning
1545 
1546             else
1547                Warn_If_No_Propagation (N);
1548             end if;
1549 
1550          end if;
1551       end if;
1552 
1553       --  If a string expression is present, then the raise statement is
1554       --  converted to a call:
1555       --     Raise_Exception (exception-name'Identity, string);
1556       --  and there is nothing else to do.
1557 
1558       if Present (Expression (N)) then
1559 
1560          --  Adjust message to deal with Prefix_Exception_Messages. We only
1561          --  add the prefix to string literals, if the message is being
1562          --  constructed, we assume it already deals with uniqueness.
1563 
1564          if Prefix_Exception_Messages
1565            and then Nkind (Expression (N)) = N_String_Literal
1566          then
1567             declare
1568                Buf : Bounded_String;
1569             begin
1570                Add_Source_Info (Buf, Loc, Name_Enclosing_Entity);
1571                Append (Buf, ": ");
1572                Append (Buf, Strval (Expression (N)));
1573                Rewrite (Expression (N), Make_String_Literal (Loc, +Buf));
1574                Analyze_And_Resolve (Expression (N), Standard_String);
1575             end;
1576          end if;
1577 
1578          --  Avoid passing exception-name'identity in runtimes in which this
1579          --  argument is not used. This avoids generating undefined references
1580          --  to these exceptions when compiling with no optimization
1581 
1582          if Configurable_Run_Time_On_Target
1583            and then (Restriction_Active (No_Exception_Handlers)
1584                        or else
1585                      Restriction_Active (No_Exception_Propagation))
1586          then
1587             Rewrite (N,
1588               Make_Procedure_Call_Statement (Loc,
1589                 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1590                 Parameter_Associations => New_List (
1591                   New_Occurrence_Of (RTE (RE_Null_Id), Loc),
1592                   Expression (N))));
1593          else
1594             Rewrite (N,
1595               Make_Procedure_Call_Statement (Loc,
1596                 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1597                 Parameter_Associations => New_List (
1598                   Make_Attribute_Reference (Loc,
1599                     Prefix         => Name (N),
1600                     Attribute_Name => Name_Identity),
1601                   Expression (N))));
1602          end if;
1603 
1604          Analyze (N);
1605          return;
1606       end if;
1607 
1608       --  Remaining processing is for the case where no string expression is
1609       --  present.
1610 
1611       --  Don't expand a raise statement that does not come from source if we
1612       --  have already had configurable run-time violations, since most likely
1613       --  it will be junk cascaded nonsense.
1614 
1615       if Configurable_Run_Time_Violations > 0
1616         and then not Comes_From_Source (N)
1617       then
1618          return;
1619       end if;
1620 
1621       --  Convert explicit raise of Program_Error, Constraint_Error, and
1622       --  Storage_Error into the corresponding raise (in High_Integrity_Mode
1623       --  all other raises will get normal expansion and be disallowed,
1624       --  but this is also faster in all modes). Propagate Comes_From_Source
1625       --  flag to the new node.
1626 
1627       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1628          Src := Comes_From_Source (N);
1629 
1630          if Entity (Name (N)) = Standard_Constraint_Error then
1631             Rewrite (N,
1632               Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
1633             Set_Comes_From_Source (N, Src);
1634             Analyze (N);
1635             return;
1636 
1637          elsif Entity (Name (N)) = Standard_Program_Error then
1638             Rewrite (N,
1639               Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1640             Set_Comes_From_Source (N, Src);
1641             Analyze (N);
1642             return;
1643 
1644          elsif Entity (Name (N)) = Standard_Storage_Error then
1645             Rewrite (N,
1646               Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
1647             Set_Comes_From_Source (N, Src);
1648             Analyze (N);
1649             return;
1650          end if;
1651       end if;
1652 
1653       --  Case of name present, in this case we expand raise name to
1654 
1655       --    Raise_Exception (name'Identity, location_string);
1656 
1657       --  where location_string identifies the file/line of the raise
1658 
1659       if Present (Name (N)) then
1660          declare
1661             Id : Entity_Id := Entity (Name (N));
1662             Buf : Bounded_String;
1663 
1664          begin
1665             Build_Location_String (Buf, Loc);
1666 
1667             --  If the exception is a renaming, use the exception that it
1668             --  renames (which might be a predefined exception, e.g.).
1669 
1670             if Present (Renamed_Object (Id)) then
1671                Id := Renamed_Object (Id);
1672             end if;
1673 
1674             --  Build a C-compatible string in case of no exception handlers,
1675             --  since this is what the last chance handler is expecting.
1676 
1677             if No_Exception_Handlers_Set then
1678 
1679                --  Generate an empty message if configuration pragma
1680                --  Suppress_Exception_Locations is set for this unit.
1681 
1682                if Opt.Exception_Locations_Suppressed then
1683                   Buf.Length := 0;
1684                end if;
1685 
1686                Append (Buf, ASCII.NUL);
1687             end if;
1688 
1689             if Opt.Exception_Locations_Suppressed then
1690                Buf.Length := 0;
1691             end if;
1692 
1693             Str := String_From_Name_Buffer (Buf);
1694 
1695             --  Convert raise to call to the Raise_Exception routine
1696 
1697             Rewrite (N,
1698               Make_Procedure_Call_Statement (Loc,
1699                  Name                   =>
1700                    New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1701                  Parameter_Associations => New_List (
1702                    Make_Attribute_Reference (Loc,
1703                      Prefix         => Name (N),
1704                      Attribute_Name => Name_Identity),
1705                    Make_String_Literal (Loc, Strval => Str))));
1706          end;
1707 
1708       --  Case of no name present (reraise). We rewrite the raise to:
1709 
1710       --    Reraise_Occurrence_Always (EO);
1711 
1712       --  where EO is the current exception occurrence. If the current handler
1713       --  does not have a choice parameter specification, then we provide one.
1714 
1715       else
1716          --  Bypass expansion to a run-time call when back-end exception
1717          --  handling is active, unless the target is CodePeer or GNATprove.
1718          --  In CodePeer, raising an exception is treated as an error, while in
1719          --  GNATprove all code with exceptions falls outside the subset of
1720          --  code which can be formally analyzed.
1721 
1722          if not CodePeer_Mode
1723            and then Back_End_Exceptions
1724          then
1725             return;
1726          end if;
1727 
1728          --  Find innermost enclosing exception handler (there must be one,
1729          --  since the semantics has already verified that this raise statement
1730          --  is valid, and a raise with no arguments is only permitted in the
1731          --  context of an exception handler.
1732 
1733          Ehand := Parent (N);
1734          while Nkind (Ehand) /= N_Exception_Handler loop
1735             Ehand := Parent (Ehand);
1736          end loop;
1737 
1738          --  Make exception choice parameter if none present. Note that we do
1739          --  not need to put the entity on the entity chain, since no one will
1740          --  be referencing this entity by normal visibility methods.
1741 
1742          if No (Choice_Parameter (Ehand)) then
1743             E := Make_Temporary (Loc, 'E');
1744             Set_Choice_Parameter (Ehand, E);
1745             Set_Ekind (E, E_Variable);
1746             Set_Etype (E, RTE (RE_Exception_Occurrence));
1747             Set_Scope (E, Current_Scope);
1748          end if;
1749 
1750          --  Now rewrite the raise as a call to Reraise. A special case arises
1751          --  if this raise statement occurs in the context of a handler for
1752          --  all others (i.e. an at end handler). in this case we avoid
1753          --  the call to defer abort, cleanup routines are expected to be
1754          --  called in this case with aborts deferred.
1755 
1756          declare
1757             Ech : constant Node_Id := First (Exception_Choices (Ehand));
1758             Ent : Entity_Id;
1759 
1760          begin
1761             if Nkind (Ech) = N_Others_Choice
1762               and then All_Others (Ech)
1763             then
1764                Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1765             else
1766                Ent := RTE (RE_Reraise_Occurrence_Always);
1767             end if;
1768 
1769             Rewrite (N,
1770               Make_Procedure_Call_Statement (Loc,
1771                 Name => New_Occurrence_Of (Ent, Loc),
1772                 Parameter_Associations => New_List (
1773                   New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1774          end;
1775       end if;
1776 
1777       Analyze (N);
1778    end Expand_N_Raise_Statement;
1779 
1780    ----------------------------------
1781    -- Expand_N_Raise_Storage_Error --
1782    ----------------------------------
1783 
1784    procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1785    begin
1786       --  We adjust the condition to deal with the C/Fortran boolean case. This
1787       --  may well not be necessary, as all such conditions are generated by
1788       --  the expander and probably are all standard boolean, but who knows
1789       --  what strange optimization in future may require this adjustment.
1790 
1791       Adjust_Condition (Condition (N));
1792 
1793       --  Now deal with possible local raise handling
1794 
1795       Possible_Local_Raise (N, Standard_Storage_Error);
1796    end Expand_N_Raise_Storage_Error;
1797 
1798    --------------------------
1799    -- Possible_Local_Raise --
1800    --------------------------
1801 
1802    procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1803    begin
1804       --  Nothing to do if local raise optimization not active
1805 
1806       if not Debug_Flag_Dot_G
1807         and then not Restriction_Active (No_Exception_Propagation)
1808       then
1809          return;
1810       end if;
1811 
1812       --  Nothing to do if original node was an explicit raise, because in
1813       --  that case, we already generated the required warning for the raise.
1814 
1815       if Nkind (Original_Node (N)) = N_Raise_Statement then
1816          return;
1817       end if;
1818 
1819       --  Otherwise see if we have a local handler for the exception
1820 
1821       declare
1822          H : constant Node_Id := Find_Local_Handler (E, N);
1823 
1824       begin
1825          --  If so, mark that it has a local raise
1826 
1827          if Present (H) then
1828             Set_Has_Local_Raise (H, True);
1829 
1830          --  Otherwise, if the No_Exception_Propagation restriction is active
1831          --  and the warning is enabled, generate the appropriate warnings.
1832 
1833          elsif Warn_On_Non_Local_Exception
1834            and then Restriction_Active (No_Exception_Propagation)
1835          then
1836             Warn_No_Exception_Propagation_Active (N);
1837 
1838             if Configurable_Run_Time_Mode then
1839                Error_Msg_NE
1840                  ("\?X?& may call Last_Chance_Handler", N, E);
1841             else
1842                Error_Msg_NE
1843                  ("\?X?& may result in unhandled exception", N, E);
1844             end if;
1845          end if;
1846       end;
1847    end Possible_Local_Raise;
1848 
1849    ------------------------
1850    -- Find_Local_Handler --
1851    ------------------------
1852 
1853    function Find_Local_Handler
1854      (Ename : Entity_Id;
1855       Nod   : Node_Id) return Node_Id
1856    is
1857       N : Node_Id;
1858       P : Node_Id;
1859       H : Node_Id;
1860       C : Node_Id;
1861 
1862       SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1863       --  This is used to test for wrapped actions below
1864 
1865       ERaise  : Entity_Id;
1866       EHandle : Entity_Id;
1867       --  The entity Id's for the exception we are raising and handling, using
1868       --  the renamed exception if a Renamed_Entity is present.
1869 
1870    begin
1871       --  Never any local handler if all handlers removed
1872 
1873       if Debug_Flag_Dot_X then
1874          return Empty;
1875       end if;
1876 
1877       --  Get the exception we are raising, allowing for renaming
1878 
1879       ERaise := Get_Renamed_Entity (Ename);
1880 
1881       --  We need to check if the node we are looking at is contained in
1882       --
1883 
1884       --  Loop to search up the tree
1885 
1886       N := Nod;
1887       loop
1888          P := Parent (N);
1889 
1890          --  If we get to the top of the tree, or to a subprogram, task, entry,
1891          --  protected body, or accept statement without having found a
1892          --  matching handler, then there is no local handler.
1893 
1894          if No (P)
1895            or else Nkind (P) = N_Subprogram_Body
1896            or else Nkind (P) = N_Task_Body
1897            or else Nkind (P) = N_Protected_Body
1898            or else Nkind (P) = N_Entry_Body
1899            or else Nkind (P) = N_Accept_Statement
1900          then
1901             return Empty;
1902 
1903             --  Test for handled sequence of statements with at least one
1904             --  exception handler which might be the one we are looking for.
1905 
1906          elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1907            and then Present (Exception_Handlers (P))
1908          then
1909             --  Before we proceed we need to check if the node N is covered
1910             --  by the statement part of P rather than one of its exception
1911             --  handlers (an exception handler obviously does not cover its
1912             --  own statements).
1913 
1914             --  This test is more delicate than might be thought. It is not
1915             --  just a matter of checking the Statements (P), because the node
1916             --  might be waiting to be wrapped in a transient scope, in which
1917             --  case it will end up in the block statements, even though it
1918             --  is not there now.
1919 
1920             if Is_List_Member (N) then
1921                declare
1922                   LCN : constant List_Id := List_Containing (N);
1923 
1924                begin
1925                   if LCN = Statements (P)
1926                        or else
1927                      LCN = SSE.Actions_To_Be_Wrapped (Before)
1928                        or else
1929                      LCN = SSE.Actions_To_Be_Wrapped (After)
1930                        or else
1931                      LCN = SSE.Actions_To_Be_Wrapped (Cleanup)
1932                   then
1933                      --  Loop through exception handlers
1934 
1935                      H := First (Exception_Handlers (P));
1936                      while Present (H) loop
1937 
1938                         --  Guard against other constructs appearing in the
1939                         --  list of exception handlers.
1940 
1941                         if Nkind (H) = N_Exception_Handler then
1942 
1943                            --  Loop through choices in one handler
1944 
1945                            C := First (Exception_Choices (H));
1946                            while Present (C) loop
1947 
1948                               --  Deal with others case
1949 
1950                               if Nkind (C) = N_Others_Choice then
1951 
1952                                  --  Matching others handler, but we need
1953                                  --  to ensure there is no choice parameter.
1954                                  --  If there is, then we don't have a local
1955                                  --  handler after all (since we do not allow
1956                                  --  choice parameters for local handlers).
1957 
1958                                  if No (Choice_Parameter (H)) then
1959                                     return H;
1960                                  else
1961                                     return Empty;
1962                                  end if;
1963 
1964                                  --  If not others must be entity name
1965 
1966                               elsif Nkind (C) /= N_Others_Choice then
1967                                  pragma Assert (Is_Entity_Name (C));
1968                                  pragma Assert (Present (Entity (C)));
1969 
1970                                  --  Get exception being handled, dealing with
1971                                  --  renaming.
1972 
1973                                  EHandle := Get_Renamed_Entity (Entity (C));
1974 
1975                                  --  If match, then check choice parameter
1976 
1977                                  if ERaise = EHandle then
1978                                     if No (Choice_Parameter (H)) then
1979                                        return H;
1980                                     else
1981                                        return Empty;
1982                                     end if;
1983                                  end if;
1984                               end if;
1985 
1986                               Next (C);
1987                            end loop;
1988                         end if;
1989 
1990                         Next (H);
1991                      end loop;
1992                   end if;
1993                end;
1994             end if;
1995          end if;
1996 
1997          N := P;
1998       end loop;
1999    end Find_Local_Handler;
2000 
2001    ---------------------------------
2002    -- Get_Local_Raise_Call_Entity --
2003    ---------------------------------
2004 
2005    --  Note: this is primarily provided for use by the back end in generating
2006    --  calls to Local_Raise. But it would be too late in the back end to call
2007    --  RTE if this actually caused a load/analyze of the unit. So what we do
2008    --  is to ensure there is a dummy call to this function during front end
2009    --  processing so that the unit gets loaded then, and not later.
2010 
2011    Local_Raise_Call_Entity     : Entity_Id;
2012    Local_Raise_Call_Entity_Set : Boolean := False;
2013 
2014    function Get_Local_Raise_Call_Entity return Entity_Id is
2015    begin
2016       if not Local_Raise_Call_Entity_Set then
2017          Local_Raise_Call_Entity_Set := True;
2018 
2019          if RTE_Available (RE_Local_Raise) then
2020             Local_Raise_Call_Entity := RTE (RE_Local_Raise);
2021          else
2022             Local_Raise_Call_Entity := Empty;
2023          end if;
2024       end if;
2025 
2026       return Local_Raise_Call_Entity;
2027    end Get_Local_Raise_Call_Entity;
2028 
2029    -----------------------------
2030    -- Get_RT_Exception_Entity --
2031    -----------------------------
2032 
2033    function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
2034    begin
2035       case Rkind (R) is
2036          when CE_Reason => return Standard_Constraint_Error;
2037          when PE_Reason => return Standard_Program_Error;
2038          when SE_Reason => return Standard_Storage_Error;
2039       end case;
2040    end Get_RT_Exception_Entity;
2041 
2042    ---------------------------
2043    -- Get_RT_Exception_Name --
2044    ---------------------------
2045 
2046    procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is
2047    begin
2048       case Code is
2049          when CE_Access_Check_Failed =>
2050             Add_Str_To_Name_Buffer ("CE_Access_Check");
2051          when CE_Access_Parameter_Is_Null =>
2052             Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter");
2053          when CE_Discriminant_Check_Failed =>
2054             Add_Str_To_Name_Buffer ("CE_Discriminant_Check");
2055          when CE_Divide_By_Zero =>
2056             Add_Str_To_Name_Buffer ("CE_Divide_By_Zero");
2057          when CE_Explicit_Raise =>
2058             Add_Str_To_Name_Buffer ("CE_Explicit_Raise");
2059          when CE_Index_Check_Failed =>
2060             Add_Str_To_Name_Buffer ("CE_Index_Check");
2061          when CE_Invalid_Data =>
2062             Add_Str_To_Name_Buffer ("CE_Invalid_Data");
2063          when CE_Length_Check_Failed =>
2064             Add_Str_To_Name_Buffer ("CE_Length_Check");
2065          when CE_Null_Exception_Id =>
2066             Add_Str_To_Name_Buffer ("CE_Null_Exception_Id");
2067          when CE_Null_Not_Allowed =>
2068             Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed");
2069          when CE_Overflow_Check_Failed =>
2070             Add_Str_To_Name_Buffer ("CE_Overflow_Check");
2071          when CE_Partition_Check_Failed =>
2072             Add_Str_To_Name_Buffer ("CE_Partition_Check");
2073          when CE_Range_Check_Failed =>
2074             Add_Str_To_Name_Buffer ("CE_Range_Check");
2075          when CE_Tag_Check_Failed =>
2076             Add_Str_To_Name_Buffer ("CE_Tag_Check");
2077 
2078          when PE_Access_Before_Elaboration =>
2079             Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration");
2080          when PE_Accessibility_Check_Failed =>
2081             Add_Str_To_Name_Buffer ("PE_Accessibility_Check");
2082          when PE_Address_Of_Intrinsic =>
2083             Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic");
2084          when PE_Aliased_Parameters =>
2085             Add_Str_To_Name_Buffer ("PE_Aliased_Parameters");
2086          when PE_All_Guards_Closed =>
2087             Add_Str_To_Name_Buffer ("PE_All_Guards_Closed");
2088          when PE_Bad_Predicated_Generic_Type =>
2089             Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type");
2090          when PE_Current_Task_In_Entry_Body =>
2091             Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body");
2092          when PE_Duplicated_Entry_Address =>
2093             Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address");
2094          when PE_Explicit_Raise =>
2095             Add_Str_To_Name_Buffer ("PE_Explicit_Raise");
2096          when PE_Finalize_Raised_Exception =>
2097             Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception");
2098          when PE_Implicit_Return =>
2099             Add_Str_To_Name_Buffer ("PE_Implicit_Return");
2100          when PE_Misaligned_Address_Value =>
2101             Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value");
2102          when PE_Missing_Return =>
2103             Add_Str_To_Name_Buffer ("PE_Missing_Return");
2104          when PE_Non_Transportable_Actual =>
2105             Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual");
2106          when PE_Overlaid_Controlled_Object =>
2107             Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object");
2108          when PE_Potentially_Blocking_Operation =>
2109             Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation");
2110          when PE_Stream_Operation_Not_Allowed =>
2111             Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed");
2112          when PE_Stubbed_Subprogram_Called =>
2113             Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called");
2114          when PE_Unchecked_Union_Restriction =>
2115             Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction");
2116 
2117          when SE_Empty_Storage_Pool =>
2118             Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool");
2119          when SE_Explicit_Raise =>
2120             Add_Str_To_Name_Buffer ("SE_Explicit_Raise");
2121          when SE_Infinite_Recursion =>
2122             Add_Str_To_Name_Buffer ("SE_Infinite_Recursion");
2123          when SE_Object_Too_Large =>
2124             Add_Str_To_Name_Buffer ("SE_Object_Too_Large");
2125       end case;
2126    end Get_RT_Exception_Name;
2127 
2128    ----------------------------
2129    -- Warn_If_No_Propagation --
2130    ----------------------------
2131 
2132    procedure Warn_If_No_Propagation (N : Node_Id) is
2133    begin
2134       if Restriction_Check_Required (No_Exception_Propagation)
2135         and then Warn_On_Non_Local_Exception
2136       then
2137          Warn_No_Exception_Propagation_Active (N);
2138 
2139          if Configurable_Run_Time_Mode then
2140             Error_Msg_N
2141               ("\?X?Last_Chance_Handler will be called on exception", N);
2142          else
2143             Error_Msg_N
2144               ("\?X?execution may raise unhandled exception", N);
2145          end if;
2146       end if;
2147    end Warn_If_No_Propagation;
2148 
2149    ------------------------------------------
2150    -- Warn_No_Exception_Propagation_Active --
2151    ------------------------------------------
2152 
2153    procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
2154    begin
2155       Error_Msg_N
2156         ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N);
2157    end Warn_No_Exception_Propagation_Active;
2158 
2159 end Exp_Ch11;