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