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