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-2015, 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    -- CPP_Init_Proc --
 114    -------------------
 115
 116    function CPP_Init_Proc (Typ  : Entity_Id) return Entity_Id is
 117       FN   : constant Node_Id := Freeze_Node (Typ);
 118       Elmt : Elmt_Id;
 119
 120    begin
 121       if not Is_CPP_Class (Root_Type (Typ))
 122         or else No (FN)
 123         or else No (TSS_Elist (FN))
 124       then
 125          return Empty;
 126
 127       else
 128          Elmt := First_Elmt (TSS_Elist (FN));
 129          while Present (Elmt) loop
 130             if Is_CPP_Init_Proc (Node (Elmt)) then
 131                return Node (Elmt);
 132             end if;
 133
 134             Next_Elmt (Elmt);
 135          end loop;
 136       end if;
 137
 138       return Empty;
 139    end CPP_Init_Proc;
 140
 141    ------------------------
 142    -- Find_Inherited_TSS --
 143    ------------------------
 144
 145    function Find_Inherited_TSS
 146      (Typ : Entity_Id;
 147       Nam : TSS_Name_Type) return Entity_Id
 148    is
 149       Btyp : Entity_Id := Typ;
 150       Proc : Entity_Id;
 151
 152    begin
 153       loop
 154          Btyp := Base_Type (Btyp);
 155          Proc := TSS (Btyp, Nam);
 156
 157          exit when Present (Proc)
 158            or else not Is_Derived_Type (Btyp);
 159
 160          --  If Typ is a derived type, it may inherit attributes from some
 161          --  ancestor.
 162
 163          Btyp := Etype (Btyp);
 164       end loop;
 165
 166       if No (Proc) then
 167
 168          --  If nothing else, use the TSS of the root type
 169
 170          Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
 171       end if;
 172
 173       return Proc;
 174    end Find_Inherited_TSS;
 175
 176    -----------------------
 177    -- Get_TSS_Name_Type --
 178    -----------------------
 179
 180    function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
 181       C1 : Character;
 182       C2 : Character;
 183       Nm : TSS_Name_Type;
 184
 185    begin
 186       Get_Last_Two_Chars (Chars (E), C1, C2);
 187
 188       if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
 189          Nm := (C1, C2);
 190
 191          for J in TSS_Names'Range loop
 192             if Nm = TSS_Names (J) then
 193                return Nm;
 194             end if;
 195          end loop;
 196       end if;
 197
 198       return TSS_Null;
 199    end Get_TSS_Name;
 200
 201    ---------------------------------
 202    -- Has_Non_Null_Base_Init_Proc --
 203    ---------------------------------
 204
 205    --  Note: if a base Init_Proc is present, and No_Default_Initialization is
 206    --  present, then we must avoid testing for a null init proc, since there
 207    --  is no init proc present in this case.
 208
 209    function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
 210       BIP : constant Entity_Id := Base_Init_Proc (Typ);
 211    begin
 212       return Present (BIP)
 213         and then (Restriction_Active (No_Default_Initialization)
 214                    or else not Is_Null_Init_Proc (BIP));
 215    end Has_Non_Null_Base_Init_Proc;
 216
 217    ---------------
 218    -- Init_Proc --
 219    ---------------
 220
 221    function Init_Proc
 222      (Typ  : Entity_Id;
 223       Ref  : Entity_Id := Empty) return Entity_Id
 224    is
 225       FN   : constant Node_Id := Freeze_Node (Typ);
 226       Elmt : Elmt_Id;
 227       E1   : Entity_Id;
 228       E2   : Entity_Id;
 229
 230    begin
 231       if No (FN) then
 232          return Empty;
 233
 234       elsif No (TSS_Elist (FN)) then
 235          return Empty;
 236
 237       elsif No (Ref) then
 238          Elmt := First_Elmt (TSS_Elist (FN));
 239          while Present (Elmt) loop
 240             if Is_Init_Proc (Node (Elmt)) then
 241                if not Is_CPP_Class (Typ) then
 242                   return Node (Elmt);
 243
 244                --  For CPP classes, we are looking for the default constructor,
 245                --  and so we must skip any non-default constructor.
 246
 247                elsif
 248                  No (Next
 249                       (First
 250                         (Parameter_Specifications (Parent (Node (Elmt))))))
 251                then
 252                   return Node (Elmt);
 253                end if;
 254             end if;
 255
 256             Next_Elmt (Elmt);
 257          end loop;
 258
 259       --  Non-default constructors are currently supported only in the context
 260       --  of interfacing with C++.
 261
 262       else pragma Assert (Is_CPP_Class (Typ));
 263
 264          --  Use the referenced function to locate the init_proc matching
 265          --  the C++ constructor.
 266
 267          Elmt := First_Elmt (TSS_Elist (FN));
 268          while Present (Elmt) loop
 269             if Is_Init_Proc (Node (Elmt)) then
 270                E1 := Next_Formal (First_Formal (Node (Elmt)));
 271                E2 := First_Formal (Ref);
 272                while Present (E1) and then Present (E2) loop
 273                   if Chars (E1) /= Chars (E2)
 274                     or else Ekind (E1) /= Ekind (E2)
 275                   then
 276                      exit;
 277
 278                   elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
 279                     and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
 280                     and then Etype (E1) /= Etype (E2)
 281                   then
 282                      exit;
 283
 284                   elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
 285                     and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
 286                     and then Directly_Designated_Type (Etype (E1))
 287                                /= Directly_Designated_Type (Etype (E2))
 288                   then
 289                      exit;
 290                   end if;
 291
 292                   E1 := Next_Formal (E1);
 293                   E2 := Next_Formal (E2);
 294                end loop;
 295
 296                if No (E1) and then No (E2) then
 297                   return Node (Elmt);
 298                end if;
 299             end if;
 300
 301             Next_Elmt (Elmt);
 302          end loop;
 303       end if;
 304
 305       return Empty;
 306    end Init_Proc;
 307
 308    ----------------------
 309    -- Is_CPP_Init_Proc --
 310    ----------------------
 311
 312    function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
 313       C1 : Character;
 314       C2 : Character;
 315    begin
 316       Get_Last_Two_Chars (Chars (E), C1, C2);
 317       return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
 318    end Is_CPP_Init_Proc;
 319
 320    ------------------
 321    -- Is_Init_Proc --
 322    ------------------
 323
 324    function Is_Init_Proc (E : Entity_Id) return Boolean is
 325       C1 : Character;
 326       C2 : Character;
 327    begin
 328       Get_Last_Two_Chars (Chars (E), C1, C2);
 329       return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
 330    end Is_Init_Proc;
 331
 332    ------------
 333    -- Is_TSS --
 334    ------------
 335
 336    function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
 337       C1 : Character;
 338       C2 : Character;
 339    begin
 340       Get_Last_Two_Chars (Chars (E), C1, C2);
 341       return C1 = Nam (1) and then C2 = Nam (2);
 342    end Is_TSS;
 343
 344    function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
 345       C1 : Character;
 346       C2 : Character;
 347    begin
 348       Get_Last_Two_Chars (N, C1, C2);
 349       return C1 = Nam (1) and then C2 = Nam (2);
 350    end Is_TSS;
 351
 352    -------------------------
 353    -- Make_Init_Proc_Name --
 354    -------------------------
 355
 356    function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
 357    begin
 358       return Make_TSS_Name (Typ, TSS_Init_Proc);
 359    end Make_Init_Proc_Name;
 360
 361    -------------------
 362    -- Make_TSS_Name --
 363    -------------------
 364
 365    function Make_TSS_Name
 366      (Typ : Entity_Id;
 367       Nam : TSS_Name_Type) return Name_Id
 368    is
 369    begin
 370       Get_Name_String (Chars (Typ));
 371       Add_Char_To_Name_Buffer (Nam (1));
 372       Add_Char_To_Name_Buffer (Nam (2));
 373       return Name_Find;
 374    end Make_TSS_Name;
 375
 376    -------------------------
 377    -- Make_TSS_Name_Local --
 378    -------------------------
 379
 380    function Make_TSS_Name_Local
 381      (Typ : Entity_Id;
 382       Nam : TSS_Name_Type) return Name_Id
 383    is
 384    begin
 385       Get_Name_String (Chars (Typ));
 386       Add_Char_To_Name_Buffer ('_');
 387       Add_Nat_To_Name_Buffer (Increment_Serial_Number);
 388       Add_Char_To_Name_Buffer (Nam (1));
 389       Add_Char_To_Name_Buffer (Nam (2));
 390       return Name_Find;
 391    end Make_TSS_Name_Local;
 392
 393    --------------
 394    -- Same_TSS --
 395    --------------
 396
 397    function Same_TSS (E1, E2 : Entity_Id) return Boolean is
 398       E1C1 : Character;
 399       E1C2 : Character;
 400       E2C1 : Character;
 401       E2C2 : Character;
 402
 403    begin
 404       Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
 405       Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
 406
 407       return
 408         E1C1 = E2C1
 409           and then
 410         E1C2 = E2C2
 411           and then
 412         E1C1 in 'A' .. 'Z'
 413           and then
 414         E1C2 in 'A' .. 'Z';
 415    end Same_TSS;
 416
 417    -------------------
 418    -- Set_Init_Proc --
 419    -------------------
 420
 421    procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
 422    begin
 423       Set_TSS (Typ, Init);
 424    end Set_Init_Proc;
 425
 426    -------------
 427    -- Set_TSS --
 428    -------------
 429
 430    procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
 431    begin
 432       --  Make sure body of subprogram is frozen
 433
 434       --  Skip this for Init_Proc with No_Default_Initialization, since the
 435       --  Init proc is a dummy void entity in this case to be ignored.
 436
 437       if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
 438         and then Restriction_Active (No_Default_Initialization)
 439       then
 440          null;
 441
 442       --  Skip this if not in the same code unit (since it means we are using
 443       --  an already existing TSS in another unit)
 444
 445       elsif not In_Same_Code_Unit (Typ, TSS) then
 446          null;
 447
 448       --  Otherwise make sure body is frozen
 449
 450       else
 451          Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
 452       end if;
 453
 454       --  Set TSS entry
 455
 456       Copy_TSS (TSS, Typ);
 457    end Set_TSS;
 458
 459    ---------
 460    -- TSS --
 461    ---------
 462
 463    function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
 464       FN   : constant Node_Id := Freeze_Node (Typ);
 465       Elmt : Elmt_Id;
 466       Subp : Entity_Id;
 467
 468    begin
 469       if No (FN) then
 470          return Empty;
 471
 472       elsif No (TSS_Elist (FN)) then
 473          return Empty;
 474
 475       else
 476          Elmt := First_Elmt (TSS_Elist (FN));
 477          while Present (Elmt) loop
 478             if Is_TSS (Node (Elmt), Nam) then
 479                Subp := Node (Elmt);
 480
 481                --  For stream subprograms, the TSS entity may be a renaming-
 482                --  as-body of an already generated entity. Use that one rather
 483                --  the one introduced by the renaming, which is an artifact of
 484                --  current stream handling.
 485
 486                if Nkind (Parent (Parent (Subp))) =
 487                                            N_Subprogram_Renaming_Declaration
 488                  and then
 489                    Present (Corresponding_Spec (Parent (Parent (Subp))))
 490                then
 491                   return Corresponding_Spec (Parent (Parent (Subp)));
 492                else
 493                   return Subp;
 494                end if;
 495
 496             else
 497                Next_Elmt (Elmt);
 498             end if;
 499          end loop;
 500       end if;
 501
 502       return Empty;
 503    end TSS;
 504
 505    function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
 506       FN   : constant Node_Id := Freeze_Node (Typ);
 507       Elmt : Elmt_Id;
 508       Subp : Entity_Id;
 509
 510    begin
 511       if No (FN) then
 512          return Empty;
 513
 514       elsif No (TSS_Elist (FN)) then
 515          return Empty;
 516
 517       else
 518          Elmt := First_Elmt (TSS_Elist (FN));
 519          while Present (Elmt) loop
 520             if Chars (Node (Elmt)) = Nam then
 521                Subp := Node (Elmt);
 522
 523                --  For stream subprograms, the TSS entity may be a renaming-
 524                --  as-body of an already generated entity. Use that one rather
 525                --  the one introduced by the renaming, which is an artifact of
 526                --  current stream handling.
 527
 528                if Nkind (Parent (Parent (Subp))) =
 529                                            N_Subprogram_Renaming_Declaration
 530                  and then
 531                    Present (Corresponding_Spec (Parent (Parent (Subp))))
 532                then
 533                   return Corresponding_Spec (Parent (Parent (Subp)));
 534                else
 535                   return Subp;
 536                end if;
 537
 538             else
 539                Next_Elmt (Elmt);
 540             end if;
 541          end loop;
 542       end if;
 543
 544       return Empty;
 545    end TSS;
 546
 547 end Exp_Tss;