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-2006, 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 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 Stringt;  use Stringt;
  47 with Tbuild;   use Tbuild;
  48 with Uintp;    use Uintp;
  49
  50 package body Exp_Ch13 is
  51
  52    procedure Expand_External_Tag_Definition (N : Node_Id);
  53    --  The code to assign and register an external tag must be elaborated
  54    --  after the dispatch table has been created, so the expansion of the
  55    --  attribute definition node is delayed until after the type is frozen.
  56
  57    ------------------------------------------
  58    -- Expand_N_Attribute_Definition_Clause --
  59    ------------------------------------------
  60
  61    --  Expansion action depends on attribute involved
  62
  63    procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
  64       Loc : constant Source_Ptr := Sloc (N);
  65       Exp : constant Node_Id    := Expression (N);
  66       Ent : Entity_Id;
  67       V   : Node_Id;
  68
  69    begin
  70       Ent := Entity (Name (N));
  71
  72       if Is_Type (Ent) then
  73          Ent := Underlying_Type (Ent);
  74       end if;
  75
  76       case Get_Attribute_Id (Chars (N)) is
  77
  78          -------------
  79          -- Address --
  80          -------------
  81
  82          when Attribute_Address =>
  83
  84             --  If there is an initialization which did not come from the
  85             --  source program, then it is an artifact of our expansion, and we
  86             --  suppress it. The case we are most concerned about here is the
  87             --  initialization of a packed array to all false, which seems
  88             --  inappropriate for variable to which an address clause is
  89             --  applied. The expression may itself have been rewritten if the
  90             --  type is packed array, so we need to examine whether the
  91             --  original node is in the source.
  92
  93             declare
  94                Decl : constant Node_Id := Declaration_Node (Ent);
  95             begin
  96                if Nkind (Decl) = N_Object_Declaration
  97                   and then Present (Expression (Decl))
  98                   and then
  99                    not Comes_From_Source (Original_Node (Expression (Decl)))
 100                then
 101                   Set_Expression (Decl, Empty);
 102                end if;
 103             end;
 104
 105          ---------------
 106          -- Alignment --
 107          ---------------
 108
 109          when Attribute_Alignment =>
 110
 111             --  As required by Gigi, we guarantee that the operand is an
 112             --  integer literal (this simplifies things in Gigi).
 113
 114             if Nkind (Exp) /= N_Integer_Literal then
 115                Rewrite
 116                  (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
 117             end if;
 118
 119          ------------------
 120          -- Storage_Size --
 121          ------------------
 122
 123          when Attribute_Storage_Size =>
 124
 125             --  If the type is a task type, then assign the value of the
 126             --  storage size to the Size variable associated with the task.
 127             --    task_typeZ := expression
 128
 129             if Ekind (Ent) = E_Task_Type then
 130                Insert_Action (N,
 131                  Make_Assignment_Statement (Loc,
 132                    Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
 133                    Expression =>
 134                      Convert_To (RTE (RE_Size_Type), Expression (N))));
 135
 136             --  For Storage_Size for an access type, create a variable to hold
 137             --  the value of the specified size with name typeV and expand an
 138             --  assignment statement to initialze this value.
 139
 140             elsif Is_Access_Type (Ent) then
 141                V := Make_Defining_Identifier (Loc,
 142                       New_External_Name (Chars (Ent), 'V'));
 143
 144                Insert_Action (N,
 145                  Make_Object_Declaration (Loc,
 146                    Defining_Identifier => V,
 147                    Object_Definition  =>
 148                      New_Reference_To (RTE (RE_Storage_Offset), Loc),
 149                    Expression =>
 150                      Convert_To (RTE (RE_Storage_Offset), Expression (N))));
 151
 152                Set_Storage_Size_Variable (Ent, Entity_Id (V));
 153             end if;
 154
 155          --  Other attributes require no expansion
 156
 157          when others =>
 158             null;
 159
 160       end case;
 161
 162    end Expand_N_Attribute_Definition_Clause;
 163
 164    -------------------------------------
 165    -- Expand_External_Tag_Definition --
 166    -------------------------------------
 167
 168    procedure Expand_External_Tag_Definition (N : Node_Id) is
 169       Loc     : constant Source_Ptr := Sloc (N);
 170       Ent     : constant Entity_Id  := Entity (Name (N));
 171       Old_Val : constant String_Id  := Strval (Expr_Value_S (Expression (N)));
 172       New_Val : String_Id;
 173       E       : Entity_Id;
 174
 175    begin
 176       --  For the rep clause "for x'external_tag use y" generate:
 177
 178       --     xV : constant string := y;
 179       --     Set_External_Tag (x'tag, xV'Address);
 180       --     Register_Tag (x'tag);
 181
 182       --  note that register_tag has been delayed up to now because
 183       --  the external_tag must be set before registering.
 184
 185       --  Create a new nul terminated string if it is not already
 186
 187       if String_Length (Old_Val) > 0
 188         and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
 189       then
 190          New_Val := Old_Val;
 191       else
 192          Start_String (Old_Val);
 193          Store_String_Char (Get_Char_Code (ASCII.NUL));
 194          New_Val := End_String;
 195       end if;
 196
 197       E :=
 198         Make_Defining_Identifier (Loc,
 199           New_External_Name (Chars (Ent), 'A'));
 200
 201       --  The generated actions must be elaborated at the subsequent
 202       --  freeze point, not at the point of the attribute definition.
 203
 204       Append_Freeze_Action (Ent,
 205         Make_Object_Declaration (Loc,
 206           Defining_Identifier => E,
 207           Constant_Present    => True,
 208           Object_Definition   =>
 209             New_Reference_To (Standard_String, Loc),
 210           Expression          =>
 211             Make_String_Literal (Loc, Strval => New_Val)));
 212
 213       Append_Freeze_Actions (Ent, New_List (
 214         Make_Procedure_Call_Statement (Loc,
 215           Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
 216           Parameter_Associations => New_List (
 217             Make_Attribute_Reference (Loc,
 218               Attribute_Name => Name_Tag,
 219               Prefix         => New_Occurrence_Of (Ent, Loc)),
 220
 221             Make_Attribute_Reference (Loc,
 222               Attribute_Name => Name_Address,
 223               Prefix         => New_Occurrence_Of (E, Loc)))),
 224
 225         Make_Procedure_Call_Statement (Loc,
 226           Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
 227           Parameter_Associations => New_List (
 228             Make_Attribute_Reference (Loc,
 229               Attribute_Name => Name_Tag,
 230               Prefix         => New_Occurrence_Of (Ent, Loc))))));
 231    end Expand_External_Tag_Definition;
 232
 233    ----------------------------
 234    -- Expand_N_Freeze_Entity --
 235    ----------------------------
 236
 237    procedure Expand_N_Freeze_Entity (N : Node_Id) is
 238       E              : constant Entity_Id := Entity (N);
 239       E_Scope        : Entity_Id;
 240       S              : Entity_Id;
 241       In_Other_Scope : Boolean;
 242       In_Outer_Scope : Boolean;
 243       Decl           : Node_Id;
 244       Delete         : Boolean := False;
 245
 246    begin
 247       --  Processing for objects with address clauses
 248
 249       if Is_Object (E) and then Present (Address_Clause (E)) then
 250          Apply_Address_Clause_Check (E, N);
 251          return;
 252
 253       --  Only other items requiring any front end action are types and
 254       --  subprograms.
 255
 256       elsif not Is_Type (E) and then not Is_Subprogram (E) then
 257          return;
 258       end if;
 259
 260       --  Here E is a type or a subprogram
 261
 262       E_Scope := Scope (E);
 263
 264       --  This is an error protection against previous errors
 265
 266       if No (E_Scope) then
 267          return;
 268       end if;
 269
 270       --  If we are freezing entities defined in protected types, they belong
 271       --  in the enclosing scope, given that the original type has been
 272       --  expanded away. The same is true for entities in task types, in
 273       --  particular the parameter records of entries (Entities in bodies are
 274       --  all frozen within the body). If we are in the task body, this is a
 275       --  proper scope.
 276
 277       if Ekind (E_Scope) = E_Protected_Type
 278         or else (Ekind (E_Scope) = E_Task_Type
 279                    and then not Has_Completion (E_Scope))
 280       then
 281          E_Scope := Scope (E_Scope);
 282       end if;
 283
 284       S := Current_Scope;
 285       while S /= Standard_Standard and then S /= E_Scope loop
 286          S := Scope (S);
 287       end loop;
 288
 289       In_Other_Scope := not (S = E_Scope);
 290       In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
 291
 292       --  If the entity being frozen is defined in a scope that is not
 293       --  currently on the scope stack, we must establish the proper
 294       --  visibility before freezing the entity and related subprograms.
 295
 296       if In_Other_Scope then
 297          New_Scope (E_Scope);
 298          Install_Visible_Declarations (E_Scope);
 299
 300          if Ekind (E_Scope) = E_Package         or else
 301             Ekind (E_Scope) = E_Generic_Package or else
 302             Is_Protected_Type (E_Scope)         or else
 303             Is_Task_Type (E_Scope)
 304          then
 305             Install_Private_Declarations (E_Scope);
 306          end if;
 307
 308       --  If the entity is in an outer scope, then that scope needs to
 309       --  temporarily become the current scope so that operations created
 310       --  during type freezing will be declared in the right scope and
 311       --  can properly override any corresponding inherited operations.
 312
 313       elsif In_Outer_Scope then
 314          New_Scope (E_Scope);
 315       end if;
 316
 317       --  If type, freeze the type
 318
 319       if Is_Type (E) then
 320          Delete := Freeze_Type (N);
 321
 322          --  And for enumeration type, build the enumeration tables
 323
 324          if Is_Enumeration_Type (E) then
 325             Build_Enumeration_Image_Tables (E, N);
 326
 327          elsif Is_Tagged_Type (E)
 328            and then Is_First_Subtype (E)
 329          then
 330             --  Check for a definition of External_Tag, whose expansion must
 331             --  be delayed until the dispatch table is built. The clause
 332             --  is considered only if it applies to this specific tagged
 333             --  type, as opposed to one of its ancestors.
 334
 335             declare
 336                Def : constant Node_Id :=
 337                        Get_Attribute_Definition_Clause
 338                          (E, Attribute_External_Tag);
 339
 340             begin
 341                if Present (Def) and then Entity (Name (Def)) = E then
 342                   Expand_External_Tag_Definition (Def);
 343                end if;
 344             end;
 345          end if;
 346
 347       --  If subprogram, freeze the subprogram
 348
 349       elsif Is_Subprogram (E) then
 350          Freeze_Subprogram (N);
 351
 352          --  Ada 2005 (AI-251): Remove the freezing node associated with the
 353          --  entities internally used by the frontend to register primitives
 354          --  covering abstract interfaces. The call to Freeze_Subprogram has
 355          --  already expanded the code that fills the corresponding entry in
 356          --  its secondary dispatch table and therefore the code generator
 357          --  has nothing else to do with this freezing node.
 358
 359          Delete := Present (Abstract_Interface_Alias (E));
 360       end if;
 361
 362       --  Analyze actions generated by freezing. The init_proc contains source
 363       --  expressions that may raise Constraint_Error, and the assignment
 364       --  procedure for complex types needs checks on individual component
 365       --  assignments, but all other freezing actions should be compiled with
 366       --  all checks off.
 367
 368       if Present (Actions (N)) then
 369          Decl := First (Actions (N));
 370          while Present (Decl) loop
 371             if Nkind (Decl) = N_Subprogram_Body
 372               and then (Is_Init_Proc (Defining_Entity (Decl))
 373                           or else
 374                             Chars (Defining_Entity (Decl)) = Name_uAssign)
 375             then
 376                Analyze (Decl);
 377
 378             --  A subprogram body created for a renaming_as_body completes
 379             --  a previous declaration, which may be in a different scope.
 380             --  Establish the proper scope before analysis.
 381
 382             elsif Nkind (Decl) = N_Subprogram_Body
 383               and then Present (Corresponding_Spec (Decl))
 384               and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
 385             then
 386                New_Scope (Scope (Corresponding_Spec (Decl)));
 387                Analyze (Decl, Suppress => All_Checks);
 388                Pop_Scope;
 389
 390             else
 391                Analyze (Decl, Suppress => All_Checks);
 392             end if;
 393
 394             Next (Decl);
 395          end loop;
 396       end if;
 397
 398       --  If we are to delete this N_Freeze_Entity, do so by rewriting so that
 399       --  a loop on all nodes being inserted will work propertly.
 400
 401       if Delete then
 402          Rewrite (N, Make_Null_Statement (Sloc (N)));
 403       end if;
 404
 405       if In_Other_Scope then
 406          if Ekind (Current_Scope) = E_Package then
 407             End_Package_Scope (E_Scope);
 408          else
 409             End_Scope;
 410          end if;
 411
 412       elsif In_Outer_Scope then
 413          Pop_Scope;
 414       end if;
 415    end Expand_N_Freeze_Entity;
 416
 417    -------------------------------------------
 418    -- Expand_N_Record_Representation_Clause --
 419    -------------------------------------------
 420
 421    --  The only expansion required is for the case of a mod clause present,
 422    --  which is removed, and translated into an alignment representation
 423    --  clause inserted immediately after the record rep clause with any
 424    --  initial pragmas inserted at the start of the component clause list.
 425
 426    procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
 427       Loc     : constant Source_Ptr := Sloc (N);
 428       Rectype : constant Entity_Id  := Entity (Identifier (N));
 429       Mod_Val : Uint;
 430       Citems  : List_Id;
 431       Repitem : Node_Id;
 432       AtM_Nod : Node_Id;
 433
 434    begin
 435       if Present (Mod_Clause (N)) then
 436          Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
 437          Citems  := Pragmas_Before (Mod_Clause (N));
 438
 439          if Present (Citems) then
 440             Append_List_To (Citems, Component_Clauses (N));
 441             Set_Component_Clauses (N, Citems);
 442          end if;
 443
 444          AtM_Nod :=
 445            Make_Attribute_Definition_Clause (Loc,
 446              Name       => New_Reference_To (Base_Type (Rectype), Loc),
 447              Chars      => Name_Alignment,
 448              Expression => Make_Integer_Literal (Loc, Mod_Val));
 449
 450          Set_From_At_Mod (AtM_Nod);
 451          Insert_After (N, AtM_Nod);
 452          Set_Mod_Clause (N, Empty);
 453       end if;
 454
 455       --  If the record representation clause has no components, then
 456       --  completely remove it.  Note that we also have to remove
 457       --  ourself from the Rep Item list.
 458
 459       if Is_Empty_List (Component_Clauses (N)) then
 460          if First_Rep_Item (Rectype) = N then
 461             Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
 462          else
 463             Repitem := First_Rep_Item (Rectype);
 464             while Present (Next_Rep_Item (Repitem)) loop
 465                if Next_Rep_Item (Repitem) = N then
 466                   Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
 467                   exit;
 468                end if;
 469
 470                Next_Rep_Item (Repitem);
 471             end loop;
 472          end if;
 473
 474          Rewrite (N,
 475            Make_Null_Statement (Loc));
 476       end if;
 477    end Expand_N_Record_Representation_Clause;
 478
 479 end Exp_Ch13;