gcc/ada/exp_tss.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ T S S                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Exp_Util; use Exp_Util;
  32 with Lib;      use Lib;
  33 with Sem_Util; use Sem_Util;
  34 with Sinfo;    use Sinfo;
  35 with Snames;   use Snames;
  36
  37 package body Exp_Tss is
  38
  39    --------------------
  40    -- Base_Init_Proc --
  41    --------------------
  42
  43    function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
  44       Full_Type : E;
  45       Proc      : Entity_Id;
  46
  47    begin
  48       pragma Assert (Ekind (Typ) in Type_Kind);
  49
  50       if Is_Private_Type (Typ) then
  51          Full_Type := Underlying_Type (Base_Type (Typ));
  52       else
  53          Full_Type := Typ;
  54       end if;
  55
  56       if No (Full_Type) then
  57          return Empty;
  58       elsif Is_Concurrent_Type (Full_Type)
  59         and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
  60       then
  61          return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
  62
  63       else
  64          Proc := Init_Proc (Base_Type (Full_Type));
  65
  66          if No (Proc)
  67            and then Is_Composite_Type (Full_Type)
  68            and then Is_Derived_Type (Full_Type)
  69          then
  70             return Init_Proc (Root_Type (Full_Type));
  71          else
  72             return Proc;
  73          end if;
  74       end if;
  75    end Base_Init_Proc;
  76
  77    --------------
  78    -- Copy_TSS --
  79    --------------
  80
  81    --  Note: internally this routine is also used to initially set up
  82    --  a TSS entry for a new type (case of being called from Set_TSS)
  83
  84    procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
  85       FN : Node_Id;
  86
  87    begin
  88       Ensure_Freeze_Node (Typ);
  89       FN := Freeze_Node (Typ);
  90
  91       if No (TSS_Elist (FN)) then
  92          Set_TSS_Elist (FN, New_Elmt_List);
  93       end if;
  94
  95       --  We prepend here, so that a second call overrides the first, it
  96       --  is not clear that this is required, but it seems reasonable.
  97
  98       Prepend_Elmt (TSS, TSS_Elist (FN));
  99    end Copy_TSS;
 100
 101    ---------------------------------
 102    -- Has_Non_Null_Base_Init_Proc --
 103    ---------------------------------
 104
 105    function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
 106       BIP : constant Entity_Id := Base_Init_Proc (Typ);
 107
 108    begin
 109       return Present (BIP) and then not Is_Null_Init_Proc (BIP);
 110    end Has_Non_Null_Base_Init_Proc;
 111
 112    ---------------
 113    -- Init_Proc --
 114    ---------------
 115
 116    function Init_Proc (Typ : Entity_Id) return Entity_Id is
 117    begin
 118       return TSS (Typ, Name_uInit_Proc);
 119    end Init_Proc;
 120
 121    -------------------
 122    -- Set_Init_Proc --
 123    -------------------
 124
 125    procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
 126    begin
 127       Set_TSS (Typ, Init);
 128    end Set_Init_Proc;
 129
 130    -------------
 131    -- Set_TSS --
 132    -------------
 133
 134    procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
 135       Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
 136
 137    begin
 138       --  Case of insertion location is in unit defining the type
 139
 140       if In_Same_Code_Unit (Typ, TSS) then
 141          Append_Freeze_Action (Typ, Subprog_Body);
 142
 143       --  Otherwise, we are using an already existing TSS in another unit
 144
 145       else
 146          null;
 147       end if;
 148
 149       Copy_TSS (TSS, Typ);
 150    end Set_TSS;
 151
 152    ---------
 153    -- TSS --
 154    ---------
 155
 156    function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
 157       FN   : constant Node_Id := Freeze_Node (Typ);
 158       Elmt : Elmt_Id;
 159       Subp : Entity_Id;
 160
 161    begin
 162       if No (FN) then
 163          return Empty;
 164
 165       elsif No (TSS_Elist (FN)) then
 166          return Empty;
 167
 168       else
 169          Elmt := First_Elmt (TSS_Elist (FN));
 170
 171          while Present (Elmt) loop
 172             if Chars (Node (Elmt)) = Nam then
 173                Subp := Node (Elmt);
 174
 175                --  For stream subprograms, the TSS entity may be a renaming-
 176                --  as-body of an already generated entity. Use that one rather
 177                --  the one introduced by the renaming, which is an artifact of
 178                --  current stream handling.
 179
 180                if Nkind (Parent (Parent (Subp))) =
 181                                            N_Subprogram_Renaming_Declaration
 182                  and then
 183                    Present (Corresponding_Spec (Parent (Parent (Subp))))
 184                then
 185                   return Corresponding_Spec (Parent (Parent (Subp)));
 186                else
 187                   return Subp;
 188                end if;
 189
 190             else
 191                Next_Elmt (Elmt);
 192             end if;
 193          end loop;
 194       end if;
 195
 196       return Empty;
 197    end TSS;
 198
 199 end Exp_Tss;