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