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