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