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