New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45960 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 522 insertions, 0 deletions

diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
new file mode 100644
index 00000000000..3ccd7a7472e
--- /dev/null
+++ b/gcc/ada/tbuild.adb
@@ -0,0 +1,522 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T B U I L D                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.98 $
+--                                                                          --
+--          Copyright (C) 1992-2001, 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+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;
+
+   --------------------
+   -- 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_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);
+
+      --  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;