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