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