gcc/ada/exp_ch8.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 8                               --
   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 Exp_Ch3;        use Exp_Ch3;
  31 with Exp_Ch4;        use Exp_Ch4;
  32 with Exp_Ch6;        use Exp_Ch6;
  33 with Exp_Dbug;       use Exp_Dbug;
  34 with Exp_Util;       use Exp_Util;
  35 with Freeze;         use Freeze;
  36 with Namet;          use Namet;
  37 with Nmake;          use Nmake;
  38 with Nlists;         use Nlists;
  39 with Opt;            use Opt;
  40 with Sem;            use Sem;
  41 with Sem_Aux;        use Sem_Aux;
  42 with Sem_Ch8;        use Sem_Ch8;
  43 with Sem_Util;       use Sem_Util;
  44 with Sinfo;          use Sinfo;
  45 with Sinfo.Nodes;    use Sinfo.Nodes;
  46 with Sinfo.Utils;    use Sinfo.Utils;
  47 with Snames;         use Snames;
  48 with Stand;          use Stand;
  49 with Tbuild;         use Tbuild;
  50
  51 package body Exp_Ch8 is
  52
  53    ---------------------------------------------
  54    -- Expand_N_Exception_Renaming_Declaration --
  55    ---------------------------------------------
  56
  57    procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
  58       Decl : Node_Id;
  59
  60    begin
  61       Decl := Debug_Renaming_Declaration (N);
  62
  63       if Present (Decl) then
  64          Insert_Action (N, Decl);
  65       end if;
  66    end Expand_N_Exception_Renaming_Declaration;
  67
  68    ------------------------------------------
  69    -- Expand_N_Object_Renaming_Declaration --
  70    ------------------------------------------
  71
  72    --  Most object renaming cases can be done by just capturing the address
  73    --  of the renamed object. The cases in which this is not true are when
  74    --  this address is not computable, since it involves extraction of a
  75    --  packed array element, or of a record component to which a component
  76    --  clause applies (that can specify an arbitrary bit boundary), or where
  77    --  the enclosing record itself has a non-standard representation.
  78
  79    --  In Ada 2022, a third case arises when the renamed object is a nonatomic
  80    --  subcomponent of an atomic object, because reads of or writes to it must
  81    --  access the enclosing atomic object. That's also the case for an object
  82    --  subject to the Volatile_Full_Access GNAT aspect/pragma in any language
  83    --  version. For the sake of simplicity, we treat any subcomponent of an
  84    --  atomic or Volatile_Full_Access object in any language version this way.
  85
  86    --  In these three cases, we pre-evaluate the renaming expression, by
  87    --  extracting and freezing the values of any subscripts, and then we
  88    --  set the flag Is_Renaming_Of_Object which means that any reference
  89    --  to the object will be handled by macro substitution in the front
  90    --  end, and the back end will know to ignore the renaming declaration.
  91
  92    --  An additional odd case that requires processing by expansion is
  93    --  the renaming of a discriminant of a mutable record type. The object
  94    --  is a constant because it renames something that cannot be assigned to,
  95    --  but in fact the underlying value can change and must be reevaluated
  96    --  at each reference. Gigi does have a notion of a "constant view" of
  97    --  an object, and therefore the front-end must perform the expansion.
  98    --  For simplicity, and to bypass some obscure code-generation problem,
  99    --  we use macro substitution for all renamed discriminants, whether the
 100    --  enclosing type is constrained or not.
 101
 102    --  The other special processing required is for the case of renaming
 103    --  of an object of a class wide type, where it is necessary to build
 104    --  the appropriate subtype for the renamed object.
 105    --  More comments needed for this para ???
 106
 107    procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
 108       function Evaluation_Required (Nam : Node_Id) return Boolean;
 109       --  Determines whether it is necessary to do static name evaluation for
 110       --  renaming of Nam. It is considered necessary if evaluating the name
 111       --  involves indexing a packed array, or extracting a component of a
 112       --  record to which a component clause applies, or a subcomponent of an
 113       --  atomic object. Note that we are only interested in these operations
 114       --  if they occur as part of the name itself, subscripts are just values
 115       --  that are computed as part of the evaluation, so they are unimportant.
 116       --  In addition, always return True for Modify_Tree_For_C since the
 117       --  code generator doesn't know how to handle renamings.
 118
 119       -------------------------
 120       -- Evaluation_Required --
 121       -------------------------
 122
 123       function Evaluation_Required (Nam : Node_Id) return Boolean is
 124       begin
 125          if Modify_Tree_For_C then
 126             return True;
 127
 128          elsif Nkind (Nam) in N_Indexed_Component | N_Slice then
 129             if Is_Packed (Etype (Prefix (Nam))) then
 130                return True;
 131
 132             elsif Is_Full_Access_Object (Prefix (Nam)) then
 133                return True;
 134
 135             else
 136                return Evaluation_Required (Prefix (Nam));
 137             end if;
 138
 139          elsif Nkind (Nam) = N_Selected_Component then
 140             declare
 141                Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
 142
 143             begin
 144                if Present (Component_Clause (Entity (Selector_Name (Nam))))
 145                  or else Has_Non_Standard_Rep (Rec_Type)
 146                then
 147                   return True;
 148
 149                elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
 150                  and then Is_Record_Type (Rec_Type)
 151                  and then not Is_Concurrent_Record_Type (Rec_Type)
 152                then
 153                   return True;
 154
 155                elsif Is_Full_Access_Object (Prefix (Nam)) then
 156                   return True;
 157
 158                else
 159                   return Evaluation_Required (Prefix (Nam));
 160                end if;
 161             end;
 162
 163          else
 164             return False;
 165          end if;
 166       end Evaluation_Required;
 167
 168       --  Local variables
 169
 170       Decl : Node_Id;
 171       Nam  : constant Node_Id   := Name (N);
 172       T    : constant Entity_Id := Etype (Defining_Identifier (N));
 173
 174    --  Start of processing for Expand_N_Object_Renaming_Declaration
 175
 176    begin
 177       --  Perform name evaluation if required
 178
 179       if Evaluation_Required (Nam) then
 180          Evaluate_Name (Nam);
 181          Set_Is_Renaming_Of_Object (Defining_Identifier (N));
 182       end if;
 183
 184       --  Deal with construction of subtype in class-wide case
 185
 186       if Is_Class_Wide_Type (T) then
 187          Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
 188          Find_Type (Subtype_Mark (N));
 189          Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
 190
 191          --  Freeze the class-wide subtype here to ensure that the subtype
 192          --  and equivalent type are frozen before the renaming.
 193
 194          Freeze_Before (N, Entity (Subtype_Mark (N)));
 195       end if;
 196
 197       --  Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
 198       --  place function, then a temporary return object needs to be created
 199       --  and access to it must be passed to the function.
 200
 201       if Is_Build_In_Place_Function_Call (Nam) then
 202          Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
 203
 204       --  Ada 2005 (AI-318-02): Specialization of previous case for renaming
 205       --  containing build-in-place function calls whose returned object covers
 206       --  interface types.
 207
 208       elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
 209          Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
 210       end if;
 211
 212       --  Create renaming entry for debug information. Mark the entity as
 213       --  needing debug info if it comes from sources because the current
 214       --  setting in Freeze_Entity occurs too late. ???
 215
 216       Set_Debug_Info_Defining_Id (N);
 217       Decl := Debug_Renaming_Declaration (N);
 218
 219       if Present (Decl) then
 220          Insert_Action (N, Decl);
 221       end if;
 222    end Expand_N_Object_Renaming_Declaration;
 223
 224    -------------------------------------------
 225    -- Expand_N_Package_Renaming_Declaration --
 226    -------------------------------------------
 227
 228    procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
 229       Decl : Node_Id;
 230
 231    begin
 232       Decl := Debug_Renaming_Declaration (N);
 233
 234       if Present (Decl) then
 235
 236          --  If we are in a compilation unit, then this is an outer
 237          --  level declaration, and must have a scope of Standard
 238
 239          if Nkind (Parent (N)) = N_Compilation_Unit then
 240             declare
 241                Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
 242
 243             begin
 244                Push_Scope (Standard_Standard);
 245
 246                if No (Actions (Aux)) then
 247                   Set_Actions (Aux, New_List (Decl));
 248                else
 249                   Append (Decl, Actions (Aux));
 250                end if;
 251
 252                Analyze (Decl);
 253
 254                --  Enter the debug variable in the qualification list, which
 255                --  must be done at this point because auxiliary declarations
 256                --  occur at the library level and aren't associated with a
 257                --  normal scope.
 258
 259                Qualify_Entity_Names (Decl);
 260
 261                Pop_Scope;
 262             end;
 263
 264          --  Otherwise, just insert after the package declaration
 265
 266          else
 267             Insert_Action (N, Decl);
 268          end if;
 269       end if;
 270    end Expand_N_Package_Renaming_Declaration;
 271
 272    ----------------------------------------------
 273    -- Expand_N_Subprogram_Renaming_Declaration --
 274    ----------------------------------------------
 275
 276    procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
 277       Loc : constant Source_Ptr := Sloc (N);
 278       Id  : constant Entity_Id  := Defining_Entity (N);
 279
 280       function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
 281       --  Build and return the body for the renaming declaration of an equality
 282       --  or inequality operator of type Typ.
 283
 284       -----------------------------
 285       -- Build_Body_For_Renaming --
 286       -----------------------------
 287
 288       function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
 289          Left    : constant Entity_Id := First_Formal (Id);
 290          Right   : constant Entity_Id := Next_Formal (Left);
 291          Body_Id : Entity_Id;
 292          Decl    : Node_Id;
 293
 294       begin
 295          Set_Alias (Id, Empty);
 296          Set_Has_Completion (Id, False);
 297          Set_Has_Delayed_Freeze (Id);
 298          Rewrite (N,
 299            Make_Subprogram_Declaration (Loc,
 300              Specification => Specification (N)));
 301
 302          Body_Id := Make_Defining_Identifier (Loc, Chars (Id));
 303          Set_Debug_Info_Needed (Body_Id);
 304
 305          if Has_Variant_Part (Typ) then
 306             Decl :=
 307               Build_Variant_Record_Equality
 308                 (Typ         => Typ,
 309                  Spec_Id     => Id,
 310                  Body_Id     => Body_Id,
 311                  Param_Specs => Copy_Parameter_List (Id));
 312
 313          --  Build body for renamed equality, to capture its current meaning.
 314          --  It may be redefined later, but the renaming is elaborated where
 315          --  it occurs. This is technically known as Squirreling semantics.
 316          --  Renaming is rewritten as a subprogram declaration, and the
 317          --  generated body is inserted into the freeze actions for the
 318          --  subprogram.
 319
 320          else
 321             Decl :=
 322               Make_Subprogram_Body (Loc,
 323                 Specification              =>
 324                   Make_Function_Specification (Loc,
 325                     Defining_Unit_Name       => Body_Id,
 326                     Parameter_Specifications => Copy_Parameter_List (Id),
 327                     Result_Definition        =>
 328                       New_Occurrence_Of (Standard_Boolean, Loc)),
 329                 Declarations               => Empty_List,
 330                 Handled_Statement_Sequence =>
 331                   Make_Handled_Sequence_Of_Statements (Loc,
 332                     Statements => New_List (
 333                       Make_Simple_Return_Statement (Loc,
 334                         Expression =>
 335                           Expand_Record_Equality
 336                             (Id,
 337                              Typ => Typ,
 338                              Lhs => Make_Identifier (Loc, Chars (Left)),
 339                              Rhs => Make_Identifier (Loc, Chars (Right)))))));
 340          end if;
 341
 342          return Decl;
 343       end Build_Body_For_Renaming;
 344
 345       --  Local variables
 346
 347       Nam : constant Node_Id := Name (N);
 348
 349    --  Start of processing for Expand_N_Subprogram_Renaming_Declaration
 350
 351    begin
 352       --  When the prefix of the name is a function call, we must force the
 353       --  call to be made by removing side effects from the call, since we
 354       --  must only call the function once.
 355
 356       if Nkind (Nam) = N_Selected_Component
 357         and then Nkind (Prefix (Nam)) = N_Function_Call
 358       then
 359          Remove_Side_Effects (Prefix (Nam));
 360
 361       --  For an explicit dereference, the prefix must be captured to prevent
 362       --  reevaluation on calls through the renaming, which could result in
 363       --  calling the wrong subprogram if the access value were to be changed.
 364
 365       elsif Nkind (Nam) = N_Explicit_Dereference then
 366          Force_Evaluation (Prefix (Nam));
 367       end if;
 368
 369       --  Handle cases where we build a body for a renamed equality
 370
 371       if Is_Entity_Name (Nam)
 372         and then Chars (Entity (Nam)) = Name_Op_Eq
 373         and then Scope (Entity (Nam)) = Standard_Standard
 374       then
 375          declare
 376             Typ : constant Entity_Id := Etype (First_Formal (Id));
 377
 378          begin
 379             --  Check whether this is a renaming of a predefined equality on an
 380             --  untagged record type (AI05-0123).
 381
 382             if Ada_Version >= Ada_2012
 383               and then Is_Record_Type (Typ)
 384               and then not Is_Tagged_Type (Typ)
 385               and then not Is_Frozen (Typ)
 386             then
 387                Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
 388             end if;
 389          end;
 390       end if;
 391    end Expand_N_Subprogram_Renaming_Declaration;
 392
 393 end Exp_Ch8;