gcc/ada/exp_ch6.adb

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