New Language: Ada

From-SVN: r45954

1 files changed, 200 insertions, 0 deletions

diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
new file mode 100644
index 0000000..6e3722c
--- /dev/null
+++ b/gcc/ada/exp_tss.adb
@@ -0,0 +1,200 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              E X P _ T S S                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.26 $
+--                                                                          --
+--          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 Elists;   use Elists;
+with Exp_Util; use Exp_Util;
+with Lib;      use Lib;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+
+package body Exp_Tss is
+
+   --------------------
+   -- Base_Init_Proc --
+   --------------------
+
+   function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
+      Full_Type : E;
+      Proc      : Entity_Id;
+
+   begin
+      pragma Assert (Ekind (Typ) in Type_Kind);
+
+      if Is_Private_Type (Typ) then
+         Full_Type := Underlying_Type (Base_Type (Typ));
+      else
+         Full_Type := Typ;
+      end if;
+
+      if No (Full_Type) then
+         return Empty;
+      elsif Is_Concurrent_Type (Full_Type)
+        and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
+      then
+         return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
+
+      else
+         Proc := Init_Proc (Base_Type (Full_Type));
+
+         if No (Proc)
+           and then Is_Composite_Type (Full_Type)
+           and then Is_Derived_Type (Full_Type)
+         then
+            return Init_Proc (Root_Type (Full_Type));
+         else
+            return Proc;
+         end if;
+      end if;
+   end Base_Init_Proc;
+
+   --------------
+   -- Copy_TSS --
+   --------------
+
+   --  Note: internally this routine is also used to initially set up
+   --  a TSS entry for a new type (case of being called from Set_TSS)
+
+   procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
+      FN : Node_Id;
+
+   begin
+      Ensure_Freeze_Node (Typ);
+      FN := Freeze_Node (Typ);
+
+      if No (TSS_Elist (FN)) then
+         Set_TSS_Elist (FN, New_Elmt_List);
+      end if;
+
+      --  We prepend here, so that a second call overrides the first, it
+      --  is not clear that this is required, but it seems reasonable.
+
+      Prepend_Elmt (TSS, TSS_Elist (FN));
+   end Copy_TSS;
+
+   ---------------------------------
+   -- Has_Non_Null_Base_Init_Proc --
+   ---------------------------------
+
+   function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
+      BIP : constant Entity_Id := Base_Init_Proc (Typ);
+
+   begin
+      return Present (BIP) and then not Is_Null_Init_Proc (BIP);
+   end Has_Non_Null_Base_Init_Proc;
+
+   ---------------
+   -- Init_Proc --
+   ---------------
+
+   function Init_Proc (Typ : Entity_Id) return Entity_Id is
+   begin
+      return TSS (Typ, Name_uInit_Proc);
+   end Init_Proc;
+
+   -------------------
+   -- Set_Init_Proc --
+   -------------------
+
+   procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
+   begin
+      Set_TSS (Typ, Init);
+   end Set_Init_Proc;
+
+   -------------
+   -- Set_TSS --
+   -------------
+
+   procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
+      Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
+
+   begin
+      --  Case of insertion location is in unit defining the type
+
+      if In_Same_Code_Unit (Typ, TSS) then
+         Append_Freeze_Action (Typ, Subprog_Body);
+
+      --  Otherwise, we are using an already existing TSS in another unit
+
+      else
+         null;
+      end if;
+
+      Copy_TSS (TSS, Typ);
+   end Set_TSS;
+
+   ---------
+   -- TSS --
+   ---------
+
+   function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
+      FN   : constant Node_Id := Freeze_Node (Typ);
+      Elmt : Elmt_Id;
+      Subp : Entity_Id;
+
+   begin
+      if No (FN) then
+         return Empty;
+
+      elsif No (TSS_Elist (FN)) then
+         return Empty;
+
+      else
+         Elmt := First_Elmt (TSS_Elist (FN));
+
+         while Present (Elmt) loop
+            if Chars (Node (Elmt)) = Nam then
+               Subp := Node (Elmt);
+
+               --  For stream subprograms, the TSS entity may be a renaming-
+               --  as-body of an already generated entity. Use that one rather
+               --  the one introduced by the renaming, which is an artifact of
+               --  current stream handling.
+
+               if Nkind (Parent (Parent (Subp))) =
+                                           N_Subprogram_Renaming_Declaration
+                 and then
+                   Present (Corresponding_Spec (Parent (Parent (Subp))))
+               then
+                  return Corresponding_Spec (Parent (Parent (Subp)));
+               else
+                  return Subp;
+               end if;
+
+            else
+               Next_Elmt (Elmt);
+            end if;
+         end loop;
+      end if;
+
+      return Empty;
+   end TSS;
+
+end Exp_Tss;