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