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