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