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