Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                               T B U I L D                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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 Einfo;    use Einfo;

with Elists;   use Elists;

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 Sem_Aux;  use Sem_Aux;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

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

   ------------------------------

   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

      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 (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),

          Make_Selected_Component (Loc,

            Prefix => New_Copy (Rec),

            Selector_Name =>

              New_Reference_To (First_Tag_Component (Full_Type), Loc)));

   end Make_DT_Access;

   -------------------------------------

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

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

      Debug_Statement              : Node_Id := Empty) return Node_Id

   is

   begin

      return

        Make_Pragma (Sloc,

          Pragma_Argument_Associations => Pragma_Argument_Associations,

          Debug_Statement              => Debug_Statement,

          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 (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_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_Temporary --

   --------------------

   function Make_Temporary

     (Loc          : Source_Ptr;

      Id           : Character;

      Related_Node : Node_Id := Empty) return Node_Id

   is

      Temp : constant Node_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 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) 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

      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_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_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);

      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;

   --------------------------

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

        and then Is_Access_Type (Typ)

      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;