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