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