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