path: root/gcc/ada/tbuild.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               T B U I L D                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2003, 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 2,  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 COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- 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 Einfo;    use Einfo;
with Lib;      use Lib;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Restrict; use Restrict;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Stand;    use Stand;
with Uintp;    use Uintp;

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 --
   ------------------------------

   procedure Add_Unique_Serial_Number is
      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 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
      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;

   ------------------
   -- 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 = Name_Address
                       or else
                     Attribute_Name = Name_Unrestricted_Access);
      Set_Must_Be_Byte_Aligned (N, True);
      return N;
   end Make_Byte_Aligned_Attribute_Reference;

   --------------------
   -- Make_DT_Access --
   --------------------

   function Make_DT_Access
     (Loc  : Source_Ptr;
      Rec  : Node_Id;
      Typ  : Entity_Id)
      return Node_Id
   is
      Full_Type : Entity_Id := Typ;

   begin
      if Is_Private_Type (Typ) then
         Full_Type := Underlying_Type (Typ);
      end if;

      return
        Unchecked_Convert_To (
          New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
          Make_Selected_Component (Loc,
            Prefix => New_Copy (Rec),
            Selector_Name =>
              New_Reference_To (Tag_Component (Full_Type), Loc)));
   end Make_DT_Access;

   -----------------------
   -- Make_DT_Component --
   -----------------------

   function Make_DT_Component
     (Loc  : Source_Ptr;
      Typ  : Entity_Id;
      I    : Positive)
      return Node_Id
   is
      X : Node_Id;
      Full_Type : Entity_Id := Typ;

   begin
      if Is_Private_Type (Typ) then
         Full_Type := Underlying_Type (Typ);
      end if;

      X := First_Component (
             Designated_Type (Etype (Access_Disp_Table (Full_Type))));

      for J in 2 .. I loop
         X := Next_Component (X);
      end loop;

      return New_Reference_To (X, Loc);
   end Make_DT_Component;

   --------------------------------
   -- 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
   begin
      Check_Restriction (No_Implicit_Loops, Node);

      if Present (Iteration_Scheme)
        and then Present (Condition (Iteration_Scheme))
      then
         Check_Restriction (No_Implicit_Conditionals, Node);
      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_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_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 (Reason in RT_CE_Exceptions);
      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 (Reason in RT_PE_Exceptions);
      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 (Reason in RT_SE_Exceptions);
      return
        Make_Raise_Storage_Error (Sloc,
          Condition => Condition,
          Reason =>
            UI_From_Int (RT_Exception_Code'Pos (Reason)));
   end Make_Raise_Storage_Error;

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

   --  Generates the following expansion:

   --    declare
   --       pragma Suppress (<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_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_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));

         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));
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := 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
      Occurrence : Node_Id;

   begin
      Occurrence := New_Node (N_Identifier, Loc);
      Set_Chars (Occurrence, Chars (Def_Id));
      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;

      return Occurrence;
   end New_Occurrence_Of;

   ----------------------
   -- New_Reference_To --
   ----------------------

   function New_Reference_To
     (Def_Id : Entity_Id;
      Loc    : Source_Ptr)
      return   Node_Id
   is
      Occurrence : Node_Id;

   begin
      Occurrence := New_Node (N_Identifier, Loc);
      Set_Chars (Occurrence, Chars (Def_Id));
      Set_Entity (Occurrence, Def_Id);
      return Occurrence;
   end New_Reference_To;

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

   function New_Suffixed_Name
     (Related_Id : Name_Id;
      Suffix     : String)
      return       Name_Id
   is
   begin
      Get_Name_String (Related_Id);
      Name_Len := Name_Len + 1;
      Name_Buffer (Name_Len) := '_';
      Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
      Name_Len := Name_Len + Suffix'Length;
      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;

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

   function Unchecked_Convert_To
     (Typ  : Entity_Id;
      Expr : Node_Id)
      return Node_Id
   is
      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 in case this is required.

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

      --  Cases where the inner expression is itself an unchecked conversion
      --  to the same type, and we can thus eliminate the outer conversion.

      elsif Nkind (Expr) = N_Unchecked_Type_Conversion
        and then Entity (Subtype_Mark (Expr)) = Typ
      then
         Result := Relocate_Node (Expr);

      elsif Nkind (Expr) = N_Null then

         --  No need for a conversion

         Result := Relocate_Node (Expr);

      --  All other cases

      else
         Result :=
           Make_Unchecked_Type_Conversion (Loc,
             Subtype_Mark => New_Occurrence_Of (Typ, Loc),
             Expression   => Relocate_Node (Expr));
      end if;

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

end Tbuild;