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