gcc/ada/tbuild.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               T B U I L D                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Csets;    use Csets;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Lib;      use Lib;
  31 with Nlists;   use Nlists;
  32 with Nmake;    use Nmake;
  33 with Opt;      use Opt;
  34 with Restrict; use Restrict;
  35 with Rident;   use Rident;
  36 with Sem_Aux;  use Sem_Aux;
  37 with Snames;   use Snames;
  38 with Stand;    use Stand;
  39 with Stringt;  use Stringt;
  40 with Urealp;   use Urealp;
  41
  42 package body Tbuild is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Add_Unique_Serial_Number;
  49    --  Add a unique serialization to the string in the Name_Buffer. This
  50    --  consists of a unit specific serial number, and b/s for body/spec.
  51
  52    ------------------------------
  53    -- Add_Unique_Serial_Number --
  54    ------------------------------
  55
  56    Config_Serial_Number : Nat := 0;
  57    --  Counter for use in config pragmas, see comment below
  58
  59    procedure Add_Unique_Serial_Number is
  60    begin
  61       --  If we are analyzing configuration pragmas, Cunit (Main_Unit) will
  62       --  not be set yet. This happens for example when analyzing static
  63       --  string expressions in configuration pragmas. For this case, we
  64       --  just maintain a local counter, defined above and we do not need
  65       --  to add a b or s indication in this case.
  66
  67       if No (Cunit (Current_Sem_Unit)) then
  68          Config_Serial_Number := Config_Serial_Number + 1;
  69          Add_Nat_To_Name_Buffer (Config_Serial_Number);
  70          return;
  71
  72       --  Normal case, within a unit
  73
  74       else
  75          declare
  76             Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
  77
  78          begin
  79             Add_Nat_To_Name_Buffer (Increment_Serial_Number);
  80
  81             --  Add either b or s, depending on whether current unit is a spec
  82             --  or a body. This is needed because we may generate the same name
  83             --  in a spec and a body otherwise.
  84
  85             Name_Len := Name_Len + 1;
  86
  87             if Nkind (Unit_Node) = N_Package_Declaration
  88               or else Nkind (Unit_Node) = N_Subprogram_Declaration
  89               or else Nkind (Unit_Node) in N_Generic_Declaration
  90             then
  91                Name_Buffer (Name_Len) := 's';
  92             else
  93                Name_Buffer (Name_Len) := 'b';
  94             end if;
  95          end;
  96       end if;
  97    end Add_Unique_Serial_Number;
  98
  99    ----------------
 100    -- Checks_Off --
 101    ----------------
 102
 103    function Checks_Off (N : Node_Id) return Node_Id is
 104    begin
 105       return
 106         Make_Unchecked_Expression (Sloc (N),
 107           Expression => N);
 108    end Checks_Off;
 109
 110    ----------------
 111    -- Convert_To --
 112    ----------------
 113
 114    function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 115       Result : Node_Id;
 116
 117    begin
 118       if Present (Etype (Expr))
 119         and then (Etype (Expr)) = Typ
 120       then
 121          return Relocate_Node (Expr);
 122       else
 123          Result :=
 124            Make_Type_Conversion (Sloc (Expr),
 125              Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 126              Expression => Relocate_Node (Expr));
 127
 128          Set_Etype (Result, Typ);
 129          return Result;
 130       end if;
 131    end Convert_To;
 132
 133    ----------------------------
 134    -- Convert_To_And_Rewrite --
 135    ----------------------------
 136
 137    procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id) is
 138    begin
 139       Rewrite (Expr, Convert_To (Typ, Expr));
 140    end Convert_To_And_Rewrite;
 141
 142    ------------------
 143    -- Discard_List --
 144    ------------------
 145
 146    procedure Discard_List (L : List_Id) is
 147       pragma Warnings (Off, L);
 148    begin
 149       null;
 150    end Discard_List;
 151
 152    ------------------
 153    -- Discard_Node --
 154    ------------------
 155
 156    procedure Discard_Node (N : Node_Or_Entity_Id) is
 157       pragma Warnings (Off, N);
 158    begin
 159       null;
 160    end Discard_Node;
 161
 162    -------------------------------------------
 163    -- Make_Byte_Aligned_Attribute_Reference --
 164    -------------------------------------------
 165
 166    function Make_Byte_Aligned_Attribute_Reference
 167      (Sloc           : Source_Ptr;
 168       Prefix         : Node_Id;
 169       Attribute_Name : Name_Id)
 170       return           Node_Id
 171    is
 172       N : constant Node_Id :=
 173             Make_Attribute_Reference (Sloc,
 174               Prefix        => Prefix,
 175               Attribute_Name => Attribute_Name);
 176
 177    begin
 178       pragma Assert (Nam_In (Attribute_Name, Name_Address,
 179                                              Name_Unrestricted_Access));
 180       Set_Must_Be_Byte_Aligned (N, True);
 181       return N;
 182    end Make_Byte_Aligned_Attribute_Reference;
 183
 184    --------------------
 185    -- Make_DT_Access --
 186    --------------------
 187
 188    function Make_DT_Access
 189      (Loc : Source_Ptr;
 190       Rec : Node_Id;
 191       Typ : Entity_Id) return Node_Id
 192    is
 193       Full_Type : Entity_Id := Typ;
 194
 195    begin
 196       if Is_Private_Type (Typ) then
 197          Full_Type := Underlying_Type (Typ);
 198       end if;
 199
 200       return
 201         Unchecked_Convert_To (
 202           New_Occurrence_Of
 203             (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
 204           Make_Selected_Component (Loc,
 205             Prefix => New_Copy (Rec),
 206             Selector_Name =>
 207               New_Occurrence_Of (First_Tag_Component (Full_Type), Loc)));
 208    end Make_DT_Access;
 209
 210    ------------------------
 211    -- Make_Float_Literal --
 212    ------------------------
 213
 214    function Make_Float_Literal
 215      (Loc         : Source_Ptr;
 216       Radix       : Uint;
 217       Significand : Uint;
 218       Exponent    : Uint) return Node_Id
 219    is
 220    begin
 221       if Radix = 2 and then abs Significand /= 1 then
 222          return
 223            Make_Float_Literal
 224              (Loc, Uint_16,
 225               Significand * Radix**(Exponent mod 4),
 226               Exponent / 4);
 227
 228       else
 229          declare
 230             N : constant Node_Id := New_Node (N_Real_Literal, Loc);
 231
 232          begin
 233             Set_Realval (N,
 234               UR_From_Components
 235                 (Num      => abs Significand,
 236                  Den      => -Exponent,
 237                  Rbase    => UI_To_Int (Radix),
 238                  Negative => Significand < 0));
 239             return N;
 240          end;
 241       end if;
 242    end Make_Float_Literal;
 243
 244    -------------
 245    -- Make_Id --
 246    -------------
 247
 248    function Make_Id (Str : Text_Buffer) return Node_Id is
 249    begin
 250       Name_Len := 0;
 251
 252       for J in Str'Range loop
 253          Name_Len := Name_Len + 1;
 254          Name_Buffer (Name_Len) := Fold_Lower (Str (J));
 255       end loop;
 256
 257       return
 258         Make_Identifier (System_Location,
 259           Chars => Name_Find);
 260    end Make_Id;
 261
 262    -------------------------------------
 263    -- Make_Implicit_Exception_Handler --
 264    -------------------------------------
 265
 266    function Make_Implicit_Exception_Handler
 267      (Sloc              : Source_Ptr;
 268       Choice_Parameter  : Node_Id := Empty;
 269       Exception_Choices : List_Id;
 270       Statements        : List_Id) return Node_Id
 271    is
 272       Handler : Node_Id;
 273       Loc     : Source_Ptr;
 274
 275    begin
 276       --  Set the source location only when debugging the expanded code
 277
 278       --  When debugging the source code directly, we do not want the compiler
 279       --  to associate this implicit exception handler with any specific source
 280       --  line, because it can potentially confuse the debugger. The most
 281       --  damaging situation would arise when the debugger tries to insert a
 282       --  breakpoint at a certain line. If the code of the associated implicit
 283       --  exception handler is generated before the code of that line, then the
 284       --  debugger will end up inserting the breakpoint inside the exception
 285       --  handler, rather than the code the user intended to break on. As a
 286       --  result, it is likely that the program will not hit the breakpoint
 287       --  as expected.
 288
 289       if Debug_Generated_Code then
 290          Loc := Sloc;
 291       else
 292          Loc := No_Location;
 293       end if;
 294
 295       Handler :=
 296         Make_Exception_Handler
 297           (Loc, Choice_Parameter, Exception_Choices, Statements);
 298       Set_Local_Raise_Statements (Handler, No_Elist);
 299       return Handler;
 300    end Make_Implicit_Exception_Handler;
 301
 302    --------------------------------
 303    -- Make_Implicit_If_Statement --
 304    --------------------------------
 305
 306    function Make_Implicit_If_Statement
 307      (Node            : Node_Id;
 308       Condition       : Node_Id;
 309       Then_Statements : List_Id;
 310       Elsif_Parts     : List_Id := No_List;
 311       Else_Statements : List_Id := No_List) return Node_Id
 312    is
 313    begin
 314       Check_Restriction (No_Implicit_Conditionals, Node);
 315
 316       return Make_If_Statement (Sloc (Node),
 317         Condition,
 318         Then_Statements,
 319         Elsif_Parts,
 320         Else_Statements);
 321    end Make_Implicit_If_Statement;
 322
 323    -------------------------------------
 324    -- Make_Implicit_Label_Declaration --
 325    -------------------------------------
 326
 327    function Make_Implicit_Label_Declaration
 328      (Loc                 : Source_Ptr;
 329       Defining_Identifier : Node_Id;
 330       Label_Construct     : Node_Id) return Node_Id
 331    is
 332       N : constant Node_Id :=
 333             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 334    begin
 335       Set_Label_Construct (N, Label_Construct);
 336       return N;
 337    end Make_Implicit_Label_Declaration;
 338
 339    ----------------------------------
 340    -- Make_Implicit_Loop_Statement --
 341    ----------------------------------
 342
 343    function Make_Implicit_Loop_Statement
 344      (Node                   : Node_Id;
 345       Statements             : List_Id;
 346       Identifier             : Node_Id := Empty;
 347       Iteration_Scheme       : Node_Id := Empty;
 348       Has_Created_Identifier : Boolean := False;
 349       End_Label              : Node_Id := Empty) return Node_Id
 350    is
 351    begin
 352       Check_Restriction (No_Implicit_Loops, Node);
 353
 354       if Present (Iteration_Scheme)
 355         and then Present (Condition (Iteration_Scheme))
 356       then
 357          Check_Restriction (No_Implicit_Conditionals, Node);
 358       end if;
 359
 360       return Make_Loop_Statement (Sloc (Node),
 361         Identifier             => Identifier,
 362         Iteration_Scheme       => Iteration_Scheme,
 363         Statements             => Statements,
 364         Has_Created_Identifier => Has_Created_Identifier,
 365         End_Label              => End_Label);
 366    end Make_Implicit_Loop_Statement;
 367
 368    --------------------------
 369    -- Make_Integer_Literal --
 370    ---------------------------
 371
 372    function Make_Integer_Literal
 373      (Loc    : Source_Ptr;
 374       Intval : Int) return Node_Id
 375    is
 376    begin
 377       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 378    end Make_Integer_Literal;
 379
 380    --------------------------------
 381    -- Make_Linker_Section_Pragma --
 382    --------------------------------
 383
 384    function Make_Linker_Section_Pragma
 385      (Ent : Entity_Id;
 386       Loc : Source_Ptr;
 387       Sec : String) return Node_Id
 388    is
 389       LS : Node_Id;
 390
 391    begin
 392       LS :=
 393         Make_Pragma
 394           (Loc,
 395            Name_Linker_Section,
 396            New_List
 397              (Make_Pragma_Argument_Association
 398                 (Sloc => Loc,
 399                  Expression => New_Occurrence_Of (Ent, Loc)),
 400               Make_Pragma_Argument_Association
 401                 (Sloc => Loc,
 402                  Expression =>
 403                    Make_String_Literal
 404                      (Sloc => Loc,
 405                       Strval => Sec))));
 406
 407       Set_Has_Gigi_Rep_Item (Ent);
 408       return LS;
 409    end Make_Linker_Section_Pragma;
 410
 411    -----------------
 412    -- Make_Pragma --
 413    -----------------
 414
 415    function Make_Pragma
 416      (Sloc                         : Source_Ptr;
 417       Chars                        : Name_Id;
 418       Pragma_Argument_Associations : List_Id := No_List) return Node_Id
 419    is
 420    begin
 421       return
 422         Make_Pragma (Sloc,
 423           Pragma_Argument_Associations => Pragma_Argument_Associations,
 424           Pragma_Identifier            => Make_Identifier (Sloc, Chars));
 425    end Make_Pragma;
 426
 427    ---------------------------------
 428    -- Make_Raise_Constraint_Error --
 429    ---------------------------------
 430
 431    function Make_Raise_Constraint_Error
 432      (Sloc      : Source_Ptr;
 433       Condition : Node_Id := Empty;
 434       Reason    : RT_Exception_Code) return Node_Id
 435    is
 436    begin
 437       pragma Assert (Rkind (Reason) = CE_Reason);
 438       return
 439         Make_Raise_Constraint_Error (Sloc,
 440           Condition => Condition,
 441           Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
 442    end Make_Raise_Constraint_Error;
 443
 444    ------------------------------
 445    -- Make_Raise_Program_Error --
 446    ------------------------------
 447
 448    function Make_Raise_Program_Error
 449      (Sloc      : Source_Ptr;
 450       Condition : Node_Id := Empty;
 451       Reason    : RT_Exception_Code) return Node_Id
 452    is
 453    begin
 454       pragma Assert (Rkind (Reason) = PE_Reason);
 455       return
 456         Make_Raise_Program_Error (Sloc,
 457           Condition => Condition,
 458           Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
 459    end Make_Raise_Program_Error;
 460
 461    ------------------------------
 462    -- Make_Raise_Storage_Error --
 463    ------------------------------
 464
 465    function Make_Raise_Storage_Error
 466      (Sloc      : Source_Ptr;
 467       Condition : Node_Id := Empty;
 468       Reason    : RT_Exception_Code) return Node_Id
 469    is
 470    begin
 471       pragma Assert (Rkind (Reason) = SE_Reason);
 472       return
 473         Make_Raise_Storage_Error (Sloc,
 474           Condition => Condition,
 475           Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
 476    end Make_Raise_Storage_Error;
 477
 478    -------------
 479    -- Make_SC --
 480    -------------
 481
 482    function  Make_SC (Pre, Sel : Node_Id) return Node_Id is
 483    begin
 484       return
 485         Make_Selected_Component (System_Location,
 486           Prefix        => Pre,
 487           Selector_Name => Sel);
 488    end Make_SC;
 489
 490    -------------------------
 491    -- Make_String_Literal --
 492    -------------------------
 493
 494    function Make_String_Literal
 495      (Sloc   : Source_Ptr;
 496       Strval : String) return Node_Id
 497    is
 498    begin
 499       Start_String;
 500       Store_String_Chars (Strval);
 501       return Make_String_Literal (Sloc, Strval => End_String);
 502    end Make_String_Literal;
 503
 504    --------------------
 505    -- Make_Temporary --
 506    --------------------
 507
 508    function Make_Temporary
 509      (Loc          : Source_Ptr;
 510       Id           : Character;
 511       Related_Node : Node_Id := Empty) return Entity_Id
 512    is
 513       Temp : constant Entity_Id :=
 514                Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id));
 515    begin
 516       Set_Related_Expression (Temp, Related_Node);
 517       return Temp;
 518    end Make_Temporary;
 519
 520    ---------------------------
 521    -- Make_Unsuppress_Block --
 522    ---------------------------
 523
 524    --  Generates the following expansion:
 525
 526    --    declare
 527    --       pragma Suppress (<check>);
 528    --    begin
 529    --       <stmts>
 530    --    end;
 531
 532    function Make_Unsuppress_Block
 533      (Loc   : Source_Ptr;
 534       Check : Name_Id;
 535       Stmts : List_Id) return Node_Id
 536    is
 537    begin
 538       return
 539         Make_Block_Statement (Loc,
 540           Declarations => New_List (
 541             Make_Pragma (Loc,
 542               Chars => Name_Suppress,
 543               Pragma_Argument_Associations => New_List (
 544                 Make_Pragma_Argument_Association (Loc,
 545                   Expression => Make_Identifier (Loc, Check))))),
 546
 547           Handled_Statement_Sequence =>
 548             Make_Handled_Sequence_Of_Statements (Loc,
 549               Statements => Stmts));
 550    end Make_Unsuppress_Block;
 551
 552    --------------------------
 553    -- New_Constraint_Error --
 554    --------------------------
 555
 556    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 557       Ident_Node : Node_Id;
 558       Raise_Node : Node_Id;
 559
 560    begin
 561       Ident_Node := New_Node (N_Identifier, Loc);
 562       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 563       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 564       Raise_Node := New_Node (N_Raise_Statement, Loc);
 565       Set_Name (Raise_Node, Ident_Node);
 566       return Raise_Node;
 567    end New_Constraint_Error;
 568
 569    -----------------------
 570    -- New_External_Name --
 571    -----------------------
 572
 573    function New_External_Name
 574      (Related_Id   : Name_Id;
 575       Suffix       : Character := ' ';
 576       Suffix_Index : Int       := 0;
 577       Prefix       : Character := ' ') return Name_Id
 578    is
 579    begin
 580       Get_Name_String (Related_Id);
 581
 582       if Prefix /= ' ' then
 583          pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
 584
 585          for J in reverse 1 .. Name_Len loop
 586             Name_Buffer (J + 1) := Name_Buffer (J);
 587          end loop;
 588
 589          Name_Len := Name_Len + 1;
 590          Name_Buffer (1) := Prefix;
 591       end if;
 592
 593       if Suffix /= ' ' then
 594          pragma Assert (Is_OK_Internal_Letter (Suffix));
 595          Add_Char_To_Name_Buffer (Suffix);
 596       end if;
 597
 598       if Suffix_Index /= 0 then
 599          if Suffix_Index < 0 then
 600             Add_Unique_Serial_Number;
 601          else
 602             Add_Nat_To_Name_Buffer (Suffix_Index);
 603          end if;
 604       end if;
 605
 606       return Name_Find;
 607    end New_External_Name;
 608
 609    function New_External_Name
 610      (Related_Id   : Name_Id;
 611       Suffix       : String;
 612       Suffix_Index : Int       := 0;
 613       Prefix       : Character := ' ') return Name_Id
 614    is
 615    begin
 616       Get_Name_String (Related_Id);
 617
 618       if Prefix /= ' ' then
 619          pragma Assert (Is_OK_Internal_Letter (Prefix));
 620
 621          for J in reverse 1 .. Name_Len loop
 622             Name_Buffer (J + 1) := Name_Buffer (J);
 623          end loop;
 624
 625          Name_Len := Name_Len + 1;
 626          Name_Buffer (1) := Prefix;
 627       end if;
 628
 629       if Suffix /= "" then
 630          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 631          Name_Len := Name_Len + Suffix'Length;
 632       end if;
 633
 634       if Suffix_Index /= 0 then
 635          if Suffix_Index < 0 then
 636             Add_Unique_Serial_Number;
 637          else
 638             Add_Nat_To_Name_Buffer (Suffix_Index);
 639          end if;
 640       end if;
 641
 642       return Name_Find;
 643    end New_External_Name;
 644
 645    function New_External_Name
 646      (Suffix       : Character;
 647       Suffix_Index : Nat) return Name_Id
 648    is
 649    begin
 650       Name_Buffer (1) := Suffix;
 651       Name_Len := 1;
 652       Add_Nat_To_Name_Buffer (Suffix_Index);
 653       return Name_Find;
 654    end New_External_Name;
 655
 656    -----------------------
 657    -- New_Internal_Name --
 658    -----------------------
 659
 660    function New_Internal_Name (Id_Char : Character) return Name_Id is
 661    begin
 662       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 663       Name_Buffer (1) := Id_Char;
 664       Name_Len := 1;
 665       Add_Unique_Serial_Number;
 666       return Name_Enter;
 667    end New_Internal_Name;
 668
 669    -----------------------
 670    -- New_Occurrence_Of --
 671    -----------------------
 672
 673    function New_Occurrence_Of
 674      (Def_Id : Entity_Id;
 675       Loc    : Source_Ptr) return Node_Id
 676    is
 677       pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity);
 678       Occurrence : Node_Id;
 679
 680    begin
 681       Occurrence := New_Node (N_Identifier, Loc);
 682       Set_Chars (Occurrence, Chars (Def_Id));
 683       Set_Entity (Occurrence, Def_Id);
 684
 685       if Is_Type (Def_Id) then
 686          Set_Etype (Occurrence, Def_Id);
 687       else
 688          Set_Etype (Occurrence, Etype (Def_Id));
 689       end if;
 690
 691       if Ekind (Def_Id) = E_Enumeration_Literal then
 692          Set_Is_Static_Expression (Occurrence, True);
 693       end if;
 694
 695       return Occurrence;
 696    end New_Occurrence_Of;
 697
 698    -----------------
 699    -- New_Op_Node --
 700    -----------------
 701
 702    function New_Op_Node
 703      (New_Node_Kind : Node_Kind;
 704       New_Sloc      : Source_Ptr) return Node_Id
 705    is
 706       type Name_Of_Type is array (N_Op) of Name_Id;
 707       Name_Of : constant Name_Of_Type := Name_Of_Type'(
 708          N_Op_And                    => Name_Op_And,
 709          N_Op_Or                     => Name_Op_Or,
 710          N_Op_Xor                    => Name_Op_Xor,
 711          N_Op_Eq                     => Name_Op_Eq,
 712          N_Op_Ne                     => Name_Op_Ne,
 713          N_Op_Lt                     => Name_Op_Lt,
 714          N_Op_Le                     => Name_Op_Le,
 715          N_Op_Gt                     => Name_Op_Gt,
 716          N_Op_Ge                     => Name_Op_Ge,
 717          N_Op_Add                    => Name_Op_Add,
 718          N_Op_Subtract               => Name_Op_Subtract,
 719          N_Op_Concat                 => Name_Op_Concat,
 720          N_Op_Multiply               => Name_Op_Multiply,
 721          N_Op_Divide                 => Name_Op_Divide,
 722          N_Op_Mod                    => Name_Op_Mod,
 723          N_Op_Rem                    => Name_Op_Rem,
 724          N_Op_Expon                  => Name_Op_Expon,
 725          N_Op_Plus                   => Name_Op_Add,
 726          N_Op_Minus                  => Name_Op_Subtract,
 727          N_Op_Abs                    => Name_Op_Abs,
 728          N_Op_Not                    => Name_Op_Not,
 729
 730          --  We don't really need these shift operators, since they never
 731          --  appear as operators in the source, but the path of least
 732          --  resistance is to put them in (the aggregate must be complete).
 733
 734          N_Op_Rotate_Left            => Name_Rotate_Left,
 735          N_Op_Rotate_Right           => Name_Rotate_Right,
 736          N_Op_Shift_Left             => Name_Shift_Left,
 737          N_Op_Shift_Right            => Name_Shift_Right,
 738          N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
 739
 740       Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
 741
 742    begin
 743       if New_Node_Kind in Name_Of'Range then
 744          Set_Chars (Nod, Name_Of (New_Node_Kind));
 745       end if;
 746
 747       return Nod;
 748    end New_Op_Node;
 749
 750    -----------------------
 751    -- New_Suffixed_Name --
 752    -----------------------
 753
 754    function New_Suffixed_Name
 755      (Related_Id : Name_Id;
 756       Suffix     : String) return Name_Id
 757    is
 758    begin
 759       Get_Name_String (Related_Id);
 760       Add_Char_To_Name_Buffer ('_');
 761       Add_Str_To_Name_Buffer (Suffix);
 762       return Name_Find;
 763    end New_Suffixed_Name;
 764
 765    -------------------
 766    -- OK_Convert_To --
 767    -------------------
 768
 769    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 770       Result : Node_Id;
 771    begin
 772       Result :=
 773         Make_Type_Conversion (Sloc (Expr),
 774           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 775           Expression   => Relocate_Node (Expr));
 776       Set_Conversion_OK (Result, True);
 777       Set_Etype (Result, Typ);
 778       return Result;
 779    end OK_Convert_To;
 780
 781    -------------
 782    -- Set_RND --
 783    -------------
 784
 785    procedure Set_RND (Unit : Node_Id) is
 786    begin
 787       Set_Restriction_No_Dependence (Unit, Warn => False);
 788    end Set_RND;
 789
 790    --------------------------
 791    -- Unchecked_Convert_To --
 792    --------------------------
 793
 794    function Unchecked_Convert_To
 795      (Typ  : Entity_Id;
 796       Expr : Node_Id) return Node_Id
 797    is
 798       Loc         : constant Source_Ptr := Sloc (Expr);
 799       Result      : Node_Id;
 800       Expr_Parent : Node_Id;
 801
 802    begin
 803       --  If the expression is already of the correct type, then nothing
 804       --  to do, except for relocating the node in case this is required.
 805
 806       if Present (Etype (Expr))
 807         and then (Base_Type (Etype (Expr)) = Typ
 808                    or else Etype (Expr) = Typ)
 809       then
 810          return Relocate_Node (Expr);
 811
 812       --  Cases where the inner expression is itself an unchecked conversion
 813       --  to the same type, and we can thus eliminate the outer conversion.
 814
 815       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 816         and then Entity (Subtype_Mark (Expr)) = Typ
 817       then
 818          Result := Relocate_Node (Expr);
 819
 820       elsif Nkind (Expr) = N_Null
 821         and then Is_Access_Type (Typ)
 822       then
 823          --  No need for a conversion
 824
 825          Result := Relocate_Node (Expr);
 826
 827       --  All other cases
 828
 829       else
 830          --  Capture the parent of the expression before relocating it and
 831          --  creating the conversion, so the conversion's parent can be set
 832          --  to the original parent below.
 833
 834          Expr_Parent := Parent (Expr);
 835
 836          Result :=
 837            Make_Unchecked_Type_Conversion (Loc,
 838              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 839              Expression   => Relocate_Node (Expr));
 840
 841          Set_Parent (Result, Expr_Parent);
 842       end if;
 843
 844       Set_Etype (Result, Typ);
 845       return Result;
 846    end Unchecked_Convert_To;
 847
 848 end Tbuild;