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