gcc/ada/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-2012, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Util; use Exp_Util;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Restrict; use Restrict;
  39 with Rident;   use Rident;
  40 with Rtsfind;  use Rtsfind;
  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; Block : Node_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       --  Don't expand if back end exception handling active
 120
 121       if Exception_Mechanism = Back_End_Exceptions then
 122          return;
 123       end if;
 124
 125       --  Don't expand an At End handler if we have already had configurable
 126       --  run-time violations, since likely this will just be a matter of
 127       --  generating useless cascaded messages
 128
 129       if Configurable_Run_Time_Violations > 0 then
 130          return;
 131       end if;
 132
 133       --  Don't expand an At End handler if we are not allowing exceptions
 134       --  or if exceptions are transformed into local gotos, and never
 135       --  propagated (No_Exception_Propagation).
 136
 137       if No_Exception_Handlers_Set then
 138          return;
 139       end if;
 140
 141       if Present (Block) then
 142          Push_Scope (Block);
 143       end if;
 144
 145       Ohandle :=
 146         Make_Others_Choice (Loc);
 147       Set_All_Others (Ohandle);
 148
 149       Stmnts := New_List (
 150         Make_Procedure_Call_Statement (Loc,
 151           Name => New_Occurrence_Of (Clean, Loc)));
 152
 153       --  Generate reraise statement as last statement of AT-END handler,
 154       --  unless we are under control of No_Exception_Propagation, in which
 155       --  case no exception propagation is possible anyway, so we do not need
 156       --  a reraise (the AT END handler in this case is only for normal exits
 157       --  not for exceptional exits). Also, we flag the Reraise statement as
 158       --  being part of an AT END handler to prevent signalling this reraise
 159       --  as a violation of the restriction when it is not set.
 160
 161       if not Restriction_Active (No_Exception_Propagation) then
 162          declare
 163             Rstm : constant Node_Id := Make_Raise_Statement (Loc);
 164          begin
 165             Set_From_At_End (Rstm);
 166             Append_To (Stmnts, Rstm);
 167          end;
 168       end if;
 169
 170       Set_Exception_Handlers (HSS, New_List (
 171         Make_Implicit_Exception_Handler (Loc,
 172           Exception_Choices => New_List (Ohandle),
 173           Statements        => Stmnts)));
 174
 175       Analyze_List (Stmnts, Suppress => All_Checks);
 176       Expand_Exception_Handlers (HSS);
 177
 178       if Present (Block) then
 179          Pop_Scope;
 180       end if;
 181    end Expand_At_End_Handler;
 182
 183    -------------------------------
 184    -- Expand_Exception_Handlers --
 185    -------------------------------
 186
 187    procedure Expand_Exception_Handlers (HSS : Node_Id) is
 188       Handlrs       : constant List_Id    := Exception_Handlers (HSS);
 189       Loc           : constant Source_Ptr := Sloc (HSS);
 190       Handler       : Node_Id;
 191       Others_Choice : Boolean;
 192       Obj_Decl      : Node_Id;
 193       Next_Handler  : Node_Id;
 194
 195       procedure Expand_Local_Exception_Handlers;
 196       --  This procedure handles the expansion of exception handlers for the
 197       --  optimization of local raise statements into goto statements.
 198
 199       procedure Prepend_Call_To_Handler
 200         (Proc : RE_Id;
 201          Args : List_Id := No_List);
 202       --  Routine to prepend a call to the procedure referenced by Proc at
 203       --  the start of the handler code for the current Handler.
 204
 205       procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
 206       --  Raise_S is a raise statement (possibly expanded, and possibly of the
 207       --  form of a Raise_xxx_Error node with a condition. This procedure is
 208       --  called to replace the raise action with the (already analyzed) goto
 209       --  statement passed as Goto_L1. This procedure also takes care of the
 210       --  requirement of inserting a Local_Raise call where possible.
 211
 212       -------------------------------------
 213       -- Expand_Local_Exception_Handlers --
 214       -------------------------------------
 215
 216       --  There are two cases for this transformation. First the case of
 217       --  explicit raise statements. For this case, the transformation we do
 218       --  looks like this. Right now we have for example (where L1, L2 are
 219       --  exception labels)
 220
 221       --  begin
 222       --     ...
 223       --     raise_exception (excep1'identity);  -- was raise excep1
 224       --     ...
 225       --     raise_exception (excep2'identity);  -- was raise excep2
 226       --     ...
 227       --  exception
 228       --     when excep1 =>
 229       --        estmts1
 230       --     when excep2 =>
 231       --        estmts2
 232       --  end;
 233
 234       --  This gets transformed into:
 235
 236       --  begin
 237       --     L1 : label;                        -- marked Exception_Junk
 238       --     L2 : label;                        -- marked Exception_Junk
 239       --     L3 : label;                        -- marked Exception_Junk
 240
 241       --     begin                              -- marked Exception_Junk
 242       --        ...
 243       --        local_raise (excep1'address);   -- was raise excep1
 244       --        goto L1;
 245       --        ...
 246       --        local_raise (excep2'address);   -- was raise excep2
 247       --        goto L2;
 248       --        ...
 249       --     exception
 250       --        when excep1 =>
 251       --           goto L1;
 252       --        when excep2 =>
 253       --           goto L2;
 254       --     end;
 255
 256       --     goto L3;        -- skip handler if no raise, marked Exception_Junk
 257
 258       --     <<L1>>          -- local excep target label, marked Exception_Junk
 259       --        begin        -- marked Exception_Junk
 260       --           estmts1
 261       --        end;
 262       --        goto L3;     -- marked Exception_Junk
 263
 264       --     <<L2>>          -- marked Exception_Junk
 265       --        begin        -- marked Exception_Junk
 266       --           estmts2
 267       --        end;
 268       --        goto L3;     -- marked Exception_Junk
 269       --     <<L3>>          -- marked Exception_Junk
 270       --  end;
 271
 272       --  Note: the reason we wrap the original statement sequence in an
 273       --  inner block is that there may be raise statements within the
 274       --  sequence of statements in the handlers, and we must ensure that
 275       --  these are properly handled, and in particular, such raise statements
 276       --  must not reenter the same exception handlers.
 277
 278       --  If the restriction No_Exception_Propagation is in effect, then we
 279       --  can omit the exception handlers.
 280
 281       --  begin
 282       --     L1 : label;                        -- marked Exception_Junk
 283       --     L2 : label;                        -- marked Exception_Junk
 284       --     L3 : label;                        -- marked Exception_Junk
 285
 286       --     begin                              -- marked Exception_Junk
 287       --        ...
 288       --        local_raise (excep1'address);   -- was raise excep1
 289       --        goto L1;
 290       --        ...
 291       --        local_raise (excep2'address);   -- was raise excep2
 292       --        goto L2;
 293       --        ...
 294       --     end;
 295
 296       --     goto L3;        -- skip handler if no raise, marked Exception_Junk
 297
 298       --     <<L1>>          -- local excep target label, marked Exception_Junk
 299       --        begin        -- marked Exception_Junk
 300       --           estmts1
 301       --        end;
 302       --        goto L3;     -- marked Exception_Junk
 303
 304       --     <<L2>>          -- marked Exception_Junk
 305       --        begin        -- marked Exception_Junk
 306       --           estmts2
 307       --        end;
 308
 309       --     <<L3>>          -- marked Exception_Junk
 310       --  end;
 311
 312       --  The second case is for exceptions generated by the back end in one
 313       --  of three situations:
 314
 315       --    1. Front end generates N_Raise_xxx_Error node
 316       --    2. Front end sets Do_xxx_Check flag in subexpression node
 317       --    3. Back end detects a situation where an exception is appropriate
 318
 319       --  In all these cases, the current processing in gigi is to generate a
 320       --  call to the appropriate Rcheck_xx routine (where xx encodes both the
 321       --  exception message and the exception to be raised, Constraint_Error,
 322       --  Program_Error, or Storage_Error.
 323
 324       --  We could handle some subcases of 1 using the same front end expansion
 325       --  into gotos, but even for case 1, we can't handle all cases, since
 326       --  generating gotos in the middle of expressions is not possible (it's
 327       --  possible at the gigi/gcc level, but not at the level of the GNAT
 328       --  tree).
 329
 330       --  In any case, it seems easier to have a scheme which handles all three
 331       --  cases in a uniform manner. So here is how we proceed in this case.
 332
 333       --  This procedure detects all handlers for these three exceptions,
 334       --  Constraint_Error, Program_Error and Storage_Error (including WHEN
 335       --  OTHERS handlers that cover one or more of these cases).
 336
 337       --  If the handler meets the requirements for being the target of a local
 338       --  raise, then the front end does the expansion described previously,
 339       --  creating a label to be used as a goto target to raise the exception.
 340       --  However, no attempt is made in the front end to convert any related
 341       --  raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
 342       --  left unchanged and passed to the back end.
 343
 344       --  Instead, the front end generates three nodes
 345
 346       --     N_Push_Constraint_Error_Label
 347       --     N_Push_Program_Error_Label
 348       --     N_Push_Storage_Error_Label
 349
 350       --       The Push node is generated at the start of the statements
 351       --       covered by the handler, and has as a parameter the label to be
 352       --       used as the raise target.
 353
 354       --     N_Pop_Constraint_Error_Label
 355       --     N_Pop_Program_Error_Label
 356       --     N_Pop_Storage_Error_Label
 357
 358       --       The Pop node is generated at the end of the covered statements
 359       --       and undoes the effect of the preceding corresponding Push node.
 360
 361       --  In the case where the handler does NOT meet the requirements, the
 362       --  front end will still generate the Push and Pop nodes, but the label
 363       --  field in the Push node will be empty signifying that for this region
 364       --  of code, no optimization is possible.
 365
 366       --  These Push/Pop nodes are inhibited if No_Exception_Handlers is set
 367       --  since they are useless in this case, and in CodePeer mode, where
 368       --  they serve no purpose and can intefere with the analysis.
 369
 370       --  The back end must maintain three stacks, one for each exception case,
 371       --  the Push node pushes an entry onto the corresponding stack, and Pop
 372       --  node pops off the entry. Then instead of calling Rcheck_nn, if the
 373       --  corresponding top stack entry has an non-empty label, a goto is
 374       --  generated. This goto should be preceded by a call to Local_Raise as
 375       --  described above.
 376
 377       --  An example of this transformation is as follows, given:
 378
 379       --  declare
 380       --    A : Integer range 1 .. 10;
 381       --  begin
 382       --    A := B + C;
 383       --  exception
 384       --    when Constraint_Error =>
 385       --       estmts
 386       --  end;
 387
 388       --  gets transformed to:
 389
 390       --  declare
 391       --    A : Integer range 1 .. 10;
 392
 393       --  begin
 394       --     L1 : label;
 395       --     L2 : label;
 396
 397       --     begin
 398       --        %push_constraint_error_label (L1)
 399       --        R1b : constant long_long_integer := long_long_integer?(b) +
 400       --          long_long_integer?(c);
 401       --        [constraint_error when
 402       --          not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
 403       --          "overflow check failed"]
 404       --        a := integer?(R1b);
 405       --        %pop_constraint_error_Label
 406
 407       --     exception
 408       --        ...
 409       --        when constraint_error =>
 410       --           goto L1;
 411       --     end;
 412
 413       --     goto L2;       -- skip handler when exception not raised
 414       --     <<L1>>         -- target label for local exception
 415       --     estmts
 416       --     <<L2>>
 417       --  end;
 418
 419       --  Note: the generated labels and goto statements all have the flag
 420       --  Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
 421       --  this generated exception stuff when checking for missing return
 422       --  statements (see circuitry in Check_Statement_Sequence).
 423
 424       --  Note: All of the processing described above occurs only if
 425       --  restriction No_Exception_Propagation applies or debug flag .g is
 426       --  enabled.
 427
 428       CE_Locally_Handled : Boolean := False;
 429       SE_Locally_Handled : Boolean := False;
 430       PE_Locally_Handled : Boolean := False;
 431       --  These three flags indicate whether a handler for the corresponding
 432       --  exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
 433       --  is present. If so the switch is set to True, the Exception_Label
 434       --  field of the corresponding handler is set, and appropriate Push
 435       --  and Pop nodes are inserted into the code.
 436
 437       Local_Expansion_Required : Boolean := False;
 438       --  Set True if we have at least one handler requiring local raise
 439       --  expansion as described above.
 440
 441       procedure Expand_Local_Exception_Handlers is
 442
 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                  ("\?this handler can never be entered, and has been removed",
1009                   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                if Present (Choice_Parameter (Handler)) then
1029                   declare
1030                      Cparm : constant Entity_Id  := Choice_Parameter (Handler);
1031                      Cloc  : constant Source_Ptr := Sloc (Cparm);
1032                      Hloc  : constant Source_Ptr := Sloc (Handler);
1033                      Save  : Node_Id;
1034
1035                   begin
1036                      --  Note use of No_Location to hide this code from the
1037                      --  debugger, so single stepping doesn't jump back and
1038                      --  forth.
1039
1040                      Save :=
1041                        Make_Procedure_Call_Statement (No_Location,
1042                          Name =>
1043                            New_Occurrence_Of
1044                              (RTE (RE_Save_Occurrence), No_Location),
1045                          Parameter_Associations => New_List (
1046                            New_Occurrence_Of (Cparm, No_Location),
1047                            Make_Explicit_Dereference (No_Location,
1048                              Make_Function_Call (No_Location,
1049                                Name =>
1050                                  Make_Explicit_Dereference (No_Location,
1051                                    New_Occurrence_Of
1052                                      (RTE (RE_Get_Current_Excep),
1053                                       No_Location))))));
1054
1055                      Mark_Rewrite_Insertion (Save);
1056                      Prepend (Save, Statements (Handler));
1057
1058                      Obj_Decl :=
1059                        Make_Object_Declaration
1060                          (Cloc,
1061                           Defining_Identifier => Cparm,
1062                           Object_Definition   =>
1063                             New_Occurrence_Of
1064                               (RTE (RE_Exception_Occurrence), Cloc));
1065                      Set_No_Initialization (Obj_Decl, True);
1066
1067                      Rewrite (Handler,
1068                        Make_Exception_Handler (Hloc,
1069                          Choice_Parameter  => Empty,
1070                          Exception_Choices => Exception_Choices (Handler),
1071
1072                          Statements => New_List (
1073                            Make_Block_Statement (Hloc,
1074                              Declarations => New_List (Obj_Decl),
1075                              Handled_Statement_Sequence =>
1076                                Make_Handled_Sequence_Of_Statements (Hloc,
1077                                  Statements => Statements (Handler))))));
1078
1079                      --  Local raise statements can't occur, since exception
1080                      --  handlers with choice parameters are not allowed when
1081                      --  No_Exception_Propagation applies, so set attributes
1082                      --  accordingly.
1083
1084                      Set_Local_Raise_Statements (Handler, No_Elist);
1085                      Set_Local_Raise_Not_OK (Handler);
1086
1087                      Analyze_List
1088                        (Statements (Handler), Suppress => All_Checks);
1089                   end;
1090                end if;
1091
1092                --  The processing at this point is rather different for the JVM
1093                --  case, so we completely separate the processing.
1094
1095                --  For the VM case, we unconditionally call Update_Exception,
1096                --  passing a call to the intrinsic Current_Target_Exception
1097                --  (see JVM/.NET versions of Ada.Exceptions for details).
1098
1099                if VM_Target /= No_VM then
1100                   declare
1101                      Arg : constant Node_Id :=
1102                              Make_Function_Call (Loc,
1103                                Name =>
1104                                  New_Occurrence_Of
1105                                    (RTE (RE_Current_Target_Exception), Loc));
1106                   begin
1107                      Prepend_Call_To_Handler
1108                        (RE_Update_Exception, New_List (Arg));
1109                   end;
1110
1111                   --  For the normal case, we have to worry about the state of
1112                   --  abort deferral. Generally, we defer abort during runtime
1113                   --  handling of exceptions. When control is passed to the
1114                   --  handler, then in the normal case we undefer aborts. In
1115                   --  any case this entire handling is relevant only if aborts
1116                   --  are allowed!
1117
1118                elsif Abort_Allowed
1119                  and then Exception_Mechanism /= Back_End_Exceptions
1120                then
1121                   --  There are some special cases in which we do not do the
1122                   --  undefer. In particular a finalization (AT END) handler
1123                   --  wants to operate with aborts still deferred.
1124
1125                   --  We also suppress the call if this is the special handler
1126                   --  for Abort_Signal, since if we are aborting, we want to
1127                   --  keep aborts deferred (one abort is enough).
1128
1129                   --  If abort really needs to be deferred the expander must
1130                   --  add this call explicitly, see
1131                   --  Expand_N_Asynchronous_Select.
1132
1133                   Others_Choice :=
1134                     Nkind (First (Exception_Choices (Handler))) =
1135                                                          N_Others_Choice;
1136
1137                   if (Others_Choice
1138                        or else Entity (First (Exception_Choices (Handler))) /=
1139                                                          Stand.Abort_Signal)
1140                     and then not
1141                       (Others_Choice
1142                         and then
1143                           All_Others (First (Exception_Choices (Handler))))
1144                   then
1145                      Prepend_Call_To_Handler (RE_Abort_Undefer);
1146                   end if;
1147                end if;
1148             end if;
1149          end if;
1150
1151          Handler := Next_Handler;
1152       end loop Handler_Loop;
1153
1154       --  If all handlers got removed, then remove the list. Note we cannot
1155       --  reference HSS here, since expanding local handlers may have buried
1156       --  the handlers in an inner block.
1157
1158       if Is_Empty_List (Handlrs) then
1159          Set_Exception_Handlers (Parent (Handlrs), No_List);
1160       end if;
1161    end Expand_Exception_Handlers;
1162
1163    ------------------------------------
1164    -- Expand_N_Exception_Declaration --
1165    ------------------------------------
1166
1167    --  Generates:
1168    --     exceptE : constant String := "A.B.EXCEP";   -- static data
1169    --     except : exception_data :=  (
1170    --                    Handled_By_Other => False,
1171    --                    Lang             => 'A',
1172    --                    Name_Length      => exceptE'Length,
1173    --                    Full_Name        => exceptE'Address,
1174    --                    HTable_Ptr       => null,
1175    --                    Import_Code      => 0,
1176    --                    Raise_Hook       => null,
1177    --                    );
1178
1179    --  (protecting test only needed if not at library level)
1180    --
1181    --     exceptF : Boolean := True --  static data
1182    --     if exceptF then
1183    --        exceptF := False;
1184    --        Register_Exception (except'Unchecked_Access);
1185    --     end if;
1186
1187    procedure Expand_N_Exception_Declaration (N : Node_Id) is
1188       Loc     : constant Source_Ptr := Sloc (N);
1189       Id      : constant Entity_Id  := Defining_Identifier (N);
1190       L       : List_Id             := New_List;
1191       Flag_Id : Entity_Id;
1192
1193       Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1194       Exname      : constant Node_Id :=
1195                       Make_Defining_Identifier (Loc, Name_Exname);
1196
1197       procedure Force_Static_Allocation_Of_Referenced_Objects
1198         (Aggregate : Node_Id);
1199       --  A specialized solution to one particular case of an ugly problem
1200       --
1201       --  The given aggregate includes an Unchecked_Conversion as one of the
1202       --  component values. The call to Analyze_And_Resolve below ends up
1203       --  calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1204       --  to introduce a (constant) temporary and then obtain the component
1205       --  value by evaluating the temporary.
1206       --
1207       --  In the case of an exception declared within a subprogram (or any
1208       --  other dynamic scope), this is a bad transformation. The exception
1209       --  object is marked as being Statically_Allocated but the temporary is
1210       --  not. If the initial value of a Statically_Allocated declaration
1211       --  references a dynamically allocated object, this prevents static
1212       --  initialization of the object.
1213       --
1214       --  We cope with this here by marking the temporary Statically_Allocated.
1215       --  It might seem cleaner to generalize this utility and then use it to
1216       --  enforce a rule that the entities referenced in the declaration of any
1217       --  "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1218       --  entity must also be either Library_Level or hoisted. It turns out
1219       --  that this would be incompatible with the current treatment of an
1220       --  object which is local to a subprogram, subject to an Export pragma,
1221       --  not subject to an address clause, and whose declaration contains
1222       --  references to other local (non-hoisted) objects (e.g., in the initial
1223       --  value expression).
1224
1225       ---------------------------------------------------
1226       -- Force_Static_Allocation_Of_Referenced_Objects --
1227       ---------------------------------------------------
1228
1229       procedure Force_Static_Allocation_Of_Referenced_Objects
1230         (Aggregate : Node_Id)
1231       is
1232          function Fixup_Node (N : Node_Id) return Traverse_Result;
1233          --  If the given node references a dynamically allocated object, then
1234          --  correct the declaration of the object.
1235
1236          ----------------
1237          -- Fixup_Node --
1238          ----------------
1239
1240          function Fixup_Node (N : Node_Id) return Traverse_Result is
1241          begin
1242             if Nkind (N) in N_Has_Entity
1243               and then Present (Entity (N))
1244               and then not Is_Library_Level_Entity (Entity (N))
1245
1246               --  Note: the following test is not needed but it seems cleaner
1247               --  to do this test (this would be more important if procedure
1248               --  Force_Static_Allocation_Of_Referenced_Objects recursively
1249               --  traversed the declaration of an entity after marking it as
1250               --  statically allocated).
1251
1252               and then not Is_Statically_Allocated (Entity (N))
1253             then
1254                Set_Is_Statically_Allocated (Entity (N));
1255             end if;
1256
1257             return OK;
1258          end Fixup_Node;
1259
1260          procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
1261
1262       --  Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1263
1264       begin
1265          Fixup_Tree (Aggregate);
1266       end Force_Static_Allocation_Of_Referenced_Objects;
1267
1268    --  Start of processing for Expand_N_Exception_Declaration
1269
1270    begin
1271       --  There is no expansion needed when compiling for the JVM since the
1272       --  JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
1273       --  for details.
1274
1275       if VM_Target /= No_VM then
1276          return;
1277       end if;
1278
1279       --  Definition of the external name: nam : constant String := "A.B.NAME";
1280
1281       Insert_Action (N,
1282         Make_Object_Declaration (Loc,
1283           Defining_Identifier => Exname,
1284           Constant_Present    => True,
1285           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1286           Expression          =>
1287             Make_String_Literal (Loc,
1288               Strval => Fully_Qualified_Name_String (Id))));
1289
1290       Set_Is_Statically_Allocated (Exname);
1291
1292       --  Create the aggregate list for type Standard.Exception_Type:
1293       --  Handled_By_Other component: False
1294
1295       Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1296
1297       --  Lang component: 'A'
1298
1299       Append_To (L,
1300         Make_Character_Literal (Loc,
1301           Chars              =>  Name_uA,
1302           Char_Literal_Value =>  UI_From_Int (Character'Pos ('A'))));
1303
1304       --  Name_Length component: Nam'Length
1305
1306       Append_To (L,
1307         Make_Attribute_Reference (Loc,
1308           Prefix         => New_Occurrence_Of (Exname, Loc),
1309           Attribute_Name => Name_Length));
1310
1311       --  Full_Name component: Standard.A_Char!(Nam'Address)
1312
1313       Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1314         Make_Attribute_Reference (Loc,
1315           Prefix         => New_Occurrence_Of (Exname, Loc),
1316           Attribute_Name => Name_Address)));
1317
1318       --  HTable_Ptr component: null
1319
1320       Append_To (L, Make_Null (Loc));
1321
1322       --  Import_Code component: 0
1323
1324       Append_To (L, Make_Integer_Literal (Loc, 0));
1325
1326       --  Raise_Hook component: null
1327
1328       Append_To (L, Make_Null (Loc));
1329
1330       Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1331       Analyze_And_Resolve (Expression (N), Etype (Id));
1332
1333       Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
1334
1335       --  Register_Exception (except'Unchecked_Access);
1336
1337       if not No_Exception_Handlers_Set
1338         and then not Restriction_Active (No_Exception_Registration)
1339       then
1340          L := New_List (
1341                 Make_Procedure_Call_Statement (Loc,
1342                   Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1343                   Parameter_Associations => New_List (
1344                     Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1345                       Make_Attribute_Reference (Loc,
1346                         Prefix         => New_Occurrence_Of (Id, Loc),
1347                         Attribute_Name => Name_Unrestricted_Access)))));
1348
1349          Set_Register_Exception_Call (Id, First (L));
1350
1351          if not Is_Library_Level_Entity (Id) then
1352             Flag_Id :=  Make_Defining_Identifier (Loc,
1353                           New_External_Name (Chars (Id), 'F'));
1354
1355             Insert_Action (N,
1356               Make_Object_Declaration (Loc,
1357                 Defining_Identifier => Flag_Id,
1358                 Object_Definition   =>
1359                   New_Occurrence_Of (Standard_Boolean, Loc),
1360                 Expression          =>
1361                   New_Occurrence_Of (Standard_True, Loc)));
1362
1363             Set_Is_Statically_Allocated (Flag_Id);
1364
1365             Append_To (L,
1366               Make_Assignment_Statement (Loc,
1367                 Name       => New_Occurrence_Of (Flag_Id, Loc),
1368                 Expression => New_Occurrence_Of (Standard_False, Loc)));
1369
1370             Insert_After_And_Analyze (N,
1371               Make_Implicit_If_Statement (N,
1372                 Condition       => New_Occurrence_Of (Flag_Id, Loc),
1373                 Then_Statements => L));
1374
1375          else
1376             Insert_List_After_And_Analyze (N, L);
1377          end if;
1378       end if;
1379    end Expand_N_Exception_Declaration;
1380
1381    ---------------------------------------------
1382    -- Expand_N_Handled_Sequence_Of_Statements --
1383    ---------------------------------------------
1384
1385    procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1386    begin
1387       --  Expand exception handlers
1388
1389       if Present (Exception_Handlers (N))
1390         and then not Restriction_Active (No_Exception_Handlers)
1391       then
1392          Expand_Exception_Handlers (N);
1393       end if;
1394
1395       --  If local exceptions are being expanded, the previous call will
1396       --  have rewritten the construct as a block and reanalyzed it. No
1397       --  further expansion is needed.
1398
1399       if Analyzed (N) then
1400          return;
1401       end if;
1402
1403       --  Add clean up actions if required
1404
1405       if Nkind (Parent (N)) /= N_Package_Body
1406         and then Nkind (Parent (N)) /= N_Accept_Statement
1407         and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1408         and then not Delay_Cleanups (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_Program_Error --
1436    ----------------------------------
1437
1438    procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1439    begin
1440       --  We adjust the condition to deal with the C/Fortran boolean case. This
1441       --  may well not be necessary, as all such conditions are generated by
1442       --  the expander and probably are all standard boolean, but who knows
1443       --  what strange optimization in future may require this adjustment!
1444
1445       Adjust_Condition (Condition (N));
1446
1447       --  Now deal with possible local raise handling
1448
1449       Possible_Local_Raise (N, Standard_Program_Error);
1450    end Expand_N_Raise_Program_Error;
1451
1452    ------------------------------
1453    -- Expand_N_Raise_Statement --
1454    ------------------------------
1455
1456    procedure Expand_N_Raise_Statement (N : Node_Id) is
1457       Loc   : constant Source_Ptr := Sloc (N);
1458       Ehand : Node_Id;
1459       E     : Entity_Id;
1460       Str   : String_Id;
1461       H     : Node_Id;
1462       Src   : Boolean;
1463
1464    begin
1465       --  Processing for locally handled exception (exclude reraise case)
1466
1467       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1468          if Debug_Flag_Dot_G
1469            or else Restriction_Active (No_Exception_Propagation)
1470          then
1471             --  If we have a local handler, then note that this is potentially
1472             --  able to be transformed into a goto statement.
1473
1474             H := Find_Local_Handler (Entity (Name (N)), N);
1475
1476             if Present (H) then
1477                if Local_Raise_Statements (H) = No_Elist then
1478                   Set_Local_Raise_Statements (H, New_Elmt_List);
1479                end if;
1480
1481                --  Append the new entry if it is not there already. Sometimes
1482                --  we have situations where due to reexpansion, the same node
1483                --  is analyzed twice and would otherwise be added twice.
1484
1485                Append_Unique_Elmt (N, Local_Raise_Statements (H));
1486                Set_Has_Local_Raise (H);
1487
1488             --  If no local handler, then generate no propagation warning
1489
1490             else
1491                Warn_If_No_Propagation (N);
1492             end if;
1493
1494          end if;
1495       end if;
1496
1497       --  If a string expression is present, then the raise statement is
1498       --  converted to a call:
1499       --     Raise_Exception (exception-name'Identity, string);
1500       --  and there is nothing else to do.
1501
1502       if Present (Expression (N)) then
1503
1504          --  Avoid passing exception-name'identity in runtimes in which this
1505          --  argument is not used. This avoids generating undefined references
1506          --  to these exceptions when compiling with no optimization
1507
1508          if Configurable_Run_Time_On_Target
1509            and then (Restriction_Active (No_Exception_Handlers)
1510                        or else
1511                      Restriction_Active (No_Exception_Propagation))
1512          then
1513             Rewrite (N,
1514               Make_Procedure_Call_Statement (Loc,
1515                 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1516                 Parameter_Associations => New_List (
1517                   New_Occurrence_Of (RTE (RE_Null_Id), Loc),
1518                   Expression (N))));
1519          else
1520             Rewrite (N,
1521               Make_Procedure_Call_Statement (Loc,
1522                 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1523                 Parameter_Associations => New_List (
1524                   Make_Attribute_Reference (Loc,
1525                     Prefix         => Name (N),
1526                     Attribute_Name => Name_Identity),
1527                   Expression (N))));
1528          end if;
1529
1530          Analyze (N);
1531          return;
1532       end if;
1533
1534       --  Remaining processing is for the case where no string expression is
1535       --  present.
1536
1537       --  Don't expand a raise statement that does not come from source if we
1538       --  have already had configurable run-time violations, since most likely
1539       --  it will be junk cascaded nonsense.
1540
1541       if Configurable_Run_Time_Violations > 0
1542         and then not Comes_From_Source (N)
1543       then
1544          return;
1545       end if;
1546
1547       --  Convert explicit raise of Program_Error, Constraint_Error, and
1548       --  Storage_Error into the corresponding raise (in High_Integrity_Mode
1549       --  all other raises will get normal expansion and be disallowed,
1550       --  but this is also faster in all modes). Propagate Comes_From_Source
1551       --  flag to the new node.
1552
1553       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1554          Src := Comes_From_Source (N);
1555
1556          if Entity (Name (N)) = Standard_Constraint_Error then
1557             Rewrite (N,
1558               Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
1559             Set_Comes_From_Source (N, Src);
1560             Analyze (N);
1561             return;
1562
1563          elsif Entity (Name (N)) = Standard_Program_Error then
1564             Rewrite (N,
1565               Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1566             Set_Comes_From_Source (N, Src);
1567             Analyze (N);
1568             return;
1569
1570          elsif Entity (Name (N)) = Standard_Storage_Error then
1571             Rewrite (N,
1572               Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
1573             Set_Comes_From_Source (N, Src);
1574             Analyze (N);
1575             return;
1576          end if;
1577       end if;
1578
1579       --  Case of name present, in this case we expand raise name to
1580
1581       --    Raise_Exception (name'Identity, location_string);
1582
1583       --  where location_string identifies the file/line of the raise
1584
1585       if Present (Name (N)) then
1586          declare
1587             Id : Entity_Id := Entity (Name (N));
1588
1589          begin
1590             Name_Len := 0;
1591             Build_Location_String (Loc);
1592
1593             --  If the exception is a renaming, use the exception that it
1594             --  renames (which might be a predefined exception, e.g.).
1595
1596             if Present (Renamed_Object (Id)) then
1597                Id := Renamed_Object (Id);
1598             end if;
1599
1600             --  Build a C-compatible string in case of no exception handlers,
1601             --  since this is what the last chance handler is expecting.
1602
1603             if No_Exception_Handlers_Set then
1604
1605                --  Generate an empty message if configuration pragma
1606                --  Suppress_Exception_Locations is set for this unit.
1607
1608                if Opt.Exception_Locations_Suppressed then
1609                   Name_Len := 1;
1610                else
1611                   Name_Len := Name_Len + 1;
1612                end if;
1613
1614                Name_Buffer (Name_Len) := ASCII.NUL;
1615             end if;
1616
1617             if Opt.Exception_Locations_Suppressed then
1618                Name_Len := 0;
1619             end if;
1620
1621             Str := String_From_Name_Buffer;
1622
1623             --  For VMS exceptions, convert the raise into a call to
1624             --  lib$stop so it will be handled by __gnat_error_handler.
1625
1626             if Is_VMS_Exception (Id) then
1627                declare
1628                   Excep_Image : String_Id;
1629                   Cond        : Node_Id;
1630
1631                begin
1632                   if Present (Interface_Name (Id)) then
1633                      Excep_Image := Strval (Interface_Name (Id));
1634                   else
1635                      Get_Name_String (Chars (Id));
1636                      Set_All_Upper_Case;
1637                      Excep_Image := String_From_Name_Buffer;
1638                   end if;
1639
1640                   if Exception_Code (Id) /= No_Uint then
1641                      Cond :=
1642                        Make_Integer_Literal (Loc, Exception_Code (Id));
1643                   else
1644                      Cond :=
1645                        Unchecked_Convert_To (Standard_Integer,
1646                          Make_Function_Call (Loc,
1647                            Name => New_Occurrence_Of
1648                              (RTE (RE_Import_Value), Loc),
1649                            Parameter_Associations => New_List
1650                              (Make_String_Literal (Loc,
1651                                Strval => Excep_Image))));
1652                   end if;
1653
1654                   Rewrite (N,
1655                     Make_Procedure_Call_Statement (Loc,
1656                       Name =>
1657                         New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1658                       Parameter_Associations => New_List (Cond)));
1659                         Analyze_And_Resolve (Cond, Standard_Integer);
1660                end;
1661
1662             --  Not VMS exception case, convert raise to call to the
1663             --  Raise_Exception routine.
1664
1665             else
1666                Rewrite (N,
1667                  Make_Procedure_Call_Statement (Loc,
1668                     Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1669                     Parameter_Associations => New_List (
1670                       Make_Attribute_Reference (Loc,
1671                         Prefix => Name (N),
1672                         Attribute_Name => Name_Identity),
1673                       Make_String_Literal (Loc,
1674                         Strval => Str))));
1675             end if;
1676          end;
1677
1678       --  Case of no name present (reraise). We rewrite the raise to:
1679
1680       --    Reraise_Occurrence_Always (EO);
1681
1682       --  where EO is the current exception occurrence. If the current handler
1683       --  does not have a choice parameter specification, then we provide one.
1684
1685       else
1686          --  Bypass expansion to a run-time call when back-end exception
1687          --  handling is active, unless the target is a VM, CodePeer or
1688          --  GNATprove. In CodePeer, raising an exception is treated as an
1689          --  error, while in GNATprove all code with exceptions falls outside
1690          --  the subset of code which can be formally analyzed.
1691
1692          if VM_Target = No_VM
1693            and then not CodePeer_Mode
1694            and then Exception_Mechanism = Back_End_Exceptions
1695          then
1696             return;
1697          end if;
1698
1699          --  Find innermost enclosing exception handler (there must be one,
1700          --  since the semantics has already verified that this raise statement
1701          --  is valid, and a raise with no arguments is only permitted in the
1702          --  context of an exception handler.
1703
1704          Ehand := Parent (N);
1705          while Nkind (Ehand) /= N_Exception_Handler loop
1706             Ehand := Parent (Ehand);
1707          end loop;
1708
1709          --  Make exception choice parameter if none present. Note that we do
1710          --  not need to put the entity on the entity chain, since no one will
1711          --  be referencing this entity by normal visibility methods.
1712
1713          if No (Choice_Parameter (Ehand)) then
1714             E := Make_Temporary (Loc, 'E');
1715             Set_Choice_Parameter (Ehand, E);
1716             Set_Ekind (E, E_Variable);
1717             Set_Etype (E, RTE (RE_Exception_Occurrence));
1718             Set_Scope (E, Current_Scope);
1719          end if;
1720
1721          --  Now rewrite the raise as a call to Reraise. A special case arises
1722          --  if this raise statement occurs in the context of a handler for
1723          --  all others (i.e. an at end handler). in this case we avoid
1724          --  the call to defer abort, cleanup routines are expected to be
1725          --  called in this case with aborts deferred.
1726
1727          declare
1728             Ech : constant Node_Id := First (Exception_Choices (Ehand));
1729             Ent : Entity_Id;
1730
1731          begin
1732             if Nkind (Ech) = N_Others_Choice
1733               and then All_Others (Ech)
1734             then
1735                Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1736             else
1737                Ent := RTE (RE_Reraise_Occurrence_Always);
1738             end if;
1739
1740             Rewrite (N,
1741               Make_Procedure_Call_Statement (Loc,
1742                 Name => New_Occurrence_Of (Ent, Loc),
1743                 Parameter_Associations => New_List (
1744                   New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1745          end;
1746       end if;
1747
1748       Analyze (N);
1749    end Expand_N_Raise_Statement;
1750
1751    ----------------------------------
1752    -- Expand_N_Raise_Storage_Error --
1753    ----------------------------------
1754
1755    procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1756    begin
1757       --  We adjust the condition to deal with the C/Fortran boolean case. This
1758       --  may well not be necessary, as all such conditions are generated by
1759       --  the expander and probably are all standard boolean, but who knows
1760       --  what strange optimization in future may require this adjustment!
1761
1762       Adjust_Condition (Condition (N));
1763
1764       --  Now deal with possible local raise handling
1765
1766       Possible_Local_Raise (N, Standard_Storage_Error);
1767    end Expand_N_Raise_Storage_Error;
1768
1769    --------------------------
1770    -- Possible_Local_Raise --
1771    --------------------------
1772
1773    procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1774    begin
1775       --  Nothing to do if local raise optimization not active
1776
1777       if not Debug_Flag_Dot_G
1778         and then not Restriction_Active (No_Exception_Propagation)
1779       then
1780          return;
1781       end if;
1782
1783       --  Nothing to do if original node was an explicit raise, because in
1784       --  that case, we already generated the required warning for the raise.
1785
1786       if Nkind (Original_Node (N)) = N_Raise_Statement then
1787          return;
1788       end if;
1789
1790       --  Otherwise see if we have a local handler for the exception
1791
1792       declare
1793          H : constant Node_Id := Find_Local_Handler (E, N);
1794
1795       begin
1796          --  If so, mark that it has a local raise
1797
1798          if Present (H) then
1799             Set_Has_Local_Raise (H, True);
1800
1801          --  Otherwise, if the No_Exception_Propagation restriction is active
1802          --  and the warning is enabled, generate the appropriate warnings.
1803
1804          elsif Warn_On_Non_Local_Exception
1805            and then Restriction_Active (No_Exception_Propagation)
1806          then
1807             Warn_No_Exception_Propagation_Active (N);
1808
1809             if Configurable_Run_Time_Mode then
1810                Error_Msg_NE
1811                  ("\?& may call Last_Chance_Handler", N, E);
1812             else
1813                Error_Msg_NE
1814                  ("\?& may result in unhandled exception", N, E);
1815             end if;
1816          end if;
1817       end;
1818    end Possible_Local_Raise;
1819
1820    ------------------------------
1821    -- Expand_N_Subprogram_Info --
1822    ------------------------------
1823
1824    procedure Expand_N_Subprogram_Info (N : Node_Id) is
1825       Loc : constant Source_Ptr := Sloc (N);
1826
1827    begin
1828       --  For now, we replace an Expand_N_Subprogram_Info node with an
1829       --  attribute reference that gives the address of the procedure.
1830       --  This is because gigi does not yet recognize this node, and
1831       --  for the initial targets, this is the right value anyway.
1832
1833       Rewrite (N,
1834         Make_Attribute_Reference (Loc,
1835           Prefix => Identifier (N),
1836           Attribute_Name => Name_Code_Address));
1837
1838       Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1839    end Expand_N_Subprogram_Info;
1840
1841    ------------------------
1842    -- Find_Local_Handler --
1843    ------------------------
1844
1845    function Find_Local_Handler
1846      (Ename : Entity_Id;
1847       Nod   : Node_Id) return Node_Id
1848    is
1849       N : Node_Id;
1850       P : Node_Id;
1851       H : Node_Id;
1852       C : Node_Id;
1853
1854       SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1855       --  This is used to test for wrapped actions below
1856
1857       ERaise  : Entity_Id;
1858       EHandle : Entity_Id;
1859       --  The entity Id's for the exception we are raising and handling, using
1860       --  the renamed exception if a Renamed_Entity is present.
1861
1862    begin
1863       --  Never any local handler if all handlers removed
1864
1865       if Debug_Flag_Dot_X then
1866          return Empty;
1867       end if;
1868
1869       --  Get the exception we are raising, allowing for renaming
1870
1871       ERaise := Get_Renamed_Entity (Ename);
1872
1873       --  We need to check if the node we are looking at is contained in
1874       --
1875
1876       --  Loop to search up the tree
1877
1878       N := Nod;
1879       loop
1880          P := Parent (N);
1881
1882          --  If we get to the top of the tree, or to a subprogram, task, entry,
1883          --  protected body, or accept statement without having found a
1884          --  matching handler, then there is no local handler.
1885
1886          if No (P)
1887            or else Nkind (P) = N_Subprogram_Body
1888            or else Nkind (P) = N_Task_Body
1889            or else Nkind (P) = N_Protected_Body
1890            or else Nkind (P) = N_Entry_Body
1891            or else Nkind (P) = N_Accept_Statement
1892          then
1893             return Empty;
1894
1895             --  Test for handled sequence of statements with at least one
1896             --  exception handler which might be the one we are looking for.
1897
1898          elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1899            and then Present (Exception_Handlers (P))
1900          then
1901             --  Before we proceed we need to check if the node N is covered
1902             --  by the statement part of P rather than one of its exception
1903             --  handlers (an exception handler obviously does not cover its
1904             --  own statements).
1905
1906             --  This test is more delicate than might be thought. It is not
1907             --  just a matter of checking the Statements (P), because the node
1908             --  might be waiting to be wrapped in a transient scope, in which
1909             --  case it will end up in the block statements, even though it
1910             --  is not there now.
1911
1912             if Is_List_Member (N)
1913               and then (List_Containing (N) = Statements (P)
1914                           or else
1915                         List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
1916                           or else
1917                         List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
1918             then
1919                --  Loop through exception handlers
1920
1921                H := First (Exception_Handlers (P));
1922                while Present (H) loop
1923
1924                   --  Guard against other constructs appearing in the list of
1925                   --  exception handlers.
1926
1927                   if Nkind (H) = N_Exception_Handler then
1928
1929                      --  Loop through choices in one handler
1930
1931                      C := First (Exception_Choices (H));
1932                      while Present (C) loop
1933
1934                         --  Deal with others case
1935
1936                         if Nkind (C) = N_Others_Choice then
1937
1938                            --  Matching others handler, but we need to ensure
1939                            --  there is no choice parameter. If there is, then
1940                            --  we don't have a local handler after all (since
1941                            --  we do not allow choice parameters for local
1942                            --  handlers).
1943
1944                            if No (Choice_Parameter (H)) then
1945                               return H;
1946                            else
1947                               return Empty;
1948                            end if;
1949
1950                         --  If not others must be entity name
1951
1952                         elsif Nkind (C) /= N_Others_Choice then
1953                            pragma Assert (Is_Entity_Name (C));
1954                            pragma Assert (Present (Entity (C)));
1955
1956                            --  Get exception being handled, dealing with
1957                            --  renaming.
1958
1959                            EHandle := Get_Renamed_Entity (Entity (C));
1960
1961                            --  If match, then check choice parameter
1962
1963                            if ERaise = EHandle then
1964                               if No (Choice_Parameter (H)) then
1965                                  return H;
1966                               else
1967                                  return Empty;
1968                               end if;
1969                            end if;
1970                         end if;
1971
1972                         Next (C);
1973                      end loop;
1974                   end if;
1975
1976                   Next (H);
1977                end loop;
1978             end if;
1979          end if;
1980
1981          N := P;
1982       end loop;
1983    end Find_Local_Handler;
1984
1985    ---------------------------------
1986    -- Get_Local_Raise_Call_Entity --
1987    ---------------------------------
1988
1989    --  Note: this is primary provided for use by the back end in generating
1990    --  calls to Local_Raise. But it would be too late in the back end to call
1991    --  RTE if this actually caused a load/analyze of the unit. So what we do
1992    --  is to ensure there is a dummy call to this function during front end
1993    --  processing so that the unit gets loaded then, and not later.
1994
1995    Local_Raise_Call_Entity     : Entity_Id;
1996    Local_Raise_Call_Entity_Set : Boolean := False;
1997
1998    function Get_Local_Raise_Call_Entity return Entity_Id is
1999    begin
2000       if not Local_Raise_Call_Entity_Set then
2001          Local_Raise_Call_Entity_Set := True;
2002
2003          if RTE_Available (RE_Local_Raise) then
2004             Local_Raise_Call_Entity := RTE (RE_Local_Raise);
2005          else
2006             Local_Raise_Call_Entity := Empty;
2007          end if;
2008       end if;
2009
2010       return Local_Raise_Call_Entity;
2011    end Get_Local_Raise_Call_Entity;
2012
2013    -----------------------------
2014    -- Get_RT_Exception_Entity --
2015    -----------------------------
2016
2017    function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
2018    begin
2019       case R is
2020          when RT_CE_Exceptions => return Standard_Constraint_Error;
2021          when RT_PE_Exceptions => return Standard_Program_Error;
2022          when RT_SE_Exceptions => return Standard_Storage_Error;
2023       end case;
2024    end Get_RT_Exception_Entity;
2025
2026    ----------------------
2027    -- Is_Non_Ada_Error --
2028    ----------------------
2029
2030    function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
2031    begin
2032       if not OpenVMS_On_Target then
2033          return False;
2034       end if;
2035
2036       Get_Name_String (Chars (E));
2037
2038       --  Note: it is a little irregular for the body of exp_ch11 to know
2039       --  the details of the encoding scheme for names, but on the other
2040       --  hand, gigi knows them, and this is for gigi's benefit anyway!
2041
2042       if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
2043          return False;
2044       end if;
2045
2046       return True;
2047    end Is_Non_Ada_Error;
2048
2049    ----------------------------
2050    -- Warn_If_No_Propagation --
2051    ----------------------------
2052
2053    procedure Warn_If_No_Propagation (N : Node_Id) is
2054    begin
2055       if Restriction_Check_Required (No_Exception_Propagation)
2056         and then Warn_On_Non_Local_Exception
2057       then
2058          Warn_No_Exception_Propagation_Active (N);
2059
2060          if Configurable_Run_Time_Mode then
2061             Error_Msg_N
2062               ("\?Last_Chance_Handler will be called on exception", N);
2063          else
2064             Error_Msg_N
2065               ("\?execution may raise unhandled exception", N);
2066          end if;
2067       end if;
2068    end Warn_If_No_Propagation;
2069
2070    ------------------------------------------
2071    -- Warn_No_Exception_Propagation_Active --
2072    ------------------------------------------
2073
2074    procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
2075    begin
2076       Error_Msg_N
2077         ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
2078    end Warn_No_Exception_Propagation_Active;
2079
2080 end Exp_Ch11;