gcc/ada/exp_ch6.adb

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