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