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