gcc/ada/exp_ch6.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 6                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2003, 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 Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Elists;   use Elists;
  33 with Exp_Ch2;  use Exp_Ch2;
  34 with Exp_Ch3;  use Exp_Ch3;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Ch11; use Exp_Ch11;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Exp_Disp; use Exp_Disp;
  40 with Exp_Dist; use Exp_Dist;
  41 with Exp_Intr; use Exp_Intr;
  42 with Exp_Pakd; use Exp_Pakd;
  43 with Exp_Tss;  use Exp_Tss;
  44 with Exp_Util; use Exp_Util;
  45 with Fname;    use Fname;
  46 with Freeze;   use Freeze;
  47 with Hostparm; use Hostparm;
  48 with Inline;   use Inline;
  49 with Lib;      use Lib;
  50 with Nlists;   use Nlists;
  51 with Nmake;    use Nmake;
  52 with Opt;      use Opt;
  53 with Restrict; use Restrict;
  54 with Rtsfind;  use Rtsfind;
  55 with Sem;      use Sem;
  56 with Sem_Ch6;  use Sem_Ch6;
  57 with Sem_Ch8;  use Sem_Ch8;
  58 with Sem_Ch12; use Sem_Ch12;
  59 with Sem_Ch13; use Sem_Ch13;
  60 with Sem_Disp; use Sem_Disp;
  61 with Sem_Dist; use Sem_Dist;
  62 with Sem_Eval; use Sem_Eval;
  63 with Sem_Res;  use Sem_Res;
  64 with Sem_Util; use Sem_Util;
  65 with Sinfo;    use Sinfo;
  66 with Snames;   use Snames;
  67 with Stand;    use Stand;
  68 with Tbuild;   use Tbuild;
  69 with Ttypes;   use Ttypes;
  70 with Uintp;    use Uintp;
  71 with Validsw;  use Validsw;
  72
  73 package body Exp_Ch6 is
  74
  75    -----------------------
  76    -- Local Subprograms --
  77    -----------------------
  78
  79    procedure Check_Overriding_Operation (Subp : Entity_Id);
  80    --  Subp is a dispatching operation. Check whether it may override an
  81    --  inherited private operation, in which case its DT entry is that of
  82    --  the hidden operation, not the one it may have received earlier.
  83    --  This must be done before emitting the code to set the corresponding
  84    --  DT to the address of the subprogram. The actual placement of Subp in
  85    --  the proper place in the list of primitive operations is done in
  86    --  Declare_Inherited_Private_Subprograms, which also has to deal with
  87    --  implicit operations. This duplication is unavoidable for now???
  88
  89    procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
  90    --  This procedure is called only if the subprogram body N, whose spec
  91    --  has the given entity Spec, contains a parameterless recursive call.
  92    --  It attempts to generate runtime code to detect if this a case of
  93    --  infinite recursion.
  94    --
  95    --  The body is scanned to determine dependencies. If the only external
  96    --  dependencies are on a small set of scalar variables, then the values
  97    --  of these variables are captured on entry to the subprogram, and if
  98    --  the values are not changed for the call, we know immediately that
  99    --  we have an infinite recursion.
 100
 101    procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
 102    --  For each actual of an in-out parameter which is a numeric conversion
 103    --  of the form T(A), where A denotes a variable, we insert the declaration:
 104    --
 105    --    Temp : T := T (A);
 106    --
 107    --  prior to the call. Then we replace the actual with a reference to Temp,
 108    --  and append the assignment:
 109    --
 110    --    A := TypeA (Temp);
 111    --
 112    --  after the call. Here TypeA is the actual type of variable A.
 113    --  For out parameters, the initial declaration has no expression.
 114    --  If A is not an entity name, we generate instead:
 115    --
 116    --    Var  : TypeA renames A;
 117    --    Temp : T := Var;       --  omitting expression for out parameter.
 118    --    ...
 119    --    Var := TypeA (Temp);
 120    --
 121    --  For other in-out parameters, we emit the required constraint checks
 122    --  before and/or after the call.
 123    --
 124    --  For all parameter modes, actuals that denote components and slices
 125    --  of packed arrays are expanded into suitable temporaries.
 126
 127    procedure Expand_Inlined_Call
 128     (N         : Node_Id;
 129      Subp      : Entity_Id;
 130      Orig_Subp : Entity_Id);
 131    --  If called subprogram can be inlined by the front-end, retrieve the
 132    --  analyzed body, replace formals with actuals and expand call in place.
 133    --  Generate thunks for actuals that are expressions, and insert the
 134    --  corresponding constant declarations before the call. If the original
 135    --  call is to a derived operation, the return type is the one of the
 136    --  derived operation, but the body is that of the original, so return
 137    --  expressions in the body must be converted to the desired type (which
 138    --  is simply not noted in the tree without inline expansion).
 139
 140    function Expand_Protected_Object_Reference
 141      (N    : Node_Id;
 142       Scop : Entity_Id)
 143       return Node_Id;
 144
 145    procedure Expand_Protected_Subprogram_Call
 146      (N    : Node_Id;
 147       Subp : Entity_Id;
 148       Scop : Entity_Id);
 149    --  A call to a protected subprogram within the protected object may appear
 150    --  as a regular call. The list of actuals must be expanded to contain a
 151    --  reference to the object itself, and the call becomes a call to the
 152    --  corresponding protected subprogram.
 153
 154    --------------------------------
 155    -- Check_Overriding_Operation --
 156    --------------------------------
 157
 158    procedure Check_Overriding_Operation (Subp : Entity_Id) is
 159       Typ     : constant Entity_Id := Find_Dispatching_Type (Subp);
 160       Op_List : constant Elist_Id  := Primitive_Operations (Typ);
 161       Op_Elmt : Elmt_Id;
 162       Prim_Op : Entity_Id;
 163       Par_Op  : Entity_Id;
 164
 165    begin
 166       if Is_Derived_Type (Typ)
 167         and then not Is_Private_Type (Typ)
 168         and then In_Open_Scopes (Scope (Etype (Typ)))
 169         and then Typ = Base_Type (Typ)
 170       then
 171          --  Subp overrides an inherited private operation if there is
 172          --  an inherited operation with a different name than Subp (see
 173          --  Derive_Subprogram) whose Alias is a hidden  subprogram with
 174          --  the same name as Subp.
 175
 176          Op_Elmt := First_Elmt (Op_List);
 177          while Present (Op_Elmt) loop
 178             Prim_Op := Node (Op_Elmt);
 179             Par_Op  := Alias (Prim_Op);
 180
 181             if Present (Par_Op)
 182               and then not Comes_From_Source (Prim_Op)
 183               and then Chars (Prim_Op) /= Chars (Par_Op)
 184               and then Chars (Par_Op) = Chars (Subp)
 185               and then Is_Hidden (Par_Op)
 186               and then Type_Conformant (Prim_Op, Subp)
 187             then
 188                Set_DT_Position (Subp, DT_Position (Prim_Op));
 189             end if;
 190
 191             Next_Elmt (Op_Elmt);
 192          end loop;
 193       end if;
 194    end Check_Overriding_Operation;
 195
 196    -------------------------------
 197    -- Detect_Infinite_Recursion --
 198    -------------------------------
 199
 200    procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
 201       Loc : constant Source_Ptr := Sloc (N);
 202
 203       Var_List : constant Elist_Id := New_Elmt_List;
 204       --  List of globals referenced by body of procedure
 205
 206       Call_List : constant Elist_Id := New_Elmt_List;
 207       --  List of recursive calls in body of procedure
 208
 209       Shad_List : constant Elist_Id := New_Elmt_List;
 210       --  List of entity id's for entities created to capture the
 211       --  value of referenced globals on entry to the procedure.
 212
 213       Scop : constant Uint := Scope_Depth (Spec);
 214       --  This is used to record the scope depth of the current
 215       --  procedure, so that we can identify global references.
 216
 217       Max_Vars : constant := 4;
 218       --  Do not test more than four global variables
 219
 220       Count_Vars : Natural := 0;
 221       --  Count variables found so far
 222
 223       Var  : Entity_Id;
 224       Elm  : Elmt_Id;
 225       Ent  : Entity_Id;
 226       Call : Elmt_Id;
 227       Decl : Node_Id;
 228       Test : Node_Id;
 229       Elm1 : Elmt_Id;
 230       Elm2 : Elmt_Id;
 231       Last : Node_Id;
 232
 233       function Process (Nod : Node_Id) return Traverse_Result;
 234       --  Function to traverse the subprogram body (using Traverse_Func)
 235
 236       -------------
 237       -- Process --
 238       -------------
 239
 240       function Process (Nod : Node_Id) return Traverse_Result is
 241       begin
 242          --  Procedure call
 243
 244          if Nkind (Nod) = N_Procedure_Call_Statement then
 245
 246             --  Case of one of the detected recursive calls
 247
 248             if Is_Entity_Name (Name (Nod))
 249               and then Has_Recursive_Call (Entity (Name (Nod)))
 250               and then Entity (Name (Nod)) = Spec
 251             then
 252                Append_Elmt (Nod, Call_List);
 253                return Skip;
 254
 255             --  Any other procedure call may have side effects
 256
 257             else
 258                return Abandon;
 259             end if;
 260
 261          --  A call to a pure function can always be ignored
 262
 263          elsif Nkind (Nod) = N_Function_Call
 264            and then Is_Entity_Name (Name (Nod))
 265            and then Is_Pure (Entity (Name (Nod)))
 266          then
 267             return Skip;
 268
 269          --  Case of an identifier reference
 270
 271          elsif Nkind (Nod) = N_Identifier then
 272             Ent := Entity (Nod);
 273
 274             --  If no entity, then ignore the reference
 275
 276             --  Not clear why this can happen. To investigate, remove this
 277             --  test and look at the crash that occurs here in 3401-004 ???
 278
 279             if No (Ent) then
 280                return Skip;
 281
 282             --  Ignore entities with no Scope, again not clear how this
 283             --  can happen, to investigate, look at 4108-008 ???
 284
 285             elsif No (Scope (Ent)) then
 286                return Skip;
 287
 288             --  Ignore the reference if not to a more global object
 289
 290             elsif Scope_Depth (Scope (Ent)) >= Scop then
 291                return Skip;
 292
 293             --  References to types, exceptions and constants are always OK
 294
 295             elsif Is_Type (Ent)
 296               or else Ekind (Ent) = E_Exception
 297               or else Ekind (Ent) = E_Constant
 298             then
 299                return Skip;
 300
 301             --  If other than a non-volatile scalar variable, we have some
 302             --  kind of global reference (e.g. to a function) that we cannot
 303             --  deal with so we forget the attempt.
 304
 305             elsif Ekind (Ent) /= E_Variable
 306               or else not Is_Scalar_Type (Etype (Ent))
 307               or else Treat_As_Volatile (Ent)
 308             then
 309                return Abandon;
 310
 311             --  Otherwise we have a reference to a global scalar
 312
 313             else
 314                --  Loop through global entities already detected
 315
 316                Elm := First_Elmt (Var_List);
 317                loop
 318                   --  If not detected before, record this new global reference
 319
 320                   if No (Elm) then
 321                      Count_Vars := Count_Vars + 1;
 322
 323                      if Count_Vars <= Max_Vars then
 324                         Append_Elmt (Entity (Nod), Var_List);
 325                      else
 326                         return Abandon;
 327                      end if;
 328
 329                      exit;
 330
 331                   --  If recorded before, ignore
 332
 333                   elsif Node (Elm) = Entity (Nod) then
 334                      return Skip;
 335
 336                   --  Otherwise keep looking
 337
 338                   else
 339                      Next_Elmt (Elm);
 340                   end if;
 341                end loop;
 342
 343                return Skip;
 344             end if;
 345
 346          --  For all other node kinds, recursively visit syntactic children
 347
 348          else
 349             return OK;
 350          end if;
 351       end Process;
 352
 353       function Traverse_Body is new Traverse_Func;
 354
 355    --  Start of processing for Detect_Infinite_Recursion
 356
 357    begin
 358       --  Do not attempt detection in No_Implicit_Conditional mode,
 359       --  since we won't be able to generate the code to handle the
 360       --  recursion in any case.
 361
 362       if Restrictions (No_Implicit_Conditionals) then
 363          return;
 364       end if;
 365
 366       --  Otherwise do traversal and quit if we get abandon signal
 367
 368       if Traverse_Body (N) = Abandon then
 369          return;
 370
 371       --  We must have a call, since Has_Recursive_Call was set. If not
 372       --  just ignore (this is only an error check, so if we have a funny
 373       --  situation, due to bugs or errors, we do not want to bomb!)
 374
 375       elsif Is_Empty_Elmt_List (Call_List) then
 376          return;
 377       end if;
 378
 379       --  Here is the case where we detect recursion at compile time
 380
 381       --  Push our current scope for analyzing the declarations and
 382       --  code that we will insert for the checking.
 383
 384       New_Scope (Spec);
 385
 386       --  This loop builds temporary variables for each of the
 387       --  referenced globals, so that at the end of the loop the
 388       --  list Shad_List contains these temporaries in one-to-one
 389       --  correspondence with the elements in Var_List.
 390
 391       Last := Empty;
 392       Elm := First_Elmt (Var_List);
 393       while Present (Elm) loop
 394          Var := Node (Elm);
 395          Ent :=
 396            Make_Defining_Identifier (Loc,
 397              Chars => New_Internal_Name ('S'));
 398          Append_Elmt (Ent, Shad_List);
 399
 400          --  Insert a declaration for this temporary at the start of
 401          --  the declarations for the procedure. The temporaries are
 402          --  declared as constant objects initialized to the current
 403          --  values of the corresponding temporaries.
 404
 405          Decl :=
 406            Make_Object_Declaration (Loc,
 407              Defining_Identifier => Ent,
 408              Object_Definition   => New_Occurrence_Of (Etype (Var), Loc),
 409              Constant_Present    => True,
 410              Expression          => New_Occurrence_Of (Var, Loc));
 411
 412          if No (Last) then
 413             Prepend (Decl, Declarations (N));
 414          else
 415             Insert_After (Last, Decl);
 416          end if;
 417
 418          Last := Decl;
 419          Analyze (Decl);
 420          Next_Elmt (Elm);
 421       end loop;
 422
 423       --  Loop through calls
 424
 425       Call := First_Elmt (Call_List);
 426       while Present (Call) loop
 427
 428          --  Build a predicate expression of the form
 429
 430          --    True
 431          --      and then global1 = temp1
 432          --      and then global2 = temp2
 433          --      ...
 434
 435          --  This predicate determines if any of the global values
 436          --  referenced by the procedure have changed since the
 437          --  current call, if not an infinite recursion is assured.
 438
 439          Test := New_Occurrence_Of (Standard_True, Loc);
 440
 441          Elm1 := First_Elmt (Var_List);
 442          Elm2 := First_Elmt (Shad_List);
 443          while Present (Elm1) loop
 444             Test :=
 445               Make_And_Then (Loc,
 446                 Left_Opnd  => Test,
 447                 Right_Opnd =>
 448                   Make_Op_Eq (Loc,
 449                     Left_Opnd  => New_Occurrence_Of (Node (Elm1), Loc),
 450                     Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
 451
 452             Next_Elmt (Elm1);
 453             Next_Elmt (Elm2);
 454          end loop;
 455
 456          --  Now we replace the call with the sequence
 457
 458          --    if no-changes (see above) then
 459          --       raise Storage_Error;
 460          --    else
 461          --       original-call
 462          --    end if;
 463
 464          Rewrite (Node (Call),
 465            Make_If_Statement (Loc,
 466              Condition       => Test,
 467              Then_Statements => New_List (
 468                Make_Raise_Storage_Error (Loc,
 469                  Reason => SE_Infinite_Recursion)),
 470
 471              Else_Statements => New_List (
 472                Relocate_Node (Node (Call)))));
 473
 474          Analyze (Node (Call));
 475
 476          Next_Elmt (Call);
 477       end loop;
 478
 479       --  Remove temporary scope stack entry used for analysis
 480
 481       Pop_Scope;
 482    end Detect_Infinite_Recursion;
 483
 484    --------------------
 485    -- Expand_Actuals --
 486    --------------------
 487
 488    procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is
 489       Loc       : constant Source_Ptr := Sloc (N);
 490       Actual    : Node_Id;
 491       Formal    : Entity_Id;
 492       N_Node    : Node_Id;
 493       Post_Call : List_Id;
 494       E_Formal  : Entity_Id;
 495
 496       procedure Add_Call_By_Copy_Code;
 497       --  For cases where the parameter must be passed by copy, this routine
 498       --  generates a temporary variable into which the actual is copied and
 499       --  then passes this as the parameter. For an OUT or IN OUT parameter,
 500       --  an assignment is also generated to copy the result back. The call
 501       --  also takes care of any constraint checks required for the type
 502       --  conversion case (on both the way in and the way out).
 503
 504       procedure Add_Packed_Call_By_Copy_Code;
 505       --  This is used when the actual involves a reference to an element
 506       --  of a packed array, where we can appropriately use a simpler
 507       --  approach than the full call by copy code. We just copy the value
 508       --  in and out of an appropriate temporary.
 509
 510       procedure Check_Fortran_Logical;
 511       --  A value of type Logical that is passed through a formal parameter
 512       --  must be normalized because .TRUE. usually does not have the same
 513       --  representation as True. We assume that .FALSE. = False = 0.
 514       --  What about functions that return a logical type ???
 515
 516       function Make_Var (Actual : Node_Id) return Entity_Id;
 517       --  Returns an entity that refers to the given actual parameter,
 518       --  Actual (not including any type conversion). If Actual is an
 519       --  entity name, then this entity is returned unchanged, otherwise
 520       --  a renaming is created to provide an entity for the actual.
 521
 522       procedure Reset_Packed_Prefix;
 523       --  The expansion of a packed array component reference is delayed in
 524       --  the context of a call. Now we need to complete the expansion, so we
 525       --  unmark the analyzed bits in all prefixes.
 526
 527       ---------------------------
 528       -- Add_Call_By_Copy_Code --
 529       ---------------------------
 530
 531       procedure Add_Call_By_Copy_Code is
 532          Expr    : Node_Id;
 533          Init    : Node_Id;
 534          Temp    : Entity_Id;
 535          Var     : Entity_Id;
 536          V_Typ   : Entity_Id;
 537          Crep    : Boolean;
 538
 539       begin
 540          Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 541
 542          if Nkind (Actual) = N_Type_Conversion then
 543             V_Typ := Etype (Expression (Actual));
 544             Var   := Make_Var (Expression (Actual));
 545             Crep  := not Same_Representation
 546                        (Etype (Formal), Etype (Expression (Actual)));
 547          else
 548             V_Typ := Etype (Actual);
 549             Var   := Make_Var (Actual);
 550             Crep  := False;
 551          end if;
 552
 553          --  Setup initialization for case of in out parameter, or an out
 554          --  parameter where the formal is an unconstrained array (in the
 555          --  latter case, we have to pass in an object with bounds).
 556
 557          if Ekind (Formal) = E_In_Out_Parameter
 558            or else (Is_Array_Type (Etype (Formal))
 559                      and then
 560                     not Is_Constrained (Etype (Formal)))
 561          then
 562             if Nkind (Actual) = N_Type_Conversion then
 563                if Conversion_OK (Actual) then
 564                   Init := OK_Convert_To
 565                             (Etype (Formal), New_Occurrence_Of (Var, Loc));
 566                else
 567                   Init := Convert_To
 568                             (Etype (Formal), New_Occurrence_Of (Var, Loc));
 569                end if;
 570             else
 571                Init := New_Occurrence_Of (Var, Loc);
 572             end if;
 573
 574          --  An initialization is created for packed conversions as
 575          --  actuals for out parameters to enable Make_Object_Declaration
 576          --  to determine the proper subtype for N_Node. Note that this
 577          --  is wasteful because the extra copying on the call side is
 578          --  not required for such out parameters. ???
 579
 580          elsif Ekind (Formal) = E_Out_Parameter
 581            and then Nkind (Actual) = N_Type_Conversion
 582            and then (Is_Bit_Packed_Array (Etype (Formal))
 583                        or else
 584                      Is_Bit_Packed_Array (Etype (Expression (Actual))))
 585          then
 586             if Conversion_OK (Actual) then
 587                Init :=
 588                  OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
 589             else
 590                Init :=
 591                  Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
 592             end if;
 593          else
 594             Init := Empty;
 595          end if;
 596
 597          N_Node :=
 598            Make_Object_Declaration (Loc,
 599              Defining_Identifier => Temp,
 600              Object_Definition   =>
 601                New_Occurrence_Of (Etype (Formal), Loc),
 602              Expression => Init);
 603          Set_Assignment_OK (N_Node);
 604          Insert_Action (N, N_Node);
 605
 606          --  Now, normally the deal here is that we use the defining
 607          --  identifier created by that object declaration. There is
 608          --  one exception to this. In the change of representation case
 609          --  the above declaration will end up looking like:
 610
 611          --    temp : type := identifier;
 612
 613          --  And in this case we might as well use the identifier directly
 614          --  and eliminate the temporary. Note that the analysis of the
 615          --  declaration was not a waste of time in that case, since it is
 616          --  what generated the necessary change of representation code. If
 617          --  the change of representation introduced additional code, as in
 618          --  a fixed-integer conversion, the expression is not an identifier
 619          --  and must be kept.
 620
 621          if Crep
 622            and then Present (Expression (N_Node))
 623            and then Is_Entity_Name (Expression (N_Node))
 624          then
 625             Temp := Entity (Expression (N_Node));
 626             Rewrite (N_Node, Make_Null_Statement (Loc));
 627          end if;
 628
 629          --  For IN parameter, all we do is to replace the actual
 630
 631          if Ekind (Formal) = E_In_Parameter then
 632             Rewrite (Actual, New_Reference_To (Temp, Loc));
 633             Analyze (Actual);
 634
 635          --  Processing for OUT or IN OUT parameter
 636
 637          else
 638             --  If type conversion, use reverse conversion on exit
 639
 640             if Nkind (Actual) = N_Type_Conversion then
 641                if Conversion_OK (Actual) then
 642                   Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
 643                else
 644                   Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
 645                end if;
 646             else
 647                Expr := New_Occurrence_Of (Temp, Loc);
 648             end if;
 649
 650             Rewrite (Actual, New_Reference_To (Temp, Loc));
 651             Analyze (Actual);
 652
 653             Append_To (Post_Call,
 654               Make_Assignment_Statement (Loc,
 655                 Name       => New_Occurrence_Of (Var, Loc),
 656                 Expression => Expr));
 657
 658             Set_Assignment_OK (Name (Last (Post_Call)));
 659          end if;
 660       end Add_Call_By_Copy_Code;
 661
 662       ----------------------------------
 663       -- Add_Packed_Call_By_Copy_Code --
 664       ----------------------------------
 665
 666       procedure Add_Packed_Call_By_Copy_Code is
 667          Temp   : Entity_Id;
 668          Incod  : Node_Id;
 669          Outcod : Node_Id;
 670          Lhs    : Node_Id;
 671          Rhs    : Node_Id;
 672
 673       begin
 674          Reset_Packed_Prefix;
 675
 676          --  Prepare to generate code
 677
 678          Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 679          Incod  := Relocate_Node (Actual);
 680          Outcod := New_Copy_Tree (Incod);
 681
 682          --  Generate declaration of temporary variable, initializing it
 683          --  with the input parameter unless we have an OUT variable.
 684
 685          if Ekind (Formal) = E_Out_Parameter then
 686             Incod := Empty;
 687          end if;
 688
 689          Insert_Action (N,
 690            Make_Object_Declaration (Loc,
 691              Defining_Identifier => Temp,
 692              Object_Definition   =>
 693                New_Occurrence_Of (Etype (Formal), Loc),
 694              Expression => Incod));
 695
 696          --  The actual is simply a reference to the temporary
 697
 698          Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
 699
 700          --  Generate copy out if OUT or IN OUT parameter
 701
 702          if Ekind (Formal) /= E_In_Parameter then
 703             Lhs := Outcod;
 704             Rhs := New_Occurrence_Of (Temp, Loc);
 705
 706             --  Deal with conversion
 707
 708             if Nkind (Lhs) = N_Type_Conversion then
 709                Lhs := Expression (Lhs);
 710                Rhs := Convert_To (Etype (Actual), Rhs);
 711             end if;
 712
 713             Append_To (Post_Call,
 714               Make_Assignment_Statement (Loc,
 715                 Name       => Lhs,
 716                 Expression => Rhs));
 717          end if;
 718       end Add_Packed_Call_By_Copy_Code;
 719
 720       ---------------------------
 721       -- Check_Fortran_Logical --
 722       ---------------------------
 723
 724       procedure Check_Fortran_Logical is
 725          Logical : constant Entity_Id := Etype (Formal);
 726          Var     : Entity_Id;
 727
 728       --  Note: this is very incomplete, e.g. it does not handle arrays
 729       --  of logical values. This is really not the right approach at all???)
 730
 731       begin
 732          if Convention (Subp) = Convention_Fortran
 733            and then Root_Type (Etype (Formal)) = Standard_Boolean
 734            and then Ekind (Formal) /= E_In_Parameter
 735          then
 736             Var := Make_Var (Actual);
 737             Append_To (Post_Call,
 738               Make_Assignment_Statement (Loc,
 739                 Name => New_Occurrence_Of (Var, Loc),
 740                 Expression =>
 741                   Unchecked_Convert_To (
 742                     Logical,
 743                     Make_Op_Ne (Loc,
 744                       Left_Opnd  => New_Occurrence_Of (Var, Loc),
 745                       Right_Opnd =>
 746                         Unchecked_Convert_To (
 747                           Logical,
 748                           New_Occurrence_Of (Standard_False, Loc))))));
 749          end if;
 750       end Check_Fortran_Logical;
 751
 752       --------------
 753       -- Make_Var --
 754       --------------
 755
 756       function Make_Var (Actual : Node_Id) return Entity_Id is
 757          Var : Entity_Id;
 758
 759       begin
 760          if Is_Entity_Name (Actual) then
 761             return Entity (Actual);
 762
 763          else
 764             Var := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 765
 766             N_Node :=
 767               Make_Object_Renaming_Declaration (Loc,
 768                 Defining_Identifier => Var,
 769                 Subtype_Mark        =>
 770                   New_Occurrence_Of (Etype (Actual), Loc),
 771                 Name                => Relocate_Node (Actual));
 772
 773             Insert_Action (N, N_Node);
 774             return Var;
 775          end if;
 776       end Make_Var;
 777
 778       -------------------------
 779       -- Reset_Packed_Prefix --
 780       -------------------------
 781
 782       procedure Reset_Packed_Prefix is
 783          Pfx : Node_Id := Actual;
 784
 785       begin
 786          loop
 787             Set_Analyzed (Pfx, False);
 788             exit when Nkind (Pfx) /= N_Selected_Component
 789               and then Nkind (Pfx) /= N_Indexed_Component;
 790             Pfx := Prefix (Pfx);
 791          end loop;
 792       end Reset_Packed_Prefix;
 793
 794    --  Start of processing for Expand_Actuals
 795
 796    begin
 797       Formal := First_Formal (Subp);
 798       Actual := First_Actual (N);
 799
 800       Post_Call := New_List;
 801
 802       while Present (Formal) loop
 803          E_Formal := Etype (Formal);
 804
 805          if Is_Scalar_Type (E_Formal)
 806            or else Nkind (Actual) = N_Slice
 807          then
 808             Check_Fortran_Logical;
 809
 810          --  RM 6.4.1 (11)
 811
 812          elsif Ekind (Formal) /= E_Out_Parameter then
 813
 814             --  The unusual case of the current instance of a protected type
 815             --  requires special handling. This can only occur in the context
 816             --  of a call within the body of a protected operation.
 817
 818             if Is_Entity_Name (Actual)
 819               and then Ekind (Entity (Actual)) = E_Protected_Type
 820               and then In_Open_Scopes (Entity (Actual))
 821             then
 822                if Scope (Subp) /= Entity (Actual) then
 823                   Error_Msg_N ("operation outside protected type may not "
 824                     & "call back its protected operations?", Actual);
 825                end if;
 826
 827                Rewrite (Actual,
 828                  Expand_Protected_Object_Reference (N, Entity (Actual)));
 829             end if;
 830
 831             Apply_Constraint_Check (Actual, E_Formal);
 832
 833          --  Out parameter case. No constraint checks on access type
 834          --  RM 6.4.1 (13)
 835
 836          elsif Is_Access_Type (E_Formal) then
 837             null;
 838
 839          --  RM 6.4.1 (14)
 840
 841          elsif Has_Discriminants (Base_Type (E_Formal))
 842            or else Has_Non_Null_Base_Init_Proc (E_Formal)
 843          then
 844             Apply_Constraint_Check (Actual, E_Formal);
 845
 846          --  RM 6.4.1 (15)
 847
 848          else
 849             Apply_Constraint_Check (Actual, Base_Type (E_Formal));
 850          end if;
 851
 852          --  Processing for IN-OUT and OUT parameters
 853
 854          if Ekind (Formal) /= E_In_Parameter then
 855
 856             --  For type conversions of arrays, apply length/range checks
 857
 858             if Is_Array_Type (E_Formal)
 859               and then Nkind (Actual) = N_Type_Conversion
 860             then
 861                if Is_Constrained (E_Formal) then
 862                   Apply_Length_Check (Expression (Actual), E_Formal);
 863                else
 864                   Apply_Range_Check (Expression (Actual), E_Formal);
 865                end if;
 866             end if;
 867
 868             --  If argument is a type conversion for a type that is passed
 869             --  by copy, then we must pass the parameter by copy.
 870
 871             if Nkind (Actual) = N_Type_Conversion
 872               and then
 873                 (Is_Numeric_Type (E_Formal)
 874                   or else Is_Access_Type (E_Formal)
 875                   or else Is_Enumeration_Type (E_Formal)
 876                   or else Is_Bit_Packed_Array (Etype (Formal))
 877                   or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
 878
 879                   --  Also pass by copy if change of representation
 880
 881                   or else not Same_Representation
 882                                (Etype (Formal),
 883                                 Etype (Expression (Actual))))
 884             then
 885                Add_Call_By_Copy_Code;
 886
 887             --  References to components of bit packed arrays are expanded
 888             --  at this point, rather than at the point of analysis of the
 889             --  actuals, to handle the expansion of the assignment to
 890             --  [in] out parameters.
 891
 892             elsif Is_Ref_To_Bit_Packed_Array (Actual) then
 893                Add_Packed_Call_By_Copy_Code;
 894
 895             --  References to slices of bit packed arrays are expanded
 896
 897             elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
 898                Add_Call_By_Copy_Code;
 899
 900             --  References to possibly unaligned slices of arrays are expanded
 901
 902             elsif Is_Possibly_Unaligned_Slice (Actual) then
 903                Add_Call_By_Copy_Code;
 904
 905             --  Deal with access types where the actual subtpe and the
 906             --  formal subtype are not the same, requiring a check.
 907
 908             --  It is necessary to exclude tagged types because of "downward
 909             --  conversion" errors and a strange assertion error in namet
 910             --  from gnatf in bug 1215-001 ???
 911
 912             elsif Is_Access_Type (E_Formal)
 913               and then not Same_Type (E_Formal, Etype (Actual))
 914               and then not Is_Tagged_Type (Designated_Type (E_Formal))
 915             then
 916                Add_Call_By_Copy_Code;
 917
 918             elsif Is_Entity_Name (Actual)
 919               and then Treat_As_Volatile (Entity (Actual))
 920               and then not Is_Scalar_Type (Etype (Entity (Actual)))
 921               and then not Treat_As_Volatile (E_Formal)
 922             then
 923                Add_Call_By_Copy_Code;
 924
 925             elsif Nkind (Actual) = N_Indexed_Component
 926               and then Is_Entity_Name (Prefix (Actual))
 927               and then Has_Volatile_Components (Entity (Prefix (Actual)))
 928             then
 929                Add_Call_By_Copy_Code;
 930             end if;
 931
 932          --  Processing for IN parameters
 933
 934          else
 935             --  For IN parameters is in the packed array case, we expand an
 936             --  indexed component (the circuit in Exp_Ch4 deliberately left
 937             --  indexed components appearing as actuals untouched, so that
 938             --  the special processing above for the OUT and IN OUT cases
 939             --  could be performed. We could make the test in Exp_Ch4 more
 940             --  complex and have it detect the parameter mode, but it is
 941             --  easier simply to handle all cases here.
 942
 943             if Nkind (Actual) = N_Indexed_Component
 944               and then Is_Packed (Etype (Prefix (Actual)))
 945             then
 946                Reset_Packed_Prefix;
 947                Expand_Packed_Element_Reference (Actual);
 948
 949             --  If we have a reference to a bit packed array, we copy it,
 950             --  since the actual must be byte aligned.
 951
 952             --  Is this really necessary in all cases???
 953
 954             elsif Is_Ref_To_Bit_Packed_Array (Actual) then
 955                Add_Packed_Call_By_Copy_Code;
 956
 957             --  Similarly, we have to expand slices of packed arrays here
 958             --  because the result must be byte aligned.
 959
 960             elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
 961                Add_Call_By_Copy_Code;
 962
 963             --  Only processing remaining is to pass by copy if this is a
 964             --  reference to a possibly unaligned slice, since the caller
 965             --  expects an appropriately aligned argument.
 966
 967             elsif Is_Possibly_Unaligned_Slice (Actual) then
 968                Add_Call_By_Copy_Code;
 969             end if;
 970          end if;
 971
 972          Next_Formal (Formal);
 973          Next_Actual (Actual);
 974       end loop;
 975
 976       --  Find right place to put post call stuff if it is present
 977
 978       if not Is_Empty_List (Post_Call) then
 979
 980          --  If call is not a list member, it must be the triggering
 981          --  statement of a triggering alternative or an entry call
 982          --  alternative, and we can add the post call stuff to the
 983          --  corresponding statement list.
 984
 985          if not Is_List_Member (N) then
 986             declare
 987                P : constant Node_Id := Parent (N);
 988
 989             begin
 990                pragma Assert (Nkind (P) = N_Triggering_Alternative
 991                  or else Nkind (P) = N_Entry_Call_Alternative);
 992
 993                if Is_Non_Empty_List (Statements (P)) then
 994                   Insert_List_Before_And_Analyze
 995                     (First (Statements (P)), Post_Call);
 996                else
 997                   Set_Statements (P, Post_Call);
 998                end if;
 999             end;
1000
1001          --  Otherwise, normal case where N is in a statement sequence,
1002          --  just put the post-call stuff after the call statement.
1003
1004          else
1005             Insert_Actions_After (N, Post_Call);
1006          end if;
1007       end if;
1008
1009       --  The call node itself is re-analyzed in Expand_Call.
1010
1011    end Expand_Actuals;
1012
1013    -----------------
1014    -- Expand_Call --
1015    -----------------
1016
1017    --  This procedure handles expansion of function calls and procedure call
1018    --  statements (i.e. it serves as the body for Expand_N_Function_Call and
1019    --  Expand_N_Procedure_Call_Statement. Processing for calls includes:
1020
1021    --    Replace call to Raise_Exception by Raise_Exception always if possible
1022    --    Provide values of actuals for all formals in Extra_Formals list
1023    --    Replace "call" to enumeration literal function by literal itself
1024    --    Rewrite call to predefined operator as operator
1025    --    Replace actuals to in-out parameters that are numeric conversions,
1026    --     with explicit assignment to temporaries before and after the call.
1027    --    Remove optional actuals if First_Optional_Parameter specified.
1028
1029    --   Note that the list of actuals has been filled with default expressions
1030    --   during semantic analysis of the call. Only the extra actuals required
1031    --   for the 'Constrained attribute and for accessibility checks are added
1032    --   at this point.
1033
1034    procedure Expand_Call (N : Node_Id) is
1035       Loc           : constant Source_Ptr := Sloc (N);
1036       Remote        : constant Boolean    := Is_Remote_Call (N);
1037       Subp          : Entity_Id;
1038       Orig_Subp     : Entity_Id := Empty;
1039       Parent_Subp   : Entity_Id;
1040       Parent_Formal : Entity_Id;
1041       Actual        : Node_Id;
1042       Formal        : Entity_Id;
1043       Prev          : Node_Id := Empty;
1044       Prev_Orig     : Node_Id;
1045       Scop          : Entity_Id;
1046       Extra_Actuals : List_Id := No_List;
1047       Cond          : Node_Id;
1048
1049       procedure Add_Actual_Parameter (Insert_Param : Node_Id);
1050       --  Adds one entry to the end of the actual parameter list. Used for
1051       --  default parameters and for extra actuals (for Extra_Formals).
1052       --  The argument is an N_Parameter_Association node.
1053
1054       procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
1055       --  Adds an extra actual to the list of extra actuals. Expr
1056       --  is the expression for the value of the actual, EF is the
1057       --  entity for the extra formal.
1058
1059       function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
1060       --  Within an instance, a type derived from a non-tagged formal derived
1061       --  type inherits from the original parent, not from the actual. This is
1062       --  tested in 4723-003. The current derivation mechanism has the derived
1063       --  type inherit from the actual, which is only correct outside of the
1064       --  instance. If the subprogram is inherited, we test for this particular
1065       --  case through a convoluted tree traversal before setting the proper
1066       --  subprogram to be called.
1067
1068       --------------------------
1069       -- Add_Actual_Parameter --
1070       --------------------------
1071
1072       procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
1073          Actual_Expr : constant Node_Id :=
1074                          Explicit_Actual_Parameter (Insert_Param);
1075
1076       begin
1077          --  Case of insertion is first named actual
1078
1079          if No (Prev) or else
1080             Nkind (Parent (Prev)) /= N_Parameter_Association
1081          then
1082             Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N));
1083             Set_First_Named_Actual (N, Actual_Expr);
1084
1085             if No (Prev) then
1086                if not Present (Parameter_Associations (N)) then
1087                   Set_Parameter_Associations (N, New_List);
1088                   Append (Insert_Param, Parameter_Associations (N));
1089                end if;
1090             else
1091                Insert_After (Prev, Insert_Param);
1092             end if;
1093
1094          --  Case of insertion is not first named actual
1095
1096          else
1097             Set_Next_Named_Actual
1098               (Insert_Param, Next_Named_Actual (Parent (Prev)));
1099             Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
1100             Append (Insert_Param, Parameter_Associations (N));
1101          end if;
1102
1103          Prev := Actual_Expr;
1104       end Add_Actual_Parameter;
1105
1106       ----------------------
1107       -- Add_Extra_Actual --
1108       ----------------------
1109
1110       procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
1111          Loc : constant Source_Ptr := Sloc (Expr);
1112
1113       begin
1114          if Extra_Actuals = No_List then
1115             Extra_Actuals := New_List;
1116             Set_Parent (Extra_Actuals, N);
1117          end if;
1118
1119          Append_To (Extra_Actuals,
1120            Make_Parameter_Association (Loc,
1121              Explicit_Actual_Parameter => Expr,
1122              Selector_Name =>
1123                Make_Identifier (Loc, Chars (EF))));
1124
1125          Analyze_And_Resolve (Expr, Etype (EF));
1126       end Add_Extra_Actual;
1127
1128       ---------------------------
1129       -- Inherited_From_Formal --
1130       ---------------------------
1131
1132       function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
1133          Par      : Entity_Id;
1134          Gen_Par  : Entity_Id;
1135          Gen_Prim : Elist_Id;
1136          Elmt     : Elmt_Id;
1137          Indic    : Node_Id;
1138
1139       begin
1140          --  If the operation is inherited, it is attached to the corresponding
1141          --  type derivation. If the parent in the derivation is a generic
1142          --  actual, it is a subtype of the actual, and we have to recover the
1143          --  original derived type declaration to find the proper parent.
1144
1145          if Nkind (Parent (S)) /= N_Full_Type_Declaration
1146            or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
1147            or else Nkind (Type_Definition (Original_Node (Parent (S))))
1148              /= N_Derived_Type_Definition
1149            or else not In_Instance
1150          then
1151             return Empty;
1152
1153          else
1154             Indic :=
1155               (Subtype_Indication
1156                 (Type_Definition (Original_Node (Parent (S)))));
1157
1158             if Nkind (Indic) = N_Subtype_Indication then
1159                Par := Entity (Subtype_Mark (Indic));
1160             else
1161                Par := Entity (Indic);
1162             end if;
1163          end if;
1164
1165          if not Is_Generic_Actual_Type (Par)
1166            or else Is_Tagged_Type (Par)
1167            or else Nkind (Parent (Par)) /= N_Subtype_Declaration
1168            or else not In_Open_Scopes (Scope (Par))
1169          then
1170             return Empty;
1171
1172          else
1173             Gen_Par := Generic_Parent_Type (Parent (Par));
1174          end if;
1175
1176          --  If the generic parent type is still the generic type, this
1177          --  is a private formal, not a derived formal, and there are no
1178          --  operations inherited from the formal.
1179
1180          if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
1181             return Empty;
1182          end if;
1183
1184          Gen_Prim := Collect_Primitive_Operations (Gen_Par);
1185          Elmt := First_Elmt (Gen_Prim);
1186
1187          while Present (Elmt) loop
1188             if Chars (Node (Elmt)) = Chars (S) then
1189                declare
1190                   F1 : Entity_Id;
1191                   F2 : Entity_Id;
1192                begin
1193
1194                   F1 := First_Formal (S);
1195                   F2 := First_Formal (Node (Elmt));
1196
1197                   while Present (F1)
1198                     and then Present (F2)
1199                   loop
1200
1201                      if Etype (F1) = Etype (F2)
1202                        or else Etype (F2) = Gen_Par
1203                      then
1204                         Next_Formal (F1);
1205                         Next_Formal (F2);
1206                      else
1207                         Next_Elmt (Elmt);
1208                         exit;   --  not the right subprogram
1209                      end if;
1210
1211                      return Node (Elmt);
1212                   end loop;
1213                end;
1214
1215             else
1216                Next_Elmt (Elmt);
1217             end if;
1218          end loop;
1219
1220          raise Program_Error;
1221       end Inherited_From_Formal;
1222
1223    --  Start of processing for Expand_Call
1224
1225    begin
1226       --  Ignore if previous error
1227
1228       if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
1229          return;
1230       end if;
1231
1232       --  Call using access to subprogram with explicit dereference
1233
1234       if Nkind (Name (N)) = N_Explicit_Dereference then
1235          Subp        := Etype (Name (N));
1236          Parent_Subp := Empty;
1237
1238       --  Case of call to simple entry, where the Name is a selected component
1239       --  whose prefix is the task, and whose selector name is the entry name
1240
1241       elsif Nkind (Name (N)) = N_Selected_Component then
1242          Subp        := Entity (Selector_Name (Name (N)));
1243          Parent_Subp := Empty;
1244
1245       --  Case of call to member of entry family, where Name is an indexed
1246       --  component, with the prefix being a selected component giving the
1247       --  task and entry family name, and the index being the entry index.
1248
1249       elsif Nkind (Name (N)) = N_Indexed_Component then
1250          Subp        := Entity (Selector_Name (Prefix (Name (N))));
1251          Parent_Subp := Empty;
1252
1253       --  Normal case
1254
1255       else
1256          Subp        := Entity (Name (N));
1257          Parent_Subp := Alias (Subp);
1258
1259          --  Replace call to Raise_Exception by call to Raise_Exception_Always
1260          --  if we can tell that the first parameter cannot possibly be null.
1261          --  This helps optimization and also generation of warnings.
1262
1263          if not Restrictions (No_Exception_Handlers)
1264            and then Is_RTE (Subp, RE_Raise_Exception)
1265          then
1266             declare
1267                FA : constant Node_Id := Original_Node (First_Actual (N));
1268
1269             begin
1270                --  The case we catch is where the first argument is obtained
1271                --  using the Identity attribute (which must always be non-null)
1272
1273                if Nkind (FA) = N_Attribute_Reference
1274                  and then Attribute_Name (FA) = Name_Identity
1275                then
1276                   Subp := RTE (RE_Raise_Exception_Always);
1277                   Set_Entity (Name (N), Subp);
1278                end if;
1279             end;
1280          end if;
1281
1282          if Ekind (Subp) = E_Entry then
1283             Parent_Subp := Empty;
1284          end if;
1285       end if;
1286
1287       --  First step, compute extra actuals, corresponding to any
1288       --  Extra_Formals present. Note that we do not access Extra_Formals
1289       --  directly, instead we simply note the presence of the extra
1290       --  formals as we process the regular formals and collect the
1291       --  corresponding actuals in Extra_Actuals.
1292
1293       --  We also generate any required range checks for actuals as we go
1294       --  through the loop, since this is a convenient place to do this.
1295
1296       Formal := First_Formal (Subp);
1297       Actual := First_Actual (N);
1298       while Present (Formal) loop
1299
1300          --  Generate range check if required (not activated yet ???)
1301
1302 --         if Do_Range_Check (Actual) then
1303 --            Set_Do_Range_Check (Actual, False);
1304 --            Generate_Range_Check
1305 --              (Actual, Etype (Formal), CE_Range_Check_Failed);
1306 --         end if;
1307
1308          --  Prepare to examine current entry
1309
1310          Prev := Actual;
1311          Prev_Orig := Original_Node (Prev);
1312
1313          --  Create possible extra actual for constrained case. Usually,
1314          --  the extra actual is of the form actual'constrained, but since
1315          --  this attribute is only available for unconstrained records,
1316          --  TRUE is expanded if the type of the formal happens to be
1317          --  constrained (for instance when this procedure is inherited
1318          --  from an unconstrained record to a constrained one) or if the
1319          --  actual has no discriminant (its type is constrained). An
1320          --  exception to this is the case of a private type without
1321          --  discriminants. In this case we pass FALSE because the
1322          --  object has underlying discriminants with defaults.
1323
1324          if Present (Extra_Constrained (Formal)) then
1325             if Ekind (Etype (Prev)) in Private_Kind
1326               and then not Has_Discriminants (Base_Type (Etype (Prev)))
1327             then
1328                Add_Extra_Actual (
1329                  New_Occurrence_Of (Standard_False, Loc),
1330                  Extra_Constrained (Formal));
1331
1332             elsif Is_Constrained (Etype (Formal))
1333               or else not Has_Discriminants (Etype (Prev))
1334             then
1335                Add_Extra_Actual (
1336                  New_Occurrence_Of (Standard_True, Loc),
1337                  Extra_Constrained (Formal));
1338
1339             else
1340                --  If the actual is a type conversion, then the constrained
1341                --  test applies to the actual, not the target type.
1342
1343                declare
1344                   Act_Prev : Node_Id := Prev;
1345
1346                begin
1347                   --  Test for unchecked conversions as well, which can
1348                   --  occur as out parameter actuals on calls to stream
1349                   --  procedures.
1350
1351                   while Nkind (Act_Prev) = N_Type_Conversion
1352                     or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
1353                   loop
1354                      Act_Prev := Expression (Act_Prev);
1355                   end loop;
1356
1357                   Add_Extra_Actual (
1358                     Make_Attribute_Reference (Sloc (Prev),
1359                       Prefix =>
1360                         Duplicate_Subexpr_No_Checks
1361                           (Act_Prev, Name_Req => True),
1362                       Attribute_Name => Name_Constrained),
1363                     Extra_Constrained (Formal));
1364                end;
1365             end if;
1366          end if;
1367
1368          --  Create possible extra actual for accessibility level
1369
1370          if Present (Extra_Accessibility (Formal)) then
1371             if Is_Entity_Name (Prev_Orig) then
1372
1373                --  When passing an access parameter as the actual to another
1374                --  access parameter we need to pass along the actual's own
1375                --  associated access level parameter. This is done is we are
1376                --  in the scope of the formal access parameter (if this is an
1377                --  inlined body the extra formal is irrelevant).
1378
1379                if Ekind (Entity (Prev_Orig)) in Formal_Kind
1380                  and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
1381                  and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
1382                then
1383                   declare
1384                      Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig);
1385
1386                   begin
1387                      pragma Assert (Present (Parm_Ent));
1388
1389                      if Present (Extra_Accessibility (Parm_Ent)) then
1390                         Add_Extra_Actual (
1391                           New_Occurrence_Of
1392                             (Extra_Accessibility (Parm_Ent), Loc),
1393                           Extra_Accessibility (Formal));
1394
1395                      --  If the actual access parameter does not have an
1396                      --  associated extra formal providing its scope level,
1397                      --  then treat the actual as having library-level
1398                      --  accessibility.
1399
1400                      else
1401                         Add_Extra_Actual (
1402                           Make_Integer_Literal (Loc,
1403                             Intval => Scope_Depth (Standard_Standard)),
1404                           Extra_Accessibility (Formal));
1405                      end if;
1406                   end;
1407
1408                --  The actual is a normal access value, so just pass the
1409                --  level of the actual's access type.
1410
1411                else
1412                   Add_Extra_Actual (
1413                     Make_Integer_Literal (Loc,
1414                       Intval => Type_Access_Level (Etype (Prev_Orig))),
1415                     Extra_Accessibility (Formal));
1416                end if;
1417
1418             else
1419                case Nkind (Prev_Orig) is
1420
1421                   when N_Attribute_Reference =>
1422
1423                      case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
1424
1425                         --  For X'Access, pass on the level of the prefix X
1426
1427                         when Attribute_Access =>
1428                            Add_Extra_Actual (
1429                              Make_Integer_Literal (Loc,
1430                                Intval =>
1431                                  Object_Access_Level (Prefix (Prev_Orig))),
1432                              Extra_Accessibility (Formal));
1433
1434                         --  Treat the unchecked attributes as library-level
1435
1436                         when Attribute_Unchecked_Access |
1437                            Attribute_Unrestricted_Access =>
1438                            Add_Extra_Actual (
1439                              Make_Integer_Literal (Loc,
1440                                Intval => Scope_Depth (Standard_Standard)),
1441                              Extra_Accessibility (Formal));
1442
1443                         --  No other cases of attributes returning access
1444                         --  values that can be passed to access parameters
1445
1446                         when others =>
1447                            raise Program_Error;
1448
1449                      end case;
1450
1451                   --  For allocators we pass the level of the execution of
1452                   --  the called subprogram, which is one greater than the
1453                   --  current scope level.
1454
1455                   when N_Allocator =>
1456                      Add_Extra_Actual (
1457                        Make_Integer_Literal (Loc,
1458                         Scope_Depth (Current_Scope) + 1),
1459                        Extra_Accessibility (Formal));
1460
1461                   --  For other cases we simply pass the level of the
1462                   --  actual's access type.
1463
1464                   when others =>
1465                      Add_Extra_Actual (
1466                        Make_Integer_Literal (Loc,
1467                          Intval => Type_Access_Level (Etype (Prev_Orig))),
1468                        Extra_Accessibility (Formal));
1469
1470                end case;
1471             end if;
1472          end if;
1473
1474          --  Perform the check of 4.6(49) that prevents a null value
1475          --  from being passed as an actual to an access parameter.
1476          --  Note that the check is elided in the common cases of
1477          --  passing an access attribute or access parameter as an
1478          --  actual. Also, we currently don't enforce this check for
1479          --  expander-generated actuals and when -gnatdj is set.
1480
1481          if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
1482            or else Access_Checks_Suppressed (Subp)
1483          then
1484             null;
1485
1486          elsif Debug_Flag_J then
1487             null;
1488
1489          elsif not Comes_From_Source (Prev) then
1490             null;
1491
1492          elsif Is_Entity_Name (Prev)
1493            and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
1494          then
1495             null;
1496
1497          elsif Nkind (Prev) = N_Allocator
1498            or else Nkind (Prev) = N_Attribute_Reference
1499          then
1500             null;
1501
1502          --  Suppress null checks when passing to access parameters
1503          --  of Java subprograms. (Should this be done for other
1504          --  foreign conventions as well ???)
1505
1506          elsif Convention (Subp) = Convention_Java then
1507             null;
1508
1509          else
1510             Cond :=
1511               Make_Op_Eq (Loc,
1512                 Left_Opnd => Duplicate_Subexpr_No_Checks (Prev),
1513                 Right_Opnd => Make_Null (Loc));
1514             Insert_Action (Prev,
1515               Make_Raise_Constraint_Error (Loc,
1516                 Condition => Cond,
1517                 Reason    => CE_Access_Parameter_Is_Null));
1518          end if;
1519
1520          --  Perform appropriate validity checks on parameters that
1521          --  are entities.
1522
1523          if Validity_Checks_On then
1524             if Ekind (Formal) = E_In_Parameter
1525               and then Validity_Check_In_Params
1526               and then Is_Entity_Name (Actual)
1527             then
1528                Ensure_Valid (Actual);
1529
1530             elsif Ekind (Formal) = E_In_Out_Parameter
1531               and then Validity_Check_In_Out_Params
1532             then
1533                Ensure_Valid (Actual);
1534             end if;
1535          end if;
1536
1537          --  For IN OUT and OUT parameters, ensure that subscripts are valid
1538          --  since this is a left side reference. We only do this for calls
1539          --  from the source program since we assume that compiler generated
1540          --  calls explicitly generate any required checks. We also need it
1541          --  only if we are doing standard validity checks, since clearly it
1542          --  is not needed if validity checks are off, and in subscript
1543          --  validity checking mode, all indexed components are checked with
1544          --  a call directly from Expand_N_Indexed_Component.
1545
1546          if Comes_From_Source (N)
1547            and then Ekind (Formal) /= E_In_Parameter
1548            and then Validity_Checks_On
1549            and then Validity_Check_Default
1550            and then not Validity_Check_Subscripts
1551          then
1552             Check_Valid_Lvalue_Subscripts (Actual);
1553          end if;
1554
1555          --  Mark any scalar OUT parameter that is a simple variable
1556          --  as no longer known to be valid (unless the type is always
1557          --  valid). This reflects the fact that if an OUT parameter
1558          --  is never set in a procedure, then it can become invalid
1559          --  on return from the procedure.
1560
1561          if Ekind (Formal) = E_Out_Parameter
1562            and then Is_Entity_Name (Actual)
1563            and then Ekind (Entity (Actual)) = E_Variable
1564            and then not Is_Known_Valid (Etype (Actual))
1565          then
1566             Set_Is_Known_Valid (Entity (Actual), False);
1567          end if;
1568
1569          --  For an OUT or IN OUT parameter of an access type, if the
1570          --  actual is an entity, then it is no longer known to be non-null.
1571
1572          if Ekind (Formal) /= E_In_Parameter
1573            and then Is_Entity_Name (Actual)
1574            and then Is_Access_Type (Etype (Actual))
1575          then
1576             Set_Is_Known_Non_Null (Entity (Actual), False);
1577          end if;
1578
1579          --  If the formal is class wide and the actual is an aggregate, force
1580          --  evaluation so that the back end who does not know about class-wide
1581          --  type, does not generate a temporary of the wrong size.
1582
1583          if not Is_Class_Wide_Type (Etype (Formal)) then
1584             null;
1585
1586          elsif Nkind (Actual) = N_Aggregate
1587            or else (Nkind (Actual) = N_Qualified_Expression
1588                      and then Nkind (Expression (Actual)) = N_Aggregate)
1589          then
1590             Force_Evaluation (Actual);
1591          end if;
1592
1593          --  In a remote call, if the formal is of a class-wide type, check
1594          --  that the actual meets the requirements described in E.4(18).
1595
1596          if Remote
1597            and then Is_Class_Wide_Type (Etype (Formal))
1598          then
1599             Insert_Action (Actual,
1600               Make_Implicit_If_Statement (N,
1601                 Condition       =>
1602                   Make_Op_Not (Loc,
1603                     Get_Remotely_Callable
1604                       (Duplicate_Subexpr_Move_Checks (Actual))),
1605                 Then_Statements => New_List (
1606                   Make_Procedure_Call_Statement (Loc,
1607                     New_Occurrence_Of (RTE
1608                       (RE_Raise_Program_Error_For_E_4_18), Loc)))));
1609          end if;
1610
1611          Next_Actual (Actual);
1612          Next_Formal (Formal);
1613       end loop;
1614
1615       --  If we are expanding a rhs of an assignement we need to check if
1616       --  tag propagation is needed. This code belongs theorically in Analyze
1617       --  Assignment but has to be done earlier (bottom-up) because the
1618       --  assignment might be transformed into a declaration for an uncons-
1619       --  trained value, if the expression is classwide.
1620
1621       if Nkind (N) = N_Function_Call
1622         and then Is_Tag_Indeterminate (N)
1623         and then Is_Entity_Name (Name (N))
1624       then
1625          declare
1626             Ass : Node_Id := Empty;
1627
1628          begin
1629             if Nkind (Parent (N)) = N_Assignment_Statement then
1630                Ass := Parent (N);
1631
1632             elsif Nkind (Parent (N)) = N_Qualified_Expression
1633               and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
1634             then
1635                Ass := Parent (Parent (N));
1636             end if;
1637
1638             if Present (Ass)
1639               and then Is_Class_Wide_Type (Etype (Name (Ass)))
1640             then
1641                if Etype (N) /= Root_Type (Etype (Name (Ass))) then
1642                   Error_Msg_NE
1643                     ("tag-indeterminate expression must have type&"
1644                       & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
1645                else
1646                   Propagate_Tag (Name (Ass), N);
1647                end if;
1648
1649                --  The call will be rewritten as a dispatching call, and
1650                --  expanded as such.
1651
1652                return;
1653             end if;
1654          end;
1655       end if;
1656
1657       --  Deals with Dispatch_Call if we still have a call, before expanding
1658       --  extra actuals since this will be done on the re-analysis of the
1659       --  dispatching call. Note that we do not try to shorten the actual
1660       --  list for a dispatching call, it would not make sense to do so.
1661       --  Expansion of dispatching calls is suppressed when Java_VM, because
1662       --  the JVM back end directly handles the generation of dispatching
1663       --  calls and would have to undo any expansion to an indirect call.
1664
1665       if (Nkind (N) = N_Function_Call
1666            or else Nkind (N) =  N_Procedure_Call_Statement)
1667         and then Present (Controlling_Argument (N))
1668         and then not Java_VM
1669       then
1670          Expand_Dispatch_Call (N);
1671
1672          --  The following return is worrisome. Is it really OK to
1673          --  skip all remaining processing in this procedure ???
1674
1675          return;
1676
1677       --  Similarly, expand calls to RCI subprograms on which pragma
1678       --  All_Calls_Remote applies. The rewriting will be reanalyzed
1679       --  later. Do this only when the call comes from source since we do
1680       --  not want such a rewritting to occur in expanded code.
1681
1682       elsif Is_All_Remote_Call (N) then
1683          Expand_All_Calls_Remote_Subprogram_Call (N);
1684
1685       --  Similarly, do not add extra actuals for an entry call whose entity
1686       --  is a protected procedure, or for an internal protected subprogram
1687       --  call, because it will be rewritten as a protected subprogram call
1688       --  and reanalyzed (see Expand_Protected_Subprogram_Call).
1689
1690       elsif Is_Protected_Type (Scope (Subp))
1691          and then (Ekind (Subp) = E_Procedure
1692                     or else Ekind (Subp) = E_Function)
1693       then
1694          null;
1695
1696       --  During that loop we gathered the extra actuals (the ones that
1697       --  correspond to Extra_Formals), so now they can be appended.
1698
1699       else
1700          while Is_Non_Empty_List (Extra_Actuals) loop
1701             Add_Actual_Parameter (Remove_Head (Extra_Actuals));
1702          end loop;
1703       end if;
1704
1705       if Ekind (Subp) = E_Procedure
1706          or else (Ekind (Subp) = E_Subprogram_Type
1707                    and then Etype (Subp) = Standard_Void_Type)
1708          or else Is_Entry (Subp)
1709       then
1710          Expand_Actuals (N, Subp);
1711       end if;
1712
1713       --  If the subprogram is a renaming, or if it is inherited, replace it
1714       --  in the call with the name of the actual subprogram being called.
1715       --  If this is a dispatching call, the run-time decides what to call.
1716       --  The Alias attribute does not apply to entries.
1717
1718       if Nkind (N) /= N_Entry_Call_Statement
1719         and then No (Controlling_Argument (N))
1720         and then Present (Parent_Subp)
1721       then
1722          if Present (Inherited_From_Formal (Subp)) then
1723             Parent_Subp := Inherited_From_Formal (Subp);
1724          else
1725             while Present (Alias (Parent_Subp)) loop
1726                Parent_Subp := Alias (Parent_Subp);
1727             end loop;
1728          end if;
1729
1730          Set_Entity (Name (N), Parent_Subp);
1731
1732          if Is_Abstract (Parent_Subp)
1733            and then not In_Instance
1734          then
1735             Error_Msg_NE
1736               ("cannot call abstract subprogram &!", Name (N), Parent_Subp);
1737          end if;
1738
1739          --  Add an explicit conversion for parameter of the derived type.
1740          --  This is only done for scalar and access in-parameters. Others
1741          --  have been expanded in expand_actuals.
1742
1743          Formal := First_Formal (Subp);
1744          Parent_Formal := First_Formal (Parent_Subp);
1745          Actual := First_Actual (N);
1746
1747          --  It is not clear that conversion is needed for intrinsic
1748          --  subprograms, but it certainly is for those that are user-
1749          --  defined, and that can be inherited on derivation, namely
1750          --  unchecked conversion and deallocation.
1751          --  General case needs study ???
1752
1753          if not Is_Intrinsic_Subprogram (Parent_Subp)
1754            or else Is_Generic_Instance (Parent_Subp)
1755          then
1756             while Present (Formal) loop
1757
1758                if Etype (Formal) /= Etype (Parent_Formal)
1759                  and then Is_Scalar_Type (Etype (Formal))
1760                  and then Ekind (Formal) = E_In_Parameter
1761                  and then not Raises_Constraint_Error (Actual)
1762                then
1763                   Rewrite (Actual,
1764                     OK_Convert_To (Etype (Parent_Formal),
1765                       Relocate_Node (Actual)));
1766
1767                   Analyze (Actual);
1768                   Resolve (Actual, Etype (Parent_Formal));
1769                   Enable_Range_Check (Actual);
1770
1771                elsif Is_Access_Type (Etype (Formal))
1772                  and then Base_Type (Etype (Parent_Formal))
1773                    /= Base_Type (Etype (Actual))
1774                then
1775                   if Ekind (Formal) /= E_In_Parameter then
1776                      Rewrite (Actual,
1777                        Convert_To (Etype (Parent_Formal),
1778                          Relocate_Node (Actual)));
1779
1780                      Analyze (Actual);
1781                      Resolve (Actual, Etype (Parent_Formal));
1782
1783                   elsif
1784                     Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type
1785                       and then Designated_Type (Etype (Parent_Formal))
1786                                  /=
1787                                Designated_Type (Etype (Actual))
1788                       and then not Is_Controlling_Formal (Formal)
1789                   then
1790                      --  This unchecked conversion is not necessary unless
1791                      --  inlining is enabled, because in that case the type
1792                      --  mismatch may become visible in the body about to be
1793                      --  inlined.
1794
1795                      Rewrite (Actual,
1796                        Unchecked_Convert_To (Etype (Parent_Formal),
1797                          Relocate_Node (Actual)));
1798
1799                      Analyze (Actual);
1800                      Resolve (Actual, Etype (Parent_Formal));
1801                   end if;
1802                end if;
1803
1804                Next_Formal (Formal);
1805                Next_Formal (Parent_Formal);
1806                Next_Actual (Actual);
1807             end loop;
1808          end if;
1809
1810          Orig_Subp := Subp;
1811          Subp := Parent_Subp;
1812       end if;
1813
1814       if Is_RTE (Subp, RE_Abort_Task) then
1815          Check_Restriction (No_Abort_Statements, N);
1816       end if;
1817
1818       --  Some more special cases for cases other than explicit dereference
1819
1820       if Nkind (Name (N)) /= N_Explicit_Dereference then
1821
1822          --  Calls to an enumeration literal are replaced by the literal
1823          --  This case occurs only when we have a call to a function that
1824          --  is a renaming of an enumeration literal. The normal case of
1825          --  a direct reference to an enumeration literal has already been
1826          --  been dealt with by Resolve_Call. If the function is itself
1827          --  inherited (see 7423-001) the literal of the parent type must
1828          --  be explicitly converted to the return type of the function.
1829
1830          if Ekind (Subp) = E_Enumeration_Literal then
1831             if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then
1832                Rewrite
1833                  (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc)));
1834             else
1835                Rewrite (N, New_Occurrence_Of (Subp, Loc));
1836             end if;
1837
1838             Resolve (N);
1839          end if;
1840
1841       --  Handle case of access to protected subprogram type
1842
1843       else
1844          if Ekind (Base_Type (Etype (Prefix (Name (N))))) =
1845                                E_Access_Protected_Subprogram_Type
1846          then
1847             --  If this is a call through an access to protected operation,
1848             --  the prefix has the form (object'address, operation'access).
1849             --  Rewrite as a for other protected calls: the object is the
1850             --  first parameter of the list of actuals.
1851
1852             declare
1853                Call : Node_Id;
1854                Parm : List_Id;
1855                Nam  : Node_Id;
1856                Obj  : Node_Id;
1857                Ptr  : constant Node_Id := Prefix (Name (N));
1858
1859                T : constant Entity_Id :=
1860                      Equivalent_Type (Base_Type (Etype (Ptr)));
1861
1862                D_T : constant Entity_Id :=
1863                        Designated_Type (Base_Type (Etype (Ptr)));
1864
1865             begin
1866                Obj := Make_Selected_Component (Loc,
1867                  Prefix => Unchecked_Convert_To (T, Ptr),
1868                  Selector_Name => New_Occurrence_Of (First_Entity (T), Loc));
1869
1870                Nam := Make_Selected_Component (Loc,
1871                  Prefix => Unchecked_Convert_To (T, Ptr),
1872                  Selector_Name => New_Occurrence_Of (
1873                    Next_Entity (First_Entity (T)), Loc));
1874
1875                Nam := Make_Explicit_Dereference (Loc, Nam);
1876
1877                if Present (Parameter_Associations (N))  then
1878                   Parm := Parameter_Associations (N);
1879                else
1880                   Parm := New_List;
1881                end if;
1882
1883                Prepend (Obj, Parm);
1884
1885                if Etype (D_T) = Standard_Void_Type then
1886                   Call := Make_Procedure_Call_Statement (Loc,
1887                     Name => Nam,
1888                     Parameter_Associations => Parm);
1889                else
1890                   Call := Make_Function_Call (Loc,
1891                     Name => Nam,
1892                     Parameter_Associations => Parm);
1893                end if;
1894
1895                Set_First_Named_Actual (Call, First_Named_Actual (N));
1896                Set_Etype (Call, Etype (D_T));
1897
1898                --  We do not re-analyze the call to avoid infinite recursion.
1899                --  We analyze separately the prefix and the object, and set
1900                --  the checks on the prefix that would otherwise be emitted
1901                --  when resolving a call.
1902
1903                Rewrite (N, Call);
1904                Analyze (Nam);
1905                Apply_Access_Check (Nam);
1906                Analyze (Obj);
1907                return;
1908             end;
1909          end if;
1910       end if;
1911
1912       --  If this is a call to an intrinsic subprogram, then perform the
1913       --  appropriate expansion to the corresponding tree node and we
1914       --  are all done (since after that the call is gone!)
1915
1916       if Is_Intrinsic_Subprogram (Subp) then
1917          Expand_Intrinsic_Call (N, Subp);
1918          return;
1919       end if;
1920
1921       if Ekind (Subp) = E_Function
1922         or else Ekind (Subp) = E_Procedure
1923       then
1924          if Is_Inlined (Subp) then
1925
1926             declare
1927                Bod         : Node_Id;
1928                Must_Inline : Boolean := False;
1929                Spec        : constant Node_Id := Unit_Declaration_Node (Subp);
1930
1931             begin
1932                --  Verify that the body to inline has already been seen,
1933                --  and that if the body is in the current unit the inlining
1934                --  does not occur earlier. This avoids order-of-elaboration
1935                --  problems in gigi.
1936
1937                if No (Spec)
1938                  or else Nkind (Spec) /= N_Subprogram_Declaration
1939                  or else No (Body_To_Inline (Spec))
1940                then
1941                   Must_Inline := False;
1942
1943                else
1944                   Bod := Body_To_Inline (Spec);
1945
1946                   if (In_Extended_Main_Code_Unit (N)
1947                         or else In_Extended_Main_Code_Unit (Parent (N))
1948                         or else Is_Always_Inlined (Subp))
1949                     and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
1950                                or else
1951                                  Earlier_In_Extended_Unit (Sloc (Bod), Loc))
1952                   then
1953                      Must_Inline := True;
1954
1955                   --  If we are compiling a package body that is not the main
1956                   --  unit, it must be for inlining/instantiation purposes,
1957                   --  in which case we inline the call to insure that the same
1958                   --  temporaries are generated when compiling the body by
1959                   --  itself. Otherwise link errors can occur.
1960
1961                   elsif not (In_Extended_Main_Code_Unit (N))
1962                     and then In_Package_Body
1963                   then
1964                      Must_Inline := True;
1965                   end if;
1966                end if;
1967
1968                if Must_Inline then
1969                   Expand_Inlined_Call (N, Subp, Orig_Subp);
1970
1971                else
1972                   --  Let the back end handle it
1973
1974                   Add_Inlined_Body (Subp);
1975
1976                   if Front_End_Inlining
1977                     and then Nkind (Spec) = N_Subprogram_Declaration
1978                     and then (In_Extended_Main_Code_Unit (N))
1979                     and then No (Body_To_Inline (Spec))
1980                     and then not Has_Completion (Subp)
1981                     and then In_Same_Extended_Unit (Sloc (Spec), Loc)
1982                   then
1983                      Cannot_Inline
1984                       ("cannot inline& (body not seen yet)?",
1985                        N, Subp);
1986                   end if;
1987                end if;
1988             end;
1989          end if;
1990       end if;
1991
1992       --  Check for a protected subprogram. This is either an intra-object
1993       --  call, or a protected function call. Protected procedure calls are
1994       --  rewritten as entry calls and handled accordingly.
1995
1996       Scop := Scope (Subp);
1997
1998       if Nkind (N) /= N_Entry_Call_Statement
1999         and then Is_Protected_Type (Scop)
2000       then
2001          --  If the call is an internal one, it is rewritten as a call to
2002          --  to the corresponding unprotected subprogram.
2003
2004          Expand_Protected_Subprogram_Call (N, Subp, Scop);
2005       end if;
2006
2007       --  Functions returning controlled objects need special attention
2008
2009       if Controlled_Type (Etype (Subp))
2010         and then not Is_Return_By_Reference_Type (Etype (Subp))
2011       then
2012          Expand_Ctrl_Function_Call (N);
2013       end if;
2014
2015       --  Test for First_Optional_Parameter, and if so, truncate parameter
2016       --  list if there are optional parameters at the trailing end.
2017       --  Note we never delete procedures for call via a pointer.
2018
2019       if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function)
2020         and then Present (First_Optional_Parameter (Subp))
2021       then
2022          declare
2023             Last_Keep_Arg : Node_Id;
2024
2025          begin
2026             --  Last_Keep_Arg will hold the last actual that should be
2027             --  retained. If it remains empty at the end, it means that
2028             --  all parameters are optional.
2029
2030             Last_Keep_Arg := Empty;
2031
2032             --  Find first optional parameter, must be present since we
2033             --  checked the validity of the parameter before setting it.
2034
2035             Formal := First_Formal (Subp);
2036             Actual := First_Actual (N);
2037             while Formal /= First_Optional_Parameter (Subp) loop
2038                Last_Keep_Arg := Actual;
2039                Next_Formal (Formal);
2040                Next_Actual (Actual);
2041             end loop;
2042
2043             --  We have Formal and Actual pointing to the first potentially
2044             --  droppable argument. We can drop all the trailing arguments
2045             --  whose actual matches the default. Note that we know that all
2046             --  remaining formals have defaults, because we checked that this
2047             --  requirement was met before setting First_Optional_Parameter.
2048
2049             --  We use Fully_Conformant_Expressions to check for identity
2050             --  between formals and actuals, which may miss some cases, but
2051             --  on the other hand, this is only an optimization (if we fail
2052             --  to truncate a parameter it does not affect functionality).
2053             --  So if the default is 3 and the actual is 1+2, we consider
2054             --  them unequal, which hardly seems worrisome.
2055
2056             while Present (Formal) loop
2057                if not Fully_Conformant_Expressions
2058                     (Actual, Default_Value (Formal))
2059                then
2060                   Last_Keep_Arg := Actual;
2061                end if;
2062
2063                Next_Formal (Formal);
2064                Next_Actual (Actual);
2065             end loop;
2066
2067             --  If no arguments, delete entire list, this is the easy case
2068
2069             if No (Last_Keep_Arg) then
2070                while Is_Non_Empty_List (Parameter_Associations (N)) loop
2071                   Delete_Tree (Remove_Head (Parameter_Associations (N)));
2072                end loop;
2073
2074                Set_Parameter_Associations (N, No_List);
2075                Set_First_Named_Actual (N, Empty);
2076
2077             --  Case where at the last retained argument is positional. This
2078             --  is also an easy case, since the retained arguments are already
2079             --  in the right form, and we don't need to worry about the order
2080             --  of arguments that get eliminated.
2081
2082             elsif Is_List_Member (Last_Keep_Arg) then
2083                while Present (Next (Last_Keep_Arg)) loop
2084                   Delete_Tree (Remove_Next (Last_Keep_Arg));
2085                end loop;
2086
2087                Set_First_Named_Actual (N, Empty);
2088
2089             --  This is the annoying case where the last retained argument
2090             --  is a named parameter. Since the original arguments are not
2091             --  in declaration order, we may have to delete some fairly
2092             --  random collection of arguments.
2093
2094             else
2095                declare
2096                   Temp   : Node_Id;
2097                   Passoc : Node_Id;
2098
2099                   Discard : Node_Id;
2100                   pragma Warnings (Off, Discard);
2101
2102                begin
2103                   --  First step, remove all the named parameters from the
2104                   --  list (they are still chained using First_Named_Actual
2105                   --  and Next_Named_Actual, so we have not lost them!)
2106
2107                   Temp := First (Parameter_Associations (N));
2108
2109                   --  Case of all parameters named, remove them all
2110
2111                   if Nkind (Temp) = N_Parameter_Association then
2112                      while Is_Non_Empty_List (Parameter_Associations (N)) loop
2113                         Temp := Remove_Head (Parameter_Associations (N));
2114                      end loop;
2115
2116                   --  Case of mixed positional/named, remove named parameters
2117
2118                   else
2119                      while Nkind (Next (Temp)) /= N_Parameter_Association loop
2120                         Next (Temp);
2121                      end loop;
2122
2123                      while Present (Next (Temp)) loop
2124                         Discard := Remove_Next (Temp);
2125                      end loop;
2126                   end if;
2127
2128                   --  Now we loop through the named parameters, till we get
2129                   --  to the last one to be retained, adding them to the list.
2130                   --  Note that the Next_Named_Actual list does not need to be
2131                   --  touched since we are only reordering them on the actual
2132                   --  parameter association list.
2133
2134                   Passoc := Parent (First_Named_Actual (N));
2135                   loop
2136                      Temp := Relocate_Node (Passoc);
2137                      Append_To
2138                        (Parameter_Associations (N), Temp);
2139                      exit when
2140                        Last_Keep_Arg = Explicit_Actual_Parameter (Passoc);
2141                      Passoc := Parent (Next_Named_Actual (Passoc));
2142                   end loop;
2143
2144                   Set_Next_Named_Actual (Temp, Empty);
2145
2146                   loop
2147                      Temp := Next_Named_Actual (Passoc);
2148                      exit when No (Temp);
2149                      Set_Next_Named_Actual
2150                        (Passoc, Next_Named_Actual (Parent (Temp)));
2151                      Delete_Tree (Temp);
2152                   end loop;
2153                end;
2154             end if;
2155          end;
2156       end if;
2157    end Expand_Call;
2158
2159    --------------------------
2160    -- Expand_Inlined_Call --
2161    --------------------------
2162
2163    procedure Expand_Inlined_Call
2164     (N         : Node_Id;
2165      Subp      : Entity_Id;
2166      Orig_Subp : Entity_Id)
2167    is
2168       Loc       : constant Source_Ptr := Sloc (N);
2169       Is_Predef : constant Boolean :=
2170                    Is_Predefined_File_Name
2171                      (Unit_File_Name (Get_Source_Unit (Subp)));
2172       Orig_Bod  : constant Node_Id :=
2173                     Body_To_Inline (Unit_Declaration_Node (Subp));
2174
2175       Blk      : Node_Id;
2176       Bod      : Node_Id;
2177       Decl     : Node_Id;
2178       Exit_Lab : Entity_Id := Empty;
2179       F        : Entity_Id;
2180       A        : Node_Id;
2181       Lab_Decl : Node_Id;
2182       Lab_Id   : Node_Id;
2183       New_A    : Node_Id;
2184       Num_Ret  : Int := 0;
2185       Ret_Type : Entity_Id;
2186       Targ     : Node_Id;
2187       Temp     : Entity_Id;
2188       Temp_Typ : Entity_Id;
2189
2190       procedure Make_Exit_Label;
2191       --  Build declaration for exit label to be used in Return statements.
2192
2193       function Process_Formals (N : Node_Id) return Traverse_Result;
2194       --  Replace occurrence of a formal with the corresponding actual, or
2195       --  the thunk generated for it.
2196
2197       function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2198       --  If the call being expanded is that of an internal subprogram,
2199       --  set the sloc of the generated block to that of the call itself,
2200       --  so that the expansion is skipped by the -next- command in gdb.
2201       --  Same processing for a subprogram in a predefined file, e.g.
2202       --  Ada.Tags. If Debug_Generated_Code is true, suppress this change
2203       --  to simplify our own development.
2204
2205       procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2206       --  If the function body is a single expression, replace call with
2207       --  expression, else insert block appropriately.
2208
2209       procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2210       --  If procedure body has no local variables, inline body without
2211       --  creating block,  otherwise rewrite call with block.
2212
2213       ---------------------
2214       -- Make_Exit_Label --
2215       ---------------------
2216
2217       procedure Make_Exit_Label is
2218       begin
2219          --  Create exit label for subprogram, if one doesn't exist yet.
2220
2221          if No (Exit_Lab) then
2222             Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
2223             Set_Entity (Lab_Id,
2224               Make_Defining_Identifier (Loc, Chars (Lab_Id)));
2225             Exit_Lab := Make_Label (Loc, Lab_Id);
2226
2227             Lab_Decl :=
2228               Make_Implicit_Label_Declaration (Loc,
2229                 Defining_Identifier  => Entity (Lab_Id),
2230                 Label_Construct      => Exit_Lab);
2231          end if;
2232       end Make_Exit_Label;
2233
2234       ---------------------
2235       -- Process_Formals --
2236       ---------------------
2237
2238       function Process_Formals (N : Node_Id) return Traverse_Result is
2239          A   : Entity_Id;
2240          E   : Entity_Id;
2241          Ret : Node_Id;
2242
2243       begin
2244          if Is_Entity_Name (N)
2245            and then Present (Entity (N))
2246          then
2247             E := Entity (N);
2248
2249             if Is_Formal (E)
2250               and then Scope (E) = Subp
2251             then
2252                A := Renamed_Object (E);
2253
2254                if Is_Entity_Name (A) then
2255                   Rewrite (N, New_Occurrence_Of (Entity (A), Loc));
2256
2257                elsif Nkind (A) = N_Defining_Identifier then
2258                   Rewrite (N, New_Occurrence_Of (A, Loc));
2259
2260                else   --  numeric literal
2261                   Rewrite (N, New_Copy (A));
2262                end if;
2263             end if;
2264
2265             return Skip;
2266
2267          elsif Nkind (N) = N_Return_Statement then
2268
2269             if No (Expression (N)) then
2270                Make_Exit_Label;
2271                Rewrite (N, Make_Goto_Statement (Loc,
2272                  Name => New_Copy (Lab_Id)));
2273
2274             else
2275                if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2276                  and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2277                then
2278                   --  Function body is a single expression. No need for
2279                   --  exit label.
2280
2281                   null;
2282
2283                else
2284                   Num_Ret := Num_Ret + 1;
2285                   Make_Exit_Label;
2286                end if;
2287
2288                --  Because of the presence of private types, the views of the
2289                --  expression and the context may be different, so place an
2290                --  unchecked conversion to the context type to avoid spurious
2291                --  errors, eg. when the expression is a numeric literal and
2292                --  the context is private. If the expression is an aggregate,
2293                --  use a qualified expression, because an aggregate is not a
2294                --  legal argument of a conversion.
2295
2296                if Nkind (Expression (N)) = N_Aggregate
2297                  or else Nkind (Expression (N)) = N_Null
2298                then
2299                   Ret :=
2300                     Make_Qualified_Expression (Sloc (N),
2301                        Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2302                        Expression => Relocate_Node (Expression (N)));
2303                else
2304                   Ret :=
2305                     Unchecked_Convert_To
2306                       (Ret_Type, Relocate_Node (Expression (N)));
2307                end if;
2308
2309                if Nkind (Targ) = N_Defining_Identifier then
2310                   Rewrite (N,
2311                     Make_Assignment_Statement (Loc,
2312                       Name => New_Occurrence_Of (Targ, Loc),
2313                       Expression => Ret));
2314                else
2315                   Rewrite (N,
2316                     Make_Assignment_Statement (Loc,
2317                       Name => New_Copy (Targ),
2318                       Expression => Ret));
2319                end if;
2320
2321                Set_Assignment_OK (Name (N));
2322
2323                if Present (Exit_Lab) then
2324                   Insert_After (N,
2325                     Make_Goto_Statement (Loc,
2326                       Name => New_Copy (Lab_Id)));
2327                end if;
2328             end if;
2329
2330             return OK;
2331
2332          --  Remove pragma Unreferenced since it may refer to formals that
2333          --  are not visible in the inlined body, and in any case we will
2334          --  not be posting warnings on the inlined body so it is unneeded.
2335
2336          elsif Nkind (N) = N_Pragma
2337            and then Chars (N) = Name_Unreferenced
2338          then
2339             Rewrite (N, Make_Null_Statement (Sloc (N)));
2340             return OK;
2341
2342          else
2343             return OK;
2344          end if;
2345       end Process_Formals;
2346
2347       procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2348
2349       ------------------
2350       -- Process_Sloc --
2351       ------------------
2352
2353       function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2354       begin
2355          if not Debug_Generated_Code then
2356             Set_Sloc (Nod, Sloc (N));
2357             Set_Comes_From_Source (Nod, False);
2358          end if;
2359
2360          return OK;
2361       end Process_Sloc;
2362
2363       procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2364
2365       ---------------------------
2366       -- Rewrite_Function_Call --
2367       ---------------------------
2368
2369       procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2370          HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2371          Fst : constant Node_Id := First (Statements (HSS));
2372
2373       begin
2374          --  Optimize simple case: function body is a single return statement,
2375          --  which has been expanded into an assignment.
2376
2377          if Is_Empty_List (Declarations (Blk))
2378            and then Nkind (Fst) = N_Assignment_Statement
2379            and then No (Next (Fst))
2380          then
2381
2382             --  The function call may have been rewritten as the temporary
2383             --  that holds the result of the call, in which case remove the
2384             --  now useless declaration.
2385
2386             if Nkind (N) = N_Identifier
2387               and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2388             then
2389                Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2390             end if;
2391
2392             Rewrite (N, Expression (Fst));
2393
2394          elsif Nkind (N) = N_Identifier
2395            and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2396          then
2397
2398             --  The block assigns the result of the call to the temporary.
2399
2400             Insert_After (Parent (Entity (N)), Blk);
2401
2402          elsif Nkind (Parent (N)) = N_Assignment_Statement
2403            and then Is_Entity_Name (Name (Parent (N)))
2404          then
2405
2406             --  Replace assignment with the block
2407
2408             Rewrite (Parent (N), Blk);
2409
2410          elsif Nkind (Parent (N)) = N_Object_Declaration then
2411             Set_Expression (Parent (N), Empty);
2412             Insert_After (Parent (N), Blk);
2413          end if;
2414       end Rewrite_Function_Call;
2415
2416       ----------------------------
2417       -- Rewrite_Procedure_Call --
2418       ----------------------------
2419
2420       procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2421          HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
2422
2423       begin
2424          if Is_Empty_List (Declarations (Blk)) then
2425             Insert_List_After (N, Statements (HSS));
2426             Rewrite (N, Make_Null_Statement (Loc));
2427          else
2428             Rewrite (N, Blk);
2429          end if;
2430       end Rewrite_Procedure_Call;
2431
2432    --  Start of processing for Expand_Inlined_Call
2433
2434    begin
2435       --  Check for special case of To_Address call, and if so, just
2436       --  do an unchecked conversion instead of expanding the call.
2437       --  Not only is this more efficient, but it also avoids a
2438       --  problem with order of elaboration when address clauses
2439       --  are inlined (address expr elaborated at wrong point).
2440
2441       if Subp = RTE (RE_To_Address) then
2442          Rewrite (N,
2443            Unchecked_Convert_To
2444             (RTE (RE_Address),
2445              Relocate_Node (First_Actual (N))));
2446          return;
2447       end if;
2448
2449       if Nkind (Orig_Bod) = N_Defining_Identifier then
2450
2451          --  Subprogram is a renaming_as_body. Calls appearing after the
2452          --  renaming can be replaced with calls to the renamed entity
2453          --  directly, because the subprograms are subtype conformant.
2454
2455          Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2456          return;
2457       end if;
2458
2459       --  Use generic machinery to copy body of inlined subprogram, as if it
2460       --  were an instantiation, resetting source locations appropriately, so
2461       --  that nested inlined calls appear in the main unit.
2462
2463       Save_Env (Subp, Empty);
2464       Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2465
2466       Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2467       Blk :=
2468         Make_Block_Statement (Loc,
2469           Declarations => Declarations (Bod),
2470           Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
2471
2472       if No (Declarations (Bod)) then
2473          Set_Declarations (Blk, New_List);
2474       end if;
2475
2476       --  If this is a derived function, establish the proper return type.
2477
2478       if Present (Orig_Subp)
2479         and then Orig_Subp /= Subp
2480       then
2481          Ret_Type := Etype (Orig_Subp);
2482       else
2483          Ret_Type := Etype (Subp);
2484       end if;
2485
2486       F := First_Formal (Subp);
2487       A := First_Actual (N);
2488
2489       --  Create temporaries for the actuals that are expressions, or that
2490       --  are scalars and require copying to preserve semantics.
2491
2492       while Present (F) loop
2493          if Present (Renamed_Object (F)) then
2494             Error_Msg_N (" cannot inline call to recursive subprogram", N);
2495             return;
2496          end if;
2497
2498          --  If the argument may be a controlling argument in a call within
2499          --  the inlined body, we must preserve its classwide nature to
2500          --  insure that dynamic dispatching take place subsequently.
2501          --  If the formal has a constraint it must be preserved to retain
2502          --  the semantics of the body.
2503
2504          if Is_Class_Wide_Type (Etype (F))
2505            or else (Is_Access_Type (Etype (F))
2506                       and then
2507                     Is_Class_Wide_Type (Designated_Type (Etype (F))))
2508          then
2509             Temp_Typ := Etype (F);
2510
2511          elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
2512            and then Etype (F) /= Base_Type (Etype (F))
2513          then
2514             Temp_Typ := Etype (F);
2515
2516          else
2517             Temp_Typ := Etype (A);
2518          end if;
2519
2520          --  Comments needed here ???
2521
2522          if (Is_Entity_Name (A)
2523               and then
2524                (not Is_Scalar_Type (Etype (A))
2525                  or else Ekind (Entity (A)) = E_Enumeration_Literal))
2526
2527            or else Nkind (A) = N_Real_Literal
2528            or else Nkind (A) = N_Integer_Literal
2529            or else Nkind (A) = N_Character_Literal
2530          then
2531             if Etype (F) /= Etype (A) then
2532                Set_Renamed_Object
2533                 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
2534             else
2535                Set_Renamed_Object (F, A);
2536             end if;
2537
2538          else
2539             Temp :=
2540               Make_Defining_Identifier (Loc,
2541                 Chars => New_Internal_Name ('C'));
2542
2543             --  If the actual for an in/in-out parameter is a view conversion,
2544             --  make it into an unchecked conversion, given that an untagged
2545             --  type conversion is not a proper object for a renaming.
2546
2547             --  In-out conversions that involve real conversions have already
2548             --  been transformed in Expand_Actuals.
2549
2550             if Nkind (A) = N_Type_Conversion
2551               and then Ekind (F) /= E_In_Parameter
2552             then
2553                New_A := Make_Unchecked_Type_Conversion (Loc,
2554                  Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
2555                  Expression   => Relocate_Node (Expression (A)));
2556
2557             elsif Etype (F) /= Etype (A) then
2558                New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
2559                Temp_Typ := Etype (F);
2560
2561             else
2562                New_A := Relocate_Node (A);
2563             end if;
2564
2565             Set_Sloc (New_A, Sloc (N));
2566
2567             if Ekind (F) = E_In_Parameter
2568               and then not Is_Limited_Type (Etype (A))
2569             then
2570                Decl :=
2571                  Make_Object_Declaration (Loc,
2572                    Defining_Identifier => Temp,
2573                    Constant_Present => True,
2574                    Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
2575                    Expression => New_A);
2576             else
2577                Decl :=
2578                  Make_Object_Renaming_Declaration (Loc,
2579                    Defining_Identifier => Temp,
2580                    Subtype_Mark        => New_Occurrence_Of (Temp_Typ, Loc),
2581                    Name                => New_A);
2582             end if;
2583
2584             Prepend (Decl, Declarations (Blk));
2585             Set_Renamed_Object (F, Temp);
2586          end if;
2587
2588          Next_Formal (F);
2589          Next_Actual (A);
2590       end loop;
2591
2592       --  Establish target of function call. If context is not assignment or
2593       --  declaration, create a temporary as a target. The declaration for
2594       --  the temporary may be subsequently optimized away if the body is a
2595       --  single expression, or if the left-hand side of the assignment is
2596       --  simple enough.
2597
2598       if Ekind (Subp) = E_Function then
2599          if Nkind (Parent (N)) = N_Assignment_Statement
2600            and then Is_Entity_Name (Name (Parent (N)))
2601          then
2602             Targ := Name (Parent (N));
2603
2604          else
2605             --  Replace call with temporary, and create its declaration.
2606
2607             Temp :=
2608               Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2609
2610             Decl :=
2611               Make_Object_Declaration (Loc,
2612                 Defining_Identifier => Temp,
2613                 Object_Definition =>
2614                   New_Occurrence_Of (Ret_Type, Loc));
2615
2616             Set_No_Initialization (Decl);
2617             Insert_Action (N, Decl);
2618             Rewrite (N, New_Occurrence_Of (Temp, Loc));
2619             Targ := Temp;
2620          end if;
2621       end if;
2622
2623       --  Traverse the tree and replace  formals with actuals or their thunks.
2624       --  Attach block to tree before analysis and rewriting.
2625
2626       Replace_Formals (Blk);
2627       Set_Parent (Blk, N);
2628
2629       if not Comes_From_Source (Subp)
2630         or else Is_Predef
2631       then
2632          Reset_Slocs (Blk);
2633       end if;
2634
2635       if Present (Exit_Lab) then
2636
2637          --  If the body was a single expression, the single return statement
2638          --  and the corresponding label are useless.
2639
2640          if Num_Ret = 1
2641            and then
2642              Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
2643                N_Goto_Statement
2644          then
2645             Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
2646          else
2647             Append (Lab_Decl, (Declarations (Blk)));
2648             Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
2649          end if;
2650       end if;
2651
2652       --  Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
2653       --  conflicting private views that Gigi would ignore. If this is a
2654       --  predefined unit, analyze with checks off, as is done in the non-
2655       --  inlined run-time units.
2656
2657       declare
2658          I_Flag : constant Boolean := In_Inlined_Body;
2659
2660       begin
2661          In_Inlined_Body := True;
2662
2663          if Is_Predef then
2664             declare
2665                Style : constant Boolean := Style_Check;
2666             begin
2667                Style_Check := False;
2668                Analyze (Blk, Suppress => All_Checks);
2669                Style_Check := Style;
2670             end;
2671
2672          else
2673             Analyze (Blk);
2674          end if;
2675
2676          In_Inlined_Body := I_Flag;
2677       end;
2678
2679       if Ekind (Subp) = E_Procedure then
2680          Rewrite_Procedure_Call (N, Blk);
2681       else
2682          Rewrite_Function_Call (N, Blk);
2683       end if;
2684
2685       Restore_Env;
2686
2687       --  Cleanup mapping between formals and actuals, for other expansions.
2688
2689       F := First_Formal (Subp);
2690
2691       while Present (F) loop
2692          Set_Renamed_Object (F, Empty);
2693          Next_Formal (F);
2694       end loop;
2695    end Expand_Inlined_Call;
2696
2697    ----------------------------
2698    -- Expand_N_Function_Call --
2699    ----------------------------
2700
2701    procedure Expand_N_Function_Call (N : Node_Id) is
2702       Typ : constant Entity_Id := Etype (N);
2703
2704       function Returned_By_Reference return Boolean;
2705       --  If the return type is returned through the secondary stack. that is
2706       --  by reference, we don't want to create a temp to force stack checking.
2707
2708       function Returned_By_Reference return Boolean is
2709          S : Entity_Id := Current_Scope;
2710
2711       begin
2712          if Is_Return_By_Reference_Type (Typ) then
2713             return True;
2714
2715          elsif Nkind (Parent (N)) /= N_Return_Statement then
2716             return False;
2717
2718          elsif Requires_Transient_Scope (Typ) then
2719
2720             --  Verify that the return type of the enclosing function has
2721             --  the same constrained status as that of the expression.
2722
2723             while Ekind (S) /= E_Function loop
2724                S := Scope (S);
2725             end loop;
2726
2727             return Is_Constrained (Typ) = Is_Constrained (Etype (S));
2728          else
2729             return False;
2730          end if;
2731       end Returned_By_Reference;
2732
2733    --  Start of processing for Expand_N_Function_Call
2734
2735    begin
2736       --  A special check. If stack checking is enabled, and the return type
2737       --  might generate a large temporary, and the call is not the right
2738       --  side of an assignment, then generate an explicit temporary. We do
2739       --  this because otherwise gigi may generate a large temporary on the
2740       --  fly and this can cause trouble with stack checking.
2741
2742       if May_Generate_Large_Temp (Typ)
2743         and then Nkind (Parent (N)) /= N_Assignment_Statement
2744         and then
2745           (Nkind (Parent (N)) /= N_Qualified_Expression
2746              or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement)
2747         and then
2748           (Nkind (Parent (N)) /= N_Object_Declaration
2749              or else Expression (Parent (N)) /= N)
2750         and then not Returned_By_Reference
2751       then
2752          --  Note: it might be thought that it would be OK to use a call to
2753          --  Force_Evaluation here, but that's not good enough, because that
2754          --  results in a 'Reference construct that may still need a temporary.
2755
2756          declare
2757             Loc      : constant Source_Ptr := Sloc (N);
2758             Temp_Obj : constant Entity_Id :=
2759                          Make_Defining_Identifier (Loc,
2760                            Chars => New_Internal_Name ('F'));
2761             Temp_Typ : Entity_Id := Typ;
2762             Decl     : Node_Id;
2763             A        : Node_Id;
2764             F        : Entity_Id;
2765             Proc     : Entity_Id;
2766
2767          begin
2768             if Is_Tagged_Type (Typ)
2769               and then Present (Controlling_Argument (N))
2770             then
2771                if Nkind (Parent (N)) /= N_Procedure_Call_Statement
2772                  and then Nkind (Parent (N)) /= N_Function_Call
2773                then
2774                   --  If this is a tag-indeterminate call, the object must
2775                   --  be classwide.
2776
2777                   if Is_Tag_Indeterminate (N) then
2778                      Temp_Typ := Class_Wide_Type (Typ);
2779                   end if;
2780
2781                else
2782                   --  If this is a dispatching call that is itself the
2783                   --  controlling argument of an enclosing call, the nominal
2784                   --  subtype of the object that replaces it must be classwide,
2785                   --  so that dispatching will take place properly. If it is
2786                   --  not a controlling argument, the object is not classwide.
2787
2788                   Proc := Entity (Name (Parent (N)));
2789                   F    := First_Formal (Proc);
2790                   A    := First_Actual (Parent (N));
2791
2792                   while A /= N loop
2793                      Next_Formal (F);
2794                      Next_Actual (A);
2795                   end loop;
2796
2797                   if Is_Controlling_Formal (F) then
2798                      Temp_Typ := Class_Wide_Type (Typ);
2799                   end if;
2800                end if;
2801             end if;
2802
2803             Decl :=
2804               Make_Object_Declaration (Loc,
2805                 Defining_Identifier => Temp_Obj,
2806                 Object_Definition   => New_Occurrence_Of (Temp_Typ, Loc),
2807                 Constant_Present    => True,
2808                 Expression          => Relocate_Node (N));
2809             Set_Assignment_OK (Decl);
2810
2811             Insert_Actions (N, New_List (Decl));
2812             Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
2813          end;
2814
2815       --  Normal case, expand the call
2816
2817       else
2818          Expand_Call (N);
2819       end if;
2820    end Expand_N_Function_Call;
2821
2822    ---------------------------------------
2823    -- Expand_N_Procedure_Call_Statement --
2824    ---------------------------------------
2825
2826    procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
2827    begin
2828       Expand_Call (N);
2829    end Expand_N_Procedure_Call_Statement;
2830
2831    ------------------------------
2832    -- Expand_N_Subprogram_Body --
2833    ------------------------------
2834
2835    --  Add poll call if ATC polling is enabled
2836
2837    --  Add return statement if last statement in body is not a return
2838    --  statement (this makes things easier on Gigi which does not want
2839    --  to have to handle a missing return).
2840
2841    --  Add call to Activate_Tasks if body is a task activator
2842
2843    --  Deal with possible detection of infinite recursion
2844
2845    --  Eliminate body completely if convention stubbed
2846
2847    --  Encode entity names within body, since we will not need to reference
2848    --  these entities any longer in the front end.
2849
2850    --  Initialize scalar out parameters if Initialize/Normalize_Scalars
2851
2852    --  Reset Pure indication if any parameter has root type System.Address
2853
2854    --  Wrap thread body
2855
2856    procedure Expand_N_Subprogram_Body (N : Node_Id) is
2857       Loc      : constant Source_Ptr := Sloc (N);
2858       H        : constant Node_Id    := Handled_Statement_Sequence (N);
2859       Body_Id  : Entity_Id;
2860       Spec_Id  : Entity_Id;
2861       Except_H : Node_Id;
2862       Scop     : Entity_Id;
2863       Dec      : Node_Id;
2864       Next_Op  : Node_Id;
2865       L        : List_Id;
2866
2867       procedure Add_Return (S : List_Id);
2868       --  Append a return statement to the statement sequence S if the last
2869       --  statement is not already a return or a goto statement. Note that
2870       --  the latter test is not critical, it does not matter if we add a
2871       --  few extra returns, since they get eliminated anyway later on.
2872
2873       procedure Expand_Thread_Body;
2874       --  Perform required expansion of a thread body
2875
2876       ----------------
2877       -- Add_Return --
2878       ----------------
2879
2880       procedure Add_Return (S : List_Id) is
2881       begin
2882          if not Is_Transfer (Last (S)) then
2883
2884             --  The source location for the return is the end label
2885             --  of the procedure in all cases. This is a bit odd when
2886             --  there are exception handlers, but not much else we can do.
2887
2888             Append_To (S, Make_Return_Statement (Sloc (End_Label (H))));
2889          end if;
2890       end Add_Return;
2891
2892       ------------------------
2893       -- Expand_Thread_Body --
2894       ------------------------
2895
2896       --  The required expansion of a thread body is as follows
2897
2898       --  procedure <thread body procedure name> is
2899
2900       --    _Secondary_Stack : aliased
2901       --       Storage_Elements.Storage_Array
2902       --         (1 .. Storage_Offset (Sec_Stack_Size));
2903       --    for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
2904
2905       --    _Process_ATSD : aliased System.Threads.ATSD;
2906
2907       --  begin
2908       --     System.Threads.Thread_Body_Enter;
2909       --       (_Secondary_Stack'Address,
2910       --        _Secondary_Stack'Length,
2911       --        _Process_ATSD'Address);
2912
2913       --     declare
2914       --        <user declarations>
2915       --     begin
2916       --        <user statements>
2917       --     <user exception handlers>
2918       --     end;
2919
2920       --    System.Threads.Thread_Body_Leave;
2921
2922       --  exception
2923       --     when E : others =>
2924       --       System.Threads.Thread_Body_Exceptional_Exit (E);
2925       --  end;
2926
2927       --  Note the exception handler is omitted if pragma Restriction
2928       --  No_Exception_Handlers is currently active.
2929
2930       procedure Expand_Thread_Body is
2931          User_Decls    : constant List_Id := Declarations (N);
2932          Sec_Stack_Len : Node_Id;
2933
2934          TB_Pragma  : constant Node_Id :=
2935                         Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
2936
2937          Ent_SS   : Entity_Id;
2938          Ent_ATSD : Entity_Id;
2939          Ent_EO   : Entity_Id;
2940
2941          Decl_SS   : Node_Id;
2942          Decl_ATSD : Node_Id;
2943
2944          Excep_Handlers : List_Id;
2945
2946       begin
2947          --  Get proper setting for secondary stack size
2948
2949          if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
2950             Sec_Stack_Len :=
2951               Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
2952          else
2953             Sec_Stack_Len :=
2954               Make_Integer_Literal (Loc,
2955                 Intval =>
2956                   Expr_Value
2957                    (Expression (RTE (RE_Default_Secondary_Stack_Size))));
2958          end if;
2959
2960          Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
2961
2962          --  Build and set declarations for the wrapped thread body
2963
2964          Ent_SS   := Make_Defining_Identifier (Loc, Name_uSecondary_Stack);
2965          Ent_ATSD := Make_Defining_Identifier (Loc, Name_uProcess_ATSD);
2966
2967          Decl_SS :=
2968            Make_Object_Declaration (Loc,
2969              Defining_Identifier => Ent_SS,
2970              Aliased_Present     => True,
2971              Object_Definition   =>
2972                Make_Subtype_Indication (Loc,
2973                  Subtype_Mark =>
2974                    New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
2975                  Constraint   =>
2976                    Make_Index_Or_Discriminant_Constraint (Loc,
2977                      Constraints => New_List (
2978                        Make_Range (Loc,
2979                          Low_Bound  => Make_Integer_Literal (Loc, 1),
2980                          High_Bound => Sec_Stack_Len)))));
2981
2982          Decl_ATSD :=
2983            Make_Object_Declaration (Loc,
2984              Defining_Identifier => Ent_ATSD,
2985              Aliased_Present     => True,
2986              Object_Definition   => New_Occurrence_Of (RTE (RE_ATSD), Loc));
2987
2988          Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
2989          Analyze (Decl_SS);
2990          Analyze (Decl_ATSD);
2991          Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
2992
2993          --  Create new exception handler
2994
2995          if Restrictions (No_Exception_Handlers) then
2996             Excep_Handlers := No_List;
2997
2998          else
2999             Check_Restriction (No_Exception_Handlers, N);
3000
3001             Ent_EO := Make_Defining_Identifier (Loc, Name_uE);
3002
3003             Excep_Handlers := New_List (
3004               Make_Exception_Handler (Loc,
3005                 Choice_Parameter => Ent_EO,
3006                 Exception_Choices => New_List (
3007                   Make_Others_Choice (Loc)),
3008                 Statements => New_List (
3009                   Make_Procedure_Call_Statement (Loc,
3010                     Name =>
3011                       New_Occurrence_Of
3012                         (RTE (RE_Thread_Body_Exceptional_Exit), Loc),
3013                     Parameter_Associations => New_List (
3014                       New_Occurrence_Of (Ent_EO, Loc))))));
3015          end if;
3016
3017          --  Now build new handled statement sequence and analyze it
3018
3019          Set_Handled_Statement_Sequence (N,
3020            Make_Handled_Sequence_Of_Statements (Loc,
3021              Statements => New_List (
3022
3023                Make_Procedure_Call_Statement (Loc,
3024                  Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
3025                  Parameter_Associations => New_List (
3026
3027                    Make_Attribute_Reference (Loc,
3028                      Prefix => New_Occurrence_Of (Ent_SS, Loc),
3029                      Attribute_Name => Name_Address),
3030
3031                    Make_Attribute_Reference (Loc,
3032                      Prefix => New_Occurrence_Of (Ent_SS, Loc),
3033                      Attribute_Name => Name_Length),
3034
3035                    Make_Attribute_Reference (Loc,
3036                      Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
3037                      Attribute_Name => Name_Address))),
3038
3039                Make_Block_Statement (Loc,
3040                  Declarations => User_Decls,
3041                  Handled_Statement_Sequence => H),
3042
3043                Make_Procedure_Call_Statement (Loc,
3044                  Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
3045
3046              Exception_Handlers => Excep_Handlers));
3047
3048          Analyze (Handled_Statement_Sequence (N));
3049       end Expand_Thread_Body;
3050
3051    --  Start of processing for Expand_N_Subprogram_Body
3052
3053    begin
3054       --  Set L to either the list of declarations if present, or
3055       --  to the list of statements if no declarations are present.
3056       --  This is used to insert new stuff at the start.
3057
3058       if Is_Non_Empty_List (Declarations (N)) then
3059          L := Declarations (N);
3060       else
3061          L := Statements (Handled_Statement_Sequence (N));
3062       end if;
3063
3064       --  Need poll on entry to subprogram if polling enabled. We only
3065       --  do this for non-empty subprograms, since it does not seem
3066       --  necessary to poll for a dummy null subprogram.
3067
3068       if Is_Non_Empty_List (L) then
3069          Generate_Poll_Call (First (L));
3070       end if;
3071
3072       --  Find entity for subprogram
3073
3074       Body_Id := Defining_Entity (N);
3075
3076       if Present (Corresponding_Spec (N)) then
3077          Spec_Id := Corresponding_Spec (N);
3078       else
3079          Spec_Id := Body_Id;
3080       end if;
3081
3082       --  If this is a Pure function which has any parameters whose root
3083       --  type is System.Address, reset the Pure indication, since it will
3084       --  likely cause incorrect code to be generated.
3085
3086       if Is_Pure (Spec_Id)
3087         and then Is_Subprogram (Spec_Id)
3088         and then not Has_Pragma_Pure_Function (Spec_Id)
3089       then
3090          declare
3091             F : Entity_Id := First_Formal (Spec_Id);
3092
3093          begin
3094             while Present (F) loop
3095                if Is_RTE (Root_Type (Etype (F)), RE_Address) then
3096                   Set_Is_Pure (Spec_Id, False);
3097
3098                   if Spec_Id /= Body_Id then
3099                      Set_Is_Pure (Body_Id, False);
3100                   end if;
3101
3102                   exit;
3103                end if;
3104
3105                Next_Formal (F);
3106             end loop;
3107          end;
3108       end if;
3109
3110       --  Initialize any scalar OUT args if Initialize/Normalize_Scalars
3111
3112       if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
3113          declare
3114             F : Entity_Id        := First_Formal (Spec_Id);
3115             V : constant Boolean := Validity_Checks_On;
3116
3117          begin
3118             --  We turn off validity checking, since we do not want any
3119             --  check on the initializing value itself (which we know
3120             --  may well be invalid!)
3121
3122             Validity_Checks_On := False;
3123
3124             --  Loop through formals
3125
3126             while Present (F) loop
3127                if Is_Scalar_Type (Etype (F))
3128                  and then Ekind (F) = E_Out_Parameter
3129                then
3130                   Insert_Before_And_Analyze (First (L),
3131                     Make_Assignment_Statement (Loc,
3132                       Name => New_Occurrence_Of (F, Loc),
3133                       Expression => Get_Simple_Init_Val (Etype (F), Loc)));
3134                end if;
3135
3136                Next_Formal (F);
3137             end loop;
3138
3139             Validity_Checks_On := V;
3140          end;
3141       end if;
3142
3143       --  Clear out statement list for stubbed procedure
3144
3145       if Present (Corresponding_Spec (N)) then
3146          Set_Elaboration_Flag (N, Spec_Id);
3147
3148          if Convention (Spec_Id) = Convention_Stubbed
3149            or else Is_Eliminated (Spec_Id)
3150          then
3151             Set_Declarations (N, Empty_List);
3152             Set_Handled_Statement_Sequence (N,
3153               Make_Handled_Sequence_Of_Statements (Loc,
3154                 Statements => New_List (
3155                   Make_Null_Statement (Loc))));
3156             return;
3157          end if;
3158       end if;
3159
3160       Scop := Scope (Spec_Id);
3161
3162       --  Returns_By_Ref flag is normally set when the subprogram is frozen
3163       --  but subprograms with no specs are not frozen
3164
3165       declare
3166          Typ  : constant Entity_Id := Etype (Spec_Id);
3167          Utyp : constant Entity_Id := Underlying_Type (Typ);
3168
3169       begin
3170          if not Acts_As_Spec (N)
3171            and then Nkind (Parent (Parent (Spec_Id))) /=
3172              N_Subprogram_Body_Stub
3173          then
3174             null;
3175
3176          elsif Is_Return_By_Reference_Type (Typ) then
3177             Set_Returns_By_Ref (Spec_Id);
3178
3179          elsif Present (Utyp) and then Controlled_Type (Utyp) then
3180             Set_Returns_By_Ref (Spec_Id);
3181          end if;
3182       end;
3183
3184       --  For a procedure, we add a return for all possible syntactic ends
3185       --  of the subprogram. Note that reanalysis is not necessary in this
3186       --  case since it would require a lot of work and accomplish nothing.
3187
3188       if Ekind (Spec_Id) = E_Procedure
3189         or else Ekind (Spec_Id) = E_Generic_Procedure
3190       then
3191          Add_Return (Statements (H));
3192
3193          if Present (Exception_Handlers (H)) then
3194             Except_H := First_Non_Pragma (Exception_Handlers (H));
3195
3196             while Present (Except_H) loop
3197                Add_Return (Statements (Except_H));
3198                Next_Non_Pragma (Except_H);
3199             end loop;
3200          end if;
3201
3202       --  For a function, we must deal with the case where there is at
3203       --  least one missing return. What we do is to wrap the entire body
3204       --  of the function in a block:
3205
3206       --    begin
3207       --      ...
3208       --    end;
3209
3210       --  becomes
3211
3212       --    begin
3213       --       begin
3214       --          ...
3215       --       end;
3216
3217       --       raise Program_Error;
3218       --    end;
3219
3220       --  This approach is necessary because the raise must be signalled
3221       --  to the caller, not handled by any local handler (RM 6.4(11)).
3222
3223       --  Note: we do not need to analyze the constructed sequence here,
3224       --  since it has no handler, and an attempt to analyze the handled
3225       --  statement sequence twice is risky in various ways (e.g. the
3226       --  issue of expanding cleanup actions twice).
3227
3228       elsif Has_Missing_Return (Spec_Id) then
3229          declare
3230             Hloc : constant Source_Ptr := Sloc (H);
3231             Blok : constant Node_Id    :=
3232                      Make_Block_Statement (Hloc,
3233                        Handled_Statement_Sequence => H);
3234             Rais : constant Node_Id    :=
3235                      Make_Raise_Program_Error (Hloc,
3236                        Reason => PE_Missing_Return);
3237
3238          begin
3239             Set_Handled_Statement_Sequence (N,
3240               Make_Handled_Sequence_Of_Statements (Hloc,
3241                 Statements => New_List (Blok, Rais)));
3242
3243             New_Scope (Spec_Id);
3244             Analyze (Blok);
3245             Analyze (Rais);
3246             Pop_Scope;
3247          end;
3248       end if;
3249
3250       --  Add discriminal renamings to protected subprograms.
3251       --  Install new discriminals for expansion of the next
3252       --  subprogram of this protected type, if any.
3253
3254       if Is_List_Member (N)
3255         and then Present (Parent (List_Containing (N)))
3256         and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
3257       then
3258          Add_Discriminal_Declarations
3259            (Declarations (N), Scop, Name_uObject, Loc);
3260          Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
3261
3262          --  Associate privals and discriminals with the next protected
3263          --  operation body to be expanded. These are used to expand
3264          --  references to private data objects and discriminants,
3265          --  respectively.
3266
3267          Next_Op := Next_Protected_Operation (N);
3268
3269          if Present (Next_Op) then
3270             Dec := Parent (Base_Type (Scop));
3271             Set_Privals (Dec, Next_Op, Loc);
3272             Set_Discriminals (Dec);
3273          end if;
3274       end if;
3275
3276       --  If subprogram contains a parameterless recursive call, then we may
3277       --  have an infinite recursion, so see if we can generate code to check
3278       --  for this possibility if storage checks are not suppressed.
3279
3280       if Ekind (Spec_Id) = E_Procedure
3281         and then Has_Recursive_Call (Spec_Id)
3282         and then not Storage_Checks_Suppressed (Spec_Id)
3283       then
3284          Detect_Infinite_Recursion (N, Spec_Id);
3285       end if;
3286
3287       --  Finally, if we are in Normalize_Scalars mode, then any scalar out
3288       --  parameters must be initialized to the appropriate default value.
3289
3290       if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then
3291          declare
3292             Floc   : Source_Ptr;
3293             Formal : Entity_Id;
3294             Stm    : Node_Id;
3295
3296          begin
3297             Formal := First_Formal (Spec_Id);
3298
3299             while Present (Formal) loop
3300                Floc := Sloc (Formal);
3301
3302                if Ekind (Formal) = E_Out_Parameter
3303                  and then Is_Scalar_Type (Etype (Formal))
3304                then
3305                   Stm :=
3306                     Make_Assignment_Statement (Floc,
3307                       Name => New_Occurrence_Of (Formal, Floc),
3308                       Expression =>
3309                         Get_Simple_Init_Val (Etype (Formal), Floc));
3310                   Prepend (Stm, Declarations (N));
3311                   Analyze (Stm);
3312                end if;
3313
3314                Next_Formal (Formal);
3315             end loop;
3316          end;
3317       end if;
3318
3319       --  Deal with thread body
3320
3321       if Is_Thread_Body (Spec_Id) then
3322          Expand_Thread_Body;
3323       end if;
3324
3325       --  If the subprogram does not have pending instantiations, then we
3326       --  must generate the subprogram descriptor now, since the code for
3327       --  the subprogram is complete, and this is our last chance. However
3328       --  if there are pending instantiations, then the code is not
3329       --  complete, and we will delay the generation.
3330
3331       if Is_Subprogram (Spec_Id)
3332         and then not Delay_Subprogram_Descriptors (Spec_Id)
3333       then
3334          Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id);
3335       end if;
3336
3337       --  Set to encode entity names in package body before gigi is called
3338
3339       Qualify_Entity_Names (N);
3340    end Expand_N_Subprogram_Body;
3341
3342    -----------------------------------
3343    -- Expand_N_Subprogram_Body_Stub --
3344    -----------------------------------
3345
3346    procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
3347    begin
3348       if Present (Corresponding_Body (N)) then
3349          Expand_N_Subprogram_Body (
3350            Unit_Declaration_Node (Corresponding_Body (N)));
3351       end if;
3352    end Expand_N_Subprogram_Body_Stub;
3353
3354    -------------------------------------
3355    -- Expand_N_Subprogram_Declaration --
3356    -------------------------------------
3357
3358    --  If the declaration appears within a protected body, it is a private
3359    --  operation of the protected type. We must create the corresponding
3360    --  protected subprogram an associated formals. For a normal protected
3361    --  operation, this is done when expanding the protected type declaration.
3362
3363    procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
3364       Loc       : constant Source_Ptr := Sloc (N);
3365       Subp      : constant Entity_Id  := Defining_Entity (N);
3366       Scop      : constant Entity_Id  := Scope (Subp);
3367       Prot_Decl : Node_Id;
3368       Prot_Bod  : Node_Id;
3369       Prot_Id   : Entity_Id;
3370
3371    begin
3372       --  Deal with case of protected subprogram
3373
3374       if Is_List_Member (N)
3375         and then Present (Parent (List_Containing (N)))
3376         and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
3377         and then Is_Protected_Type (Scop)
3378       then
3379          if No (Protected_Body_Subprogram (Subp)) then
3380             Prot_Decl :=
3381               Make_Subprogram_Declaration (Loc,
3382                 Specification =>
3383                   Build_Protected_Sub_Specification
3384                     (N, Scop, Unprotected => True));
3385
3386             --  The protected subprogram is declared outside of the protected
3387             --  body. Given that the body has frozen all entities so far, we
3388             --  analyze the subprogram and perform freezing actions explicitly.
3389             --  If the body is a subunit, the insertion point is before the
3390             --  stub in the parent.
3391
3392             Prot_Bod := Parent (List_Containing (N));
3393
3394             if Nkind (Parent (Prot_Bod)) = N_Subunit then
3395                Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
3396             end if;
3397
3398             Insert_Before (Prot_Bod, Prot_Decl);
3399             Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
3400
3401             New_Scope (Scope (Scop));
3402             Analyze (Prot_Decl);
3403             Create_Extra_Formals (Prot_Id);
3404             Set_Protected_Body_Subprogram (Subp, Prot_Id);
3405             Pop_Scope;
3406          end if;
3407       end if;
3408    end Expand_N_Subprogram_Declaration;
3409
3410    ---------------------------------------
3411    -- Expand_Protected_Object_Reference --
3412    ---------------------------------------
3413
3414    function Expand_Protected_Object_Reference
3415      (N    : Node_Id;
3416       Scop : Entity_Id)
3417      return Node_Id
3418    is
3419       Loc   : constant Source_Ptr := Sloc (N);
3420       Corr  : Entity_Id;
3421       Rec   : Node_Id;
3422       Param : Entity_Id;
3423       Proc  : Entity_Id;
3424
3425    begin
3426       Rec := Make_Identifier (Loc, Name_uObject);
3427       Set_Etype (Rec, Corresponding_Record_Type (Scop));
3428
3429       --  Find enclosing protected operation, and retrieve its first
3430       --  parameter, which denotes the enclosing protected object.
3431       --  If the enclosing operation is an entry, we are immediately
3432       --  within the protected body, and we can retrieve the object
3433       --  from the service entries procedure. A barrier function has
3434       --  has the same signature as an entry. A barrier function is
3435       --  compiled within the protected object, but unlike protected
3436       --  operations its never needs locks, so that its protected body
3437       --  subprogram points to itself.
3438
3439       Proc := Current_Scope;
3440
3441       while Present (Proc)
3442         and then Scope (Proc) /= Scop
3443       loop
3444          Proc := Scope (Proc);
3445       end loop;
3446
3447       Corr := Protected_Body_Subprogram (Proc);
3448
3449       if No (Corr) then
3450
3451          --  Previous error left expansion incomplete.
3452          --  Nothing to do on this call.
3453
3454          return Empty;
3455       end if;
3456
3457       Param :=
3458         Defining_Identifier
3459           (First (Parameter_Specifications (Parent (Corr))));
3460
3461       if Is_Subprogram (Proc)
3462         and then Proc /= Corr
3463       then
3464          --  Protected function or procedure.
3465
3466          Set_Entity (Rec, Param);
3467
3468          --  Rec is a reference to an entity which will not be in scope
3469          --  when the call is reanalyzed, and needs no further analysis.
3470
3471          Set_Analyzed (Rec);
3472
3473       else
3474          --  Entry or barrier function for entry body.
3475          --  The first parameter of the entry body procedure is a
3476          --  pointer to the object. We create a local variable
3477          --  of the proper type, duplicating what is done to define
3478          --  _object later on.
3479
3480          declare
3481             Decls : List_Id;
3482             Obj_Ptr : constant Entity_Id :=  Make_Defining_Identifier (Loc,
3483                                                Chars =>
3484                                                  New_Internal_Name ('T'));
3485
3486          begin
3487             Decls := New_List (
3488               Make_Full_Type_Declaration (Loc,
3489                 Defining_Identifier => Obj_Ptr,
3490                   Type_Definition =>
3491                      Make_Access_To_Object_Definition (Loc,
3492                        Subtype_Indication =>
3493                          New_Reference_To
3494                       (Corresponding_Record_Type (Scop), Loc))));
3495
3496             Insert_Actions (N, Decls);
3497             Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N)));
3498
3499             Rec :=
3500               Make_Explicit_Dereference (Loc,
3501                 Unchecked_Convert_To (Obj_Ptr,
3502                   New_Occurrence_Of (Param, Loc)));
3503
3504             --  Analyze new actual. Other actuals in calls are already
3505             --  analyzed and the list of actuals is not renalyzed after
3506             --  rewriting.
3507
3508             Set_Parent (Rec, N);
3509             Analyze (Rec);
3510          end;
3511       end if;
3512
3513       return Rec;
3514    end Expand_Protected_Object_Reference;
3515
3516    --------------------------------------
3517    -- Expand_Protected_Subprogram_Call --
3518    --------------------------------------
3519
3520    procedure Expand_Protected_Subprogram_Call
3521      (N    : Node_Id;
3522       Subp : Entity_Id;
3523       Scop : Entity_Id)
3524    is
3525       Rec   : Node_Id;
3526
3527    begin
3528       --  If the protected object is not an enclosing scope, this is
3529       --  an inter-object function call. Inter-object procedure
3530       --  calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
3531       --  The call is intra-object only if the subprogram being
3532       --  called is in the protected body being compiled, and if the
3533       --  protected object in the call is statically the enclosing type.
3534       --  The object may be an component of some other data structure,
3535       --  in which case this must be handled as an inter-object call.
3536
3537       if not In_Open_Scopes (Scop)
3538         or else not Is_Entity_Name (Name (N))
3539       then
3540          if Nkind (Name (N)) = N_Selected_Component then
3541             Rec := Prefix (Name (N));
3542
3543          else
3544             pragma Assert (Nkind (Name (N)) = N_Indexed_Component);
3545             Rec := Prefix (Prefix (Name (N)));
3546          end if;
3547
3548          Build_Protected_Subprogram_Call (N,
3549            Name => New_Occurrence_Of (Subp, Sloc (N)),
3550            Rec =>  Convert_Concurrent (Rec, Etype (Rec)),
3551            External => True);
3552
3553       else
3554          Rec := Expand_Protected_Object_Reference (N, Scop);
3555
3556          if No (Rec) then
3557             return;
3558          end if;
3559
3560          Build_Protected_Subprogram_Call (N,
3561            Name     => Name (N),
3562            Rec      => Rec,
3563            External => False);
3564
3565       end if;
3566
3567       Analyze (N);
3568
3569       --  If it is a function call it can appear in elaboration code and
3570       --  the called entity must be frozen here.
3571
3572       if Ekind (Subp) = E_Function then
3573          Freeze_Expression (Name (N));
3574       end if;
3575    end Expand_Protected_Subprogram_Call;
3576
3577    -----------------------
3578    -- Freeze_Subprogram --
3579    -----------------------
3580
3581    procedure Freeze_Subprogram (N : Node_Id) is
3582       E : constant Entity_Id := Entity (N);
3583
3584    begin
3585       --  When a primitive is frozen, enter its name in the corresponding
3586       --  dispatch table. If the DTC_Entity field is not set this is an
3587       --  overridden primitive that can be ignored. We suppress the
3588       --  initialization of the dispatch table entry when Java_VM because
3589       --  the dispatching mechanism is handled internally by the JVM.
3590
3591       if Is_Dispatching_Operation (E)
3592         and then not Is_Abstract (E)
3593         and then Present (DTC_Entity (E))
3594         and then not Is_CPP_Class (Scope (DTC_Entity (E)))
3595         and then not Java_VM
3596       then
3597          Check_Overriding_Operation (E);
3598          Insert_After (N, Fill_DT_Entry (Sloc (N), E));
3599       end if;
3600
3601       --  Mark functions that return by reference. Note that it cannot be
3602       --  part of the normal semantic analysis of the spec since the
3603       --  underlying returned type may not be known yet (for private types)
3604
3605       declare
3606          Typ  : constant Entity_Id := Etype (E);
3607          Utyp : constant Entity_Id := Underlying_Type (Typ);
3608
3609       begin
3610          if Is_Return_By_Reference_Type (Typ) then
3611             Set_Returns_By_Ref (E);
3612
3613          elsif Present (Utyp) and then Controlled_Type (Utyp) then
3614             Set_Returns_By_Ref (E);
3615          end if;
3616       end;
3617    end Freeze_Subprogram;
3618
3619 end Exp_Ch6;