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-2011, 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    -- Discard_List --
 134    ------------------
 135
 136    procedure Discard_List (L : List_Id) is
 137       pragma Warnings (Off, L);
 138    begin
 139       null;
 140    end Discard_List;
 141
 142    ------------------
 143    -- Discard_Node --
 144    ------------------
 145
 146    procedure Discard_Node (N : Node_Or_Entity_Id) is
 147       pragma Warnings (Off, N);
 148    begin
 149       null;
 150    end Discard_Node;
 151
 152    -------------------------------------------
 153    -- Make_Byte_Aligned_Attribute_Reference --
 154    -------------------------------------------
 155
 156    function Make_Byte_Aligned_Attribute_Reference
 157      (Sloc           : Source_Ptr;
 158       Prefix         : Node_Id;
 159       Attribute_Name : Name_Id)
 160       return           Node_Id
 161    is
 162       N : constant Node_Id :=
 163             Make_Attribute_Reference (Sloc,
 164               Prefix        => Prefix,
 165               Attribute_Name => Attribute_Name);
 166
 167    begin
 168       pragma Assert (Attribute_Name = Name_Address
 169                        or else
 170                      Attribute_Name = Name_Unrestricted_Access);
 171       Set_Must_Be_Byte_Aligned (N, True);
 172       return N;
 173    end Make_Byte_Aligned_Attribute_Reference;
 174
 175    --------------------
 176    -- Make_DT_Access --
 177    --------------------
 178
 179    function Make_DT_Access
 180      (Loc : Source_Ptr;
 181       Rec : Node_Id;
 182       Typ : Entity_Id) return Node_Id
 183    is
 184       Full_Type : Entity_Id := Typ;
 185
 186    begin
 187       if Is_Private_Type (Typ) then
 188          Full_Type := Underlying_Type (Typ);
 189       end if;
 190
 191       return
 192         Unchecked_Convert_To (
 193           New_Occurrence_Of
 194             (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
 195           Make_Selected_Component (Loc,
 196             Prefix => New_Copy (Rec),
 197             Selector_Name =>
 198               New_Reference_To (First_Tag_Component (Full_Type), Loc)));
 199    end Make_DT_Access;
 200
 201    ------------------------
 202    -- Make_Float_Literal --
 203    ------------------------
 204
 205    function Make_Float_Literal
 206      (Loc         : Source_Ptr;
 207       Radix       : Uint;
 208       Significand : Uint;
 209       Exponent    : Uint) return Node_Id
 210    is
 211    begin
 212       if Radix = 2 and then abs Significand /= 1 then
 213          return
 214            Make_Float_Literal
 215              (Loc, Uint_16,
 216               Significand * Radix**(Exponent mod 4),
 217               Exponent / 4);
 218
 219       else
 220          declare
 221             N : constant Node_Id := New_Node (N_Real_Literal, Loc);
 222
 223          begin
 224             Set_Realval (N,
 225               UR_From_Components
 226                 (Num      => abs Significand,
 227                  Den      => -Exponent,
 228                  Rbase    => UI_To_Int (Radix),
 229                  Negative => Significand < 0));
 230             return N;
 231          end;
 232       end if;
 233    end Make_Float_Literal;
 234
 235    -------------------------------------
 236    -- Make_Implicit_Exception_Handler --
 237    -------------------------------------
 238
 239    function Make_Implicit_Exception_Handler
 240      (Sloc              : Source_Ptr;
 241       Choice_Parameter  : Node_Id := Empty;
 242       Exception_Choices : List_Id;
 243       Statements        : List_Id) return Node_Id
 244    is
 245       Handler : Node_Id;
 246       Loc     : Source_Ptr;
 247
 248    begin
 249       --  Set the source location only when debugging the expanded code
 250
 251       --  When debugging the source code directly, we do not want the compiler
 252       --  to associate this implicit exception handler with any specific source
 253       --  line, because it can potentially confuse the debugger. The most
 254       --  damaging situation would arise when the debugger tries to insert a
 255       --  breakpoint at a certain line. If the code of the associated implicit
 256       --  exception handler is generated before the code of that line, then the
 257       --  debugger will end up inserting the breakpoint inside the exception
 258       --  handler, rather than the code the user intended to break on. As a
 259       --  result, it is likely that the program will not hit the breakpoint
 260       --  as expected.
 261
 262       if Debug_Generated_Code then
 263          Loc := Sloc;
 264       else
 265          Loc := No_Location;
 266       end if;
 267
 268       Handler :=
 269         Make_Exception_Handler
 270           (Loc, Choice_Parameter, Exception_Choices, Statements);
 271       Set_Local_Raise_Statements (Handler, No_Elist);
 272       return Handler;
 273    end Make_Implicit_Exception_Handler;
 274
 275    --------------------------------
 276    -- Make_Implicit_If_Statement --
 277    --------------------------------
 278
 279    function Make_Implicit_If_Statement
 280      (Node            : Node_Id;
 281       Condition       : Node_Id;
 282       Then_Statements : List_Id;
 283       Elsif_Parts     : List_Id := No_List;
 284       Else_Statements : List_Id := No_List) return Node_Id
 285    is
 286    begin
 287       Check_Restriction (No_Implicit_Conditionals, Node);
 288
 289       return Make_If_Statement (Sloc (Node),
 290         Condition,
 291         Then_Statements,
 292         Elsif_Parts,
 293         Else_Statements);
 294    end Make_Implicit_If_Statement;
 295
 296    -------------------------------------
 297    -- Make_Implicit_Label_Declaration --
 298    -------------------------------------
 299
 300    function Make_Implicit_Label_Declaration
 301      (Loc                 : Source_Ptr;
 302       Defining_Identifier : Node_Id;
 303       Label_Construct     : Node_Id) return Node_Id
 304    is
 305       N : constant Node_Id :=
 306             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 307    begin
 308       Set_Label_Construct (N, Label_Construct);
 309       return N;
 310    end Make_Implicit_Label_Declaration;
 311
 312    ----------------------------------
 313    -- Make_Implicit_Loop_Statement --
 314    ----------------------------------
 315
 316    function Make_Implicit_Loop_Statement
 317      (Node                   : Node_Id;
 318       Statements             : List_Id;
 319       Identifier             : Node_Id := Empty;
 320       Iteration_Scheme       : Node_Id := Empty;
 321       Has_Created_Identifier : Boolean := False;
 322       End_Label              : Node_Id := Empty) return Node_Id
 323    is
 324    begin
 325       Check_Restriction (No_Implicit_Loops, Node);
 326
 327       if Present (Iteration_Scheme)
 328         and then Present (Condition (Iteration_Scheme))
 329       then
 330          Check_Restriction (No_Implicit_Conditionals, Node);
 331       end if;
 332
 333       return Make_Loop_Statement (Sloc (Node),
 334         Identifier             => Identifier,
 335         Iteration_Scheme       => Iteration_Scheme,
 336         Statements             => Statements,
 337         Has_Created_Identifier => Has_Created_Identifier,
 338         End_Label              => End_Label);
 339    end Make_Implicit_Loop_Statement;
 340
 341    --------------------------
 342    -- Make_Integer_Literal --
 343    ---------------------------
 344
 345    function Make_Integer_Literal
 346      (Loc    : Source_Ptr;
 347       Intval : Int) return Node_Id
 348    is
 349    begin
 350       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 351    end Make_Integer_Literal;
 352
 353    --------------------------------
 354    -- Make_Linker_Section_Pragma --
 355    --------------------------------
 356
 357    function Make_Linker_Section_Pragma
 358      (Ent : Entity_Id;
 359       Loc : Source_Ptr;
 360       Sec : String) return Node_Id
 361    is
 362       LS : Node_Id;
 363
 364    begin
 365       LS :=
 366         Make_Pragma
 367           (Loc,
 368            Name_Linker_Section,
 369            New_List
 370              (Make_Pragma_Argument_Association
 371                 (Sloc => Loc,
 372                  Expression => New_Occurrence_Of (Ent, Loc)),
 373               Make_Pragma_Argument_Association
 374                 (Sloc => Loc,
 375                  Expression =>
 376                    Make_String_Literal
 377                      (Sloc => Loc,
 378                       Strval => Sec))));
 379
 380       Set_Has_Gigi_Rep_Item (Ent);
 381       return LS;
 382    end Make_Linker_Section_Pragma;
 383
 384    -----------------
 385    -- Make_Pragma --
 386    -----------------
 387
 388    function Make_Pragma
 389      (Sloc                         : Source_Ptr;
 390       Chars                        : Name_Id;
 391       Pragma_Argument_Associations : List_Id := No_List) return Node_Id
 392    is
 393    begin
 394       return
 395         Make_Pragma (Sloc,
 396           Pragma_Argument_Associations => Pragma_Argument_Associations,
 397           Pragma_Identifier            => Make_Identifier (Sloc, Chars));
 398    end Make_Pragma;
 399
 400    ---------------------------------
 401    -- Make_Raise_Constraint_Error --
 402    ---------------------------------
 403
 404    function Make_Raise_Constraint_Error
 405      (Sloc      : Source_Ptr;
 406       Condition : Node_Id := Empty;
 407       Reason    : RT_Exception_Code) return Node_Id
 408    is
 409    begin
 410       pragma Assert (Reason in RT_CE_Exceptions);
 411       return
 412         Make_Raise_Constraint_Error (Sloc,
 413           Condition => Condition,
 414           Reason =>
 415             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 416    end Make_Raise_Constraint_Error;
 417
 418    ------------------------------
 419    -- Make_Raise_Program_Error --
 420    ------------------------------
 421
 422    function Make_Raise_Program_Error
 423      (Sloc      : Source_Ptr;
 424       Condition : Node_Id := Empty;
 425       Reason    : RT_Exception_Code) return Node_Id
 426    is
 427    begin
 428       pragma Assert (Reason in RT_PE_Exceptions);
 429       return
 430         Make_Raise_Program_Error (Sloc,
 431           Condition => Condition,
 432           Reason =>
 433             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 434    end Make_Raise_Program_Error;
 435
 436    ------------------------------
 437    -- Make_Raise_Storage_Error --
 438    ------------------------------
 439
 440    function Make_Raise_Storage_Error
 441      (Sloc      : Source_Ptr;
 442       Condition : Node_Id := Empty;
 443       Reason    : RT_Exception_Code) return Node_Id
 444    is
 445    begin
 446       pragma Assert (Reason in RT_SE_Exceptions);
 447       return
 448         Make_Raise_Storage_Error (Sloc,
 449           Condition => Condition,
 450           Reason =>
 451             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 452    end Make_Raise_Storage_Error;
 453
 454    -------------------------
 455    -- Make_String_Literal --
 456    -------------------------
 457
 458    function Make_String_Literal
 459      (Sloc   : Source_Ptr;
 460       Strval : String) return Node_Id
 461    is
 462    begin
 463       Start_String;
 464       Store_String_Chars (Strval);
 465       return
 466         Make_String_Literal (Sloc,
 467           Strval => End_String);
 468    end Make_String_Literal;
 469
 470    --------------------
 471    -- Make_Temporary --
 472    --------------------
 473
 474    function Make_Temporary
 475      (Loc          : Source_Ptr;
 476       Id           : Character;
 477       Related_Node : Node_Id := Empty) return Entity_Id
 478    is
 479       Temp : constant Entity_Id :=
 480                Make_Defining_Identifier (Loc,
 481                  Chars => New_Internal_Name (Id));
 482    begin
 483       Set_Related_Expression (Temp, Related_Node);
 484       return Temp;
 485    end Make_Temporary;
 486
 487    ---------------------------
 488    -- Make_Unsuppress_Block --
 489    ---------------------------
 490
 491    --  Generates the following expansion:
 492
 493    --    declare
 494    --       pragma Suppress (<check>);
 495    --    begin
 496    --       <stmts>
 497    --    end;
 498
 499    function Make_Unsuppress_Block
 500      (Loc   : Source_Ptr;
 501       Check : Name_Id;
 502       Stmts : List_Id) return Node_Id
 503    is
 504    begin
 505       return
 506         Make_Block_Statement (Loc,
 507           Declarations => New_List (
 508             Make_Pragma (Loc,
 509               Chars => Name_Suppress,
 510               Pragma_Argument_Associations => New_List (
 511                 Make_Pragma_Argument_Association (Loc,
 512                   Expression => Make_Identifier (Loc, Check))))),
 513
 514           Handled_Statement_Sequence =>
 515             Make_Handled_Sequence_Of_Statements (Loc,
 516               Statements => Stmts));
 517    end Make_Unsuppress_Block;
 518
 519    --------------------------
 520    -- New_Constraint_Error --
 521    --------------------------
 522
 523    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 524       Ident_Node : Node_Id;
 525       Raise_Node : Node_Id;
 526
 527    begin
 528       Ident_Node := New_Node (N_Identifier, Loc);
 529       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 530       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 531       Raise_Node := New_Node (N_Raise_Statement, Loc);
 532       Set_Name (Raise_Node, Ident_Node);
 533       return Raise_Node;
 534    end New_Constraint_Error;
 535
 536    -----------------------
 537    -- New_External_Name --
 538    -----------------------
 539
 540    function New_External_Name
 541      (Related_Id   : Name_Id;
 542       Suffix       : Character := ' ';
 543       Suffix_Index : Int       := 0;
 544       Prefix       : Character := ' ') return Name_Id
 545    is
 546    begin
 547       Get_Name_String (Related_Id);
 548
 549       if Prefix /= ' ' then
 550          pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
 551
 552          for J in reverse 1 .. Name_Len loop
 553             Name_Buffer (J + 1) := Name_Buffer (J);
 554          end loop;
 555
 556          Name_Len := Name_Len + 1;
 557          Name_Buffer (1) := Prefix;
 558       end if;
 559
 560       if Suffix /= ' ' then
 561          pragma Assert (Is_OK_Internal_Letter (Suffix));
 562          Add_Char_To_Name_Buffer (Suffix);
 563       end if;
 564
 565       if Suffix_Index /= 0 then
 566          if Suffix_Index < 0 then
 567             Add_Unique_Serial_Number;
 568          else
 569             Add_Nat_To_Name_Buffer (Suffix_Index);
 570          end if;
 571       end if;
 572
 573       return Name_Find;
 574    end New_External_Name;
 575
 576    function New_External_Name
 577      (Related_Id   : Name_Id;
 578       Suffix       : String;
 579       Suffix_Index : Int       := 0;
 580       Prefix       : Character := ' ') return Name_Id
 581    is
 582    begin
 583       Get_Name_String (Related_Id);
 584
 585       if Prefix /= ' ' then
 586          pragma Assert (Is_OK_Internal_Letter (Prefix));
 587
 588          for J in reverse 1 .. Name_Len loop
 589             Name_Buffer (J + 1) := Name_Buffer (J);
 590          end loop;
 591
 592          Name_Len := Name_Len + 1;
 593          Name_Buffer (1) := Prefix;
 594       end if;
 595
 596       if Suffix /= "" then
 597          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 598          Name_Len := Name_Len + Suffix'Length;
 599       end if;
 600
 601       if Suffix_Index /= 0 then
 602          if Suffix_Index < 0 then
 603             Add_Unique_Serial_Number;
 604          else
 605             Add_Nat_To_Name_Buffer (Suffix_Index);
 606          end if;
 607       end if;
 608
 609       return Name_Find;
 610    end New_External_Name;
 611
 612    function New_External_Name
 613      (Suffix       : Character;
 614       Suffix_Index : Nat) return Name_Id
 615    is
 616    begin
 617       Name_Buffer (1) := Suffix;
 618       Name_Len := 1;
 619       Add_Nat_To_Name_Buffer (Suffix_Index);
 620       return Name_Find;
 621    end New_External_Name;
 622
 623    -----------------------
 624    -- New_Internal_Name --
 625    -----------------------
 626
 627    function New_Internal_Name (Id_Char : Character) return Name_Id is
 628    begin
 629       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 630       Name_Buffer (1) := Id_Char;
 631       Name_Len := 1;
 632       Add_Unique_Serial_Number;
 633       return Name_Enter;
 634    end New_Internal_Name;
 635
 636    -----------------------
 637    -- New_Occurrence_Of --
 638    -----------------------
 639
 640    function New_Occurrence_Of
 641      (Def_Id : Entity_Id;
 642       Loc    : Source_Ptr) return Node_Id
 643    is
 644       Occurrence : Node_Id;
 645
 646    begin
 647       Occurrence := New_Node (N_Identifier, Loc);
 648       Set_Chars (Occurrence, Chars (Def_Id));
 649       Set_Entity (Occurrence, Def_Id);
 650
 651       if Is_Type (Def_Id) then
 652          Set_Etype (Occurrence, Def_Id);
 653       else
 654          Set_Etype (Occurrence, Etype (Def_Id));
 655       end if;
 656
 657       return Occurrence;
 658    end New_Occurrence_Of;
 659
 660    -----------------
 661    -- New_Op_Node --
 662    -----------------
 663
 664    function New_Op_Node
 665      (New_Node_Kind : Node_Kind;
 666       New_Sloc      : Source_Ptr) return Node_Id
 667    is
 668       type Name_Of_Type is array (N_Op) of Name_Id;
 669       Name_Of : constant Name_Of_Type := Name_Of_Type'(
 670          N_Op_And                    => Name_Op_And,
 671          N_Op_Or                     => Name_Op_Or,
 672          N_Op_Xor                    => Name_Op_Xor,
 673          N_Op_Eq                     => Name_Op_Eq,
 674          N_Op_Ne                     => Name_Op_Ne,
 675          N_Op_Lt                     => Name_Op_Lt,
 676          N_Op_Le                     => Name_Op_Le,
 677          N_Op_Gt                     => Name_Op_Gt,
 678          N_Op_Ge                     => Name_Op_Ge,
 679          N_Op_Add                    => Name_Op_Add,
 680          N_Op_Subtract               => Name_Op_Subtract,
 681          N_Op_Concat                 => Name_Op_Concat,
 682          N_Op_Multiply               => Name_Op_Multiply,
 683          N_Op_Divide                 => Name_Op_Divide,
 684          N_Op_Mod                    => Name_Op_Mod,
 685          N_Op_Rem                    => Name_Op_Rem,
 686          N_Op_Expon                  => Name_Op_Expon,
 687          N_Op_Plus                   => Name_Op_Add,
 688          N_Op_Minus                  => Name_Op_Subtract,
 689          N_Op_Abs                    => Name_Op_Abs,
 690          N_Op_Not                    => Name_Op_Not,
 691
 692          --  We don't really need these shift operators, since they never
 693          --  appear as operators in the source, but the path of least
 694          --  resistance is to put them in (the aggregate must be complete).
 695
 696          N_Op_Rotate_Left            => Name_Rotate_Left,
 697          N_Op_Rotate_Right           => Name_Rotate_Right,
 698          N_Op_Shift_Left             => Name_Shift_Left,
 699          N_Op_Shift_Right            => Name_Shift_Right,
 700          N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
 701
 702       Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
 703
 704    begin
 705       if New_Node_Kind in Name_Of'Range then
 706          Set_Chars (Nod, Name_Of (New_Node_Kind));
 707       end if;
 708
 709       return Nod;
 710    end New_Op_Node;
 711
 712    ----------------------
 713    -- New_Reference_To --
 714    ----------------------
 715
 716    function New_Reference_To
 717      (Def_Id : Entity_Id;
 718       Loc    : Source_Ptr) return Node_Id
 719    is
 720       pragma Assert (Nkind (Def_Id) in N_Entity);
 721       Occurrence : Node_Id;
 722    begin
 723       Occurrence := New_Node (N_Identifier, Loc);
 724       Set_Chars (Occurrence, Chars (Def_Id));
 725       Set_Entity (Occurrence, Def_Id);
 726       return Occurrence;
 727    end New_Reference_To;
 728
 729    -----------------------
 730    -- New_Suffixed_Name --
 731    -----------------------
 732
 733    function New_Suffixed_Name
 734      (Related_Id : Name_Id;
 735       Suffix     : String) return Name_Id
 736    is
 737    begin
 738       Get_Name_String (Related_Id);
 739       Add_Char_To_Name_Buffer ('_');
 740       Add_Str_To_Name_Buffer (Suffix);
 741       return Name_Find;
 742    end New_Suffixed_Name;
 743
 744    -------------------
 745    -- OK_Convert_To --
 746    -------------------
 747
 748    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 749       Result : Node_Id;
 750    begin
 751       Result :=
 752         Make_Type_Conversion (Sloc (Expr),
 753           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 754           Expression   => Relocate_Node (Expr));
 755       Set_Conversion_OK (Result, True);
 756       Set_Etype (Result, Typ);
 757       return Result;
 758    end OK_Convert_To;
 759
 760    --------------------------
 761    -- Unchecked_Convert_To --
 762    --------------------------
 763
 764    function Unchecked_Convert_To
 765      (Typ  : Entity_Id;
 766       Expr : Node_Id) return Node_Id
 767    is
 768       Loc         : constant Source_Ptr := Sloc (Expr);
 769       Result      : Node_Id;
 770       Expr_Parent : Node_Id;
 771
 772    begin
 773       --  If the expression is already of the correct type, then nothing
 774       --  to do, except for relocating the node in case this is required.
 775
 776       if Present (Etype (Expr))
 777         and then (Base_Type (Etype (Expr)) = Typ
 778                    or else Etype (Expr) = Typ)
 779       then
 780          return Relocate_Node (Expr);
 781
 782       --  Cases where the inner expression is itself an unchecked conversion
 783       --  to the same type, and we can thus eliminate the outer conversion.
 784
 785       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 786         and then Entity (Subtype_Mark (Expr)) = Typ
 787       then
 788          Result := Relocate_Node (Expr);
 789
 790       elsif Nkind (Expr) = N_Null
 791         and then Is_Access_Type (Typ)
 792       then
 793          --  No need for a conversion
 794
 795          Result := Relocate_Node (Expr);
 796
 797       --  All other cases
 798
 799       else
 800          --  Capture the parent of the expression before relocating it and
 801          --  creating the conversion, so the conversion's parent can be set
 802          --  to the original parent below.
 803
 804          Expr_Parent := Parent (Expr);
 805
 806          Result :=
 807            Make_Unchecked_Type_Conversion (Loc,
 808              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 809              Expression   => Relocate_Node (Expr));
 810
 811          Set_Parent (Result, Expr_Parent);
 812       end if;
 813
 814       Set_Etype (Result, Typ);
 815       return Result;
 816    end Unchecked_Convert_To;
 817
 818 end Tbuild;