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