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