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-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 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       Nam  : constant Node_Id := Name (N);
 105       Decl : Node_Id;
 106       T    : Entity_Id;
 107
 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_In (Nam, N_Indexed_Component, N_Slice) then
 129             if Is_Packed (Etype (Prefix (Nam))) then
 130                return True;
 131
 132             elsif Is_Atomic_Or_VFA_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_Atomic_Or_VFA_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    --  Start of processing for Expand_N_Object_Renaming_Declaration
 169
 170    begin
 171       --  Perform name evaluation if required
 172
 173       if Evaluation_Required (Nam) then
 174          Evaluate_Name (Nam);
 175          Set_Is_Renaming_Of_Object (Defining_Identifier (N));
 176       end if;
 177
 178       --  Deal with construction of subtype in class-wide case
 179
 180       T := Etype (Defining_Identifier (N));
 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       if Comes_From_Source (Defining_Identifier (N)) then
 213          Set_Debug_Info_Needed (Defining_Identifier (N));
 214       end if;
 215
 216       Decl := Debug_Renaming_Declaration (N);
 217
 218       if Present (Decl) then
 219          Insert_Action (N, Decl);
 220       end if;
 221    end Expand_N_Object_Renaming_Declaration;
 222
 223    -------------------------------------------
 224    -- Expand_N_Package_Renaming_Declaration --
 225    -------------------------------------------
 226
 227    procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
 228       Decl : Node_Id;
 229
 230    begin
 231       Decl := Debug_Renaming_Declaration (N);
 232
 233       if Present (Decl) then
 234
 235          --  If we are in a compilation unit, then this is an outer
 236          --  level declaration, and must have a scope of Standard
 237
 238          if Nkind (Parent (N)) = N_Compilation_Unit then
 239             declare
 240                Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
 241
 242             begin
 243                Push_Scope (Standard_Standard);
 244
 245                if No (Actions (Aux)) then
 246                   Set_Actions (Aux, New_List (Decl));
 247                else
 248                   Append (Decl, Actions (Aux));
 249                end if;
 250
 251                Analyze (Decl);
 252
 253                --  Enter the debug variable in the qualification list, which
 254                --  must be done at this point because auxiliary declarations
 255                --  occur at the library level and aren't associated with a
 256                --  normal scope.
 257
 258                Qualify_Entity_Names (Decl);
 259
 260                Pop_Scope;
 261             end;
 262
 263          --  Otherwise, just insert after the package declaration
 264
 265          else
 266             Insert_Action (N, Decl);
 267          end if;
 268       end if;
 269    end Expand_N_Package_Renaming_Declaration;
 270
 271    ----------------------------------------------
 272    -- Expand_N_Subprogram_Renaming_Declaration --
 273    ----------------------------------------------
 274
 275    procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
 276       Loc : constant Source_Ptr := Sloc (N);
 277       Id  : constant Entity_Id  := Defining_Entity (N);
 278
 279       function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
 280       --  Build and return the body for the renaming declaration of an equality
 281       --  or inequality operator of type Typ.
 282
 283       -----------------------------
 284       -- Build_Body_For_Renaming --
 285       -----------------------------
 286
 287       function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
 288          Left    : constant Entity_Id := First_Formal (Id);
 289          Right   : constant Entity_Id := Next_Formal (Left);
 290          Body_Id : Entity_Id;
 291          Decl    : Node_Id;
 292
 293       begin
 294          Set_Alias (Id, Empty);
 295          Set_Has_Completion (Id, False);
 296          Rewrite (N,
 297            Make_Subprogram_Declaration (Sloc (N),
 298              Specification => Specification (N)));
 299          Set_Has_Delayed_Freeze (Id);
 300
 301          Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
 302          Set_Debug_Info_Needed (Body_Id);
 303
 304          if Has_Variant_Part (Typ) then
 305             Decl :=
 306               Build_Variant_Record_Equality
 307                 (Typ         => Typ,
 308                  Body_Id     => Body_Id,
 309                  Param_Specs => Copy_Parameter_List (Id));
 310
 311          --  Build body for renamed equality, to capture its current meaning.
 312          --  It may be redefined later, but the renaming is elaborated where
 313          --  it occurs. This is technically known as Squirreling semantics.
 314          --  Renaming is rewritten as a subprogram declaration, and the
 315          --  generated body is inserted into the freeze actions for the
 316          --  subprogram.
 317
 318          else
 319             Decl :=
 320               Make_Subprogram_Body (Loc,
 321                 Specification              =>
 322                   Make_Function_Specification (Loc,
 323                     Defining_Unit_Name       => Body_Id,
 324                     Parameter_Specifications => Copy_Parameter_List (Id),
 325                     Result_Definition        =>
 326                       New_Occurrence_Of (Standard_Boolean, Loc)),
 327                 Declarations               => Empty_List,
 328                 Handled_Statement_Sequence => Empty);
 329
 330             Set_Handled_Statement_Sequence (Decl,
 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                          Bodies => Declarations (Decl))))));
 341          end if;
 342
 343          return Decl;
 344       end Build_Body_For_Renaming;
 345
 346       --  Local variables
 347
 348       Nam : constant Node_Id := Name (N);
 349
 350    --  Start of processing for Expand_N_Subprogram_Renaming_Declaration
 351
 352    begin
 353       --  When the prefix of the name is a function call, we must force the
 354       --  call to be made by removing side effects from the call, since we
 355       --  must only call the function once.
 356
 357       if Nkind (Nam) = N_Selected_Component
 358         and then Nkind (Prefix (Nam)) = N_Function_Call
 359       then
 360          Remove_Side_Effects (Prefix (Nam));
 361
 362       --  For an explicit dereference, the prefix must be captured to prevent
 363       --  reevaluation on calls through the renaming, which could result in
 364       --  calling the wrong subprogram if the access value were to be changed.
 365
 366       elsif Nkind (Nam) = N_Explicit_Dereference then
 367          Force_Evaluation (Prefix (Nam));
 368       end if;
 369
 370       --  Handle cases where we build a body for a renamed equality
 371
 372       if Is_Entity_Name (Nam)
 373         and then Chars (Entity (Nam)) = Name_Op_Eq
 374         and then Scope (Entity (Nam)) = Standard_Standard
 375       then
 376          declare
 377             Typ  : constant Entity_Id := Etype (First_Formal (Id));
 378
 379          begin
 380             --  Check whether this is a renaming of a predefined equality on an
 381             --  untagged record type (AI05-0123).
 382
 383             if Ada_Version >= Ada_2012
 384               and then Is_Record_Type (Typ)
 385               and then not Is_Tagged_Type (Typ)
 386               and then not Is_Frozen (Typ)
 387             then
 388                Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
 389             end if;
 390          end;
 391       end if;
 392    end Expand_N_Subprogram_Renaming_Declaration;
 393
 394 end Exp_Ch8;