gcc/ada/exp_ch13.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ C H 1 3                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Exp_Ch3;  use Exp_Ch3;
  30 with Exp_Ch6;  use Exp_Ch6;
  31 with Exp_Imgv; use Exp_Imgv;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Restrict; use Restrict;
  39 with Rident;   use Rident;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Ch7;  use Sem_Ch7;
  43 with Sem_Ch8;  use Sem_Ch8;
  44 with Sem_Eval; use Sem_Eval;
  45 with Sem_Util; use Sem_Util;
  46 with Sinfo;    use Sinfo;
  47 with Snames;   use Snames;
  48 with Targparm; use Targparm;
  49 with Tbuild;   use Tbuild;
  50 with Uintp;    use Uintp;
  51 with Validsw;  use Validsw;
  52
  53 package body Exp_Ch13 is
  54
  55    ------------------------------------------
  56    -- Expand_N_Attribute_Definition_Clause --
  57    ------------------------------------------
  58
  59    --  Expansion action depends on attribute involved
  60
  61    procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
  62       Loc : constant Source_Ptr := Sloc (N);
  63       Exp : constant Node_Id    := Expression (N);
  64       Ent : Entity_Id;
  65       V   : Node_Id;
  66
  67    begin
  68       Ent := Entity (Name (N));
  69
  70       if Is_Type (Ent) then
  71          Ent := Underlying_Type (Ent);
  72       end if;
  73
  74       case Get_Attribute_Id (Chars (N)) is
  75
  76          -------------
  77          -- Address --
  78          -------------
  79
  80          when Attribute_Address =>
  81
  82             --  If there is an initialization which did not come from the
  83             --  source program, then it is an artifact of our expansion, and we
  84             --  suppress it. The case we are most concerned about here is the
  85             --  initialization of a packed array to all false, which seems
  86             --  inappropriate for variable to which an address clause is
  87             --  applied. The expression may itself have been rewritten if the
  88             --  type is packed array, so we need to examine whether the
  89             --  original node is in the source. An exception though is the case
  90             --  of an access variable which is default initialized to null, and
  91             --  such initialization is retained.
  92
  93             --  Furthermore, if the initialization is the equivalent aggregate
  94             --  of the type initialization procedure, it replaces an implicit
  95             --  call to the init proc, and must be respected. Note that for
  96             --  packed types we do not build equivalent aggregates.
  97
  98             --  Also, if Init_Or_Norm_Scalars applies, then we need to retain
  99             --  any default initialization for objects of scalar types and
 100             --  types with scalar components. Normally a composite type will
 101             --  have an init_proc in the presence of Init_Or_Norm_Scalars,
 102             --  so when that flag is set we have just have to do a test for
 103             --  scalar and string types (the predefined string types such as
 104             --  String and Wide_String don't have an init_proc).
 105
 106             declare
 107                Decl : constant Node_Id := Declaration_Node (Ent);
 108                Typ  : constant Entity_Id := Etype (Ent);
 109
 110             begin
 111                if Nkind (Decl) = N_Object_Declaration
 112                   and then Present (Expression (Decl))
 113                   and then Nkind (Expression (Decl)) /= N_Null
 114                   and then
 115                    not Comes_From_Source (Original_Node (Expression (Decl)))
 116                then
 117                   if Present (Base_Init_Proc (Typ))
 118                     and then
 119                       Present (Static_Initialization (Base_Init_Proc (Typ)))
 120                   then
 121                      null;
 122
 123                   elsif Init_Or_Norm_Scalars
 124                     and then
 125                       (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
 126                   then
 127                      null;
 128
 129                   else
 130                      Set_Expression (Decl, Empty);
 131                   end if;
 132
 133                --  An object declaration to which an address clause applies
 134                --  has a delayed freeze, but the address expression itself
 135                --  must be elaborated at the point it appears. If the object
 136                --  is controlled, additional checks apply elsewhere.
 137
 138                elsif Nkind (Decl) = N_Object_Declaration
 139                  and then not Needs_Constant_Address (Decl, Typ)
 140                then
 141                   Remove_Side_Effects (Exp);
 142                end if;
 143             end;
 144
 145          ---------------
 146          -- Alignment --
 147          ---------------
 148
 149          when Attribute_Alignment =>
 150
 151             --  As required by Gigi, we guarantee that the operand is an
 152             --  integer literal (this simplifies things in Gigi).
 153
 154             if Nkind (Exp) /= N_Integer_Literal then
 155                Rewrite
 156                  (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
 157             end if;
 158
 159          ------------------
 160          -- Storage_Size --
 161          ------------------
 162
 163          when Attribute_Storage_Size =>
 164
 165             --  If the type is a task type, then assign the value of the
 166             --  storage size to the Size variable associated with the task.
 167             --    task_typeZ := expression
 168
 169             if Ekind (Ent) = E_Task_Type then
 170                Insert_Action (N,
 171                  Make_Assignment_Statement (Loc,
 172                    Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
 173                    Expression =>
 174                      Convert_To (RTE (RE_Size_Type), Expression (N))));
 175
 176             --  For Storage_Size for an access type, create a variable to hold
 177             --  the value of the specified size with name typeV and expand an
 178             --  assignment statement to initialize this value.
 179
 180             elsif Is_Access_Type (Ent) then
 181
 182                --  We don't need the variable for a storage size of zero
 183
 184                if not No_Pool_Assigned (Ent) then
 185                   V :=
 186                     Make_Defining_Identifier (Loc,
 187                       Chars => New_External_Name (Chars (Ent), 'V'));
 188
 189                   --  Insert the declaration of the object
 190
 191                   Insert_Action (N,
 192                     Make_Object_Declaration (Loc,
 193                       Defining_Identifier => V,
 194                       Object_Definition  =>
 195                         New_Reference_To (RTE (RE_Storage_Offset), Loc),
 196                       Expression =>
 197                         Convert_To (RTE (RE_Storage_Offset), Expression (N))));
 198
 199                   Set_Storage_Size_Variable (Ent, Entity_Id (V));
 200                end if;
 201             end if;
 202
 203          --  Other attributes require no expansion
 204
 205          when others =>
 206             null;
 207
 208       end case;
 209    end Expand_N_Attribute_Definition_Clause;
 210
 211    -----------------------------
 212    -- Expand_N_Free_Statement --
 213    -----------------------------
 214
 215    procedure Expand_N_Free_Statement (N : Node_Id) is
 216       Expr : constant Node_Id := Expression (N);
 217       Typ  : Entity_Id;
 218
 219    begin
 220       --  Certain run-time configurations and targets do not provide support
 221       --  for controlled types.
 222
 223       if Restriction_Active (No_Finalization) then
 224          return;
 225
 226       --  Do not create a specialized Deallocate since .NET/JVM compilers do
 227       --  not support pools and address arithmetic.
 228
 229       elsif VM_Target /= No_VM then
 230          return;
 231       end if;
 232
 233       --  Use the base type to perform the check for finalization master
 234
 235       Typ := Etype (Expr);
 236
 237       if Ekind (Typ) = E_Access_Subtype then
 238          Typ := Etype (Typ);
 239       end if;
 240
 241       --  Handle private access types
 242
 243       if Is_Private_Type (Typ)
 244         and then Present (Full_View (Typ))
 245       then
 246          Typ := Full_View (Typ);
 247       end if;
 248
 249       --  Do not create a custom Deallocate when freeing an object with
 250       --  suppressed finalization. In such cases the object is never attached
 251       --  to a master, so it does not need to be detached. Use a regular free
 252       --  statement instead.
 253
 254       if No (Finalization_Master (Typ)) then
 255          return;
 256       end if;
 257
 258       --  Use a temporary to store the result of a complex expression. Perform
 259       --  the following transformation:
 260       --
 261       --     Free (Complex_Expression);
 262       --
 263       --     Temp : constant Type_Of_Expression := Complex_Expression;
 264       --     Free (Temp);
 265
 266       if Nkind (Expr) /= N_Identifier then
 267          declare
 268             Expr_Typ : constant Entity_Id  := Etype (Expr);
 269             Loc      : constant Source_Ptr := Sloc (N);
 270             New_Expr : Node_Id;
 271             Temp_Id  : Entity_Id;
 272
 273          begin
 274             Temp_Id := Make_Temporary (Loc, 'T');
 275             Insert_Action (N,
 276               Make_Object_Declaration (Loc,
 277                 Defining_Identifier => Temp_Id,
 278                 Object_Definition =>
 279                   New_Reference_To (Expr_Typ, Loc),
 280                 Expression =>
 281                   Relocate_Node (Expr)));
 282
 283             New_Expr := New_Reference_To (Temp_Id, Loc);
 284             Set_Etype (New_Expr, Expr_Typ);
 285
 286             Set_Expression (N, New_Expr);
 287          end;
 288       end if;
 289
 290       --  Create a custom Deallocate for a controlled object. This routine
 291       --  ensures that the hidden list header will be deallocated along with
 292       --  the actual object.
 293
 294       Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
 295    end Expand_N_Free_Statement;
 296
 297    ----------------------------
 298    -- Expand_N_Freeze_Entity --
 299    ----------------------------
 300
 301    procedure Expand_N_Freeze_Entity (N : Node_Id) is
 302       E              : constant Entity_Id := Entity (N);
 303       E_Scope        : Entity_Id;
 304       In_Other_Scope : Boolean;
 305       In_Outer_Scope : Boolean;
 306       Decl           : Node_Id;
 307       Delete         : Boolean := False;
 308
 309    begin
 310       --  If there are delayed aspect specifications, we insert them just
 311       --  before the freeze node. They are already analyzed so we don't need
 312       --  to reanalyze them (they were analyzed before the type was frozen),
 313       --  but we want them in the tree for the back end, and so that the
 314       --  listing from sprint is clearer on where these occur logically.
 315
 316       if Has_Delayed_Aspects (E) then
 317          declare
 318             Aitem : Node_Id;
 319             Ritem : Node_Id;
 320
 321          begin
 322             --  Look for aspect specs for this entity
 323
 324             Ritem := First_Rep_Item (E);
 325             while Present (Ritem) loop
 326                if Nkind (Ritem) = N_Aspect_Specification
 327                  and then Entity (Ritem) = E
 328                then
 329                   Aitem := Aspect_Rep_Item (Ritem);
 330
 331                   --  Skip this for aspects (e.g. Current_Value) for which
 332                   --  there is no corresponding pragma or attribute.
 333
 334                   if Present (Aitem) then
 335                      pragma Assert (Is_Delayed_Aspect (Aitem));
 336                      Insert_Before (N, Aitem);
 337                   end if;
 338                end if;
 339
 340                Next_Rep_Item (Ritem);
 341             end loop;
 342          end;
 343       end if;
 344
 345       --  Processing for objects with address clauses
 346
 347       if Is_Object (E) and then Present (Address_Clause (E)) then
 348          Apply_Address_Clause_Check (E, N);
 349          return;
 350
 351       --  Only other items requiring any front end action are types and
 352       --  subprograms.
 353
 354       elsif not Is_Type (E) and then not Is_Subprogram (E) then
 355          return;
 356       end if;
 357
 358       --  Here E is a type or a subprogram
 359
 360       E_Scope := Scope (E);
 361
 362       --  This is an error protection against previous errors
 363
 364       if No (E_Scope) then
 365          return;
 366       end if;
 367
 368       --  Remember that we are processing a freezing entity and its freezing
 369       --  nodes. This flag (non-zero = set) is used to avoid the need of
 370       --  climbing through the tree while processing the freezing actions (ie.
 371       --  to avoid generating spurious warnings or to avoid killing constant
 372       --  indications while processing the code associated with freezing
 373       --  actions). We use a counter to deal with nesting.
 374
 375       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
 376
 377       --  If we are freezing entities defined in protected types, they belong
 378       --  in the enclosing scope, given that the original type has been
 379       --  expanded away. The same is true for entities in task types, in
 380       --  particular the parameter records of entries (Entities in bodies are
 381       --  all frozen within the body). If we are in the task body, this is a
 382       --  proper scope. If we are within a subprogram body, the proper scope
 383       --  is the corresponding spec. This may happen for itypes generated in
 384       --  the bodies of protected operations.
 385
 386       if Ekind (E_Scope) = E_Protected_Type
 387         or else (Ekind (E_Scope) = E_Task_Type
 388                   and then not Has_Completion (E_Scope))
 389       then
 390          E_Scope := Scope (E_Scope);
 391
 392       elsif Ekind (E_Scope) = E_Subprogram_Body then
 393          E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
 394       end if;
 395
 396       --  If the scope of the entity is in open scopes, it is the current one
 397       --  or an enclosing one, including a loop, a block, or a subprogram.
 398
 399       if In_Open_Scopes (E_Scope) then
 400          In_Other_Scope := False;
 401          In_Outer_Scope := E_Scope /= Current_Scope;
 402
 403       --  Otherwise it is a local package or a different compilation unit
 404
 405       else
 406          In_Other_Scope := True;
 407          In_Outer_Scope := False;
 408       end if;
 409
 410       --  If the entity being frozen is defined in a scope that is not
 411       --  currently on the scope stack, we must establish the proper
 412       --  visibility before freezing the entity and related subprograms.
 413
 414       if In_Other_Scope then
 415          Push_Scope (E_Scope);
 416
 417          --  Finalizers are little odd in terms of freezing. The spec of the
 418          --  procedure appears in the declarations while the body appears in
 419          --  the statement part of a single construct. Since the finalizer must
 420          --  be called by the At_End handler of the construct, the spec is
 421          --  manually frozen right after its declaration. The only side effect
 422          --  of this action appears in contexts where the construct is not in
 423          --  its final resting place. These contexts are:
 424
 425          --    * Entry bodies - The declarations and statements are moved to
 426          --      the procedure equivalen of the entry.
 427          --    * Protected subprograms - The declarations and statements are
 428          --      moved to the non-protected version of the subprogram.
 429          --    * Task bodies - The declarations and statements are moved to the
 430          --      task body procedure.
 431
 432          --  Visible declarations do not need to be installed in these three
 433          --  cases since it does not make semantic sense to do so. All entities
 434          --  referenced by a finalizer are visible and already resolved, plus
 435          --  the enclosing scope may not have visible declarations at all.
 436
 437          if Ekind (E) = E_Procedure
 438            and then Is_Finalizer (E)
 439            and then
 440              (Is_Entry (E_Scope)
 441                 or else (Is_Subprogram (E_Scope)
 442                            and then Is_Protected_Type (Scope (E_Scope)))
 443                 or else Is_Task_Type (E_Scope))
 444          then
 445             null;
 446          else
 447             Install_Visible_Declarations (E_Scope);
 448          end if;
 449
 450          if Is_Package_Or_Generic_Package (E_Scope) or else
 451             Is_Protected_Type (E_Scope)             or else
 452             Is_Task_Type (E_Scope)
 453          then
 454             Install_Private_Declarations (E_Scope);
 455          end if;
 456
 457       --  If the entity is in an outer scope, then that scope needs to
 458       --  temporarily become the current scope so that operations created
 459       --  during type freezing will be declared in the right scope and
 460       --  can properly override any corresponding inherited operations.
 461
 462       elsif In_Outer_Scope then
 463          Push_Scope (E_Scope);
 464       end if;
 465
 466       --  If type, freeze the type
 467
 468       if Is_Type (E) then
 469          Delete := Freeze_Type (N);
 470
 471          --  And for enumeration type, build the enumeration tables
 472
 473          if Is_Enumeration_Type (E) then
 474             Build_Enumeration_Image_Tables (E, N);
 475          end if;
 476
 477       --  If subprogram, freeze the subprogram
 478
 479       elsif Is_Subprogram (E) then
 480          Freeze_Subprogram (N);
 481
 482          --  Ada 2005 (AI-251): Remove the freezing node associated with the
 483          --  entities internally used by the frontend to register primitives
 484          --  covering abstract interfaces. The call to Freeze_Subprogram has
 485          --  already expanded the code that fills the corresponding entry in
 486          --  its secondary dispatch table and therefore the code generator
 487          --  has nothing else to do with this freezing node.
 488
 489          Delete := Present (Interface_Alias (E));
 490       end if;
 491
 492       --  Analyze actions generated by freezing. The init_proc contains source
 493       --  expressions that may raise Constraint_Error, and the assignment
 494       --  procedure for complex types needs checks on individual component
 495       --  assignments, but all other freezing actions should be compiled with
 496       --  all checks off.
 497
 498       if Present (Actions (N)) then
 499          Decl := First (Actions (N));
 500          while Present (Decl) loop
 501             if Nkind (Decl) = N_Subprogram_Body
 502               and then (Is_Init_Proc (Defining_Entity (Decl))
 503                           or else
 504                             Chars (Defining_Entity (Decl)) = Name_uAssign)
 505             then
 506                Analyze (Decl);
 507
 508             --  A subprogram body created for a renaming_as_body completes
 509             --  a previous declaration, which may be in a different scope.
 510             --  Establish the proper scope before analysis.
 511
 512             elsif Nkind (Decl) = N_Subprogram_Body
 513               and then Present (Corresponding_Spec (Decl))
 514               and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
 515             then
 516                Push_Scope (Scope (Corresponding_Spec (Decl)));
 517                Analyze (Decl, Suppress => All_Checks);
 518                Pop_Scope;
 519
 520             --  We treat generated equality specially, if validity checks are
 521             --  enabled, in order to detect components default-initialized
 522             --  with invalid values.
 523
 524             elsif Nkind (Decl) = N_Subprogram_Body
 525               and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
 526               and then Validity_Checks_On
 527               and then Initialize_Scalars
 528             then
 529                declare
 530                   Save_Force : constant Boolean := Force_Validity_Checks;
 531                begin
 532                   Force_Validity_Checks := True;
 533                   Analyze (Decl);
 534                   Force_Validity_Checks := Save_Force;
 535                end;
 536
 537             else
 538                Analyze (Decl, Suppress => All_Checks);
 539             end if;
 540
 541             Next (Decl);
 542          end loop;
 543       end if;
 544
 545       --  If we are to delete this N_Freeze_Entity, do so by rewriting so that
 546       --  a loop on all nodes being inserted will work propertly.
 547
 548       if Delete then
 549          Rewrite (N, Make_Null_Statement (Sloc (N)));
 550       end if;
 551
 552       --  Pop scope if we installed one for the analysis
 553
 554       if In_Other_Scope then
 555          if Ekind (Current_Scope) = E_Package then
 556             End_Package_Scope (E_Scope);
 557          else
 558             End_Scope;
 559          end if;
 560
 561       elsif In_Outer_Scope then
 562          Pop_Scope;
 563       end if;
 564
 565       --  Restore previous value of the nesting-level counter that records
 566       --  whether we are inside a (possibly nested) call to this procedure.
 567
 568       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
 569    end Expand_N_Freeze_Entity;
 570
 571    -------------------------------------------
 572    -- Expand_N_Record_Representation_Clause --
 573    -------------------------------------------
 574
 575    --  The only expansion required is for the case of a mod clause present,
 576    --  which is removed, and translated into an alignment representation
 577    --  clause inserted immediately after the record rep clause with any
 578    --  initial pragmas inserted at the start of the component clause list.
 579
 580    procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
 581       Loc     : constant Source_Ptr := Sloc (N);
 582       Rectype : constant Entity_Id  := Entity (Identifier (N));
 583       Mod_Val : Uint;
 584       Citems  : List_Id;
 585       Repitem : Node_Id;
 586       AtM_Nod : Node_Id;
 587
 588    begin
 589       if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
 590          Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
 591          Citems  := Pragmas_Before (Mod_Clause (N));
 592
 593          if Present (Citems) then
 594             Append_List_To (Citems, Component_Clauses (N));
 595             Set_Component_Clauses (N, Citems);
 596          end if;
 597
 598          AtM_Nod :=
 599            Make_Attribute_Definition_Clause (Loc,
 600              Name       => New_Reference_To (Base_Type (Rectype), Loc),
 601              Chars      => Name_Alignment,
 602              Expression => Make_Integer_Literal (Loc, Mod_Val));
 603
 604          Set_From_At_Mod (AtM_Nod);
 605          Insert_After (N, AtM_Nod);
 606          Set_Mod_Clause (N, Empty);
 607       end if;
 608
 609       --  If the record representation clause has no components, then
 610       --  completely remove it.  Note that we also have to remove
 611       --  ourself from the Rep Item list.
 612
 613       if Is_Empty_List (Component_Clauses (N)) then
 614          if First_Rep_Item (Rectype) = N then
 615             Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
 616          else
 617             Repitem := First_Rep_Item (Rectype);
 618             while Present (Next_Rep_Item (Repitem)) loop
 619                if Next_Rep_Item (Repitem) = N then
 620                   Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
 621                   exit;
 622                end if;
 623
 624                Next_Rep_Item (Repitem);
 625             end loop;
 626          end if;
 627
 628          Rewrite (N,
 629            Make_Null_Statement (Loc));
 630       end if;
 631    end Expand_N_Record_Representation_Clause;
 632
 633 end Exp_Ch13;