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-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Namet;    use Namet;
  36 with Nlists;   use Nlists;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Rtsfind;  use Rtsfind;
  40 with Restrict; use Restrict;
  41 with Rident;   use Rident;
  42 with Sem;      use Sem;
  43 with Sem_Ch8;  use Sem_Ch8;
  44 with Sem_Res;  use Sem_Res;
  45 with Sem_Util; use Sem_Util;
  46 with Sinfo;    use Sinfo;
  47 with Sinput;   use Sinput;
  48 with Snames;   use Snames;
  49 with Stand;    use Stand;
  50 with Stringt;  use Stringt;
  51 with Targparm; use Targparm;
  52 with Tbuild;   use Tbuild;
  53 with Uintp;    use Uintp;
  54
  55 package body Exp_Ch11 is
  56
  57    ---------------------------
  58    -- Expand_At_End_Handler --
  59    ---------------------------
  60
  61    --  For a handled statement sequence that has a cleanup (At_End_Proc
  62    --  field set), an exception handler of the following form is required:
  63
  64    --     exception
  65    --       when all others =>
  66    --          cleanup call
  67    --          raise;
  68
  69    --  Note: this exception handler is treated rather specially by
  70    --  subsequent expansion in two respects:
  71
  72    --    The normal call to Undefer_Abort is omitted
  73    --    The raise call does not do Defer_Abort
  74
  75    --  This is because the current tasking code seems to assume that
  76    --  the call to the cleanup routine that is made from an exception
  77    --  handler for the abort signal is called with aborts deferred.
  78
  79    --  This expansion is only done if we have front end exception handling.
  80    --  If we have back end exception handling, then the AT END handler is
  81    --  left alone, and cleanups (including the exceptional case) are handled
  82    --  by the back end.
  83
  84    --  In the front end case, the exception handler described above handles
  85    --  the exceptional case. The AT END handler is left in the generated tree
  86    --  and the code generator (e.g. gigi) must still handle proper generation
  87    --  of cleanup calls for the non-exceptional case.
  88
  89    procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
  90       Clean   : constant Entity_Id  := Entity (At_End_Proc (HSS));
  91       Loc     : constant Source_Ptr := Sloc (Clean);
  92       Ohandle : Node_Id;
  93       Stmnts  : List_Id;
  94
  95    begin
  96       pragma Assert (Present (Clean));
  97       pragma Assert (No (Exception_Handlers (HSS)));
  98
  99       --  Don't expand if back end exception handling active
 100
 101       if Exception_Mechanism = Back_End_Exceptions then
 102          return;
 103       end if;
 104
 105       --  Don't expand an At End handler if we have already had configurable
 106       --  run-time violations, since likely this will just be a matter of
 107       --  generating useless cascaded messages
 108
 109       if Configurable_Run_Time_Violations > 0 then
 110          return;
 111       end if;
 112
 113       if Restriction_Active (No_Exception_Handlers) then
 114          return;
 115       end if;
 116
 117       if Present (Block) then
 118          New_Scope (Block);
 119       end if;
 120
 121       Ohandle :=
 122         Make_Others_Choice (Loc);
 123       Set_All_Others (Ohandle);
 124
 125       Stmnts := New_List (
 126         Make_Procedure_Call_Statement (Loc,
 127           Name => New_Occurrence_Of (Clean, Loc)),
 128         Make_Raise_Statement (Loc));
 129
 130       Set_Exception_Handlers (HSS, New_List (
 131         Make_Exception_Handler (Loc,
 132           Exception_Choices => New_List (Ohandle),
 133           Statements        => Stmnts)));
 134
 135       Analyze_List (Stmnts, Suppress => All_Checks);
 136       Expand_Exception_Handlers (HSS);
 137
 138       if Present (Block) then
 139          Pop_Scope;
 140       end if;
 141    end Expand_At_End_Handler;
 142
 143    -------------------------------
 144    -- Expand_Exception_Handlers --
 145    -------------------------------
 146
 147    procedure Expand_Exception_Handlers (HSS : Node_Id) is
 148       Handlrs       : constant List_Id := Exception_Handlers (HSS);
 149       Loc           : Source_Ptr;
 150       Handler       : Node_Id;
 151       Others_Choice : Boolean;
 152       Obj_Decl      : Node_Id;
 153
 154       procedure Prepend_Call_To_Handler
 155         (Proc : RE_Id;
 156          Args : List_Id := No_List);
 157       --  Routine to prepend a call to the procedure referenced by Proc at
 158       --  the start of the handler code for the current Handler.
 159
 160       -----------------------------
 161       -- Prepend_Call_To_Handler --
 162       -----------------------------
 163
 164       procedure Prepend_Call_To_Handler
 165         (Proc : RE_Id;
 166          Args : List_Id := No_List)
 167       is
 168          Ent : constant Entity_Id := RTE (Proc);
 169
 170       begin
 171          --  If we have no Entity, then we are probably in no run time mode
 172          --  or some weird error has occured. In either case do do nothing!
 173
 174          if Present (Ent) then
 175             declare
 176                Call : constant Node_Id :=
 177                         Make_Procedure_Call_Statement (Loc,
 178                           Name => New_Occurrence_Of (RTE (Proc), Loc),
 179                           Parameter_Associations => Args);
 180
 181             begin
 182                Prepend_To (Statements (Handler), Call);
 183                Analyze (Call, Suppress => All_Checks);
 184             end;
 185          end if;
 186       end Prepend_Call_To_Handler;
 187
 188    --  Start of processing for Expand_Exception_Handlers
 189
 190    begin
 191       --  Loop through handlers
 192
 193       Handler := First_Non_Pragma (Handlrs);
 194       Handler_Loop : while Present (Handler) loop
 195          Loc := Sloc (Handler);
 196
 197          --  Remove source handler if gnat debug flag N is set
 198
 199          if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
 200             declare
 201                H : constant Node_Id := Handler;
 202             begin
 203                Next_Non_Pragma (Handler);
 204                Remove (H);
 205                goto Continue_Handler_Loop;
 206             end;
 207          end if;
 208
 209          --  If an exception occurrence is present, then we must declare it
 210          --  and initialize it from the value stored in the TSD
 211
 212          --     declare
 213          --        name : Exception_Occurrence;
 214          --
 215          --     begin
 216          --        Save_Occurrence (name, Get_Current_Excep.all)
 217          --        ...
 218          --     end;
 219
 220          if Present (Choice_Parameter (Handler)) then
 221             declare
 222                Cparm : constant Entity_Id  := Choice_Parameter (Handler);
 223                Clc   : constant Source_Ptr := Sloc (Cparm);
 224                Save  : Node_Id;
 225
 226             begin
 227                Save :=
 228                  Make_Procedure_Call_Statement (Loc,
 229                    Name =>
 230                      New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
 231                    Parameter_Associations => New_List (
 232                      New_Occurrence_Of (Cparm, Clc),
 233                      Make_Explicit_Dereference (Loc,
 234                        Make_Function_Call (Loc,
 235                          Name => Make_Explicit_Dereference (Loc,
 236                            New_Occurrence_Of
 237                              (RTE (RE_Get_Current_Excep), Loc))))));
 238
 239                Mark_Rewrite_Insertion (Save);
 240                Prepend (Save, Statements (Handler));
 241
 242                Obj_Decl :=
 243                  Make_Object_Declaration (Clc,
 244                    Defining_Identifier => Cparm,
 245                    Object_Definition   =>
 246                      New_Occurrence_Of
 247                        (RTE (RE_Exception_Occurrence), Clc));
 248                Set_No_Initialization (Obj_Decl, True);
 249
 250                Rewrite (Handler,
 251                  Make_Exception_Handler (Loc,
 252                    Exception_Choices => Exception_Choices (Handler),
 253
 254                    Statements => New_List (
 255                      Make_Block_Statement (Loc,
 256                        Declarations => New_List (Obj_Decl),
 257                        Handled_Statement_Sequence =>
 258                          Make_Handled_Sequence_Of_Statements (Loc,
 259                            Statements => Statements (Handler))))));
 260
 261                Analyze_List (Statements (Handler), Suppress => All_Checks);
 262             end;
 263          end if;
 264
 265          --  The processing at this point is rather different for the
 266          --  JVM case, so we completely separate the processing.
 267
 268          --  For the JVM case, we unconditionally call Update_Exception,
 269          --  passing a call to the intrinsic function Current_Target_Exception
 270          --  (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
 271
 272          if Hostparm.Java_VM then
 273             declare
 274                Arg : constant Node_Id :=
 275                        Make_Function_Call (Loc,
 276                          Name => New_Occurrence_Of
 277                                    (RTE (RE_Current_Target_Exception), Loc));
 278             begin
 279                Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
 280             end;
 281
 282          --  For the normal case, we have to worry about the state of abort
 283          --  deferral. Generally, we defer abort during runtime handling of
 284          --  exceptions. When control is passed to the handler, then in the
 285          --  normal case we undefer aborts. In any case this entire handling
 286          --  is relevant only if aborts are allowed!
 287
 288          elsif Abort_Allowed then
 289
 290             --  There are some special cases in which we do not do the
 291             --  undefer. In particular a finalization (AT END) handler
 292             --  wants to operate with aborts still deferred.
 293
 294             --  We also suppress the call if this is the special handler
 295             --  for Abort_Signal, since if we are aborting, we want to keep
 296             --  aborts deferred (one abort is enough thank you very much :-)
 297
 298             --  If abort really needs to be deferred the expander must add
 299             --  this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
 300
 301             Others_Choice :=
 302               Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
 303
 304             if (Others_Choice
 305                  or else Entity (First (Exception_Choices (Handler))) /=
 306                                                       Stand.Abort_Signal)
 307               and then not
 308                 (Others_Choice
 309                    and then All_Others (First (Exception_Choices (Handler))))
 310               and then Abort_Allowed
 311             then
 312                Prepend_Call_To_Handler (RE_Abort_Undefer);
 313             end if;
 314          end if;
 315
 316          Next_Non_Pragma (Handler);
 317
 318       <<Continue_Handler_Loop>>
 319          null;
 320       end loop Handler_Loop;
 321
 322       --  If all handlers got removed by gnatdN, then remove the list
 323
 324       if Debug_Flag_Dot_X
 325         and then Is_Empty_List (Exception_Handlers (HSS))
 326       then
 327          Set_Exception_Handlers (HSS, No_List);
 328       end if;
 329    end Expand_Exception_Handlers;
 330
 331    ------------------------------------
 332    -- Expand_N_Exception_Declaration --
 333    ------------------------------------
 334
 335    --  Generates:
 336    --     exceptE : constant String := "A.B.EXCEP";   -- static data
 337    --     except : exception_data :=  (
 338    --                    Handled_By_Other => False,
 339    --                    Lang             => 'A',
 340    --                    Name_Length      => exceptE'Length,
 341    --                    Full_Name        => exceptE'Address,
 342    --                    HTable_Ptr       => null,
 343    --                    Import_Code      => 0,
 344    --                    Raise_Hook       => null,
 345    --                    );
 346
 347    --  (protecting test only needed if not at library level)
 348    --
 349    --     exceptF : Boolean := True --  static data
 350    --     if exceptF then
 351    --        exceptF := False;
 352    --        Register_Exception (except'Unchecked_Access);
 353    --     end if;
 354
 355    procedure Expand_N_Exception_Declaration (N : Node_Id) is
 356       Loc     : constant Source_Ptr := Sloc (N);
 357       Id      : constant Entity_Id  := Defining_Identifier (N);
 358       L       : List_Id             := New_List;
 359       Flag_Id : Entity_Id;
 360
 361       Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
 362       Exname      : constant Node_Id :=
 363                       Make_Defining_Identifier (Loc, Name_Exname);
 364
 365    begin
 366       --  There is no expansion needed when compiling for the JVM since the
 367       --  JVM has a built-in exception mechanism. See 4jexcept.ads for details.
 368
 369       if Hostparm.Java_VM then
 370          return;
 371       end if;
 372
 373       --  Definition of the external name: nam : constant String := "A.B.NAME";
 374
 375       Insert_Action (N,
 376         Make_Object_Declaration (Loc,
 377           Defining_Identifier => Exname,
 378           Constant_Present    => True,
 379           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 380           Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
 381
 382       Set_Is_Statically_Allocated (Exname);
 383
 384       --  Create the aggregate list for type Standard.Exception_Type:
 385       --  Handled_By_Other component: False
 386
 387       Append_To (L, New_Occurrence_Of (Standard_False, Loc));
 388
 389       --  Lang component: 'A'
 390
 391       Append_To (L,
 392         Make_Character_Literal (Loc,
 393           Chars              =>  Name_uA,
 394           Char_Literal_Value =>  UI_From_Int (Character'Pos ('A'))));
 395
 396       --  Name_Length component: Nam'Length
 397
 398       Append_To (L,
 399         Make_Attribute_Reference (Loc,
 400           Prefix         => New_Occurrence_Of (Exname, Loc),
 401           Attribute_Name => Name_Length));
 402
 403       --  Full_Name component: Standard.A_Char!(Nam'Address)
 404
 405       Append_To (L, Unchecked_Convert_To (Standard_A_Char,
 406         Make_Attribute_Reference (Loc,
 407           Prefix         => New_Occurrence_Of (Exname, Loc),
 408           Attribute_Name => Name_Address)));
 409
 410       --  HTable_Ptr component: null
 411
 412       Append_To (L, Make_Null (Loc));
 413
 414       --  Import_Code component: 0
 415
 416       Append_To (L, Make_Integer_Literal (Loc, 0));
 417
 418       --  Raise_Hook component: null
 419
 420       Append_To (L, Make_Null (Loc));
 421
 422       Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
 423       Analyze_And_Resolve (Expression (N), Etype (Id));
 424
 425       --  Register_Exception (except'Unchecked_Access);
 426
 427       if not Restriction_Active (No_Exception_Handlers)
 428         and then not Restriction_Active (No_Exception_Registration)
 429       then
 430          L := New_List (
 431                 Make_Procedure_Call_Statement (Loc,
 432                   Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
 433                   Parameter_Associations => New_List (
 434                     Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
 435                       Make_Attribute_Reference (Loc,
 436                         Prefix         => New_Occurrence_Of (Id, Loc),
 437                         Attribute_Name => Name_Unrestricted_Access)))));
 438
 439          Set_Register_Exception_Call (Id, First (L));
 440
 441          if not Is_Library_Level_Entity (Id) then
 442             Flag_Id :=  Make_Defining_Identifier (Loc,
 443                           New_External_Name (Chars (Id), 'F'));
 444
 445             Insert_Action (N,
 446               Make_Object_Declaration (Loc,
 447                 Defining_Identifier => Flag_Id,
 448                 Object_Definition   =>
 449                   New_Occurrence_Of (Standard_Boolean, Loc),
 450                 Expression          =>
 451                   New_Occurrence_Of (Standard_True, Loc)));
 452
 453             Set_Is_Statically_Allocated (Flag_Id);
 454
 455             Append_To (L,
 456               Make_Assignment_Statement (Loc,
 457                 Name       => New_Occurrence_Of (Flag_Id, Loc),
 458                 Expression => New_Occurrence_Of (Standard_False, Loc)));
 459
 460             Insert_After_And_Analyze (N,
 461               Make_Implicit_If_Statement (N,
 462                 Condition       => New_Occurrence_Of (Flag_Id, Loc),
 463                 Then_Statements => L));
 464
 465          else
 466             Insert_List_After_And_Analyze (N, L);
 467          end if;
 468       end if;
 469
 470    end Expand_N_Exception_Declaration;
 471
 472    ---------------------------------------------
 473    -- Expand_N_Handled_Sequence_Of_Statements --
 474    ---------------------------------------------
 475
 476    procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
 477    begin
 478       if Present (Exception_Handlers (N))
 479         and then not Restriction_Active (No_Exception_Handlers)
 480       then
 481          Expand_Exception_Handlers (N);
 482       end if;
 483
 484       --  The following code needs comments ???
 485
 486       if Nkind (Parent (N)) /= N_Package_Body
 487         and then Nkind (Parent (N)) /= N_Accept_Statement
 488         and then Nkind (Parent (N)) /= N_Extended_Return_Statement
 489         and then not Delay_Cleanups (Current_Scope)
 490       then
 491          Expand_Cleanup_Actions (Parent (N));
 492       else
 493          Set_First_Real_Statement (N, First (Statements (N)));
 494       end if;
 495
 496    end Expand_N_Handled_Sequence_Of_Statements;
 497
 498    -------------------------------------
 499    -- Expand_N_Raise_Constraint_Error --
 500    -------------------------------------
 501
 502    --  The only processing required is to adjust the condition to deal
 503    --  with the C/Fortran boolean case. This may well not be necessary,
 504    --  as all such conditions are generated by the expander and probably
 505    --  are all standard boolean, but who knows what strange optimization
 506    --  in future may require this adjustment!
 507
 508    procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
 509    begin
 510       Adjust_Condition (Condition (N));
 511    end Expand_N_Raise_Constraint_Error;
 512
 513    ----------------------------------
 514    -- Expand_N_Raise_Program_Error --
 515    ----------------------------------
 516
 517    --  The only processing required is to adjust the condition to deal
 518    --  with the C/Fortran boolean case. This may well not be necessary,
 519    --  as all such conditions are generated by the expander and probably
 520    --  are all standard boolean, but who knows what strange optimization
 521    --  in future may require this adjustment!
 522
 523    procedure Expand_N_Raise_Program_Error (N : Node_Id) is
 524    begin
 525       Adjust_Condition (Condition (N));
 526    end Expand_N_Raise_Program_Error;
 527
 528    ------------------------------
 529    -- Expand_N_Raise_Statement --
 530    ------------------------------
 531
 532    procedure Expand_N_Raise_Statement (N : Node_Id) is
 533       Loc   : constant Source_Ptr := Sloc (N);
 534       Ehand : Node_Id;
 535       E     : Entity_Id;
 536       Str   : String_Id;
 537
 538    begin
 539       --  If a string expression is present, then the raise statement is
 540       --  converted to a call:
 541
 542       --     Raise_Exception (exception-name'Identity, string);
 543
 544       --  and there is nothing else to do
 545
 546       if Present (Expression (N)) then
 547          Rewrite (N,
 548            Make_Procedure_Call_Statement (Loc,
 549              Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
 550              Parameter_Associations => New_List (
 551                Make_Attribute_Reference (Loc,
 552                  Prefix => Name (N),
 553                  Attribute_Name => Name_Identity),
 554                Expression (N))));
 555          Analyze (N);
 556          return;
 557       end if;
 558
 559       --  Remaining processing is for the case where no string expression
 560       --  is present.
 561
 562       --  There is no expansion needed for statement "raise <exception>;" when
 563       --  compiling for the JVM since the JVM has a built-in exception
 564       --  mechanism. However we need the keep the expansion for "raise;"
 565       --  statements. See 4jexcept.ads for details.
 566
 567       if Present (Name (N)) and then Hostparm.Java_VM then
 568          return;
 569       end if;
 570
 571       --  Don't expand a raise statement that does not come from source
 572       --  if we have already had configurable run-time violations, since
 573       --  most likely it will be junk cascaded nonsense.
 574
 575       if Configurable_Run_Time_Violations > 0
 576         and then not Comes_From_Source (N)
 577       then
 578          return;
 579       end if;
 580
 581       --  Convert explicit raise of Program_Error, Constraint_Error, and
 582       --  Storage_Error into the corresponding raise (in High_Integrity_Mode
 583       --  all other raises will get normal expansion and be disallowed,
 584       --  but this is also faster in all modes).
 585
 586       if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
 587          if Entity (Name (N)) = Standard_Constraint_Error then
 588             Rewrite (N,
 589               Make_Raise_Constraint_Error (Loc,
 590                 Reason => CE_Explicit_Raise));
 591             Analyze (N);
 592             return;
 593
 594          elsif Entity (Name (N)) = Standard_Program_Error then
 595             Rewrite (N,
 596               Make_Raise_Program_Error (Loc,
 597                 Reason => PE_Explicit_Raise));
 598             Analyze (N);
 599             return;
 600
 601          elsif Entity (Name (N)) = Standard_Storage_Error then
 602             Rewrite (N,
 603               Make_Raise_Storage_Error (Loc,
 604                 Reason => SE_Explicit_Raise));
 605             Analyze (N);
 606             return;
 607          end if;
 608       end if;
 609
 610       --  Case of name present, in this case we expand raise name to
 611
 612       --    Raise_Exception (name'Identity, location_string);
 613
 614       --  where location_string identifies the file/line of the raise
 615
 616       if Present (Name (N)) then
 617          declare
 618             Id : Entity_Id := Entity (Name (N));
 619
 620          begin
 621             Build_Location_String (Loc);
 622
 623             --  If the exception is a renaming, use the exception that it
 624             --  renames (which might be a predefined exception, e.g.).
 625
 626             if Present (Renamed_Object (Id)) then
 627                Id := Renamed_Object (Id);
 628             end if;
 629
 630             --  Build a C-compatible string in case of no exception handlers,
 631             --  since this is what the last chance handler is expecting.
 632
 633             if Restriction_Active (No_Exception_Handlers) then
 634
 635                --  Generate an empty message if configuration pragma
 636                --  Suppress_Exception_Locations is set for this unit.
 637
 638                if Opt.Exception_Locations_Suppressed then
 639                   Name_Len := 1;
 640                else
 641                   Name_Len := Name_Len + 1;
 642                end if;
 643
 644                Name_Buffer (Name_Len) := ASCII.NUL;
 645             end if;
 646
 647             if Opt.Exception_Locations_Suppressed then
 648                Name_Len := 0;
 649             end if;
 650
 651             Str := String_From_Name_Buffer;
 652
 653             --  For VMS exceptions, convert the raise into a call to
 654             --  lib$stop so it will be handled by __gnat_error_handler.
 655
 656             if Is_VMS_Exception (Id) then
 657                declare
 658                   Excep_Image : String_Id;
 659                   Cond        : Node_Id;
 660
 661                begin
 662                   if Present (Interface_Name (Id)) then
 663                      Excep_Image := Strval (Interface_Name (Id));
 664                   else
 665                      Get_Name_String (Chars (Id));
 666                      Set_All_Upper_Case;
 667                      Excep_Image := String_From_Name_Buffer;
 668                   end if;
 669
 670                   if Exception_Code (Id) /= No_Uint then
 671                      Cond :=
 672                        Make_Integer_Literal (Loc, Exception_Code (Id));
 673                   else
 674                      Cond :=
 675                        Unchecked_Convert_To (Standard_Integer,
 676                          Make_Function_Call (Loc,
 677                            Name => New_Occurrence_Of
 678                              (RTE (RE_Import_Value), Loc),
 679                            Parameter_Associations => New_List
 680                              (Make_String_Literal (Loc,
 681                                Strval => Excep_Image))));
 682                   end if;
 683
 684                   Rewrite (N,
 685                     Make_Procedure_Call_Statement (Loc,
 686                       Name =>
 687                         New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
 688                       Parameter_Associations => New_List (Cond)));
 689                         Analyze_And_Resolve (Cond, Standard_Integer);
 690                end;
 691
 692             --  Not VMS exception case, convert raise to call to the
 693             --  Raise_Exception routine.
 694
 695             else
 696                Rewrite (N,
 697                  Make_Procedure_Call_Statement (Loc,
 698                     Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
 699                     Parameter_Associations => New_List (
 700                       Make_Attribute_Reference (Loc,
 701                         Prefix => Name (N),
 702                         Attribute_Name => Name_Identity),
 703                       Make_String_Literal (Loc,
 704                         Strval => Str))));
 705             end if;
 706          end;
 707
 708       --  Case of no name present (reraise). We rewrite the raise to:
 709
 710       --    Reraise_Occurrence_Always (EO);
 711
 712       --  where EO is the current exception occurrence. If the current handler
 713       --  does not have a choice parameter specification, then we provide one.
 714
 715       else
 716          --  Find innermost enclosing exception handler (there must be one,
 717          --  since the semantics has already verified that this raise statement
 718          --  is valid, and a raise with no arguments is only permitted in the
 719          --  context of an exception handler.
 720
 721          Ehand := Parent (N);
 722          while Nkind (Ehand) /= N_Exception_Handler loop
 723             Ehand := Parent (Ehand);
 724          end loop;
 725
 726          --  Make exception choice parameter if none present. Note that we do
 727          --  not need to put the entity on the entity chain, since no one will
 728          --  be referencing this entity by normal visibility methods.
 729
 730          if No (Choice_Parameter (Ehand)) then
 731             E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
 732             Set_Choice_Parameter (Ehand, E);
 733             Set_Ekind (E, E_Variable);
 734             Set_Etype (E, RTE (RE_Exception_Occurrence));
 735             Set_Scope (E, Current_Scope);
 736          end if;
 737
 738          --  Now rewrite the raise as a call to Reraise. A special case arises
 739          --  if this raise statement occurs in the context of a handler for
 740          --  all others (i.e. an at end handler). in this case we avoid
 741          --  the call to defer abort, cleanup routines are expected to be
 742          --  called in this case with aborts deferred.
 743
 744          declare
 745             Ech : constant Node_Id := First (Exception_Choices (Ehand));
 746             Ent : Entity_Id;
 747
 748          begin
 749             if Nkind (Ech) = N_Others_Choice
 750               and then All_Others (Ech)
 751             then
 752                Ent := RTE (RE_Reraise_Occurrence_No_Defer);
 753             else
 754                Ent := RTE (RE_Reraise_Occurrence_Always);
 755             end if;
 756
 757             Rewrite (N,
 758               Make_Procedure_Call_Statement (Loc,
 759                 Name => New_Occurrence_Of (Ent, Loc),
 760                 Parameter_Associations => New_List (
 761                   New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
 762          end;
 763       end if;
 764
 765       Analyze (N);
 766    end Expand_N_Raise_Statement;
 767
 768    ----------------------------------
 769    -- Expand_N_Raise_Storage_Error --
 770    ----------------------------------
 771
 772    --  The only processing required is to adjust the condition to deal
 773    --  with the C/Fortran boolean case. This may well not be necessary,
 774    --  as all such conditions are generated by the expander and probably
 775    --  are all standard boolean, but who knows what strange optimization
 776    --  in future may require this adjustment!
 777
 778    procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
 779    begin
 780       Adjust_Condition (Condition (N));
 781    end Expand_N_Raise_Storage_Error;
 782
 783    ------------------------------
 784    -- Expand_N_Subprogram_Info --
 785    ------------------------------
 786
 787    procedure Expand_N_Subprogram_Info (N : Node_Id) is
 788       Loc : constant Source_Ptr := Sloc (N);
 789
 790    begin
 791       --  For now, we replace an Expand_N_Subprogram_Info node with an
 792       --  attribute reference that gives the address of the procedure.
 793       --  This is because gigi does not yet recognize this node, and
 794       --  for the initial targets, this is the right value anyway.
 795
 796       Rewrite (N,
 797         Make_Attribute_Reference (Loc,
 798           Prefix => Identifier (N),
 799           Attribute_Name => Name_Code_Address));
 800
 801       Analyze_And_Resolve (N, RTE (RE_Code_Loc));
 802    end Expand_N_Subprogram_Info;
 803
 804    ----------------------
 805    -- Is_Non_Ada_Error --
 806    ----------------------
 807
 808    function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
 809    begin
 810       if not OpenVMS_On_Target then
 811          return False;
 812       end if;
 813
 814       Get_Name_String (Chars (E));
 815
 816       --  Note: it is a little irregular for the body of exp_ch11 to know
 817       --  the details of the encoding scheme for names, but on the other
 818       --  hand, gigi knows them, and this is for gigi's benefit anyway!
 819
 820       if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
 821          return False;
 822       end if;
 823
 824       return True;
 825    end Is_Non_Ada_Error;
 826
 827 end Exp_Ch11;