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