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