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-2010, 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 Rtsfind;  use Rtsfind;
  39 with Sem;      use Sem;
  40 with Sem_Ch7;  use Sem_Ch7;
  41 with Sem_Ch8;  use Sem_Ch8;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Util; use Sem_Util;
  44 with Sinfo;    use Sinfo;
  45 with Snames;   use Snames;
  46 with Stand;    use Stand;
  47 with Tbuild;   use Tbuild;
  48 with Uintp;    use Uintp;
  49 with Validsw;  use Validsw;
  50
  51 package body Exp_Ch13 is
  52
  53    ------------------------------------------
  54    -- Expand_N_Attribute_Definition_Clause --
  55    ------------------------------------------
  56
  57    --  Expansion action depends on attribute involved
  58
  59    procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
  60       Loc : constant Source_Ptr := Sloc (N);
  61       Exp : constant Node_Id    := Expression (N);
  62       Ent : Entity_Id;
  63       V   : Node_Id;
  64
  65    begin
  66       Ent := Entity (Name (N));
  67
  68       if Is_Type (Ent) then
  69          Ent := Underlying_Type (Ent);
  70       end if;
  71
  72       case Get_Attribute_Id (Chars (N)) is
  73
  74          -------------
  75          -- Address --
  76          -------------
  77
  78          when Attribute_Address =>
  79
  80             --  If there is an initialization which did not come from the
  81             --  source program, then it is an artifact of our expansion, and we
  82             --  suppress it. The case we are most concerned about here is the
  83             --  initialization of a packed array to all false, which seems
  84             --  inappropriate for variable to which an address clause is
  85             --  applied. The expression may itself have been rewritten if the
  86             --  type is packed array, so we need to examine whether the
  87             --  original node is in the source. An exception though is the case
  88             --  of an access variable which is default initialized to null, and
  89             --  such initialization is retained.
  90
  91             --  Furthermore, if the initialization is the equivalent aggregate
  92             --  of the type initialization procedure, it replaces an implicit
  93             --  call to the init proc, and must be respected. Note that for
  94             --  packed types we do not build equivalent aggregates.
  95
  96             --  Also, if Init_Or_Norm_Scalars applies, then we need to retain
  97             --  any default initialization for objects of scalar types and
  98             --  types with scalar components. Normally a composite type will
  99             --  have an init_proc in the presence of Init_Or_Norm_Scalars,
 100             --  so when that flag is set we have just have to do a test for
 101             --  scalar and string types (the predefined string types such as
 102             --  String and Wide_String don't have an init_proc).
 103
 104             declare
 105                Decl : constant Node_Id := Declaration_Node (Ent);
 106                Typ  : constant Entity_Id := Etype (Ent);
 107
 108             begin
 109                if Nkind (Decl) = N_Object_Declaration
 110                   and then Present (Expression (Decl))
 111                   and then Nkind (Expression (Decl)) /= N_Null
 112                   and then
 113                    not Comes_From_Source (Original_Node (Expression (Decl)))
 114                then
 115                   if Present (Base_Init_Proc (Typ))
 116                     and then
 117                       Present (Static_Initialization (Base_Init_Proc (Typ)))
 118                   then
 119                      null;
 120
 121                   elsif Init_Or_Norm_Scalars
 122                     and then
 123                       (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
 124                   then
 125                      null;
 126
 127                   else
 128                      Set_Expression (Decl, Empty);
 129                   end if;
 130
 131                --  An object declaration to which an address clause applies
 132                --  has a delayed freeze, but the address expression itself
 133                --  must be elaborated at the point it appears. If the object
 134                --  is controlled, additional checks apply elsewhere.
 135
 136                elsif Nkind (Decl) = N_Object_Declaration
 137                  and then not Needs_Constant_Address (Decl, Typ)
 138                then
 139                   Remove_Side_Effects (Exp);
 140                end if;
 141             end;
 142
 143          ---------------
 144          -- Alignment --
 145          ---------------
 146
 147          when Attribute_Alignment =>
 148
 149             --  As required by Gigi, we guarantee that the operand is an
 150             --  integer literal (this simplifies things in Gigi).
 151
 152             if Nkind (Exp) /= N_Integer_Literal then
 153                Rewrite
 154                  (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
 155             end if;
 156
 157          ------------------
 158          -- Storage_Size --
 159          ------------------
 160
 161          when Attribute_Storage_Size =>
 162
 163             --  If the type is a task type, then assign the value of the
 164             --  storage size to the Size variable associated with the task.
 165             --    task_typeZ := expression
 166
 167             if Ekind (Ent) = E_Task_Type then
 168                Insert_Action (N,
 169                  Make_Assignment_Statement (Loc,
 170                    Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
 171                    Expression =>
 172                      Convert_To (RTE (RE_Size_Type), Expression (N))));
 173
 174             --  For Storage_Size for an access type, create a variable to hold
 175             --  the value of the specified size with name typeV and expand an
 176             --  assignment statement to initialize this value.
 177
 178             elsif Is_Access_Type (Ent) then
 179
 180                --  We don't need the variable for a storage size of zero
 181
 182                if not No_Pool_Assigned (Ent) then
 183                   V :=
 184                     Make_Defining_Identifier (Loc,
 185                       Chars => New_External_Name (Chars (Ent), 'V'));
 186
 187                   --  Insert the declaration of the object
 188
 189                   Insert_Action (N,
 190                     Make_Object_Declaration (Loc,
 191                       Defining_Identifier => V,
 192                       Object_Definition  =>
 193                         New_Reference_To (RTE (RE_Storage_Offset), Loc),
 194                       Expression =>
 195                         Convert_To (RTE (RE_Storage_Offset), Expression (N))));
 196
 197                   Set_Storage_Size_Variable (Ent, Entity_Id (V));
 198                end if;
 199             end if;
 200
 201          --  Other attributes require no expansion
 202
 203          when others =>
 204             null;
 205
 206       end case;
 207    end Expand_N_Attribute_Definition_Clause;
 208
 209    ----------------------------
 210    -- Expand_N_Freeze_Entity --
 211    ----------------------------
 212
 213    procedure Expand_N_Freeze_Entity (N : Node_Id) is
 214       E              : constant Entity_Id := Entity (N);
 215       E_Scope        : Entity_Id;
 216       S              : Entity_Id;
 217       In_Other_Scope : Boolean;
 218       In_Outer_Scope : Boolean;
 219       Decl           : Node_Id;
 220       Delete         : Boolean := False;
 221
 222    begin
 223       --  If there are delayed aspect specifications, we insert them just
 224       --  before the freeze node. They are already analyzed so we don't need
 225       --  to reanalyze them (they were analyzed before the type was frozen),
 226       --  but we want them in the tree for the back end, and so that the
 227       --  listing from sprint is clearer on where these occur logically.
 228
 229       if Has_Delayed_Aspects (E) then
 230          declare
 231             Aitem : Node_Id;
 232             Ritem : Node_Id;
 233
 234          begin
 235             --  Look for aspect specs for this entity
 236
 237             Ritem := First_Rep_Item (E);
 238             while Present (Ritem) loop
 239                if Nkind (Ritem) = N_Aspect_Specification
 240                  and then Entity (Ritem) = E
 241                then
 242                   Aitem := Aspect_Rep_Item (Ritem);
 243
 244                   --  Skip this for aspects (e.g. Current_Value) for which
 245                   --  there is no corresponding pragma or attribute.
 246
 247                   if Present (Aitem) then
 248                      pragma Assert (Is_Delayed_Aspect (Aitem));
 249                      Insert_Before (N, Aitem);
 250                   end if;
 251                end if;
 252
 253                Next_Rep_Item (Ritem);
 254             end loop;
 255          end;
 256       end if;
 257
 258       --  Processing for objects with address clauses
 259
 260       if Is_Object (E) and then Present (Address_Clause (E)) then
 261          Apply_Address_Clause_Check (E, N);
 262          return;
 263
 264       --  Only other items requiring any front end action are types and
 265       --  subprograms.
 266
 267       elsif not Is_Type (E) and then not Is_Subprogram (E) then
 268          return;
 269       end if;
 270
 271       --  Here E is a type or a subprogram
 272
 273       E_Scope := Scope (E);
 274
 275       --  This is an error protection against previous errors
 276
 277       if No (E_Scope) then
 278          return;
 279       end if;
 280
 281       --  Remember that we are processing a freezing entity and its freezing
 282       --  nodes. This flag (non-zero = set) is used to avoid the need of
 283       --  climbing through the tree while processing the freezing actions (ie.
 284       --  to avoid generating spurious warnings or to avoid killing constant
 285       --  indications while processing the code associated with freezing
 286       --  actions). We use a counter to deal with nesting.
 287
 288       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
 289
 290       --  If we are freezing entities defined in protected types, they belong
 291       --  in the enclosing scope, given that the original type has been
 292       --  expanded away. The same is true for entities in task types, in
 293       --  particular the parameter records of entries (Entities in bodies are
 294       --  all frozen within the body). If we are in the task body, this is a
 295       --  proper scope. If we are within a subprogram body, the proper scope
 296       --  is the corresponding spec. This may happen for itypes generated in
 297       --  the bodies of protected operations.
 298
 299       if Ekind (E_Scope) = E_Protected_Type
 300         or else (Ekind (E_Scope) = E_Task_Type
 301                   and then not Has_Completion (E_Scope))
 302       then
 303          E_Scope := Scope (E_Scope);
 304
 305       elsif Ekind (E_Scope) = E_Subprogram_Body then
 306          E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
 307       end if;
 308
 309       S := Current_Scope;
 310       while S /= Standard_Standard and then S /= E_Scope loop
 311          S := Scope (S);
 312       end loop;
 313
 314       In_Other_Scope := not (S = E_Scope);
 315       In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
 316
 317       --  If the entity being frozen is defined in a scope that is not
 318       --  currently on the scope stack, we must establish the proper
 319       --  visibility before freezing the entity and related subprograms.
 320
 321       if In_Other_Scope then
 322          Push_Scope (E_Scope);
 323          Install_Visible_Declarations (E_Scope);
 324
 325          if Is_Package_Or_Generic_Package (E_Scope) or else
 326             Is_Protected_Type (E_Scope)             or else
 327             Is_Task_Type (E_Scope)
 328          then
 329             Install_Private_Declarations (E_Scope);
 330          end if;
 331
 332       --  If the entity is in an outer scope, then that scope needs to
 333       --  temporarily become the current scope so that operations created
 334       --  during type freezing will be declared in the right scope and
 335       --  can properly override any corresponding inherited operations.
 336
 337       elsif In_Outer_Scope then
 338          Push_Scope (E_Scope);
 339       end if;
 340
 341       --  If type, freeze the type
 342
 343       if Is_Type (E) then
 344          Delete := Freeze_Type (N);
 345
 346          --  And for enumeration type, build the enumeration tables
 347
 348          if Is_Enumeration_Type (E) then
 349             Build_Enumeration_Image_Tables (E, N);
 350          end if;
 351
 352       --  If subprogram, freeze the subprogram
 353
 354       elsif Is_Subprogram (E) then
 355          Freeze_Subprogram (N);
 356
 357          --  Ada 2005 (AI-251): Remove the freezing node associated with the
 358          --  entities internally used by the frontend to register primitives
 359          --  covering abstract interfaces. The call to Freeze_Subprogram has
 360          --  already expanded the code that fills the corresponding entry in
 361          --  its secondary dispatch table and therefore the code generator
 362          --  has nothing else to do with this freezing node.
 363
 364          Delete := Present (Interface_Alias (E));
 365       end if;
 366
 367       --  Analyze actions generated by freezing. The init_proc contains source
 368       --  expressions that may raise Constraint_Error, and the assignment
 369       --  procedure for complex types needs checks on individual component
 370       --  assignments, but all other freezing actions should be compiled with
 371       --  all checks off.
 372
 373       if Present (Actions (N)) then
 374          Decl := First (Actions (N));
 375          while Present (Decl) loop
 376             if Nkind (Decl) = N_Subprogram_Body
 377               and then (Is_Init_Proc (Defining_Entity (Decl))
 378                           or else
 379                             Chars (Defining_Entity (Decl)) = Name_uAssign)
 380             then
 381                Analyze (Decl);
 382
 383             --  A subprogram body created for a renaming_as_body completes
 384             --  a previous declaration, which may be in a different scope.
 385             --  Establish the proper scope before analysis.
 386
 387             elsif Nkind (Decl) = N_Subprogram_Body
 388               and then Present (Corresponding_Spec (Decl))
 389               and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
 390             then
 391                Push_Scope (Scope (Corresponding_Spec (Decl)));
 392                Analyze (Decl, Suppress => All_Checks);
 393                Pop_Scope;
 394
 395             --  We treat generated equality specially, if validity checks are
 396             --  enabled, in order to detect components default-initialized
 397             --  with invalid values.
 398
 399             elsif Nkind (Decl) = N_Subprogram_Body
 400               and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
 401               and then Validity_Checks_On
 402               and then Initialize_Scalars
 403             then
 404                declare
 405                   Save_Force : constant Boolean := Force_Validity_Checks;
 406                begin
 407                   Force_Validity_Checks := True;
 408                   Analyze (Decl);
 409                   Force_Validity_Checks := Save_Force;
 410                end;
 411
 412             else
 413                Analyze (Decl, Suppress => All_Checks);
 414             end if;
 415
 416             Next (Decl);
 417          end loop;
 418       end if;
 419
 420       --  If we are to delete this N_Freeze_Entity, do so by rewriting so that
 421       --  a loop on all nodes being inserted will work propertly.
 422
 423       if Delete then
 424          Rewrite (N, Make_Null_Statement (Sloc (N)));
 425       end if;
 426
 427       --  Pop scope if we installed one for the analysis
 428
 429       if In_Other_Scope then
 430          if Ekind (Current_Scope) = E_Package then
 431             End_Package_Scope (E_Scope);
 432          else
 433             End_Scope;
 434          end if;
 435
 436       elsif In_Outer_Scope then
 437          Pop_Scope;
 438       end if;
 439
 440       --  Restore previous value of the nesting-level counter that records
 441       --  whether we are inside a (possibly nested) call to this procedure.
 442
 443       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
 444    end Expand_N_Freeze_Entity;
 445
 446    -------------------------------------------
 447    -- Expand_N_Record_Representation_Clause --
 448    -------------------------------------------
 449
 450    --  The only expansion required is for the case of a mod clause present,
 451    --  which is removed, and translated into an alignment representation
 452    --  clause inserted immediately after the record rep clause with any
 453    --  initial pragmas inserted at the start of the component clause list.
 454
 455    procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
 456       Loc     : constant Source_Ptr := Sloc (N);
 457       Rectype : constant Entity_Id  := Entity (Identifier (N));
 458       Mod_Val : Uint;
 459       Citems  : List_Id;
 460       Repitem : Node_Id;
 461       AtM_Nod : Node_Id;
 462
 463    begin
 464       if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
 465          Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
 466          Citems  := Pragmas_Before (Mod_Clause (N));
 467
 468          if Present (Citems) then
 469             Append_List_To (Citems, Component_Clauses (N));
 470             Set_Component_Clauses (N, Citems);
 471          end if;
 472
 473          AtM_Nod :=
 474            Make_Attribute_Definition_Clause (Loc,
 475              Name       => New_Reference_To (Base_Type (Rectype), Loc),
 476              Chars      => Name_Alignment,
 477              Expression => Make_Integer_Literal (Loc, Mod_Val));
 478
 479          Set_From_At_Mod (AtM_Nod);
 480          Insert_After (N, AtM_Nod);
 481          Set_Mod_Clause (N, Empty);
 482       end if;
 483
 484       --  If the record representation clause has no components, then
 485       --  completely remove it.  Note that we also have to remove
 486       --  ourself from the Rep Item list.
 487
 488       if Is_Empty_List (Component_Clauses (N)) then
 489          if First_Rep_Item (Rectype) = N then
 490             Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
 491          else
 492             Repitem := First_Rep_Item (Rectype);
 493             while Present (Next_Rep_Item (Repitem)) loop
 494                if Next_Rep_Item (Repitem) = N then
 495                   Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
 496                   exit;
 497                end if;
 498
 499                Next_Rep_Item (Repitem);
 500             end loop;
 501          end if;
 502
 503          Rewrite (N,
 504            Make_Null_Statement (Loc));
 505       end if;
 506    end Expand_N_Record_Representation_Clause;
 507
 508 end Exp_Ch13;