path: root/gcc/ada/tbuild.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               T B U I L D                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2023, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;          use Atree;
with Aspects;        use Aspects;
with Csets;          use Csets;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Lib;            use Lib;
with Nlists;         use Nlists;
with Nmake;          use Nmake;
with Opt;            use Opt;
with Restrict;       use Restrict;
with Rident;         use Rident;
with Sinfo.Utils;    use Sinfo.Utils;
with Sem_Util;       use Sem_Util;
with Snames;         use Snames;
with Stand;          use Stand;
with Stringt;        use Stringt;
with Urealp;         use Urealp;

package body Tbuild is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Add_Unique_Serial_Number;
   --  Add a unique serialization to the string in the Name_Buffer. This
   --  consists of a unit specific serial number, and b/s for body/spec.

   ------------------------------
   -- Add_Unique_Serial_Number --
   ------------------------------

   Config_Serial_Number : Nat := 0;
   --  Counter for use in config pragmas, see comment below

   procedure Add_Unique_Serial_Number is
   begin
      --  If we are analyzing configuration pragmas, Cunit (Main_Unit) will
      --  not be set yet. This happens for example when analyzing static
      --  string expressions in configuration pragmas. For this case, we
      --  just maintain a local counter, defined above and we do not need
      --  to add a b or s indication in this case.

      if No (Cunit (Current_Sem_Unit)) then
         Config_Serial_Number := Config_Serial_Number + 1;
         Add_Nat_To_Name_Buffer (Config_Serial_Number);
         return;

      --  Normal case, within a unit

      else
         declare
            Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));

         begin
            Add_Nat_To_Name_Buffer (Increment_Serial_Number);

            --  Add either b or s, depending on whether current unit is a spec
            --  or a body. This is needed because we may generate the same name
            --  in a spec and a body otherwise.

            Name_Len := Name_Len + 1;

            if Nkind (Unit_Node) = N_Package_Declaration
              or else Nkind (Unit_Node) = N_Subprogram_Declaration
              or else Nkind (Unit_Node) in N_Generic_Declaration
            then
               Name_Buffer (Name_Len) := 's';
            else
               Name_Buffer (Name_Len) := 'b';
            end if;
         end;
      end if;
   end Add_Unique_Serial_Number;

   ----------------
   -- Checks_Off --
   ----------------

   function Checks_Off (N : Node_Id) return Node_Id is
   begin
      return
        Make_Unchecked_Expression (Sloc (N),
          Expression => N);
   end Checks_Off;

   ----------------
   -- Convert_To --
   ----------------

   function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
      pragma Assert (Is_Type (Typ));
      Result : Node_Id;

   begin
      if Present (Etype (Expr)) and then Etype (Expr) = Typ then
         return Relocate_Node (Expr);

      else
         Result :=
           Make_Type_Conversion (Sloc (Expr),
             Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
             Expression => Relocate_Node (Expr));

         Set_Etype (Result, Typ);
         return Result;
      end if;
   end Convert_To;

   ----------------------------
   -- Convert_To_And_Rewrite --
   ----------------------------

   procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id) is
   begin
      Rewrite (Expr, Convert_To (Typ, Expr));
   end Convert_To_And_Rewrite;

   ------------------
   -- Discard_List --
   ------------------

   procedure Discard_List (L : List_Id) is
      pragma Warnings (Off, L);
   begin
      null;
   end Discard_List;

   ------------------
   -- Discard_Node --
   ------------------

   procedure Discard_Node (N : Node_Or_Entity_Id) is
      pragma Warnings (Off, N);
   begin
      null;
   end Discard_Node;

   -------------------------------------------
   -- Make_Byte_Aligned_Attribute_Reference --
   -------------------------------------------

   function Make_Byte_Aligned_Attribute_Reference
     (Sloc           : Source_Ptr;
      Prefix         : Node_Id;
      Attribute_Name : Name_Id)
      return           Node_Id
   is
      N : constant Node_Id :=
            Make_Attribute_Reference (Sloc,
              Prefix        => Prefix,
              Attribute_Name => Attribute_Name);

   begin
      pragma Assert
        (Attribute_Name in Name_Address | Name_Unrestricted_Access);
      Set_Must_Be_Byte_Aligned (N, True);
      return N;
   end Make_Byte_Aligned_Attribute_Reference;

   ------------------------
   -- Make_Float_Literal --
   ------------------------

   function Make_Float_Literal
     (Loc         : Source_Ptr;
      Radix       : Uint;
      Significand : Uint;
      Exponent    : Uint) return Node_Id
   is
   begin
      if Radix = 2 and then abs Significand /= 1 then
         return
           Make_Float_Literal
             (Loc, Uint_16,
              Significand * Radix**(Exponent mod 4),
              Exponent / 4);

      else
         declare
            N : constant Node_Id := New_Node (N_Real_Literal, Loc);

         begin
            Set_Realval (N,
              UR_From_Components
                (Num      => abs Significand,
                 Den      => -Exponent,
                 Rbase    => UI_To_Int (Radix),
                 Negative => Significand < 0));
            return N;
         end;
      end if;
   end Make_Float_Literal;

   -------------
   -- Make_Id --
   -------------

   function Make_Id (Str : Text_Buffer) return Node_Id is
   begin
      Name_Len := 0;

      for J in Str'Range loop
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := Fold_Lower (Str (J));
      end loop;

      return
        Make_Identifier (System_Location,
          Chars => Name_Find);
   end Make_Id;

   -------------------------------------
   -- Make_Implicit_Exception_Handler --
   -------------------------------------

   function Make_Implicit_Exception_Handler
     (Sloc              : Source_Ptr;
      Choice_Parameter  : Node_Id := Empty;
      Exception_Choices : List_Id;
      Statements        : List_Id) return Node_Id
   is
      Handler : Node_Id;
      Loc     : Source_Ptr;

   begin
      --  Set the source location only when debugging the expanded code

      --  When debugging the source code directly, we do not want the compiler
      --  to associate this implicit exception handler with any specific source
      --  line, because it can potentially confuse the debugger. The most
      --  damaging situation would arise when the debugger tries to insert a
      --  breakpoint at a certain line. If the code of the associated implicit
      --  exception handler is generated before the code of that line, then the
      --  debugger will end up inserting the breakpoint inside the exception
      --  handler, rather than the code the user intended to break on. As a
      --  result, it is likely that the program will not hit the breakpoint
      --  as expected.

      if Debug_Generated_Code then
         Loc := Sloc;
      else
         Loc := No_Location;
      end if;

      Handler :=
        Make_Exception_Handler
          (Loc, Choice_Parameter, Exception_Choices, Statements);
      Set_Local_Raise_Statements (Handler, No_Elist);
      return Handler;
   end Make_Implicit_Exception_Handler;

   --------------------------------
   -- Make_Implicit_If_Statement --
   --------------------------------

   function Make_Implicit_If_Statement
     (Node            : Node_Id;
      Condition       : Node_Id;
      Then_Statements : List_Id;
      Elsif_Parts     : List_Id := No_List;
      Else_Statements : List_Id := No_List) return Node_Id
   is
   begin
      Check_Restriction (No_Implicit_Conditionals, Node);

      return Make_If_Statement (Sloc (Node),
        Condition,
        Then_Statements,
        Elsif_Parts,
        Else_Statements);
   end Make_Implicit_If_Statement;

   -------------------------------------
   -- Make_Implicit_Label_Declaration --
   -------------------------------------

   function Make_Implicit_Label_Declaration
     (Loc                 : Source_Ptr;
      Defining_Identifier : Node_Id;
      Label_Construct     : Node_Id) return Node_Id
   is
      N : constant Node_Id :=
            Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
   begin
      Set_Label_Construct (N, Label_Construct);
      return N;
   end Make_Implicit_Label_Declaration;

   ----------------------------------
   -- Make_Implicit_Loop_Statement --
   ----------------------------------

   function Make_Implicit_Loop_Statement
     (Node                   : Node_Id;
      Statements             : List_Id;
      Identifier             : Node_Id := Empty;
      Iteration_Scheme       : Node_Id := Empty;
      Has_Created_Identifier : Boolean := False;
      End_Label              : Node_Id := Empty) return Node_Id
   is
      P                  : Node_Id;
      Check_Restrictions : Boolean := True;
   begin
      --  Do not check restrictions if the implicit loop statement is part
      --  of a dead branch: False and then ...
      --  This will occur in particular as part of the expansion of pragma
      --  Assert when assertions are disabled.

      P := Parent (Node);
      while Present (P) loop
         if Nkind (P) = N_And_Then then
            if Nkind (Left_Opnd (P)) = N_Identifier
              and then Entity (Left_Opnd (P)) = Standard_False
            then
               Check_Restrictions := False;
               exit;
            end if;

         --  Prevent the search from going too far

         elsif Is_Body_Or_Package_Declaration (P) then
            exit;
         end if;

         P := Parent (P);
      end loop;

      if Check_Restrictions then
         Check_Restriction (No_Implicit_Loops, Node);

         if Present (Iteration_Scheme)
           and then Nkind (Iteration_Scheme) /= N_Iterator_Specification
           and then Present (Condition (Iteration_Scheme))
         then
            Check_Restriction (No_Implicit_Conditionals, Node);
         end if;
      end if;

      return Make_Loop_Statement (Sloc (Node),
        Identifier             => Identifier,
        Iteration_Scheme       => Iteration_Scheme,
        Statements             => Statements,
        Has_Created_Identifier => Has_Created_Identifier,
        End_Label              => End_Label);
   end Make_Implicit_Loop_Statement;

   --------------------
   -- Make_Increment --
   --------------------

   function Make_Increment
     (Loc : Source_Ptr; Index : Entity_Id; Typ : Entity_Id) return Node_Id is
   begin
      return Make_Assignment_Statement (Loc,
               Name => New_Occurrence_Of (Index, Loc),
               Expression =>
                 Make_Attribute_Reference (Loc,
                   Prefix =>
                     New_Occurrence_Of (Typ, Loc),
                   Attribute_Name => Name_Succ,
                   Expressions => New_List (
                     New_Occurrence_Of (Index, Loc))));
   end Make_Increment;

   --------------------------
   -- Make_Integer_Literal --
   ---------------------------

   function Make_Integer_Literal
     (Loc    : Source_Ptr;
      Intval : Int) return Node_Id
   is
   begin
      return Make_Integer_Literal (Loc, UI_From_Int (Intval));
   end Make_Integer_Literal;

   --------------------------------
   -- Make_Linker_Section_Pragma --
   --------------------------------

   function Make_Linker_Section_Pragma
     (Ent : Entity_Id;
      Loc : Source_Ptr;
      Sec : String) return Node_Id
   is
      LS : Node_Id;

   begin
      LS :=
        Make_Pragma
          (Loc,
           Name_Linker_Section,
           New_List
             (Make_Pragma_Argument_Association
                (Sloc => Loc,
                 Expression => New_Occurrence_Of (Ent, Loc)),
              Make_Pragma_Argument_Association
                (Sloc => Loc,
                 Expression =>
                   Make_String_Literal
                     (Sloc => Loc,
                      Strval => Sec))));

      Set_Has_Gigi_Rep_Item (Ent);
      return LS;
   end Make_Linker_Section_Pragma;

   -----------------
   -- Make_Pragma --
   -----------------

   function Make_Pragma
     (Sloc                         : Source_Ptr;
      Chars                        : Name_Id;
      Pragma_Argument_Associations : List_Id := No_List) return Node_Id
   is
   begin
      return
        Make_Pragma (Sloc,
          Pragma_Argument_Associations => Pragma_Argument_Associations,
          Pragma_Identifier            => Make_Identifier (Sloc, Chars));
   end Make_Pragma;

   ---------------------------------
   -- Make_Raise_Constraint_Error --
   ---------------------------------

   function Make_Raise_Constraint_Error
     (Sloc      : Source_Ptr;
      Condition : Node_Id := Empty;
      Reason    : RT_Exception_Code) return Node_Id
   is
   begin
      pragma Assert (Rkind (Reason) = CE_Reason);
      return
        Make_Raise_Constraint_Error (Sloc,
          Condition => Condition,
          Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
   end Make_Raise_Constraint_Error;

   ------------------------------
   -- Make_Raise_Program_Error --
   ------------------------------

   function Make_Raise_Program_Error
     (Sloc      : Source_Ptr;
      Condition : Node_Id := Empty;
      Reason    : RT_Exception_Code) return Node_Id
   is
   begin
      pragma Assert (Rkind (Reason) = PE_Reason);
      return
        Make_Raise_Program_Error (Sloc,
          Condition => Condition,
          Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
   end Make_Raise_Program_Error;

   ------------------------------
   -- Make_Raise_Storage_Error --
   ------------------------------

   function Make_Raise_Storage_Error
     (Sloc      : Source_Ptr;
      Condition : Node_Id := Empty;
      Reason    : RT_Exception_Code) return Node_Id
   is
   begin
      pragma Assert (Rkind (Reason) = SE_Reason);
      return
        Make_Raise_Storage_Error (Sloc,
          Condition => Condition,
          Reason    => UI_From_Int (RT_Exception_Code'Pos (Reason)));
   end Make_Raise_Storage_Error;

   -------------
   -- Make_SC --
   -------------

   function  Make_SC (Pre, Sel : Node_Id) return Node_Id is
   begin
      return
        Make_Selected_Component (System_Location,
          Prefix        => Pre,
          Selector_Name => Sel);
   end Make_SC;

   -------------------------
   -- Make_String_Literal --
   -------------------------

   function Make_String_Literal
     (Sloc   : Source_Ptr;
      Strval : String) return Node_Id
   is
   begin
      Start_String;
      Store_String_Chars (Strval);
      return Make_String_Literal (Sloc, Strval => End_String);
   end Make_String_Literal;

   -------------------------
   -- Make_Suppress_Block --
   -------------------------

   --  Generates the following expansion:

   --    declare
   --       pragma Suppress (<check>);
   --    begin
   --       <stmts>
   --    end;

   function Make_Suppress_Block
     (Loc   : Source_Ptr;
      Check : Name_Id;
      Stmts : List_Id) return Node_Id
   is
   begin
      return
        Make_Block_Statement (Loc,
          Declarations => New_List (
            Make_Pragma (Loc,
              Chars => Name_Suppress,
              Pragma_Argument_Associations => New_List (
                Make_Pragma_Argument_Association (Loc,
                  Expression => Make_Identifier (Loc, Check))))),

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => Stmts));
   end Make_Suppress_Block;

   --------------------
   -- Make_Temporary --
   --------------------

   function Make_Temporary
     (Loc          : Source_Ptr;
      Id           : Character;
      Related_Node : Node_Id := Empty) return Entity_Id
   is
      Temp : constant Entity_Id :=
               Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id));
   begin
      Set_Related_Expression (Temp, Related_Node);
      return Temp;
   end Make_Temporary;

   ---------------------------
   -- Make_Unsuppress_Block --
   ---------------------------

   --  Generates the following expansion:

   --    declare
   --       pragma Unsuppress (<check>);
   --    begin
   --       <stmts>
   --    end;

   function Make_Unsuppress_Block
     (Loc   : Source_Ptr;
      Check : Name_Id;
      Stmts : List_Id) return Node_Id
   is
   begin
      return
        Make_Block_Statement (Loc,
          Declarations => New_List (
            Make_Pragma (Loc,
              Chars => Name_Unsuppress,
              Pragma_Argument_Associations => New_List (
                Make_Pragma_Argument_Association (Loc,
                  Expression => Make_Identifier (Loc, Check))))),

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => Stmts));
   end Make_Unsuppress_Block;

   --------------------------
   -- New_Constraint_Error --
   --------------------------

   function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
      Ident_Node : Node_Id;
      Raise_Node : Node_Id;

   begin
      Ident_Node := New_Node (N_Identifier, Loc);
      Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
      Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
      Raise_Node := New_Node (N_Raise_Statement, Loc);
      Set_Name (Raise_Node, Ident_Node);
      return Raise_Node;
   end New_Constraint_Error;

   -----------------------
   -- New_External_Name --
   -----------------------

   function New_External_Name
     (Related_Id   : Name_Id;
      Suffix       : Character := ' ';
      Suffix_Index : Int       := 0;
      Prefix       : Character := ' ') return Name_Id
   is
   begin
      Get_Name_String (Related_Id);

      if Prefix /= ' ' then
         pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');

         for J in reverse 1 .. Name_Len loop
            Name_Buffer (J + 1) := Name_Buffer (J);
         end loop;

         Name_Len := Name_Len + 1;
         Name_Buffer (1) := Prefix;
      end if;

      if Suffix /= ' ' then
         pragma Assert (Is_OK_Internal_Letter (Suffix));
         Add_Char_To_Name_Buffer (Suffix);
      end if;

      if Suffix_Index /= 0 then
         if Suffix_Index < 0 then
            Add_Unique_Serial_Number;
         else
            Add_Nat_To_Name_Buffer (Suffix_Index);
         end if;
      end if;

      return Name_Find;
   end New_External_Name;

   function New_External_Name
     (Related_Id   : Name_Id;
      Suffix       : String;
      Suffix_Index : Int       := 0;
      Prefix       : Character := ' ') return Name_Id
   is
   begin
      Get_Name_String (Related_Id);

      if Prefix /= ' ' then
         pragma Assert (Is_OK_Internal_Letter (Prefix));

         for J in reverse 1 .. Name_Len loop
            Name_Buffer (J + 1) := Name_Buffer (J);
         end loop;

         Name_Len := Name_Len + 1;
         Name_Buffer (1) := Prefix;
      end if;

      if Suffix /= "" then
         Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
         Name_Len := Name_Len + Suffix'Length;
      end if;

      if Suffix_Index /= 0 then
         if Suffix_Index < 0 then
            Add_Unique_Serial_Number;
         else
            Add_Nat_To_Name_Buffer (Suffix_Index);
         end if;
      end if;

      return Name_Find;
   end New_External_Name;

   function New_External_Name
     (Suffix       : Character;
      Suffix_Index : Nat) return Name_Id
   is
   begin
      Name_Buffer (1) := Suffix;
      Name_Len := 1;
      Add_Nat_To_Name_Buffer (Suffix_Index);
      return Name_Find;
   end New_External_Name;

   -----------------------
   -- New_Internal_Name --
   -----------------------

   function New_Internal_Name (Id_Char : Character) return Name_Id is
   begin
      pragma Assert (Is_OK_Internal_Letter (Id_Char));
      Name_Buffer (1) := Id_Char;
      Name_Len := 1;
      Add_Unique_Serial_Number;
      return Name_Enter;
   end New_Internal_Name;

   -----------------------
   -- New_Occurrence_Of --
   -----------------------

   function New_Occurrence_Of
     (Def_Id : Entity_Id;
      Loc    : Source_Ptr) return Node_Id
   is
      pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity);
      Occurrence : constant Node_Id :=
        Make_Identifier (Loc, Chars (Def_Id));

   begin
      Set_Entity (Occurrence, Def_Id);

      if Is_Type (Def_Id) then
         Set_Etype (Occurrence, Def_Id);
      else
         Set_Etype (Occurrence, Etype (Def_Id));
      end if;

      if Ekind (Def_Id) = E_Enumeration_Literal then
         Set_Is_Static_Expression (Occurrence, True);
      end if;

      return Occurrence;
   end New_Occurrence_Of;

   -----------------
   -- New_Op_Node --
   -----------------

   function New_Op_Node
     (New_Node_Kind : Node_Kind;
      New_Sloc      : Source_Ptr) return Node_Id
   is
      type Name_Of_Type is array (N_Op) of Name_Id;
      Name_Of : constant Name_Of_Type := Name_Of_Type'(
         N_Op_And                    => Name_Op_And,
         N_Op_Or                     => Name_Op_Or,
         N_Op_Xor                    => Name_Op_Xor,
         N_Op_Eq                     => Name_Op_Eq,
         N_Op_Ne                     => Name_Op_Ne,
         N_Op_Lt                     => Name_Op_Lt,
         N_Op_Le                     => Name_Op_Le,
         N_Op_Gt                     => Name_Op_Gt,
         N_Op_Ge                     => Name_Op_Ge,
         N_Op_Add                    => Name_Op_Add,
         N_Op_Subtract               => Name_Op_Subtract,
         N_Op_Concat                 => Name_Op_Concat,
         N_Op_Multiply               => Name_Op_Multiply,
         N_Op_Divide                 => Name_Op_Divide,
         N_Op_Mod                    => Name_Op_Mod,
         N_Op_Rem                    => Name_Op_Rem,
         N_Op_Expon                  => Name_Op_Expon,
         N_Op_Plus                   => Name_Op_Add,
         N_Op_Minus                  => Name_Op_Subtract,
         N_Op_Abs                    => Name_Op_Abs,
         N_Op_Not                    => Name_Op_Not,

         --  We don't really need these shift operators, since they never
         --  appear as operators in the source, but the path of least
         --  resistance is to put them in (the aggregate must be complete).

         N_Op_Rotate_Left            => Name_Rotate_Left,
         N_Op_Rotate_Right           => Name_Rotate_Right,
         N_Op_Shift_Left             => Name_Shift_Left,
         N_Op_Shift_Right            => Name_Shift_Right,
         N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);

      Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);

   begin
      if New_Node_Kind in Name_Of'Range then
         Set_Chars (Nod, Name_Of (New_Node_Kind));
      end if;

      return Nod;
   end New_Op_Node;

   -----------------------
   -- New_Suffixed_Name --
   -----------------------

   function New_Suffixed_Name
     (Related_Id : Name_Id;
      Suffix     : String) return Name_Id
   is
   begin
      Get_Name_String (Related_Id);
      Add_Char_To_Name_Buffer ('_');
      Add_Str_To_Name_Buffer (Suffix);
      return Name_Find;
   end New_Suffixed_Name;

   -------------------
   -- OK_Convert_To --
   -------------------

   function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
      Result : Node_Id;
   begin
      Result :=
        Make_Type_Conversion (Sloc (Expr),
          Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
          Expression   => Relocate_Node (Expr));
      Set_Conversion_OK (Result, True);
      Set_Etype (Result, Typ);
      return Result;
   end OK_Convert_To;

   --------------
   -- Sel_Comp --
   --------------

   function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id is
   begin
      return Make_Selected_Component
        (Sloc          => Sloc (Pre),
         Prefix        => Pre,
         Selector_Name => Make_Identifier (Sloc (Pre), Name_Find (Sel)));
   end Sel_Comp;

   function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id is
   begin
      return Sel_Comp (Make_Identifier (Loc, Name_Find (Pre)), Sel);
   end Sel_Comp;

   -------------
   -- Set_NOD --
   -------------

   procedure Set_NOD (Unit : Node_Id) is
   begin
      Set_Restriction_No_Dependence (Unit, Warn => False);
   end Set_NOD;

   -------------
   -- Set_NSA --
   -------------

   procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is
      Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
   begin
      if Asp_Id = No_Aspect then
         OK := False;
      else
         OK := True;
         Set_Restriction_No_Specification_Of_Aspect (Asp_Id);
      end if;
   end Set_NSA;

   -------------
   -- Set_NUA --
   -------------

   procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is
   begin
      if Is_Attribute_Name (Attr) then
         OK := True;
         Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr));
      else
         OK := False;
      end if;
   end Set_NUA;

   -------------
   -- Set_NUP --
   -------------

   procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is
   begin
      if Is_Pragma_Name (Prag) then
         OK := True;
         Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag));
      else
         OK := False;
      end if;
   end Set_NUP;

   --------------------------
   -- Unchecked_Convert_To --
   --------------------------

   function Unchecked_Convert_To
     (Typ  : Entity_Id;
      Expr : Node_Id) return Node_Id
   is
      pragma Assert (Ekind (Typ) in E_Void | Type_Kind);
      --  We don't really want to allow E_Void here, but existing code passes
      --  it.

      Loc    : constant Source_Ptr := Sloc (Expr);
      Result : Node_Id;

   begin
      --  If the expression is already of the correct type, then nothing
      --  to do, except for relocating the node

      if Present (Etype (Expr))
        and then (Base_Type (Etype (Expr)) = Typ or else Etype (Expr) = Typ)
      then
         return Relocate_Node (Expr);

      --  Case where the expression is already an unchecked conversion. We
      --  replace the type being converted to, to avoid creating an unchecked
      --  conversion of an unchecked conversion. Extra unchecked conversions
      --  make the .dg output less readable. We can't do this in cases
      --  involving bitfields, because the sizes might not match. The
      --  Is_Composite_Type checks avoid such cases.

      elsif Nkind (Expr) = N_Unchecked_Type_Conversion
        and then Is_Composite_Type (Etype (Expr))
        and then Is_Composite_Type (Typ)
      then
         Set_Subtype_Mark (Expr, New_Occurrence_Of (Typ, Loc));
         Result := Relocate_Node (Expr);

      elsif Nkind (Expr) = N_Null
        and then Is_Access_Type (Typ)
      then
         --  No need for a conversion

         Result := Relocate_Node (Expr);

      --  All other cases

      else
         declare
            Expr_Parent : constant Node_Id := Parent (Expr);
         begin
            Result :=
              Make_Unchecked_Type_Conversion (Loc,
                Subtype_Mark => New_Occurrence_Of (Typ, Loc),
                Expression   => Relocate_Node (Expr));
            Set_Parent (Result, Expr_Parent);
         end;
      end if;

      Set_Etype (Result, Typ);
      return Result;
   end Unchecked_Convert_To;

end Tbuild;