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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Checks;   use Checks;
  30 with Einfo;    use Einfo;
  31 with Exp_Ch3;  use Exp_Ch3;
  32 with Exp_Ch6;  use Exp_Ch6;
  33 with Exp_Imgv; use Exp_Imgv;
  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
  85             --  the source program, then it is an artifact of our
  86             --  expansion, and we suppress it. The case we are most
  87             --  concerned about here is the initialization of a packed
  88             --  array to all false, which seems inappropriate for a
  89             --  variable to which an address clause is applied. The
  90             --  expression may itself have been rewritten if the type is a
  91             --  packed array, so we need to examine whether the original
  92             --  node is in the source.
  93
  94             declare
  95                Decl : constant Node_Id := Declaration_Node (Ent);
  96
  97             begin
  98                if Nkind (Decl) = N_Object_Declaration
  99                   and then Present (Expression (Decl))
 100                   and then
 101                    not Comes_From_Source (Original_Node (Expression (Decl)))
 102                then
 103                   Set_Expression (Decl, Empty);
 104                end if;
 105             end;
 106
 107          ---------------
 108          -- Alignment --
 109          ---------------
 110
 111          when Attribute_Alignment =>
 112
 113             --  As required by Gigi, we guarantee that the operand is an
 114             --  integer literal (this simplifies things in Gigi).
 115
 116             if Nkind (Exp) /= N_Integer_Literal then
 117                Rewrite
 118                  (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
 119             end if;
 120
 121          ------------------
 122          -- Storage_Size --
 123          ------------------
 124
 125          when Attribute_Storage_Size =>
 126
 127             --  If the type is a task type, then assign the value of the
 128             --  storage size to the Size variable associated with the task.
 129             --    task_typeZ := expression
 130
 131             if Ekind (Ent) = E_Task_Type then
 132                Insert_Action (N,
 133                  Make_Assignment_Statement (Loc,
 134                    Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
 135                    Expression =>
 136                      Convert_To (RTE (RE_Size_Type), Expression (N))));
 137
 138             --  For Storage_Size for an access type, create a variable to hold
 139             --  the value of the specified size with name typeV and expand an
 140             --  assignment statement to initialze this value.
 141
 142             elsif Is_Access_Type (Ent) then
 143
 144                V := Make_Defining_Identifier (Loc,
 145                       New_External_Name (Chars (Ent), 'V'));
 146
 147                Insert_Action (N,
 148                  Make_Object_Declaration (Loc,
 149                    Defining_Identifier => V,
 150                    Object_Definition  =>
 151                      New_Reference_To (RTE (RE_Storage_Offset), Loc),
 152                    Expression =>
 153                      Convert_To (RTE (RE_Storage_Offset), Expression (N))));
 154
 155                Set_Storage_Size_Variable (Ent, Entity_Id (V));
 156             end if;
 157
 158          --  Other attributes require no expansion
 159
 160          when others =>
 161             null;
 162
 163       end case;
 164
 165    end Expand_N_Attribute_Definition_Clause;
 166
 167    -------------------------------------
 168    -- Expand_External_Tag_Definition --
 169    -------------------------------------
 170
 171    procedure Expand_External_Tag_Definition (N : Node_Id) is
 172       Loc     : constant Source_Ptr := Sloc (N);
 173       Ent     : constant Entity_Id  := Entity (Name (N));
 174       E       : Entity_Id;
 175       Old_Val : String_Id := Strval (Expr_Value_S (Expression (N)));
 176       New_Val : String_Id;
 177
 178    begin
 179
 180       --  For the rep clause "for x'external_tag use y" generate:
 181
 182       --     xV : constant string := y;
 183       --     Set_External_Tag (x'tag, xV'Address);
 184       --     Register_Tag (x'tag);
 185
 186       --  note that register_tag has been delayed up to now because
 187       --  the external_tag must be set before registering.
 188
 189       --  Create a new nul terminated string if it is not already
 190
 191       if String_Length (Old_Val) > 0
 192         and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
 193       then
 194          New_Val := Old_Val;
 195       else
 196          Start_String (Old_Val);
 197          Store_String_Char (Get_Char_Code (ASCII.NUL));
 198          New_Val := End_String;
 199       end if;
 200
 201       E :=
 202         Make_Defining_Identifier (Loc,
 203           New_External_Name (Chars (Ent), 'A'));
 204
 205       --  The generated actions must be elaborated at the subsequent
 206       --  freeze point, not at the point of the attribute definition.
 207
 208       Append_Freeze_Action (Ent,
 209         Make_Object_Declaration (Loc,
 210           Defining_Identifier => E,
 211           Constant_Present    => True,
 212           Object_Definition   =>
 213             New_Reference_To (Standard_String, Loc),
 214           Expression          =>
 215             Make_String_Literal (Loc, Strval => New_Val)));
 216
 217       Append_Freeze_Actions (Ent, New_List (
 218         Make_Procedure_Call_Statement (Loc,
 219           Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
 220           Parameter_Associations => New_List (
 221             Make_Attribute_Reference (Loc,
 222               Attribute_Name => Name_Tag,
 223               Prefix         => New_Occurrence_Of (Ent, Loc)),
 224
 225             Make_Attribute_Reference (Loc,
 226               Attribute_Name => Name_Address,
 227               Prefix         => New_Occurrence_Of (E, Loc)))),
 228
 229         Make_Procedure_Call_Statement (Loc,
 230           Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
 231           Parameter_Associations => New_List (
 232             Make_Attribute_Reference (Loc,
 233               Attribute_Name => Name_Tag,
 234               Prefix         => New_Occurrence_Of (Ent, Loc))))));
 235    end Expand_External_Tag_Definition;
 236
 237    ----------------------------
 238    -- Expand_N_Freeze_Entity --
 239    ----------------------------
 240
 241    procedure Expand_N_Freeze_Entity (N : Node_Id) is
 242       E              : constant Entity_Id := Entity (N);
 243       E_Scope        : Entity_Id;
 244       S              : Entity_Id;
 245       In_Other_Scope : Boolean;
 246       In_Outer_Scope : Boolean;
 247       Decl           : Node_Id;
 248
 249    begin
 250       --  For object, with address clause, check alignment is OK
 251
 252       if Is_Object (E) then
 253          Apply_Alignment_Check (E, N);
 254
 255       --  Only other items requiring any front end action are
 256       --  types and subprograms.
 257
 258       elsif not Is_Type (E) and then not Is_Subprogram (E) then
 259          return;
 260       end if;
 261
 262       --  Here E is a type or a subprogram
 263
 264       E_Scope := Scope (E);
 265
 266       --  If we are freezing entities defined in protected types, they
 267       --  belong in the enclosing scope, given that the original type
 268       --  has been expanded away. The same is true for entities in task types,
 269       --  in particular the parameter records of entries (Entities in bodies
 270       --  are all frozen within the body). If we are in the task body, this
 271       --  is a proper scope.
 272
 273       if Ekind (E_Scope) = E_Protected_Type
 274         or else (Ekind (E_Scope) = E_Task_Type
 275                    and then not Has_Completion (E_Scope))
 276       then
 277          E_Scope := Scope (E_Scope);
 278       end if;
 279
 280       S := Current_Scope;
 281       while S /= Standard_Standard and then S /= E_Scope loop
 282          S := Scope (S);
 283       end loop;
 284
 285       In_Other_Scope := not (S = E_Scope);
 286       In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
 287
 288       --  If the entity being frozen is defined in a scope that is not
 289       --  currently on the scope stack, we must establish the proper
 290       --  visibility before freezing the entity and related subprograms.
 291
 292       if In_Other_Scope then
 293          New_Scope (E_Scope);
 294          Install_Visible_Declarations (E_Scope);
 295
 296          if Ekind (E_Scope) = E_Package         or else
 297             Ekind (E_Scope) = E_Generic_Package or else
 298             Is_Protected_Type (E_Scope)         or else
 299             Is_Task_Type (E_Scope)
 300          then
 301             Install_Private_Declarations (E_Scope);
 302          end if;
 303
 304       --  If the entity is in an outer scope, then that scope needs to
 305       --  temporarily become the current scope so that operations created
 306       --  during type freezing will be declared in the right scope and
 307       --  can properly override any corresponding inherited operations.
 308
 309       elsif In_Outer_Scope then
 310          New_Scope (E_Scope);
 311       end if;
 312
 313       --  If type, freeze the type
 314
 315       if Is_Type (E) then
 316          Freeze_Type (N);
 317
 318          --  And for enumeration type, build the enumeration tables
 319
 320          if Is_Enumeration_Type (E) then
 321             Build_Enumeration_Image_Tables (E, N);
 322
 323          elsif Is_Tagged_Type (E)
 324            and then Is_First_Subtype (E)
 325          then
 326
 327             --  Check for a definition of External_Tag, whose expansion must
 328             --  be delayed until the dispatch table is built.
 329
 330             declare
 331                Def : Node_Id :=
 332                   Get_Attribute_Definition_Clause (E, Attribute_External_Tag);
 333             begin
 334                if Present (Def) then
 335                   Expand_External_Tag_Definition (Def);
 336                end if;
 337             end;
 338          end if;
 339
 340       --  If subprogram, freeze the subprogram
 341
 342       elsif Is_Subprogram (E) then
 343          Freeze_Subprogram (N);
 344       end if;
 345
 346       --  Analyze actions generated by freezing. The init_proc contains
 347       --  source expressions that may raise constraint_error, and the
 348       --  assignment procedure for complex types needs checks on individual
 349       --  component assignments, but all other freezing actions should be
 350       --  compiled with all checks off.
 351
 352       if Present (Actions (N)) then
 353          Decl := First (Actions (N));
 354
 355          while Present (Decl) loop
 356
 357             if Nkind (Decl) = N_Subprogram_Body
 358               and then (Chars (Defining_Entity (Decl)) = Name_uInit_Proc
 359                  or else Chars (Defining_Entity (Decl)) = Name_uAssign)
 360             then
 361                Analyze (Decl);
 362
 363             --  A subprogram body created for a renaming_as_body completes
 364             --  a previous declaration, which may be in a different scope.
 365             --  Establish the proper scope before analysis.
 366
 367             elsif Nkind (Decl) = N_Subprogram_Body
 368               and then Present (Corresponding_Spec (Decl))
 369               and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
 370             then
 371                New_Scope (Scope (Corresponding_Spec (Decl)));
 372                Analyze (Decl, Suppress => All_Checks);
 373                Pop_Scope;
 374
 375             else
 376                Analyze (Decl, Suppress => All_Checks);
 377             end if;
 378
 379             Next (Decl);
 380          end loop;
 381       end if;
 382
 383       if In_Other_Scope then
 384          if Ekind (Current_Scope) = E_Package then
 385             End_Package_Scope (E_Scope);
 386          else
 387             End_Scope;
 388          end if;
 389
 390       elsif In_Outer_Scope then
 391          Pop_Scope;
 392       end if;
 393    end Expand_N_Freeze_Entity;
 394
 395    -------------------------------------------
 396    -- Expand_N_Record_Representation_Clause --
 397    -------------------------------------------
 398
 399    --  The only expansion required is for the case of a mod clause present,
 400    --  which is removed, and translated into an alignment representation
 401    --  clause inserted immediately after the record rep clause with any
 402    --  initial pragmas inserted at the start of the component clause list.
 403
 404    procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
 405       Loc     : constant Source_Ptr := Sloc (N);
 406       Rectype : constant Entity_Id  := Entity (Identifier (N));
 407       Mod_Val : Uint;
 408       Citems  : List_Id;
 409       Repitem : Node_Id;
 410       AtM_Nod : Node_Id;
 411
 412    begin
 413       if Present (Mod_Clause (N)) then
 414          Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
 415          Citems  := Pragmas_Before (Mod_Clause (N));
 416
 417          if Present (Citems) then
 418             Append_List_To (Citems, Component_Clauses (N));
 419             Set_Component_Clauses (N, Citems);
 420          end if;
 421
 422          AtM_Nod :=
 423            Make_Attribute_Definition_Clause (Loc,
 424              Name       => New_Reference_To (Base_Type (Rectype), Loc),
 425              Chars      => Name_Alignment,
 426              Expression => Make_Integer_Literal (Loc, Mod_Val));
 427
 428          Set_From_At_Mod (AtM_Nod);
 429          Insert_After (N, AtM_Nod);
 430          Set_Mod_Clause (N, Empty);
 431       end if;
 432
 433       --  If the record representation clause has no components, then
 434       --  completely remove it.  Note that we also have to remove
 435       --  ourself from the Rep Item list.
 436
 437       if Is_Empty_List (Component_Clauses (N)) then
 438          if First_Rep_Item (Rectype) = N then
 439             Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
 440          else
 441             Repitem := First_Rep_Item (Rectype);
 442             while Present (Next_Rep_Item (Repitem)) loop
 443                if Next_Rep_Item (Repitem) = N then
 444                   Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
 445                   exit;
 446                end if;
 447
 448                Next_Rep_Item (Repitem);
 449             end loop;
 450          end if;
 451
 452          Rewrite (N,
 453            Make_Null_Statement (Loc));
 454       end if;
 455    end Expand_N_Record_Representation_Clause;
 456
 457 end Exp_Ch13;