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 --          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Exp_Util; use Exp_Util;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Sem_Util; use Sem_Util;
  34 with Sinfo;    use Sinfo;
  35
  36 package body Exp_Tss is
  37
  38    --------------------
  39    -- Base_Init_Proc --
  40    --------------------
  41
  42    function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
  43       Full_Type : E;
  44       Proc      : Entity_Id;
  45
  46    begin
  47       pragma Assert (Ekind (Typ) in Type_Kind);
  48
  49       if Is_Private_Type (Typ) then
  50          Full_Type := Underlying_Type (Base_Type (Typ));
  51       else
  52          Full_Type := Typ;
  53       end if;
  54
  55       if No (Full_Type) then
  56          return Empty;
  57       elsif Is_Concurrent_Type (Full_Type)
  58         and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
  59       then
  60          return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
  61
  62       else
  63          Proc := Init_Proc (Base_Type (Full_Type));
  64
  65          if No (Proc)
  66            and then Is_Composite_Type (Full_Type)
  67            and then Is_Derived_Type (Full_Type)
  68          then
  69             return Init_Proc (Root_Type (Full_Type));
  70          else
  71             return Proc;
  72          end if;
  73       end if;
  74    end Base_Init_Proc;
  75
  76    --------------
  77    -- Copy_TSS --
  78    --------------
  79
  80    --  Note: internally this routine is also used to initially set up
  81    --  a TSS entry for a new type (case of being called from Set_TSS)
  82
  83    procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
  84       FN : Node_Id;
  85
  86    begin
  87       Ensure_Freeze_Node (Typ);
  88       FN := Freeze_Node (Typ);
  89
  90       if No (TSS_Elist (FN)) then
  91          Set_TSS_Elist (FN, New_Elmt_List);
  92       end if;
  93
  94       --  We prepend here, so that a second call overrides the first, it
  95       --  is not clear that this is required, but it seems reasonable.
  96
  97       Prepend_Elmt (TSS, TSS_Elist (FN));
  98    end Copy_TSS;
  99
 100    -----------------------
 101    -- Get_TSS_Name_Type --
 102    -----------------------
 103
 104    function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
 105       C1 : Character;
 106       C2 : Character;
 107       Nm : TSS_Name_Type;
 108
 109    begin
 110       Get_Last_Two_Chars (Chars (E), C1, C2);
 111
 112       if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
 113          Nm := (C1, C2);
 114
 115          for J in OK_TSS_Names'Range loop
 116             if Nm = OK_TSS_Names (J) then
 117                return Nm;
 118             end if;
 119          end loop;
 120       end if;
 121
 122       return TSS_Null;
 123    end Get_TSS_Name;
 124
 125    ---------------------------------
 126    -- Has_Non_Null_Base_Init_Proc --
 127    ---------------------------------
 128
 129    function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
 130       BIP : constant Entity_Id := Base_Init_Proc (Typ);
 131
 132    begin
 133       return Present (BIP) and then not Is_Null_Init_Proc (BIP);
 134    end Has_Non_Null_Base_Init_Proc;
 135
 136    ---------------
 137    -- Init_Proc --
 138    ---------------
 139
 140    function Init_Proc (Typ : Entity_Id) return Entity_Id is
 141       FN   : constant Node_Id := Freeze_Node (Typ);
 142       Elmt : Elmt_Id;
 143
 144    begin
 145       if No (FN) then
 146          return Empty;
 147
 148       elsif No (TSS_Elist (FN)) then
 149          return Empty;
 150
 151       else
 152          Elmt := First_Elmt (TSS_Elist (FN));
 153          while Present (Elmt) loop
 154             if Is_Init_Proc (Node (Elmt)) then
 155                return Node (Elmt);
 156             end if;
 157
 158             Next_Elmt (Elmt);
 159          end loop;
 160       end if;
 161
 162       return Empty;
 163    end Init_Proc;
 164
 165    ------------------
 166    -- Is_Init_Proc --
 167    ------------------
 168
 169    function Is_Init_Proc (E : Entity_Id) return Boolean is
 170       C1 : Character;
 171       C2 : Character;
 172    begin
 173       Get_Last_Two_Chars (Chars (E), C1, C2);
 174       return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
 175    end Is_Init_Proc;
 176
 177    ------------
 178    -- Is_TSS --
 179    ------------
 180
 181    function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
 182       C1 : Character;
 183       C2 : Character;
 184    begin
 185       Get_Last_Two_Chars (Chars (E), C1, C2);
 186       return C1 = Nam (1) and then C2 = Nam (2);
 187    end Is_TSS;
 188
 189    function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
 190       C1 : Character;
 191       C2 : Character;
 192    begin
 193       Get_Last_Two_Chars (N, C1, C2);
 194       return C1 = Nam (1) and then C2 = Nam (2);
 195    end Is_TSS;
 196
 197    -------------------------
 198    -- Make_Init_Proc_Name --
 199    -------------------------
 200
 201    function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
 202    begin
 203       Get_Name_String (Chars (Typ));
 204       Name_Len := Name_Len + 2;
 205       Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1);
 206       Name_Buffer (Name_Len)     := TSS_Init_Proc (2);
 207       return Name_Find;
 208    end Make_Init_Proc_Name;
 209
 210    -------------------------
 211    -- Make_TSS_Name_Local --
 212    -------------------------
 213
 214    function Make_TSS_Name_Local
 215      (Typ : Entity_Id;
 216       Nam : TSS_Name_Type) return Name_Id
 217    is
 218    begin
 219       Get_Name_String (Chars (Typ));
 220       Add_Char_To_Name_Buffer (Nam (1));
 221       Add_Char_To_Name_Buffer (Nam (2));
 222       Add_Char_To_Name_Buffer ('_');
 223       Add_Nat_To_Name_Buffer (Increment_Serial_Number);
 224       return Name_Find;
 225    end Make_TSS_Name_Local;
 226
 227    -------------------
 228    -- Make_TSS_Name --
 229    -------------------
 230
 231    function Make_TSS_Name
 232      (Typ : Entity_Id;
 233       Nam : TSS_Name_Type) return Name_Id
 234    is
 235    begin
 236       Get_Name_String (Chars (Typ));
 237       Add_Char_To_Name_Buffer (Nam (1));
 238       Add_Char_To_Name_Buffer (Nam (2));
 239       return Name_Find;
 240    end Make_TSS_Name;
 241
 242    --------------
 243    -- Same_TSS --
 244    --------------
 245
 246    function Same_TSS (E1, E2 : Entity_Id) return Boolean is
 247       E1C1 : Character;
 248       E1C2 : Character;
 249       E2C1 : Character;
 250       E2C2 : Character;
 251
 252    begin
 253       Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
 254       Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
 255
 256       return
 257         E1C1 = E2C1
 258           and then
 259         E1C2 = E2C2
 260           and then
 261         E1C1 in 'A' .. 'Z'
 262           and then
 263         E1C2 in 'A' .. 'Z';
 264    end Same_TSS;
 265
 266    -------------------
 267    -- Set_Init_Proc --
 268    -------------------
 269
 270    procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
 271    begin
 272       Set_TSS (Typ, Init);
 273    end Set_Init_Proc;
 274
 275    -------------
 276    -- Set_TSS --
 277    -------------
 278
 279    procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
 280       Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
 281
 282    begin
 283       --  Case of insertion location is in unit defining the type
 284
 285       if In_Same_Code_Unit (Typ, TSS) then
 286          Append_Freeze_Action (Typ, Subprog_Body);
 287
 288       --  Otherwise, we are using an already existing TSS in another unit
 289
 290       else
 291          null;
 292       end if;
 293
 294       Copy_TSS (TSS, Typ);
 295    end Set_TSS;
 296
 297    ---------
 298    -- TSS --
 299    ---------
 300
 301    function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
 302       FN   : constant Node_Id := Freeze_Node (Typ);
 303       Elmt : Elmt_Id;
 304       Subp : Entity_Id;
 305
 306    begin
 307       if No (FN) then
 308          return Empty;
 309
 310       elsif No (TSS_Elist (FN)) then
 311          return Empty;
 312
 313       else
 314          Elmt := First_Elmt (TSS_Elist (FN));
 315          while Present (Elmt) loop
 316             if Is_TSS (Node (Elmt), Nam) then
 317                Subp := Node (Elmt);
 318
 319                --  For stream subprograms, the TSS entity may be a renaming-
 320                --  as-body of an already generated entity. Use that one rather
 321                --  the one introduced by the renaming, which is an artifact of
 322                --  current stream handling.
 323
 324                if Nkind (Parent (Parent (Subp))) =
 325                                            N_Subprogram_Renaming_Declaration
 326                  and then
 327                    Present (Corresponding_Spec (Parent (Parent (Subp))))
 328                then
 329                   return Corresponding_Spec (Parent (Parent (Subp)));
 330                else
 331                   return Subp;
 332                end if;
 333
 334             else
 335                Next_Elmt (Elmt);
 336             end if;
 337          end loop;
 338       end if;
 339
 340       return Empty;
 341    end TSS;
 342
 343    function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
 344       FN   : constant Node_Id := Freeze_Node (Typ);
 345       Elmt : Elmt_Id;
 346       Subp : Entity_Id;
 347
 348    begin
 349       if No (FN) then
 350          return Empty;
 351
 352       elsif No (TSS_Elist (FN)) then
 353          return Empty;
 354
 355       else
 356          Elmt := First_Elmt (TSS_Elist (FN));
 357          while Present (Elmt) loop
 358             if Chars (Node (Elmt)) =  Nam then
 359                Subp := Node (Elmt);
 360
 361                --  For stream subprograms, the TSS entity may be a renaming-
 362                --  as-body of an already generated entity. Use that one rather
 363                --  the one introduced by the renaming, which is an artifact of
 364                --  current stream handling.
 365
 366                if Nkind (Parent (Parent (Subp))) =
 367                                            N_Subprogram_Renaming_Declaration
 368                  and then
 369                    Present (Corresponding_Spec (Parent (Parent (Subp))))
 370                then
 371                   return Corresponding_Spec (Parent (Parent (Subp)));
 372                else
 373                   return Subp;
 374                end if;
 375
 376             else
 377                Next_Elmt (Elmt);
 378             end if;
 379          end loop;
 380       end if;
 381
 382       return Empty;
 383    end TSS;
 384
 385 end Exp_Tss;