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-2005 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Util; use Exp_Util;
  34 with Hostparm; use Hostparm;
  35 with Inline;   use Inline;
  36 with Lib;      use Lib;
  37 with Namet;    use Namet;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Rtsfind;  use Rtsfind;
  42 with Restrict; use Restrict;
  43 with Rident;   use Rident;
  44 with Sem;      use Sem;
  45 with Sem_Ch5;  use Sem_Ch5;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Res;  use Sem_Res;
  48 with Sem_Util; use Sem_Util;
  49 with Sinfo;    use Sinfo;
  50 with Sinput;   use Sinput;
  51 with Snames;   use Snames;
  52 with Stand;    use Stand;
  53 with Stringt;  use Stringt;
  54 with Targparm; use Targparm;
  55 with Tbuild;   use Tbuild;
  56 with Uintp;    use Uintp;
  57 with Uname;    use Uname;
  58
  59 package body Exp_Ch11 is
  60
  61    SD_List : List_Id;
  62    --  This list gathers the values SDn'Unrestricted_Access used to
  63    --  construct the unit exception table. It is set to Empty_List if
  64    --  there are no subprogram descriptors.
  65
  66    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    procedure Expand_Exception_Handler_Tables (HSS : Node_Id);
  71    --  Subsidiary procedure called by Expand_Exception_Handlers if zero
  72    --  cost exception handling is installed for this target. Replaces the
  73    --  exception handler structure with appropriate labeled code and tables
  74    --  that allow the zero cost exception handling circuits to find the
  75    --  correct handler (see unit Ada.Exceptions for details).
  76
  77    procedure Generate_Subprogram_Descriptor
  78      (N     : Node_Id;
  79       Loc   : Source_Ptr;
  80       Spec  : Entity_Id;
  81       Slist : List_Id);
  82    --  Procedure called to generate a subprogram descriptor. N is the
  83    --  subprogram body node or, in the case of an imported subprogram, is
  84    --  Empty, and Spec is the entity of the sunprogram. For details of the
  85    --  required structure, see package System.Exceptions. The generated
  86    --  subprogram descriptor is appended to Slist. Loc provides the
  87    --  source location to be used for the generated descriptor.
  88
  89    ---------------------------
  90    -- Expand_At_End_Handler --
  91    ---------------------------
  92
  93    --  For a handled statement sequence that has a cleanup (At_End_Proc
  94    --  field set), an exception handler of the following form is required:
  95
  96    --     exception
  97    --       when all others =>
  98    --          cleanup call
  99    --          raise;
 100
 101    --  Note: this exception handler is treated rather specially by
 102    --  subsequent expansion in two respects:
 103
 104    --    The normal call to Undefer_Abort is omitted
 105    --    The raise call does not do Defer_Abort
 106
 107    --  This is because the current tasking code seems to assume that
 108    --  the call to the cleanup routine that is made from an exception
 109    --  handler for the abort signal is called with aborts deferred.
 110
 111    --  This expansion is only done if we have front end exception handling.
 112    --  If we have back end exception handling, then the AT END handler is
 113    --  left alone, and cleanups (including the exceptional case) are handled
 114    --  by the back end.
 115
 116    --  In the front end case, the exception handler described above handles
 117    --  the exceptional case. The AT END handler is left in the generated tree
 118    --  and the code generator (e.g. gigi) must still handle proper generation
 119    --  of cleanup calls for the non-exceptional case.
 120
 121    procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
 122       Clean   : constant Entity_Id  := Entity (At_End_Proc (HSS));
 123       Loc     : constant Source_Ptr := Sloc (Clean);
 124       Ohandle : Node_Id;
 125       Stmnts  : List_Id;
 126
 127    begin
 128       pragma Assert (Present (Clean));
 129       pragma Assert (No (Exception_Handlers (HSS)));
 130
 131       --  Don't expand if back end exception handling active
 132
 133       if Exception_Mechanism = Back_End_ZCX_Exceptions then
 134          return;
 135       end if;
 136
 137       --  Don't expand an At End handler if we have already had configurable
 138       --  run-time violations, since likely this will just be a matter of
 139       --  generating useless cascaded messages
 140
 141       if Configurable_Run_Time_Violations > 0 then
 142          return;
 143       end if;
 144
 145       if Restriction_Active (No_Exception_Handlers) then
 146          return;
 147       end if;
 148
 149       if Present (Block) then
 150          New_Scope (Block);
 151       end if;
 152
 153       Ohandle :=
 154         Make_Others_Choice (Loc);
 155       Set_All_Others (Ohandle);
 156
 157       Stmnts := New_List (
 158         Make_Procedure_Call_Statement (Loc,
 159           Name => New_Occurrence_Of (Clean, Loc)),
 160         Make_Raise_Statement (Loc));
 161
 162       Set_Exception_Handlers (HSS, New_List (
 163         Make_Exception_Handler (Loc,
 164           Exception_Choices => New_List (Ohandle),
 165           Statements        => Stmnts)));
 166
 167       Analyze_List (Stmnts, Suppress => All_Checks);
 168       Expand_Exception_Handlers (HSS);
 169
 170       if Present (Block) then
 171          Pop_Scope;
 172       end if;
 173    end Expand_At_End_Handler;
 174
 175    -------------------------------------
 176    -- Expand_Exception_Handler_Tables --
 177    -------------------------------------
 178
 179    --  See Ada.Exceptions specification for full details of the data
 180    --  structures that we need to construct here. As an example of the
 181    --  transformation that is required, given the structure:
 182
 183    --     declare
 184    --        {declarations}
 185    --        ..
 186    --     begin
 187    --        {statements-1}
 188    --        ...
 189    --     exception
 190    --        when a | b =>
 191    --           {statements-2}
 192    --           ...
 193    --        when others =>
 194    --           {statements-3}
 195    --           ...
 196    --     end;
 197
 198    --  We transform this into:
 199
 200    --     declare
 201    --        {declarations}
 202    --        ...
 203    --        L1 : label;
 204    --        L2 : label;
 205    --        L3 : label;
 206    --        L4 : Label;
 207    --        L5 : label;
 208
 209    --     begin
 210    --        <<L1>>
 211    --           {statements-1}
 212    --        <<L2>>
 213
 214    --     exception
 215
 216    --        when a | b =>
 217    --           <<L3>>
 218    --           {statements-2}
 219
 220    --           HR2 : constant Handler_Record := (
 221    --                   Lo      => L1'Address,
 222    --                   Hi      => L2'Address,
 223    --                   Id      => a'Identity,
 224    --                   Handler => L5'Address);
 225
 226    --           HR3 : constant Handler_Record := (
 227    --                   Lo      => L1'Address,
 228    --                   Hi      => L2'Address,
 229    --                   Id      => b'Identity,
 230    --                   Handler => L4'Address);
 231
 232    --        when others =>
 233    --           <<L4>>
 234    --           {statements-3}
 235
 236    --           HR1 : constant Handler_Record := (
 237    --                   Lo      => L1'Address,
 238    --                   Hi      => L2'Address,
 239    --                   Id      => Others_Id,
 240    --                   Handler => L4'Address);
 241    --     end;
 242
 243    --  The exception handlers in the transformed version are marked with the
 244    --  Zero_Cost_Handling flag set, and all gigi does in this case is simply
 245    --  to put the handler code somewhere. It can optionally be put inline
 246    --  between the goto L3 and the label <<L3>> (which is why we generate
 247    --  that goto in the first place).
 248
 249    procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is
 250       Loc     : constant Source_Ptr := Sloc (HSS);
 251       Handlrs : constant List_Id    := Exception_Handlers (HSS);
 252       Stms    : constant List_Id    := Statements (HSS);
 253       Handler : Node_Id;
 254
 255       Hlist : List_Id;
 256       --  This is the list to which handlers are to be appended. It is
 257       --  either the list for the enclosing subprogram, or the enclosing
 258       --  selective accept statement (which will turn into a subprogram
 259       --  during expansion later on).
 260
 261       L1 : constant Entity_Id :=
 262              Make_Defining_Identifier (Loc,
 263                Chars => New_Internal_Name ('L'));
 264
 265       L2 : constant Entity_Id :=
 266              Make_Defining_Identifier (Loc,
 267                Chars => New_Internal_Name ('L'));
 268
 269       Lnn    : Entity_Id;
 270       Choice : Node_Id;
 271       E_Id   : Node_Id;
 272       HR_Ent : Node_Id;
 273       HL_Ref : Node_Id;
 274       Item   : Node_Id;
 275
 276       Subp_Entity : Entity_Id;
 277       --  This is the entity for the subprogram (or library level package)
 278       --  to which the handler record is to be attached for later reference
 279       --  in a subprogram descriptor for this entity.
 280
 281       procedure Append_To_Stms (N : Node_Id);
 282       --  Append given statement to the end of the statements of the
 283       --  handled sequence of statements and analyze it in place.
 284
 285       function Inside_Selective_Accept return Boolean;
 286       --  This function is called if we are inside the scope of an entry
 287       --  or task. It checks if the handler is appearing in the context
 288       --  of a selective accept statement. If so, Hlist is set to
 289       --  temporarily park the handlers in the N_Accept_Alternative.
 290       --  node. They will subsequently be moved to the procedure entity
 291       --  for the procedure built for this alternative. The statements that
 292       --  follow the Accept within the alternative are not inside the Accept
 293       --  for purposes of this test, and handlers that may appear within
 294       --  them belong in the enclosing task procedure.
 295
 296       procedure Set_Hlist;
 297       --  Sets the handler list corresponding to Subp_Entity
 298
 299       --------------------
 300       -- Append_To_Stms --
 301       --------------------
 302
 303       procedure Append_To_Stms (N : Node_Id) is
 304       begin
 305          Insert_After_And_Analyze (Last (Stms), N);
 306          Set_Exception_Junk (N);
 307       end Append_To_Stms;
 308
 309       -----------------------------
 310       -- Inside_Selective_Accept --
 311       -----------------------------
 312
 313       function Inside_Selective_Accept return Boolean is
 314          Parnt : Node_Id;
 315          Curr  : Node_Id := HSS;
 316
 317       begin
 318          Parnt := Parent (HSS);
 319          while Nkind (Parnt) /= N_Compilation_Unit loop
 320             if Nkind (Parnt) = N_Accept_Alternative
 321               and then Curr = Accept_Statement (Parnt)
 322             then
 323                if Present (Accept_Handler_Records (Parnt)) then
 324                   Hlist := Accept_Handler_Records (Parnt);
 325                else
 326                   Hlist := New_List;
 327                   Set_Accept_Handler_Records (Parnt, Hlist);
 328                end if;
 329
 330                return True;
 331             else
 332                Curr  := Parnt;
 333                Parnt := Parent (Parnt);
 334             end if;
 335          end loop;
 336
 337          return False;
 338       end Inside_Selective_Accept;
 339
 340       ---------------
 341       -- Set_Hlist --
 342       ---------------
 343
 344       procedure Set_Hlist is
 345       begin
 346          --  Never try to inline a subprogram with exception handlers
 347
 348          Set_Is_Inlined (Subp_Entity, False);
 349
 350          if Present (Subp_Entity)
 351            and then Present (Handler_Records (Subp_Entity))
 352          then
 353             Hlist := Handler_Records (Subp_Entity);
 354          else
 355             Hlist := New_List;
 356             Set_Handler_Records (Subp_Entity, Hlist);
 357          end if;
 358       end Set_Hlist;
 359
 360    --  Start of processing for Expand_Exception_Handler_Tables
 361
 362    begin
 363       --  Nothing to do if this handler has already been processed
 364
 365       if Zero_Cost_Handling (HSS) then
 366          return;
 367       end if;
 368
 369       Set_Zero_Cost_Handling (HSS);
 370
 371       --  Find the parent subprogram or package scope containing this
 372       --  exception frame. This should always find a real package or
 373       --  subprogram. If it does not it will stop at Standard, but
 374       --  this cannot legitimately occur.
 375
 376       --  We only stop at library level packages, for inner packages
 377       --  we always attach handlers to the containing procedure.
 378
 379       Subp_Entity := Current_Scope;
 380       Scope_Loop : loop
 381
 382          --  Never need tables expanded inside a generic template
 383
 384          if Is_Generic_Unit (Subp_Entity) then
 385             return;
 386
 387          --  Stop if we reached containing subprogram. Go to protected
 388          --  subprogram if there is one defined.
 389
 390          elsif Ekind (Subp_Entity) = E_Function
 391            or else Ekind (Subp_Entity) = E_Procedure
 392          then
 393             if Present (Protected_Body_Subprogram (Subp_Entity)) then
 394                Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
 395             end if;
 396
 397             Set_Hlist;
 398             exit Scope_Loop;
 399
 400          --  Case of within an entry
 401
 402          elsif Is_Entry (Subp_Entity) then
 403
 404             --  Protected entry, use corresponding body subprogram
 405
 406             if Present (Protected_Body_Subprogram (Subp_Entity)) then
 407                Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
 408                Set_Hlist;
 409                exit Scope_Loop;
 410
 411             --  Check if we are within a selective accept alternative
 412
 413             elsif Inside_Selective_Accept then
 414
 415                --  As a side effect, Inside_Selective_Accept set Hlist,
 416                --  in much the same manner as Set_Hlist, except that
 417                --  the list involved was the one for the selective accept.
 418
 419                exit Scope_Loop;
 420             end if;
 421
 422          --  Case of within library level package
 423
 424          elsif Ekind (Subp_Entity) = E_Package
 425            and then Is_Compilation_Unit (Subp_Entity)
 426          then
 427             if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
 428                Subp_Entity := Body_Entity (Subp_Entity);
 429             end if;
 430
 431             Set_Hlist;
 432             exit Scope_Loop;
 433
 434          --  Task type case
 435
 436          elsif Ekind (Subp_Entity) = E_Task_Type then
 437
 438             --  Check if we are within a selective accept alternative
 439
 440             if Inside_Selective_Accept then
 441
 442                --  As a side effect, Inside_Selective_Accept set Hlist,
 443                --  in much the same manner as Set_Hlist, except that the
 444                --  list involved was the one for the selective accept.
 445
 446                exit Scope_Loop;
 447
 448             --  Stop if we reached task type with task body procedure,
 449             --  use the task body procedure.
 450
 451             elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
 452                Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
 453                Set_Hlist;
 454                exit Scope_Loop;
 455             end if;
 456          end if;
 457
 458          --  If we fall through, keep looking
 459
 460          Subp_Entity := Scope (Subp_Entity);
 461       end loop Scope_Loop;
 462
 463       pragma Assert (Subp_Entity /= Standard_Standard);
 464
 465       --  Analyze standard labels
 466
 467       Analyze_Label_Entity (L1);
 468       Analyze_Label_Entity (L2);
 469
 470       Insert_Before_And_Analyze (First (Stms),
 471         Make_Label (Loc,
 472           Identifier => New_Occurrence_Of (L1, Loc)));
 473       Set_Exception_Junk (First (Stms));
 474
 475       Append_To_Stms (
 476         Make_Label (Loc,
 477           Identifier => New_Occurrence_Of (L2, Loc)));
 478
 479       --  Loop through exception handlers
 480
 481       Handler := First_Non_Pragma (Handlrs);
 482       while Present (Handler) loop
 483          Set_Zero_Cost_Handling (Handler);
 484
 485          --  Add label at start of handler, and goto at the end
 486
 487          Lnn :=
 488            Make_Defining_Identifier (Loc,
 489              Chars => New_Internal_Name ('L'));
 490
 491          Analyze_Label_Entity (Lnn);
 492
 493          Item :=
 494            Make_Label (Loc,
 495              Identifier => New_Occurrence_Of (Lnn, Loc));
 496          Set_Exception_Junk (Item);
 497          Insert_Before_And_Analyze (First (Statements (Handler)), Item);
 498
 499          --  Loop through choices
 500
 501          Choice := First (Exception_Choices (Handler));
 502          while Present (Choice) loop
 503
 504             --  Others (or all others) choice
 505
 506             if Nkind (Choice) = N_Others_Choice then
 507                if All_Others (Choice) then
 508                   E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc);
 509                else
 510                   E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
 511                end if;
 512
 513             --  Special case of VMS_Exception. Not clear what we will do
 514             --  eventually here if and when we implement zero cost exceptions
 515             --  on VMS. But at least for now, don't blow up trying to take
 516             --  a garbage code address for such an exception.
 517
 518             elsif Is_VMS_Exception (Entity (Choice)) then
 519                E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
 520
 521             --  Normal case of specific exception choice
 522
 523             else
 524                E_Id :=
 525                  Make_Attribute_Reference (Loc,
 526                    Prefix => New_Occurrence_Of (Entity (Choice), Loc),
 527                    Attribute_Name => Name_Identity);
 528             end if;
 529
 530             HR_Ent :=
 531               Make_Defining_Identifier (Loc,
 532                 Chars => New_Internal_Name ('H'));
 533
 534             HL_Ref :=
 535               Make_Attribute_Reference (Loc,
 536                 Prefix => New_Occurrence_Of (HR_Ent, Loc),
 537                 Attribute_Name => Name_Unrestricted_Access);
 538
 539             --  Now we need to add the entry for the new handler record to
 540             --  the list of handler records for the current subprogram.
 541
 542             --  Normally we end up generating the handler records in exactly
 543             --  the right order. Here right order means innermost first,
 544             --  since the table will be searched sequentially. Since we
 545             --  generally expand from outside to inside, the order is just
 546             --  what we want, and we need to append the new entry to the
 547             --  end of the list.
 548
 549             --  However, there are exceptions, notably in the case where
 550             --  a generic body is inserted later on. See for example the
 551             --  case of ACVC test C37213J, which has the following form:
 552
 553             --    generic package x ... end x;
 554             --    package body x is
 555             --    begin
 556             --       ...
 557             --    exception  (1)
 558             --       ...
 559             --    end x;
 560
 561             --    ...
 562
 563             --    declare
 564             --       package q is new x;
 565             --    begin
 566             --       ...
 567             --    exception (2)
 568             --       ...
 569             --    end;
 570
 571             --  In this case, we will expand exception handler (2) first,
 572             --  since the expansion of (1) is delayed till later when the
 573             --  generic body is inserted. But (1) belongs before (2) in
 574             --  the chain.
 575
 576             --  Note that scopes are not totally ordered, because two
 577             --  scopes can be in parallel blocks, so that it does not
 578             --  matter what order these entries appear in. An ordering
 579             --  relation exists if one scope is inside another, and what
 580             --  we really want is some partial ordering.
 581
 582             --  A simple, not very efficient, but adequate algorithm to
 583             --  achieve this partial ordering is to search the list for
 584             --  the first entry containing the given scope, and put the
 585             --  new entry just before it.
 586
 587             declare
 588                New_Scop : constant Entity_Id := Current_Scope;
 589                Ent      : Node_Id;
 590
 591             begin
 592                Ent := First (Hlist);
 593                loop
 594                   --  If all searched, then we can just put the new
 595                   --  entry at the end of the list (it actually does
 596                   --  not matter where we put it in this case).
 597
 598                   if No (Ent) then
 599                      Append_To (Hlist, HL_Ref);
 600                      exit;
 601
 602                   --  If the current scope is within the scope of the
 603                   --  entry then insert the entry before to retain the
 604                   --  proper order as per above discussion.
 605
 606                   --  Note that for equal entries, we just keep going,
 607                   --  which is fine, the entry will end up at the end
 608                   --  of the list where it belongs.
 609
 610                   elsif Scope_Within
 611                           (New_Scop, Scope (Entity (Prefix (Ent))))
 612                   then
 613                      Insert_Before (Ent, HL_Ref);
 614                      exit;
 615
 616                   --  Otherwise keep looking
 617
 618                   else
 619                      Next (Ent);
 620                   end if;
 621                end loop;
 622             end;
 623
 624             Item :=
 625               Make_Object_Declaration (Loc,
 626                 Defining_Identifier => HR_Ent,
 627                 Constant_Present    => True,
 628                 Aliased_Present     => True,
 629                 Object_Definition   =>
 630                   New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
 631
 632                 Expression          =>
 633                   Make_Aggregate (Loc,
 634                     Expressions => New_List (
 635                       Make_Attribute_Reference (Loc,             -- Lo
 636                         Prefix => New_Occurrence_Of (L1, Loc),
 637                         Attribute_Name => Name_Address),
 638
 639                       Make_Attribute_Reference (Loc,             -- Hi
 640                         Prefix => New_Occurrence_Of (L2, Loc),
 641                         Attribute_Name => Name_Address),
 642
 643                       E_Id,                                      -- Id
 644
 645                       Make_Attribute_Reference (Loc,
 646                         Prefix => New_Occurrence_Of (Lnn, Loc),  -- Handler
 647                         Attribute_Name => Name_Address))));
 648
 649             Set_Handler_List_Entry (Item, HL_Ref);
 650             Set_Exception_Junk (Item);
 651             Insert_After_And_Analyze (Last (Statements (Handler)), Item);
 652             Set_Is_Statically_Allocated (HR_Ent);
 653
 654             --  If this is a late insertion (from body instance) it is being
 655             --  inserted in the component list of an already analyzed aggre-
 656             --  gate, and must be analyzed explicitly.
 657
 658             Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
 659
 660             Next (Choice);
 661          end loop;
 662
 663          Next_Non_Pragma (Handler);
 664       end loop;
 665    end Expand_Exception_Handler_Tables;
 666
 667    -------------------------------
 668    -- Expand_Exception_Handlers --
 669    -------------------------------
 670
 671    procedure Expand_Exception_Handlers (HSS : Node_Id) is
 672       Handlrs       : constant List_Id := Exception_Handlers (HSS);
 673       Loc           : Source_Ptr;
 674       Handler       : Node_Id;
 675       Others_Choice : Boolean;
 676       Obj_Decl      : Node_Id;
 677
 678       procedure Prepend_Call_To_Handler
 679         (Proc : RE_Id;
 680          Args : List_Id := No_List);
 681       --  Routine to prepend a call to the procedure referenced by Proc at
 682       --  the start of the handler code for the current Handler.
 683
 684       -----------------------------
 685       -- Prepend_Call_To_Handler --
 686       -----------------------------
 687
 688       procedure Prepend_Call_To_Handler
 689         (Proc : RE_Id;
 690          Args : List_Id := No_List)
 691       is
 692          Ent : constant Entity_Id := RTE (Proc);
 693
 694       begin
 695          --  If we have no Entity, then we are probably in no run time mode
 696          --  or some weird error has occured. In either case do do nothing!
 697
 698          if Present (Ent) then
 699             declare
 700                Call : constant Node_Id :=
 701                         Make_Procedure_Call_Statement (Loc,
 702                           Name => New_Occurrence_Of (RTE (Proc), Loc),
 703                           Parameter_Associations => Args);
 704
 705             begin
 706                Prepend_To (Statements (Handler), Call);
 707                Analyze (Call, Suppress => All_Checks);
 708             end;
 709          end if;
 710       end Prepend_Call_To_Handler;
 711
 712    --  Start of processing for Expand_Exception_Handlers
 713
 714    begin
 715       --  Loop through handlers
 716
 717       Handler := First_Non_Pragma (Handlrs);
 718       Handler_Loop : while Present (Handler) loop
 719          Loc := Sloc (Handler);
 720
 721          --  Remove source handler if gnat debug flag N is set
 722
 723          if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
 724             declare
 725                H : constant Node_Id := Handler;
 726             begin
 727                Next_Non_Pragma (Handler);
 728                Remove (H);
 729                goto Continue_Handler_Loop;
 730             end;
 731          end if;
 732
 733
 734          --  If an exception occurrence is present, then we must declare it
 735          --  and initialize it from the value stored in the TSD
 736
 737          --     declare
 738          --        name : Exception_Occurrence;
 739          --
 740          --     begin
 741          --        Save_Occurrence (name, Get_Current_Excep.all)
 742          --        ...
 743          --     end;
 744
 745          if Present (Choice_Parameter (Handler)) then
 746             declare
 747                Cparm : constant Entity_Id  := Choice_Parameter (Handler);
 748                Clc   : constant Source_Ptr := Sloc (Cparm);
 749                Save  : Node_Id;
 750
 751             begin
 752                Save :=
 753                  Make_Procedure_Call_Statement (Loc,
 754                    Name =>
 755                      New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
 756                    Parameter_Associations => New_List (
 757                      New_Occurrence_Of (Cparm, Clc),
 758                      Make_Explicit_Dereference (Loc,
 759                        Make_Function_Call (Loc,
 760                          Name => Make_Explicit_Dereference (Loc,
 761                            New_Occurrence_Of
 762                              (RTE (RE_Get_Current_Excep), Loc))))));
 763
 764                Mark_Rewrite_Insertion (Save);
 765                Prepend (Save, Statements (Handler));
 766
 767                Obj_Decl :=
 768                  Make_Object_Declaration (Clc,
 769                    Defining_Identifier => Cparm,
 770                    Object_Definition   =>
 771                      New_Occurrence_Of
 772                        (RTE (RE_Exception_Occurrence), Clc));
 773                Set_No_Initialization (Obj_Decl, True);
 774
 775                Rewrite (Handler,
 776                  Make_Exception_Handler (Loc,
 777                    Exception_Choices => Exception_Choices (Handler),
 778
 779                    Statements => New_List (
 780                      Make_Block_Statement (Loc,
 781                        Declarations => New_List (Obj_Decl),
 782                        Handled_Statement_Sequence =>
 783                          Make_Handled_Sequence_Of_Statements (Loc,
 784                            Statements => Statements (Handler))))));
 785
 786                Analyze_List (Statements (Handler), Suppress => All_Checks);
 787             end;
 788          end if;
 789
 790          --  The processing at this point is rather different for the
 791          --  JVM case, so we completely separate the processing.
 792
 793          --  For the JVM case, we unconditionally call Update_Exception,
 794          --  passing a call to the intrinsic function Current_Target_Exception
 795          --  (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
 796
 797          if Hostparm.Java_VM then
 798             declare
 799                Arg : constant Node_Id :=
 800                        Make_Function_Call (Loc,
 801                          Name => New_Occurrence_Of
 802                                    (RTE (RE_Current_Target_Exception), Loc));
 803             begin
 804                Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
 805             end;
 806
 807          --  For the normal case, we have to worry about the state of abort
 808          --  deferral. Generally, we defer abort during runtime handling of
 809          --  exceptions. When control is passed to the handler, then in the
 810          --  normal case we undefer aborts. In any case this entire handling
 811          --  is relevant only if aborts are allowed!
 812
 813          elsif Abort_Allowed then
 814
 815             --  There are some special cases in which we do not do the
 816             --  undefer. In particular a finalization (AT END) handler
 817             --  wants to operate with aborts still deferred.
 818
 819             --  We also suppress the call if this is the special handler
 820             --  for Abort_Signal, since if we are aborting, we want to keep
 821             --  aborts deferred (one abort is enough thank you very much :-)
 822
 823             --  If abort really needs to be deferred the expander must add
 824             --  this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
 825
 826             Others_Choice :=
 827               Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
 828
 829             if (Others_Choice
 830                  or else Entity (First (Exception_Choices (Handler))) /=
 831                                                       Stand.Abort_Signal)
 832               and then not
 833                 (Others_Choice
 834                    and then All_Others (First (Exception_Choices (Handler))))
 835               and then Abort_Allowed
 836             then
 837                Prepend_Call_To_Handler (RE_Abort_Undefer);
 838             end if;
 839          end if;
 840
 841          Next_Non_Pragma (Handler);
 842
 843       <<Continue_Handler_Loop>>
 844          null;
 845       end loop Handler_Loop;
 846
 847       --  If all handlers got removed by gnatdN, then remove the list
 848
 849       if Debug_Flag_Dot_X
 850         and then Is_Empty_List (Exception_Handlers (HSS))
 851       then
 852          Set_Exception_Handlers (HSS, No_List);
 853       end if;
 854
 855       --  The last step for expanding exception handlers is to expand the
 856       --  exception tables if zero cost exception handling is active.
 857
 858       if Exception_Mechanism = Front_End_ZCX_Exceptions then
 859          Expand_Exception_Handler_Tables (HSS);
 860       end if;
 861    end Expand_Exception_Handlers;
 862
 863    ------------------------------------
 864    -- Expand_N_Exception_Declaration --
 865    ------------------------------------
 866
 867    --  Generates:
 868    --     exceptE : constant String := "A.B.EXCEP";   -- static data
 869    --     except : exception_data :=  (
 870    --                    Handled_By_Other => False,
 871    --                    Lang             => 'A',
 872    --                    Name_Length      => exceptE'Length,
 873    --                    Full_Name        => exceptE'Address,
 874    --                    HTable_Ptr       => null,
 875    --                    Import_Code      => 0,
 876    --                    Raise_Hook       => null,
 877    --                    );
 878
 879    --  (protecting test only needed if not at library level)
 880    --
 881    --     exceptF : Boolean := True --  static data
 882    --     if exceptF then
 883    --        exceptF := False;
 884    --        Register_Exception (except'Unchecked_Access);
 885    --     end if;
 886
 887    procedure Expand_N_Exception_Declaration (N : Node_Id) is
 888       Loc     : constant Source_Ptr := Sloc (N);
 889       Id      : constant Entity_Id  := Defining_Identifier (N);
 890       L       : List_Id             := New_List;
 891       Flag_Id : Entity_Id;
 892
 893       Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
 894       Exname      : constant Node_Id :=
 895                       Make_Defining_Identifier (Loc, Name_Exname);
 896
 897    begin
 898       --  There is no expansion needed when compiling for the JVM since the
 899       --  JVM has a built-in exception mechanism. See 4jexcept.ads for details.
 900
 901       if Hostparm.Java_VM then
 902          return;
 903       end if;
 904
 905       --  Definition of the external name: nam : constant String := "A.B.NAME";
 906
 907       Insert_Action (N,
 908         Make_Object_Declaration (Loc,
 909           Defining_Identifier => Exname,
 910           Constant_Present    => True,
 911           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 912           Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
 913
 914       Set_Is_Statically_Allocated (Exname);
 915
 916       --  Create the aggregate list for type Standard.Exception_Type:
 917       --  Handled_By_Other component: False
 918
 919       Append_To (L, New_Occurrence_Of (Standard_False, Loc));
 920
 921       --  Lang component: 'A'
 922
 923       Append_To (L,
 924         Make_Character_Literal (Loc,
 925           Chars              =>  Name_uA,
 926           Char_Literal_Value =>  UI_From_Int (Character'Pos ('A'))));
 927
 928       --  Name_Length component: Nam'Length
 929
 930       Append_To (L,
 931         Make_Attribute_Reference (Loc,
 932           Prefix         => New_Occurrence_Of (Exname, Loc),
 933           Attribute_Name => Name_Length));
 934
 935       --  Full_Name component: Standard.A_Char!(Nam'Address)
 936
 937       Append_To (L, Unchecked_Convert_To (Standard_A_Char,
 938         Make_Attribute_Reference (Loc,
 939           Prefix         => New_Occurrence_Of (Exname, Loc),
 940           Attribute_Name => Name_Address)));
 941
 942       --  HTable_Ptr component: null
 943
 944       Append_To (L, Make_Null (Loc));
 945
 946       --  Import_Code component: 0
 947
 948       Append_To (L, Make_Integer_Literal (Loc, 0));
 949
 950       --  Raise_Hook component: null
 951
 952       Append_To (L, Make_Null (Loc));
 953
 954       Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
 955       Analyze_And_Resolve (Expression (N), Etype (Id));
 956
 957       --  Register_Exception (except'Unchecked_Access);
 958
 959       if not Restriction_Active (No_Exception_Handlers)
 960         and then not Restriction_Active (No_Exception_Registration)
 961       then
 962          L := New_List (
 963                 Make_Procedure_Call_Statement (Loc,
 964                   Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
 965                   Parameter_Associations => New_List (
 966                     Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
 967                       Make_Attribute_Reference (Loc,
 968                         Prefix         => New_Occurrence_Of (Id, Loc),
 969                         Attribute_Name => Name_Unrestricted_Access)))));
 970
 971          Set_Register_Exception_Call (Id, First (L));
 972
 973          if not Is_Library_Level_Entity (Id) then
 974             Flag_Id :=  Make_Defining_Identifier (Loc,
 975                           New_External_Name (Chars (Id), 'F'));
 976
 977             Insert_Action (N,
 978               Make_Object_Declaration (Loc,
 979                 Defining_Identifier => Flag_Id,
 980                 Object_Definition   =>
 981                   New_Occurrence_Of (Standard_Boolean, Loc),
 982                 Expression          =>
 983                   New_Occurrence_Of (Standard_True, Loc)));
 984
 985             Set_Is_Statically_Allocated (Flag_Id);
 986
 987             Append_To (L,
 988               Make_Assignment_Statement (Loc,
 989                 Name       => New_Occurrence_Of (Flag_Id, Loc),
 990                 Expression => New_Occurrence_Of (Standard_False, Loc)));
 991
 992             Insert_After_And_Analyze (N,
 993               Make_Implicit_If_Statement (N,
 994                 Condition       => New_Occurrence_Of (Flag_Id, Loc),
 995                 Then_Statements => L));
 996
 997          else
 998             Insert_List_After_And_Analyze (N, L);
 999          end if;
1000       end if;
1001
1002    end Expand_N_Exception_Declaration;
1003
1004    ---------------------------------------------
1005    -- Expand_N_Handled_Sequence_Of_Statements --
1006    ---------------------------------------------
1007
1008    procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1009    begin
1010       if Present (Exception_Handlers (N))
1011         and then not Restriction_Active (No_Exception_Handlers)
1012       then
1013          Expand_Exception_Handlers (N);
1014       end if;
1015
1016       --  The following code needs comments ???
1017
1018       if Nkind (Parent (N)) /= N_Package_Body
1019         and then Nkind (Parent (N)) /= N_Accept_Statement
1020         and then not Delay_Cleanups (Current_Scope)
1021       then
1022          Expand_Cleanup_Actions (Parent (N));
1023       else
1024          Set_First_Real_Statement (N, First (Statements (N)));
1025       end if;
1026
1027    end Expand_N_Handled_Sequence_Of_Statements;
1028
1029    -------------------------------------
1030    -- Expand_N_Raise_Constraint_Error --
1031    -------------------------------------
1032
1033    --  The only processing required is to adjust the condition to deal
1034    --  with the C/Fortran boolean case. This may well not be necessary,
1035    --  as all such conditions are generated by the expander and probably
1036    --  are all standard boolean, but who knows what strange optimization
1037    --  in future may require this adjustment!
1038
1039    procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1040    begin
1041       Adjust_Condition (Condition (N));
1042    end Expand_N_Raise_Constraint_Error;
1043
1044    ----------------------------------
1045    -- Expand_N_Raise_Program_Error --
1046    ----------------------------------
1047
1048    --  The only processing required is to adjust the condition to deal
1049    --  with the C/Fortran boolean case. This may well not be necessary,
1050    --  as all such conditions are generated by the expander and probably
1051    --  are all standard boolean, but who knows what strange optimization
1052    --  in future may require this adjustment!
1053
1054    procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1055    begin
1056       Adjust_Condition (Condition (N));
1057    end Expand_N_Raise_Program_Error;
1058
1059    ------------------------------
1060    -- Expand_N_Raise_Statement --
1061    ------------------------------
1062
1063    procedure Expand_N_Raise_Statement (N : Node_Id) is
1064       Loc   : constant Source_Ptr := Sloc (N);
1065       Ehand : Node_Id;
1066       E     : Entity_Id;
1067       Str   : String_Id;
1068
1069    begin
1070       --  If a string expression is present, then the raise statement is
1071       --  converted to a call:
1072
1073       --     Raise_Exception (exception-name'Identity, string);
1074
1075       --  and there is nothing else to do
1076
1077       if Present (Expression (N)) then
1078          Rewrite (N,
1079            Make_Procedure_Call_Statement (Loc,
1080              Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1081              Parameter_Associations => New_List (
1082                Make_Attribute_Reference (Loc,
1083                  Prefix => Name (N),
1084                  Attribute_Name => Name_Identity),
1085                Expression (N))));
1086          Analyze (N);
1087          return;
1088       end if;
1089
1090       --  Remaining processing is for the case where no string expression
1091       --  is present.
1092
1093       --  There is no expansion needed for statement "raise <exception>;" when
1094       --  compiling for the JVM since the JVM has a built-in exception
1095       --  mechanism. However we need the keep the expansion for "raise;"
1096       --  statements. See 4jexcept.ads for details.
1097
1098       if Present (Name (N)) and then Hostparm.Java_VM then
1099          return;
1100       end if;
1101
1102       --  Don't expand a raise statement that does not come from source
1103       --  if we have already had configurable run-time violations, since
1104       --  most likely it will be junk cascaded nonsense.
1105
1106       if Configurable_Run_Time_Violations > 0
1107         and then not Comes_From_Source (N)
1108       then
1109          return;
1110       end if;
1111
1112       --  Convert explicit raise of Program_Error, Constraint_Error, and
1113       --  Storage_Error into the corresponding raise (in High_Integrity_Mode
1114       --  all other raises will get normal expansion and be disallowed,
1115       --  but this is also faster in all modes).
1116
1117       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1118          if Entity (Name (N)) = Standard_Constraint_Error then
1119             Rewrite (N,
1120               Make_Raise_Constraint_Error (Loc,
1121                 Reason => CE_Explicit_Raise));
1122             Analyze (N);
1123             return;
1124
1125          elsif Entity (Name (N)) = Standard_Program_Error then
1126             Rewrite (N,
1127               Make_Raise_Program_Error (Loc,
1128                 Reason => PE_Explicit_Raise));
1129             Analyze (N);
1130             return;
1131
1132          elsif Entity (Name (N)) = Standard_Storage_Error then
1133             Rewrite (N,
1134               Make_Raise_Storage_Error (Loc,
1135                 Reason => SE_Explicit_Raise));
1136             Analyze (N);
1137             return;
1138          end if;
1139       end if;
1140
1141       --  Case of name present, in this case we expand raise name to
1142
1143       --    Raise_Exception (name'Identity, location_string);
1144
1145       --  where location_string identifies the file/line of the raise
1146
1147       if Present (Name (N)) then
1148          declare
1149             Id : Entity_Id := Entity (Name (N));
1150
1151          begin
1152             Build_Location_String (Loc);
1153
1154             --  If the exception is a renaming, use the exception that it
1155             --  renames (which might be a predefined exception, e.g.).
1156
1157             if Present (Renamed_Object (Id)) then
1158                Id := Renamed_Object (Id);
1159             end if;
1160
1161             --  Build a C-compatible string in case of no exception handlers,
1162             --  since this is what the last chance handler is expecting.
1163
1164             if Restriction_Active (No_Exception_Handlers) then
1165
1166                --  Generate an empty message if configuration pragma
1167                --  Suppress_Exception_Locations is set for this unit.
1168
1169                if Opt.Exception_Locations_Suppressed then
1170                   Name_Len := 1;
1171                else
1172                   Name_Len := Name_Len + 1;
1173                end if;
1174
1175                Name_Buffer (Name_Len) := ASCII.NUL;
1176             end if;
1177
1178
1179             if Opt.Exception_Locations_Suppressed then
1180                Name_Len := 0;
1181             end if;
1182
1183             Str := String_From_Name_Buffer;
1184
1185             --  For VMS exceptions, convert the raise into a call to
1186             --  lib$stop so it will be handled by __gnat_error_handler.
1187
1188             if Is_VMS_Exception (Id) then
1189                declare
1190                   Excep_Image : String_Id;
1191                   Cond        : Node_Id;
1192
1193                begin
1194                   if Present (Interface_Name (Id)) then
1195                      Excep_Image := Strval (Interface_Name (Id));
1196                   else
1197                      Get_Name_String (Chars (Id));
1198                      Set_All_Upper_Case;
1199                      Excep_Image := String_From_Name_Buffer;
1200                   end if;
1201
1202                   if Exception_Code (Id) /= No_Uint then
1203                      Cond :=
1204                        Make_Integer_Literal (Loc, Exception_Code (Id));
1205                   else
1206                      Cond :=
1207                        Unchecked_Convert_To (Standard_Integer,
1208                          Make_Function_Call (Loc,
1209                            Name => New_Occurrence_Of
1210                              (RTE (RE_Import_Value), Loc),
1211                            Parameter_Associations => New_List
1212                              (Make_String_Literal (Loc,
1213                                Strval => Excep_Image))));
1214                   end if;
1215
1216                   Rewrite (N,
1217                     Make_Procedure_Call_Statement (Loc,
1218                       Name =>
1219                         New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1220                       Parameter_Associations => New_List (Cond)));
1221                         Analyze_And_Resolve (Cond, Standard_Integer);
1222                end;
1223
1224             --  Not VMS exception case, convert raise to call to the
1225             --  Raise_Exception routine.
1226
1227             else
1228                Rewrite (N,
1229                  Make_Procedure_Call_Statement (Loc,
1230                     Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1231                     Parameter_Associations => New_List (
1232                       Make_Attribute_Reference (Loc,
1233                         Prefix => Name (N),
1234                         Attribute_Name => Name_Identity),
1235                       Make_String_Literal (Loc,
1236                         Strval => Str))));
1237             end if;
1238          end;
1239
1240       --  Case of no name present (reraise). We rewrite the raise to:
1241
1242       --    Reraise_Occurrence_Always (EO);
1243
1244       --  where EO is the current exception occurrence. If the current handler
1245       --  does not have a choice parameter specification, then we provide one.
1246
1247       else
1248          --  Find innermost enclosing exception handler (there must be one,
1249          --  since the semantics has already verified that this raise statement
1250          --  is valid, and a raise with no arguments is only permitted in the
1251          --  context of an exception handler.
1252
1253          Ehand := Parent (N);
1254          while Nkind (Ehand) /= N_Exception_Handler loop
1255             Ehand := Parent (Ehand);
1256          end loop;
1257
1258          --  Make exception choice parameter if none present. Note that we do
1259          --  not need to put the entity on the entity chain, since no one will
1260          --  be referencing this entity by normal visibility methods.
1261
1262          if No (Choice_Parameter (Ehand)) then
1263             E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1264             Set_Choice_Parameter (Ehand, E);
1265             Set_Ekind (E, E_Variable);
1266             Set_Etype (E, RTE (RE_Exception_Occurrence));
1267             Set_Scope (E, Current_Scope);
1268          end if;
1269
1270          --  Now rewrite the raise as a call to Reraise. A special case arises
1271          --  if this raise statement occurs in the context of a handler for
1272          --  all others (i.e. an at end handler). in this case we avoid
1273          --  the call to defer abort, cleanup routines are expected to be
1274          --  called in this case with aborts deferred.
1275
1276          declare
1277             Ech : constant Node_Id := First (Exception_Choices (Ehand));
1278             Ent : Entity_Id;
1279
1280          begin
1281             if Nkind (Ech) = N_Others_Choice
1282               and then All_Others (Ech)
1283             then
1284                Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1285             else
1286                Ent := RTE (RE_Reraise_Occurrence_Always);
1287             end if;
1288
1289             Rewrite (N,
1290               Make_Procedure_Call_Statement (Loc,
1291                 Name => New_Occurrence_Of (Ent, Loc),
1292                 Parameter_Associations => New_List (
1293                   New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1294          end;
1295       end if;
1296
1297       Analyze (N);
1298    end Expand_N_Raise_Statement;
1299
1300    ----------------------------------
1301    -- Expand_N_Raise_Storage_Error --
1302    ----------------------------------
1303
1304    --  The only processing required is to adjust the condition to deal
1305    --  with the C/Fortran boolean case. This may well not be necessary,
1306    --  as all such conditions are generated by the expander and probably
1307    --  are all standard boolean, but who knows what strange optimization
1308    --  in future may require this adjustment!
1309
1310    procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1311    begin
1312       Adjust_Condition (Condition (N));
1313    end Expand_N_Raise_Storage_Error;
1314
1315    ------------------------------
1316    -- Expand_N_Subprogram_Info --
1317    ------------------------------
1318
1319    procedure Expand_N_Subprogram_Info (N : Node_Id) is
1320       Loc : constant Source_Ptr := Sloc (N);
1321
1322    begin
1323       --  For now, we replace an Expand_N_Subprogram_Info node with an
1324       --  attribute reference that gives the address of the procedure.
1325       --  This is because gigi does not yet recognize this node, and
1326       --  for the initial targets, this is the right value anyway.
1327
1328       Rewrite (N,
1329         Make_Attribute_Reference (Loc,
1330           Prefix => Identifier (N),
1331           Attribute_Name => Name_Code_Address));
1332
1333       Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1334    end Expand_N_Subprogram_Info;
1335
1336    ------------------------------------
1337    -- Generate_Subprogram_Descriptor --
1338    ------------------------------------
1339
1340    procedure Generate_Subprogram_Descriptor
1341      (N     : Node_Id;
1342       Loc   : Source_Ptr;
1343       Spec  : Entity_Id;
1344       Slist : List_Id)
1345    is
1346       Code  : Node_Id;
1347       Ent   : Entity_Id;
1348       Decl  : Node_Id;
1349       Dtyp  : Entity_Id;
1350       Numh  : Nat;
1351       Sdes  : Node_Id;
1352       Hrc   : List_Id;
1353
1354    begin
1355       if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1356          return;
1357       end if;
1358
1359       if Restriction_Active (No_Exception_Handlers) then
1360          return;
1361       end if;
1362
1363       --  Suppress descriptor if we are not generating code. This happens
1364       --  in the case of a -gnatc -gnatt compilation where we force generics
1365       --  to be generated, but we still don't want exception tables.
1366
1367       if Operating_Mode /= Generate_Code then
1368          return;
1369       end if;
1370
1371       --  Suppress descriptor if we are in No_Exceptions restrictions mode,
1372       --  since we can never propagate exceptions in any case in this mode.
1373       --  The same consideration applies for No_Exception_Handlers (which
1374       --  is also set in High_Integrity_Mode).
1375
1376       if Restriction_Active (No_Exceptions)
1377         or Restriction_Active (No_Exception_Handlers)
1378       then
1379          return;
1380       end if;
1381
1382       --  Suppress descriptor if we are inside a generic. There are two
1383       --  ways that we can tell that, depending on what is going on. If
1384       --  we are actually inside the processing for a generic right now,
1385       --  then Expander_Active will be reset. If we are outside the
1386       --  generic, then we will see the generic entity.
1387
1388       if not Expander_Active then
1389          return;
1390       end if;
1391
1392       --  Suppress descriptor is subprogram is marked as eliminated, for
1393       --  example if this is a subprogram created to analyze a default
1394       --  expression with potential side effects. Ditto if it is nested
1395       --  within an eliminated subprogram, for example a cleanup action.
1396
1397       declare
1398          Scop : Entity_Id;
1399
1400       begin
1401          Scop := Spec;
1402          while Scop /= Standard_Standard loop
1403             if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
1404                return;
1405             end if;
1406
1407             Scop := Scope (Scop);
1408          end loop;
1409       end;
1410
1411       --  Suppress descriptor for original protected subprogram (we will
1412       --  be called again later to generate the descriptor for the actual
1413       --  protected body subprogram.) This does not apply to barrier
1414       --  functions which are there own protected subprogram.
1415
1416       if Is_Subprogram (Spec)
1417         and then Present (Protected_Body_Subprogram (Spec))
1418         and then Protected_Body_Subprogram (Spec) /= Spec
1419       then
1420          return;
1421       end if;
1422
1423       --  Suppress descriptors for packages unless they have at least one
1424       --  handler. The binder will generate the dummy (no handler) descriptors
1425       --  for elaboration procedures. We can't do it here, because we don't
1426       --  know if an elaboration routine does in fact exist.
1427
1428       --  If there is at least one handler for the package spec or body
1429       --  then most certainly an elaboration routine must exist, so we
1430       --  can safely reference it.
1431
1432       if (Nkind (N) = N_Package_Declaration
1433             or else
1434           Nkind (N) = N_Package_Body)
1435         and then No (Handler_Records (Spec))
1436       then
1437          return;
1438       end if;
1439
1440       --  Suppress all subprogram descriptors for the file System.Exceptions.
1441       --  We similarly suppress subprogram descriptors for Ada.Exceptions.
1442       --  These are all init procs for types which cannot raise exceptions.
1443       --  The reason this is done is that otherwise we get embarassing
1444       --  elaboration dependencies.
1445
1446       Get_Name_String (Unit_File_Name (Current_Sem_Unit));
1447
1448       if Name_Buffer (1 .. 12) = "s-except.ads"
1449            or else
1450          Name_Buffer (1 .. 12) = "a-except.ads"
1451       then
1452          return;
1453       end if;
1454
1455       --  Similarly, we need to suppress entries for System.Standard_Library,
1456       --  since otherwise we get elaboration circularities. Again, this would
1457       --  better be done with a Suppress_Initialization pragma :-)
1458
1459       if Name_Buffer (1 .. 11) = "s-stalib.ad" then
1460          return;
1461       end if;
1462
1463       --  For now, also suppress entries for s-stoele because we have
1464       --  some kind of unexplained error there ???
1465
1466       if Name_Buffer (1 .. 11) = "s-stoele.ad" then
1467          return;
1468       end if;
1469
1470       --  And also for g-htable, because it cannot raise exceptions,
1471       --  and generates some kind of elaboration order problem.
1472
1473       if Name_Buffer (1 .. 11) = "g-htable.ad" then
1474          return;
1475       end if;
1476
1477       --  Suppress subprogram descriptor if already generated. This happens
1478       --  in the case of late generation from Delay_Subprogram_Descriptors
1479       --  beging set (where there is more than one instantiation in the list)
1480
1481       if Has_Subprogram_Descriptor (Spec) then
1482          return;
1483       else
1484          Set_Has_Subprogram_Descriptor (Spec);
1485       end if;
1486
1487       --  Never generate descriptors for inlined bodies
1488
1489       if Analyzing_Inlined_Bodies then
1490          return;
1491       end if;
1492
1493       --  Here we definitely are going to generate a subprogram descriptor
1494
1495       declare
1496          Hnum : Nat := Homonym_Number (Spec);
1497
1498       begin
1499          if Hnum = 1 then
1500             Hnum := 0;
1501          end if;
1502
1503          Ent :=
1504            Make_Defining_Identifier (Loc,
1505              Chars => New_External_Name (Chars (Spec), "SD", Hnum));
1506       end;
1507
1508       if No (Handler_Records (Spec)) then
1509          Hrc  := Empty_List;
1510          Numh := 0;
1511       else
1512          Hrc  := Handler_Records (Spec);
1513          Numh := List_Length (Hrc);
1514       end if;
1515
1516       New_Scope (Spec);
1517
1518       --  We need a static subtype for the declaration of the subprogram
1519       --  descriptor. For the case of 0-3 handlers we can use one of the
1520       --  predefined subtypes in System.Exceptions. For more handlers,
1521       --  we build our own subtype here.
1522
1523       case Numh is
1524          when 0 =>
1525             Dtyp := RTE (RE_Subprogram_Descriptor_0);
1526
1527          when 1 =>
1528             Dtyp := RTE (RE_Subprogram_Descriptor_1);
1529
1530          when 2 =>
1531             Dtyp := RTE (RE_Subprogram_Descriptor_2);
1532
1533          when 3 =>
1534             Dtyp := RTE (RE_Subprogram_Descriptor_3);
1535
1536          when others =>
1537             Dtyp :=
1538               Make_Defining_Identifier (Loc,
1539                 Chars => New_Internal_Name ('T'));
1540
1541             --  Set the constructed type as global, since we will be
1542             --  referencing the object that is of this type globally
1543
1544             Set_Is_Statically_Allocated (Dtyp);
1545
1546             Decl :=
1547               Make_Subtype_Declaration (Loc,
1548                 Defining_Identifier => Dtyp,
1549                 Subtype_Indication =>
1550                   Make_Subtype_Indication (Loc,
1551                     Subtype_Mark =>
1552                       New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
1553                     Constraint =>
1554                       Make_Index_Or_Discriminant_Constraint (Loc,
1555                         Constraints => New_List (
1556                           Make_Integer_Literal (Loc, Numh)))));
1557
1558             Append (Decl, Slist);
1559
1560             --  We analyze the descriptor for the subprogram and package
1561             --  case, but not for the imported subprogram case (it will
1562             --  be analyzed when the freeze entity actions are analyzed.
1563
1564             if Present (N) then
1565                Analyze (Decl);
1566             end if;
1567
1568             Set_Exception_Junk (Decl);
1569       end case;
1570
1571       --  Prepare the code address entry for the table entry. For the normal
1572       --  case of being within a procedure, this is simply:
1573
1574       --    P'Code_Address
1575
1576       --  where P is the procedure, but for the package case, it is
1577
1578       --    P'Elab_Body'Code_Address
1579       --    P'Elab_Spec'Code_Address
1580
1581       --  for the body and spec respectively. Note that we do our own
1582       --  analysis of these attribute references, because we know in this
1583       --  case that the prefix of ELab_Body/Spec is a visible package,
1584       --  which can be referenced directly instead of using the general
1585       --  case expansion for these attributes.
1586
1587       if Ekind (Spec) = E_Package then
1588          Code :=
1589            Make_Attribute_Reference (Loc,
1590              Prefix         => New_Occurrence_Of (Spec, Loc),
1591              Attribute_Name => Name_Elab_Spec);
1592          Set_Etype (Code, Standard_Void_Type);
1593          Set_Analyzed (Code);
1594
1595       elsif Ekind (Spec) = E_Package_Body then
1596          Code :=
1597            Make_Attribute_Reference (Loc,
1598              Prefix         => New_Occurrence_Of (Spec_Entity (Spec), Loc),
1599              Attribute_Name => Name_Elab_Body);
1600          Set_Etype (Code, Standard_Void_Type);
1601          Set_Analyzed (Code);
1602
1603       else
1604          Code := New_Occurrence_Of (Spec, Loc);
1605       end if;
1606
1607       Code :=
1608         Make_Attribute_Reference (Loc,
1609           Prefix         => Code,
1610           Attribute_Name => Name_Code_Address);
1611
1612       Set_Etype (Code, RTE (RE_Address));
1613       Set_Analyzed (Code);
1614
1615       --  Now we can build the subprogram descriptor
1616
1617       Sdes :=
1618         Make_Object_Declaration (Loc,
1619           Defining_Identifier      => Ent,
1620           Constant_Present         => True,
1621           Aliased_Present          => True,
1622           Object_Definition        => New_Occurrence_Of (Dtyp, Loc),
1623
1624           Expression               =>
1625             Make_Aggregate (Loc,
1626               Expressions => New_List (
1627                 Make_Integer_Literal (Loc, Numh),          -- Num_Handlers
1628
1629                 Code,                                      -- Code
1630
1631 --  temp code ???
1632
1633 --                Make_Subprogram_Info (Loc,                 -- Subprogram_Info
1634 --                  Identifier =>
1635 --                    New_Occurrence_Of (Spec, Loc)),
1636
1637                 New_Copy_Tree (Code),
1638
1639                 Make_Aggregate (Loc,                       -- Handler_Records
1640                   Expressions => Hrc))));
1641
1642       Set_Exception_Junk (Sdes);
1643       Set_Is_Subprogram_Descriptor (Sdes);
1644
1645       Append (Sdes, Slist);
1646
1647       --  We analyze the descriptor for the subprogram and package case,
1648       --  but not for the imported subprogram case (it will be analyzed
1649       --  when the freeze entity actions are analyzed.
1650
1651       if Present (N) then
1652          Analyze (Sdes);
1653       end if;
1654
1655       --  We can now pop the scope used for analyzing the descriptor
1656
1657       Pop_Scope;
1658
1659       --  We need to set the descriptor as statically allocated, since
1660       --  it will be referenced from the unit exception table.
1661
1662       Set_Is_Statically_Allocated (Ent);
1663
1664       --  Append the resulting descriptor to the list. We do this only
1665       --  if we are in the main unit. You might think that we could
1666       --  simply skip generating the descriptors completely if we are
1667       --  not in the main unit, but in fact this is not the case, since
1668       --  we have problems with inconsistent serial numbers for internal
1669       --  names if we do this.
1670
1671       if In_Extended_Main_Code_Unit (Spec) then
1672          Append_To (SD_List,
1673            Make_Attribute_Reference (Loc,
1674              Prefix => New_Occurrence_Of (Ent, Loc),
1675              Attribute_Name => Name_Unrestricted_Access));
1676
1677          Unit_Exception_Table_Present := True;
1678       end if;
1679
1680    end Generate_Subprogram_Descriptor;
1681
1682    ------------------------------------------------------------
1683    -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
1684    ------------------------------------------------------------
1685
1686    procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
1687      (Spec  : Entity_Id;
1688       Slist : List_Id)
1689    is
1690    begin
1691       Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
1692    end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
1693
1694    ------------------------------------------------
1695    -- Generate_Subprogram_Descriptor_For_Package --
1696    ------------------------------------------------
1697
1698    procedure Generate_Subprogram_Descriptor_For_Package
1699      (N    : Node_Id;
1700       Spec : Entity_Id)
1701    is
1702       Adecl : Node_Id;
1703
1704    begin
1705       --  If N is empty with prior errors, ignore
1706
1707       if Total_Errors_Detected /= 0 and then No (N) then
1708          return;
1709       end if;
1710
1711       --  Do not generate if no exceptions
1712
1713       if Restriction_Active (No_Exception_Handlers) then
1714          return;
1715       end if;
1716
1717       --  Otherwise generate descriptor
1718
1719       Adecl := Aux_Decls_Node (Parent (N));
1720
1721       if No (Actions (Adecl)) then
1722          Set_Actions (Adecl, New_List);
1723       end if;
1724
1725       Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
1726    end Generate_Subprogram_Descriptor_For_Package;
1727
1728    ---------------------------------------------------
1729    -- Generate_Subprogram_Descriptor_For_Subprogram --
1730    ---------------------------------------------------
1731
1732    procedure Generate_Subprogram_Descriptor_For_Subprogram
1733      (N    : Node_Id;
1734       Spec : Entity_Id)
1735    is
1736    begin
1737       --  If we have no subprogram body and prior errors, ignore
1738
1739       if Total_Errors_Detected /= 0 and then No (N) then
1740          return;
1741       end if;
1742
1743       --  Do not generate if no exceptions
1744
1745       if Restriction_Active (No_Exception_Handlers) then
1746          return;
1747       end if;
1748
1749       --  Else generate descriptor
1750
1751       declare
1752          HSS : constant Node_Id := Handled_Statement_Sequence (N);
1753
1754       begin
1755          if No (Exception_Handlers (HSS)) then
1756             Generate_Subprogram_Descriptor
1757               (N, Sloc (N), Spec, Statements (HSS));
1758          else
1759             Generate_Subprogram_Descriptor
1760               (N, Sloc (N),
1761                Spec, Statements (Last (Exception_Handlers (HSS))));
1762          end if;
1763       end;
1764    end Generate_Subprogram_Descriptor_For_Subprogram;
1765
1766    -----------------------------------
1767    -- Generate_Unit_Exception_Table --
1768    -----------------------------------
1769
1770    --  The only remaining thing to generate here is to generate the
1771    --  reference to the subprogram descriptor chain. See Ada.Exceptions
1772    --  for details of required data structures.
1773
1774    procedure Generate_Unit_Exception_Table is
1775       Loc      : constant Source_Ptr := No_Location;
1776       Num      : Nat;
1777       Decl     : Node_Id;
1778       Ent      : Entity_Id;
1779       Next_Ent : Entity_Id;
1780       Stent    : Entity_Id;
1781
1782    begin
1783       --  Nothing to be done if zero length exceptions not active
1784
1785       if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1786          return;
1787       end if;
1788
1789       --  Nothing to do if no exceptions
1790
1791       if Restriction_Active (No_Exception_Handlers) then
1792          return;
1793       end if;
1794
1795       --  Remove any entries from SD_List that correspond to eliminated
1796       --  subprograms.
1797
1798       Ent := First (SD_List);
1799       while Present (Ent) loop
1800          Next_Ent := Next (Ent);
1801          if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
1802             Remove (Ent); -- After this, there is no Next (Ent) anymore
1803          end if;
1804
1805          Ent := Next_Ent;
1806       end loop;
1807
1808       --  Nothing to do if no unit exception table present.
1809       --  An empty table can result from subprogram elimination,
1810       --  in such a case, eliminate the exception table itself.
1811
1812       if Is_Empty_List (SD_List) then
1813          Unit_Exception_Table_Present := False;
1814          return;
1815       end if;
1816
1817       --  Do not generate table in a generic
1818
1819       if Inside_A_Generic then
1820          return;
1821       end if;
1822
1823       --  Generate the unit exception table
1824
1825       --    subtype Tnn is Subprogram_Descriptors_Record (Num);
1826       --    __gnat_unitname__SDP : aliased constant Tnn :=
1827       --                             Num,
1828       --                             (sub1'unrestricted_access,
1829       --                              sub2'unrestricted_access,
1830       --                              ...
1831       --                              subNum'unrestricted_access));
1832
1833       Num := List_Length (SD_List);
1834
1835       Stent :=
1836         Make_Defining_Identifier (Loc,
1837           Chars => New_Internal_Name ('T'));
1838
1839       Insert_Library_Level_Action (
1840         Make_Subtype_Declaration (Loc,
1841           Defining_Identifier => Stent,
1842           Subtype_Indication =>
1843             Make_Subtype_Indication (Loc,
1844               Subtype_Mark =>
1845                 New_Occurrence_Of
1846                  (RTE (RE_Subprogram_Descriptors_Record), Loc),
1847               Constraint =>
1848                 Make_Index_Or_Discriminant_Constraint (Loc,
1849                   Constraints => New_List (
1850                     Make_Integer_Literal (Loc, Num))))));
1851
1852       Set_Is_Statically_Allocated (Stent);
1853
1854       Get_External_Unit_Name_String (Unit_Name (Main_Unit));
1855       Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
1856       Name_Buffer (1 .. 7) := "__gnat_";
1857       Name_Len := Name_Len + 7;
1858       Add_Str_To_Name_Buffer ("__SDP");
1859
1860       Ent :=
1861         Make_Defining_Identifier (Loc,
1862           Chars => Name_Find);
1863
1864       Get_Name_String (Chars (Ent));
1865       Set_Interface_Name (Ent,
1866         Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
1867
1868       Decl :=
1869         Make_Object_Declaration (Loc,
1870              Defining_Identifier => Ent,
1871              Object_Definition   => New_Occurrence_Of (Stent, Loc),
1872           Constant_Present => True,
1873           Aliased_Present  => True,
1874           Expression =>
1875             Make_Aggregate (Loc,
1876               New_List (
1877                 Make_Integer_Literal (Loc, List_Length (SD_List)),
1878
1879               Make_Aggregate (Loc,
1880                 Expressions => SD_List))));
1881
1882       Insert_Library_Level_Action (Decl);
1883
1884       Set_Is_Exported             (Ent, True);
1885       Set_Is_Public               (Ent, True);
1886       Set_Is_Statically_Allocated (Ent, True);
1887
1888       Get_Name_String (Chars (Ent));
1889       Set_Interface_Name (Ent,
1890         Make_String_Literal (Loc,
1891           Strval => String_From_Name_Buffer));
1892
1893    end Generate_Unit_Exception_Table;
1894
1895    ----------------
1896    -- Initialize --
1897    ----------------
1898
1899    procedure Initialize is
1900    begin
1901       SD_List := Empty_List;
1902    end Initialize;
1903
1904    ----------------------
1905    -- Is_Non_Ada_Error --
1906    ----------------------
1907
1908    function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1909    begin
1910       if not OpenVMS_On_Target then
1911          return False;
1912       end if;
1913
1914       Get_Name_String (Chars (E));
1915
1916       --  Note: it is a little irregular for the body of exp_ch11 to know
1917       --  the details of the encoding scheme for names, but on the other
1918       --  hand, gigi knows them, and this is for gigi's benefit anyway!
1919
1920       if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1921          return False;
1922       end if;
1923
1924       return True;
1925    end Is_Non_Ada_Error;
1926
1927    ----------------------------
1928    -- Remove_Handler_Entries --
1929    ----------------------------
1930
1931    procedure Remove_Handler_Entries (N : Node_Id) is
1932       function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
1933       --  This function checks one node for a possible reference to a
1934       --  handler entry that must be deleted. it always returns OK.
1935
1936       function Remove_All_Handler_Entries is new
1937         Traverse_Func (Check_Handler_Entry);
1938       --  This defines the traversal operation
1939
1940       Discard : Traverse_Result;
1941       pragma Warnings (Off, Discard);
1942
1943       function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
1944       begin
1945          if Nkind (N) = N_Object_Declaration then
1946
1947             if Present (Handler_List_Entry (N)) then
1948                Remove (Handler_List_Entry (N));
1949                Delete_Tree (Handler_List_Entry (N));
1950                Set_Handler_List_Entry (N, Empty);
1951
1952             elsif Is_Subprogram_Descriptor (N) then
1953                declare
1954                   SDN : Node_Id;
1955
1956                begin
1957                   SDN := First (SD_List);
1958                   while Present (SDN) loop
1959                      if Defining_Identifier (N) = Entity (Prefix (SDN)) then
1960                         Remove (SDN);
1961                         Delete_Tree (SDN);
1962                         exit;
1963                      end if;
1964
1965                      Next (SDN);
1966                   end loop;
1967                end;
1968             end if;
1969          end if;
1970
1971          return OK;
1972       end Check_Handler_Entry;
1973
1974    --  Start of processing for Remove_Handler_Entries
1975
1976    begin
1977       if Exception_Mechanism = Front_End_ZCX_Exceptions then
1978          Discard := Remove_All_Handler_Entries (N);
1979       end if;
1980    end Remove_Handler_Entries;
1981
1982 end Exp_Ch11;