gcc/ada/exp_ch2.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 2                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Smem; use Exp_Smem;
  32 with Exp_Util; use Exp_Util;
  33 with Exp_VFpt; use Exp_VFpt;
  34 with Nmake;    use Nmake;
  35 with Sem;      use Sem;
  36 with Sem_Res;  use Sem_Res;
  37 with Sem_Util; use Sem_Util;
  38 with Sinfo;    use Sinfo;
  39 with Tbuild;   use Tbuild;
  40 with Snames;   use Snames;
  41
  42 package body Exp_Ch2 is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Expand_Discriminant (N : Node_Id);
  49    --  An occurrence of a discriminant within a discriminated type is replaced
  50    --  with the corresponding discriminal, that is to say the formal parameter
  51    --  of the initialization procedure for the type that is associated with
  52    --  that particular discriminant. This replacement is not performed for
  53    --  discriminants of records that appear in constraints of component of the
  54    --  record, because Gigi uses the discriminant name to retrieve its value.
  55    --  In the other hand, it has to be performed for default expressions of
  56    --  components because they are used in the record init procedure. See
  57    --  Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use.
  58    --  For discriminants of tasks and protected types, the transformation is
  59    --  more complex when it occurs within a default expression for an entry
  60    --  or protected operation. The corresponding default_expression_function
  61    --  has an additional parameter which is the target of an entry call, and
  62    --  the discriminant of the task must be replaced with a reference to the
  63    --  discriminant of that formal parameter.
  64
  65    procedure Expand_Entity_Reference (N : Node_Id);
  66    --  Common processing for expansion of identifiers and expanded names
  67
  68    procedure Expand_Entry_Index_Parameter (N : Node_Id);
  69    --  A reference to the identifier in the entry index specification
  70    --  of a protected entry body is modified to a reference to a constant
  71    --  definintion equal to the index of the entry family member being
  72    --  called. This constant is calculated as part of the elaboration
  73    --  of the expanded code for the body, and is calculated from the
  74    --  object-wide entry index returned by Next_Entry_Call.
  75
  76    procedure Expand_Entry_Parameter (N : Node_Id);
  77    --  A reference to an entry parameter is modified to be a reference to
  78    --  the corresponding component of the entry parameter record that is
  79    --  passed by the runtime to the accept body procedure
  80
  81    procedure Expand_Formal (N : Node_Id);
  82    --  A reference to a formal parameter of a protected subprogram is
  83    --  expanded to the corresponding formal of the unprotected procedure
  84    --  used to represent the protected subprogram within the protected object.
  85
  86    procedure Expand_Protected_Private (N : Node_Id);
  87    --  A reference to a private object of a protected type is expanded
  88    --  to a component selected from the record used to implement
  89    --  the protected object. Such a record is passed to all operations
  90    --  on a protected object in a parameter named _object. Such an object
  91    --  is a constant within a function, and a variable otherwise.
  92
  93    procedure Expand_Renaming (N : Node_Id);
  94    --  For renamings, just replace the identifier by the corresponding
  95    --  name expression. Note that this has been evaluated (see routine
  96    --  Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
  97    --  the correct renaming semantics.
  98
  99    -------------------------
 100    -- Expand_Discriminant --
 101    -------------------------
 102
 103    procedure Expand_Discriminant (N : Node_Id) is
 104       Scop     : constant Entity_Id := Scope (Entity (N));
 105       P        : Node_Id := N;
 106       Parent_P : Node_Id := Parent (P);
 107       In_Entry : Boolean := False;
 108
 109    begin
 110       --  The Incomplete_Or_Private_Kind happens while resolving the
 111       --  discriminant constraint involved in a derived full type,
 112       --  such as:
 113
 114       --    type D is private;
 115       --    type D(C : ...) is new T(C);
 116
 117       if Ekind (Scop) = E_Record_Type
 118         or Ekind (Scop) in Incomplete_Or_Private_Kind
 119       then
 120
 121          --  Find the origin by walking up the tree till the component
 122          --  declaration
 123
 124          while Present (Parent_P)
 125            and then Nkind (Parent_P) /= N_Component_Declaration
 126          loop
 127             P := Parent_P;
 128             Parent_P := Parent (P);
 129          end loop;
 130
 131          --  If the discriminant reference was part of the default expression
 132          --  it has to be "discriminalized"
 133
 134          if Present (Parent_P) and then P = Expression (Parent_P) then
 135             Set_Entity (N, Discriminal (Entity (N)));
 136          end if;
 137
 138       elsif Is_Concurrent_Type (Scop) then
 139          while Present (Parent_P)
 140            and then Nkind (Parent_P) /= N_Subprogram_Body
 141          loop
 142             P := Parent_P;
 143
 144             if Nkind (P) = N_Entry_Declaration then
 145                In_Entry := True;
 146             end if;
 147
 148             Parent_P := Parent (Parent_P);
 149          end loop;
 150
 151          --  If the discriminant occurs within the default expression for
 152          --  a formal of an entry or protected operation, create a default
 153          --  function for it, and replace the discriminant with a reference
 154          --  to the discriminant of the formal of the default function.
 155          --  The discriminant entity is the one defined in the corresponding
 156          --  record.
 157
 158          if Present (Parent_P)
 159            and then Present (Corresponding_Spec (Parent_P))
 160          then
 161
 162             declare
 163                Loc    : constant Source_Ptr := Sloc (N);
 164                D_Fun  : Entity_Id := Corresponding_Spec  (Parent_P);
 165                Formal : Entity_Id := First_Formal (D_Fun);
 166                New_N  : Node_Id;
 167                Disc   : Entity_Id;
 168
 169             begin
 170                --  Verify that we are within a default function: the type of
 171                --  its formal parameter is the same task or protected type.
 172
 173                if Present (Formal)
 174                  and then Etype (Formal) = Scope (Entity (N))
 175                then
 176                   Disc := CR_Discriminant (Entity (N));
 177
 178                   New_N :=
 179                     Make_Selected_Component (Loc,
 180                       Prefix => New_Occurrence_Of (Formal, Loc),
 181                       Selector_Name => New_Occurrence_Of (Disc, Loc));
 182
 183                   Set_Etype (New_N, Etype (N));
 184                   Rewrite (N, New_N);
 185
 186                else
 187                   Set_Entity (N, Discriminal (Entity (N)));
 188                end if;
 189             end;
 190
 191          elsif Nkind (Parent (N)) = N_Range
 192            and then In_Entry
 193          then
 194             Set_Entity (N, CR_Discriminant (Entity (N)));
 195          else
 196             Set_Entity (N, Discriminal (Entity (N)));
 197          end if;
 198
 199       else
 200          Set_Entity (N, Discriminal (Entity (N)));
 201       end if;
 202    end Expand_Discriminant;
 203
 204    -----------------------------
 205    -- Expand_Entity_Reference --
 206    -----------------------------
 207
 208    procedure Expand_Entity_Reference (N : Node_Id) is
 209       E : constant Entity_Id := Entity (N);
 210
 211    begin
 212       --  Defend against errors
 213
 214       if No (E) and then Total_Errors_Detected /= 0 then
 215          return;
 216       end if;
 217
 218       if Ekind (E) = E_Discriminant then
 219          Expand_Discriminant (N);
 220
 221       elsif Is_Entry_Formal (E) then
 222          Expand_Entry_Parameter (N);
 223
 224       elsif Ekind (E) = E_Component
 225         and then Is_Protected_Private (E)
 226       then
 227          Expand_Protected_Private (N);
 228
 229       elsif Ekind (E) = E_Entry_Index_Parameter then
 230          Expand_Entry_Index_Parameter (N);
 231
 232       elsif Is_Formal (E) then
 233          Expand_Formal (N);
 234
 235       elsif Is_Renaming_Of_Object (E) then
 236          Expand_Renaming (N);
 237
 238       elsif Ekind (E) = E_Variable
 239         and then Is_Shared_Passive (E)
 240       then
 241          Expand_Shared_Passive_Variable (N);
 242       end if;
 243    end Expand_Entity_Reference;
 244
 245    ----------------------------------
 246    -- Expand_Entry_Index_Parameter --
 247    ----------------------------------
 248
 249    procedure Expand_Entry_Index_Parameter (N : Node_Id) is
 250    begin
 251       Set_Entity (N, Entry_Index_Constant (Entity (N)));
 252    end Expand_Entry_Index_Parameter;
 253
 254    ----------------------------
 255    -- Expand_Entry_Parameter --
 256    ----------------------------
 257
 258    procedure Expand_Entry_Parameter (N : Node_Id) is
 259       Loc        : constant Source_Ptr := Sloc (N);
 260       Ent_Formal : constant Entity_Id  := Entity (N);
 261       Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);
 262       Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);
 263       Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);
 264       Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));
 265       P_Comp_Ref : Entity_Id;
 266
 267    begin
 268       --  What we need is a reference to the corresponding component of the
 269       --  parameter record object. The Accept_Address field of the entry
 270       --  entity references the address variable that contains the address
 271       --  of the accept parameters record. We first have to do an unchecked
 272       --  conversion to turn this into a pointer to the parameter record and
 273       --  then we select the required parameter field.
 274
 275       P_Comp_Ref :=
 276         Make_Selected_Component (Loc,
 277           Prefix =>
 278             Unchecked_Convert_To (Parm_Type,
 279               New_Reference_To (Addr_Ent, Loc)),
 280           Selector_Name =>
 281             New_Reference_To (Entry_Component (Ent_Formal), Loc));
 282
 283       --  For all types of parameters, the constructed parameter record
 284       --  object contains a pointer to the parameter. Thus we must
 285       --  dereference them to access them (this will often be redundant,
 286       --  since the needed deference is implicit, but no harm is done by
 287       --  making it explicit).
 288
 289       Rewrite (N,
 290         Make_Explicit_Dereference (Loc, P_Comp_Ref));
 291
 292       Analyze (N);
 293    end Expand_Entry_Parameter;
 294
 295    -------------------
 296    -- Expand_Formal --
 297    -------------------
 298
 299    procedure Expand_Formal (N : Node_Id) is
 300       E    : constant Entity_Id  := Entity (N);
 301       Subp : constant Entity_Id  := Scope (E);
 302
 303    begin
 304       if Is_Protected_Type (Scope (Subp))
 305         and then Chars (Subp) /= Name_uInit_Proc
 306         and then Present (Protected_Formal (E))
 307       then
 308          Set_Entity (N, Protected_Formal (E));
 309       end if;
 310    end Expand_Formal;
 311
 312    ----------------------------
 313    -- Expand_N_Expanded_Name --
 314    ----------------------------
 315
 316    procedure Expand_N_Expanded_Name (N : Node_Id) is
 317    begin
 318       Expand_Entity_Reference (N);
 319    end Expand_N_Expanded_Name;
 320
 321    -------------------------
 322    -- Expand_N_Identifier --
 323    -------------------------
 324
 325    procedure Expand_N_Identifier (N : Node_Id) is
 326    begin
 327       Expand_Entity_Reference (N);
 328    end Expand_N_Identifier;
 329
 330    ---------------------------
 331    -- Expand_N_Real_Literal --
 332    ---------------------------
 333
 334    procedure Expand_N_Real_Literal (N : Node_Id) is
 335    begin
 336       if Vax_Float (Etype (N)) then
 337          Expand_Vax_Real_Literal (N);
 338       end if;
 339    end Expand_N_Real_Literal;
 340
 341    ------------------------------
 342    -- Expand_Protected_Private --
 343    ------------------------------
 344
 345    procedure Expand_Protected_Private (N : Node_Id) is
 346       Loc      : constant Source_Ptr := Sloc (N);
 347       E        : constant Entity_Id  := Entity (N);
 348       Op       : constant Node_Id    := Protected_Operation (E);
 349       Scop     : Entity_Id;
 350       Lo       : Node_Id;
 351       Hi       : Node_Id;
 352       D_Range  : Node_Id;
 353
 354    begin
 355       if Nkind (Op) /= N_Subprogram_Body
 356         or else Nkind (Specification (Op)) /= N_Function_Specification
 357       then
 358          Set_Ekind (Prival (E), E_Variable);
 359       else
 360          Set_Ekind (Prival (E), E_Constant);
 361       end if;
 362
 363       --  If the private component appears in an assignment (either lhs or
 364       --  rhs) and is a one-dimensional array constrained by a discriminant,
 365       --  rewrite as  P (Lo .. Hi) with an explicit range, so that discriminal
 366       --  is directly visible. This solves delicate visibility problems.
 367
 368       if Comes_From_Source (N)
 369         and then Is_Array_Type (Etype (E))
 370         and then Number_Dimensions (Etype (E)) = 1
 371         and then not Within_Init_Proc
 372       then
 373          Lo := Type_Low_Bound  (Etype (First_Index (Etype (E))));
 374          Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
 375
 376          if Nkind (Parent (N)) = N_Assignment_Statement
 377            and then ((Is_Entity_Name (Lo)
 378                           and then Ekind (Entity (Lo)) = E_In_Parameter)
 379                        or else (Is_Entity_Name (Hi)
 380                                   and then
 381                                     Ekind (Entity (Hi)) = E_In_Parameter))
 382          then
 383             D_Range := New_Node (N_Range, Loc);
 384
 385             if Is_Entity_Name (Lo)
 386               and then Ekind (Entity (Lo)) = E_In_Parameter
 387             then
 388                Set_Low_Bound (D_Range,
 389                  Make_Identifier (Loc, Chars (Entity (Lo))));
 390             else
 391                Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
 392             end if;
 393
 394             if Is_Entity_Name (Hi)
 395               and then Ekind (Entity (Hi)) = E_In_Parameter
 396             then
 397                Set_High_Bound (D_Range,
 398                  Make_Identifier (Loc, Chars (Entity (Hi))));
 399             else
 400                Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
 401             end if;
 402
 403             Rewrite (N,
 404               Make_Slice (Loc,
 405                 Prefix => New_Occurrence_Of (E, Loc),
 406                 Discrete_Range => D_Range));
 407
 408             Analyze_And_Resolve (N, Etype (E));
 409             return;
 410          end if;
 411       end if;
 412
 413       --  The type of the reference is the type of the prival, which may
 414       --  differ from that of the original component if it is an itype.
 415
 416       Set_Entity (N, Prival (E));
 417       Set_Etype  (N, Etype (Prival (E)));
 418       Scop := Current_Scope;
 419
 420       --  Find entity for protected operation, which must be on scope stack.
 421
 422       while not Is_Protected_Type (Scope (Scop)) loop
 423          Scop := Scope (Scop);
 424       end loop;
 425
 426       Append_Elmt (N, Privals_Chain (Scop));
 427    end Expand_Protected_Private;
 428
 429    ---------------------
 430    -- Expand_Renaming --
 431    ---------------------
 432
 433    procedure Expand_Renaming (N : Node_Id) is
 434       E : constant Entity_Id := Entity (N);
 435       T : constant Entity_Id := Etype (N);
 436
 437    begin
 438       Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
 439
 440       --  We mark the copy as unanalyzed, so that it is sure to be
 441       --  reanalyzed at the top level. This is needed in the packed
 442       --  case since we specifically avoided expanding packed array
 443       --  references when the renaming declaration was analyzed.
 444
 445       Reset_Analyzed_Flags (N);
 446       Analyze_And_Resolve (N, T);
 447    end Expand_Renaming;
 448
 449    ------------------
 450    -- Param_Entity --
 451    ------------------
 452
 453    --  This would be trivial, simply a test for an identifier that was a
 454    --  reference to a formal, if it were not for the fact that a previous
 455    --  call to Expand_Entry_Parameter will have modified the reference
 456    --  to the identifier to be of the form
 457
 458    --    typ!(recobj).rec.all'Constrained
 459
 460    --  where rec is a selector whose Entry_Formal link points to the formal
 461
 462    function Param_Entity (N : Node_Id) return Entity_Id is
 463    begin
 464       --  Simple reference case
 465
 466       if Nkind (N) = N_Identifier then
 467          if Is_Formal (Entity (N)) then
 468             return Entity (N);
 469          end if;
 470
 471       else
 472          if Nkind (N) = N_Explicit_Dereference then
 473             declare
 474                P : constant Node_Id := Prefix (N);
 475                S : Node_Id;
 476
 477             begin
 478                if Nkind (P) = N_Selected_Component then
 479                   S := Selector_Name (P);
 480
 481                   if Present (Entry_Formal (Entity (S))) then
 482                      return Entry_Formal (Entity (S));
 483                   end if;
 484                end if;
 485             end;
 486          end if;
 487       end if;
 488
 489       return (Empty);
 490    end Param_Entity;
 491
 492 end Exp_Ch2;