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